let-syntax.mes: implement.

diff --git a/GNUmakefile b/GNUmakefile
index f88f4ec1839c5bb3662d9aef12090392f580e638..f0335e0eb5bef464470635521847130ead0a0791 100644 (file)
--- a/GNUmakefile
+++ b/GNUmakefile
@@ -1,5 +1,6 @@
 .PHONY: all check default 
 CFLAGS:=-std=c99 -O3 -finline-functions
+#CFLAGS:=-pg -std=c99 -O3 -finline-functions
 #CFLAGS:=-std=c99 -g
 
 default: all
@@ -44,6 +45,7 @@ mes-check: all
        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
+       cat base0.mes base0-if.mes base.mes quasiquote.mes let.mes scm.mes syntax.mes let-syntax.mes lib/srfi/srfi-0.scm lib/test.mes test/let-syntax.test | ./mes
 
 guile-check:
        guile -s <(cat base.mes lib/test.mes test/base.test)
@@ -115,7 +117,7 @@ guile-paren: paren.test
        echo '___P((()))' | guile -s $^ 
 
 mescc: all
-       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
+       echo ' EOF ' | cat base0.mes base0-if.mes base.mes quasiquote.mes let.mes scm.mes syntax.mes let-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
@@ -135,3 +137,12 @@ hello: hello.o
 a.out: lib/elf.mes elf.mes GNUmakefile
        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
+
+match: all
+       echo ' EOF ' | cat base0.mes base0-if.mes base.mes quasiquote.mes let.mes scm.mes syntax.mes let-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 match.mes | ./mes
+
+match.test: lib/lalr.scm lib/rnrs/bytevectors.scm lib/srfi/srfi-1.scm lib/match.scm match.mes
+       cat $^ > $@
+
+guile-match: match.test
+       guile -s $^

diff --git a/let-syntax.mes b/let-syntax.mes
new file mode 100644 (file)
index 0000000..cda9a70
--- /dev/null
+++ b/let-syntax.mes
@@ -0,0 +1,29 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; let-syntax.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 (let-syntax bindings . rest)
+  `((lambda ()
+      ,@(map (lambda (binding)
+               `(define-macro (,(car binding) . args)
+                  (,(cadr binding) (cons ',(car binding) args)
+                   (lambda (x0) x0)
+                   eq?)))
+             bindings)
+      ,@rest)))

diff --git a/let.mes b/let.mes
index fc34e9f0d6e9bcd12c4762e72047c431be4bfb79..d87b2be4a011046bb698bdaf0d0f97e66af3fbf8 100644 (file)
--- a/let.mes
+++ b/let.mes
@@ -3,7 +3,7 @@
 ;;; Mes --- Maxwell Equations of Software
 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;
-;;; test.mes: This file is part of Mes.
+;;; let.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

diff --git a/syntax.mes b/syntax.mes
index 3baa811a36ea1626143fdea45b5e8da857b8409b..134aa394a9fe01d3f591b9460c80759559f54851 100644 (file)
--- a/syntax.mes
+++ b/syntax.mes
@@ -42,8 +42,8 @@
 (define-macro (define-syntax macro-name transformer . stuff)
   `(define-macro (,macro-name . args)
      (,transformer (cons ',macro-name args)
-                             (lambda (x) x)
-                             eq?)))
+                   (lambda (x0) x0)
+                   eq?)))
 
 ;; Rewrite-rule compiler (a.k.a. "extend-syntax")
 
@@ -57,21 +57,21 @@
 ;;                    (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 "...") '---))
-  
+  (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.
@@ -84,36 +84,36 @@
       (define subkeywords (cadr exp))
 
       (define (make-transformer rules)
-          `(lambda (,%input ,%rename ,%compare)
+        `(lambda (,%input ,%rename ,%compare)
            (let ((,%tail (cdr ,%input)))
-               (cond ,@(map process-rule rules)
+             (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)))
-
+        (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)
-               (cond ((member pattern subkeywords)
-                      `((,%compare ,input (,%rename ',pattern))))
-                     (#t `())))
+        (cond ((name? pattern)
+               (if (member pattern subkeywords)
+                   `((,%compare ,input (,%rename ',pattern)))
+                   `()))
               ((segment-pattern? pattern)
                (process-segment-match input (car pattern)))
               ((pair? pattern)
@@ -125,35 +125,33 @@
                `((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))))))))))
-
+          (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)
-               (cond ((memq pattern subkeywords)
-                      '())
-                     (#t
-                      (list (list pattern (mapit path))))))
+               (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 (cond ((eq? %temp x)
-                                                path) ;+++
-                                               (#t
-                                                `(map (lambda (,%temp) ,x)
-                                                      ,path)))))))
+                                (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)))
@@ -164,29 +162,28 @@
       (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)))))
+                 (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 '())))
-                 (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)))))))))
+                 (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)))
@@ -196,9 +193,9 @@
 
       (define (meta-variables pattern rank vars)
         (cond ((name? pattern)
-               (cond ((memq pattern subkeywords)
-                      vars)
-                     (else (cons (cons pattern rank) vars))))
+               (if (memq pattern subkeywords)
+                   vars
+                   (cons (cons pattern rank) vars)))
               ((segment-pattern? pattern)
                (meta-variables (car pattern) (+ rank 1) vars))
               ((pair? pattern)
@@ -210,11 +207,11 @@
 
       (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)))
+               (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

diff --git a/test/let-syntax.test b/test/let-syntax.test
new file mode 100644 (file)
index 0000000..0a12765
--- /dev/null
+++ b/test/let-syntax.test
@@ -0,0 +1,51 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; let-syntax.test: 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/>.
+
+(pass-if "first dummy" #t)
+(pass-if-not "second dummy" #f)
+
+(pass-if "let-syntax"
+  (seq?
+   (let-syntax ((when (syntax-rules ()
+                        ((when condition exp ...)
+                         (if (not condition)
+                             (begin exp ...))))))
+     (when #f 3))
+   3))
+
+(pass-if "let-syntax no-leak"
+  (seq?
+   (when #f 3)
+   *unspecified*))
+
+(pass-if "let-syntax"
+  (sequal?
+   (let-syntax ((when (syntax-rules ()
+                        ((when condition exp ...)
+                         (if (not condition)
+                             (begin exp ...)))))
+                (unless (syntax-rules ()
+                        ((when condition exp ...)
+                         (if condition
+                             (begin exp ...))))))
+     (list (when #f 0) (unless #t 1)))
+   '(0 1)))
+
+(result 'report)