core: Make closure real type.
authorJan Nieuwenhuizen <janneke@gnu.org>
Fri, 23 Dec 2016 17:48:36 +0000 (18:48 +0100)
committerJan Nieuwenhuizen <janneke@gnu.org>
Fri, 23 Dec 2016 17:48:36 +0000 (18:48 +0100)
* display.c (display_helper):
* mes.c (type_t): Add CLOSURE.
  (scm_t): Add closure.
  (CLOSURE): New macro.
  (eval_apply:apply): Update.
  (eval_apply:eval): Remove closure special-casing.
  (gc_loop): Handle CLOSURE.
* module/mes/read-0.mes: Update types.
* module/mes/type-0.mes: Update types.
* display.c (display): Update.
* module/mes/fluids.mes (env:escape-closure): Check for '*closure.

display.c
mes.c
module/mes/fluids.mes
module/mes/read-0.mes
module/mes/type-0.mes

index 4592e1d3aaef460f96ac1ebec364dca396a7612a..4b21c54f5c0626341283d7b4f2c5edb536642be5 100644 (file)
--- a/display.c
+++ b/display.c
@@ -70,6 +70,13 @@ display_helper (FILE* f, SCM x, bool cont, char const *sep, bool quote)
         else fprintf (f, "#\\%c", VALUE (x));
         break;
       }
+    case CLOSURE:
+      {
+        fprintf (f, "#<procedure #f ");
+        display_ (f, (cadr (CLOSURE (x))));
+        fprintf (f, ">");
+        return cell_unspecified;
+      }
     case MACRO:
       fprintf (f, "(*macro* ");
       display_helper (f, g_cells[x].macro, cont, sep, quote);
