syntax...

GNUmakefile

@@ -44,3 +44,6 @@ boot: all
 
 run: all
 	cat scm.mes test.mes | ./mes
+
+syntax: all
+	cat scm.mes syntax.mes | ./mes

syntax.mes

@@ -1,21 +1,202 @@
 
-;; (display "define-syntax...")
+(display "define-syntax...")
 
-;; (define-macro define-syntax
+(define-macro define-syntax
-;;   (lambda (form expander)
+  (lambda (form expander)
-;;     (expander `(define-macro ,(cadr form)
+    (expander `(define-macro ,(cadr form)
-;;                  (let ((transformer ,(caddr form)))
+                 (let ((transformer ,(caddr form)))
-;;                    (lambda (form expander)
+                   (lambda (form expander)
-;;                      (expander (transformer form
+                     (expander (transformer form
-;;                                             (lambda (x) x)
+                                            (lambda (x) x)
-;;                                             eq?)
+                                            eq?)
-;;                                expander))))
+                               expander))))
-;;               expander)))
+              expander)))
+
+(newline)
 
-;; (newline)
 
 (display "define-syntax when...")
 
+
+(define-syntax syntax-rules
+  (let ()
+
+    (define name? symbol?)
+
+    (define (segment-pattern? pattern)
+      (and (segment-template? pattern)
+	   (or (null? (cddr pattern))
+	       (syntax-error "segment matching not implemented" pattern))))
+
+    (define (segment-template? pattern)
+      (and (pair? pattern)
+	   (pair? (cdr pattern))
+	   (memq (cadr pattern) indicators-for-zero-or-more)))
+
+    (define indicators-for-zero-or-more (list (string->symbol "...") '---))
+
+    (lambda (exp r c)
+
+      (define %input (r '%input))     ;Gensym these, if you like.
+      (define %compare (r '%compare))
+      (define %rename (r '%rename))
+      (define %tail (r '%tail))
+      (define %temp (r '%temp))
+
+      (define rules (cddr exp))
+      (define subkeywords (cadr exp))
+
+  (define (make-transformer rules)
+    `(lambda (,%input ,%rename ,%compare)
+       (let ((,%tail (cdr ,%input)))
+	 (cond ,@(map process-rule rules)
+		 (else
+		  (syntax-error
+		   "use of macro doesn't match definition"
+		   ,%input))))))
+
+  (define (process-rule rule)
+    (if (and (pair? rule)
+	     (pair? (cdr rule))
+	     (null? (cddr rule)))
+	(let ((pattern (cdar rule))
+	      (template (cadr rule)))
+	  `((and ,@(process-match %tail pattern))
+	    (let* ,(process-pattern pattern
+				      %tail
+				      (lambda (x) x))
+		    ,(process-template template
+				       0
+				       (meta-variables pattern 0 '())))))
+	(syntax-error "ill-formed syntax rule" rule)))
+
+  ; Generate code to test whether input expression matches pattern
+
+  (define (process-match input pattern)
+    (cond ((name? pattern)
+	   (if (member pattern subkeywords)
+	       `((,%compare ,input (,%rename ',pattern)))
+	       `()))
+	  ((segment-pattern? pattern)
+	   (process-segment-match input (car pattern)))
+	  ((pair? pattern)
+	   `((let ((,%temp ,input))
+	       (and (pair? ,%temp)
+		    ,@(process-match `(car ,%temp) (car pattern))
+		    ,@(process-match `(cdr ,%temp) (cdr pattern))))))
+	  ((or (null? pattern) (boolean? pattern) (char? pattern))
+	   `((eq? ,input ',pattern)))
+	  (else
+	   `((equal? ,input ',pattern)))))
+
+  (define (process-segment-match input pattern)
+    (let ((conjuncts (process-match '(car l) pattern)))
+      (if (null? conjuncts)
+	  `((list? ,input))			;+++
+	  `((let loop ((l ,input))
+	      (or (null? l)
+		  (and (pair? l)
+		       ,@conjuncts
+		       (loop (cdr l)))))))))
+
+  ; Generate code to take apart the input expression
+  ; This is pretty bad, but it seems to work (can't say why).
+
+  (define (process-pattern pattern path mapit)
+    (cond ((name? pattern)
+	   (if (memq pattern subkeywords)
+	       '()
+	       (list (list pattern (mapit path)))))
+	  ((segment-pattern? pattern)
+	   (process-pattern (car pattern)
+			    %temp
+			    (lambda (x)	;temp is free in x
+			      (mapit (if (eq? %temp x)
+					 path ;+++
+					 `(map (lambda (,%temp) ,x)
+						 ,path))))))
+	  ((pair? pattern)
+	   (append (process-pattern (car pattern) `(car ,path) mapit)
+		   (process-pattern (cdr pattern) `(cdr ,path) mapit)))
+	  (else '())))
+
+  ; Generate code to compose the output expression according to template
+
+  (define (process-template template rank env)
+    (cond ((name? template)
+	   (let ((probe (assq template env)))
+	     (if probe
+		 (if (<= (cdr probe) rank)
+		     template
+		     (syntax-error "template rank error (too few ...'s?)"
+				   template))
+		 `(,%rename ',template))))
+	  ((segment-template? template)
+	   (let ((vars
+		  (free-meta-variables (car template) (+ rank 1) env '())))
+	     (if (null? vars)
+		 (syntax-error "too many ...'s" template)
+		 (let* ((x (process-template (car template)
+					     (+ rank 1)
+					     env))
+			(gen (if (equal? (list x) vars)
+				 x	;+++
+				 `(map (lambda ,vars ,x)
+					 ,@vars))))
+		   (if (null? (cddr template))
+		       gen		;+++
+		       `(append ,gen ,(process-template (cddr template)
+							  rank env)))))))
+	  ((pair? template)
+	   `(cons ,(process-template (car template) rank env)
+		    ,(process-template (cdr template) rank env)))
+	  (else `(quote ,template))))
+
+  ; Return an association list of (var . rank)
+
+  (define (meta-variables pattern rank vars)
+    (cond ((name? pattern)
+	   (if (memq pattern subkeywords)
+	       vars
+	       (cons (cons pattern rank) vars)))
+	  ((segment-pattern? pattern)
+	   (meta-variables (car pattern) (+ rank 1) vars))
+	  ((pair? pattern)
+	   (meta-variables (car pattern) rank
+			   (meta-variables (cdr pattern) rank vars)))
+	  (else vars)))
+
+  ; Return a list of meta-variables of given higher rank
+
+  (define (free-meta-variables template rank env free)
+    (cond ((name? template)
+	   (if (and (not (memq template free))
+		    (let ((probe (assq template env)))
+		      (and probe (>= (cdr probe) rank))))
+	       (cons template free)
+	       free))
+	  ((segment-template? template)
+	   (free-meta-variables (car template)
+				rank env
+				(free-meta-variables (cddr template)
+						     rank env free)))
+	  ((pair? template)
+	   (free-meta-variables (car template)
+				rank env
+				(free-meta-variables (cdr template)
+						     rank env free)))
+	  (else free)))
+
+  c ;ignored
+
+  ;; Kludge for Scheme48 linker.
+  ;; `(cons ,(make-transformer rules)
+  ;;          ',(find-free-names-in-syntax-rules subkeywords rules))
+
+  (make-transformer rules))))
+
+
+
 ;; (define-syntax when
 ;;   (syntax-rules ()
 ;;     ((when condition exp ...)
@@ -29,27 +210,4 @@
 
 ;; (define-macro (when clause . rest)
 ;;   (list 'cond (list clause (list 'let '() rest))))
-
-
-(define-macro (when expr . body)
-  `(if ,expr
-       ((lambda () ,@body))
-       'bah))
-
-(newline)
-
-(when #t
-  (display "true")
-  (newline))
-
-(when #t
-  (display "q-when")
-  (newline)
-  '())
-
-(define *gensym* 0)
-(define (gensym)
-  (set! *gensym* (+ *gensym* 1))
-  (string->symbol (string-append "g" (number->string *gensym*))))
-
 (newline)