diff --git a/GNUmakefile b/GNUmakefile index 23e0ec2e..57402eb8 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -65,10 +65,10 @@ mes-check: all guile-check: set -e; for i in $(TESTS); do\ - guile -s <(cat $(MES-0) $$(scripts/include.mes $$i | grep -Ev 'let.mes|quasiquote.mes|base-0|loop-0|psyntax-|srfi-0') $$i);\ + guile -s <(cat $(MES-0) module/mes/test.mes $$i);\ done set -e; for i in $(TESTS); do\ - guile -s <(cat $(MES-0) module/mes/test.mes $$i);\ + guile -s <(cat $(MES-0) $$(scripts/include.mes $$i | grep -Ev 'let.mes|quasiquote.mes|match.mes|base-0|loop-0|psyntax-|srfi-0') $$i);\ done MAIN_C:=doc/examples/main.c diff --git a/mes.c b/mes.c index dc35644a..ca099aaa 100644 --- a/mes.c +++ b/mes.c @@ -101,6 +101,7 @@ scm symbol_unquote = {SYMBOL, "unquote"}; scm symbol_unquote_splicing = {SYMBOL, "unquote-splicing"}; scm symbol_sc_expand = {SYMBOL, "sc-expand"}; +scm symbol_expand_macro = {SYMBOL, "expand-macro"}; scm symbol_sc_expander_alist = {SYMBOL, "*sc-expander-alist*"}; scm symbol_noexpand = {SYMBOL, "noexpand"}; scm symbol_syntax = {SYMBOL, "syntax"}; @@ -482,6 +483,13 @@ sc_expand_env (scm *e, scm *a) scm *macro; if (e->type == PAIR && car (e)->type == SYMBOL + + && car (e) != &symbol_lambda + && car (e) != &symbol_set_x + && car (e) != &symbol_if + && car (e) != &symbol_begin + && car (e) != &symbol_define + && car (e) != &symbol_quasiquote && car (e) != &symbol_quote && car (e) != &symbol_unquote @@ -489,9 +497,12 @@ sc_expand_env (scm *e, scm *a) && ((expanders = assq_ref_cache (&symbol_sc_expander_alist, a)) != &scm_undefined) && ((macro = assq (car (e), expanders)) != &scm_f)) { - scm *sc_expand = assq_ref_cache (&symbol_sc_expand, a); - if (sc_expand != &scm_undefined) - return apply_env (sc_expand, cons (e, &scm_nil), a); + scm *sc_expand = assq_ref_cache (&symbol_expand_macro, a); + if (sc_expand != &scm_undefined && sc_expand != &scm_f) + { + e = apply_env (sc_expand, cons (e, &scm_nil), a); + return expand_macro_env (e, a); + } } return e; } diff --git a/module/language/c/parser.mes b/module/language/c/parser.mes index 2a0af14a..a97b933f 100644 --- a/module/language/c/parser.mes +++ b/module/language/c/parser.mes @@ -36,15 +36,18 @@ (mes-use-module (mes quasiquote)) (mes-use-module (mes let)) (mes-use-module (mes scm)) - (mes-use-module (mes syntax)) + (mes-use-module (srfi srfi-0)) + + (mes-use-module (mes psyntax-0)) + (mes-use-module (mes psyntax-pp)) + (mes-use-module (mes psyntax-1)) + (mes-use-module (mes record-0)) (mes-use-module (mes record)) (mes-use-module (srfi srfi-9)) (mes-use-module (mes lalr-0)) (mes-use-module (mes lalr)) - - (mes-use-module (mes let-syntax)) (mes-use-module (srfi srfi-1)) (mes-use-module (mes match)) diff --git a/module/language/paren.mes b/module/language/paren.mes index 1c0909dc..3430b085 100644 --- a/module/language/paren.mes +++ b/module/language/paren.mes @@ -39,7 +39,9 @@ (mes-use-module (mes quasiquote)) (mes-use-module (mes let)) (mes-use-module (mes scm)) - (mes-use-module (mes syntax)) + (mes-use-module (mes psyntax-0)) + (mes-use-module (mes psyntax-pp)) + (mes-use-module (mes psyntax-1)) (mes-use-module (srfi srfi-0)) (mes-use-module (mes record-0)) (mes-use-module (mes record)) diff --git a/module/mes/let-syntax.mes b/module/mes/let-syntax.mes deleted file mode 100644 index fe536c62..00000000 --- a/module/mes/let-syntax.mes +++ /dev/null @@ -1,36 +0,0 @@ -;;; -*-scheme-*- - -;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016 Jan Nieuwenhuizen -;;; -;;; 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 . - -;;; Commentary: - -;;; let-syntax.mes is loaded after syntax.mes. It provides the R5RS -;;; hygienic macro let-syntax. - -;;; Code: - -(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/module/mes/psyntax-0.mes b/module/mes/psyntax-0.mes index 47cd1ec2..04bb1d6d 100644 --- a/module/mes/psyntax-0.mes +++ b/module/mes/psyntax-0.mes @@ -77,9 +77,9 @@ (define putprop #f) (define getprop #f) +(define properties-alist #f) -;;(define properties *sc-expander-alist*) -(let ((xproperties '())) +(let ((properties '())) (set! putprop (lambda (symbol key value) (let ((plist (assq symbol *sc-expander-alist*))) @@ -100,7 +100,8 @@ (if (pair? couple) (cdr couple) #f)) - #f))))) + #f)))) + (set! properties-alist (lambda () *sc-expander-alist*))) ;; (define fx+ +) ;; (define fx- -) ;; (define fx= =) diff --git a/module/mes/psyntax-1.mes b/module/mes/psyntax-1.mes index 204dca6c..11cb99a1 100644 --- a/module/mes/psyntax-1.mes +++ b/module/mes/psyntax-1.mes @@ -27,37 +27,9 @@ (define datum->syntax datum->syntax-object) (define syntax->datum syntax-object->datum) - -(define-macro (define-syntax macro-name transformer) - `(define-macro ,macro-name - `(lambda args - (eval - (syntax-object->datum - (,transformer (cons ,macro-name args))) - (current-module))))) - -(define-syntax syntax-rules - (lambda (x) - (syntax-case x () - ((_ (k ...) ((keyword . pattern) template) ...) - (syntax (lambda (x) - (syntax-case x (k ...) - ((dummy . pattern) (syntax template)) - ...))))))) +(set! expand-macro sc-expand) (define-macro (define-syntax-rule id-pattern . template) `(define-syntax ,(car id-pattern) (syntax-rules () ((,(car id-pattern) . ,(cdr id-pattern)) ,@template)))) - -(define-macro (let-syntax bindings . rest) - `((lambda () - ,@(map (lambda (binding) - `(define-macro ,(car binding) - `(lambda args - (eval - (syntax-object->datum - (,(cadr binding) (cons ',(car binding) args))) - (current-module))))) - bindings) - ,@rest))) diff --git a/module/mes/syntax.mes b/module/mes/syntax.mes deleted file mode 100644 index 46370563..00000000 --- a/module/mes/syntax.mes +++ /dev/null @@ -1,266 +0,0 @@ -;; -*-scheme-*- - -;;; Mes --- Maxwell Equations of Software -;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. -;;; Copyright © 2016 Jan Nieuwenhuizen -;;; -;;; 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 . - -;;; Commentary: - -;;; syntax.mes is loaded after scm.mes. It provides the R5RS hygienic -;;; macros define-syntax, syntax-rules and define-syntax-rule. -;;; syntax-rules is adapted from scheme48-1.1/scheme/alt/syntax.scm - -;;; Code: - -(define (syntax-error message thing) - (display "syntax-error:" (current-error-port)) - (display message (current-error-port)) - (display ":" (current-error-port)) - (display thing (current-error-port)) - (newline (current-error-port))) - -(define (silent-syntax-error message thing) - *unspecified*) - -;;; 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 (x0) x0) - 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) - (silent-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/scripts/mescc.mes b/scripts/mescc.mes index dd21d5d0..4fc2c205 100755 --- a/scripts/mescc.mes +++ b/scripts/mescc.mes @@ -38,22 +38,20 @@ exit $? (mes-use-module (mes quasiquote)) (mes-use-module (mes let)) (mes-use-module (mes scm)) -(mes-use-module (mes syntax)) +(mes-use-module (mes psyntax-0)) +(mes-use-module (mes psyntax-pp)) +(mes-use-module (mes psyntax-1)) (mes-use-module (srfi srfi-0)) (mes-use-module (mes record-0)) (mes-use-module (mes record)) (mes-use-module (srfi srfi-9)) (mes-use-module (mes lalr-0)) (mes-use-module (mes lalr)) - -(mes-use-module (mes let-syntax)) (mes-use-module (srfi srfi-1)) (mes-use-module (mes match)) - (mes-use-module (rnrs bytevectors)) (mes-use-module (mes elf)) (mes-use-module (mes libc-i386)) - (mes-use-module (language c lexer)) (mes-use-module (language c parser)) (mes-use-module (language c compiler)) diff --git a/scripts/paren.mes b/scripts/paren.mes index 4e430a82..41c8d136 100755 --- a/scripts/paren.mes +++ b/scripts/paren.mes @@ -39,7 +39,9 @@ exit $? (mes-use-module (mes quasiquote)) (mes-use-module (mes let)) (mes-use-module (mes scm)) -(mes-use-module (mes syntax)) +(mes-use-module (mes psyntax-0)) +(mes-use-module (mes psyntax-pp)) +(mes-use-module (mes psyntax-1)) (mes-use-module (srfi srfi-0)) (mes-use-module (mes record-0)) (mes-use-module (mes record)) diff --git a/scripts/repl.mes b/scripts/repl.mes index 60f0f9ad..38ce8467 100755 --- a/scripts/repl.mes +++ b/scripts/repl.mes @@ -28,15 +28,12 @@ exit $? (mes-use-module (mes quasiquote)) (mes-use-module (mes let)) (mes-use-module (mes scm)) -(mes-use-module (mes syntax)) -(mes-use-module (mes let-syntax)) (mes-use-module (srfi srfi-0)) +(mes-use-module (mes psyntax-0)) +(mes-use-module (mes psyntax-pp)) +(mes-use-module (mes psyntax-1)) (mes-use-module (mes match)) (mes-use-module (mes repl)) -(mes-use-module (mes psyntax-0)) -(mes-use-module (mes psyntax)) -(mes-use-module (mes psyntax-1)) - (repl) () diff --git a/tests/match.test b/tests/match.test index 7b12a5cb..c2103926 100755 --- a/tests/match.test +++ b/tests/match.test @@ -31,11 +31,12 @@ exit $? (mes-use-module (mes let)) (mes-use-module (srfi srfi-0)) (mes-use-module (mes scm)) -(mes-use-module (mes syntax)) +(mes-use-module (mes psyntax-0)) +(mes-use-module (mes psyntax-pp)) +(mes-use-module (mes psyntax-1)) (mes-use-module (mes record-0)) (mes-use-module (mes record)) (mes-use-module (srfi srfi-9)) -(mes-use-module (mes let-syntax)) (mes-use-module (mes match)) (mes-use-module (mes test)) diff --git a/tests/psyntax.test b/tests/psyntax.test index 3653995e..40826b4b 100755 --- a/tests/psyntax.test +++ b/tests/psyntax.test @@ -103,6 +103,23 @@ exit $? '("bar" "foo")))) (pass-if "define-syntax swap! [syntax-case]" + (sequal? + (let () + (define-syntax swap! + (lambda (exp) + (syntax-case exp () + ((swap! a b) + (syntax + ((lambda (temp) + (set! a b) + (set! b temp)) a)))))) + (let ((foo "foo") + (bar "bar")) + (swap! foo bar) + (list foo bar))) + (list "bar" "foo"))) + +(pass-if "define-syntax swap! [syntax-case+let]" (sequal? (let () (define-syntax swap! diff --git a/tests/record.test b/tests/record.test index 060aab52..c107c158 100755 --- a/tests/record.test +++ b/tests/record.test @@ -31,7 +31,9 @@ exit $? (mes-use-module (mes let)) (mes-use-module (srfi srfi-0)) (mes-use-module (mes scm)) -(mes-use-module (mes syntax)) +(mes-use-module (mes psyntax-0)) +(mes-use-module (mes psyntax-pp)) +(mes-use-module (mes psyntax-1)) (mes-use-module (mes record-0)) (mes-use-module (mes record)) (mes-use-module (srfi srfi-9))