mes: Single environment lookup for variables, SICP chapter 3.

* src/mes.c (t): Add TVARIABLE.
  (scm_vm_eval_deref): New vm special.
  (make_vref_): New internal function.
  (eval_apply): WIP: replace symbols with their variable reference.
* src/gc.c (gc_loop): Handle TVARIABLE.
* src/lib.c (display_helper): Handle TVARIABLE.
* module/mes/type-0.mes (<cell:variable>): New variable.
  (cell:type-alist): Add it.
  (variable?): New function.
* module/mes/display.mes (display): Handle <variable>.

make.scm

@@ -434,9 +434,7 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$
    (add-target (snarf "src/vector.c" #:mes? #t))))
 
 (add-target (bin.gcc "src/mes.c" #:dependencies gcc-snarf-targets
-                     #:defines `("MES_FIXED_PRIMITIVES=1"
+                     #:defines `("POSIX=1"
-                                 "MES_FULL=1"
-                                 "POSIX=1"
                                  ,(string-append "VERSION=\"" %version "\"")
                                  ,(string-append "MODULEDIR=\"" (string-append %prefix (if (string-null? %prefix) "" "/") %moduledir "/") "\"")
                                  ,(string-append "PREFIX=\"" %prefix "\""))
@@ -444,17 +442,13 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$
 
 (add-target (bin.gcc "src/mes.c" #:libc libc-gcc.mlibc-o
                      #:dependencies mes-snarf-targets
-                     #:defines `( "MES_FIXED_PRIMITIVES=1"
+                     #:defines `(,(string-append "VERSION=\"" %version "\"")
-                                 "MES_FULL=1"
-                                 ,(string-append "VERSION=\"" %version "\"")
                                  ,(string-append "MODULEDIR=\"" (string-append %prefix (if (string-null? %prefix) "" "/") "/" %moduledir "/") "\"")
                                  ,(string-append "PREFIX=\"" %prefix "\""))
                      #:includes '("src")))
 
 (add-target (bin.mescc "src/mes.c" #:dependencies mes-snarf-targets
-                       #:defines `("MES_FIXED_PRIMITIVES=1"
+                       #:defines `(,(string-append "VERSION=\"" %version "\"")
-                                   "MES_FULL=1"
-                                   ,(string-append "VERSION=\"" %version "\"")
                                    ,(string-append "MODULEDIR=\"" (string-append %prefix (if (string-null? %prefix) "" "/") %moduledir "/") "\"")
                                    ,(string-append "PREFIX=\"" %prefix "\""))
                        #:includes '("src")))

module/language/c99/compiler.mes

@@ -1223,8 +1223,8 @@
                 (info (append-text info (wrap-as `((#:label ,skip-b-label))))))
            info))
 
-        ((cast ,cast ,o)
+        ((cast ,type ,expr)
-         ((expr->accu info) o))
+         ((expr->accu info) expr))
 
         ((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b)
          (let* ((info ((expr->accu info) `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b)))

module/mes/boot-0.scm

@@ -75,7 +75,9 @@
   (if (null? lst) (list)
       (cons (f (car lst)) (map1 f (cdr lst)))))
 
-(define map map1)
+(define (map f lst)
+  (if (null? lst) (list)
+      (cons (f (car lst)) (map f (cdr lst)))))
 
 (define (cons* . rest)
   (if (null? (cdr rest)) (car rest)
@@ -104,6 +106,7 @@
                       (list (quote if) (quote r) (quote r)
                             (cons (quote or) (cdr x))))
                 (car x)))))
+
 (define-macro (module-define! module name value)
   ;;(list 'define name value)
   #t)

module/mes/display.mes

@@ -95,6 +95,12 @@
         (display "#<macro " port)
         (display (core:cdr x) port)
         (display ">" port))
+       ((variable? x)
+        (display "#<variable " port)
+        (if (variable-global? x)
+            (display "*global* " port))
+        (display (car (core:car x)) port)
+        (display ">" port))
        ((number? x)
         (display (number->string x) port))
        ((pair? x)

module/mes/guile.scm

@@ -35,12 +35,16 @@
             core:write-error
             core:write-port
             core:type
+            pmatch-car
+            pmatch-cdr
             )
   ;;#:re-export (open-input-file open-input-string with-input-from-string)
   )
 
 (cond-expand
  (guile
+  (define pmatch-car car)
+  (define pmatch-cdr cdr)
   (define core:exit exit)
   (define core:display display)
   (define core:display-port display)

module/mes/module.mes

@@ -26,15 +26,6 @@
   (string-append (string-join (map symbol->string o) "/") ".mes"))
 
 (define *modules* '(mes/base-0.mes))
-(define (mes-load-module-env module a)
-  (push! *input-ports* (current-input-port))
-  (set-current-input-port (open-input-file (string-append %moduledir (module->file module))))
-  (let ((x (core:eval (append2 (cons 'begin (read-input-file-env a))
-                               '((current-module)))
-                      a)))
-    (set-current-input-port (pop! *input-ports*))
-    x))
-
 (define-macro (mes-use-module module)
   (list 'if (list not (list memq (list string->symbol (module->file module)) '*modules*))
         (list
@@ -46,3 +37,28 @@
                     (list core:display-error ";;; already loaded: ")
                     (list core:display-error (list 'quote module))
                     (list core:display-error "\n")))))
+
+(define *input-ports* '())
+(define-macro (push! stack o)
+  (cons
+   'begin
+   (list
+    (list 'set! stack (list cons o stack))
+    stack)))
+(define-macro (pop! stack)
+  (list 'let (list (list 'o (list car stack)))
+        (list 'set! stack (list cdr stack))
+        'o))
+(define (mes-load-module-env module a)
+  (push! *input-ports* (current-input-port))
+  (set-current-input-port (open-input-file (string-append %moduledir (module->file module))))
+  (let ((x (core:eval (append2 (cons 'begin (read-input-file-env a))
+                               '((current-module)))
+                      a)))
+    (set-current-input-port (pop! *input-ports*))
+    x))
+(define (mes-load-module-env module a)
+  (core:display-error "loading:") (core:write-error (string-append %moduledir (module->file module))) (core:display-error "\n")
+  (primitive-load (string-append %moduledir (module->file module)))
+  (core:display-error "dun\n")
+  )

module/mes/pmatch.scm

@@ -3,6 +3,7 @@
 ;;; Copyright (C) 2009, 2010, 2012 Free Software Foundation, Inc
 ;;; Copyright (C) 2005,2006,2007 Oleg Kiselyov
 ;;; Copyright (C) 2007 Daniel P. Friedman
+;;; Copyright (C) 2018 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This library is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public
@@ -51,20 +52,17 @@
 (define-module (system base pmatch)
   #:export-syntax (pmatch))
 
-(define-syntax-rule (pmatch e cs ...)
+(define-syntax pmatch
-  (let ((v e)) (pmatch1 v cs ...)))
-
-(define-syntax pmatch1
   (syntax-rules (else guard)
     ((_ v) (if #f #f))
     ((_ v (else e0 e ...)) (let () e0 e ...))
     ((_ v (pat (guard g ...) e0 e ...) cs ...)
-     (let ((fk (lambda () (pmatch1 v cs ...))))
+     (let ((fk (lambda () (pmatch v cs ...))))
        (ppat v pat
              (if (and g ...) (let () e0 e ...) (fk))
              (fk))))
     ((_ v (pat e0 e ...) cs ...)
-     (let ((fk (lambda () (pmatch1 v cs ...))))
+     (let ((fk (lambda () (pmatch v cs ...))))
        (ppat v pat (let () e0 e ...) (fk))))))
 
 (define-syntax ppat
@@ -76,8 +74,6 @@
     ((_ v (unquote var) kt kf) (let ((var v)) kt))
     ((_ v (x . y) kt kf)
      (if (pair? v)
-         (let ((vx (car v)) (vy (cdr v)))
+         (ppat (pmatch-car v) x (ppat (pmatch-cdr v) y kt kf) kf)
-           ;;(ppat vx x (ppat vy y kt kf) kf) ;; FIXME: broken with syntax.scm
-           (ppat (car v) x (ppat (cdr v) y kt kf) kf))
          kf))
     ((_ v lit kt kf) (if (eq? v (quote lit)) kt kf))))

module/mes/psyntax-1.mes

@@ -27,5 +27,6 @@
 
 (define datum->syntax datum->syntax-object)
 (define syntax->datum syntax-object->datum)
+(define-macro (portable-macro-expand) #t)
 (set! macro-expand sc-expand)
 

module/mes/type-0.mes

@@ -38,8 +38,9 @@
 (define <cell:string> 10)
 (define <cell:symbol> 11)
 (define <cell:values> 12)
-(define <cell:vector> 13)
+(define <cell:variable> 13)
-(define <cell:broken-heart> 14)
+(define <cell:vector> 14)
+(define <cell:broken-heart> 15)
 
 (define cell:type-alist
   (list (cons <cell:char> (quote <cell:char>))
@@ -55,6 +56,7 @@
         (cons <cell:string> (quote <cell:string>))
         (cons <cell:symbol> (quote <cell:symbol>))
         (cons <cell:values> (quote <cell:values>))
+        (cons <cell:variable> (quote <cell:variable>))
         (cons <cell:vector> (quote <cell:vector>))
         (cons <cell:broken-heart> (quote <cell:broken-heart>))))
 
@@ -104,10 +106,15 @@
 (define (symbol? x)
   (eq? (core:type x) <cell:symbol>))
 
-;; Hmm?
 (define (values? x)
   (eq? (core:type x) <cell:values>))
 
+(define (variable? x)
+  (eq? (core:type x) <cell:variable>))
+
+(define (variable-global? x)
+  (core:cdr x))
+
 (define (vector? x)
   (eq? (core:type x) <cell:vector>))
 

scaffold/boot/51-module.scm

@@ -111,4 +111,4 @@
 (core:display-error module->file) (core:display-error "\n")
 (define %moduledir (string-append (getcwd) "/"))
 (mes-use-module (scaffold boot data module))
-(mes-use-module (scaffold boot data module))
+;; (mes-use-module (scaffold boot data module))

src/gc.c

@@ -102,7 +102,8 @@ gc_loop (SCM scan) ///((internal))
           || scan == 1 // null
           || NTYPE (scan) == TSPECIAL
           || NTYPE (scan) == TSTRING
-          || NTYPE (scan) == TSYMBOL)
+          || NTYPE (scan) == TSYMBOL
+          || NTYPE (scan) == TVARIABLE)
         {
           SCM car = gc_copy (g_news[scan].car);
           gc_relocate_car (scan, car);
@@ -111,7 +112,8 @@ gc_loop (SCM scan) ///((internal))
            || NTYPE (scan) == TCONTINUATION
            || NTYPE (scan) == TMACRO
            || NTYPE (scan) == TPAIR
-           || NTYPE (scan) == TVALUES)
+           || NTYPE (scan) == TVALUES
+           || NTYPE (scan) == TVARIABLE)
           && g_news[scan].cdr) // allow for 0 terminated list of symbols
         {
           SCM cdr = gc_copy (g_news[scan].cdr);
@@ -133,7 +135,8 @@ gc_check ()
 SCM
 gc ()
 {
-  if (g_debug == 1) eputs (".");
+  if (g_debug == 1)
+    eputs (".");
   if (g_debug > 1)
     {
       eputs (";;; gc[");
@@ -143,11 +146,13 @@ gc ()
       eputs ("]...");
     }
   g_free = 1;
-  if (g_cells < g_news && ARENA_SIZE < MAX_ARENA_SIZE) gc_up_arena ();
+  if (g_cells < g_news && ARENA_SIZE < MAX_ARENA_SIZE)
+    gc_up_arena ();
   for (int i=g_free; i<g_symbol_max; i++)
     gc_copy (i);
   make_tmps (g_news);
   g_symbols = gc_copy (g_symbols);
+  g_macros = gc_copy (g_macros);
   SCM new = gc_copy (g_stack);
   if (g_debug > 1)
     {

src/lib.c

@@ -56,7 +56,7 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
     case TCLOSURE:
       {
         fputs ("#<closure ", fd);
-        display_helper (CDR (x), cont, "", fd, 0);
+        //display_helper (CDR (x), cont, "", fd, 0);
         fputs (">", fd);
         break;
       }
@@ -81,6 +81,15 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
         fputs (">", fd);
         break;
       }
+    case TVARIABLE:
+      {
+        fputs ("#<variable ", fd);
+        if (VARIABLE_GLOBAL_P (x) == cell_t)
+          fputs ("*global* ", fd);
+        display_helper (CAR (VARIABLE (x)), cont, "", fd, 0);
+        fputs (">", fd);
+        break;
+      }
     case TNUMBER:
       {
         fputs (itoa (VALUE (x)), fd);
@@ -89,6 +98,12 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
     case TPAIR:
       {
         if (!cont) fputs ("(", fd);
+        if (CAR (x) == cell_closure)
+          fputs ("*closure* ", fd);
+        else
+        if (CAAR (x) == cell_closure)
+          fputs ("(*closure* ...) ", fd);
+        else
         if (CAR (x) == cell_circular)
           {
             fputs ("(*circ* . ", fd);
@@ -97,8 +112,8 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
             while (x != cell_nil && i++ < 10)
               {
                 g_depth = 1;
-                //display_helper (CAAR (x), 0, "", fd, write_p); fputs (" ", fd);
+                display_helper (CAAR (x), 0, "", fd, write_p); fputs (" ", fd);
-                fdisplay_ (CAAR (x), fd, write_p); fputs (" ", fd);
+                //fdisplay_ (CAAR (x), fd, write_p); fputs (" ", fd);
                 x = CDR (x);
               }
             fputs (" ...)", fd);

src/mes.c

@@ -32,7 +32,7 @@ int MAX_ARENA_SIZE = 80000000; // 32b: ~1GiB
 int MAX_ARENA_SIZE = 200000000; // 32b: 2GiB, 64b: 4GiB
 #endif
 
-int GC_SAFETY = 250;
+int GC_SAFETY = 2000;
 
 char *g_arena = 0;
 typedef int SCM;
@@ -51,8 +51,11 @@ SCM r1 = 0;
 SCM r2 = 0;
 // continuation
 SCM r3 = 0;
+// macro
+SCM g_macros = 1; // cell_nil
 
-enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVECTOR, TBROKEN_HEART};
+
+enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART};
 
 #if !_POSIX_SOURCE
 struct scm {
@@ -86,9 +89,10 @@ struct scm {
   enum type_t type;
   union {
     char const* name;
-    SCM string;
     SCM car;
     SCM ref;
+    SCM string;
+    SCM variable;
     int length;
   };
   union {
@@ -97,6 +101,7 @@ struct scm {
     SCM cdr;
     SCM closure;
     SCM continuation;
+    SCM global_p;
     SCM macro;
     SCM vector;
     int hits;
@@ -145,6 +150,7 @@ struct scm scm_symbol_set_x = {TSYMBOL, "set!",0};
 
 struct scm scm_symbol_sc_expand = {TSYMBOL, "sc-expand",0};
 struct scm scm_symbol_macro_expand = {TSYMBOL, "macro-expand",0};
+struct scm scm_symbol_portable_macro_expand = {TSYMBOL, "portable-macro-expand",0};
 struct scm scm_symbol_sc_expander_alist = {TSYMBOL, "*sc-expander-alist*",0};
 
 struct scm scm_symbol_call_with_values = {TSYMBOL, "call-with-values",0};
@@ -170,9 +176,8 @@ struct scm scm_symbol_mes_version = {TSYMBOL, "%version",0};
 
 struct scm scm_symbol_car = {TSYMBOL, "car",0};
 struct scm scm_symbol_cdr = {TSYMBOL, "cdr",0};
-struct scm scm_symbol_null_p = {TSYMBOL, "null?",0};
+struct scm scm_symbol_pmatch_car = {TSYMBOL, "pmatch-car",0};
-struct scm scm_symbol_eq_p = {TSYMBOL, "eq?",0};
+struct scm scm_symbol_pmatch_cdr = {TSYMBOL, "pmatch-cdr",0};
-struct scm scm_symbol_cons = {TSYMBOL, "cons",0};
 
 struct scm scm_vm_evlis = {TSPECIAL, "*vm-evlis*",0};
 struct scm scm_vm_evlis2 = {TSPECIAL, "*vm-evlis2*",0};
@@ -181,11 +186,8 @@ struct scm scm_vm_apply = {TSPECIAL, "core:apply",0};
 struct scm scm_vm_apply2 = {TSPECIAL, "*vm-apply2*",0};
 struct scm scm_vm_eval = {TSPECIAL, "core:eval",0};
 
-//MES_FIXED_PRIMITIVES
+struct scm scm_vm_eval_pmatch_car = {TSPECIAL, "*vm-eval-pmatch-car*",0};
-struct scm scm_vm_eval_car = {TSPECIAL, "*vm-eval-car*",0};
+struct scm scm_vm_eval_pmatch_cdr = {TSPECIAL, "*vm-eval-pmatch-cdr*",0};
-struct scm scm_vm_eval_cdr = {TSPECIAL, "*vm-eval-cdr*",0};
-struct scm scm_vm_eval_cons = {TSPECIAL, "*vm-eval-cons*",0};
-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};
@@ -262,11 +264,14 @@ int g_function = 0;
 #define LENGTH(x) g_cells[x].car
 #define REF(x) g_cells[x].car
 #define STRING(x) g_cells[x].car
+#define VARIABLE(x) g_cells[x].car
+#define VARIABLE_GLOBAL_P(x) g_cells[x].cdr
 
 #define CLOSURE(x) g_cells[x].cdr
 #define CONTINUATION(x) g_cells[x].cdr
 
 #define FUNCTION(x) g_functions[g_cells[x].cdr]
+#define FUNCTION0(x) g_functions[g_cells[x].cdr].function
 #define MACRO(x) g_cells[x].cdr
 #define VALUE(x) g_cells[x].cdr
 #define VECTOR(x) g_cells[x].cdr
@@ -282,12 +287,16 @@ int g_function = 0;
 #define LENGTH(x) g_cells[x].length
 #define NAME(x) g_cells[x].name
 #define STRING(x) g_cells[x].string
+#define VARIABLE(x) g_cells[x].variable
+#define VARIABLE_GLOBAL_P(x) g_cells[x].cdr
+
 #define CLOSURE(x) g_cells[x].closure
 #define MACRO(x) g_cells[x].macro
 #define REF(x) g_cells[x].ref
 #define VALUE(x) g_cells[x].value
 #define VECTOR(x) g_cells[x].vector
 #define FUNCTION(x) g_functions[g_cells[x].function]
+#define FUNCTION0(x) g_functions[g_cells[x].function].function0
 
 #define NLENGTH(x) g_news[x].length
 
@@ -342,15 +351,15 @@ make_cell_ (SCM type, SCM car, SCM cdr)
   TYPE (x) = VALUE (type);
   if (VALUE (type) == TCHAR || VALUE (type) == TNUMBER) {
     if (car) CAR (x) = CAR (car);
-    if (cdr) CDR(x) = CDR(cdr);
+    if (cdr) CDR (x) = CDR (cdr);
   }
   else if (VALUE (type) == TFUNCTION) {
     if (car) CAR (x) = car;
-    if (cdr) CDR(x) = CDR(cdr);
+    if (cdr) CDR (x) = CDR (cdr);
   }
   else {
     CAR (x) = car;
-    CDR(x) = cdr;
+    CDR (x) = cdr;
   }
   return x;
 }
@@ -654,8 +663,8 @@ assq (SCM x, SCM a)
         SCM v = STRING (x);
         while (a != cell_nil && v != STRING (CAAR (a))) a = CDR (a); break;
       }
-    // case TSYMBOL:
+      // case TSYMBOL:
-    // case TSPECIAL:
+      // case TSPECIAL:
     default:
       while (a != cell_nil && x != CAAR (a)) a = CDR (a); break;
     }
@@ -689,7 +698,11 @@ set_cdr_x (SCM x, SCM e)
 SCM
 set_env_x (SCM x, SCM e, SCM a)
 {
-  SCM p = assert_defined (x, assq (x, a));
+  SCM p;
+  if (TYPE (x) == TVARIABLE)
+    p = VARIABLE (x);
+  else
+    p = assert_defined (x, assq (x, a));
   if (TYPE (p) != TPAIR) error (cell_symbol_not_a_pair, cons (p, x));
   return set_cdr_x (p, e);
 }
@@ -709,12 +722,18 @@ make_closure_ (SCM args, SCM body, SCM a) ///((internal))
   return make_cell_ (tmp_num_ (TCLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body)));
 }
 
+SCM
+make_variable_ (SCM var, SCM global_p) ///((internal))
+{
+  return make_cell_ (tmp_num_ (TVARIABLE), var, global_p);
+}
+
 SCM
 lookup_macro_ (SCM x, SCM a) ///((internal))
 {
   if (TYPE (x) != TSYMBOL) return cell_f;
-  SCM m = assq_ref_env (x, a);
+  SCM m = assq (x, a);
-  if (TYPE (m) == TMACRO) return MACRO (m);
+  if (m != cell_f) return MACRO (CDR (m));
   return cell_f;
 }
 
@@ -750,10 +769,104 @@ gc_pop_frame () ///((internal))
   return frame;
 }
 
+char const* string_to_cstring (SCM s);
+
+SCM
+add_formals (SCM formals, SCM x)
+{
+  while (TYPE (x) == TPAIR)
+    {
+      formals = cons (CAR (x), formals);
+      x = CDR (x);
+    }
+  if (TYPE (x) == TSYMBOL)
+    formals = cons (x, formals);
+  return formals;
+}
+
+int
+formal_p (SCM x, SCM formals) /// ((internal))
+{
+  if (TYPE (formals) == TSYMBOL)
+    {
+      if (x == formals) return x;
+      else return cell_f;
+    }
+  while (TYPE (formals) == TPAIR && CAR (formals) != x)
+    formals = CDR (formals);
+  if (TYPE (formals) == TSYMBOL)
+    return formals == x;
+  return TYPE (formals) == TPAIR;
+}
+
+SCM
+expand_variable_ (SCM x, SCM formals, int top_p) ///((internal))
+{
+  while (TYPE (x) == TPAIR)
+    {
+      if (TYPE (CAR (x)) == TPAIR)
+        {
+          if (CAAR (x) == cell_symbol_lambda)
+            {
+              SCM f = CAR (CDAR (x));
+              formals = add_formals (formals, f);
+            }
+          else if (CAAR (x) == cell_symbol_define
+                   || CAAR (x) == cell_symbol_define_macro)
+            {
+              SCM f = CAR (CDAR (x));
+              formals = add_formals (formals, f);
+            }
+          if (CAAR (x) != cell_symbol_quote)
+            expand_variable_ (CAR (x), formals, 0);
+        }
+      else
+        {
+          if (CAR (x) == cell_symbol_lambda)
+            {
+              SCM f = CADR (x);
+              formals = add_formals (formals, f);
+              x = CDR (x);
+            }
+          else if (CAR (x) == cell_symbol_define
+                   || CAR (x) == cell_symbol_define_macro)
+            {
+              SCM f = CADR (x);
+              if (top_p && TYPE (f) == TPAIR)
+                f = CDR (f);
+              formals = add_formals (formals, f);
+              x = CDR (x);
+            }
+          else if (CAR (x) == cell_symbol_quote)
+            return cell_unspecified;
+          else if (TYPE (CAR (x)) == TSYMBOL
+                   && CAR (x) != cell_begin
+                   && CAR (x) != cell_symbol_begin
+                   && CAR (x) != cell_symbol_current_module
+                   && CAR (x) != cell_symbol_primitive_load
+                   && CAR (x) != cell_symbol_if // HMM
+                   && !formal_p (CAR (x), formals))
+            {
+              SCM v = assq (CAR (x), r0);
+              if (v != cell_f)
+                CAR (x) = make_variable_ (v, cell_t);
+            }
+        }
+      x = CDR (x);
+      top_p = 0;
+    }
+  return cell_unspecified;
+}
+
+SCM
+expand_variable (SCM x, SCM formals) ///((internal))
+{
+  return expand_variable_ (x, formals, 1);
+}
+
 SCM
 eval_apply ()
 {
-  int expanding_p = 0;
  eval_apply:
   gc_check ();
   switch (r3)
@@ -764,12 +877,8 @@ eval_apply ()
     case cell_vm_apply: goto apply;
     case cell_vm_apply2: goto apply2;
     case cell_vm_eval: goto eval;
-#if MES_FIXED_PRIMITIVES
+    case cell_vm_eval_pmatch_car: goto eval_pmatch_car;
-    case cell_vm_eval_car: goto eval_car;
+    case cell_vm_eval_pmatch_cdr: goto eval_pmatch_cdr;
-    case cell_vm_eval_cdr: goto eval_cdr;
-    case cell_vm_eval_cons: goto eval_cons;
-    case cell_vm_eval_null_p: goto eval_null_p;
-#endif
     case cell_vm_eval_define: goto eval_define;
     case cell_vm_eval_set_x: goto eval_set_x;
     case cell_vm_eval_macro_expand_eval: goto eval_macro_expand_eval;
@@ -818,31 +927,33 @@ eval_apply ()
   gc_check ();
   switch (TYPE (CAR (r1)))
     {
-    case TFUNCTION: {
+    case TFUNCTION:
-      check_formals (CAR (r1), MAKE_NUMBER (FUNCTION (CAR (r1)).arity), CDR (r1));
+      {
-      r1 = call (CAR (r1), CDR (r1)); /// FIXME: move into eval_apply
+        check_formals (CAR (r1), MAKE_NUMBER (FUNCTION (CAR (r1)).arity), CDR (r1));
-      goto vm_return;
+        r1 = call (CAR (r1), CDR (r1)); /// FIXME: move into eval_apply
-    }
+        goto vm_return;
+      }
     case TCLOSURE:
       {
         SCM cl = CLOSURE (CAR (r1));
-        SCM formals = CADR (cl);
         SCM body = CDDR (cl);
+        SCM formals = CADR (cl);
+        SCM args = CDR (r1);
         SCM aa = CDAR (cl);
         aa = CDR (aa);
         check_formals (CAR (r1), formals, CDR (r1));
-        SCM p = pairlis (formals, CDR (r1), aa);
+        SCM p = pairlis (formals, args, aa);
         call_lambda (body, p, aa, r0);
         goto begin;
       }
-      case TCONTINUATION:
+    case TCONTINUATION:
-        {
+      {
-          x = r1;
+        x = r1;
-          g_stack = CONTINUATION (CAR (r1));
+        g_stack = CONTINUATION (CAR (r1));
-          gc_pop_frame ();
+        gc_pop_frame ();
-          r1 = CADR (x);
+        r1 = CADR (x);
-          goto eval_apply;
+        goto eval_apply;
-        }
+      }
     case TSPECIAL:
       {
         switch (CAR (r1))
@@ -886,9 +997,10 @@ eval_apply ()
           case cell_symbol_lambda:
             {
               SCM formals = CADR (CAR (r1));
+              SCM args = CDR (r1);
               SCM body = CDDR (CAR (r1));
               SCM p = pairlis (formals, CDR (r1), r0);
-              check_formals (r1, formals, CDR (r1));
+              check_formals (r1, formals, args);
               call_lambda (body, p, p, r0);
               goto begin;
             }
@@ -910,59 +1022,50 @@ eval_apply ()
       {
         switch (CAR (r1))
           {
-#if MES_FIXED_PRIMITIVES
+          case cell_symbol_pmatch_car:
-          case cell_symbol_car:
             {
-              push_cc (CADR (r1), r1, r0, cell_vm_eval_car); goto eval;
+              push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_car);
-            eval_car:
-              x = r1; gc_pop_frame (); r1 = CAR (x); goto eval_apply;
-            }
-          case cell_symbol_cdr:
-            {
-              push_cc (CADR (r1), r1, r0, cell_vm_eval_cdr); goto eval;
-            eval_cdr:
-              x = r1; gc_pop_frame (); r1 = CDR (x); goto eval_apply;
-            }
-          case cell_symbol_cons: {
-            push_cc (CDR (r1), r1, r0, cell_vm_eval_cons); goto evlis;
-            eval_cons:
-            x = r1;
-            gc_pop_frame ();
-            r1 = cons (CAR (x), CADR (x));
-            goto eval_apply;
-          }
-          case cell_symbol_null_p:
-            {
-              push_cc (CADR (r1), r1, r0, cell_vm_eval_null_p);
               goto eval;
-            eval_null_p:
+            eval_pmatch_car:
-              x = r1; gc_pop_frame (); r1 = null_p (x); goto eval_apply;
+              x = r1;
+              gc_pop_frame ();
+              r1 = CAR (x);
+              goto eval_apply;
+            }
+          case cell_symbol_pmatch_cdr:
+            {
+              push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_cdr);
+              goto eval;
+            eval_pmatch_cdr:
+              x = r1;
+              gc_pop_frame ();
+              r1 = CDR (x);
+              goto eval_apply;
             }
-#else
-          eval_car:;
-          eval_cdr:;
-          eval_cons:;
-          eval_null_p:;
-            
-#endif // MES_FIXED_PRIMITIVES
           case cell_symbol_quote:
             {
-              x = r1; gc_pop_frame (); r1 = CADR (x); goto eval_apply;
+              x = r1;
+              gc_pop_frame ();
+              r1 = CADR (x);
+              goto eval_apply;
             }
           case cell_symbol_begin: goto begin;
           case cell_symbol_lambda:
             {
-              r1 = make_closure_ (CADR (r1), CDDR (r1), assq (cell_closure, r0));
+              r1 = make_closure_ (CADR (r1), CDDR (r1), r0);
               goto vm_return;
             }
-          case cell_symbol_if: {r1=CDR (r1); goto vm_if;}
+          case cell_symbol_if:
+            {
+              r1=CDR (r1);
+              goto vm_if;
+            }
           case cell_symbol_set_x:
             {
               push_cc (CAR (CDDR (r1)), r1, r0, cell_vm_eval_set_x);
               goto eval;
             eval_set_x:
-              x = r2;
+              r1 = set_env_x (CADR (r2), r1, r0);
-              r1 = set_env_x (CADR (x), r1, r0);
               goto vm_return;
             }
           case cell_vm_macro_expand:
@@ -971,18 +1074,44 @@ eval_apply ()
               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:
             {
               if (TYPE (r1) == TPAIR
                   && (CAR (r1) == cell_symbol_define
-                    || CAR (r1) == cell_symbol_define_macro))
+                      || CAR (r1) == cell_symbol_define_macro))
                 {
+                  int global_p = CAAR (r0) != cell_closure;
+                  int macro_p = CAR (r1) == cell_symbol_define_macro;
+                  if (global_p)
+                    {
+                      SCM name = CADR (r1);
+                      if (TYPE (CADR (r1)) == TPAIR)
+                        name = CAR (name);
+                      if (macro_p)
+                        {
+                          SCM entry = assq (name, g_macros);
+                          if (entry == cell_f)
+                            {
+                              entry = cons (name, cell_f);
+                              g_macros = cons (entry, g_macros);
+                            }
+                        }
+                      else
+                        {
+                          SCM entry = assq (name, r0);
+                          if (entry == cell_f)
+                            {
+                              entry = cons (name, cell_f);
+                              SCM aa = cons (entry, cell_nil);
+                              set_cdr_x (aa, cdr (r0));
+                              set_cdr_x (r0, aa);
+                            }
+                        }
+                    }
                   r2 = r1;
                   if (TYPE (CADR (r1)) != TPAIR)
                     {
@@ -992,41 +1121,68 @@ eval_apply ()
                   else
                     {
                       SCM p = pairlis (CADR (r1), CADR (r1), r0);
-                      SCM args = CDR (CADR (r1));
+                      SCM formals = CDR (CADR (r1));
                       SCM body = CDDR (r1);
-                      r1 = cons (cell_symbol_lambda, cons (args, body));
+
+                      if (macro_p || global_p) expand_variable (body, formals);
+                      r1 = cons (cell_symbol_lambda, cons (formals, body));
                       push_cc (r1, r2, p, cell_vm_eval_define);
                       goto eval;
                     }
                 eval_define:;
                   SCM name = CADR (r2);
-                  if (TYPE (CADR (r2)) == TPAIR) name = CAR (name);
+                  if (TYPE (CADR (r2)) == TPAIR)
-                  if (CAR (r2) == cell_symbol_define_macro)
+                    name = CAR (name);
-                    r1 = MAKE_MACRO (name, r1);
+                  if (macro_p)
-                  SCM entry = cons (name, r1);
+                    {
-                  SCM aa = cons (entry, cell_nil);
+                      SCM entry = assq (name, g_macros);
-                  set_cdr_x (aa, cdr (r0));
+                      r1 = MAKE_MACRO (name, r1);
-                  set_cdr_x (r0, aa);
+                      set_cdr_x (entry, r1);
-                  SCM cl = assq (cell_closure, r0);
+                    }
-                  set_cdr_x (cl, aa);
+                  else if (global_p)
-                  //r1 = entry;
+                    {
+                      SCM entry = assq (name, r0);
+                      set_cdr_x (entry, r1);
+                    }
+                  else
+                    {
+                      SCM entry = cons (name, r1);
+                      SCM aa = cons (entry, cell_nil);
+                      set_cdr_x (aa, cdr (r0));
+                      set_cdr_x (r0, aa);
+                      SCM cl = assq (cell_closure, r0);
+                      set_cdr_x (cl, aa);
+                    }
                   r1 = cell_unspecified;
                   goto vm_return;
                 }
-              push_cc (CAR (r1), r1, r0, cell_vm_eval_check_func); goto eval;
+              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;
-          }
+            }
           }
       }
     case TSYMBOL:
       {
+        if (r1 == cell_symbol_current_module) goto vm_return;
+        if (r1 == cell_symbol_begin) // FIXME
+          {
+            r1 = cell_begin;
+            goto vm_return;
+          }
         r1 = assert_defined (r1, assq_ref_env (r1, r0));
         goto vm_return;
       }
+    case TVARIABLE:
+      {
+        r1 = CDR (VARIABLE (r1));
+        goto vm_return;
+      }
     default: goto vm_return;
     }
 
@@ -1038,13 +1194,24 @@ eval_apply ()
     if (TYPE (r1) != TPAIR || CAR (r1) == cell_symbol_quote)
       goto vm_return;
 
+    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 (TYPE (r1) == TPAIR
-        && (macro = lookup_macro_ (CAR (r1), r0)) != cell_f)
+        && (macro = lookup_macro_ (CAR (r1), g_macros)) != 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)
       {
@@ -1063,16 +1230,6 @@ eval_apply ()
         goto vm_return;
       }
 
-    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);
@@ -1086,6 +1243,7 @@ eval_apply ()
     if (TYPE (r1) == TPAIR
         && TYPE (CAR (r1)) == TSYMBOL
         && CAR (r1) != cell_symbol_begin
+        && ((macro = assq (cell_symbol_portable_macro_expand, g_macros)) != cell_f)
         && ((expanders = assq_ref_env (cell_symbol_sc_expander_alist, r0)) != cell_undefined)
         && ((macro = assq (CAR (r1), expanders)) != cell_f))
       {
@@ -1192,10 +1350,8 @@ eval_apply ()
         }
 
       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;
@@ -1203,7 +1359,8 @@ eval_apply ()
           continue;
         }
       r1 = r2;
-
+      expand_variable (CAR (r1), cell_nil);
+      //eputs ("expanded r1="); write_error_ (CAR (r1)); eputs ("\n");
       push_cc (CAR (r1), r1, r0, cell_vm_begin_expand_eval);
       goto eval;
     begin_expand_eval:
@@ -1372,7 +1529,10 @@ mes_symbols () ///((internal))
   a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a);
 
   a = acons (cell_symbol_dot, cell_dot, a);
+
   a = acons (cell_symbol_begin, cell_begin, a);
+  a = acons (cell_symbol_quasisyntax, cell_symbol_quasisyntax, a);
+
   a = acons (cell_symbol_call_with_values, cell_symbol_call_with_values, a);
   a = acons (cell_symbol_current_module, cell_symbol_current_module, a);
   a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a);
@@ -1403,7 +1563,7 @@ mes_builtins (SCM a) ///((internal))
 #if !__GNUC__ || !_POSIX_SOURCE
 #include "mes.mes.i"
 
-// Do not sort: Order of these includes define builtins
+  // Do not sort: Order of these includes define builtins
 #include "posix.mes.i"
 #include "math.mes.i"
 #include "lib.mes.i"
@@ -1421,7 +1581,7 @@ mes_builtins (SCM a) ///((internal))
 #else
 #include "mes.i"
 
-// Do not sort: Order of these includes define builtins
+  // Do not sort: Order of these includes define builtins
 #include "posix.i"
 #include "math.i"
 #include "lib.i"

src/reader.c

@@ -334,7 +334,7 @@ dump ()
       eputs ("\n");
     }
 
-  for (int i=0; i<g_free * sizeof(struct scm); i++)
+  for (int i=0; i<g_free * sizeof (struct scm); i++)
     putchar (*p++);
   return 0;
 }

tests/pmatch.test

@@ -28,7 +28,11 @@ exit $?
 
 (cond-expand
  (guile
-  (use-modules (system base pmatch)))
+  (use-modules (system base pmatch))
+  ;;(include-from-path "mes/pmatch.scm")
+  ;;(include-from-path "mes-0.scm")
+  ;;(include-from-path "mes/test.mes")
+  )
  (mes
   (mes-use-module (mes test))
   (mes-use-module (mes pmatch))))