@@ -78,12 +85,6 @@ display_helper (FILE* f, SCM x, bool cont, char const *sep, bool quote)
     case NUMBER: fprintf (f, "%d", VALUE (x)); break;
     case PAIR:
       {
-        if (car (x) == cell_closure) {
-          fprintf (f, "#<procedure #f ");
-          display_ (f, (caddr (x)));
-          fprintf (f, ">");
-          return cell_unspecified;
-        }
         if (car (x) == cell_circular) {
           fprintf (f, "(*circ* . #-1#)");
           return cell_unspecified;
diff --git a/mes.c b/mes.c
index bf128479abef2e42062a1fc73f1180a8b6060a24..7754cff72b3998c00cb259105be34a27a122719b 100644 (file)
--- a/mes.c
+++ b/mes.c
@@ -36,7 +36,7 @@ int MAX_ARENA_SIZE = 20000000;
 int GC_SAFETY = 100;
 
 typedef int SCM;
-enum type_t {CHAR, FUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, STRING, SYMBOL, VALUES, VECTOR, BROKEN_HEART};
+enum type_t {CHAR, CLOSURE, FUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, STRING, SYMBOL, VALUES, VECTOR, BROKEN_HEART};
 typedef SCM (*function0_t) (void);
 typedef SCM (*function1_t) (SCM);
 typedef SCM (*function2_t) (SCM, SCM);
@@ -66,6 +66,7 @@ typedef struct scm_t {
     int value;
     int function;
     SCM cdr;
+    SCM closure;
     SCM macro;
     SCM vector;
     int hits;
@@ -165,6 +166,7 @@ SCM r3 = 0; // param 3
 #define NAME(x) g_cells[x].name
 #define STRING(x) g_cells[x].string
 #define TYPE(x) g_cells[x].type
+#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
@@ -392,47 +394,54 @@ eval_apply ()
   return cons (r2, r1);
 
  apply:
-  if (TYPE (r1) != PAIR)
+  switch (TYPE (r1))
     {
-      if (TYPE (r1) == FUNCTION) return call (r1, r2);
-      if (r1 == cell_symbol_call_with_values)
-        {
-          r1 = car (r2);
-          r2 = cadr (r2);
-          goto call_with_values;
-        }
-      if (r1 == cell_symbol_current_module) return r0;
-    }
-  else
-    switch (car (r1))
+    case FUNCTION: return call (r1, r2);
+    case CLOSURE:
       {
-      case cell_symbol_lambda:
-        {
-          SCM args = cadr (r1);
-          SCM body = cddr (r1);
-          SCM p = pairlis (args, r2, r0);
-          call_lambda (body, p, p, r0);
-          goto begin;
-        }
-      case cell_closure:
-        {
-          SCM args = caddr (r1);
-          SCM body = cdddr (r1);
-          SCM aa = cdadr (r1);
-          aa = cdr (aa);
-          SCM p = pairlis (args, r2, aa);
-          call_lambda (body, p, aa, r0);
-          goto begin;
-        }
+        SCM cl = CLOSURE (r1);
+        SCM args = cadr (cl);
+        SCM body = cddr (cl);
+        SCM aa = cdar (cl);
+        aa = cdr (aa);
+        SCM p = pairlis (args, r2, aa);
+        call_lambda (body, p, aa, r0);
+        goto begin;
+      }
+    case SYMBOL:
+      {
+        if (r1 == cell_symbol_call_with_values)
+          {
+            r1 = car (r2);
+            r2 = cadr (r2);
+            goto call_with_values;
+          }
+        if (r1 == cell_symbol_current_module) return r0;
+        break;
+      }
+    case PAIR:
+      {
+        switch (car (r1))
+          {
+          case cell_symbol_lambda:
+            {
+              SCM args = cadr (r1);
+              SCM body = cddr (r1);
+              SCM p = pairlis (args, r2, r0);
+              call_lambda (body, p, p, r0);
+              goto begin;
+            }
 #if BOOT
-      case cell_symbol_label:
-        {
-          r0 = cons (cons (cadr (r1), caddr (r1)), r0);
-          r1 = caddr (r1);
-          goto apply;
-        }
+          case cell_symbol_label:
+            {
+              r0 = cons (cons (cadr (r1), caddr (r1)), r0);
+              r1 = caddr (r1);
+              goto apply;
+            }
 #endif
+          }
       }
+    }
   SCM e = eval_env (r1, r0);
   char const* type = 0;
   if (e == cell_f || e == cell_t) type = "bool";
@@ -471,7 +480,6 @@ eval_apply ()
           case cell_symbol_begin: goto begin;
           case cell_symbol_lambda:
             return make_closure (cadr (r1), cddr (r1), assq (cell_closure, r0));
-          case cell_closure: return r1;
           case cell_symbol_if: {r1=cdr (r1); goto label_if;}
           case cell_symbol_set_x: {
             SCM x = eval_env (caddr (r1), r0); return set_env_x (cadr (r1), x, r0);
@@ -928,7 +936,8 @@ gc_loop (SCM scan)
 {
   while (scan < g_free.value)
     {
-      if (NTYPE (scan) == KEYWORD
+      if (NTYPE (scan) == CLOSURE
+          || NTYPE (scan) == KEYWORD
           || NTYPE (scan) == MACRO
           || NTYPE (scan) == PAIR
           || NTYPE (scan) == REF
@@ -940,7 +949,8 @@ gc_loop (SCM scan)
           SCM car = gc_copy (g_news[scan].car);
           gc_relocate_car (scan, car);
         }
-      if ((NTYPE (scan) == MACRO
+      if ((NTYPE (scan) == CLOSURE
+           || NTYPE (scan) == MACRO
            || NTYPE (scan) == PAIR
            || NTYPE (scan) == VALUES)
           && g_news[scan].cdr) // allow for 0 terminated list of symbols
@@ -1099,7 +1109,7 @@ mes_environment () ///((internal))
 SCM
 make_closure (SCM args, SCM body, SCM a)
 {
-  return cons (cell_closure, cons (cons (cell_circular, a), cons (args, body)));
+  return make_cell (tmp_num_ (CLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body)));
 }
 
 SCM
index c1194d85adf8252a82292bc90df8538a0f0d13c1..d9a8d05ac4065bc754b00da465ccca3772b171e0 100644 (file)
@@ -31,8 +31,8 @@
   )
 
 (define (env:escape-closure a n)
-  (if (closure? (car a)) (if (= 0 n) a
-                             (env:escape-closure (cdr a) (- n 1)))
+  (if (eq? (caar a) '*closure*) (if (= 0 n) a
+                                    (env:escape-closure (cdr a) (- n 1)))
       (env:escape-closure (cdr a) n)))
 
 (define-macro (module-define! name value a)
index 3d8249614d573bcca48672e21751f455d9fc50ec..28cb8eb6df0c23ba0d0c8a310376030f791d651b 100644 (file)
@@ -43,8 +43,8 @@
           (set-cdr! (assq (quote *closure*) a) a+)
           (car a+)))
 
-  (env:define (cons (cons (quote <cell:macro>) 3) (list)) (current-module))
-  (env:define (cons (cons (quote <cell:pair>) 5) (list)) (current-module))
+  (env:define (cons (cons (quote <cell:macro>) 4) (list)) (current-module))
+  (env:define (cons (cons (quote <cell:pair>) 6) (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))
                (quote ((current-module))))))
      (current-module))) (current-module))
 
-  (define <cell:keyword> 2)
+  (define <cell:keyword> 3)
 
   (define (read)
     (read-word (read-byte) (list) (current-module)))
index cb17e1c8b9f5e323857b92dc531402b8728ed66c..c0b15284e2be2e08633fac0198daae64e320a065 100644 (file)
 ;;; Code:
 
 (define <cell:char> 0)
-(define <cell:function> 1)
-(define <cell:keyword> 2)
-(define <cell:macro> 3)
-(define <cell:number> 4)
-(define <cell:pair> 5)
-(define <cell:ref> 6)
-(define <cell:special> 7)
-(define <cell:string> 8)
-(define <cell:symbol> 9)
-(define <cell:values> 10)
-(define <cell:vector> 11)
-(define <cell:broken-heart> 12)
+(define <cell:closure> 1)
+(define <cell:function> 2)
+(define <cell:keyword> 3)
+(define <cell:macro> 4)
+(define <cell:number> 5)
+(define <cell:pair> 6)
+(define <cell:ref> 7)
+(define <cell:special> 8)
+(define <cell:string> 9)
+(define <cell:symbol> 10)
+(define <cell:values> 11)
+(define <cell:vector> 12)
+(define <cell:broken-heart> 13)
 
 (define cell:type-alist
   (list (cons <cell:char> (quote <cell:char>))
+        (cons <cell:closure> (quote <cell:closure>))
         (cons <cell:function> (quote <cell:function>))
         (cons <cell:keyword> (quote <cell:keyword>))
         (cons <cell:macro> (quote <cell:macro>))
@@ -57,6 +59,9 @@
 (define (char? x)
   (eq? (core:type x) <cell:char>))
 
+(define (closure? x)
+  (eq? (core:type x) <cell:closure>))
+
 (define (function? x)
   (eq? (core:type x) <cell:function>))
 
@@ -75,8 +80,7 @@
   (eq? (core:type x) <cell:pair>))
 
 (define (pair? x)
-  (and (eq? (core:type x) <cell:pair>)
-       (not (eq? (car x) '*closure*))))
+  (eq? (core:type x) <cell:pair>))
 
 (define (special? x)
   (eq? (core:type x) <cell:special>))
 ;; (define (null? x)
 ;;   (eq? x '()))
 
-(define (closure? x)
-  (and (eq? (core:type x) <cell:pair>) (eq? (car x) '*closure*)))
-
 (define (atom? x)
   (not (pair? x)))