syntax-if.mes: TODO.
authorJan Nieuwenhuizen <janneke@gnu.org>
Wed, 27 Jul 2016 10:16:44 +0000 (12:16 +0200)
committerJan Nieuwenhuizen <janneke@gnu.org>
Wed, 27 Jul 2016 10:16:44 +0000 (12:16 +0200)
GNUmakefile
syntax-cond.mes [new file with mode: 0644]
syntax-if.mes [new file with mode: 0644]
syntax.mes [deleted file]

index 33ea193d823524a0cba0023c092b2c9fbe1b8323..bb38f22fb76123b416c9f390d09b799b0006fc64 100644 (file)
@@ -70,18 +70,18 @@ psyntax: all
        cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes psyntax.mes psyntax.pp psyntax2.mes | ./mes
 
 syntax: all
-       cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes scm.mes syntax.mes syntax-test.mes | ./mes
+       cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes scm.mes syntax-cond.mes syntax-test.mes | ./mes
 
-syntax.test: syntax.mes syntax-test.mes
+syntax.test: syntax-cond.mes syntax-test.mes
        cat $^ > $@
 
 guile-syntax: syntax.test
        guile -s $^
 
 syntax-case: all
-       cat scm.mes syntax.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes syntax-case-test.mes | ./mes
+       cat scm.mes syntax-cond.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes syntax-case-test.mes | ./mes
 
-syntax-case.test: syntax.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes syntax-case-test.mes
+syntax-case.test: syntax-cond.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes syntax-case-test.mes
        cat $^ > $@
 
 guile-syntax-case: syntax-case.test
@@ -91,7 +91,7 @@ macro: all
        cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes scm.mes macro.mes | ./mes
 
 peg: all
-       cat scm.mes syntax.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes peg.mes peg/codegen.scm peg/string-peg.scm peg/simplify-tree.scm peg/using-parsers.scm peg/cache.scm peg-test.mes | ./mes
+       cat scm.mes syntax-cond.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes peg.mes peg/codegen.scm peg/string-peg.scm peg/simplify-tree.scm peg/using-parsers.scm peg/cache.scm peg-test.mes | ./mes
 
 peg.test: peg/pmatch.scm peg.mes peg/codegen.scm peg/string-peg.scm peg/simplify-tree.scm peg/using-parsers.scm peg/cache.scm peg-test.mes
        cat $^ | sed 's,\(;; Packages the results of a parser\),(when (guile?) (set! compile-peg-pattern (@@ (ice-9 peg codegen) compile-peg-pattern)))\n\1,' > $@
@@ -105,11 +105,11 @@ clean:
        rm -f mes environment.i mes.h peg.test syntax.test
 
 record: all
-       cat scm.mes syntax.mes lib/record.mes lib/record.scm lib/srfi/srfi-9.scm record.mes |./mes
+       cat scm.mes syntax-cond.mes lib/record.mes lib/record.scm lib/srfi/srfi-9.scm record.mes |./mes
 
 
 paren: all
-       echo -e 'EOF\n___P((()))' | cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes scm.mes syntax.mes lib/srfi/srfi-0.scm lib/record.mes lib/record.scm lib/srfi/srfi-9.scm lib/lalr.mes lib/lalr.scm paren.scm - | ./mes
+       echo -e 'EOF\n___P((()))' | cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes scm.mes syntax-cond.mes lib/srfi/srfi-0.scm lib/record.mes lib/record.scm lib/srfi/srfi-9.scm lib/lalr.mes lib/lalr.scm paren.scm - | ./mes
 
 paren.test: lib/lalr.scm paren.scm
        cat $^ > $@
@@ -118,7 +118,7 @@ guile-paren: paren.test
        echo '___P((()))' | guile -s $^ 
 
 mescc: all
-       echo ' EOF ' | cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes scm.mes syntax.mes lib/srfi/srfi-0.scm lib/record.mes lib/record.scm lib/srfi/srfi-9.scm lib/lalr.mes lib/lalr.scm c-lexer.scm mescc.scm - main.c | ./mes
+       echo ' EOF ' | cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes scm.mes syntax-cond.mes lib/srfi/srfi-0.scm lib/record.mes lib/record.scm lib/srfi/srfi-9.scm lib/lalr.mes lib/lalr.scm c-lexer.scm mescc.scm - main.c | ./mes
 
 mescc.test: lib/lalr.scm c-lexer.scm mescc.scm
        cat $^ > $@
