mes: Iterative recursive macro expand.

* src/mes.c (eval_apply): Iterative recursive macro expand.
* src/posix.c (set_current_input_port): Return previous port.
* module/mes/catch.mes (%eh): Use core:display.
* module/mes/display.mes (display-cut, display-cut2): Move macro
  definitions to toplevel.

diff --git a/check-mescc.sh b/check-mescc.sh
index 382a7b286c2c65e837a61dc785737be1c655770c..d71f27e9fdaa82541efe22aa6915bf94d3e90c45 100755 (executable)
--- a/check-mescc.sh
+++ b/check-mescc.sh
@@ -20,7 +20,7 @@
 
 export MES=${MES-src/mes.gcc}
 export MESCC=${MESCC-scripts/mescc.mes}
-#export MES_ARENA=${MES_ARENA-200000000} #9GiB
+#export MES_ARENA=${MES_ARENA-200000000} > 12GB mem
 
 GUILE=${GUILE-guile}
 MES=${MES-./mes}

diff --git a/module/mes/catch.mes b/module/mes/catch.mes
index bc0d5dd811053e5fbb7bb1cc9ba6443b1af94364..5be7ef83a64dc8ab33fd32d974f9dac65f91ea78 100644 (file)
--- a/module/mes/catch.mes
+++ b/module/mes/catch.mes
@@ -23,14 +23,14 @@
 
 (define %eh (make-fluid
              (lambda (key . args)
-               (if (defined? 'simple-format)
+               (if #f ;;(defined? 'simple-format)
                    (simple-format (current-error-port) "unhandled exception:~a:~a\n" key args)
                    (begin
-                     (display "unhandled exception:" (current-error-port))
-                     (display key (current-error-port))
-                     (display ":" (current-error-port))
-                     (write args (current-error-port))
-                     (newline (current-error-port))))
+                     (core:display-error "unhandled exception:")
+                     (core:display-error key)
+                     (core:display-error ":")
+                     (core:write-error args)
+                     (core:display-error "\n")))
                (exit 1))))
 
 (define (catch key thunk handler)

diff --git a/module/mes/display.mes b/module/mes/display.mes
index 91269703e7c36508a3ba83cb3c79e23dd9a0727e..beb2b0757c62a1e6aac56a18b7d0dc82fb31125d 100644 (file)
--- a/module/mes/display.mes
+++ b/module/mes/display.mes
@@ -40,16 +40,16 @@
            (and=> (srfi-1:member x (cdr a) (lambda (x e) (eq? x (cdr e))))
                   (lambda (a) (xassq x (cdr a)))))))
 
