core: Remove define.
authorJan Nieuwenhuizen <janneke@gnu.org>
Wed, 21 Dec 2016 21:22:34 +0000 (22:22 +0100)
committerJan Nieuwenhuizen <janneke@gnu.org>
Wed, 21 Dec 2016 21:22:34 +0000 (22:22 +0100)
* base-0.mes (cons*): Refactor.
* module/mes/read-0.mes: Implement define, define-macro using macros.
* define.c: Remove.
* mes.c: Remove callers.
* GNUmakefile (mes.o): Remove dependency on define.

GNUmakefile
define.c [deleted file]
mes.c
module/mes/base-0.mes
module/mes/fluids.mes
module/mes/read-0.mes

index 782e48fecb4316ee8bf0537426f7eb44638c8595..d42b67121bbd6f0f018796a93013bf8f82ba4a33 100644 (file)
@@ -29,7 +29,6 @@ all: mes module/mes/read-0.mo
 mes.o: GNUmakefile
 mes.o: mes.c
 mes.o: mes.c mes.h mes.i mes.environment.i mes.symbols.i
-mes.o: define.c define.h define.i define.environment.i
 mes.o: display.c display.h display.i display.environment.i
 mes.o: lib.c lib.h lib.i lib.environment.i
 mes.o: math.c math.h math.i math.environment.i
diff --git a/define.c b/define.c
deleted file mode 100644 (file)
index 3152119..0000000
--- a/define.c
+++ /dev/null
@@ -1,59 +0,0 @@
-/* -*-comment-start: "//";comment-end:""-*-
- * Mes --- Maxwell Equations of Software
- * Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
- *
- * This file is part of Mes.
- *
- * Mes is free software; you can redistribute it and/or modify it
- * under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 3 of the License, or (at
- * your option) any later version.
- *
- * Mes is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with Mes.  If not, see <http://www.gnu.org/licenses/>.
- */
-
-#if !BOOT
-SCM
-define_env (SCM e, SCM a)
-{
-  return vm_call (vm_define_env, e, cell_undefined, a);
-}
-
-SCM
-vm_define_env ()
-{
-  SCM x;
-  r2 = cadr (r1);
-  if (TYPE (r2) != PAIR)
-    x = eval_env (caddr (r1), cons (cons (cadr (r1), cadr (r1)), r0));
-  else {
-    r2 = car (r2);
-    SCM p = pairlis (cadr (r1), cadr (r1), r0);
-    x = eval_env (make_lambda (cdadr (r1), cddr (r1)), p);
-  }
-  if (eq_p (car (r1), cell_symbol_define_macro) == cell_t)
-    x = make_macro (r2, x);
-
-  SCM entry = cons (r2, x);
-  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);
-  return entry;
-}
-#else // BOOT
-SCM define_env (SCM r1, SCM a){}
-SCM vm_define_env (SCM r1, SCM a){}
-#endif
-
-SCM
-define_macro (SCM r1, SCM a)
-{
-}
diff --git a/mes.c b/mes.c
index f4912bab9bc89003bc946d869f43402d904f37eb..f1d78efe74fad2d02878d5108dfbd3f55ec96647 100644 (file)
--- a/mes.c
+++ b/mes.c
@@ -163,7 +163,6 @@ SCM r1 = 0; // param 1
 SCM r2 = 0; // param 2
 SCM r3 = 0; // param 3
 
-#include "define.h"
 #include "display.h"
 #include "lib.h"
 #include "math.h"
@@ -453,10 +452,6 @@ vm_eval_env ()
             return make_closure (cadr (r1), cddr (r1), assq (cell_closure, r0));
           case cell_closure: return r1;
           case cell_symbol_if: return if_env (cdr (r1), r0);
