mes: Resurrect define, define-macro in C core.
authorJan Nieuwenhuizen <janneke@gnu.org>
Sat, 9 Dec 2017 07:24:38 +0000 (08:24 +0100)
committerJan Nieuwenhuizen <janneke@gnu.org>
Sat, 9 Dec 2017 07:24:38 +0000 (08:24 +0100)
* 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
module/mes/fluids.mes
module/mes/psyntax.mes
module/mes/quasiquote.mes
module/mes/read-0.mes
src/mes.c

index 4e3f403ff5000fa993b19741b9eff0848e88059d..b39cb12d1fc6edfb7a72fb6660221b614a245f2e 100755 (executable)
--- a/make.scm
+++ b/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 "\"")
index b9f88c457213ea9e96f5f1788b04dd35e58f2ec7..87dc4307d650a69b21605bad76927559ad51940a 100644 (file)
 
 (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+)
index d3b6a07e8380d34d3cfaf5beda5a828fe47625ba..5618f12f9937e37ee6239c8a4b8e63369786e7c9 100644 (file)
@@ -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.
 ;;;
 
 ;;; 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))
index 334f057e5a233f23411ca6a5cbe4564ddf53ee9e..ee8bca2b52921e7029fcae5ad8edd6ab1c80d3ff 100644 (file)
@@ -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.
 ;;;
 
 (mes-use-module (mes base))
 
