diff --git a/GNUmakefile b/GNUmakefile index 5e4675b6..a0499aa5 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -36,7 +36,7 @@ mes.o: posix.c posix.h posix.i posix.environment.i mes.o: reader.c reader.h reader.i reader.environment.i clean: - rm -f mes mes.o *.environment.i *.symbols.i *.environment.h *.cat a.out + rm -f mes *.o *.environment.i *.symbols.i *.environment.h *.cat a.out distclean: clean rm -f .config.make @@ -113,15 +113,15 @@ mescc-check: t-check chmod +x a.out ./a.out -mini-mes: scaffold/mini-mes.c GNUmakefile - rm -f $@ - gcc -nostdlib --std=gnu99 -m32 -g -o $@ '-DVERSION="0.4"' $< - chmod +x $@ +%.h %.i %.environment.i %.symbols.i: scaffold/%.c build-aux/mes-snarf.scm + build-aux/mes-snarf.scm $< -# mini-mes: doc/examples/mini-mes.c GNUmakefile -# rm -f $@ -# gcc -nostdlib --std=gnu99 -g -o $@ '-DVERSION="0.4"' $< -# chmod +x $@ +mini-mes: mini-mes.h mini-mes.i mini-mes.environment.i mini-mes.symbols.i +mini-mes: GNUmakefile +mini-mes: doc/examples/mini-mes.c + rm -f $@ + gcc -nostdlib --std=gnu99 -m32 -g -I. -o $@ '-DVERSION="0.4"' $< + chmod +x $@ cons-mes: scaffold/cons-mes.c GNUmakefile rm -f $@ diff --git a/build-aux/mes-snarf.scm b/build-aux/mes-snarf.scm index d79f7e38..71054379 100755 --- a/build-aux/mes-snarf.scm +++ b/build-aux/mes-snarf.scm @@ -84,7 +84,9 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e (define (symbol->names s i) (string-append - (format #f "g_cells[cell_~a].car = cstring_to_list (scm_~a.name);\n" s s))) + (if GCC? + (format #f "g_cells[cell_~a].car = cstring_to_list (scm_~a.name);\n" s s) + (format #f "g_cells[cell_~a].car = cstring_to_list (scm_~a.car);\n" s s)))) (define (function->header f i) (let* ((arity (or (assoc-ref (.annotation f) 'arity) @@ -94,28 +96,36 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e (string-append (format #f "SCM ~a (~a);\n" (.name f) (.formals f)) (if GCC? - (format #f "function_t fun_~a = {.function~a=&~a, .arity=~a, .name=~s};\n" (.name f) arity (.name f) n (function-scm-name f)) - (format #f "function_t fun_~a = {&~a, ~a, ~s};\n" (.name f) (.name f) n (function-scm-name f))) + (format #f "struct function fun_~a = {.function~a=&~a, .arity=~a, .name=~s};\n" (.name f) arity (.name f) n (function-scm-name f)) + (format #f "struct function fun_~a = {&~a, ~a, ~s};\n" (.name f) (.name f) n (function-scm-name f))) (if GCC? - (format #f "scm ~a = {FUNCTION, .name=0, .function=0};\n" (function-builtin-name f)) - (format #f "scm ~a = {FUNCTION, 0, 0};\n" (function-builtin-name f))) + (format #f "struct scm ~a = {TFUNCTION, .name=0, .function=0};\n" (function-builtin-name f)) + (format #f "struct scm ~a = {TFUNCTION, 0, 0};\n" (function-builtin-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)) + (if GCC? + (format #f "~a.function = g_function;\n" (function-builtin-name f)) + (format #f "~a.cdr = g_function;\n" (function-builtin-name f))) (format #f "g_functions[g_function++] = fun_~a;\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 (fun_~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\n" (.name f) (function-cell-name f)))) + (if GCC? + (format #f "scm_~a.string = cstring_to_list (fun_~a.name);\n" (.name f) (.name f)) + (format #f "scm_~a.car = cstring_to_list (fun_~a.name);\n" (.name f) (.name f))) + (if GCC? + (format #f "g_cells[cell_~a].string = MAKE_STRING (scm_~a.string);\n" (.name f) (.name f)) + (format #f "g_cells[cell_~a].car = MAKE_STRING (scm_~a.car);\n" (.name f) (.name f))) + (if GCC? + (format #f "a = acons (make_symbol (scm_~a.string), ~a, a);\n\n" (.name f) (function-cell-name f)) + (format #f "a = acons (make_symbol (scm_~a.car), ~a, a);\n\n" (.name f) (function-cell-name f))))) (define (snarf-symbols string) - (let* ((matches (list-matches "\nscm scm_([a-z_0-9]+) = [{](SPECIAL|SYMBOL)," string))) + (let* ((matches (list-matches "\nstruct scm scm_([a-z_0-9]+) = [{](TSPECIAL|TSYMBOL)," string))) (map (cut match:substring <> 1) matches))) (define (snarf-functions string) diff --git a/guile/mes.mes b/guile/mes.mes index 25e7b25d..38b1ac1a 100644 --- a/guile/mes.mes +++ b/guile/mes.mes @@ -46,7 +46,7 @@ ((eq? (caar a) x) (car a)) (#t (assq x (cdr a))))) -(define (assq-ref-cache x a) +(define (assq-ref-env x a) (let ((e (assq x a))) (if (eq? e #f) '*undefined* (cdr e)))) @@ -92,7 +92,7 @@ (define (eval-expand e a) (cond ((eq? e '*undefined*) e) - ((symbol? e) (assq-ref-cache e a)) + ((symbol? e) (assq-ref-env e a)) ((atom? e) e) ((atom? (car e)) (cond diff --git a/guile/mes.scm b/guile/mes.scm index d9830a5e..ea0f32e2 100755 --- a/guile/mes.scm +++ b/guile/mes.scm @@ -179,7 +179,7 @@ exec guile -L $(pwd) -e '(mes)' -s "$0" "$@" (evcon . evcon) (pairlis . pairlis) (assq . assq) - (assq-ref-cache . assq-ref-cache) + (assq-ref-env . assq-ref-env) (eval-env . eval-env) (apply-env . apply-env) diff --git a/lib.c b/lib.c index cc09ea3a..10ee9f7b 100644 --- a/lib.c +++ b/lib.c @@ -18,11 +18,6 @@ * along with Mes. If not, see . */ -SCM caar (SCM x) {return car (car (x));} -SCM cadr (SCM x) {return car (cdr (x));} -SCM cdar (SCM x) {return cdr (car (x));} -SCM cddr (SCM x) {return cdr (cdr (x));} - SCM xassq (SCM x, SCM a) ///for speed in core only { @@ -37,7 +32,7 @@ length (SCM x) while (x != cell_nil) { n++; - if (TYPE (x) != PAIR) return MAKE_NUMBER (-1); + if (TYPE (x) != TPAIR) return MAKE_NUMBER (-1); x = cdr (x); } return MAKE_NUMBER (n); @@ -52,30 +47,39 @@ list (SCM x) ///((arity . n)) SCM exit_ (SCM x) ///((name . "exit")) { - assert (TYPE (x) == NUMBER); + assert (TYPE (x) == TNUMBER); exit (VALUE (x)); } -char const* -string_to_cstring (SCM s) +SCM +append (SCM x) ///((arity . n)) { - static char buf[1024]; - char *p = buf; - s = STRING (s); - while (s != cell_nil) - { - *p++ = VALUE (car (s)); - s = cdr (s); - } - *p = 0; - return buf; + if (x == cell_nil) return cell_nil; + if (cdr (x) == cell_nil) return car (x); + return append2 (car (x), append (cdr (x))); } +//MINI_MES +// char const* +// string_to_cstring (SCM s) +// { +// static char buf[1024]; +// char *p = buf; +// s = STRING (s); +// while (s != cell_nil) +// { +// *p++ = VALUE (car (s)); +// s = cdr (s); +// } +// *p = 0; +// return buf; +// } + SCM error (SCM key, SCM x) { SCM throw; - if ((throw = assq_ref_cache (cell_symbol_throw, r0)) != cell_undefined) + if ((throw = assq_ref_env (cell_symbol_throw, r0)) != cell_undefined) return apply (throw, cons (key, cons (x, cell_nil)), r0); assert (!"error"); } @@ -90,7 +94,7 @@ assert_defined (SCM x, SCM e) SCM check_formals (SCM f, SCM formals, SCM args) { - int flen = (TYPE (formals) == NUMBER) ? VALUE (formals) : VALUE (length (formals)); + int flen = (TYPE (formals) == TNUMBER) ? VALUE (formals) : VALUE (length (formals)); int alen = VALUE (length (args)); if (alen != flen && alen != -1 && flen != -1) { @@ -110,9 +114,9 @@ check_apply (SCM f, SCM e) if (f == cell_nil) type = "nil"; if (f == cell_unspecified) type = "*unspecified*"; if (f == cell_undefined) type = "*undefined*"; - if (TYPE (f) == CHAR) type = "char"; - if (TYPE (f) == NUMBER) type = "number"; - if (TYPE (f) == STRING) type = "string"; + if (TYPE (f) == TCHAR) type = "char"; + if (TYPE (f) == TNUMBER) type = "number"; + if (TYPE (f) == TSTRING) type = "string"; if (type) { @@ -174,19 +178,19 @@ dump () CAR (9) = 0x2d2d2d2d; CDR (9) = 0x3e3e3e3e; - TYPE (10) = PAIR; + TYPE (10) = TPAIR; CAR (10) = 11; CDR (10) = 12; - TYPE (11) = CHAR; + TYPE (11) = TCHAR; CAR (11) = 0x58585858; CDR (11) = 65; - TYPE (12) = PAIR; + TYPE (12) = TPAIR; CAR (12) = 13; CDR (12) = 1; - TYPE (13) = CHAR; + TYPE (13) = TCHAR; CAR (11) = 0x58585858; CDR (13) = 66; @@ -196,7 +200,7 @@ dump () g_free = 15; } - for (int i=0; i") (arity . n)) int n = INT_MAX; while (x != cell_nil) { - assert (TYPE (car (x)) == NUMBER); + assert (TYPE (car (x)) == TNUMBER); if (VALUE (car (x)) >= n) return cell_f; n = VALUE (car (x)); x = cdr (x); @@ -38,7 +38,7 @@ less_p (SCM x) ///((name . "<") (arity . n)) int n = INT_MIN; while (x != cell_nil) { - assert (TYPE (car (x)) == NUMBER); + assert (TYPE (car (x)) == TNUMBER); if (VALUE (car (x)) <= n) return cell_f; n = VALUE (car (x)); x = cdr (x); @@ -50,7 +50,7 @@ SCM is_p (SCM x) ///((name . "=") (arity . n)) { if (x == cell_nil) return cell_t; - assert (TYPE (car (x)) == NUMBER); + assert (TYPE (car (x)) == TNUMBER); int n = VALUE (car (x)); x = cdr (x); while (x != cell_nil) @@ -65,14 +65,14 @@ SCM minus (SCM x) ///((name . "-") (arity . n)) { SCM a = car (x); - assert (TYPE (a) == NUMBER); + assert (TYPE (a) == TNUMBER); int n = VALUE (a); x = cdr (x); if (x == cell_nil) n = -n; while (x != cell_nil) { - assert (TYPE (car (x)) == NUMBER); + assert (TYPE (car (x)) == TNUMBER); n -= VALUE (car (x)); x = cdr (x); } @@ -85,7 +85,7 @@ plus (SCM x) ///((name . "+") (arity . n)) int n = 0; while (x != cell_nil) { - assert (TYPE (car (x)) == NUMBER); + assert (TYPE (car (x)) == TNUMBER); n += VALUE (car (x)); x = cdr (x); } @@ -97,13 +97,13 @@ divide (SCM x) ///((name . "/") (arity . n)) { int n = 1; if (x != cell_nil) { - assert (TYPE (car (x)) == NUMBER); + assert (TYPE (car (x)) == TNUMBER); n = VALUE (car (x)); x = cdr (x); } while (x != cell_nil) { - assert (TYPE (car (x)) == NUMBER); + assert (TYPE (car (x)) == TNUMBER); n /= VALUE (car (x)); x = cdr (x); } @@ -113,8 +113,8 @@ divide (SCM x) ///((name . "/") (arity . n)) SCM modulo (SCM a, SCM b) { - assert (TYPE (a) == NUMBER); - assert (TYPE (b) == NUMBER); + assert (TYPE (a) == TNUMBER); + assert (TYPE (b) == TNUMBER); int x = VALUE (a); while (x < 0) x += VALUE (b); return MAKE_NUMBER (x % VALUE (b)); @@ -126,7 +126,7 @@ multiply (SCM x) ///((name . "*") (arity . n)) int n = 1; while (x != cell_nil) { - assert (TYPE (car (x)) == NUMBER); + assert (TYPE (car (x)) == TNUMBER); n *= VALUE (car (x)); x = cdr (x); } @@ -139,7 +139,7 @@ logior (SCM x) ///((arity . n)) int n = 0; while (x != cell_nil) { - assert (TYPE (car (x)) == NUMBER); + assert (TYPE (car (x)) == TNUMBER); n |= VALUE (car (x)); x = cdr (x); } @@ -149,8 +149,8 @@ logior (SCM x) ///((arity . n)) SCM ash (SCM n, SCM count) { - assert (TYPE (n) == NUMBER); - assert (TYPE (count) == NUMBER); + assert (TYPE (n) == TNUMBER); + assert (TYPE (count) == TNUMBER); int cn = VALUE (n); int ccount = VALUE (count); return MAKE_NUMBER ((ccount < 0) ? cn >> -ccount : cn << ccount); diff --git a/mes.c b/mes.c index f0bcc6c1..540053b1 100644 --- a/mes.c +++ b/mes.c @@ -46,13 +46,13 @@ int MAX_ARENA_SIZE = 20000000; int GC_SAFETY = 100; typedef int SCM; -enum type_t {CHAR, CLOSURE, CONTINUATION, FUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, STRING, SYMBOL, VALUES, VECTOR, BROKEN_HEART}; +enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVECTOR, TBROKEN_HEART}; typedef SCM (*function0_t) (void); 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_struct { +struct function { union { function0_t function0; function1_t function1; @@ -62,9 +62,8 @@ typedef struct function_struct { } NYACC; int arity; char const *name; -} function_t; -struct scm; -typedef struct scm_struct { +}; +struct scm { enum type_t type; union { char const* name; @@ -83,88 +82,87 @@ typedef struct scm_struct { SCM vector; int hits; } NYACC2; -} scm; +}; -scm scm_nil = {SPECIAL, "()"}; -scm scm_f = {SPECIAL, "#f"}; -scm scm_t = {SPECIAL, "#t"}; -scm scm_dot = {SPECIAL, "."}; -scm scm_arrow = {SPECIAL, "=>"}; -scm scm_undefined = {SPECIAL, "*undefined*"}; -scm scm_unspecified = {SPECIAL, "*unspecified*"}; -scm scm_closure = {SPECIAL, "*closure*"}; -scm scm_circular = {SPECIAL, "*circular*"}; -scm scm_begin = {SPECIAL, "*begin*"}; +struct scm scm_nil = {TSPECIAL, "()",0}; +struct scm scm_f = {TSPECIAL, "#f",0}; +struct scm scm_t = {TSPECIAL, "#t",0}; +struct scm scm_dot = {TSPECIAL, ".",0}; +struct scm scm_arrow = {TSPECIAL, "=>",0}; +struct scm scm_undefined = {TSPECIAL, "*undefined*",0}; +struct scm scm_unspecified = {TSPECIAL, "*unspecified*",0}; +struct scm scm_closure = {TSPECIAL, "*closure*",0}; +struct scm scm_circular = {TSPECIAL, "*circular*",0}; +struct scm scm_begin = {TSPECIAL, "*begin*",0}; -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_quote = {SYMBOL, "quote"}; -scm scm_symbol_set_x = {SYMBOL, "set!"}; +struct scm scm_symbol_dot = {TSYMBOL, "*dot*",0}; +struct scm scm_symbol_lambda = {TSYMBOL, "lambda",0}; +struct scm scm_symbol_begin = {TSYMBOL, "begin",0}; +struct scm scm_symbol_if = {TSYMBOL, "if",0}; +struct scm scm_symbol_quote = {TSYMBOL, "quote",0}; +struct scm scm_symbol_set_x = {TSYMBOL, "set!",0}; -scm scm_symbol_sc_expand = {SYMBOL, "sc-expand"}; -scm scm_symbol_macro_expand = {SYMBOL, "macro-expand"}; -scm scm_symbol_sc_expander_alist = {SYMBOL, "*sc-expander-alist*"}; +struct scm scm_symbol_sc_expand = {TSYMBOL, "sc-expand",0}; +struct scm scm_symbol_macro_expand = {TSYMBOL, "macro-expand",0}; +struct scm scm_symbol_sc_expander_alist = {TSYMBOL, "*sc-expander-alist*",0}; -scm scm_symbol_call_with_values = {SYMBOL, "call-with-values"}; -scm scm_call_with_current_continuation = {SPECIAL, "*call/cc*"}; -scm scm_symbol_call_with_current_continuation = {SYMBOL, "call-with-current-continuation"}; -scm scm_symbol_current_module = {SYMBOL, "current-module"}; -scm scm_symbol_primitive_load = {SYMBOL, "primitive-load"}; -scm scm_symbol_read_input_file = {SYMBOL, "read-input-file"}; -scm scm_symbol_write = {SYMBOL, "write"}; -scm scm_symbol_display = {SYMBOL, "display"}; +struct scm scm_symbol_call_with_values = {TSYMBOL, "call-with-values",0}; +struct scm scm_call_with_current_continuation = {TSPECIAL, "*call/cc*",0}; +struct scm scm_symbol_call_with_current_continuation = {TSYMBOL, "call-with-current-continuation",0}; +struct scm scm_symbol_current_module = {TSYMBOL, "current-module",0}; +struct scm scm_symbol_primitive_load = {TSYMBOL, "primitive-load",0}; +struct scm scm_symbol_read_input_file = {TSYMBOL, "read-input-file",0}; +struct scm scm_symbol_write = {TSYMBOL, "write",0}; +struct scm scm_symbol_display = {TSYMBOL, "display",0}; -scm scm_symbol_throw = {SYMBOL, "throw"}; -scm scm_symbol_not_a_pair = {SYMBOL, "not-a-pair"}; -scm scm_symbol_system_error = {SYMBOL, "system-error"}; -scm scm_symbol_wrong_number_of_args = {SYMBOL, "wrong-number-of-args"}; -scm scm_symbol_wrong_type_arg = {SYMBOL, "wrong-type-arg"}; -scm scm_symbol_unbound_variable = {SYMBOL, "unbound-variable"}; +struct scm scm_symbol_throw = {TSYMBOL, "throw",0}; +struct scm scm_symbol_not_a_pair = {TSYMBOL, "not-a-pair",0}; +struct scm scm_symbol_system_error = {TSYMBOL, "system-error",0}; +struct scm scm_symbol_wrong_number_of_args = {TSYMBOL, "wrong-number-of-args",0}; +struct scm scm_symbol_wrong_type_arg = {TSYMBOL, "wrong-type-arg",0}; +struct scm scm_symbol_unbound_variable = {TSYMBOL, "unbound-variable",0}; -scm scm_symbol_argv = {SYMBOL, "%argv"}; -scm scm_symbol_mes_prefix = {SYMBOL, "%prefix"}; -scm scm_symbol_mes_version = {SYMBOL, "%version"}; +struct scm scm_symbol_argv = {TSYMBOL, "%argv",0}; +struct scm scm_symbol_mes_prefix = {TSYMBOL, "%prefix",0}; +struct scm scm_symbol_mes_version = {TSYMBOL, "%version",0}; -scm scm_symbol_car = {SYMBOL, "car"}; -scm scm_symbol_cdr = {SYMBOL, "cdr"}; -scm scm_symbol_null_p = {SYMBOL, "null?"}; -scm scm_symbol_eq_p = {SYMBOL, "eq?"}; -scm scm_symbol_cons = {SYMBOL, "cons"}; +struct scm scm_symbol_car = {TSYMBOL, "car",0}; +struct scm scm_symbol_cdr = {TSYMBOL, "cdr",0}; +struct scm scm_symbol_null_p = {TSYMBOL, "null?",0}; +struct scm scm_symbol_eq_p = {TSYMBOL, "eq?",0}; +struct scm scm_symbol_cons = {TSYMBOL, "cons",0}; -scm scm_vm_evlis = {SPECIAL, "*vm-evlis*"}; -scm scm_vm_evlis2 = {SPECIAL, "*vm-evlis2*"}; -scm scm_vm_evlis3 = {SPECIAL, "*vm-evlis3*"}; -scm scm_vm_apply = {SPECIAL, "core:apply"}; -scm scm_vm_apply2 = {SPECIAL, "*vm-apply2*"}; -scm scm_vm_eval = {SPECIAL, "core:eval"}; +struct scm scm_vm_evlis = {TSPECIAL, "*vm-evlis*",0}; +struct scm scm_vm_evlis2 = {TSPECIAL, "*vm-evlis2*",0}; +struct scm scm_vm_evlis3 = {TSPECIAL, "*vm-evlis3*",0}; +struct scm scm_vm_apply = {TSPECIAL, "core:apply",0}; +struct scm scm_vm_apply2 = {TSPECIAL, "*vm-apply2*",0}; +struct scm scm_vm_eval = {TSPECIAL, "core:eval",0}; -#if 1 //FIXED_PRIMITIVES -scm scm_vm_eval_car = {SPECIAL, "*vm-eval-car*"}; -scm scm_vm_eval_cdr = {SPECIAL, "*vm-eval-cdr*"}; -scm scm_vm_eval_cons = {SPECIAL, "*vm-eval-cons*"}; -scm scm_vm_eval_null_p = {SPECIAL, "*vm-eval-null-p*"}; -#endif +//FIXED_PRIMITIVES +struct scm scm_vm_eval_car = {TSPECIAL, "*vm-eval-car*",0}; +struct scm scm_vm_eval_cdr = {TSPECIAL, "*vm-eval-cdr*",0}; +struct scm scm_vm_eval_cons = {TSPECIAL, "*vm-eval-cons*",0}; +struct scm scm_vm_eval_null_p = {TSPECIAL, "*vm-eval-null-p*",0}; -scm scm_vm_eval_set_x = {SPECIAL, "*vm-eval-set!*"}; -scm scm_vm_eval_macro = {SPECIAL, "*vm-eval-macro*"}; -scm scm_vm_eval2 = {SPECIAL, "*vm-eval2*"}; -scm scm_vm_macro_expand = {SPECIAL, "core:macro-expand"}; -scm scm_vm_begin = {SPECIAL, "*vm-begin*"}; -scm scm_vm_begin_read_input_file = {SPECIAL, "*vm-begin-read-input-file*"}; -scm scm_vm_begin2 = {SPECIAL, "*vm-begin2*"}; -scm scm_vm_if = {SPECIAL, "*vm-if*"}; -scm scm_vm_if_expr = {SPECIAL, "*vm-if-expr*"}; -scm scm_vm_call_with_values2 = {SPECIAL, "*vm-call-with-values2*"}; -scm scm_vm_call_with_current_continuation2 = {SPECIAL, "*vm-call-with-current-continuation2*"}; -scm scm_vm_return = {SPECIAL, "*vm-return*"}; +struct scm scm_vm_eval_set_x = {TSPECIAL, "*vm-eval-set!*",0}; +struct scm scm_vm_eval_macro = {TSPECIAL, "*vm-eval-macro*",0}; +struct scm scm_vm_eval2 = {TSPECIAL, "*vm-eval2*",0}; +struct scm scm_vm_macro_expand = {TSPECIAL, "core:macro-expand",0}; +struct scm scm_vm_begin = {TSPECIAL, "*vm-begin*",0}; +struct scm scm_vm_begin_read_input_file = {TSPECIAL, "*vm-begin-read-input-file*",0}; +struct scm scm_vm_begin2 = {TSPECIAL, "*vm-begin2*",0}; +struct scm scm_vm_if = {TSPECIAL, "*vm-if*",0}; +struct scm scm_vm_if_expr = {TSPECIAL, "*vm-if-expr*",0}; +struct scm scm_vm_call_with_values2 = {TSPECIAL, "*vm-call-with-values2*",0}; +struct scm scm_vm_call_with_current_continuation2 = {TSPECIAL, "*vm-call-with-current-continuation2*",0}; +struct scm scm_vm_return = {TSPECIAL, "*vm-return*",0}; -scm scm_test = {SYMBOL, "test"}; +struct scm scm_test = {TSYMBOL, "test",0}; int g_free = 0; -scm *g_cells; -scm *g_news = 0; +struct scm *g_cells; +struct scm *g_news = 0; #include "mes.symbols.h" @@ -172,7 +170,7 @@ SCM tmp; SCM tmp_num; SCM tmp_num2; -function_t g_functions[200]; +struct function g_functions[200]; int g_function = 0; SCM g_continuations = 0; @@ -215,11 +213,11 @@ SCM r3 = 0; // continuation #define CDADAR(x) CAR (CDR (CAR (CDR (x)))) #define CADR(x) CAR (CDR (x)) -#define MAKE_CHAR(n) make_cell (tmp_num_ (CHAR), 0, tmp_num2_ (n)) -#define MAKE_CONTINUATION(n) make_cell (tmp_num_ (CONTINUATION), n, g_stack) -#define MAKE_NUMBER(n) make_cell (tmp_num_ (NUMBER), 0, tmp_num2_ (n)) -#define MAKE_REF(n) make_cell (tmp_num_ (REF), n, 0) -#define MAKE_STRING(x) make_cell (tmp_num_ (STRING), x, 0) +#define MAKE_CHAR(n) make_cell (tmp_num_ (TCHAR), 0, tmp_num2_ (n)) +#define MAKE_CONTINUATION(n) make_cell (tmp_num_ (TCONTINUATION), n, g_stack) +#define MAKE_NUMBER(n) make_cell (tmp_num_ (TNUMBER), 0, tmp_num2_ (n)) +#define MAKE_REF(n) make_cell (tmp_num_ (TREF), n, 0) +#define MAKE_STRING(x) make_cell (tmp_num_ (TSTRING), x, 0) SCM vm_call (function0_t f, SCM p1, SCM a); @@ -250,12 +248,12 @@ SCM make_cell (SCM type, SCM car, SCM cdr) { SCM x = alloc (1); - assert (TYPE (type) == NUMBER); + assert (TYPE (type) == TNUMBER); TYPE (x) = VALUE (type); - if (VALUE (type) == CHAR || VALUE (type) == NUMBER) { + if (VALUE (type) == TCHAR || VALUE (type) == TNUMBER) { if (car) CAR (x) = CAR (car); if (cdr) CDR (x) = CDR (cdr); - } else if (VALUE (type) == FUNCTION) { + } else if (VALUE (type) == TFUNCTION) { if (car) CAR (x) = car; if (cdr) CDR (x) = CDR (cdr); } else { @@ -268,33 +266,39 @@ make_cell (SCM type, SCM car, SCM cdr) SCM cons (SCM x, SCM y) { - g_cells[tmp_num].value = PAIR; + g_cells[tmp_num].value = TPAIR; return make_cell (tmp_num, x, y); } SCM car (SCM x) { - if (TYPE (x) != PAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_car)); + if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_car)); return CAR (x); } SCM cdr (SCM x) { - if (TYPE (x) != PAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr)); + if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr)); return CDR (x); } +SCM +null_p (SCM x) +{ + return x == cell_nil ? cell_t : cell_f; +} + SCM eq_p (SCM x, SCM y) { return (x == y - || ((TYPE (x) == KEYWORD && TYPE (y) == KEYWORD + || ((TYPE (x) == TKEYWORD && TYPE (y) == TKEYWORD && STRING (x) == STRING (y))) - || (TYPE (x) == CHAR && TYPE (y) == CHAR + || (TYPE (x) == TCHAR && TYPE (y) == TCHAR && VALUE (x) == VALUE (y)) - || (TYPE (x) == NUMBER && TYPE (y) == NUMBER + || (TYPE (x) == TNUMBER && TYPE (y) == TNUMBER && VALUE (x) == VALUE (y))) ? cell_t : cell_f; } @@ -308,46 +312,30 @@ type_ (SCM x) SCM car_ (SCM x) { - return (TYPE (x) != CONTINUATION - && (TYPE (CAR (x)) == PAIR // FIXME: this is weird - || TYPE (CAR (x)) == REF - || TYPE (CAR (x)) == SPECIAL - || TYPE (CAR (x)) == SYMBOL - || TYPE (CAR (x)) == STRING)) ? CAR (x) : MAKE_NUMBER (CAR (x)); + return (TYPE (x) != TCONTINUATION + && (TYPE (CAR (x)) == TPAIR // FIXME: this is weird + || TYPE (CAR (x)) == TREF + || TYPE (CAR (x)) == TSPECIAL + || TYPE (CAR (x)) == TSYMBOL + || TYPE (CAR (x)) == TSTRING)) ? CAR (x) : MAKE_NUMBER (CAR (x)); } SCM cdr_ (SCM x) { - return (TYPE (CDR (x)) == PAIR - || TYPE (CDR (x)) == REF - || TYPE (CAR (x)) == SPECIAL - || TYPE (CDR (x)) == SYMBOL - || TYPE (CDR (x)) == STRING) ? CDR (x) : MAKE_NUMBER (CDR (x)); + return (TYPE (CDR (x)) == TPAIR + || TYPE (CDR (x)) == TREF + || TYPE (CAR (x)) == TSPECIAL + || TYPE (CDR (x)) == TSYMBOL + || TYPE (CDR (x)) == TSTRING) ? CDR (x) : MAKE_NUMBER (CDR (x)); } SCM -set_car_x (SCM x, SCM e) +append2 (SCM x, SCM y) { - assert (TYPE (x) == PAIR); - CAR (x) = e; - return cell_unspecified; -} - -SCM -set_cdr_x (SCM x, SCM e) -{ - if (TYPE (x) != PAIR) error (cell_symbol_not_a_pair, cons (x, cell_set_cdr_x)); - CDR (x) = e; - return cell_unspecified; -} - -SCM -set_env_x (SCM x, SCM e, SCM a) -{ - SCM p = assert_defined (x, assq (x, a)); - if (TYPE (p) != PAIR) error (cell_symbol_not_a_pair, cons (p, x)); - return set_cdr_x (p, e); + if (x == cell_nil) return y; + assert (TYPE (x) == TPAIR); + return cons (car (x), append2 (cdr (x), y)); } SCM @@ -355,12 +343,33 @@ pairlis (SCM x, SCM y, SCM a) { if (x == cell_nil) return a; - if (TYPE (x) != PAIR) + if (TYPE (x) != TPAIR) return cons (cons (x, y), a); return cons (cons (car (x), car (y)), pairlis (cdr (x), cdr (y), a)); } +SCM +call (SCM fn, SCM x) +{ + if ((FUNCTION (fn).arity > 0 || FUNCTION (fn).arity == -1) + && x != cell_nil && TYPE (CAR (x)) == TVALUES) + x = cons (CADAR (x), CDR (x)); + if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1) + && x != cell_nil && TYPE (CDR (x)) == TPAIR && TYPE (CADR (x)) == TVALUES) + x = cons (CAR (x), cons (CDADAR (x), CDR (x))); + switch (FUNCTION (fn).arity) + { + 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), car (cddr (x))); + case -1: return FUNCTION (fn).functionn (x); + } + + return cell_unspecified; +} + SCM assq (SCM x, SCM a) { @@ -369,13 +378,37 @@ assq (SCM x, SCM a) } SCM -assq_ref_cache (SCM x, SCM a) +assq_ref_env (SCM x, SCM a) { x = assq (x, a); if (x == cell_f) return cell_undefined; return cdr (x); } +SCM +set_car_x (SCM x, SCM e) +{ + assert (TYPE (x) == TPAIR); + CAR (x) = e; + return cell_unspecified; +} + +SCM +set_cdr_x (SCM x, SCM e) +{ + if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_set_cdr_x)); + CDR (x) = e; + return cell_unspecified; +} + +SCM +set_env_x (SCM x, SCM e, SCM a) +{ + SCM p = assert_defined (x, assq (x, a)); + if (TYPE (p) != TPAIR) error (cell_symbol_not_a_pair, cons (p, x)); + return set_cdr_x (p, e); +} + SCM call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal)) { @@ -385,6 +418,21 @@ call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal)) return cell_unspecified; } +SCM +make_closure (SCM args, SCM body, SCM a) +{ + return make_cell (tmp_num_ (TCLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body))); +} + +SCM +lookup_macro (SCM x, SCM a) +{ + if (TYPE (x) != TSYMBOL) return cell_f; + SCM m = assq_ref_env (x, a); + if (TYPE (m) == TMACRO) return MACRO (m); + return cell_f; +} + SCM push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal)) { @@ -398,6 +446,11 @@ push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal)) return cell_unspecified; } +SCM caar (SCM x) {return car (car (x));} +SCM cadr (SCM x) {return car (cdr (x));} +SCM cdar (SCM x) {return cdr (car (x));} +SCM cddr (SCM x) {return cdr (cdr (x));} + SCM eval_apply () { @@ -440,7 +493,7 @@ eval_apply () SCM y = cell_nil; evlis: if (r1 == cell_nil) goto vm_return; - if (TYPE (r1) != PAIR) goto eval; + if (TYPE (r1) != TPAIR) goto eval; push_cc (car (r1), r1, r0, cell_vm_evlis2); goto eval; evlis2: @@ -453,12 +506,12 @@ eval_apply () apply: switch (TYPE (car (r1))) { - case FUNCTION: { + case TFUNCTION: { check_formals (car (r1), MAKE_NUMBER (FUNCTION (car (r1)).arity), cdr (r1)); r1 = call (car (r1), cdr (r1)); /// FIXME: move into eval_apply goto vm_return; } - case CLOSURE: + case TCLOSURE: { SCM cl = CLOSURE (car (r1)); SCM formals = cadr (cl); @@ -470,7 +523,7 @@ eval_apply () call_lambda (body, p, aa, r0); goto begin; } - case CONTINUATION: + case TCONTINUATION: { x = r1; g_stack = CONTINUATION (CAR (r1)); @@ -478,7 +531,7 @@ eval_apply () r1 = cadr (x); goto eval_apply; } - case SPECIAL: + case TSPECIAL: { switch (car (r1)) { @@ -500,7 +553,7 @@ eval_apply () default: check_apply (cell_f, car (r1)); } } - case SYMBOL: + case TSYMBOL: { if (car (r1) == cell_symbol_call_with_values) { @@ -514,7 +567,7 @@ eval_apply () } break; } - case PAIR: + case TPAIR: { switch (caar (r1)) { @@ -540,7 +593,7 @@ eval_apply () eval: switch (TYPE (r1)) { - case PAIR: + case TPAIR: { switch (car (r1)) { @@ -605,7 +658,7 @@ eval_apply () x = r2; if (r1 != r2) { - if (TYPE (r1) == PAIR) + if (TYPE (r1) == TPAIR) { set_cdr_x (r2, cdr (r1)); set_car_x (r2, car (r1)); @@ -619,9 +672,9 @@ eval_apply () } } } - case SYMBOL: + case TSYMBOL: { - r1 = assert_defined (r1, assq_ref_cache (r1, r0)); + r1 = assert_defined (r1, assq_ref_env (r1, r0)); goto vm_return; } default: goto vm_return; @@ -630,18 +683,18 @@ eval_apply () SCM macro; SCM expanders; macro_expand: - if (TYPE (r1) == PAIR + if (TYPE (r1) == TPAIR && (macro = lookup_macro (car (r1), r0)) != cell_f) { r1 = cons (macro, CDR (r1)); goto apply; } - else if (TYPE (r1) == PAIR - && TYPE (CAR (r1)) == SYMBOL - && ((expanders = assq_ref_cache (cell_symbol_sc_expander_alist, r0)) != cell_undefined) + else if (TYPE (r1) == TPAIR + && TYPE (CAR (r1)) == TSYMBOL + && ((expanders = assq_ref_env (cell_symbol_sc_expander_alist, r0)) != cell_undefined) && ((macro = assq (CAR (r1), expanders)) != cell_f)) { - SCM sc_expand = assq_ref_cache (cell_symbol_macro_expand, r0); + SCM sc_expand = assq_ref_env (cell_symbol_macro_expand, r0); if (sc_expand != cell_undefined && sc_expand != cell_f) { r1 = cons (sc_expand, cons (r1, cell_nil)); @@ -653,7 +706,7 @@ eval_apply () begin: x = cell_unspecified; while (r1 != cell_nil) { - if (TYPE (r1) == PAIR && TYPE (CAR (r1)) == PAIR) + if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR) { if (caar (r1) == cell_symbol_begin) r1 = append2 (cdar (r1), cdr (r1)); @@ -712,7 +765,7 @@ eval_apply () push_cc (cons (car (r1), cell_nil), r1, r0, cell_vm_call_with_values2); goto apply; call_with_values2: - if (TYPE (r1) == VALUES) + if (TYPE (r1) == TVALUES) r1 = CDR (r1); r1 = cons (cadr (r2), r1); goto apply; @@ -725,28 +778,7 @@ eval_apply () } SCM -call (SCM fn, SCM x) -{ - if ((FUNCTION (fn).arity > 0 || FUNCTION (fn).arity == -1) - && x != cell_nil && TYPE (CAR (x)) == VALUES) - x = cons (CADAR (x), CDR (x)); - 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 (FUNCTION (fn).arity) - { - 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), car (cddr (x))); - case -1: return FUNCTION (fn).functionn (x); - } - - return cell_unspecified; -} - -SCM -gc_peek_frame () +gc_peek_frame () ///((internal)) { SCM frame = car (g_stack); r1 = car (frame); @@ -757,7 +789,7 @@ gc_peek_frame () } SCM -gc_pop_frame () +gc_pop_frame () ///((internal)) { SCM frame = gc_peek_frame (g_stack); g_stack = cdr (g_stack); @@ -765,7 +797,7 @@ gc_pop_frame () } SCM -gc_push_frame () +gc_push_frame () ///((internal)) { SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil)))); return g_stack = cons (frame, g_stack); @@ -779,22 +811,6 @@ apply (SCM f, SCM x, SCM a) ///((internal)) return eval_apply (); } -SCM -append2 (SCM x, SCM y) -{ - if (x == cell_nil) return y; - assert (TYPE (x) == PAIR); - return cons (car (x), append2 (cdr (x), y)); -} - -SCM -append (SCM x) ///((arity . n)) - { - if (x == cell_nil) return cell_nil; - if (cdr (x) == cell_nil) return car (x); - return append2 (car (x), append (cdr (x))); - } - SCM cstring_to_list (char const* s) { @@ -806,17 +822,35 @@ cstring_to_list (char const* s) } SCM -null_p (SCM x) +make_symbol_ (SCM s) { - return x == cell_nil ? cell_t : cell_f; + g_cells[tmp_num].value = TSYMBOL; + SCM x = make_cell (tmp_num, s, 0); + g_symbols = cons (x, g_symbols); + return x; } SCM -make_symbol_ (SCM s) +list_of_char_equal_p (SCM a, SCM b) { - g_cells[tmp_num].value = SYMBOL; - SCM x = make_cell (tmp_num, s, 0); - g_symbols = cons (x, g_symbols); + while (a != cell_nil && b != cell_nil && VALUE (car (a)) == VALUE (car (b))) { + assert (TYPE (car (a)) == TCHAR); + assert (TYPE (car (b)) == TCHAR); + a = cdr (a); + b = cdr (b); + } + return (a == cell_nil && b == cell_nil) ? cell_t : cell_f; +} + +SCM +lookup_symbol_ (SCM s) +{ + SCM x = g_symbols; + while (x) { + if (list_of_char_equal_p (STRING (car (x)), s) == cell_t) break; + x = cdr (x); + } + if (x) x = car (x); return x; } @@ -827,11 +861,213 @@ make_symbol (SCM s) return x ? x : make_symbol_ (s); } +SCM +acons (SCM key, SCM value, SCM alist) +{ + return cons (cons (key, value), alist); +} + +// temp MINI_MES lib + +SCM +write_byte (SCM x) ///((arity . n)) +{ + SCM c = car (x); + SCM p = cdr (x); + int fd = 1; + if (TYPE (p) == TPAIR && TYPE (car (p)) == TNUMBER) fd = VALUE (car (p)); + FILE *f = fd == 1 ? stdout : stderr; + assert (TYPE (c) == TNUMBER || TYPE (c) == TCHAR); + fputc (VALUE (c), f); + return c; +} + +char const* +string_to_cstring (SCM s) +{ + static char buf[1024]; + char *p = buf; + s = STRING(s); + while (s != cell_nil) + { + *p++ = VALUE (car (s)); + s = cdr (s); + } + *p = 0; + return buf; +} + +#if __GNUC__ +char const* itoa(int); +#endif + +SCM +display_ (SCM x) +{ + // eputs ("\n"); + switch (TYPE (x)) + { + case TCHAR: + { + //puts ("\n"); + puts ("#\\"); + putchar (VALUE (x)); + break; + } + case TFUNCTION: + { +#if __GNUC__ + puts ("#"); + break; +#endif + //puts ("\n"); + if (VALUE (x) == 0) + puts ("make-cell"); + if (VALUE (x) == 1) + puts ("cons"); + if (VALUE (x) == 2) + puts ("car"); + if (VALUE (x) == 3) + puts ("cdr"); + break; + } + case TNUMBER: + { + //puts ("\n"); +#if __GNUC__ + puts (itoa (VALUE (x))); +#else + int i; + i = VALUE (x); + i = i + 48; + putchar (i); +#endif + break; + } + case TPAIR: + { + //puts ("\n"); + //if (cont != cell_f) puts "("); + puts ("("); + if (x && x != cell_nil) display_ (CAR (x)); + if (CDR (x) && CDR (x) != cell_nil) + { +#if __GNUC__ + if (TYPE (CDR (x)) != TPAIR) + puts (" . "); +#else + int c; + c = CDR (x); + c = TYPE (c); + if (c != TPAIR) + puts (" . "); +#endif + display_ (CDR (x)); + } + //if (cont != cell_f) puts (")"); + puts (")"); + break; + } + case TSPECIAL: + { + switch (x) + { + case 1: {puts ("()"); break;} + case 2: {puts ("#f"); break;} + case 3: {puts ("#t"); break;} + default: + { +#if __GNUC__ + puts (""); +#else + puts (""); +#endif + } + } + break; + } + case TSYMBOL: + { +#if 0 + switch (x) + { + case 11: {puts (" . "); break;} + case 12: {puts ("lambda"); break;} + case 13: {puts ("begin"); break;} + case 14: {puts ("if"); break;} + case 15: {puts ("quote"); break;} + case 37: {puts ("car"); break;} + case 38: {puts ("cdr"); break;} + case 39: {puts ("null?"); break;} + case 40: {puts ("eq?"); break;} + case 41: {puts ("cons"); break;} + default: + { +#if __GNUC__ + puts (""); +#else + puts (""); +#endif + } + } + break; +#else + SCM t = CAR (x); + while (t != cell_nil) + { + putchar (VALUE (CAR (t))); + t = CDR (t); + } +#endif + } + default: + { + //puts ("\n"); +#if __GNUC__ + puts ("<"); + puts (itoa (TYPE (x))); + puts (":"); + puts (itoa (x)); + puts (">"); +#else + puts ("_"); +#endif + break; + } + } + return 0; +} + +SCM +stderr_ (SCM x) +{ + SCM write; + if (TYPE (x) == TSTRING) + fprintf (stderr, string_to_cstring (x)); + else if ((write = assq_ref_env (cell_symbol_write, r0)) != cell_undefined) + apply (assq_ref_env (cell_symbol_display, r0), cons (x, cons (MAKE_NUMBER (2), cell_nil)), r0); + else if (TYPE (x) == TSPECIAL || TYPE (x) == TSTRING || TYPE (x) == TSYMBOL) + fprintf (stderr, string_to_cstring (x)); + else if (TYPE (x) == TNUMBER) + fprintf (stderr, "%d", VALUE (x)); + else + fprintf (stderr, "display: undefined\n"); + return cell_unspecified; +} + SCM make_vector (SCM n) { int k = VALUE (n); - g_cells[tmp_num].value = VECTOR; + g_cells[tmp_num].value = TVECTOR; SCM v = alloc (k); SCM x = make_cell (tmp_num, k, v); for (int i=0; i jam[%d]\n", g_free); @@ -1032,21 +1268,15 @@ gc_flip () } // Environment setup -SCM -acons (SCM key, SCM value, SCM alist) -{ - return cons (cons (key, value), alist); -} - SCM gc_init_cells () { - g_cells = (scm *)malloc (2*ARENA_SIZE*sizeof(scm)); - g_cells[0].type = VECTOR; + g_cells = (struct scm *)malloc (2*ARENA_SIZE*sizeof(struct scm)); + g_cells[0].type = TVECTOR; g_cells[0].length = 1000; g_cells[0].vector = 0; g_cells++; - g_cells[0].type = CHAR; + g_cells[0].type = TCHAR; g_cells[0].value = 'c'; } @@ -1054,11 +1284,11 @@ SCM gc_init_news () { g_news = g_cells-1 + ARENA_SIZE; - g_news[0].type = VECTOR; + g_news[0].type = TVECTOR; g_news[0].length = 1000; g_news[0].vector = 0; g_news++; - g_news[0].type = CHAR; + g_news[0].type = TCHAR; g_news[0].value = 'n'; } @@ -1097,7 +1327,7 @@ mes_symbols () ///((internal)) } SCM -mes_builtins (SCM a) +mes_builtins (SCM a) ///((internal)) { #include "mes.i" @@ -1133,21 +1363,6 @@ mes_environment () ///((internal)) return mes_g_stack (a); } -SCM -make_closure (SCM args, SCM body, SCM a) -{ - return make_cell (tmp_num_ (CLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body))); -} - -SCM -lookup_macro (SCM x, SCM a) -{ - if (TYPE (x) != SYMBOL) return cell_f; - SCM m = assq_ref_cache (x, a); - if (TYPE (m) == MACRO) return MACRO (m); - return cell_f; -} - FILE *g_stdin; #include "lib.c" #include "math.c" diff --git a/module/language/c99/compiler.mes b/module/language/c99/compiler.mes index c165fc38..5cba1d78 100644 --- a/module/language/c99/compiler.mes +++ b/module/language/c99/compiler.mes @@ -2041,6 +2041,7 @@ (define (initzer->data info functions globals ta t d o) (pmatch o ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value))) + ((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value)))) ((initzer (ref-to (p-expr (ident ,name)))) ;;(stderr "INITZER[~a] => 0x~a\n" o (dec->hex (+ ta (function-offset name functions)))) (int->bv32 (+ ta (function-offset name functions)))) diff --git a/module/mes/elf-util.mes b/module/mes/elf-util.mes index 002d4c84..53db0f8c 100644 --- a/module/mes/elf-util.mes +++ b/module/mes/elf-util.mes @@ -93,16 +93,22 @@ (if (and prefix (or (equal? name "exit") (> offset 0))) (set! cache (assoc-set! cache name offset))) offset))))) -(define (label-offset function label functions) - (let ((prefix (function-prefix function functions))) - (if (not prefix) 0 - (let ((function-entry (car prefix))) - (let loop ((text (cdr function-entry))) - (if (or (equal? (car text) label) (null? text)) 0 - (let* ((l/l (car text)) - (t ((lambda/label->list '() '() 0 0 0) l/l)) - (n (length t))) - (+ (loop (cdr text)) n)))))))) +(define label-offset + (let ((cache '())) + (lambda (function label functions) + (or (assoc-ref cache (cons function label)) + (let ((prefix (function-prefix function functions))) + (if (not prefix) 0 + (let* ((function-entry (car prefix)) + (offset (let loop ((text (cdr function-entry))) + (if (or (equal? (car text) label) (null? text)) 0 + (let* ((l/l (car text)) + (t ((lambda/label->list '() '() 0 0 0) l/l)) + (n (length t))) + (+ (loop (cdr text)) n)))))) + (when (> offset 0) + (set! cache (assoc-set! cache (cons function label) offset))) + offset))))))) (define (globals->data globals) (append-map (compose global:value cdr) globals)) diff --git a/module/mes/mes-0.mes b/module/mes/mes-0.mes index dad18dac..166fa9da 100644 --- a/module/mes/mes-0.mes +++ b/module/mes/mes-0.mes @@ -104,7 +104,7 @@ (define (eval-expand e a) (cond - ((symbol? e) (assq-ref-cache e a)) + ((symbol? e) (assq-ref-env e a)) ((atom? e) e) ((atom? (car e)) (cond diff --git a/posix.c b/posix.c index b71f1377..f708b9ef 100644 --- a/posix.c +++ b/posix.c @@ -20,6 +20,39 @@ #include +//MINI_MES +// SCM +// write_byte (SCM x) ///((arity . n)) +// { +// SCM c = car (x); +// SCM p = cdr (x); +// int fd = 1; +// if (TYPE (p) == TPAIR && TYPE (car (p)) == TNUMBER) fd = VALUE (car (p)); +// FILE *f = fd == 1 ? stdout : stderr; +// assert (TYPE (c) == TNUMBER || TYPE (c) == TCHAR); +// fputc (VALUE (c), f); +// return c; +// } + +char const* string_to_cstring (SCM); + +// SCM +// stderr_ (SCM x) +// { +// SCM write; +// if (TYPE (x) == TSTRING) +// fprintf (stderr, string_to_cstring (x)); +// else if ((write = assq_ref_env (cell_symbol_write, r0)) != cell_undefined) +// apply (assq_ref_env (cell_symbol_display, r0), cons (x, cons (MAKE_NUMBER (2), cell_nil)), r0); +// else if (TYPE (x) == TSPECIAL || TYPE (x) == TSTRING || TYPE (x) == TSYMBOL) +// fprintf (stderr, string_to_cstring (x)); +// else if (TYPE (x) == TNUMBER) +// fprintf (stderr, "%d", VALUE (x)); +// else +// fprintf (stderr, "display: undefined\n"); +// return cell_unspecified; +// } + int getchar () { @@ -66,41 +99,11 @@ unread_byte (SCM i) return i; } -SCM -write_byte (SCM x) ///((arity . n)) -{ - SCM c = car (x); - SCM p = cdr (x); - int fd = 1; - if (TYPE (p) == PAIR && TYPE (car (p)) == NUMBER) fd = VALUE (car (p)); - FILE *f = fd == 1 ? stdout : stderr; - assert (TYPE (c) == NUMBER || TYPE (c) == CHAR); - fputc (VALUE (c), f); - return c; -} - -SCM -stderr_ (SCM x) -{ - SCM write; - if (TYPE (x) == STRING) - fprintf (stderr, string_to_cstring (x)); - else if ((write = assq_ref_cache (cell_symbol_write, r0)) != cell_undefined) - apply (assq_ref_cache (cell_symbol_display, r0), cons (x, cons (MAKE_NUMBER (2), cell_nil)), r0); - else if (TYPE (x) == SPECIAL || TYPE (x) == STRING || TYPE (x) == SYMBOL) - fprintf (stderr, string_to_cstring (x)); - else if (TYPE (x) == NUMBER) - fprintf (stderr, "%d", VALUE (x)); - else - fprintf (stderr, "display: undefined\n"); - return cell_unspecified; -} - SCM force_output (SCM p) ///((arity . n)) { int fd = 1; - if (TYPE (p) == PAIR && TYPE (car (p)) == NUMBER) fd = VALUE (car (p)); + if (TYPE (p) == TPAIR && TYPE (car (p)) == TNUMBER) fd = VALUE (car (p)); FILE *f = fd == 1 ? stdout : stderr; fflush (f); return cell_unspecified; diff --git a/reader.c b/reader.c index 098e7087..ed55709f 100644 --- a/reader.c +++ b/reader.c @@ -30,7 +30,7 @@ SCM read_input_file_env (SCM a) { r0 = a; - if (assq_ref_cache (cell_symbol_read_input_file, r0) != cell_undefined) + if (assq_ref_env (cell_symbol_read_input_file, r0) != cell_undefined) return apply (cell_symbol_read_input_file, cell_nil, r0); return read_input_file_env_ (read_env (r0), r0); } @@ -108,27 +108,3 @@ lookup_ (SCM s, SCM a) SCM x = lookup_symbol_ (s); return x ? x : make_symbol_ (s); } - -SCM -list_of_char_equal_p (SCM a, SCM b) -{ - while (a != cell_nil && b != cell_nil && VALUE (car (a)) == VALUE (car (b))) { - assert (TYPE (car (a)) == CHAR); - assert (TYPE (car (b)) == CHAR); - a = cdr (a); - b = cdr (b); - } - return (a == cell_nil && b == cell_nil) ? cell_t : cell_f; -} - -SCM -lookup_symbol_ (SCM s) -{ - SCM x = g_symbols; - while (x) { - if (list_of_char_equal_p (STRING (car (x)), s) == cell_t) break; - x = cdr (x); - } - if (x) x = car (x); - return x; -} diff --git a/scaffold/mini-mes.c b/scaffold/mini-mes.c index 17d4030e..a1349ac9 100644 --- a/scaffold/mini-mes.c +++ b/scaffold/mini-mes.c @@ -19,7 +19,7 @@ */ #define MES_MINI 1 -#define FIXED_PRIMITIVES 1 +#define FIXED_PRIMITIVES 0 #if __GNUC__ #define FIXME_NYACC 1 @@ -32,8 +32,8 @@ #define NYACC_CDR nyacc_cdr #endif -int ARENA_SIZE = 200000; -char arena[200000]; +int ARENA_SIZE = 1200000; +char arena[1200000]; int g_stdin = 0; @@ -263,11 +263,7 @@ SCM r2 = 0; // continuation SCM r3 = 0; -#if __NYACC__ || FIXME_NYACC -enum type_t {CHAR, TCLOSURE, TCONTINUATION, TFUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, TSTRING, SYMBOL, VALUES, TVECTOR, BROKEN_HEART}; -#else -enum type_t {CHAR, CLOSURE, CONTINUATION, FUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, STRING, SYMBOL, VALUES, VECTOR, BROKEN_HEART}; -#endif +enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVECTOR, TBROKEN_HEART}; struct scm { enum type_t type; @@ -284,134 +280,99 @@ struct function { struct scm *g_cells = arena; -//scm *g_news = 0; +struct scm *g_news = 0; -// struct scm scm_nil = {SPECIAL, "()"}; -// struct scm scm_f = {SPECIAL, "#f"}; -// struct scm scm_t = {SPECIAL, "#t"}; -// struct scm_dot = {SPECIAL, "."}; -// struct scm_arrow = {SPECIAL, "=>"}; -// struct scm_undefined = {SPECIAL, "*undefined*"}; -// struct scm_unspecified = {SPECIAL, "*unspecified*"}; -// struct scm_closure = {SPECIAL, "*closure*"}; -// struct scm_circular = {SPECIAL, "*circular*"}; -// struct scm_begin = {SPECIAL, "*begin*"}; +struct scm scm_nil = {TSPECIAL, "()",0}; +struct scm scm_f = {TSPECIAL, "#f",0}; +struct scm scm_t = {TSPECIAL, "#t",0}; +struct scm scm_dot = {TSPECIAL, ".",0}; +struct scm scm_arrow = {TSPECIAL, "=>",0}; +struct scm scm_undefined = {TSPECIAL, "*undefined*",0}; +struct scm scm_unspecified = {TSPECIAL, "*unspecified*",0}; +struct scm scm_closure = {TSPECIAL, "*closure*",0}; +struct scm scm_circular = {TSPECIAL, "*circular*",0}; +struct scm scm_begin = {TSPECIAL, "*begin*",0}; -// struct scm_vm_apply = {SPECIAL, "core:apply"}; -// struct scm_vm_apply2 = {SPECIAL, "*vm-apply2*"}; +struct scm scm_symbol_dot = {TSYMBOL, "*dot*",0}; +struct scm scm_symbol_lambda = {TSYMBOL, "lambda",0}; +struct scm scm_symbol_begin = {TSYMBOL, "begin",0}; +struct scm scm_symbol_if = {TSYMBOL, "if",0}; +struct scm scm_symbol_quote = {TSYMBOL, "quote",0}; +struct scm scm_symbol_set_x = {TSYMBOL, "set!",0}; -// struct scm_vm_eval = {SPECIAL, "core:eval"}; +struct scm scm_symbol_sc_expand = {TSYMBOL, "sc-expand",0}; +struct scm scm_symbol_macro_expand = {TSYMBOL, "macro-expand",0}; +struct scm scm_symbol_sc_expander_alist = {TSYMBOL, "*sc-expander-alist*",0}; -// struct scm_vm_begin = {SPECIAL, "*vm-begin*"}; -// //scm scm_vm_begin_read_input_file = {SPECIAL, "*vm-begin-read-input-file*"}; -// struct scm_vm_begin2 = {SPECIAL, "*vm-begin2*"}; +struct scm scm_symbol_call_with_values = {TSYMBOL, "call-with-values",0}; +struct scm scm_call_with_current_continuation = {TSPECIAL, "*call/cc*",0}; +struct scm scm_symbol_call_with_current_continuation = {TSYMBOL, "call-with-current-continuation",0}; +struct scm scm_symbol_current_module = {TSYMBOL, "current-module",0}; +struct scm scm_symbol_primitive_load = {TSYMBOL, "primitive-load",0}; +struct scm scm_symbol_read_input_file = {TSYMBOL, "read-input-file",0}; +struct scm scm_symbol_write = {TSYMBOL, "write",0}; +struct scm scm_symbol_display = {TSYMBOL, "display",0}; -// struct scm_vm_return = {SPECIAL, "*vm-return*"}; +struct scm scm_symbol_throw = {TSYMBOL, "throw",0}; +struct scm scm_symbol_not_a_pair = {TSYMBOL, "not-a-pair",0}; +struct scm scm_symbol_system_error = {TSYMBOL, "system-error",0}; +struct scm scm_symbol_wrong_number_of_args = {TSYMBOL, "wrong-number-of-args",0}; +struct scm scm_symbol_wrong_type_arg = {TSYMBOL, "wrong-type-arg",0}; +struct scm scm_symbol_unbound_variable = {TSYMBOL, "unbound-variable",0}; -// //#include "mes.symbols.h" +struct scm scm_symbol_argv = {TSYMBOL, "%argv",0}; +struct scm scm_symbol_mes_prefix = {TSYMBOL, "%prefix",0}; +struct scm scm_symbol_mes_version = {TSYMBOL, "%version",0}; -#define cell_nil 1 -#define cell_f 2 -#define cell_t 3 -#define cell_dot 4 -// #define cell_arrow 5 -#define cell_undefined 6 -#define cell_unspecified 7 -#define cell_closure 8 -#define cell_circular 9 -#define cell_begin 10 -#define cell_symbol_dot 11 -#define cell_symbol_lambda 12 -#define cell_symbol_begin 13 -#define cell_symbol_if 14 -#define cell_symbol_quote 15 -#define cell_symbol_set_x 16 -#define cell_symbol_sc_expand 17 -#define cell_symbol_macro_expand 18 -#define cell_symbol_sc_expander_alist 19 -#define cell_symbol_call_with_values 20 -#define cell_call_with_current_continuation 21 -#define cell_symbol_call_with_current_continuation 22 -#define cell_symbol_current_module 23 -#define cell_symbol_primitive_load 24 -#define cell_symbol_read_input_file 25 +struct scm scm_symbol_car = {TSYMBOL, "car",0}; +struct scm scm_symbol_cdr = {TSYMBOL, "cdr",0}; +struct scm scm_symbol_null_p = {TSYMBOL, "null?",0}; +struct scm scm_symbol_eq_p = {TSYMBOL, "eq?",0}; +struct scm scm_symbol_cons = {TSYMBOL, "cons",0}; -#define cell_symbol_car 37 -#define cell_symbol_cdr 38 -#define cell_symbol_null_p 39 -#define cell_symbol_eq_p 40 -#define cell_symbol_cons 41 +struct scm scm_vm_evlis = {TSPECIAL, "*vm-evlis*",0}; +struct scm scm_vm_evlis2 = {TSPECIAL, "*vm-evlis2*",0}; +struct scm scm_vm_evlis3 = {TSPECIAL, "*vm-evlis3*",0}; +struct scm scm_vm_apply = {TSPECIAL, "core:apply",0}; +struct scm scm_vm_apply2 = {TSPECIAL, "*vm-apply2*",0}; +struct scm scm_vm_eval = {TSPECIAL, "core:eval",0}; -#define cell_vm_evlis 42 -#define cell_vm_evlis2 43 -#define cell_vm_evlis3 44 -#define cell_vm_apply 45 -#define cell_vm_apply2 46 -#define cell_vm_eval 47 -#define cell_vm_eval_car 48 -#define cell_vm_eval_cdr 49 -#define cell_vm_eval_cons 50 -#define cell_vm_eval_null_p 51 -#define cell_vm_eval_set_x 52 -#define cell_vm_eval_macro 53 -#define cell_vm_eval2 54 -#define cell_vm_macro_expand 55 -#define cell_vm_begin 56 -#define cell_vm_begin_read_input_file 57 -#define cell_vm_begin2 58 -#define cell_vm_if 59 -#define cell_vm_if_expr 60 -#define cell_vm_call_with_values2 61 -#define cell_vm_call_with_current_continuation2 62 -#define cell_vm_return 63 -#define cell_test 64 +//FIXED_PRIMITIVES +struct scm scm_vm_eval_car = {TSPECIAL, "*vm-eval-car*",0}; +struct scm scm_vm_eval_cdr = {TSPECIAL, "*vm-eval-cdr*",0}; +struct scm scm_vm_eval_cons = {TSPECIAL, "*vm-eval-cons*",0}; +struct scm scm_vm_eval_null_p = {TSPECIAL, "*vm-eval-null-p*",0}; +struct scm scm_vm_eval_set_x = {TSPECIAL, "*vm-eval-set!*",0}; +struct scm scm_vm_eval_macro = {TSPECIAL, "*vm-eval-macro*",0}; +struct scm scm_vm_eval2 = {TSPECIAL, "*vm-eval2*",0}; +struct scm scm_vm_macro_expand = {TSPECIAL, "core:macro-expand",0}; +struct scm scm_vm_begin = {TSPECIAL, "*vm-begin*",0}; +struct scm scm_vm_begin_read_input_file = {TSPECIAL, "*vm-begin-read-input-file*",0}; +struct scm scm_vm_begin2 = {TSPECIAL, "*vm-begin2*",0}; +struct scm scm_vm_if = {TSPECIAL, "*vm-if*",0}; +struct scm scm_vm_if_expr = {TSPECIAL, "*vm-if-expr*",0}; +struct scm scm_vm_call_with_values2 = {TSPECIAL, "*vm-call-with-values2*",0}; +struct scm scm_vm_call_with_current_continuation2 = {TSPECIAL, "*vm-call-with-current-continuation2*",0}; +struct scm scm_vm_return = {TSPECIAL, "*vm-return*",0}; +struct scm scm_test = {TSYMBOL, "test",0}; + +#include "mini-mes.symbols.h" SCM tmp; SCM tmp_num; SCM tmp_num2; -struct function g_functions[5]; +struct function g_functions[200]; int g_function = 0; +// #include "lib.h" +// #include "math.h" +#include "mini-mes.h" +// #include "posix.h" +// #include "reader.h" -#if __GNUC__ -//FIXME -SCM make_cell (SCM type, SCM car, SCM cdr); -#endif -struct function fun_make_cell = {&make_cell,3,"make-cell"}; -struct scm scm_make_cell = {TFUNCTION,0,0}; -SCM cell_make_cell; - -#if __GNUC__ -//FIXME -SCM cons (SCM x, SCM y); -#endif -struct function fun_cons = {&cons,2,"cons"}; -struct scm scm_cons = {TFUNCTION,0,0}; -SCM cell_cons; - -#if __GNUC__ -//FIXME -SCM car (SCM x); -#endif -struct function fun_car = {&car,1,"car"}; -struct scm scm_car = {TFUNCTION,0,0}; -SCM cell_car; - -#if __GNUC__ -//FIXME -SCM cdr (SCM x); -#endif -struct function fun_cdr = {&cdr,1,"cdr"}; -struct scm scm_cdr = {TFUNCTION,0,0}; -SCM cell_cdr; - -// SCM eq_p (SCM x, SCM y); -// struct function fun_eq_p = {&eq_p, 2}; -// scm scm_eq_p = {TFUNCTION,0,0};// "eq?", 0}; -// SCM cell_eq_p; #define TYPE(x) (g_cells[x].type) @@ -427,29 +388,25 @@ SCM cell_cdr; #endif #define FUNCTION(x) g_functions[g_cells[x].cdr] +#define MACRO(x) g_cells[x].car #define VALUE(x) g_cells[x].cdr #define VECTOR(x) g_cells[x].cdr -#define MAKE_CHAR(n) make_cell (tmp_num_ (CHAR), 0, tmp_num2_ (n)) +#define MAKE_CHAR(n) make_cell (tmp_num_ (TCHAR), 0, tmp_num2_ (n)) #define MAKE_CONTINUATION(n) make_cell (tmp_num_ (TCONTINUATION), n, g_stack) -#define MAKE_NUMBER(n) make_cell (tmp_num_ (NUMBER), 0, tmp_num2_ (n)) +#define MAKE_NUMBER(n) make_cell (tmp_num_ (TNUMBER), 0, tmp_num2_ (n)) //#define MAKE_REF(n) make_cell (tmp_num_ (REF), n, 0) #define CAAR(x) CAR (CAR (x)) -// #define CDAR(x) CDR (CAR (x)) +#define CDAR(x) CDR (CAR (x)) #define CADAR(x) CAR (CDR (CAR (x))) #define CADDR(x) CAR (CDR (CDR (x))) // #define CDDDR(x) CDR (CDR (CDR (x))) #define CDADAR(x) CAR (CDR (CAR (CDR (x)))) #define CADR(x) CAR (CDR (x)) - -#if __NYACC__ || FIXME_NYACC #define MAKE_STRING(x) make_cell (tmp_num_ (TSTRING), x, 0) -// #else -// #define MAKE_STRING(x) make_cell (tmp_num_ (STRING), x, 0) -#endif SCM alloc (int n) @@ -466,9 +423,9 @@ SCM make_cell (SCM type, SCM car, SCM cdr) { SCM x = alloc (1); - assert (TYPE (type) == NUMBER); + assert (TYPE (type) == TNUMBER); TYPE (x) = VALUE (type); - if (VALUE (type) == CHAR || VALUE (type) == NUMBER) { + if (VALUE (type) == TCHAR || VALUE (type) == TNUMBER) { if (car) CAR (x) = CAR (car); if (cdr) CDR(x) = CDR(cdr); } @@ -500,7 +457,7 @@ tmp_num2_ (int x) SCM cons (SCM x, SCM y) { - VALUE (tmp_num) = PAIR; + VALUE (tmp_num) = TPAIR; return make_cell (tmp_num, x, y); } @@ -511,7 +468,7 @@ car (SCM x) //Nyacc //assert ("!car"); #else - if (TYPE (x) != PAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_car)); + if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_car)); #endif return CAR (x); } @@ -523,7 +480,7 @@ cdr (SCM x) //Nyacc //assert ("!cdr"); #else - if (TYPE (x) != PAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr)); + if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr)); #endif return CDR(x); } @@ -534,21 +491,48 @@ null_p (SCM x) return x == cell_nil ? cell_t : cell_f; } -// 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 +eq_p (SCM x, SCM y) +{ + return (x == y + || ((TYPE (x) == TKEYWORD && TYPE (y) == TKEYWORD + && STRING (x) == STRING (y))) + || (TYPE (x) == TCHAR && TYPE (y) == TCHAR + && VALUE (x) == VALUE (y)) + || (TYPE (x) == TNUMBER && TYPE (y) == TNUMBER + && VALUE (x) == VALUE (y))) + ? cell_t : cell_f; +} SCM -assert_defined (SCM x, SCM e) +type_ (SCM x) +{ + return MAKE_NUMBER (TYPE (x)); +} + +SCM +car_ (SCM x) +{ + return (TYPE (x) != TCONTINUATION + && (TYPE (CAR (x)) == TPAIR // FIXME: this is weird + || TYPE (CAR (x)) == TREF + || TYPE (CAR (x)) == TSPECIAL + || TYPE (CAR (x)) == TSYMBOL + || TYPE (CAR (x)) == TSTRING)) ? CAR (x) : MAKE_NUMBER (CAR (x)); +} + +SCM +cdr_ (SCM x) +{ + return (TYPE (CDR (x)) == TPAIR + || TYPE (CDR (x)) == TREF + || TYPE (CAR (x)) == TSPECIAL + || TYPE (CDR (x)) == TSYMBOL + || TYPE (CDR (x)) == TSTRING) ? CDR (x) : MAKE_NUMBER (CDR (x)); +} + +SCM +assert_defined (SCM x, SCM e) ///((internal)) { if (e != cell_undefined) return e; // error (cell_symbol_unbound_variable, x); @@ -558,7 +542,7 @@ assert_defined (SCM x, SCM e) } SCM -gc_push_frame () +gc_push_frame () ///((internal)) { SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil)))); g_stack = cons (frame, g_stack); @@ -571,7 +555,7 @@ append2 (SCM x, SCM y) if (x == cell_nil) return y; #if __GNUC__ //FIXME GNUC - assert (TYPE (x) == PAIR); + assert (TYPE (x) == TPAIR); #endif return cons (car (x), append2 (cdr (x), y)); } @@ -581,17 +565,66 @@ pairlis (SCM x, SCM y, SCM a) { if (x == cell_nil) return a; - if (TYPE (x) != PAIR) + if (TYPE (x) != TPAIR) return cons (cons (x, y), a); return cons (cons (car (x), car (y)), pairlis (cdr (x), cdr (y), a)); } + +#if __GNUC__ +SCM display_ (SCM); +#endif + +SCM +call (SCM fn, SCM x) +{ + if ((FUNCTION (fn).arity > 0 || FUNCTION (fn).arity == -1) + && x != cell_nil && TYPE (CAR (x)) == TVALUES) + x = cons (CADAR (x), CDR (x)); + if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1) + && x != cell_nil && TYPE (CDR (x)) == TPAIR && TYPE (CADR (x)) == TVALUES) + x = cons (CAR (x), cons (CDADAR (x), CDR (x))); + + eputs ("call: "); + if (FUNCTION (fn).name) eputs (FUNCTION (fn).name); + else eputs (itoa (CDR (fn))); + eputs ("\n"); + switch (FUNCTION (fn).arity) + { + // 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), car (cddr (x))); + // case -1: return FUNCTION (fn).functionn (x); + case 0: {return (FUNCTION (fn).function) ();} + case 1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (car (x));} + case 2: {return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x));} + case 3: {return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x), car (cddr (x)));} +#if __GNUC__ + // FIXME GNUC + case -1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);} +#endif + default: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);} + } + + return cell_unspecified; +} + SCM assq (SCM x, SCM a) { //while (a != cell_nil && eq_p (x, CAAR (a)) == cell_f) a = CDR (a); - while (a != cell_nil && x == CAAR (a)) a = CDR (a); + while (a != cell_nil && x != CAAR (a)) a = CDR (a); +#if __GNUC__ + puts ("assq: "); + display_ (x); + puts (" => "); + display_ (a != cell_nil ? car (a) : cell_f); + puts ("["); + puts (itoa (CDR (CDR (CAR (a))))); + puts ("]\n"); +#endif return a != cell_nil ? car (a) : cell_f; } @@ -606,7 +639,7 @@ assq_ref_env (SCM x, SCM a) SCM set_car_x (SCM x, SCM e) { - assert (TYPE (x) == PAIR); + assert (TYPE (x) == TPAIR); CAR (x) = e; return cell_unspecified; } @@ -614,7 +647,7 @@ set_car_x (SCM x, SCM e) SCM set_cdr_x (SCM x, SCM e) { - //if (TYPE (x) != PAIR) error (cell_symbol_not_a_pair, cons (x, cell_set_cdr_x)); + //if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_set_cdr_x)); CDR (x) = e; return cell_unspecified; } @@ -623,7 +656,7 @@ SCM set_env_x (SCM x, SCM e, SCM a) { SCM p = assert_defined (x, assq (x, a)); - //if (TYPE (p) != PAIR) error (cell_symbol_not_a_pair, cons (p, x)); + //if (TYPE (p) != TPAIR) error (cell_symbol_not_a_pair, cons (p, x)); return set_cdr_x (p, e); } @@ -636,6 +669,21 @@ call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal)) return cell_unspecified; } +SCM +make_closure (SCM args, SCM body, SCM a) +{ + return make_cell (tmp_num_ (TCLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body))); +} + +SCM +lookup_macro (SCM x, SCM a) +{ + if (TYPE (x) != TSYMBOL) return cell_f; + SCM m = assq_ref_env (x, a); + if (TYPE (m) == TMACRO) return MACRO (m); + return cell_f; +} + SCM push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal)) { @@ -656,9 +704,7 @@ SCM cddr (SCM x) {return cdr (cdr (x));} #if __GNUC__ //FIXME -SCM make_closure (SCM,SCM,SCM); -SCM call (SCM,SCM); -SCM gc_pop_frame (); +SCM gc_pop_frame (); //((internal)) #endif SCM @@ -702,7 +748,7 @@ eval_apply () SCM y = cell_nil; evlis: if (r1 == cell_nil) goto vm_return; - if (TYPE (r1) != PAIR) goto eval; + if (TYPE (r1) != TPAIR) goto eval; push_cc (car (r1), r1, r0, cell_vm_evlis2); goto eval; evlis2: @@ -740,7 +786,7 @@ eval_apply () r1 = cadr (x); goto eval_apply; } - case SPECIAL: + case TSPECIAL: { switch (car (r1)) { @@ -762,7 +808,7 @@ eval_apply () //default: check_apply (cell_f, car (r1)); } } - case SYMBOL: + case TSYMBOL: { if (car (r1) == cell_symbol_call_with_values) { @@ -776,7 +822,7 @@ eval_apply () } break; } - case PAIR: + case TPAIR: { switch (caar (r1)) { @@ -802,7 +848,7 @@ eval_apply () eval: switch (TYPE (r1)) { - case PAIR: + case TPAIR: { switch (car (r1)) { @@ -867,7 +913,7 @@ eval_apply () x = r2; if (r1 != r2) { - if (TYPE (r1) == PAIR) + if (TYPE (r1) == TPAIR) { set_cdr_x (r2, cdr (r1)); set_car_x (r2, car (r1)); @@ -881,7 +927,7 @@ eval_apply () } } } - case SYMBOL: + case TSYMBOL: { r1 = assert_defined (r1, assq_ref_env (r1, r0)); goto vm_return; @@ -892,15 +938,16 @@ eval_apply () SCM macro; SCM expanders; macro_expand: -#if 0 - if (TYPE (r1) == PAIR +#if __GNUC__ + //FIXME + if (TYPE (r1) == TPAIR && (macro = lookup_macro (car (r1), r0)) != cell_f) // FIXME GNUC { r1 = cons (macro, CDR (r1)); goto apply; } - else if (TYPE (r1) == PAIR - && TYPE (CAR (r1)) == SYMBOL + else if (TYPE (r1) == TPAIR + && TYPE (CAR (r1)) == TSYMBOL && ((expanders = assq_ref_env (cell_symbol_sc_expander_alist, r0)) != cell_undefined) && ((macro = assq (CAR (r1), expanders)) != cell_f)) { @@ -916,7 +963,7 @@ eval_apply () begin: x = cell_unspecified; while (r1 != cell_nil) { - if (TYPE (r1) == PAIR && TYPE (CAR (r1)) == PAIR) + if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR) { if (caar (r1) == cell_symbol_begin) r1 = append2 (cdar (r1), cdr (r1)); @@ -981,7 +1028,7 @@ eval_apply () push_cc (cons (car (r1), cell_nil), r1, r0, cell_vm_call_with_values2); goto apply; call_with_values2: - if (TYPE (r1) == VALUES) + if (TYPE (r1) == TVALUES) r1 = CDR (r1); r1 = cons (cadr (r2), r1); goto apply; @@ -993,70 +1040,19 @@ eval_apply () goto eval_apply; } -#if __GNUC__ -SCM display_ (SCM); -#endif - SCM -call (SCM fn, SCM x) -{ - if ((FUNCTION (fn).arity > 0 || FUNCTION (fn).arity == -1) - && x != cell_nil && TYPE (CAR (x)) == VALUES) - x = cons (CADAR (x), CDR (x)); - 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 (FUNCTION (fn).arity) - { - // 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), car (cddr (x))); - // case -1: return FUNCTION (fn).functionn (x); - case 0: {return (FUNCTION (fn).function) ();} - case 1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (car (x));} - case 2: {return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x));} - case 3: {return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x), car (cddr (x)));} -#if __GNUC__ - // FIXME GNUC - case -1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);} -#endif - default: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);} - } - - return cell_unspecified; -} - -SCM -gc_peek_frame () +gc_peek_frame () ///((internal)) { SCM frame = car (g_stack); r1 = car (frame); -#if 1 - //GNUC r2 = cadr (frame); r3 = car (cddr (frame)); r0 = cadr (cddr (frame)); -#else - r2 = cdr (frame); - r2 = car (r2); - - r3 = cdr (frame); - r3 = cdr (r3); - r3 = car (r3); - - r0 = cdr (frame); - r0 = cdr (r0); - r0 = cdr (r0); - r0 = cdr (r0); - r0 = car (r0); -#endif return frame; } SCM -gc_pop_frame () +gc_pop_frame () ///((internal)) { SCM frame = gc_peek_frame (g_stack); g_stack = cdr (g_stack); @@ -1079,27 +1075,55 @@ SCM make_tmps (struct scm* cells) { tmp = g_free++; - cells[tmp].type = CHAR; + cells[tmp].type = TCHAR; tmp_num = g_free++; - cells[tmp_num].type = NUMBER; + cells[tmp_num].type = TNUMBER; tmp_num2 = g_free++; - cells[tmp_num2].type = NUMBER; + cells[tmp_num2].type = TNUMBER; return 0; } SCM make_symbol_ (SCM s) { - VALUE (tmp_num) = SYMBOL; + VALUE (tmp_num) = TSYMBOL; SCM x = make_cell (tmp_num, s, 0); + puts ("MAKE SYMBOL: "); + display_ (x); + puts ("\n"); g_symbols = cons (x, g_symbols); return x; } +SCM +list_of_char_equal_p (SCM a, SCM b) +{ + while (a != cell_nil && b != cell_nil && VALUE (car (a)) == VALUE (car (b))) { + assert (TYPE (car (a)) == TCHAR); + assert (TYPE (car (b)) == TCHAR); + a = cdr (a); + b = cdr (b); + } + return (a == cell_nil && b == cell_nil) ? cell_t : cell_f; +} + +SCM +lookup_symbol_ (SCM s) +{ + SCM x = g_symbols; + while (x) { + if (list_of_char_equal_p (STRING (car (x)), s) == cell_t) break; + x = cdr (x); + } + if (x) x = car (x); + return x; +} + SCM make_symbol (SCM s) { -#if MES_MINI +#if 0 + // MINI_MES SCM x = 0; #else SCM x = lookup_symbol_ (s); @@ -1132,247 +1156,32 @@ acons (SCM key, SCM value, SCM alist) return cons (cons (key, value), alist); } -// Jam Collector -SCM g_symbol_max; + +// MINI_MES: temp-lib SCM -gc_init_cells () +write_byte (SCM x) ///((arity . n)) { - return 0; -// g_cells = (scm *)malloc (2*ARENA_SIZE*sizeof(scm)); - -// #if __NYACC__ || FIXME_NYACC -// TYPE (0) = TVECTOR; -// // #else -// // TYPE (0) = VECTOR; -// #endif -// LENGTH (0) = 1000; -// VECTOR (0) = 0; -// g_cells++; -// TYPE (0) = CHAR; -// VALUE (0) = 'c'; -} - -// INIT NEWS - -SCM -mes_symbols () ///((internal)) -{ - gc_init_cells (); - // gc_init_news (); - -#if __GNUC__ && 0 - //#include "mes.symbols.i" -#else -g_free++; -// g_cells[cell_nil] = scm_nil; - -g_free++; -// g_cells[cell_f] = scm_f; - -g_free++; -// g_cells[cell_t] = scm_t; - -g_free++; -// g_cells[cell_dot] = scm_dot; - -g_free++; -// g_cells[cell_arrow] = scm_arrow; - -g_free++; -// g_cells[cell_undefined] = scm_undefined; - -g_free++; -// g_cells[cell_unspecified] = scm_unspecified; - -g_free++; -// g_cells[cell_closure] = scm_closure; - -g_free++; -// g_cells[cell_circular] = scm_circular; - -g_free++; -// g_cells[cell_begin] = scm_begin; - -/// -g_free = 44; -g_free++; -// g_cells[cell_vm_apply] = scm_vm_apply; - -g_free++; -// g_cells[cell_vm_apply2] = scm_vm_apply2; - -g_free++; -// g_cells[cell_vm_eval] = scm_vm_eval; - -/// -g_free = 55; -g_free++; -// g_cells[cell_vm_begin] = scm_vm_begin; - -g_free++; -// g_cells[cell_vm_begin_read_input_file] = scm_vm_begin_read_input_file; - -g_free++; -// g_cells[cell_vm_begin2] = scm_vm_begin2; - -/// -g_free = 62; -g_free++; -// g_cells[cell_vm_return] = scm_vm_return; - -g_free = 63; -g_free++; -//g_cells[cell_test] = scm_test; - -#endif - - g_symbol_max = g_free; - make_tmps (g_cells); - - g_symbols = 0; - for (int i=1; i\n"); + // eputs ("\n"); switch (TYPE (x)) { - case CHAR: + case TCHAR: { //puts ("\n"); puts ("#\\"); @@ -1381,6 +1190,14 @@ display_ (SCM x) } case TFUNCTION: { +#if __GNUC__ + puts ("#"); + break; +#endif //puts ("\n"); if (VALUE (x) == 0) puts ("make-cell"); @@ -1392,7 +1209,7 @@ display_ (SCM x) puts ("cdr"); break; } - case NUMBER: + case TNUMBER: { //puts ("\n"); #if __GNUC__ @@ -1405,7 +1222,7 @@ display_ (SCM x) #endif break; } - case PAIR: + case TPAIR: { //puts ("\n"); //if (cont != cell_f) puts "("); @@ -1414,13 +1231,13 @@ display_ (SCM x) if (CDR (x) && CDR (x) != cell_nil) { #if __GNUC__ - if (TYPE (CDR (x)) != PAIR) + if (TYPE (CDR (x)) != TPAIR) puts (" . "); #else int c; c = CDR (x); c = TYPE (c); - if (c != PAIR) + if (c != TPAIR) puts (" . "); #endif display_ (CDR (x)); @@ -1429,7 +1246,7 @@ display_ (SCM x) puts (")"); break; } - case SPECIAL: + case TSPECIAL: { switch (x) { @@ -1449,8 +1266,9 @@ display_ (SCM x) } break; } - case SYMBOL: + case TSYMBOL: { +#if 0 switch (x) { case 11: {puts (" . "); break;} @@ -1475,6 +1293,14 @@ display_ (SCM x) } } break; +#else + SCM t = CAR (x); + while (t != cell_nil) + { + putchar (VALUE (CAR (t))); + t = CDR (t); + } +#endif } default: { @@ -1494,101 +1320,142 @@ display_ (SCM x) return 0; } + +// Jam Collector +SCM g_symbol_max; + SCM -simple_bload_env (SCM a) ///((internal)) +gc_init_cells () ///((internal)) +{ + return 0; +// g_cells = (scm *)malloc (2*ARENA_SIZE*sizeof(scm)); + +// #if __NYACC__ || FIXME_NYACC +// TYPE (0) = TVECTOR; +// // #else +// // TYPE (0) = VECTOR; +// #endif +// LENGTH (0) = 1000; +// VECTOR (0) = 0; +// g_cells++; +// TYPE (0) = CHAR; +// VALUE (0) = 'c'; +} + +// INIT NEWS + +SCM +mes_symbols () ///((internal)) +{ + gc_init_cells (); + // gc_init_news (); + + #include "mini-mes.symbols.i" + + g_symbol_max = g_free; + make_tmps (g_cells); + + g_symbols = 0; + for (int i=1; i 1 && !strcmp (argv[1], "--load")) ? bload_env (r0) : load_env (r0); @@ -1659,6 +1526,9 @@ main (int argc, char *argv[]) #endif push_cc (r2, cell_unspecified, r0, cell_unspecified); + eputs ("program: "); + display_ (r1); + eputs ("\n"); r3 = cell_vm_begin; r1 = eval_apply (); display_ (r1);