Initial psyntax integration.
* mes.c (sc_expand_env): New function. (builtin_eval): Use it. * module/mes/psyntax-0.mes: New file. * module/mes/psyntax-1.mes: New file. * tests/psyntax.test: New file. * GNUmakefile (TESTS): Add it.
This commit is contained in:
Jan Nieuwenhuizen
parent
f6baa9ce98
commit
d18542e25f
|
|
@ -51,6 +51,7 @@ TESTS:=\
|
|||
tests/scm.test\
|
||||
tests/record.test\
|
||||
tests/let-syntax.test\
|
||||
tests/psyntax.test\
|
||||
tests/match.test\
|
||||
#
|
||||
|
||||
|
|
@ -63,7 +64,7 @@ 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|srfi-0') $$i);\
|
||||
guile -s <(cat $(MES-0) $$(scripts/include.mes $$i | grep -Ev 'let.mes|quasiquote.mes|base-0|loop-0|psyntax-|srfi-0') $$i);\
|
||||
done
|
||||
set -e; for i in $(TESTS); do\
|
||||
guile -s <(cat $(MES-0) module/mes/test.mes $$i);\
|
||||
|
|
|
|||
29
mes.c
29
mes.c
|
|
@ -100,6 +100,8 @@ scm symbol_unquote = {SYMBOL, "unquote"};
|
|||
scm symbol_unquote_splicing = {SYMBOL, "unquote-splicing"};
|
||||
|
||||
scm symbol_sc_expand = {SYMBOL, "sc-expand"};
|
||||
scm symbol_sc_expander_alist = {SYMBOL, "*sc-expander-alist*"};
|
||||
scm symbol_noexpand = {SYMBOL, "noexpand"};
|
||||
scm symbol_syntax = {SYMBOL, "syntax"};
|
||||
scm symbol_quasisyntax = {SYMBOL, "quasisyntax"};
|
||||
scm symbol_unsyntax = {SYMBOL, "unsyntax"};
|
||||
|
|
@ -409,6 +411,10 @@ builtin_eval (scm *e, scm *a)
|
|||
return e;
|
||||
else if (e->car->type != PAIR)
|
||||
{
|
||||
if (e->car->type == STRING && string_to_symbol (e->car) == &symbol_noexpand)
|
||||
e = cadr (e);
|
||||
else
|
||||
e = sc_expand_env (e, a);
|
||||
if (e->car == &symbol_quote)
|
||||
return cadr (e);
|
||||
#if QUASISYNTAX
|
||||
|
|
@ -468,6 +474,27 @@ expand_macro_env (scm *e, scm *a)
|
|||
return e;
|
||||
}
|
||||
|
||||
scm *
|
||||
sc_expand_env (scm *e, scm *a)
|
||||
{
|
||||
scm *expanders;
|
||||
scm *macro;
|
||||
if (e->type == PAIR
|
||||
&& car (e)->type == SYMBOL
|
||||
&& car (e) != &symbol_quasiquote
|
||||
&& car (e) != &symbol_quote
|
||||
&& car (e) != &symbol_unquote
|
||||
&& car (e) != &symbol_unquote_splicing
|
||||
&& ((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);
|
||||
}
|
||||
return e;
|
||||
}
|
||||
|
||||
scm *
|
||||
begin (scm *e, scm *a)
|
||||
{
|
||||
|
|
@ -1089,6 +1116,8 @@ mes_environment () ///((internal))
|
|||
#include "define.environment.i"
|
||||
#include "type.environment.i"
|
||||
|
||||
a = add_environment (a, "sc-expand", &scm_f);
|
||||
|
||||
a = cons (cons (&scm_closure, a), a);
|
||||
return a;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -0,0 +1,107 @@
|
|||
;;; -*-scheme-*-
|
||||
|
||||
;;; Mes --- Maxwell Equations of Software
|
||||
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
|
||||
;;;
|
||||
;;; 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 (interaction-environment) (current-module))
|
||||
|
||||
;; (define c:eval (assq-ref %builtins 'eval))
|
||||
;; (define (eval x . environment)
|
||||
;; (display "***EVAL x=***=\n")
|
||||
;; (display x)
|
||||
;; (newline)
|
||||
;; (c:eval (if (and (pair? x)
|
||||
;; (equal? (car x) "noexpand"))
|
||||
;; (cadr x)
|
||||
;; (sc-expand x))
|
||||
;; (interaction-environment)))
|
||||
|
||||
(define annotation? (lambda (x) #f))
|
||||
(define (self-evaluating? x)
|
||||
(or (boolean? x) (number? x) (string? x) (char? x) (null? x)))
|
||||
|
||||
(define (void) (if #f #f))
|
||||
|
||||
|
||||
(define sc-expand #f)
|
||||
(define sc-chi #f)
|
||||
(define sc-expand3 #f)
|
||||
(define install-global-transformer #f)
|
||||
(define syntax-dispatch #f)
|
||||
(define syntax-error #f)
|
||||
|
||||
(define bound-identifier=? #f)
|
||||
(define datum->syntax-object #f)
|
||||
(define define-syntax (void))
|
||||
(define fluid-let-syntax #f)
|
||||
(define free-identifier=? #f)
|
||||
(define generate-temporaries #f)
|
||||
(define identifier? #f)
|
||||
(define identifier-syntax #f)
|
||||
(define let-syntax #f)
|
||||
(define letrec-syntax #f)
|
||||
(define syntax #f)
|
||||
(define syntax-case #f)
|
||||
(define syntax-object->datum #f)
|
||||
(define syntax-rules #f)
|
||||
(define with-syntax #f)
|
||||
|
||||
(define andmap
|
||||
(lambda (f . lists)
|
||||
(if (null? (car lists)) (and)
|
||||
(if (null? (cdr (car lists))) (apply f (map car lists))
|
||||
(and (apply f (map car lists))
|
||||
(apply andmap f (map cdr lists)))))))
|
||||
|
||||
(define ormap
|
||||
(lambda (proc list1)
|
||||
(and (not (null? list1))
|
||||
(or (proc (car list1)) (ormap proc (cdr list1))))))
|
||||
|
||||
(define *sc-expander-alist* '())
|
||||
|
||||
(define putprop #f)
|
||||
(define getprop #f)
|
||||
|
||||
;;(define properties *sc-expander-alist*)
|
||||
(let ((xproperties '()))
|
||||
(set! putprop
|
||||
(lambda (symbol key value)
|
||||
(let ((plist (assq symbol *sc-expander-alist*)))
|
||||
(if (pair? plist)
|
||||
(let ((couple (assq key (cdr plist))))
|
||||
(if (pair? couple)
|
||||
(set-cdr! couple value)
|
||||
(set-cdr! plist (cons (cons key value)
|
||||
(cdr plist)))))
|
||||
(let ((plist (list symbol (cons key value))))
|
||||
(set! *sc-expander-alist* (cons plist *sc-expander-alist*)))))
|
||||
value))
|
||||
(set! getprop
|
||||
(lambda (symbol key)
|
||||
(let ((plist (assq symbol *sc-expander-alist*)))
|
||||
(if (pair? plist)
|
||||
(let ((couple (assq key (cdr plist))))
|
||||
(if (pair? couple)
|
||||
(cdr couple)
|
||||
#f))
|
||||
#f)))))
|
||||
;; (define fx+ +)
|
||||
;; (define fx- -)
|
||||
;; (define fx= =)
|
||||
;; (define fx< <)
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
;;; -*-scheme-*-
|
||||
|
||||
;;; Mes --- Maxwell Equations of Software
|
||||
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
|
||||
;;;
|
||||
;;; 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:
|
||||
|
||||
;;; psyntax-1.mes - post psyntax.pp hook. psyntax-1.mes is loaded
|
||||
;;; after psyntax-pp.mes.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(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)))))
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,123 @@
|
|||
#! /bin/sh
|
||||
# -*-scheme-*-
|
||||
echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes "$@"
|
||||
#paredit:||
|
||||
exit $?
|
||||
!#
|
||||
|
||||
;;; -*-scheme-*-
|
||||
|
||||
;;; Mes --- Maxwell Equations of Software
|
||||
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
|
||||
;;;
|
||||
;;; 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/>.
|
||||
|
||||
(mes-use-module (mes base-0))
|
||||
(mes-use-module (mes base))
|
||||
(mes-use-module (mes quasiquote))
|
||||
(mes-use-module (mes let))
|
||||
(mes-use-module (srfi srfi-0))
|
||||
(mes-use-module (mes scm))
|
||||
(mes-use-module (mes psyntax-0))
|
||||
(mes-use-module (mes psyntax-pp))
|
||||
(mes-use-module (mes psyntax-1))
|
||||
(mes-use-module (mes test))
|
||||
|
||||
(pass-if "first dummy" #t)
|
||||
(pass-if-not "second dummy" #f)
|
||||
|
||||
(cond-expand
|
||||
(guile
|
||||
;;(use-modules (ice-9 syncase))
|
||||
(define sc-expand identity)
|
||||
(define syntax-object->datum syntax->datum)
|
||||
(define datum->syntax-object datum->syntax)
|
||||
)
|
||||
(mes))
|
||||
|
||||
(when (not guile?)
|
||||
(pass-if "andmap"
|
||||
(seq? (andmap (lambda (x) (> x 0)) '(3 2 1)) #t))
|
||||
|
||||
(pass-if "andmap 2"
|
||||
(seq? (andmap (lambda (x) (> x 0)) '(3 2 1 0)) #f))
|
||||
|
||||
(pass-if "putprop" (putprop 'foo '*sc-expander 'bar))
|
||||
|
||||
(pass-if "getprop"
|
||||
(seq? (getprop 'foo '*sc-expander) 'bar))
|
||||
)
|
||||
|
||||
(pass-if "syntax-case"
|
||||
(sequal? (let* ((sexp '(syntax-case '((1 2) (3 4)) ()
|
||||
(((x ...) ...) (syntax (x ... ...)))))
|
||||
(expanded (sc-expand sexp)))
|
||||
(primitive-eval expanded))
|
||||
'(1 2 3 4)))
|
||||
|
||||
(pass-if "sc-expand"
|
||||
(sequal? (let ()
|
||||
(syntax-case '((1 2) (3 4)) ()
|
||||
(((x ...) ...) (syntax (x ... ...)))))
|
||||
'(1 2 3 4)))
|
||||
|
||||
(pass-if "syntax-object->datum"
|
||||
(sequal? (syntax-object->datum (syntax (set! a b)))
|
||||
'(set! a b)))
|
||||
|
||||
(pass-if "syntax-case swap!"
|
||||
(sequal? (syntax-object->datum
|
||||
(let ((exp '(set! a b)))
|
||||
(syntax-case exp ()
|
||||
((swap! a b)
|
||||
(syntax
|
||||
(let ((temp a))
|
||||
(set! a b)
|
||||
(set! b temp)))))))
|
||||
'(let ((temp a)) (set! a b) (set! b temp))))
|
||||
|
||||
(when (not guile?)
|
||||
(pass-if "syntax-case manual swap!"
|
||||
(sequal?
|
||||
(let* ((sc (sc-expand '(syntax-case exp () ((swap! a b) (syntax (let ((temp a)) (set! a b) (set! b temp)))))))
|
||||
(exp '(swap foo bar))
|
||||
(foo "foo")
|
||||
(bar "bar")
|
||||
(s (eval sc (current-module)))
|
||||
(d (syntax-object->datum s)))
|
||||
(eval d (current-module))
|
||||
(list foo bar))
|
||||
'("bar" "foo"))))
|
||||
|
||||
(pass-if "define-syntax swap! [syntax-case]"
|
||||
(sequal?
|
||||
(let ()
|
||||
(define-syntax swap!
|
||||
(lambda (exp)
|
||||
(syntax-case exp ()
|
||||
((swap! a b)
|
||||
(syntax
|
||||
(let ((temp a))
|
||||
(set! a b)
|
||||
(set! b temp)))))))
|
||||
(let ((foo "foo")
|
||||
(bar "bar"))
|
||||
(swap! foo bar)
|
||||
(list foo bar)))
|
||||
(list "bar" "foo")))
|
||||
|
||||
(result 'report)
|
||||
|
||||
Loading…
Reference in New Issue