diff --git a/syntax-cond.mes b/syntax-cond.mes
new file mode 100644 (file)
index 0000000..3baa811
--- /dev/null
@@ -0,0 +1,241 @@
+;; -*-scheme-*-
+
+(define (syntax-error message thing)
+  (display "syntax-error:")
+  (display message)
+  (display ":")
+  (display thing)
+  (newline))
+
+;;; Adapted from scheme48-1.1/scheme/alt/syntax.scm
+
+;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+;;; scheme48-1.1/COPYING
+
+;; Copyright (c) 1993-2004 Richard Kelsey and Jonathan Rees
+;; All rights reserved.
+
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;; 1. Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 2. Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;; 3. The name of the authors may not be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+
+;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
+;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+
+(define-macro (define-syntax macro-name transformer . stuff)
+  `(define-macro (,macro-name . args)
+     (,transformer (cons ',macro-name args)
+                             (lambda (x) x)
+                             eq?)))
+
+;; Rewrite-rule compiler (a.k.a. "extend-syntax")
+
+;; Example:
+;;
+;; (define-syntax or
+;;   (syntax-rules ()
+;;     ((or) #f)
+;;     ((or e) e)
+;;     ((or e1 e ...) (let ((temp e1))
+;;                    (if temp temp (or e ...))))))
+
+(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)
+          (cond ((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)
+               (cond ((member pattern subkeywords)
+                      `((,%compare ,input (,%rename ',pattern))))
+                     (#t `())))
+              ((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)))
+          (cond ((null? conjuncts)
+                 `((list? ,input)))     ;+++
+                (#t `((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)
+               (cond ((memq pattern subkeywords)
+                      '())
+                     (#t
+                      (list (list pattern (mapit path))))))
+              ((segment-pattern? pattern)
+               (process-pattern (car pattern)
+                                %temp
+                                (lambda (x) ;temp is free in x
+                                  (mapit (cond ((eq? %temp x)
+                                                path) ;+++
+                                               (#t
+                                                `(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)))
+                 (cond (probe
+                        (cond ((<= (cdr probe) rank)
+                               template)
+                              (#t (syntax-error "template rank error (too few ...'s?)"
+                                                template))))
+                       (#t `(,%rename ',template)))))
+              ((segment-template? template)
+               (let ((vars
+                      (free-meta-variables (car template) (+ rank 1) env '())))
+                 (cond ((null? vars)
+                        (syntax-error "too many ...'s" template))
+                       (#t (let* ((x (process-template (car template)
+                                                       (+ rank 1)
+                                                       env))
+                                  (gen (cond ((equal? (list x) vars)
+                                              x) ;+++
+                                             (#t `(map (lambda ,vars ,x)
+                                                       ,@vars)))))
+                             (cond ((null? (cddr template))
+                                    gen) ;+++
+                                   (else
+                                    `(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)
+               (cond ((memq pattern subkeywords)
+                      vars)
+                     (else (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)
+               (cond ((and (not (memq template free))
+                           (let ((probe (assq template env)))
+                             (and probe (>= (cdr probe) rank))))
+                      (cons template free))
+                     (else 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-macro (define-syntax-rule id-pattern . template)
+  `(define-syntax ,(car id-pattern)
+     (syntax-rules ()
+       ((,(car id-pattern) . ,(cdr id-pattern)) ,@template))))
diff --git a/syntax-if.mes b/syntax-if.mes
new file mode 100644 (file)
index 0000000..9a50b67
--- /dev/null
@@ -0,0 +1,238 @@
+;; -*-scheme-*-
+
+(define (syntax-error message thing)
+  (display "syntax-error:")
+  (display message)
+  (display ":")
+  (display thing)
+  (newline))
+
+;;; Adapted from scheme48-1.1/scheme/alt/syntax.scm
+
+;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+;;; scheme48-1.1/COPYING
+
+;; Copyright (c) 1993-2004 Richard Kelsey and Jonathan Rees
+;; All rights reserved.
+
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;; 1. Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 2. Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;; 3. The name of the authors may not be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+
+;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
+;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+
+(define-macro (define-syntax macro-name transformer . stuff)
+  `(define-macro (,macro-name . args)
+     (,transformer (cons ',macro-name args)
+                             (lambda (x) x)
+                             eq?)))
+
+;; Rewrite-rule compiler (a.k.a. "extend-syntax")
+
+;; Example:
+;;
+;; (define-syntax or
+;;   (syntax-rules ()
+;;     ((or) #f)
+;;     ((or e) e)
+;;     ((or e1 e ...) (let ((temp e1))
+;;                    (if temp temp (or e ...))))))
+
+(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-macro (define-syntax-rule id-pattern . template)
+  `(define-syntax ,(car id-pattern)
+     (syntax-rules ()
+       ((,(car id-pattern) . ,(cdr id-pattern)) ,@template))))
diff --git a/syntax.mes b/syntax.mes
deleted file mode 100644 (file)
index 3baa811..0000000
+++ /dev/null
@@ -1,241 +0,0 @@
-;; -*-scheme-*-
-
-(define (syntax-error message thing)
-  (display "syntax-error:")
-  (display message)
-  (display ":")
-  (display thing)
-  (newline))
-
-;;; Adapted from scheme48-1.1/scheme/alt/syntax.scm
-
-;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-;;; scheme48-1.1/COPYING
-
-;; Copyright (c) 1993-2004 Richard Kelsey and Jonathan Rees
-;; All rights reserved.
-
-;; Redistribution and use in source and binary forms, with or without
-;; modification, are permitted provided that the following conditions
-;; are met:
-;; 1. Redistributions of source code must retain the above copyright
-;;    notice, this list of conditions and the following disclaimer.
-;; 2. Redistributions in binary form must reproduce the above copyright
-;;    notice, this list of conditions and the following disclaimer in the
-;;    documentation and/or other materials provided with the distribution.
-;; 3. The name of the authors may not be used to endorse or promote products
-;;    derived from this software without specific prior written permission.
-
-;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
-;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
-;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
-;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
-;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
-;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
-;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-
-(define-macro (define-syntax macro-name transformer . stuff)
-  `(define-macro (,macro-name . args)
-     (,transformer (cons ',macro-name args)
-                             (lambda (x) x)
-                             eq?)))
-
-;; Rewrite-rule compiler (a.k.a. "extend-syntax")
-
-;; Example:
-;;
-;; (define-syntax or
-;;   (syntax-rules ()
-;;     ((or) #f)
-;;     ((or e) e)
-;;     ((or e1 e ...) (let ((temp e1))
-;;                    (if temp temp (or e ...))))))
-
-(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)
-          (cond ((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)
-               (cond ((member pattern subkeywords)
-                      `((,%compare ,input (,%rename ',pattern))))
-                     (#t `())))
-              ((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)))
-          (cond ((null? conjuncts)
-                 `((list? ,input)))     ;+++
-                (#t `((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)
-               (cond ((memq pattern subkeywords)
-                      '())
-                     (#t
-                      (list (list pattern (mapit path))))))
-              ((segment-pattern? pattern)
-               (process-pattern (car pattern)
-                                %temp
-                                (lambda (x) ;temp is free in x
-                                  (mapit (cond ((eq? %temp x)
-                                                path) ;+++
-                                               (#t
-                                                `(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)))
-                 (cond (probe
-                        (cond ((<= (cdr probe) rank)
-                               template)
-                              (#t (syntax-error "template rank error (too few ...'s?)"
-                                                template))))
-                       (#t `(,%rename ',template)))))
-              ((segment-template? template)
-               (let ((vars
-                      (free-meta-variables (car template) (+ rank 1) env '())))
-                 (cond ((null? vars)
-                        (syntax-error "too many ...'s" template))
-                       (#t (let* ((x (process-template (car template)
-                                                       (+ rank 1)
-                                                       env))
-                                  (gen (cond ((equal? (list x) vars)
-                                              x) ;+++
-                                             (#t `(map (lambda ,vars ,x)
-                                                       ,@vars)))))
-                             (cond ((null? (cddr template))
-                                    gen) ;+++
-                                   (else
-                                    `(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)
-               (cond ((memq pattern subkeywords)
-                      vars)
-                     (else (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)
-               (cond ((and (not (memq template free))
-                           (let ((probe (assq template env)))
-                             (and probe (>= (cdr probe) rank))))
-                      (cons template free))
-                     (else 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-macro (define-syntax-rule id-pattern . template)
-  `(define-syntax ,(car id-pattern)
-     (syntax-rules ()
-       ((,(car id-pattern) . ,(cdr id-pattern)) ,@template))))