artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

Finalize psyntax integration.

Browse source 
* mes.c (sc_expand_env): Exclude primitives, expand native macros.
  (symbol_expand_macro): New symbol.
* module/mes/psyntax-0.mes (properties-alist): New function.
* module/mes/psyntax-1.mes: Set expand-macro.
  (define-syntax, syntax-rules, let-syntax): Remove macro.
* module/language/c/parser.mes: Use psyntax modules, remove syntax module.
* module/language/paren.mes: Likewise.
* scripts/repl.mes: Likewise.
* tests/match.test: Likewise.
* tests/record.test: Likewise.
* tests/psyntax.test (define-syntax swap!): Add test.
* module/mes/let-syntax.mes: Remove.
* module/mes/syntax.mes: Remove.
This commit is contained in:
Jan Nieuwenhuizen 2016-11-02 10:36:09 +01:00
parent c851935d4d
commit 2b373ff40f
14 changed files with 62 additions and 358 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
GNUmakefile
View file

@ -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

17
mes.c
View file

@ -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;
}

9
module/language/c/parser.mes
View file

@ -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))

4
module/language/paren.mes
View file

@ -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))

36
module/mes/let-syntax.mes
View file

@ -1,36 +0,0 @@
;;; -*-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/>.
;;; 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)))

7
module/mes/psyntax-0.mes
View file

@ -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= =)

30
module/mes/psyntax-1.mes
View file

@ -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)))

266
module/mes/syntax.mes
View file

@ -1,266 +0,0 @@
;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees.
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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/>.
;;; 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))))

8
scripts/mescc.mes
View file

@ -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))

4
scripts/paren.mes
View file

@ -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))

9
scripts/repl.mes
View file

@ -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)
()

5
tests/match.test
View file

@ -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))

17
tests/psyntax.test
View file

@ -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!

4
tests/record.test
View file

@ -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))