core: Add function indirection.
* 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.
This commit is contained in:
Jan Nieuwenhuizen
parent
61e42e8527
commit
d50b0fe24a
|
|
@ -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))
|
||||
(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))))
|
||||
(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"))
|
||||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
52
mes.c
52
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))
|
||||
|
|
|
|||
Loading…
Reference in a new issue