core: Add function indirection.
authorJan Nieuwenhuizen <janneke@gnu.org>
Sat, 19 Nov 2016 21:31:30 +0000 (22:31 +0100)
committerJan Nieuwenhuizen <janneke@gnu.org>
Mon, 12 Dec 2016 19:35:19 +0000 (20:35 +0100)
* mes.c (functions): New array.
  (scm_t): Change function pointer to index.
  (make_cell): Handle function.
  (call): Update for function change.
  (display_): Likewise.
  (make_function): New function.
* build-aux/mes-snarf.scm (function->source): Update declarations.
  (function->environment): New function.

build-aux/mes-snarf.scm
mes.c

index b413be9c6f515a52b811646a9a808573a5d73a4b..e80669740e1c586fc01f9672b24bfa7d56dccbf5 100755 (executable)
@@ -70,15 +70,6 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
 (define (function-cell-name f)
   (string-append %cell-prefix% (.name f)))
 
-(define (function->source f i)
-  (string-append
-   (format #f "cell_~a = g_free.value++;\n" (.name f))
-   (format #f "g_cells[cell_~a] = ~a;\n" (.name f) (function-builtin-name f))))
-
-(define (function->environment f i)
-  (string-append
-   (format #f "a = add_environment (a, ~S, ~a);\n" (function-scm-name f) (function-cell-name f))))
-
 (define %start 1)
 (define (symbol->header s i)
   (format #f "SCM cell_~a;\n" s))
@@ -86,17 +77,29 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
 (define (symbol->source s i)
   (string-append
    (format #f "cell_~a = g_free.value++;\n" s)
-   (format #f "g_cells[cell_~a] = scm_~a;\n" s s)))
+   (format #f "g_cells[cell_~a] = scm_~a;\n\n" s s)))
 
 (define (function->header f i)
   (let* ((arity (or (assoc-ref (.annotation f) 'arity)
                     (if (string-null? (.formals f)) 0
                         (length (string-split (.formals f) #\,)))))
          (n (if (eq? arity 'n) -1 arity)))
-    (string-append (format #f "SCM ~a (~a);\n" (.name f) (.formals f))
-                   (format #f "function fun_~a = {.function~a=&~a, .arity=~a};\n" (.name f) arity (.name f) n)
-                   (format #f "scm ~a = {FUNCTION, .name=~S, .function=&fun_~a};\n" (function-builtin-name f) (function-scm-name f) (.name f))
-                   (format #f "SCM cell_~a = ~a;\n" (.name f) i))))
+    (string-append
+     (format #f "SCM ~a (~a);\n" (.name f) (.formals f))
+     (format #f "function fun_~a = {.function~a=&~a, .arity=~a};\n" (.name f) arity (.name f) n)
+     (format #f "scm ~a = {FUNCTION, .name=~S, .function=0};\n" (function-builtin-name f) (function-scm-name f))
+     (format #f "SCM cell_~a;\n\n" (.name f)))))
+
+(define (function->source f i)
+  (string-append
+   (format #f "~a.function = g_function;\n" (function-builtin-name f))
+   (format #f "functions[g_function++] = fun_~a;\n" (.name f))
+   (format #f "cell_~a = g_free.value++;\n" (.name f))
+   (format #f "g_cells[cell_~a] = ~a;\n\n" (.name f) (function-builtin-name f))))
+
+(define (function->environment f i)
+  (string-append
+   (format #f "a = add_environment (a, ~S, ~a);\n" (function-scm-name f) (function-cell-name f))))
 
 (define (snarf-symbols string)
   (let* ((matches (append (list-matches "\nscm scm_([a-z_0-9]+) = [{](SPECIAL)," string)
@@ -127,7 +130,6 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
   (let* ((string (with-input-from-file file-name read-string))
          (functions (snarf-functions string))
          (functions (delete-duplicates functions (lambda (a b) (equal? (.name a) (.name b)))))
-         (functions (sort functions (lambda (a b) (string< (.name a) (.name b)))))
          (functions (filter (negate internal?) functions))
          (symbols (snarf-symbols string))
          (base-name (basename file-name ".c"))
@@ -136,7 +138,7 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
                    #:content (string-join (map function->header functions (iota (length functions) (+ %start (length symbols)))) "")))
          (source (make <file>
                         #:name (string-append base-name ".i")
-                        #:content (string-join (map function->source (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) "")))
+                        #:content (string-join (map function->source (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) ""))) 
          (environment (make <file>
                         #:name (string-append base-name ".environment.i")
                         #:content (string-join (map function->environment (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) "")))
@@ -156,4 +158,3 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
     (map file-write (filter content? (append-map generate-includes files)))))
 
 ;;(define string (with-input-from-file "../mes.c" read-string))
-
diff --git a/mes.c b/mes.c
index 4a8ccb59996ef4c3cfa021d0ab101b3c97de7a5b..745e2d712ab0786d78f50c57fde79e47e57c231d 100644 (file)
--- a/mes.c
+++ b/mes.c
@@ -84,7 +84,7 @@ typedef struct scm_t {
   };
   union {
     int value;
-    function* function;
+    int function;
     SCM cdr;
     SCM macro;
     SCM vector;
@@ -92,6 +92,9 @@ typedef struct scm_t {
   };
 } scm;
 
+function functions[200];
+int g_function = 0;
+
 #include "mes.symbols.h"
 #include "define.h"
 #include "lib.h"
@@ -179,6 +182,8 @@ scm *g_news = 0;
 #define VALUE(x) g_cells[x].value
 #define VECTOR(x) g_cells[x].vector
 
+#define FUNCTION(x) functions[g_cells[x].function]
+
 #define NCAR(x) g_news[x].car
 #define NTYPE(x) g_news[x].type
 
@@ -389,6 +394,9 @@ make_cell (SCM type, SCM car, SCM cdr)
   if (VALUE (type) == CHAR || VALUE (type) == NUMBER) {
     if (car) g_cells[x].car = g_cells[car].car;
     if (cdr) g_cells[x].cdr = g_cells[cdr].cdr;
+  } else if (VALUE (type) == FUNCTION) {
+    if (car) g_cells[x].car = car;
+    if (cdr) g_cells[x].cdr = g_cells[cdr].cdr;
   } else {
     g_cells[x].car = car;
     g_cells[x].cdr = cdr;
@@ -893,19 +901,19 @@ display_ (FILE* f, SCM x)
 SCM
 call (SCM fn, SCM x)
 {
-  if ((g_cells[fn].function->arity > 0 || g_cells[fn].function->arity == -1)
+  if ((FUNCTION (fn).arity > 0 || FUNCTION (fn).arity == -1)
       && x != cell_nil && TYPE (CAR (x)) == VALUES)
     x = cons (CADAR (x), CDR (x));
-  if ((g_cells[fn].function->arity > 1 || g_cells[fn].function->arity == -1)
+  if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1)
       && x != cell_nil && TYPE (CDR (x)) == PAIR && TYPE (CADR (x)) == VALUES)
     x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
-  switch (g_cells[fn].function->arity)
+  switch (FUNCTION (fn).arity)
     {
-    case 0: return g_cells[fn].function->function0 ();
-    case 1: return g_cells[fn].function->function1 (car (x));
-    case 2: return g_cells[fn].function->function2 (car (x), cadr (x));
-    case 3: return g_cells[fn].function->function3 (car (x), cadr (x), caddr (x));
-    case -1: return g_cells[fn].function->functionn (x);
+    case 0: return FUNCTION (fn).function0 ();
+    case 1: return FUNCTION (fn).function1 (car (x));
+    case 2: return FUNCTION (fn).function2 (car (x), cadr (x));
+    case 3: return FUNCTION (fn).function3 (car (x), cadr (x), caddr (x));
+    case -1: return FUNCTION (fn).functionn (x);
     }
   return cell_unspecified;
 }
@@ -933,6 +941,19 @@ make_char (int x)
   return make_cell (tmp_num, tmp_num2, tmp_num2);
 }
 
+SCM
+make_function (SCM name, SCM id, SCM arity)
+{
+  g_cells[tmp_num3].value = FUNCTION;
+  // function fun_read_byte = {.function0=&read_byte, .arity=0};
+  // scm scm_read_byte = {FUNCTION, .name="read-int", .function=&fun_read_byte};
+  // SCM cell_read_byte = 93;
+  function *f = (function*)malloc (sizeof (function));
+  f->arity = VALUE (arity);
+  g_cells[tmp_num4].value = (long)f;
+  return make_cell (tmp_num3, name, tmp_num4);
+}
+
 SCM
 make_macro (SCM name, SCM x)
 {
@@ -1233,7 +1254,18 @@ display_helper (FILE* f, SCM x, bool cont, char const *sep, bool quote)
         break;
       }
     case REF: display_helper (f, g_cells[x].ref, cont, "", true); break;
-    case FUNCTION: fprintf (f, "#<procedure %s>", g_cells[x].name); ;break;
+    case FUNCTION:
+      {
+        fprintf (f, "#<procedure ");
+        SCM p = g_cells[x].string;
+        char const* n = g_cells[x].name;
+        if (p < 0 || p >= g_free.value || g_cells[p].type != PAIR)
+          fprintf (f, "%s", g_cells[x].name);
+        else
+          display_ (f, g_cells[x].string);
+        fprintf (f, ">");
+        break;
+      }
     case BROKEN_HEART: fprintf (f, "<3"); break;
     default:
       if (STRING (x))