-#if !BOOT
-          case cell_symbol_define: return define_env (r1, r0);
-          case cell_symbol_define_macro: return define_env (r1, r0);
-#endif
 #if 1 //!BOOT
           case cell_symbol_set_x: {
             SCM x = eval_env (caddr (r1), r0); return set_env_x (cadr (r1), x, r0);
@@ -1102,7 +1097,6 @@ mes_builtins (SCM a)
 {
 #include "mes.i"
 
-#include "define.i"
 #include "display.i"
 #include "lib.i"
 #include "math.i"
@@ -1112,7 +1106,6 @@ mes_builtins (SCM a)
 #include "string.i"
 #include "type.i"
 
-#include "define.environment.i"
 #include "display.environment.i"
 #include "lib.environment.i"
 #include "math.environment.i"
@@ -1206,7 +1199,7 @@ SCM
 load_env (SCM a) ///((internal))
 {
   r0 =a;
-#if !READER
+#if 1 //!READER
   g_stdin = fopen ("module/mes/read-0.mes", "r");
   g_stdin = g_stdin ? g_stdin : fopen (PREFIX "module/mes/read-0.mes", "r");
 #endif
@@ -1262,7 +1255,6 @@ dump ()
 }
 
 #include "type.c"
-#include "define.c"
 #include "display.c"
 #include "lib.c"
 #include "math.c"
index 4dfbeb60b3c0b6e8ad7442b236b0ec73a81a3fad..b9058795b37a4155902fc68656547ccfce6259ef 100644 (file)
 (define (ftell port) 0)
 (define (false-if-exception x) x)
 
-(define (cons* x . rest)
-  (define (loop rest)
-    (if (null? (cdr rest)) (car rest)
-        (cons (car rest) (loop (cdr rest)))))
-  (loop (cons x rest)))
+(define (cons* . rest)
+  (if (null? (cdr rest)) (car rest)
+      (cons (car rest) (apply-env cons* (cdr rest) (current-module)))))
 
 (define (apply f h . t) (apply-env f (cons h t) (current-module)))
 (define (apply f h . t)
index 4f7a1db83f6d141380c236e488fcbcd87ace59b5..c1194d85adf8252a82292bc90df8538a0f0d13c1 100644 (file)
 
 (mes-use-module (mes scm))
 
-(define (env:define a+ a)
+(define (f:env:define a+ a)
   (set-cdr! a+ (cdr a))
   (set-cdr! a a+)
   ;;(set-cdr! (assq '*closure* a) a+)
   )
 
-(define (env:escape-closure a)
-  (let loop ((a a) (n 1))
-    (if (eq? (caar a) '*closure*) (if (= 0 n) a
-                                      (loop (cdr a) (- n 1)))
-        (loop (cdr a) n))))
-
-(define (sexp:define e a)
-  (if (atom? (cadr e)) (cons (cadr e) (eval-env (caddr e) a))
-      (cons (caadr e) (eval-env (cons 'lambda (cons (cdadr e) (cddr e))) a))))
+(define (env:escape-closure a n)
+  (if (closure? (car a)) (if (= 0 n) a
+                             (env:escape-closure (cdr a) (- n 1)))
+      (env:escape-closure (cdr a) n)))
 
 (define-macro (module-define! name value a)
-  `(env:define (cons (sexp:define (cons 'define (cons ',name (cons ,value '()))) ,a) '()) (env:escape-closure ,a)))
+  `(f:env:define (cons (sexp:define (cons 'define (cons ',name (cons ,value '()))) ,a) '()) (env:escape-closure ,a 1)))
 
 (define-macro (make-fluid . default)
   `(begin
index 315548465c61f51a3dde9cd810650715768a0f5a..44196bc27c2f050ecf1b2307959fd1e72958a20b 100644 (file)
 ;;; to use this reader to read and run the minimal gc-3.test
 ;;; TODO: complete this reader, remove reader from C.
 
+;;; copy of mes/read-0.mes, comment-out read-input-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 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))
+
+  (set! sexp:define
+        (lambda (e a)
+          (if (atom? (cadr e)) (cons (cadr e) (eval-env (caddr e) a))
+              (cons (caadr e) (eval-env (cons (quote lambda) (cons (cdadr e) (cddr e))) a)))))
+
+  (set! env:macro
+        (lambda (name+entry)
+          (cons
+           (cons (car name+entry)
+                 (make-macro (car name+entry)
+                             (cdr name+entry)))
+           (list))))
+
+  (set! cons*
+        (lambda (. rest)
+          (if (null? (cdr rest)) (car rest)
+              (cons (car rest) (apply-env 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 car (make-function 'car 0))
   ;; (define cdr (make-function 'cdr 1))
   ;; (define cons (make-function 'cons 1))
     (helper (read)))
 
   (define-macro (cond . clauses)
-    (list 'if (pair? clauses)
-          (list 'if (car (car clauses))
+    (list (quote if) (pair? clauses)
+          (list (quote if) (car (car clauses))
                 (if (pair? (cdar clauses))
-                    (if (eq? (cadar clauses) '=>)
+                    (if (eq? (cadar clauses) (quote =>))
                         (append2 (cddar clauses) (list (caar clauses)))
-                        (list (cons 'lambda (cons '() (car clauses)))))
-                    (list (cons 'lambda (cons '() (car clauses)))))
+                        (list (cons (quote lambda) (cons (list) (car clauses)))))
+                    (list (cons (quote lambda) (cons (list) (car clauses)))))
               (if (pair? (cdr clauses))
-                  (cons 'cond (cdr clauses))))))
-  
+                  (cons (quote cond) (cdr clauses))))))
+
   (define (eat-whitespace)
     (cond
      ((eq? (peek-byte) 9) (read-byte) (eat-whitespace))