+(define (quasiquote-expand x)
+  (cond ((vector? x) (list 'list->vector (quasiquote-expand (vector->list x))))
+        ((not (pair? x)) (cons 'quote (cons x '())))
+        ((eq? (car x) 'quasiquote) (quasiquote-expand (quasiquote-expand
+                                             (if (null? (cddr x)) (cadr x)
+                                                 (cons 'list (cdr x))))))
+        ((eq? (car x) 'unquote) (if (null? (cddr x)) (cadr x)
+                                    (cons 'list (cdr x))))
+        ((and (pair? (car x)) (eq? (caar x) 'unquote-splicing))
+         ((lambda (d)
+            (if (null? (cddar x)) (list 'append (cadar x) d)
+                (list 'quote (append (cdar x) d))))
+          (quasiquote-expand (cdr x))))
+        (else ((lambda (a d)
+                 (if (pair? d)
+                     (if (eq? (car d) 'quote)
+                         (if (and (pair? a) (eq? (car a) 'quote))
+                             (list 'quote (cons (cadr a) (cadr d)))
+                             (if (null? (cadr d))
+                                 (list 'list a)
+                                 (list 'cons* a d)))
+                         (if (memq (car d) '(list cons*))
+                             (cons (car d) (cons a (cdr d)))
+                             (list 'cons* a d)))
+                     (list 'cons* a d)))
+               (quasiquote-expand (car x))
+               (quasiquote-expand (cdr x))))))
+
 (define-macro (quasiquote x)
-  (define (loop 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) (loop (loop
-                                            (if (null? (cddr x)) (cadr x)
-                                                (cons 'list (cdr x))))))
-          ((eq? (car x) 'unquote) (if (null? (cddr x)) (cadr x)
-                                      (cons 'list (cdr x))))
-          ((and (pair? (car x)) (eq? (caar x) 'unquote-splicing))
-           ((lambda (d)
-              (if (null? (cddar x)) (list 'append (cadar x) d)
-                  (list 'quote (append (cdar x) d))))
-            (loop (cdr x))))
-          (else ((lambda (a d)
-                   (if (pair? d)
-                       (if (eq? (car d) 'quote)
-                           (if (and (pair? a) (eq? (car a) 'quote))
-                               (list 'quote (cons (cadr a) (cadr d)))
-                               (if (null? (cadr d))
-                                   (list 'list a)
-                                   (list 'cons* a d)))
-                           (if (memq (car d) '(list cons*))
-                               (cons (car d) (cons a (cdr d)))
-                               (list 'cons* a d)))
-                       (list 'cons* a d)))
-                 (loop (car x))
-                 (loop (cdr x))))))
-  (loop x))
+  (quasiquote-expand x))
index 2753b15aa6fc7d9b9797e85f3fd02b68dd90ba5b..e7f99b7de3e6c39e6b072449f0e0e7b7fd23a639 100644 (file)
 ;;; Code:
 
 (begin
-
-  ((lambda (a+ a)
-     (set-cdr! a+ (cdr a))
-     (set-cdr! a a+)
-     (set-cdr! (assq (quote *closure*) a) a+)
-     (car a+))
-   (cons (cons (quote env:define) #f) (list))
-   (current-module))
-
-  (set! env:define
-        (lambda (a+ a)
-          (set-cdr! a+ (cdr a))
-          (set-cdr! a a+)
-          (set-cdr! (assq (quote *closure*) a) a+)
-          (car a+)))
-
-  (env:define (cons (cons (quote <cell:macro>) 5) (list)) (current-module))
-  (env:define (cons (cons (quote <cell:pair>) 7) (list)) (current-module))
-  (env:define (cons (cons (quote sexp:define) #f) (list)) (current-module))
-  (env:define (cons (cons (quote env:macro) #f) (list)) (current-module))
-  (env:define (cons (cons (quote cons*) #f) (list)) (current-module))
-  (env:define (cons (cons (quote not)
-                          (lambda (x) (if x #f #t)))
-                    (list)) (current-module))
-  (env:define (cons (cons (quote pair?)
-                          (lambda (x) (eq? (core:type x) <cell:pair>)))
-                    (list)) (current-module))
-  (env:define (cons (cons (quote atom?)
-                          (lambda (x) (not (pair? x))))
-                    (list)) (current-module))
-
-  (set! sexp:define
-        (lambda (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)))))
-
-  (set! env:macro
-        (lambda (name+entry)
-          (cons
-           (cons (car name+entry)
-                 (core:make-cell <cell:macro> (core:car (car name+entry)) (cdr name+entry)))
-           (list))))
-
-  (set! cons*
-        (lambda (. rest)
-          (if (null? (cdr rest)) (car rest)
-              (cons (car rest) (core:apply cons* (cdr rest) (current-module))))))
-
-  (env:define
-   (env:macro
-    (sexp:define
-     (quote
-      (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))))))
-     (current-module))) (current-module))
-
-  (env:define
-   (env:macro
-    (sexp:define
-     (quote
-      (define-macro (define-macro ARGS . BODY)
-        (cons* (quote env:define)
-               (list (quote env:macro)
-                     (cons* (quote sexp:define)
-                            (list (quote quote)
-                                  (cons (quote DEFINE-MACRO) (cons ARGS BODY)))
-                            (quote ((current-module)))))
-               (quote ((current-module))))))
-     (current-module))) (current-module))
+  (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+)
+           (set-cdr! (assq (quote *closure*) a) a+)
+           (car a+))
+         (cons (cons (quote env:define) #f) (list))
+         (current-module))
+
+        (set! env:define
+              (lambda (a+ a)
+                (set-cdr! a+ (cdr a))
+                (set-cdr! a a+)
+                (set-cdr! (assq (quote *closure*) a) a+)
+                (car a+)))
+
+        (env:define (cons (cons (quote <cell:macro>) 5) (list)) (current-module))
+        (env:define (cons (cons (quote <cell:pair>) 7) (list)) (current-module))
+        (env:define (cons (cons (quote sexp:define) #f) (list)) (current-module))
+        (env:define (cons (cons (quote env:macro) #f) (list)) (current-module))
+        (env:define (cons (cons (quote cons*) #f) (list)) (current-module))
+        (env:define (cons (cons (quote not)
+                                (lambda (x) (if x #f #t)))
+                          (list)) (current-module))
+        (env:define (cons (cons (quote pair?)
+                                (lambda (x) (eq? (core:type x) <cell:pair>)))
+                          (list)) (current-module))
+        (env:define (cons (cons (quote atom?)
+                                (lambda (x) (not (pair? x))))
+                          (list)) (current-module))
+
+        (set! sexp:define
+              (lambda (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)))))
+
+        (set! env:macro
+              (lambda (name+entry)
+                (cons
+                 (cons (car name+entry)
+                       (core:make-cell <cell:macro> (core:car (car name+entry)) (cdr name+entry)))
+                 (list))))
+
+        (set! cons*
+              (lambda (. rest)
+                (if (null? (cdr rest)) (car rest)
+                    (cons (car rest) (core:apply cons* (cdr rest) (current-module))))))
+
+        (env:define
+         (env:macro
+          (sexp:define
+           (quote
+            (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))))))
+           (current-module))) (current-module))
+
+        (env:define
+         (env:macro
+          (sexp:define
+           (quote
+            (define-macro (define-macro ARGS . BODY)
+              (cons* (quote env:define)
+                     (list (quote env:macro)
+                           (cons* (quote sexp:define)
+                                  (list (quote quote)
+                                        (cons (quote DEFINE-MACRO) (cons ARGS BODY)))
+                                  (quote ((current-module)))))
+                     (quote ((current-module))))))
+           (current-module))) (current-module))))
 
   (define <cell:character> 0)
   (define <cell:keyword> 4)
index 8b2201e42d3a1eefa3c3d4b1233a75f88e415050..92f47124c81f5aeabdfcf323125fd5ea988300ad 100644 (file)
--- a/src/mes.c
+++ b/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
-//MES_C_READER
-//Only for MES_C_READER; snarfing makes these always needed for linking
+#if 1 //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;