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

Initial psyntax integration.

Browse source 
* 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 2016-10-30 16:16:20 +01:00
parent f6baa9ce98
commit d18542e25f
7 changed files with 10221 additions and 9930 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
GNUmakefile
View file

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

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

107
module/mes/psyntax-0.mes Normal file
View file

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

37
module/mes/psyntax-1.mes Normal file
View file

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

9923
module/mes/psyntax-pp.mes Normal file
View file

File diff suppressed because it is too large Load diff

9929
module/mes/psyntax.mes
View file

File diff suppressed because it is too large Load diff

123
tests/psyntax.test Executable file
View file

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