use IF as primitive, drop using cond/evcon only option.
authorJan Nieuwenhuizen <janneke@gnu.org>
Sat, 8 Oct 2016 14:54:59 +0000 (16:54 +0200)
committerJan Nieuwenhuizen <janneke@gnu.org>
Sat, 8 Oct 2016 14:54:59 +0000 (16:54 +0200)
GNUmakefile
base.mes
base0-cond.mes [deleted file]
base0-if.mes
let.mes
mes.c
scm.mes
syntax-cond.mes [deleted file]
syntax-if.mes [deleted file]
syntax.mes [new file with mode: 0644]

index 4f0cfebeeac4bddbf7197763cfadcc1f0421948d..f88f4ec1839c5bb3662d9aef12090392f580e638 100644 (file)
@@ -2,15 +2,6 @@
 CFLAGS:=-std=c99 -O3 -finline-functions
 #CFLAGS:=-std=c99 -g
 
-COND:=0
-ifeq ($(COND),1)
-CONDIF:=cond
-else
-CONDIF:=if
-endif
-
-CFLAGS+=-DCOND=$(COND)
-
 default: all
 
 all: mes
@@ -48,11 +39,11 @@ check: all guile-check mes-check
 mes-check: all
 #      ./mes.test
 #      ./mes.test ./mes
-       cat base0.mes base0-$(CONDIF).mes base.mes lib/test.mes test/base.test | ./mes
-       cat base0.mes base0-$(CONDIF).mes base.mes lib/test.mes test/closure.test | ./mes
-       cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes lib/test.mes test/quasiquote.test | ./mes
-       cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes lib/test.mes test/let.test | ./mes
-       cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes lib/srfi/srfi-0.scm scm.mes lib/test.mes test/scm.test | ./mes
+       cat base0.mes base0-if.mes base.mes lib/test.mes test/base.test | ./mes
+       cat base0.mes base0-if.mes base.mes lib/test.mes test/closure.test | ./mes
+       cat base0.mes base0-if.mes base.mes quasiquote.mes lib/test.mes test/quasiquote.test | ./mes
+       cat base0.mes base0-if.mes base.mes quasiquote.mes let.mes lib/test.mes test/let.test | ./mes
+       cat base0.mes base0-if.mes base.mes quasiquote.mes let.mes lib/srfi/srfi-0.scm scm.mes lib/test.mes test/scm.test | ./mes
 
 guile-check:
        guile -s <(cat base.mes lib/test.mes test/base.test)
@@ -73,31 +64,31 @@ run: all
        cat scm.mes test.mes | ./mes
 
 psyntax: all
-       cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes psyntax.mes psyntax.pp psyntax2.mes | ./mes
+       cat base0.mes base0-if.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-cond.mes syntax-test.mes | ./mes
+       cat base0.mes base0-if.mes base.mes quasiquote.mes let.mes scm.mes syntax.mes syntax-test.mes | ./mes
 
-syntax.test: syntax-cond.mes syntax-test.mes
+syntax.test: syntax.mes syntax-test.mes
        cat $^ > $@
 
 guile-syntax: syntax.test
        guile -s $^
 
 syntax-case: all
-       cat scm.mes syntax-cond.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes syntax-case-test.mes | ./mes
+       cat scm.mes syntax.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes syntax-case-test.mes | ./mes
 
-syntax-case.test: syntax-cond.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes syntax-case-test.mes
+syntax-case.test: syntax.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes syntax-case-test.mes
        cat $^ > $@
 
 guile-syntax-case: syntax-case.test
        guile -s $^
 
 macro: all
-       cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes scm.mes macro.mes | ./mes
+       cat base0.mes base0-if.mes base.mes quasiquote.mes let.mes scm.mes macro.mes | ./mes
 
 peg: all
-       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
+       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
 
 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,' > $@
@@ -111,11 +102,11 @@ clean:
        rm -f mes environment.i mes.h peg.test syntax.test
 
 record: all
-       cat scm.mes syntax-cond.mes lib/record.mes lib/record.scm lib/srfi/srfi-9.scm record.mes |./mes
+       cat scm.mes syntax.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-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
+       echo -e 'EOF\n___P((()))' | cat base0.mes base0-if.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
 
 paren.test: lib/lalr.scm paren.scm
        cat $^ > $@
@@ -124,7 +115,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-cond.mes lib/srfi/srfi-0.scm lib/record.mes lib/record.scm lib/srfi/srfi-9.scm lib/lalr.mes lib/lalr.scm lib/rnrs/bytevectors.scm lib/srfi/srfi-1.scm lib/match.scm lib/elf.mes c-lexer.scm mescc.scm - main.c | ./mes > a.out
+       echo ' EOF ' | cat base0.mes base0-if.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 lib/rnrs/bytevectors.scm lib/srfi/srfi-1.scm lib/match.scm lib/elf.mes c-lexer.scm mescc.scm - main.c | ./mes > a.out
        chmod +x a.out
 
 mescc.test: lib/lalr.scm lib/rnrs/bytevectors.scm lib/srfi/srfi-1.scm lib/match.scm lib/elf.mes c-lexer.scm mescc.scm
