diff --git a/build-aux/mes-snarf.scm b/build-aux/mes-snarf.scm index b413be9c..e8066974 100755 --- a/build-aux/mes-snarf.scm +++ b/build-aux/mes-snarf.scm @@ -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 #: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 #: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 4a8ccb59..745e2d71 100644 --- 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, "#", g_cells[x].name); ;break; + case FUNCTION: + { + fprintf (f, "#= 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))