diff --git a/build-aux/mes-snarf.scm b/build-aux/mes-snarf.scm index 97499e39..06f268aa 100755 --- a/build-aux/mes-snarf.scm +++ b/build-aux/mes-snarf.scm @@ -34,6 +34,7 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e (cut regexp-substitute #f <> 'pre replace 'post)) string)) +(define GCC? #t) ;; (define-record-type function (make-function name formals annotation) ;; function? ;; (name .name) @@ -78,7 +79,7 @@ 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 "g_free.value++;\n") + (format #f "g_free++;\n") (format #f "g_cells[cell_~a] = scm_~a;\n\n" s s))) (define (symbol->names s i) @@ -92,28 +93,29 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e (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=0};\n" (function-builtin-name f) (function-scm-name f)) + (if GCC? + (format #f "function_t fun_~a = {.function~a=&~a, .arity=~a};\n" (.name f) arity (.name f) n) + (format #f "function_t fun_~a = {&~a, ~a};\n" (.name f) (.name f) n)) + (if GCC? + (format #f "scm ~a = {FUNCTION, .name=~S, .function=0};\n" (function-builtin-name f) (function-scm-name f)) + (format #f "scm ~a = {FUNCTION, ~S, 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 "cell_~a = g_free++;\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 "scm_~a.string = cstring_to_list (scm_~a.name);\n" (.name f) (.name f)) (format #f "g_cells[cell_~a].string = MAKE_STRING (scm_~a.string);\n" (.name f) (.name f)) - (format #f "a = acons (make_symbol (scm_~a.string), ~a, a);\n" (.name f) (function-cell-name f)) - ;;(format #f "a = add_environment (a, ~S, ~a);\n" (function-scm-name f) (function-cell-name f)) - )) + (format #f "a = acons (make_symbol (scm_~a.string), ~a, a);\n\n" (.name f) (function-cell-name f)))) (define (snarf-symbols string) - (let* ((matches (append (list-matches "\nscm scm_([a-z_0-9]+) = [{](SPECIAL)," string) - (list-matches "\nscm scm_([a-z_0-9]+) = [{](SYMBOL)," string)))) + (let* ((matches (list-matches "\nscm scm_([a-z_0-9]+) = [{](SPECIAL|SYMBOL)," string))) (map (cut match:substring <> 1) matches))) (define (snarf-functions string) diff --git a/lib.c b/lib.c index 8b09cb9b..eaf26ce3 100644 --- a/lib.c +++ b/lib.c @@ -136,7 +136,7 @@ dump () fputc ('S', stdout); fputc (g_stack >> 8, stdout); fputc (g_stack % 256, stdout); - for (int i=0; i #include #include @@ -27,6 +31,12 @@ #include #include #include +#else +typedef int bool; +#define __NYACC__ 1 +#define NYACC nyacc +#define NYACC2 nyacc2 +#endif #define DEBUG 0 #define FIXED_PRIMITIVES 1 @@ -42,18 +52,18 @@ typedef SCM (*function1_t) (SCM); typedef SCM (*function2_t) (SCM, SCM); typedef SCM (*function3_t) (SCM, SCM, SCM); typedef SCM (*functionn_t) (SCM); -typedef struct function_t { +typedef struct function_struct { union { function0_t function0; function1_t function1; function2_t function2; function3_t function3; functionn_t functionn; - }; + } NYACC; int arity; -} function; -struct scm_t; -typedef struct scm_t { +} function_t; +struct scm; +typedef struct scm_struct { enum type_t type; union { char const *name; @@ -61,7 +71,7 @@ typedef struct scm_t { SCM car; SCM ref; int length; - }; + } NYACC; union { int value; int function; @@ -70,7 +80,7 @@ typedef struct scm_t { SCM macro; SCM vector; int hits; - }; + } NYACC2; } scm; scm scm_nil = {SPECIAL, "()"}; @@ -88,9 +98,8 @@ scm scm_symbol_dot = {SYMBOL, "*dot*"}; scm scm_symbol_lambda = {SYMBOL, "lambda"}; scm scm_symbol_begin = {SYMBOL, "begin"}; scm scm_symbol_if = {SYMBOL, "if"}; -scm scm_symbol_set_x = {SYMBOL, "set!"}; - scm scm_symbol_quote = {SYMBOL, "quote"}; +scm scm_symbol_set_x = {SYMBOL, "set!"}; scm scm_symbol_sc_expand = {SYMBOL, "sc-expand"}; scm scm_symbol_macro_expand = {SYMBOL, "macro-expand"}; @@ -113,7 +122,7 @@ scm scm_symbol_null_p = {SYMBOL, "null?"}; scm scm_symbol_eq_p = {SYMBOL, "eq?"}; scm scm_symbol_cons = {SYMBOL, "cons"}; -scm g_free = {NUMBER, .value=0}; +int g_free = 0; scm *g_cells; scm *g_news = 0; @@ -122,10 +131,8 @@ scm *g_news = 0; SCM tmp; SCM tmp_num; SCM tmp_num2; -SCM tmp_num3; -SCM tmp_num4; -function functions[200]; +function_t functions[200]; int g_function = 0; SCM g_symbols = 0; @@ -190,9 +197,9 @@ tmp_num2_ (int x) SCM alloc (int n) { - assert (g_free.value + n < ARENA_SIZE); - SCM x = g_free.value; - g_free.value += n; + assert (g_free + n < ARENA_SIZE); + SCM x = g_free; + g_free += n; return x; } @@ -235,6 +242,18 @@ cdr (SCM x) if (TYPE (x) != PAIR) error ("cdr: not pair: ", x); return CDR (x); } +SCM +eq_p (SCM x, SCM y) +{ + return (x == y + || ((TYPE (x) == KEYWORD && TYPE (y) == KEYWORD + && STRING (x) == STRING (y))) + || (TYPE (x) == CHAR && TYPE (y) == CHAR + && VALUE (x) == VALUE (y)) + || (TYPE (x) == NUMBER && TYPE (y) == NUMBER + && VALUE (x) == VALUE (y))) + ? cell_t : cell_f; +} SCM type_ (SCM x) @@ -262,19 +281,6 @@ cdr_ (SCM x) || TYPE (CDR (x)) == STRING) ? CDR (x) : MAKE_NUMBER (CDR (x)); } -SCM -eq_p (SCM x, SCM y) -{ - return (x == y - || ((TYPE (x) == KEYWORD && TYPE (y) == KEYWORD - && STRING (x) == STRING (y))) - || (TYPE (x) == CHAR && TYPE (y) == CHAR - && VALUE (x) == VALUE (y)) - || (TYPE (x) == NUMBER && TYPE (y) == NUMBER - && VALUE (x) == VALUE (y))) - ? cell_t : cell_f; -} - SCM set_car_x (SCM x, SCM e) { @@ -576,7 +582,7 @@ vm_call (function0_t f, SCM p1, SCM a) gc_push_frame (); r1 = p1; r0 = a; - if (g_free.value + GC_SAFETY > ARENA_SIZE) + if (g_free + GC_SAFETY > ARENA_SIZE) gc_pop_frame (gc (gc_push_frame ())); SCM r = f (); @@ -770,16 +776,12 @@ vector_to_list (SCM v) void make_tmps (scm* cells) { - tmp = g_free.value++; + tmp = g_free++; cells[tmp].type = CHAR; - tmp_num = g_free.value++; + tmp_num = g_free++; cells[tmp_num].type = NUMBER; - tmp_num2 = g_free.value++; + tmp_num2 = g_free++; cells[tmp_num2].type = NUMBER; - tmp_num3 = g_free.value++; - cells[tmp_num3].type = NUMBER; - tmp_num4 = g_free.value++; - cells[tmp_num4].type = NUMBER; } // Jam Collector @@ -791,7 +793,7 @@ gc_up_arena () { ARENA_SIZE *= 2; void *p = realloc (g_cells-1, 2*ARENA_SIZE*sizeof(scm)); - if (!p) error (strerror (errno), MAKE_NUMBER (g_free.value)); + if (!p) error (strerror (errno), MAKE_NUMBER (g_free)); g_cells = (scm*)p; g_cells++; gc_init_news (); @@ -800,10 +802,10 @@ gc_up_arena () SCM gc () { - if (g_debug) fprintf (stderr, "***gc[%d]...", g_free.value); - g_free.value = 1; + if (g_debug) fprintf (stderr, "***gc[%d]...", g_free); + g_free = 1; if (g_cells < g_news && ARENA_SIZE < MAX_ARENA_SIZE) gc_up_arena (); - for (int i=g_free.value; i jam[%d]\n", g_free.value); + if (g_debug) fprintf (stderr, " => jam[%d]\n", g_free); return g_stack; } @@ -926,7 +928,7 @@ mes_symbols () ///((internal)) #include "mes.symbols.i" - g_symbol_max = g_free.value; + g_symbol_max = g_free; make_tmps (g_cells); g_symbols = 0; @@ -1012,10 +1014,13 @@ FILE *g_stdin; int main (int argc, char *argv[]) { +#if __GNUC__ g_debug = getenv ("MES_DEBUG"); +#else +#endif if (getenv ("MES_ARENA")) ARENA_SIZE = atoi (getenv ("MES_ARENA")); if (argc > 1 && !strcmp (argv[1], "--help")) return puts ("Usage: mes [--dump|--load] < FILE"); - if (argc > 1 && !strcmp (argv[1], "--version")) return puts ("Mes " VERSION); + if (argc > 1 && !strcmp (argv[1], "--version")) {puts ("Mes ");puts (VERSION);return 0;}; g_stdin = stdin; r0 = mes_environment (); SCM program = (argc > 1 && !strcmp (argv[1], "--load")) @@ -1029,6 +1034,9 @@ main (int argc, char *argv[]) stderr_ (begin_env (program, r0)); fputs ("", stderr); gc (g_stack); - if (g_debug) fprintf (stderr, "\nstats: [%d]\n", g_free.value); +#if __GNUC__ + if (g_debug) fprintf (stderr, "\nstats: [%d]\n", g_free); +#else +#endif return 0; }