@@ -142,5 +133,5 @@ hello: hello.o
 #      ld -A i386 -m elf_i386 -A i386 -o $@ $^
 
 a.out: lib/elf.mes elf.mes GNUmakefile
-       cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes scm.mes lib/rnrs/bytevectors.scm lib/elf.mes elf.mes | ./mes > a.out
+       cat base0.mes base0-if.mes base.mes quasiquote.mes let.mes scm.mes lib/rnrs/bytevectors.scm lib/elf.mes elf.mes | ./mes > a.out
        chmod +x a.out
index 31bcda13941d86b49faeb8318b7a8d1af18645db..7dbedea0b190309d2a94e35ba49d08332388955c 100644 (file)
--- a/base.mes
+++ b/base.mes
 (define (identity x) x)
 (define else #t)
 
-;;; COND based
-(define-macro (or . x)
-  (cond ;; COND
-   ((null? x) #f)
-   ((null? (cdr x)) (car x))
-   (#t (list 'cond (list (car x)) ;; COND
-             (list #t (cons 'or (cdr x)))))))
-
-(define-macro (and . x)
-  (cond ((null? x) #t) ;; COND
-        ((null? (cdr x)) (car x))
-        (#t (list 'cond (list (car x) (cons 'and (cdr x))) ;; COND
-                  '(#t #f)))))
-
-(define (not x)
-  (cond (x #f) ;; COND
-        (#t #t)))
-
-(define (equal? a b) ;; FIXME: only 2 arg
-  (cond ((and (null? a) (null? b)) #t) ;; COND
-        ((and (pair? a) (pair? b))
-         (and (equal? (car a) (car b))
-              (equal? (cdr a) (cdr b))))
-        ((and (string? a) (string? b))
-         (eq? (string->symbol a) (string->symbol b)))
-        ((and (vector? a) (vector? b))
-         (equal? (vector->list a) (vector->list b)))
-        (#t (eq? a b))))
-
-(define (memq x lst)
-  (cond ((null? lst) #f) ;; COND
-        ((eq? x (car lst)) lst)
-        (#t (memq x (cdr lst)))))
-
-(define (map f l . r)
-  (cond ((null? l) '()) ;; COND
-        ((null? r) (cons (f (car l)) (map f (cdr l))))
-        ((null? (cdr r))
-         (cons (f (car l) (caar r)) (map f (cdr l) (cdar r))))))
-
 ;; IF based
 (define-macro (or . x)
   (if (null? x) #f ;; IF
diff --git a/base0-cond.mes b/base0-cond.mes
deleted file mode 100644 (file)
index 6d6b21c..0000000
+++ /dev/null
@@ -1,31 +0,0 @@
-;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; base.mes: This file is part of Mes.
-;;;
-;;; Mes is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; Mes is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-(define-macro (if expr then . else)
-  (list 'cond ;; COND
-        (list expr then)
-        (list #t (list 'cond (list (pair? else) ;; COND
-                                   (cons (cons 'lambda (cons '() (cons (cons 'begin (cons *unspecified* else)) '()))) '()))))))
-
-(define (cons* x . rest)
-  (define (loop rest)
-    (cond ((null? (cdr rest)) (car rest)) ;; COND
-          (#t (cons (car rest) (loop (cdr rest))))))
-  (loop (cons x rest)))
index 7a7280b75d6c4d25088848b8c99636e197704d61..51d8ab2e3197e32f0ce4acfdb9cc61039be7089d 100644 (file)
@@ -24,7 +24,7 @@
         (cons (car rest) (loop (cdr rest)))))
   (loop (cons x rest)))
 
-(define-macro cond
+(define-macro xcond ;; using evcon: 50% speedup (cond in syntax.mes)
   (lambda clauses
     (if (null? clauses) *unspecified* ;; IF
         (if (null? (cdr clauses)) ;; IF
diff --git a/let.mes b/let.mes
index b8d694a7a9a1439c1a00838d6479570144763818..fc34e9f0d6e9bcd12c4762e72047c431be4bfb79 100644 (file)
--- a/let.mes
+++ b/let.mes
      (,label ,@(map cadr bindings))))
 
 (define-macro (let bindings-or-label . rest)
-  `(`,(cond (,(symbol? bindings-or-label)
-             (list 'lambda '() (cons* 'named-let ,bindings-or-label ,(car rest) ,(cdr rest))))
-            (#t
-             (list 'lambda '() (cons* 'simple-let ,bindings-or-label ,rest))))))
+  `(`,(if ,(symbol? bindings-or-label)
+          (list 'lambda '() (cons* 'named-let ,bindings-or-label ,(car rest) ,(cdr rest)))
+            (list 'lambda '() (cons* 'simple-let ,bindings-or-label ,rest)))))
 
 (define-macro (xsimple-let bindings rest)
   `(,`(lambda ,(map car bindings) ,@rest)
      (set! ,label (lambda ,(map car bindings) ,@rest))
      (,label ,@(map cadr bindings))))
 
-;; COND
-(define-macro (let bindings-or-label . rest)
-  `(cond (,(symbol? bindings-or-label) ;; COND
-          (xnamed-let ,bindings-or-label ,(car rest) ,(cdr rest)))
-         (#t (xsimple-let ,bindings-or-label ,rest))))
-
 ;; IF
 (define-macro (let bindings-or-label . rest)
   `(if ,(symbol? bindings-or-label) ;; IF
        (xsimple-let ,bindings-or-label ,rest)))
 
 (define (expand-let* bindings body)
-  (cond ((null? bindings)
-         `((lambda () ,@body)))
-        (#t `((lambda (,(caar bindings))
-                ,(expand-let* (cdr bindings) body))
-              ,@(cdar bindings)))))
+  (if (null? bindings)
+      `((lambda () ,@body))
+      `((lambda (,(caar bindings))
+          ,(expand-let* (cdr bindings) body))
+        ,@(cdar bindings))))
 
 (define-macro (let* bindings . body)
   (expand-let* bindings body))
 
 (define (unspecified-bindings bindings params)
-  (cond ((null? bindings) params)
-        (#t (unspecified-bindings
-             (cdr bindings)
-             (append params (cons (cons (caar bindings) '(*unspecified*)) '()))))))
+  (if (null? bindings) params
+      (unspecified-bindings
+       (cdr bindings)
+       (append params (cons (cons (caar bindings) '(*unspecified*)) '())))))
 
 (define (letrec-setters bindings setters)
-  (cond ((null? bindings) setters)
-        (#t (letrec-setters (cdr bindings)
-                            (append setters
-                                    (cons (cons 'set! (car bindings)) '()))))))
+  (if (null? bindings) setters
+      (letrec-setters (cdr bindings)
+                      (append setters
+                              (cons (cons 'set! (car bindings)) '())))))
 
 (define-macro (letrec bindings . body)
   `(let ,(unspecified-bindings bindings '())
diff --git a/mes.c b/mes.c
index d122f2653bd8bac19aa5b50605ed93dd96a27597..55256eb11f4e3f3783906512a64d99f936235a4e 100644 (file)
--- a/mes.c
+++ b/mes.c
@@ -375,13 +375,12 @@ eval (scm *e, scm *a)
           return eval (apply_env (cdr (macro), e, a), a);
       if ((macro = lookup_macro (car (e), a)) != &scm_f)
         return eval (apply_env (macro, cdr (e), a), a);
-#if COND
+#if 1 //COND
       if (car (e) == &symbol_cond)
         return evcon (cdr (e), a);
-#else
+#endif
       if (car (e) == &symbol_if)
         return if_env (cdr (e), a);
-#endif
       if (eq_p (car (e), &symbol_define) == &scm_t)
         return define (e, a);
       if (eq_p (car (e), &symbol_define_macro) == &scm_t)
diff --git a/scm.mes b/scm.mes
index 456663958ba1bb54dae5a07fbf5d3ebe762b487c..cf76c6c59be2f5e7239df707e4fecf5de1ce2fe6 100755 (executable)
--- a/scm.mes
+++ b/scm.mes
 (define assv assq)
 (define assv-ref assq-ref)
 
-(define (assoc key alist)
-  (cond ((null? alist) #f) ;; COND
-        ((equal? key (caar alist)) (car alist))
-        (#t (assoc key (cdr alist)))))
-
 (define (assoc key alist)
   (if (null? alist) #f ;; IF
       (if (equal? key (caar alist)) (car alist)
     (if entry (cdr entry)
         #f)))
 
-(define (memq x lst)
-  (cond ((null? lst) #f) ;; COND
-        ((eq? x (car lst)) lst)
-        (#t (memq x (cdr lst)))))
-
 (define (memq x lst)
   (if (null? lst) #f ;; IF
       (if (eq? x (car lst)) lst
           (memq x (cdr lst)))))
 (define memv memq)
 
-(define (member x lst)
-  (cond ((null? lst) #f) ;; COND
-        ((equal? x (car lst)) lst)
-        (#t (member x (cdr lst)))))
-
 (define (member x lst)
   (if (null? lst) #f ;; IF
       (if (equal? x (car lst)) lst
           (member x (cdr lst)))))
 
-(define (for-each f l . r)
-  (cond ((null? l) '()) ;; COND
-        ((null? r) (f (car l)) (for-each f (cdr l)))
-        ((null? (cdr r))
-         (for-each f (cdr l) (cdar r)))))
-
 (define (for-each f l . r)
   (if (null? l) '() ;; IF
       (if (null? r) (begin (f (car l)) (for-each f (cdr l)))
diff --git a/syntax-cond.mes b/syntax-cond.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))))
diff --git a/syntax-if.mes b/syntax-if.mes
deleted file mode 100644 (file)
index 9a50b67..0000000
+++ /dev/null
@@ -1,238 +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)
-        (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
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))))