mes: Resurrect define, define-macro in C core.

* make.scm (bin.gcc, bin.mescc): Use MES_C_READER=1.
* src/mes.c (scm_symbol_define, scm_symbol_define_macro): New symbol.
  (scm_vm_eval_define): New special.
  (scm_symbol_c_define): New symbol.
  (MAKE_MACRO): New define.
  (eval_apply)[MES_C_DEFINE]: Handle define, define-macro.
  (mes_symbols): Define %c-define for use in read-0.mes.
* module/mes/read-0.mes: Do not implement full scheme define if %c-define.
* module/mes/quasiquote.mes (sexp:define, env:define, env:macro): New function.
  (define-macro): New macro.  FIXME
* module/mes/psyntax.mes (define): New macro.  FIXME

make.scm

@@ -417,6 +417,7 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$
 
 (add-target (bin.gcc "src/mes.c" #:dependencies gcc-snarf-targets
                      #:defines `("MES_C_READER=1"
+                                 "MES_C_DEFINE=1"
                                  "MES_FIXED_PRIMITIVES=1"
                                  "MES_FULL=1"
                                  "POSIX=1"
@@ -428,6 +429,7 @@ 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_C_READER=1"
+                                 "MES_C_DEFINE=1"
                                  "MES_FIXED_PRIMITIVES=1"
                                  "MES_FULL=1"
                                  ,(string-append "VERSION=\"" %version "\"")
@@ -437,6 +439,7 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$
 
 (add-target (bin.mescc "src/mes.c" #:dependencies mes-snarf-targets
                        #:defines `("MES_C_READER=1"
+                                   "MES_C_DEFINE=1"
                                    "MES_FIXED_PRIMITIVES=1"
                                    "MES_FULL=1"
                                    ,(string-append "VERSION=\"" %version "\"")

module/mes/fluids.mes

@@ -24,6 +24,14 @@
 
 (mes-use-module (mes scm))
 
+
+(define (sexp:define e a)
+  (if (atom? (car (cdr e))) (cons (car (cdr e))
+                                  (core:eval (car (cdr (cdr e))) a))
+      (cons (car (car (cdr e)))
+            (core:eval (cons (quote lambda)
+                             (cons (cdr (car (cdr e))) (cdr (cdr e)))) a))))
+
 (define (f:env:define a+ a)
   (set-cdr! a+ (cdr a))
   (set-cdr! a a+)

module/mes/psyntax.mes

@@ -1,7 +1,7 @@
 ;;; -*-scheme-*-
 
 ;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of Mes.
 ;;;
@@ -22,6 +22,22 @@
 
 ;;; 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 psyntax-0))
 (include-from-path "mes/psyntax.pp")
 (mes-use-module (mes psyntax-1))

module/mes/quasiquote.mes

@@ -1,7 +1,7 @@
 ;;; -*-scheme-*-
 
 ;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of Mes.
 ;;;
@@ -27,12 +27,10 @@
 
 (mes-use-module (mes base))
 
-(define-macro (quasiquote x)
+(define (quasiquote-expand x)
-  (define (loop x)
+  (cond ((vector? x) (list 'list->vector (quasiquote-expand (vector->list x))))
-    (cond ((vector? x) (list 'list->vector (loop (vector->list x))))
         ((not (pair? x)) (cons 'quote (cons x '())))
-          ;;((eq? (car x) 'quasiquote) (loop (loop (cadr x))))
+        ((eq? (car x) 'quasiquote) (quasiquote-expand (quasiquote-expand
-          ((eq? (car x) 'quasiquote) (loop (loop
                                              (if (null? (cddr x)) (cadr x)
                                                  (cons 'list (cdr x))))))
         ((eq? (car x) 'unquote) (if (null? (cddr x)) (cadr x)
@@ -41,7 +39,7 @@
          ((lambda (d)
             (if (null? (cddar x)) (list 'append (cadar x) d)
                 (list 'quote (append (cdar x) d))))
-            (loop (cdr x))))
+          (quasiquote-expand (cdr x))))
         (else ((lambda (a d)
                  (if (pair? d)
                      (if (eq? (car d) 'quote)
@@ -54,6 +52,8 @@
                              (cons (car d) (cons a (cdr d)))
                              (list 'cons* a d)))
                      (list 'cons* a d)))
-                 (loop (car x))
+               (quasiquote-expand (car x))
-                 (loop (cdr x))))))
+               (quasiquote-expand (cdr x))))))
-  (loop x))
+
+(define-macro (quasiquote x)
+  (quasiquote-expand x))

module/mes/read-0.mes

@@ -27,7 +27,13 @@
 ;;; Code:
 
 (begin
-
+  (if %c-define
+      (begin
+        (define <cell:pair> 7)
+        (define (not x) (if x #f #t))
+        (define (pair? x) (eq? (core:type x) <cell:pair>))
+        (define (atom? x) (not (pair? x))))
+      (begin
         ((lambda (a+ a)
            (set-cdr! a+ (cdr a))
            (set-cdr! a a+)
@@ -102,7 +108,7 @@
                                         (cons (quote DEFINE-MACRO) (cons ARGS BODY)))
                                   (quote ((current-module)))))
                      (quote ((current-module))))))
-     (current-module))) (current-module))
+           (current-module))) (current-module))))
 
   (define <cell:character> 0)
   (define <cell:keyword> 4)

src/mes.c

@@ -131,10 +131,12 @@ struct scm scm_symbol_lambda = {TSYMBOL, "lambda",0};
 struct scm scm_symbol_begin = {TSYMBOL, "begin",0};
 struct scm scm_symbol_if = {TSYMBOL, "if",0};
 struct scm scm_symbol_quote = {TSYMBOL, "quote",0};
+#if 1 //MES_C_DEFINE // snarfing makes these always needed for linking
+struct scm scm_symbol_define = {TSYMBOL, "define",0};
+struct scm scm_symbol_define_macro = {TSYMBOL, "define-macro",0};
+#endif
 
-#if 1
+#if 1 //MES_C_READER // snarfing makes these always needed for linking
-//MES_C_READER
-//Only for MES_C_READER; snarfing makes these always needed for linking
 struct scm scm_symbol_quasiquote = {TSYMBOL, "quasiquote", 0};
 struct scm scm_symbol_unquote = {TSYMBOL, "unquote", 0};
 struct scm scm_symbol_unquote_splicing = {TSYMBOL, "unquote-splicing", 0};
@@ -188,6 +190,9 @@ struct scm scm_vm_eval_car = {TSPECIAL, "*vm-eval-car*",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};
+#if 1 //MES_C_DEFINE // snarfing makes these always needed for linking
+struct scm scm_vm_eval_define = {TSPECIAL, "*vm-eval-define*",0};
+#endif
 
 struct scm scm_vm_eval_set_x = {TSPECIAL, "*vm-eval-set!*",0};
 struct scm scm_vm_eval_macro = {TSPECIAL, "*vm-eval-macro*",0};
@@ -206,6 +211,7 @@ struct scm scm_vm_return = {TSPECIAL, "*vm-return*",0};
 struct scm scm_symbol_gnuc = {TSYMBOL, "%gnuc",0};
 struct scm scm_symbol_mesc = {TSYMBOL, "%mesc",0};
 struct scm scm_symbol_c_reader = {TSYMBOL, "%c-reader",0};
+struct scm scm_symbol_c_define = {TSYMBOL, "%c-define",0};
 
 struct scm scm_test = {TSYMBOL, "test",0};
 
@@ -293,6 +299,9 @@ int g_function = 0;
 #if MES_C_READER
 #define MAKE_KEYWORD(x) make_cell_ (tmp_num_ (TKEYWORD), x, 0)
 #endif
+#if MES_C_DEFINE
+#define MAKE_MACRO(name, x) make_cell_ (tmp_num_ (TMACRO), STRING (name), x)
+#endif
 
 #define CAAR(x) CAR (CAR (x))
 #define CADR(x) CAR (CDR (x))
@@ -744,6 +753,9 @@ eval_apply ()
     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
+#if MES_C_DEFINE
+    case cell_vm_eval_define: goto eval_define;
 #endif
     case cell_vm_eval_set_x: goto eval_set_x;
     case cell_vm_eval_macro: goto eval_macro;
@@ -940,6 +952,42 @@ eval_apply ()
                   }
                 goto eval;
               }
+#if MES_C_DEFINE
+            if (TYPE (r1) == TPAIR
+                && (CAR (r1) == cell_symbol_define
+                    || CAR (r1) == cell_symbol_define_macro))
+              {
+                r2 = CADR (r1);
+                if (TYPE (r2) != TPAIR)
+                  {
+                    push_cc (CAR (CDDR (r1)), r2, cons (cons (CADR (r1), CADR (r1)), r0), cell_vm_eval_define);
+                    goto eval;
+                  }
+                else
+                  {
+                    r2 = CAR (r2);
+                    SCM p = pairlis (CADR (r1), CADR (r1), r0);
+                    SCM args = CDR (CADR (r1));
+                    SCM body = CDDR (r1);
+                    r1 = cons (cell_symbol_lambda, cons (args, body));
+                    push_cc (r1, r2, p, cell_vm_eval_define);
+                    goto eval;
+                  }
+              eval_define:
+                if (CAAR (CAAR (g_stack)) == cell_symbol_define_macro
+                    || CAR (CAAR (g_stack)) == cell_symbol_define_macro)
+                  r1 = MAKE_MACRO (r2, r1);
+                SCM entry = cons (r2, 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 = entry;
+                goto vm_return;
+              }
+#endif // MES_C_DEFINE
+
             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;
@@ -1189,6 +1237,11 @@ mes_symbols () ///((internal))
   a = acons (cell_symbol_c_reader, cell_f, a);
 #endif
 
+#if MES_C_DEFINE
+  a = acons (cell_symbol_c_define, cell_t, a);
+#else
+  a = acons (cell_symbol_c_define, cell_f, a);
+#endif
   a = acons (cell_closure, a, a);
 
   return a;