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
chmod +x a.out
./a.out
-mini-mes: scaffold/mini-mes.c GNUmakefile
+%.h %.i %.environment.i %.symbols.i: scaffold/%.c build-aux/mes-snarf.scm
+ build-aux/mes-snarf.scm $<
+
+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 -o $@ '-DVERSION="0.4"' $<
+ gcc -nostdlib --std=gnu99 -m32 -g -I. -o $@ '-DVERSION="0.4"' $<
chmod +x $@
-# mini-mes: doc/examples/mini-mes.c GNUmakefile
-# rm -f $@
-# gcc -nostdlib --std=gnu99 -g -o $@ '-DVERSION="0.4"' $<
-# chmod +x $@
-
cons-mes: scaffold/cons-mes.c GNUmakefile
rm -f $@
gcc -nostdlib --std=gnu99 -m32 -g -o $@ '-DVERSION="0.4"' $<
(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)
(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)
((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))))
(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
(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)
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/
-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
{
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);
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");
}
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)
{
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)
{
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;
g_free = 15;
}
- for (int i=0; i<g_free * sizeof(scm); i++)
+ for (int i=0; i<g_free * sizeof(struct scm); i++)
fputc (*p++, stdout);
return 0;
}
*p++ = c;
c = getchar ();
}
- g_free = (p-(char*)g_cells) / sizeof (scm);
+ g_free = (p-(char*)g_cells) / sizeof (struct scm);
gc_peek_frame ();
g_symbols = r1;
g_stdin = stdin;
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);
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);
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)
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);
}
int n = 0;
while (x != cell_nil)
{
- assert (TYPE (car (x)) == NUMBER);
+ assert (TYPE (car (x)) == TNUMBER);
n += VALUE (car (x));
x = cdr (x);
}
{
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);
}
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));
int n = 1;
while (x != cell_nil)
{
- assert (TYPE (car (x)) == NUMBER);
+ assert (TYPE (car (x)) == TNUMBER);
n *= VALUE (car (x));
x = cdr (x);
}
int n = 0;
while (x != cell_nil)
{
- assert (TYPE (car (x)) == NUMBER);
+ assert (TYPE (car (x)) == TNUMBER);
n |= VALUE (car (x));
x = cdr (x);
}
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);
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;
} NYACC;
int arity;
char const *name;
-} function_t;
-struct scm;
-typedef struct scm_struct {
+};
+struct scm {
enum type_t type;
union {
char const* name;
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*"};
-
-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!"};
-
-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*"};
-
-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"};
-
-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"};
-
-scm scm_symbol_argv = {SYMBOL, "%argv"};
-scm scm_symbol_mes_prefix = {SYMBOL, "%prefix"};
-scm scm_symbol_mes_version = {SYMBOL, "%version"};
-
-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"};
-
-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"};
-
-#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
-
-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*"};
-
-scm scm_test = {SYMBOL, "test"};
+};
+
+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 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 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 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 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};
+
+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};
+
+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};
+
+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};
+
+//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};
int g_free = 0;
-scm *g_cells;
-scm *g_news = 0;
+struct scm *g_cells;
+struct scm *g_news = 0;
#include "mes.symbols.h"
SCM tmp_num;
SCM tmp_num2;
-function_t g_functions[200];
+struct function g_functions[200];
int g_function = 0;
SCM g_continuations = 0;
#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);
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 {
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;
}
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));
-}
-
-SCM
-set_car_x (SCM x, SCM e)
-{
- assert (TYPE (x) == PAIR);
- CAR (x) = e;
- return cell_unspecified;
+ 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_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)
+append2 (SCM x, SCM y)
{
- 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
{
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)
{
}
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))
{
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))
{
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 ()
{
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:
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);
call_lambda (body, p, aa, r0);
goto begin;
}
- case CONTINUATION:
+ case TCONTINUATION:
{
x = r1;
g_stack = CONTINUATION (CAR (r1));
r1 = cadr (x);
goto eval_apply;
}
- case SPECIAL:
+ case TSPECIAL:
{
switch (car (r1))
{
default: check_apply (cell_f, car (r1));
}
}
- case SYMBOL:
+ case TSYMBOL:
{
if (car (r1) == cell_symbol_call_with_values)
{
}
break;
}
- case PAIR:
+ case TPAIR:
{
switch (caar (r1))
{
eval:
switch (TYPE (r1))
{
- case PAIR:
+ case TPAIR:
{
switch (car (r1))
{
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));
}
}
}
- 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;
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));
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));
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;
}
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);
}
SCM
-gc_pop_frame ()
+gc_pop_frame () ///((internal))
{
SCM frame = gc_peek_frame (g_stack);
g_stack = cdr (g_stack);
}
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);
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)
{
}
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;
}
return x ? x : make_symbol_ (s);
}
+SCM
+acons (SCM key, SCM value, SCM alist)
+{
+ return cons (cons (key, value), alist);
+}
+
+//\f 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 ("<display>\n");
+ switch (TYPE (x))
+ {
+ case TCHAR:
+ {
+ //puts ("<char>\n");
+ puts ("#\\");
+ putchar (VALUE (x));
+ break;
+ }
+ case TFUNCTION:
+ {
+#if __GNUC__
+ puts ("#<procedure ");
+ puts (FUNCTION (x).name ? FUNCTION (x).name : "?");
+ puts ("[");
+ puts (itoa (CDR (x)));
+ puts ("]>");
+ break;
+#endif
+ //puts ("<function>\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 ("<number>\n");
+#if __GNUC__
+ puts (itoa (VALUE (x)));
+#else
+ int i;
+ i = VALUE (x);
+ i = i + 48;
+ putchar (i);
+#endif
+ break;
+ }
+ case TPAIR:
+ {
+ //puts ("<pair>\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 ("<x:");
+ puts (itoa (x));
+ puts (">");
+#else
+ puts ("<x>");
+#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 ("<s:");
+ puts (itoa (x));
+ puts (">");
+#else
+ puts ("<s>");
+#endif
+ }
+ }
+ break;
+#else
+ SCM t = CAR (x);
+ while (t != cell_nil)
+ {
+ putchar (VALUE (CAR (t)));
+ t = CDR (t);
+ }
+#endif
+ }
+ default:
+ {
+ //puts ("<default>\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<k; i++) g_cells[v+i] = g_cells[vector_entry (cell_unspecified)];
SCM
arity_ (SCM x)
{
- assert (TYPE (x) == FUNCTION);
+ assert (TYPE (x) == TFUNCTION);
return MAKE_NUMBER (FUNCTION (x).arity);
}
values (SCM x) ///((arity . n))
{
SCM v = cons (0, x);
- TYPE (v) = VALUES;
+ TYPE (v) = TVALUES;
return v;
}
SCM
vector_length (SCM x)
{
- assert (TYPE (x) == VECTOR);
+ assert (TYPE (x) == TVECTOR);
return MAKE_NUMBER (LENGTH (x));
}
SCM
vector_ref (SCM x, SCM i)
{
- assert (TYPE (x) == VECTOR);
+ assert (TYPE (x) == TVECTOR);
assert (VALUE (i) < LENGTH (x));
SCM e = VECTOR (x) + VALUE (i);
- if (TYPE (e) == REF) e = g_cells[e].ref;
- if (TYPE (e) == CHAR) e = MAKE_CHAR (VALUE (e));
- if (TYPE (e) == NUMBER) e = MAKE_NUMBER (VALUE (e));
+ if (TYPE (e) == TREF) e = g_cells[e].ref;
+ if (TYPE (e) == TCHAR) e = MAKE_CHAR (VALUE (e));
+ if (TYPE (e) == TNUMBER) e = MAKE_NUMBER (VALUE (e));
return e;
}
SCM
vector_entry (SCM x) {
- if (TYPE (x) == PAIR || TYPE (x) == SPECIAL || TYPE (x) == STRING || TYPE (x) == SYMBOL || TYPE (x) == VECTOR) x = MAKE_REF (x);
+ if (TYPE (x) == TPAIR || TYPE (x) == TSPECIAL || TYPE (x) == TSTRING || TYPE (x) == TSYMBOL || TYPE (x) == TVECTOR) x = MAKE_REF (x);
return x;
}
SCM
vector_set_x (SCM x, SCM i, SCM e)
{
- assert (TYPE (x) == VECTOR);
+ assert (TYPE (x) == TVECTOR);
assert (VALUE (i) < LENGTH (x));
g_cells[VECTOR (x)+g_cells[i].value] = g_cells[vector_entry (e)];
return cell_unspecified;
SCM x = cell_nil;
for (int i = 0; i < LENGTH (v); i++) {
SCM e = VECTOR (v)+i;
- if (TYPE (e) == REF) e = g_cells[e].ref;
+ if (TYPE (e) == TREF) e = g_cells[e].ref;
x = append2 (x, cons (e, cell_nil));
}
return x;
}
void
-make_tmps (scm* cells)
+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;
}
//\f Jam Collector
gc_up_arena ()
{
ARENA_SIZE *= 2;
- void *p = realloc (g_cells-1, 2*ARENA_SIZE*sizeof(scm));
+ void *p = realloc (g_cells-1, 2*ARENA_SIZE*sizeof(struct scm));
if (!p) error (cell_symbol_system_error, cons (MAKE_STRING (cstring_to_list (strerror (errno))), MAKE_NUMBER (g_free)));
- g_cells = (scm*)p;
+ g_cells = (struct scm*)p;
g_cells++;
gc_init_news ();
}
{
while (scan < g_free)
{
- if (NTYPE (scan) == CLOSURE
- || NTYPE (scan) == CONTINUATION
- || NTYPE (scan) == FUNCTION
- || NTYPE (scan) == KEYWORD
- || NTYPE (scan) == MACRO
- || NTYPE (scan) == PAIR
- || NTYPE (scan) == REF
+ if (NTYPE (scan) == TCLOSURE
+ || NTYPE (scan) == TCONTINUATION
+ || NTYPE (scan) == TFUNCTION
+ || NTYPE (scan) == TKEYWORD
+ || NTYPE (scan) == TMACRO
+ || NTYPE (scan) == TPAIR
+ || NTYPE (scan) == TREF
|| scan == 1 // null
- || NTYPE (scan) == SPECIAL
- || NTYPE (scan) == STRING
- || NTYPE (scan) == SYMBOL)
+ || NTYPE (scan) == TSPECIAL
+ || NTYPE (scan) == TSTRING
+ || NTYPE (scan) == TSYMBOL)
{
SCM car = gc_copy (g_news[scan].car);
gc_relocate_car (scan, car);
}
- if ((NTYPE (scan) == CLOSURE
- || NTYPE (scan) == CONTINUATION
- || NTYPE (scan) == MACRO
- || NTYPE (scan) == PAIR
- || NTYPE (scan) == VALUES)
+ if ((NTYPE (scan) == TCLOSURE
+ || NTYPE (scan) == TCONTINUATION
+ || NTYPE (scan) == TMACRO
+ || NTYPE (scan) == TPAIR
+ || NTYPE (scan) == TVALUES)
&& g_news[scan].cdr) // allow for 0 terminated list of symbols
{
SCM cdr = gc_copy (g_news[scan].cdr);
SCM
gc_copy (SCM old)
{
- if (TYPE (old) == BROKEN_HEART) return g_cells[old].car;
+ if (TYPE (old) == TBROKEN_HEART) return g_cells[old].car;
SCM new = g_free++;
g_news[new] = g_cells[old];
- if (NTYPE (new) == VECTOR)
+ if (NTYPE (new) == TVECTOR)
{
g_news[new].vector = g_free;
for (int i=0; i<LENGTH (old); i++)
g_news[g_free++] = g_cells[VECTOR (old)+i];
}
- g_cells[old].type = BROKEN_HEART;
+ g_cells[old].type = TBROKEN_HEART;
g_cells[old].car = new;
return new;
}
SCM
gc_flip ()
{
- scm *cells = g_cells;
+ struct scm *cells = g_cells;
g_cells = g_news;
g_news = cells;
if (g_debug) fprintf (stderr, " => jam[%d]\n", g_free);
}
//\f 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';
}
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';
}
}
SCM
-mes_builtins (SCM a)
+mes_builtins (SCM a) ///((internal))
{
#include "mes.i"
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"
(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))))
(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))
(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
#include <fcntl.h>
+//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 ()
{
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;
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);
}
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;
-}
*/
#define MES_MINI 1
-#define FIXED_PRIMITIVES 1
+#define FIXED_PRIMITIVES 0
#if __GNUC__
#define FIXME_NYACC 1
#define NYACC_CDR nyacc_cdr
#endif
-int ARENA_SIZE = 200000;
-char arena[200000];
+int ARENA_SIZE = 1200000;
+char arena[1200000];
int g_stdin = 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;
struct scm *g_cells = arena;
-//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_vm_apply = {SPECIAL, "core:apply"};
-// struct scm_vm_apply2 = {SPECIAL, "*vm-apply2*"};
-
-// struct scm_vm_eval = {SPECIAL, "core:eval"};
-
-// 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_vm_return = {SPECIAL, "*vm-return*"};
-
-// //#include "mes.symbols.h"
-
-#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
-
-#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
-
-#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
-
-
+struct scm *g_news = 0;
+
+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 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 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 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 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};
+
+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};
+
+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};
+
+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};
+
+//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)
#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)
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);
}
SCM
cons (SCM x, SCM y)
{
- VALUE (tmp_num) = PAIR;
+ VALUE (tmp_num) = TPAIR;
return make_cell (tmp_num, x, y);
}
//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);
}
//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);
}
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
+type_ (SCM x)
+{
+ return MAKE_NUMBER (TYPE (x));
+}
SCM
-assert_defined (SCM x, SCM e)
+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);
}
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);
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));
}
{
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;
}
SCM
set_car_x (SCM x, SCM e)
{
- assert (TYPE (x) == PAIR);
+ assert (TYPE (x) == TPAIR);
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));
+ //if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_set_cdr_x));
CDR (x) = e;
return cell_unspecified;
}
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);
}
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))
{
#if __GNUC__
//FIXME
-SCM make_closure (SCM,SCM,SCM);
-SCM call (SCM,SCM);
-SCM gc_pop_frame ();
+SCM gc_pop_frame (); //((internal))
#endif
SCM
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:
r1 = cadr (x);
goto eval_apply;
}
- case SPECIAL:
+ case TSPECIAL:
{
switch (car (r1))
{
//default: check_apply (cell_f, car (r1));
}
}
- case SYMBOL:
+ case TSYMBOL:
{
if (car (r1) == cell_symbol_call_with_values)
{
}
break;
}
- case PAIR:
+ case TPAIR:
{
switch (caar (r1))
{
eval:
switch (TYPE (r1))
{
- case PAIR:
+ case TPAIR:
{
switch (car (r1))
{
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));
}
}
}
- case SYMBOL:
+ case TSYMBOL:
{
r1 = assert_defined (r1, assq_ref_env (r1, r0));
goto vm_return;
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))
{
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));
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;
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);
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);
return cons (cons (key, value), alist);
}
-//\f Jam Collector
-SCM g_symbol_max;
-
-SCM
-gc_init_cells ()
-{
- 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
+//\f MINI_MES: temp-lib
SCM
-mes_symbols () ///((internal))
+write_byte (SCM x) ///((arity . n))
{
- 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<g_symbol_max; i++)
- g_symbols = cons (i, g_symbols);
-
- SCM a = cell_nil;
-
-#if __GNUC__ && 0
- //#include "mes.symbol-names.i"
-#else
-// g_cells[cell_nil].car = cstring_to_list (scm_nil.name);
-// g_cells[cell_f].car = cstring_to_list (scm_f.name);
-// g_cells[cell_t].car = cstring_to_list (scm_t.name);
-// g_cells[cell_dot].car = cstring_to_list (scm_dot.name);
-// g_cells[cell_arrow].car = cstring_to_list (scm_arrow.name);
-// g_cells[cell_undefined].car = cstring_to_list (scm_undefined.name);
-// g_cells[cell_unspecified].car = cstring_to_list (scm_unspecified.name);
-// g_cells[cell_closure].car = cstring_to_list (scm_closure.name);
-// g_cells[cell_circular].car = cstring_to_list (scm_circular.name);
-// g_cells[cell_begin].car = cstring_to_list (scm_begin.name);
-#endif
-
- // a = acons (cell_symbol_mes_version, MAKE_STRING (cstring_to_list (VERSION)), a);
- // a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a);
-
- a = acons (cell_symbol_dot, cell_dot, a);
- a = acons (cell_symbol_begin, cell_begin, a);
- a = acons (cell_closure, a, a);
-
- // a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a);
- // a = acons (cell_symbol_sc_expand, cell_f, a);
-
- return a;
-}
-
-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
-mes_environment () ///((internal))
-{
- SCM a = 0;
- a = mes_symbols ();
- a = mes_g_stack (a);
- return a;
-}
-
-SCM
-mes_builtins (SCM a)
-{
-#if 0
- //__GNUC__
-//#include "mes.i"
-
-// #include "lib.i"
-// #include "math.i"
-// #include "posix.i"
-// #include "reader.i"
-
-// #include "lib.environment.i"
-// #include "math.environment.i"
-// #include "mes.environment.i"
-// #include "posix.environment.i"
-// #include "reader.environment.i"
-#else
-
-scm_make_cell.cdr = g_function;
-g_functions[g_function++] = fun_make_cell;
-cell_make_cell = g_free++;
-g_cells[cell_make_cell] = scm_make_cell;
-
-scm_cons.cdr = g_function;
-g_functions[g_function++] = fun_cons;
-cell_cons = g_free++;
-g_cells[cell_cons] = scm_cons;
-
-scm_car.cdr = g_function;
-g_functions[g_function++] = fun_car;
-cell_car = g_free++;
-g_cells[cell_car] = scm_car;
-
-scm_cdr.cdr = g_function;
-g_functions[g_function++] = fun_cdr;
-cell_cdr = g_free++;
-g_cells[cell_cdr] = scm_cdr;
-
-scm_make_cell.car = cstring_to_list (fun_make_cell.name);
-g_cells[cell_make_cell].car = MAKE_STRING (scm_make_cell.car);
-a = acons (make_symbol (scm_make_cell.car), cell_make_cell, a);
-
-scm_cons.car = cstring_to_list (fun_cons.name);
-g_cells[cell_cons].car = MAKE_STRING (scm_cons.car);
-a = acons (make_symbol (scm_cons.car), cell_cons, a);
-
-scm_car.car = cstring_to_list (fun_car.name);
-g_cells[cell_car].car = MAKE_STRING (scm_car.car);
-a = acons (make_symbol (scm_cons.car), cell_cons, a);
-
-scm_cdr.car = cstring_to_list (fun_cdr.name);
-g_cells[cell_cdr].car = MAKE_STRING (scm_cdr.car);
-a = acons (make_symbol (scm_cdr.car), cell_cdr, a);
-
-#endif
- return a;
-}
-
-SCM
-bload_env (SCM a) ///((internal))
-{
- g_stdin = open ("module/mes/read-0.mo", 0);
-#if __GNUC__
- //FIXME GNUC
- //g_stdin = g_stdin ? g_stdin : fopen (PREFIX "module/mes/read-0.mo", "r");
-#endif
- char *p = (char*)g_cells;
- assert (getchar () == 'M');
- assert (getchar () == 'E');
- assert (getchar () == 'S');
- g_stack = getchar () << 8;
- g_stack += getchar ();
- int c = getchar ();
- while (c != EOF)
- {
- *p++ = c;
- c = getchar ();
- }
- g_free = (p-(char*)g_cells) / sizeof (struct scm);
- gc_peek_frame ();
- g_symbols = r1;
- g_stdin = STDIN;
- r0 = mes_builtins (r0);
- return r2;
+ puts ("write-byte 00\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);
+ char cc = VALUE (c);
+ write (1, (char*)&cc, fd);
+ return c;
}
SCM
display_ (SCM x)
{
- //puts ("<display>\n");
+ // eputs ("<display>\n");
switch (TYPE (x))
{
- case CHAR:
+ case TCHAR:
{
//puts ("<char>\n");
puts ("#\\");
}
case TFUNCTION:
{
+#if __GNUC__
+ puts ("#<procedure ");
+ puts (FUNCTION (x).name ? FUNCTION (x).name : "?");
+ puts ("[");
+ puts (itoa (CDR (x)));
+ puts ("]>");
+ break;
+#endif
//puts ("<function>\n");
if (VALUE (x) == 0)
puts ("make-cell");
puts ("cdr");
break;
}
- case NUMBER:
+ case TNUMBER:
{
//puts ("<number>\n");
#if __GNUC__
#endif
break;
}
- case PAIR:
+ case TPAIR:
{
//puts ("<pair>\n");
//if (cont != cell_f) puts "(");
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));
puts (")");
break;
}
- case SPECIAL:
+ case TSPECIAL:
{
switch (x)
{
}
break;
}
- case SYMBOL:
+ case TSYMBOL:
{
+#if 0
switch (x)
{
case 11: {puts (" . "); break;}
}
}
break;
+#else
+ SCM t = CAR (x);
+ while (t != cell_nil)
+ {
+ putchar (VALUE (CAR (t)));
+ t = CDR (t);
+ }
+#endif
}
default:
{
return 0;
}
+
+//\f Jam Collector
+SCM g_symbol_max;
+
SCM
-simple_bload_env (SCM a) ///((internal))
+gc_init_cells () ///((internal))
{
- puts ("reading: ");
- char *mo = "mini-0-32.mo";
+ return 0;
+// g_cells = (scm *)malloc (2*ARENA_SIZE*sizeof(scm));
- puts (mo);
- puts ("\n");
- g_stdin = open (mo, 0);
- if (g_stdin < 0) {eputs ("no such file: module/mes/read-0-32.mo\n");return 1;}
+// #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';
+}
- char *p = (char*)g_cells;
- int c;
+// INIT NEWS
-#if 0
- //__GNUC__
- puts ("fd: ");
- puts (itoa (g_stdin));
+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<g_symbol_max; i++)
+ g_symbols = cons (i, g_symbols);
+
+ SCM a = cell_nil;
+
+ #include "mini-mes.symbol-names.i"
+
+ // a = acons (cell_symbol_mes_version, MAKE_STRING (cstring_to_list (VERSION)), a);
+ // a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a);
+
+ a = acons (cell_symbol_dot, cell_dot, a);
+ a = acons (cell_symbol_begin, cell_begin, a);
+ a = acons (cell_closure, a, a);
+
+ // a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a);
+ // a = acons (cell_symbol_sc_expand, cell_f, a);
+
+ return a;
+}
+
+SCM
+mes_environment () ///((internal))
+{
+ SCM a = 0;
+ a = mes_symbols ();
+ a = mes_g_stack (a);
+ return a;
+}
+
+SCM
+mes_builtins (SCM a) ///((internal))
+{
+ #include "mini-mes.i"
+
+// #include "lib.i"
+// #include "math.i"
+// #include "posix.i"
+// #include "reader.i"
+
+// #include "lib.environment.i"
+// #include "math.environment.i"
+ #include "mini-mes.environment.i"
+// #include "posix.environment.i"
+// #include "reader.environment.i"
+
+ puts ("cell_write_byte: ");
+ puts (itoa (CDR (cell_write_byte)));
puts ("\n");
-#endif
+ return a;
+}
+SCM
+bload_env (SCM a) ///((internal))
+{
+ char *mo = "mini-0-32.mo";
+ //char *mo = "module/mes/read-0-32.mo";
+ g_stdin = open (mo, 0);
+ if (g_stdin < 0) {eputs ("no such file: ");eputs (mo);eputs ("\n");return 1;}
assert (getchar () == 'M');
assert (getchar () == 'E');
assert (getchar () == 'S');
- puts (" *GOT MES*\n");
+ eputs ("*GOT MES*\n");
g_stack = getchar () << 8;
g_stack += getchar ();
-#if __GNUC__
- puts ("stack: ");
- puts (itoa (g_stack));
- puts ("\n");
-#endif
- c = getchar ();
+ char *p = (char*)g_cells;
+ int c = getchar ();
while (c != -1)
{
*p++ = c;
c = getchar ();
}
-
- puts ("read done\n");
-
g_free = (p-(char*)g_cells) / sizeof (struct scm);
gc_peek_frame ();
g_symbols = r1;
-
-#if __GNUC__
- puts ("XXcells read: ");
- puts (itoa (g_free));
- puts ("\n");
-
- eputs ("r0=");
- eputs (itoa (r0));
- eputs ("\n");
-
- eputs ("r1=");
- eputs (itoa (r1));
- eputs ("\n");
-
- eputs ("r2=");
- eputs (itoa (r2));
- eputs ("\n");
-
- eputs ("g_stack=");
- eputs (itoa (g_stack));
- eputs ("\n");
-#endif
-
g_stdin = STDIN;
r0 = mes_builtins (r0);
-
#if __GNUC__
- puts ("cells read: ");
- puts (itoa (g_free));
- puts ("\n");
-
puts ("symbols: ");
- puts (itoa (g_symbols));
+ SCM s = g_symbols;
+ while (s && s != cell_nil) {
+ display_ (CAR (s));
+ puts (" ");
+ s = CDR (s);
+ }
puts ("\n");
-
- puts ("r2: ");
- puts (itoa (r2));
+ puts ("functions: ");
+ puts (itoa (g_function));
puts ("\n");
-#endif
-
- puts ("program[");
-#if __GNUC__
- puts (itoa (r2));
-#endif
- puts ("]: ");
-
- display_ (r2);
- //stderr_ (r2);
+ for (int i = 0; i < g_function; i++)
+ {
+ puts ("[");
+ puts (itoa (i));
+ puts ("]: ");
+ puts (g_functions[i].name);
+ puts ("\n");
+ }
+ display_ (r0);
puts ("\n");
-
+#endif
return r2;
}
// 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);
#if __NYACC__ || FIXME_NYACC
- else if (TYPE (x) == SPECIAL || TYPE (x) == TSTRING || TYPE (x) == SYMBOL)
+ else if (TYPE (x) == TSPECIAL || TYPE (x) == TSTRING || TYPE (x) == TSYMBOL)
// #else
// else if (TYPE (x) == SPECIAL || TYPE (x) == STRING || TYPE (x) == SYMBOL)
#endif
eputs (string_to_cstring (x));
- else if (TYPE (x) == NUMBER)
+ else if (TYPE (x) == TNUMBER)
eputs (itoa (VALUE (x)));
else
- eputs ("display: undefined\n");
+ eputs ("core:stderr: display undefined\n");
return cell_unspecified;
}
int
main (int argc, char *argv[])
{
- puts ("Hello mini-mes!\n");
+ eputs ("Hello mini-mes!\n");
#if __GNUC__
//g_debug = getenv ("MES_DEBUG");
#endif
r0 = mes_environment ();
#if MES_MINI
- SCM program = simple_bload_env (r0);
+ SCM program = bload_env (r0);
#else
SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
? bload_env (r0) : load_env (r0);
#endif
push_cc (r2, cell_unspecified, r0, cell_unspecified);
+ eputs ("program: ");
+ display_ (r1);
+ eputs ("\n");
r3 = cell_vm_begin;
r1 = eval_apply ();
display_ (r1);
projects / mes.git / commitdiff