From 4dfff28892240095f1ef2655d04ef840e7c36027 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 21 Mar 2018 00:40:16 -0700
Subject: [PATCH] Implement pattern language to make spars more terse.

---
 src/runtime/mit-macros.scm    | 128 +++++++++++++++++-----------------
 src/runtime/runtime.pkg       |   2 +
 src/runtime/syntax-parser.scm | 127 ++++++++++++++++++++++++++++++++-
 3 files changed, 193 insertions(+), 64 deletions(-)

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index 0062502ef..bf900b940 100644
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -147,59 +147,65 @@ USA.
   (spar-transformer->runtime
    (delay
      (spar-call-with-values
-	 (lambda (close identifiers expr . body-forms)
+	 (lambda (close bvl expr . body-forms)
 	   (let ((r-cwv (close 'call-with-values))
 		 (r-lambda (close 'lambda)))
 	     `(,r-cwv (,r-lambda () ,expr)
-		      (,r-lambda (,@identifiers) ,@body-forms))))
-       (spar-elt)
-       (spar-push spar-arg:close)
-       (spar-push-elt-if r4rs-lambda-list? spar-arg:form)
-       (spar-push-elt spar-arg:form)
-       (spar+ (spar-push-elt spar-arg:form))
-       (spar-match-null)))
+		      (,r-lambda ,bvl ,@body-forms))))
+       (pattern->spar '(ignore (push close) r4rs-bvl expr (+ form)))))
    system-global-environment))
 
-(define-syntax :define-record-type
-  (er-macro-transformer
-   (lambda (form rename compare)
-     compare				;ignore
-     (if (syntax-match? '((or identifier
-			      (identifier expression))
-			  (identifier * identifier)
-			  identifier
-			  * (identifier identifier ? identifier))
-			(cdr form))
-	 (let ((type-spec (cadr form))
-	       (constructor (car (caddr form)))
-	       (c-tags (cdr (caddr form)))
-	       (predicate (cadddr form))
-	       (fields (cddddr form))
-	       (de (rename 'define)))
-	   (let ((type (if (pair? type-spec) (car type-spec) type-spec)))
-	     `(,(rename 'begin)
-	       (,de ,type
-		    (,(rename 'new-make-record-type)
-		     ',type
-		     ',(map car fields)
-		     ,@(if (pair? type-spec)
-			   (list (cadr type-spec))
-			   '())))
-	       (,de ,constructor (,(rename 'record-constructor) ,type ',c-tags))
-	       (,de ,predicate (,(rename 'record-predicate) ,type))
-	       ,@(append-map
-		  (lambda (field)
-		    (let ((name (car field)))
-		      (cons `(,de ,(cadr field)
-				  (,(rename 'record-accessor) ,type ',name))
-			    (if (pair? (cddr field))
-				`((,de ,(caddr field)
-				       (,(rename 'record-modifier)
-					,type ',name)))
-				'()))))
-		  fields))))
-	 (ill-formed-syntax form)))))
-
+(define :define-record-type
+  (spar-transformer->runtime
+   (delay
+     (spar-call-with-values
+	 (lambda (close type-name parent maker-name maker-args pred-name
+			field-specs)
+	   (let ((beg (close 'begin))
+		 (de (close 'define))
+		 (mrt (close 'new-make-record-type))
+		 (rc (close 'record-constructor))
+		 (rp (close 'record-predicate))
+		 (ra (close 'record-accessor))
+		 (rm (close 'record-modifier)))
+	     `(,beg
+	       (,de ,type-name
+		    (,mrt ',type-name
+			  ',(map car field-specs)
+			  ,@(if parent
+				(list parent)
+				'())))
+	       ,@(if maker-name
+		     `((,de ,maker-name
+			    (,rc ,type-name
+				 ,@(if maker-args
+				       (list `',maker-args)
+				       '()))))
+		     '())
+	       ,@(if pred-name
+		     `((,de ,pred-name (,rp ,type-name)))
+		     '())
+	       ,@(append-map (lambda (field)
+			       (let ((field-name (car field)))
+				 `((,de ,(cadr field)
+					(,ra ,type-name ',field-name))
+				   ,@(if (caddr field)
+					 `((,de ,(caddr field)
+						(,rm ,type-name ',field-name)))
+					 '()))))
+			     field-specs))))
+       (pattern->spar
+	'(ignore (push close)
+		 (or (seq id (push #f))
+		     (elt id expr))
+		 (or (seq '#f (push #f #f))
+		     (seq id (push #f))
+		     (elt id (list (* symbol))))
+		 (or (seq '#f (push #f))
+		     id)
+		 (list (* (list (elt symbol id (or id (push #f))))))))))
+   system-global-environment))
+
 (define-syntax :define
   (er-macro-transformer
    (lambda (form rename compare)
@@ -236,21 +242,17 @@ USA.
 		    (,scode-lambda-name:let ,@ids)
 		    ,@body-forms)
 		   ,@vals))))
-       (spar-elt)
-       (spar-push spar-arg:close)
-       (spar-or (spar-push-elt-if identifier? spar-arg:form)
-		(spar-push '#f))
-       (spar-elt
-	 (spar-call-with-values list
-	  (spar* (spar-elt
-		   (spar-call-with-values cons
-		     (spar-push-elt-if identifier? spar-arg:form)
-		     (spar-or (spar-push-elt spar-arg:form)
-			      (spar-push-value unassigned-expression)))
-		   (spar-match-null)))
-	  (spar-match-null)))
-       (spar+ (spar-push-elt spar-arg:form))
-       (spar-match-null)))
+       (pattern->spar
+	`(ignore (push close)
+		 (or id (push #f))
+		 (elt
+		  (list
+		   (*
+		    (elt
+		     (cons id
+			   (or expr
+			       (push-value ,unassigned-expression)))))))
+		 (+ form)))))
    system-global-environment))
 
 (define named-let-strategy 'internal-definition)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 426f86d42..2856084f9 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4547,6 +4547,8 @@ USA.
   (files "syntax-parser")
   (parent (runtime syntax))
   (export ()
+	  pattern->spar
+	  pattern->spar-expr
 	  spar*
 	  spar+
 	  spar-append-map-values
diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm
index ff5ef9ac7..d0c0b0370 100644
--- a/src/runtime/syntax-parser.scm
+++ b/src/runtime/syntax-parser.scm
@@ -437,4 +437,129 @@ USA.
 			    elts))))
       (spar+ (spar-elt spar-push-open-classified))
       (spar-match-null))
-    (spar-push spar-arg:senv)))
\ No newline at end of file
+    (spar-push spar-arg:senv)))
+
+;;;; Shorthand
+
+(define (make-pattern-compiler expr? caller)
+  (call-with-constructors expr?
+    (lambda (:* :+ :call :close :cons :elt :eqv? :form :hist :identifier? :list
+		:match-elt :match-null :mit-bvl? :opt :or :push :push-elt
+		:push-elt-if :push-value :r4rs-bvl? :senv :seq :symbol? :value)
+
+      (define (loop pattern)
+	(cond ((symbol? pattern)
+	       (case pattern
+		 ((symbol) (:push-elt-if (:symbol?) (:form)))
+		 ((identifier id) (:push-elt-if (:identifier?) (:form)))
+		 ((form expr) (:push-elt (:form)))
+		 ((r4rs-bvl) (:push-elt-if (:r4rs-bvl?) (:form)))
+		 ((mit-bvl) (:push-elt-if (:mit-bvl?) (:form)))
+		 ((ignore) (:elt))
+		 (else (bad-pattern pattern))))
+	      ((procedure? pattern)
+	       (:push-elt-if pattern (:form)))
+	      ((and (pair? pattern)
+		    (list? (cdr pattern)))
+	       (case (car pattern)
+		 ((*) (apply :* (map loop (cdr pattern))))
+		 ((+) (apply :+ (map loop (cdr pattern))))
+		 ((?) (apply :opt (map loop (cdr pattern))))
+		 ((or) (apply :or (map loop (cdr pattern))))
+		 ((seq) (apply :seq (map loop (cdr pattern))))
+		 ((quote)
+		  (if (not (and (pair? (cdr pattern))
+				(null? (cddr pattern))))
+		      (bad-pattern pattern))
+		  (:match-elt (:eqv?) (cadr pattern) (:form)))
+		 ((push) (apply :push (map convert-spar-arg (cdr pattern))))
+		 ((push-value)
+		  (apply :push-value
+			 (cadr pattern)
+			 (map convert-spar-arg (cddr pattern))))
+		 ((list) (apply :call (:list) (map loop (cdr pattern))))
+		 ((cons) (apply :call (:cons) (map loop (cdr pattern))))
+		 ((call) (apply :call (cadr pattern) (map loop (cddr pattern))))
+		 ((spar) (apply :seq (cdr pattern)))
+		 ((elt)
+		  (:elt (apply :seq (map loop (cdr pattern)))
+			(:match-null)))
+		 (else
+		  (bad-pattern pattern))))
+	      (else
+	       (bad-pattern pattern))))
+
+      (define (convert-spar-arg arg)
+	(case arg
+	  ((form) (:form))
+	  ((hist) (:hist))
+	  ((close) (:close))
+	  ((senv) (:senv))
+	  ((value) (:value))
+	  (else arg)))
+
+      (define (bad-pattern pattern)
+	(error:wrong-type-argument pattern "syntax-parser pattern" caller))
+
+      (lambda (pattern)
+	(if (not (list? pattern))
+	    (bad-pattern pattern))
+	(:seq (apply :seq (map loop pattern))
+	      (:match-null))))))
+
+(define (call-with-constructors expr? procedure)
+
+  (define (proc name procedure)
+    (if expr?
+	(lambda args (cons name args))
+	(lambda args (apply procedure args))))
+
+  (define (flat-proc name procedure)
+    (if expr?
+	(lambda args (cons name (elide-seqs args)))
+	(lambda args (apply procedure args))))
+
+  (define (elide-seqs exprs)
+    (append-map (lambda (expr)
+		  (if (and (pair? expr)
+			   (eq? 'spar-seq (car expr)))
+		      (cdr expr)
+		      (list expr)))
+		exprs))
+
+  (define (const name value)
+    (if expr?
+	(lambda () name)
+	(lambda () value)))
+
+  (procedure (flat-proc 'spar* spar*)
+	     (flat-proc 'spar+ spar+)
+	     (flat-proc 'spar-call-with-values spar-call-with-values)
+	     (const 'spar-arg:close spar-arg:close)
+	     (const 'cons cons)
+	     (flat-proc 'spar-elt spar-elt)
+	     (const 'eqv? eqv?)
+	     (const 'spar-arg:form spar-arg:form)
+	     (const 'spar-arg:hist spar-arg:hist)
+	     (const 'identifier? identifier?)
+	     (const 'list list)
+	     (proc 'spar-match-elt spar-match-elt)
+	     (proc 'spar-match-null spar-match-null)
+	     (const 'mit-lambda-list? mit-lambda-list?)
+	     (flat-proc 'spar-opt spar-opt)
+	     (proc 'spar-or spar-or)
+	     (proc 'spar-push spar-push)
+	     (proc 'spar-push-elt spar-push-elt)
+	     (proc 'spar-push-elt-if spar-push-elt-if)
+	     (proc 'spar-push-value spar-push-value)
+	     (const 'r4rs-lambda-list? r4rs-lambda-list?)
+	     (const 'spar-arg:senv spar-arg:senv)
+	     (flat-proc 'spar-seq spar-seq)
+	     (const 'symbol? symbol?)
+	     (const 'spar-arg:value spar-arg:value)))
+
+(define-deferred pattern->spar
+  (make-pattern-compiler #f 'pattern->spar))
+
+(define-deferred pattern->spar-expr
+  (make-pattern-compiler #t 'pattern->spar-expr))
\ No newline at end of file
-- 
2.25.1