andrius
/
mes
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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 2016-11-19 22:31:30 +01:00
parent 61e42e8527
commit d50b0fe24a
2 changed files with 60 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
build-aux/mes-snarf.scm
View File

@ -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))

52
mes.c
View File

@ -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))