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.

GNUmakefile

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

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

module/mes/psyntax-0.mes

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

module/mes/psyntax-1.mes

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

tests/psyntax.test

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