+(define-macro (display-cut f slot n1)
+  `(lambda (slot) (,f slot ,n1)))
+
+(define-macro (display-cut2 f slot n1 n2)
+  `(lambda (slot) (,f slot ,n1 ,n2)))
+
 (define (display x . rest)
   (let* ((port (if (null? rest) (current-output-port) (car rest)))
          (write? (and (pair? rest) (pair? (cdr rest)) (cadr rest))))
 
-    (define-macro (cut f slot n1)
-      `(lambda (slot) (,f slot ,n1)))
-
-    (define-macro (cut2 f slot n1 n2)
-      `(lambda (slot) (,f slot ,n1 ,n2)))
-
     (define (display-char x port write?)
       (cond ((and write? (or (eq? x #\") (eq? x #\\)))
              (write-char #\\ port)
@@ -60,7 +60,7 @@
             (#t (write-char x port))))
 
     (define (d x cont? sep)
-      (for-each (cut write-char <> port) (string->list sep))
+      (for-each (display-cut write-char <> port) (string->list sep))
       (cond
        ((eof-object? x)
         (display "#<eof>" port))
@@ -114,7 +114,7 @@
        ((or (keyword? x) (special? x) (string? x) (symbol? x))
         (if (and (string? x) write?) (write-char #\" port))
         (if (keyword? x) (display "#:" port))
-        (for-each (cut2 display-char <> port write?) (string->list x))
+        (for-each (display-cut2 display-char <> port write?) (string->list x))
         (if (and (string? x) write?) (write-char #\" port)))
        ((vector? x)
         (display "#(" port)

diff --git a/module/mes/guile.mes b/module/mes/guile.mes
index 627ccf42fcb7d357adc22715f1611a86b4ae38f4..2397d4c37bfa93d1a1ced4108ec738184f43b441 100644 (file)
--- a/module/mes/guile.mes
+++ b/module/mes/guile.mes
@@ -28,7 +28,7 @@
 
 (define-macro (include-from-path file)
   (let loop ((path (cons %moduledir (string-split (or (getenv "GUILE_LOAD_PATH") "") #\:))))
-    (if (getenv "MES_DEBUG") 
+    (if (getenv "MES_DEBUG")
         ;;(format (current-error-port) "include-from-path: ~s [PATH:~s]\n" file path)
         (core:display-error (string-append "include-from-path: " file " [PATH:" (string-join path ":") "]\n")))
     (if (null? path) (error "include-from-path: not found: " file)
@@ -175,3 +175,40 @@
   (let ((lst (filter (negate string-null?) (string-split file-name #\/))))
     (if (<= (length lst) 1) "."
         (string-join (list-head lst (1- (length lst))) "/"))))
+
+;; FIXME: c&p from display
+(define (with-output-to-string thunk)
+  (define save-write-byte write-byte)
+  (let ((stdout '()))
+    (set! write-byte
+          (lambda (x . rest)
+            (let ((out? (or (null? rest) (eq? (car rest) (current-output-port)))))
+              (if (not out?) (apply save-write-byte (cons x rest))
+                  (begin
+                    (set! stdout (append stdout (list (integer->char x))))
+                    x)))))
+    (thunk)
+    (let ((r (apply string stdout)))
+      (set! write-byte save-write-byte)
+      r)))
+
+;; FIXME: c&p from display
+(define (simple-format destination format . rest)
+  (let ((port (if (boolean? destination) (current-output-port) destination))
+        (lst (string->list format)))
+    (define (simple-format lst args)
+      (if (pair? lst)
+          (let ((c (car lst)))
+            (if (not (eq? c #\~)) (begin (write-char (car lst) port)
+                                         (simple-format (cdr lst) args))
+                (let ((c (cadr lst)))
+                  (case c
+                    ((#\a) (display (car args) port))
+                    ((#\s) (write (car args) port)))
+                  (simple-format (cddr lst) (cdr args)))))))
+
+    (if destination (simple-format lst rest)
+        (with-output-to-string
+          (lambda () (simple-format lst rest))))))
+(define format simple-format)
+

diff --git a/module/mes/peg.mes b/module/mes/peg.mes
index ac3ba7bfaac538b87b1db23c1aa2f70aa55c28a1..261178b3d9bbed1c9ced46a8bdd5bb6647c290ed 100644 (file)
--- a/module/mes/peg.mes
+++ b/module/mes/peg.mes
@@ -1,7 +1,7 @@
 ;;; -*-scheme-*-
 
 ;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2016,2018 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of Mes.
 ;;;
@@ -25,11 +25,14 @@
 
 ;;; Code:
 
+(mes-use-module (mes let))
+(mes-use-module (mes scm))
 (mes-use-module (mes guile))
 (mes-use-module (mes pretty-print))
 (mes-use-module (mes psyntax))
 (mes-use-module (srfi srfi-13))
-(mes-use-module (srfi srfi-9-psyntax))
+;;(mes-use-module (srfi srfi-9-psyntax))
+;;(mes-use-module (srfi srfi-9))
 (mes-use-module (mes pmatch))
 (include-from-path "mes/peg/cache.scm")
 (include-from-path "mes/peg/codegen.scm")

diff --git a/module/mes/psyntax.mes b/module/mes/psyntax.mes
index 5618f12f9937e37ee6239c8a4b8e63369786e7c9..abaa9969845d5708d0e935e52fd0efcc449df2e8 100644 (file)
--- a/module/mes/psyntax.mes
+++ b/module/mes/psyntax.mes
@@ -22,22 +22,7 @@
 
 ;;; Code:
 
-(define (env:define a+ a)
-  (set-cdr! a+ (cdr a))
-  (set-cdr! a a+)
-  (set-cdr! (assq (quote *closure*) a) a+)
-  (car a+))
-
-(define-macro (define ARGS . BODY)
-  (cons* (quote env:define)
-         (cons* (quote cons)
-                (cons* (quote sexp:define)
-                       (list (quote quote)
-                             (cons (quote DEFINE) (cons ARGS BODY)))
-                       (quote ((current-module))))
-                (quote ((list))))
-         (quote ((current-module)))))
-
+(mes-use-module (mes scm))
 (mes-use-module (mes psyntax-0))
 (include-from-path "mes/psyntax.pp")
 (mes-use-module (mes psyntax-1))

diff --git a/scripts/repl.mes b/scripts/repl.mes
index d086e58fd85106d902d7028fb9d15fe69608d4e0..56f4d38514c1b0369b5eb3fabeca9251b8faa184 100755 (executable)
--- a/scripts/repl.mes
+++ b/scripts/repl.mes
@@ -10,7 +10,7 @@ exit $?
 !#
 
 ;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of Mes.
 ;;;
@@ -27,6 +27,10 @@ exit $?
 ;;; 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 repl))
+(mes-use-module (mes syntax))
+(primitive-load 0)
+
 (let* ((files (cdr (command-line)))
        (file (if (pair? files) (car files)))
        (file (if (and (equal? file "--") (pair? files) (pair? (cdr files))) (cadr files) file)))
@@ -37,9 +41,6 @@ exit $?
            (format (current-error-port) "mescc.mes (mes) ~a\n" %version)
            (exit 0))))
 
-;;(mes-use-module (mes scm))
-(mes-use-module (mes syntax))
-(mes-use-module (mes repl))
-
 (repl)
 ()
+

diff --git a/src/mes.c b/src/mes.c
index 8788bc5d93933d9a28961344996c00fbd5a06251..11b828b04270081078c51f9a7d10e0417cadc07c 100644 (file)
--- a/src/mes.c
+++ b/src/mes.c
@@ -189,13 +189,25 @@ struct scm scm_vm_eval_null_p = {TSPECIAL, "*vm-eval-null-p*",0};
 struct scm scm_vm_eval_define = {TSPECIAL, "*vm-eval-define*",0};
 
 struct scm scm_vm_eval_set_x = {TSPECIAL, "*vm-eval-set!*",0};
-struct scm scm_vm_eval_macro = {TSPECIAL, "*vm-eval-macro*",0};
+struct scm scm_vm_eval_macro_expand_eval = {TSPECIAL, "*vm:eval-macro-expand-eval*",0};
+struct scm scm_vm_eval_macro_expand_expand = {TSPECIAL, "*vm:eval-macro-expand-expand*",0};
 struct scm scm_vm_eval_check_func = {TSPECIAL, "*vm-eval-check-func*",0};
 struct scm scm_vm_eval2 = {TSPECIAL, "*vm-eval2*",0};
 struct scm scm_vm_macro_expand = {TSPECIAL, "core:macro-expand",0};
+struct scm scm_vm_macro_expand_define = {TSPECIAL, "*vm:core:macro-expand-define*",0};
+struct scm scm_vm_macro_expand_define_macro = {TSPECIAL, "*vm:core:macro-expand-define-macro*",0};
+struct scm scm_vm_macro_expand_lambda = {TSPECIAL, "*vm:core:macro-expand-lambda*",0};
+struct scm scm_vm_macro_expand_set_x = {TSPECIAL, "*vm:core:macro-expand-set!*",0};
+struct scm scm_vm_begin_expand_primitive_load = {TSPECIAL, "*vm:core:begin-expand-primitive-load*",0};
+struct scm scm_vm_begin_primitive_load = {TSPECIAL, "*vm:core:begin-primitive-load*",0};
+struct scm scm_vm_macro_expand_car = {TSPECIAL, "*vm:core:macro-expand-car*",0};
+struct scm scm_vm_macro_expand_cdr = {TSPECIAL, "*vm:macro-expand-cdr*",0};
+struct scm scm_vm_begin_expand = {TSPECIAL, "*vm:begin-expand*",0};
+struct scm scm_vm_begin_expand_eval = {TSPECIAL, "*vm:begin-expand-eval*",0};
+struct scm scm_vm_begin_expand_macro = {TSPECIAL, "*vm:begin-expand-macro*",0};
 struct scm scm_vm_begin = {TSPECIAL, "*vm-begin*",0};
 struct scm scm_vm_begin_read_input_file = {TSPECIAL, "*vm-begin-read-input-file*",0};
-struct scm scm_vm_begin2 = {TSPECIAL, "*vm-begin2*",0};
+struct scm scm_vm_begin_eval = {TSPECIAL, "*vm:begin-eval*",0};
 struct scm scm_vm_if = {TSPECIAL, "*vm-if*",0};
 struct scm scm_vm_if_expr = {TSPECIAL, "*vm-if-expr*",0};
 struct scm scm_vm_call_with_values2 = {TSPECIAL, "*vm-call-with-values2*",0};
@@ -741,6 +753,7 @@ gc_pop_frame () ///((internal))
 SCM
 eval_apply ()
 {
+  int expanding_p = 0;
  eval_apply:
   gc_check ();
   switch (r3)
@@ -759,13 +772,24 @@ eval_apply ()
 #endif
     case cell_vm_eval_define: goto eval_define;
     case cell_vm_eval_set_x: goto eval_set_x;
-    case cell_vm_eval_macro: goto eval_macro;
+    case cell_vm_eval_macro_expand_eval: goto eval_macro_expand_eval;
+    case cell_vm_eval_macro_expand_expand: goto eval_macro_expand_expand;
     case cell_vm_eval_check_func: goto eval_check_func;
     case cell_vm_eval2: goto eval2;
     case cell_vm_macro_expand: goto macro_expand;
+    case cell_vm_macro_expand_define: goto macro_expand_define;
+    case cell_vm_macro_expand_define_macro: goto macro_expand_define_macro;
+    case cell_vm_macro_expand_lambda: goto macro_expand_lambda;
+    case cell_vm_macro_expand_set_x: goto macro_expand_set_x;
+    case cell_vm_macro_expand_car: goto macro_expand_car;
+    case cell_vm_macro_expand_cdr: goto macro_expand_cdr;
     case cell_vm_begin: goto begin;
-    case cell_vm_begin_read_input_file: goto begin_read_input_file;
-    case cell_vm_begin2: goto begin2;
+    case cell_vm_begin_eval: goto begin_eval;
+    case cell_vm_begin_primitive_load: goto begin_primitive_load;
+    case cell_vm_begin_expand: goto begin_expand;
+    case cell_vm_begin_expand_eval: goto begin_expand_eval;
+    case cell_vm_begin_expand_macro: goto begin_expand_macro;
+    case cell_vm_begin_expand_primitive_load: goto begin_expand_primitive_load;
     case cell_vm_if: goto vm_if;
     case cell_vm_if_expr: goto if_expr;
     case cell_vm_call_with_current_continuation2: goto call_with_current_continuation2;
@@ -914,6 +938,12 @@ eval_apply ()
             eval_null_p:
               x = r1; gc_pop_frame (); r1 = null_p (x); goto eval_apply;
             }
+#else
+          eval_car:;
+          eval_cdr:;
+          eval_cons:;
+          eval_null_p:;
+            
 #endif // MES_FIXED_PRIMITIVES
           case cell_symbol_quote:
             {
@@ -937,8 +967,15 @@ eval_apply ()
             }
           case cell_vm_macro_expand:
             {
-              push_cc (CADR (r1), r1, r0, cell_vm_macro_expand);
+              push_cc (CADR (r1), r1, r0, cell_vm_eval_macro_expand_eval);
               goto eval;
+            eval_macro_expand_eval:
+              push_cc (r1, r2, r0, cell_vm_eval_macro_expand_expand);
+              expanding_p++;
+              goto macro_expand;
+            eval_macro_expand_expand:
+              expanding_p--;
+              goto vm_return;
             }
           default:
             {
@@ -978,10 +1015,10 @@ eval_apply ()
                 }
               push_cc (CAR (r1), r1, r0, cell_vm_eval_check_func); goto eval;
             eval_check_func:
-            push_cc (CDR (r2), r2, r0, cell_vm_eval2); goto evlis;
+              push_cc (CDR (r2), r2, r0, cell_vm_eval2); goto evlis;
             eval2:
-            r1 = cons (CAR (r2), r1);
-            goto apply;
+              r1 = cons (CAR (r2), r1);
+              goto apply;
           }
           }
       }
@@ -993,74 +1030,186 @@ eval_apply ()
     default: goto vm_return;
     }
 
-  SCM macro;
-  SCM expanders;
  macro_expand:
-  if (TYPE (r1) == TPAIR
-      && (macro = lookup_macro_ (CAR (r1), r0)) != cell_f)
-    {
-      r1 = cons (macro, CDR (r1));
-      goto apply;
-    }
-  else if (TYPE (r1) == TPAIR
-           && TYPE (CAR (r1)) == TSYMBOL
-           && ((expanders = assq_ref_env (cell_symbol_sc_expander_alist, r0)) != cell_undefined)
-           && ((macro = assq (CAR (r1), expanders)) != cell_f))
-    {
-      SCM sc_expand = assq_ref_env (cell_symbol_macro_expand, r0);
-      if (sc_expand != cell_undefined && sc_expand != cell_f)
-        {
-          r1 = cons (sc_expand, cons (r1, cell_nil));
-          goto apply;
-        }
-    }
-  goto vm_return;
+  {
+    SCM macro;
+    SCM expanders;
 
- begin:
-  x = cell_unspecified;
-  while (r1 != cell_nil) {
-    gc_check ();
-    if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR)
+    if (TYPE (r1) != TPAIR || CAR (r1) == cell_symbol_quote)
+      goto vm_return;
+
+    if (TYPE (r1) == TPAIR
+        && (macro = lookup_macro_ (CAR (r1), r0)) != cell_f)
+      {
+        r1 = cons (macro, CDR (r1));
+        push_cc (r1, cell_nil, r0, cell_vm_macro_expand);
+        goto apply;
+      }
+    if (CAR (r1) == cell_symbol_define
+        || CAR (r1) == cell_symbol_define_macro)
       {
-        if (CAAR (r1) == cell_symbol_begin)
-          r1 = append2 (CDAR (r1), CDR (r1));
-        else if (CAAR (r1) == cell_symbol_primitive_load)
+        push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_define);
+        goto macro_expand;
+      macro_expand_define:
+        CDDR (r2) = r1;
+        r1 = r2;
+        if (CAR (r1) == cell_symbol_define_macro)
           {
-            // push_cc (cons (cell_symbol_read_input_file, cell_nil), r1, r0, cell_vm_begin_read_input_file);
-            // goto apply;
-
-            push_cc (CAR (CDAR (r1)), r1, r0, cell_vm_begin_read_input_file);
-            goto eval; // FIXME: expand too?!
-          begin_read_input_file:;
-            SCM input = r1;
-            if ((TYPE (r1) == TNUMBER && VALUE (r1) == 0))
-              ;
-            else
-              input = set_current_input_port (open_input_file (r1));
-            push_cc (input, r2, r0, cell_vm_return);
-            x = read_input_file_env (r0);
-            gc_pop_frame ();
-            r1 = x;
-            input = r1;
-#if DEBUG
-            eputs ("  ..2.r2="); write_error_ (r2); eputs ("\n");
-            eputs ("  => result r1="); write_error_ (r1); eputs ("\n");
-#endif
-            set_current_input_port (input);
-            r1 = append2 (r1, cons (cell_t, CDR (r2)));
+            push_cc (r1, r1, r0, cell_vm_macro_expand_define_macro);
+            goto eval;
+          macro_expand_define_macro:
+            r1 = r2;
           }
+        goto vm_return;
       }
-    if (CDR (r1) == cell_nil)
+
+    if (CAR (r1) == cell_symbol_lambda)
+      {
+        push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_lambda);
+        goto macro_expand;
+      macro_expand_lambda:
+        CDDR (r2) = r1;
+        r1 = r2;
+        goto vm_return;
+      }
+
+    if (CAR (r1) == cell_symbol_set_x)
+      {
+        push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_set_x);
+        goto macro_expand;
+      macro_expand_set_x:
+        CDDR (r2) = r1;
+        r1 = r2;
+        goto vm_return;
+      }
+
+    if (TYPE (r1) == TPAIR
+        && TYPE (CAR (r1)) == TSYMBOL
+        && CAR (r1) != cell_symbol_begin
+        && ((expanders = assq_ref_env (cell_symbol_sc_expander_alist, r0)) != cell_undefined)
+        && ((macro = assq (CAR (r1), expanders)) != cell_f))
       {
-        r1 = CAR (r1);
-        goto eval;
+        SCM sc_expand = assq_ref_env (cell_symbol_macro_expand, r0);
+        r2 = r1;
+        if (sc_expand != cell_undefined && sc_expand != cell_f)
+          {
+            r1 = cons (sc_expand, cons (r1, cell_nil));
+            goto apply;
+          }
       }
-    push_cc (CAR (r1), r1, r0, cell_vm_begin2);
-    goto eval;
-  begin2:
-    x = r1;
-    r1 = CDR (r2);
+
+    push_cc (CAR (r1), r1, r0, cell_vm_macro_expand_car);
+    goto macro_expand;
+
+  macro_expand_car:
+    CAR (r2) = r1;
+    r1 = r2;
+    if (CDR (r1) == cell_nil)
+      goto vm_return;
+
+    push_cc (CDR (r1), r1, r0, cell_vm_macro_expand_cdr);
+    goto macro_expand;
+
+  macro_expand_cdr:
+    CDR (r2) = r1;
+    r1 = r2;
+
+    goto vm_return;
   }
+
+ begin:
+  x = cell_unspecified;
+  while (r1 != cell_nil)
+    {
+      gc_check ();
+      if (TYPE (r1) == TPAIR)
+        {
+          if (CAAR (r1) == cell_symbol_primitive_load)
+            {
+              SCM program = cons (CAR (r1), cell_nil);
+              push_cc (program, r1, r0, cell_vm_begin_primitive_load);
+              goto begin_expand;
+            begin_primitive_load:
+              CAR (r2) = r1;
+              r1 = r2;
+            }
+        }
+
+      if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR)
+        {
+          if (CAAR (r1) == cell_symbol_begin)
+            r1 = append2 (CDAR (r1), CDR (r1));
+        }
+      if (CDR (r1) == cell_nil)
+        {
+          r1 = CAR (r1);
+          goto eval;
+        }
+      push_cc (CAR (r1), r1, r0, cell_vm_begin_eval);
+      goto eval;
+    begin_eval:
+      x = r1;
+      r1 = CDR (r2);
+    }
+  r1 = x;
+  goto vm_return;
+
+
+ begin_expand:
+  x = cell_unspecified;
+  while (r1 != cell_nil)
+    {
+      gc_check ();
+
+      if (TYPE (r1) == TPAIR)
+        {
+          if (TYPE (CAR (r1)) == TPAIR && CAAR (r1) == cell_symbol_begin)
+            r1 = append2 (CDAR (r1), CDR (r1));
+          if (CAAR (r1) == cell_symbol_primitive_load)
+            {
+              push_cc (CADR (CAR (r1)), r1, r0, cell_vm_begin_expand_primitive_load);
+              goto eval; // FIXME: expand too?!
+            begin_expand_primitive_load:;
+              SCM input; // = current_input_port ();
+              if (TYPE (r1) == TNUMBER && VALUE (r1) == 0)
+                ;
+              else if (TYPE (r1) == TSTRING)
+                input = set_current_input_port (open_input_file (r1));
+              else
+                assert (0);
+              
+              push_cc (input, r2, r0, cell_vm_return);
+              x = read_input_file_env (r0);
+              gc_pop_frame ();
+              input = r1;
+              r1 = x;
+              set_current_input_port (input);
+              r1 = cons (cell_symbol_begin, r1);
+              CAR (r2) = r1;
+              r1 = r2;
+              continue;
+            }
+        }
+
+      push_cc (CAR (r1), r1, r0, cell_vm_begin_expand_macro);
+      expanding_p++;
+      goto macro_expand;
+    begin_expand_macro:
+      expanding_p--;
+      if (r1 != CAR (r2))
+        {
+          CAR (r2) = r1;
+          r1 = r2;
+          continue;
+        }
+      r1 = r2;
+
+      push_cc (CAR (r1), r1, r0, cell_vm_begin_expand_eval);
+      goto eval;
+    begin_expand_eval:
+      x = r1;
+      r1 = CDR (r2);
+    }
   r1 = x;
   goto vm_return;
 
@@ -1481,6 +1630,7 @@ main (int argc, char *argv[])
 
   SCM lst = cell_nil;
   for (int i=argc-1; i>=0; i--) lst = cons (MAKE_STRING (cstring_to_list (argv[i])), lst);
+  r0 = acons (cell_symbol_argv, lst, r0); // FIXME
   r0 = acons (cell_symbol_argv, lst, r0);
   push_cc (r2, cell_unspecified, r0, cell_unspecified);
   if (g_debug > 1)
@@ -1489,14 +1639,14 @@ main (int argc, char *argv[])
       write_error_ (r1);
       eputs ("\n");
     }
-  r3 = cell_vm_begin;
+  r3 = cell_vm_begin_expand;
   r1 = eval_apply ();
   write_error_ (r1);
   eputs ("\n");
   gc (g_stack);
   if (g_debug)
     {
-      eputs ("\nstats: [");
+      eputs ("\ngc stats: [");
       eputs (itoa (g_free));
       eputs ("]\n");
     }

diff --git a/src/posix.c b/src/posix.c
index 95b4df73ab7899ef0b6316d2fdd90dea4789c1d7..fe7c9b381377b4f3f66c080bae6277643f7375e9 100644 (file)
--- a/src/posix.c
+++ b/src/posix.c
@@ -1,6 +1,6 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * Mes --- Maxwell Equations of Software
- * Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2016,2017,2018 Jan Nieuwenhuizen <janneke@gnu.org>
  *
  * This file is part of Mes.
  *
@@ -156,8 +156,9 @@ open_input_file (SCM file_name)
 SCM
 set_current_input_port (SCM port)
 {
+  int prev = g_stdin;
   g_stdin = VALUE (port) ? VALUE (port) : STDIN;
-  return current_input_port ();
+  return MAKE_NUMBER (prev);
 }
 
 SCM

diff --git a/tests/psyntax.test b/tests/psyntax.test
index 701f0b057705e6d6389b3e5ce2a7d704a2a8c46d..71ef46c1d0e333c28454dbfb57a6ebb88f33afed 100755 (executable)
--- a/tests/psyntax.test
+++ b/tests/psyntax.test
@@ -9,7 +9,7 @@ exit $?
 ;;; -*-scheme-*-
 
 ;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2016,2018 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of Mes.
 ;;;
@@ -46,17 +46,19 @@ exit $?
 (pass-if "first dummy" #t)
 (pass-if-not "second dummy" #f)
 
-(when (not guile?)
- (pass-if "andmap"
-   (seq? (andmap (lambda (x) (> x 0)) '(3 2 1)) #t))
+(cond-expand
+ (guile)
+ (mes
+  (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 "andmap 2"
+    (seq? (andmap (lambda (x) (> x 0)) '(3 2 1 0)) #f))
 
- (pass-if "putprop" (putprop 'foo '*sc-expander 'bar))
+  (pass-if "putprop" (putprop 'foo '*sc-expander 'bar))
 
- (pass-if "getprop"
-   (seq? (getprop 'foo '*sc-expander) 'bar))
+  (pass-if "getprop"
+    (seq? (getprop 'foo '*sc-expander) 'bar)))
  )
 
 (pass-if "syntax-case"
@@ -76,84 +78,97 @@ exit $?
   (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
-             ((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!
-       (lambda (exp)
-         (syntax-case exp ()
-           ((swap! a b)
-            (syntax
-             (let ((temp a))
+(pass-if-equal "syntax-case swap!"
+    '((lambda (temp)
+        (set! a b)
+        (set! b temp))
+      a)
+  (syntax-object->datum
+   (let ((exp '(set! a b)))
+     (syntax-case exp ()
+       ((swap! a b)
+        (syntax
+         ((lambda (temp)
+            (set! a b)
+            (set! b temp))
+          a)))))))
+
+(pass-if-equal "syntax-case swap! let"
+    '(let ((temp a)) (set! a b) (set! b temp))
+  (syntax-object->datum
+   (let ((exp '(set! a b)))
+     (syntax-case exp ()
+       ((swap! a b)
+        (syntax
+         (let ((temp a))
+           (set! a b)
+           (set! b temp))))))))
+
+(cond-expand
+ (guile)
+ (mes
+  (pass-if-equal "syntax-case manual swap!"
+      '("bar" "foo")
+    (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))
+           (e (core:macro-expand d)))
+      (eval e (current-module))
+      (list foo bar)))))
+
+(pass-if-equal "define-syntax swap! [syntax-case]"
+    (list "bar" "foo")
+  (let ()
+    (define-syntax swap!
+      (lambda (exp)
+        (syntax-case exp ()
+          ((swap! a b)
+           (syntax
+            ((lambda (temp)
                (set! a b)
-               (set! b temp)))))))
-     (let ((foo "foo")
-           (bar "bar"))
-       (swap! foo bar)
-       (list foo bar)))
-   (list "bar" "foo")))
-
-(pass-if "define-syntax sr:when [syntax-rules]"
-  (sequal?
-   (let ()
-     (define-syntax sr:when
-       (syntax-rules ()
-         ((sc:when condition exp ...)
-          (if condition
-              (begin exp ...)))))
-     (let ()
-       (sr:when #t "if not now, then?")))
-   "if not now, then?"))
-
-(pass-if "define-syntax-rule"
-  (sequal?
-   (let ()
-     (define-syntax-rule (sre:when c e ...)
-       (if c (begin e ...)))
-     (let ()
-       (sre:when #t "if not now, then?")))
-   "if not now, then?"))
+               (set! b temp)) a))))))
+    (let ((foo "foo")
+          (bar "bar"))
+      (swap! foo bar)
+      (list foo bar))))
+
+(pass-if-equal "define-syntax swap! [syntax-case+let]"
+  (list "bar" "foo")
+  (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))))
+
+(pass-if-equal "define-syntax sr:when [syntax-rules]"
+    "if not now, then?"
+  (let ()
+    (define-syntax sr:when
+      (syntax-rules ()
+        ((sc:when condition exp ...)
+         (if condition
+             (begin exp ...)))))
+    (let ()
+      (sr:when #t "if not now, then?"))))
+
+(pass-if-equal "define-syntax-rule"
+    "if not now, then?"
+  (let ()
+    (define-syntax-rule (sre:when c e ...)
+      (if c (begin e ...)))
+    (let ()
+      (sre:when #t "if not now, then?"))))
 
 (pass-if-equal "syntax-rules plus"
     (+ 1 2 3)
@@ -163,7 +178,8 @@ exit $?
         ((plus x ...) (+ x ...))))
     (plus 1 2 3)))
 
-(when guile?
+(cond-expand
+ (guile
   (pass-if-equal "macro with quasisyntax"
       '("foo" "foo")
     (let ()
@@ -174,6 +190,7 @@ exit $?
              #`(let ((id #,(symbol->string (syntax->datum #'id))))
                  body ...)))))
       (string-let foo (list foo foo)))))
+ (mes))
 
   ;; (pass-if-equal "custom ellipsis within normal ellipsis"
   ;;     '((((a x) (a y) (a …))