From 21a5e16a8846e111344df5dd837e77e2ce8eb48c Mon Sep 17 00:00:00 2001
From: Jan Nieuwenhuizen <janneke@gnu.org>
Date: Sat, 16 Jul 2016 21:53:32 +0200
Subject: [PATCH] define-syntax...

---
 syntax.mes | 397 +++++++++++++++++++++++++++++++++--------------------
 1 file changed, 247 insertions(+), 150 deletions(-)

diff --git a/syntax.mes b/syntax.mes
index a2f4c57d..67580c24 100644
--- a/syntax.mes
+++ b/syntax.mes
@@ -1,22 +1,100 @@
+(define else #t)
+(define (syntax-error message thing)
+  (display "syntax-error:")
+  (display message)
+  (display ":")
+  ;;(display thing)
+  (newline))
 
 (display "define-syntax...")
 
-(define-macro define-syntax
-  (lambda (form expander)
-    (expander `(define-macro ,(cadr form)
-                 (let ((transformer ,(caddr form)))
-                   (lambda (form expander)
-                     (expander (transformer form
-                                            (lambda (x) x)
-                                            eq?)
-                               expander))))
-              expander)))
+;;(define (caddr x) (car (cdr (cdr x))))
+;; (define (caddr x)
+;;   (display "wanna caddr:")
+;;   (display x)
+;;   (newline))
+
+;; (define-macro define-syntax
+;;   (lambda (form expander)
+;;      (expander `(define-macro ,(cadr form)
+;;                   (let ((transformer ,(caddr form)))
+;;                     (lambda (form expander)
+;;                       (expander (transformer form
+;;                                              (lambda (x) x)
+;;                                              eq?)
+;;                                 expander))))
+;;                expander)))
+
+;; (define (dinges form expander)
+;;   (display "dinges form:")
+;;   (display form)
+;;   (newline)
+;;   `(define-macro BOO ;;;,(cadr form)
+;;      (let ((transformer ,(caddr form)))
+;;        (lambda (form expander)
+;;          (expander (transformer form
+;;                                 (lambda (x) x)
+;;                                 eq?)
+;;                    expander)))))
+
+;; (define-macro (define-syntax form expander)
+;;   `(expander (dinges form expander)
+;;              expander))
+
+(define-macro (define-syntax macro-name transformer . stuff)
+  ;; (display "define-syntax:")
+  ;; (newline)
+  ;; (display   `(define-macro (,macro-name . args)
+  ;;    (,transformer (cons ',macro-name args)
+  ;;                  (lambda (x) x)
+  ;;                  eq?)))
+  ;; (newline)
+  `(define-macro (,macro-name . args)
+     (
+      ,transformer (cons ',macro-name args)
+                   (lambda (x) x)
+                   eq?
+                   )
+     )
+  )
+
+;; (define-macro (define-syntax form expander)
+;;   (expander `(define-macro ,(cadr form)
+;;                (let ((transformer ,(caddr form)))
+;;                  (lambda (form expander)
+;;                    (expander (transformer form
+;;                                           (lambda (x) x)
+;;                                           eq?)
+;;                              expander))))
+;;             expander))
+
+;; (define-macro (define-syntax form expander)
+;;   (expander `(define-macro ((cadr form) form expander) 
+;;                (let ((transformer (caddr form)))
+;;                  (expander (transformer form
+;;                                         (lambda (x) x)
+;;                                         eq?)
+;;                            expander)))
+;;             expander))
 
 (newline)
 
 
-(display "define-syntax when...")
+(display "define-syntax syntax-rules...")
+(newline)
+;; (define-macro (syntax-rules exp r c))
 
+;; (define-syntax syntax-rules
+;;   (let ()
+;;     (lambda (exp r c)
+;;       (display "hallo")
+;;       (display "newline"))))
+
+
+;; (define-syntax syntax-rules
+;;   (lambda (exp r c)
+;;     (display "hallo")
+;;     (display "newline")))
 
 (define-syntax syntax-rules
   (let ()
@@ -25,16 +103,16 @@
 
     (define (segment-pattern? pattern)
       (and (segment-template? pattern)
-	   (or (null? (cddr pattern))
-	       (syntax-error "segment matching not implemented" 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)))
+           (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.
@@ -46,163 +124,179 @@
       (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 (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)))
+      (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
+      ;; 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-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)))))))))
+      (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).
+      ;; 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 '())))
+      (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
+      ;; 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))))
+      (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)
+                                        ; 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)))
+      (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
+                                        ; 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)))
+      (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
+      ;;c ;ignored
 
-  ;; Kludge for Scheme48 linker.
-  ;; `(cons ,(make-transformer rules)
-  ;;          ',(find-free-names-in-syntax-rules subkeywords rules))
+      ;; Kludge for Scheme48 linker.
+      ;; `(cons ,(make-transformer rules)
+      ;;          ',(find-free-names-in-syntax-rules subkeywords rules))
 
-  (make-transformer rules))))
+      (make-transformer rules))))
 
 
+;; (define-syntax or
+;;   (syntax-rules ()
+;;     ((or) #f)
+;;     ((or e) e)
+;;     ((or e1 e ...) (let ((temp e1))
+;;                   (if temp temp (or e ...))))))
 
-;; (define-syntax when
+;; (define-syntax xwhen
 ;;   (syntax-rules ()
 ;;     ((when condition exp ...)
 ;;      (if condition
 ;;          (begin exp ...)))))
 
+;; (display "define-when: ")
+;; (display 
+;;  (define-syntax xwhen
+;;    (syntax-rules ()
+;;      ((when condition exp ...)
+;;       (if condition
+;;           (begin exp ...))))))
+;; (newline)
+;; (display (xwhen #t "hello syntax world"))
+
 ;; (define-macro (when cond exp . rest)
 ;;   `(if ,cond
 ;;        (begin ,exp . ,rest)))
@@ -211,3 +305,6 @@
 ;; (define-macro (when clause . rest)
 ;;   (list 'cond (list clause (list 'let '() rest))))
 (newline)
+'boo
+EOF
+'()