--- cvsroot/microscheme/scheme.c 2015/12/02 17:01:51 1.65 +++ cvsroot/microscheme/scheme.c 2015/12/07 18:10:57 1.66 @@ -221,15 +221,16 @@ T_VECTOR, T_PROMISE, T_ENVIRONMENT, + T_SPECIAL, // #t, #f, '(), eof-object T_NUM_SYSTEM_TYPES }; -#define T_MASKTYPE 0x000f -#define T_SYNTAX 0x0010 -#define T_IMMUTABLE 0x0020 -#define T_ATOM 0x0040 /* only for gc */ -#define T_MARK 0x0080 /* only for gc */ +#define T_MASKTYPE 0x001f +#define T_SYNTAX 0x0020 +#define T_IMMUTABLE 0x0040 +#define T_ATOM 0x0080 /* only for gc */ +//#define T_MARK 0x0080 /* only for gc */ /* num, for generic arithmetic */ struct num @@ -512,9 +513,15 @@ #define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM) #define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM) +#if 1 +#define is_mark(p) (CELL(p)->mark) +#define setmark(p) (CELL(p)->mark = 1) +#define clrmark(p) (CELL(p)->mark = 0) +#else #define is_mark(p) (typeflag (p) & T_MARK) #define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK) #define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK) +#endif INTERFACE int is_immutable (pointer p) @@ -930,6 +937,7 @@ for (p = newp; p <= last; p++) { pointer cp = POINTER (p); + clrmark (cp); set_typeflag (cp, T_PAIR); set_car (cp, NIL); set_cdr (cp, POINTER (p + 1)); @@ -3340,15 +3348,10 @@ stream_free (o); } -// calculates a (preferably small) integer that makes it possible to find -// the symbol again. if pointers were offsets into a memory area... until -// then, we return segment number in the low bits, and offset in the high -// bits. -// also, this function must never return 0. ecb_cold static uint32_t -symbol_id (SCHEME_P_ pointer sym) +cell_id (SCHEME_P_ pointer x) { - struct cell *p = CELL (sym); + struct cell *p = CELL (x); int i; for (i = SCHEME_V->last_cell_seg; i >= 0; --i) @@ -3358,26 +3361,30 @@ abort (); } +// calculates a (preferably small) integer that makes it possible to find +// the symbol again. if pointers were offsets into a memory area... until +// then, we return segment number in the low bits, and offset in the high +// bits. +// also, this function must never return 0. ecb_cold static uint32_t -cell_id (SCHEME_P_ pointer p) +symbol_id (SCHEME_P_ pointer sym) { - return symbol_id (SCHEME_A_ p); + return cell_id (SCHEME_A_ sym); } enum byteop { BOP_NIL, - BOP_SYNTAX, BOP_INTEGER, BOP_SYMBOL, + BOP_DATUM, BOP_LIST_BEG, BOP_LIST_END, - BOP_BIFT, // branch if true - BOP_BIFF, // branch if false - BOP_BIFNE, // branch if not eqv? - BOP_BRA, // "short" branch - BOP_JMP, // "long" jump - BOP_DATUM, + BOP_IF, + BOP_AND, + BOP_OR, + BOP_CASE, + BOP_COND, BOP_LET, BOP_LETAST, BOP_LETREC, @@ -3386,6 +3393,7 @@ BOP_SET, BOP_BEGIN, BOP_LAMBDA, + BOP_OP, }; ecb_cold static void compile_expr (SCHEME_P_ stream s, pointer x); @@ -3393,27 +3401,29 @@ ecb_cold static void compile_list (SCHEME_P_ stream s, pointer x) { + // TODO: improper list + for (; x != NIL; x = cdr (x)) - compile_expr (SCHEME_A_ s, car (x)); + { + stream t = stream_init (); + compile_expr (SCHEME_A_ t, car (x)); + stream_put_v (s, stream_size (t)); + stream_put_stream (s, t); + } + + stream_put_v (s, 0); } static void compile_if (SCHEME_P_ stream s, pointer cond, pointer ift, pointer iff) { - //TODO: borked stream sift = stream_init (); compile_expr (SCHEME_A_ sift, ift); - stream_put (s, BOP_BIFF); + stream_put (s, BOP_IF); compile_expr (SCHEME_A_ s, cond); stream_put_v (s, stream_size (sift)); stream_put_stream (s, sift); - - if (iff != NIL) - { - stream siff = stream_init (); compile_expr (SCHEME_A_ siff, iff); - stream_put_tv (s, BOP_BRA, stream_size (siff)); - stream_put_stream (s, siff); - } + compile_expr (SCHEME_A_ s, iff); } typedef uint32_t stream_fixup; @@ -3439,17 +3449,61 @@ static void compile_and_or (SCHEME_P_ stream s, int and, pointer x) { - if (cdr (x) == NIL) - compile_expr (SCHEME_A_ s, car (x)); - else + for (; cdr (x) != NIL; x = cdr (x)) + { + stream t = stream_init (); + compile_expr (SCHEME_A_ t, car (x)); + stream_put_v (s, stream_size (t)); + stream_put_stream (s, t); + } + + stream_put_v (s, 0); +} + +static void +compile_case (SCHEME_P_ stream s, pointer x) +{ + compile_expr (SCHEME_A_ s, caar (x)); + + for (;;) { - stream_put (s, and ? BOP_BIFF : BOP_BIFT); - compile_expr (SCHEME_A_ s, car (x)); - stream_fixup end = stream_put_fixup (s); + x = cdr (x); - compile_and_or (SCHEME_A_ s, and, cdr (x)); - stream_fix_fixup (s, end, stream_size (s)); + if (x == NIL) + break; + + compile_expr (SCHEME_A_ s, caar (x)); + stream t = stream_init (); compile_expr (SCHEME_A_ t, cdar (x)); + stream_put_v (s, stream_size (t)); + stream_put_stream (s, t); } + + stream_put_v (s, 0); +} + +static void +compile_cond (SCHEME_P_ stream s, pointer x) +{ + for ( ; x != NIL; x = cdr (x)) + { + compile_expr (SCHEME_A_ s, caar (x)); + stream t = stream_init (); compile_expr (SCHEME_A_ t, cdar (x)); + stream_put_v (s, stream_size (t)); + stream_put_stream (s, t); + } + + stream_put_v (s, 0); +} + +static pointer +lookup (SCHEME_P_ pointer x) +{ + x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, x, 1); + + if (x != NIL) + x = slot_value_in_env (x); + + return x; } ecb_cold static void @@ -3472,23 +3526,28 @@ switch (syntaxnum (head)) { case OP_IF0: /* if */ + stream_put_v (s, BOP_IF); compile_if (SCHEME_A_ s, car (x), cadr (x), caddr (x)); break; case OP_OR0: /* or */ + stream_put_v (s, BOP_OR); compile_and_or (SCHEME_A_ s, 0, x); break; case OP_AND0: /* and */ + stream_put_v (s, BOP_AND); compile_and_or (SCHEME_A_ s, 1, x); break; case OP_CASE0: /* case */ - abort (); + stream_put_v (s, BOP_CASE); + compile_case (SCHEME_A_ s, x); break; case OP_COND0: /* cond */ - abort (); + stream_put_v (s, BOP_COND); + compile_cond (SCHEME_A_ s, x); break; case OP_LET0: /* let */ @@ -3576,23 +3635,26 @@ return; } - pointer m = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, head, 1); + pointer m = lookup (SCHEME_A_ head); - if (m != NIL) + if (is_macro (m)) { - m = slot_value_in_env (m); - - if (is_macro (m)) - { - s_save (SCHEME_A_ OP_DEBUG2, SCHEME_V->args, SCHEME_V->code); - SCHEME_V->code = m; - SCHEME_V->args = cons (x, NIL); - Eval_Cycle (SCHEME_A_ OP_APPLY); - x = SCHEME_V->value; - compile_expr (SCHEME_A_ s, SCHEME_V->value); - return; - } + s_save (SCHEME_A_ OP_DEBUG2, SCHEME_V->args, SCHEME_V->code); + SCHEME_V->code = m; + SCHEME_V->args = cons (x, NIL); + Eval_Cycle (SCHEME_A_ OP_APPLY); + x = SCHEME_V->value; + compile_expr (SCHEME_A_ s, SCHEME_V->value); + return; } + + stream_put (s, BOP_LIST_BEG); + + for (; x != NIL; x = cdr (x)) + compile_expr (SCHEME_A_ s, car (x)); + + stream_put (s, BOP_LIST_END); + return; } switch (type (x)) @@ -3600,22 +3662,27 @@ case T_INTEGER: { IVALUE iv = ivalue_unchecked (x); - iv = iv < 0 ? ((uint32_t)-iv << 1) | 1 : (uint32_t)iv << 1; + iv = iv < 0 ? ((~(uint32_t)iv) << 1) | 1 : (uint32_t)iv << 1; stream_put_tv (s, BOP_INTEGER, iv); } return; case T_SYMBOL: - stream_put_tv (s, BOP_SYMBOL, symbol_id (SCHEME_A_ x)); - return; - - case T_PAIR: - stream_put (s, BOP_LIST_BEG); + if (0) + { + // no can do without more analysis + pointer m = lookup (SCHEME_A_ x); - for (; x != NIL; x = cdr (x)) - compile_expr (SCHEME_A_ s, car (x)); + if (is_proc (m)) + { + printf ("compile proc %s %d\n", procname(m), procnum(m)); + stream_put_tv (s, BOP_SYMBOL, BOP_OP + procnum (m)); + } + else + stream_put_tv (s, BOP_SYMBOL, symbol_id (SCHEME_A_ x)); + } - stream_put (s, BOP_LIST_END); + stream_put_tv (s, BOP_SYMBOL, symbol_id (SCHEME_A_ x)); return; default: @@ -5949,7 +6016,6 @@ scheme_init (SCHEME_P) { int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); - pointer x; /* this memset is not strictly correct, as we assume (intcache) * that memset 0 will also set pointers to 0, but memset does @@ -5994,23 +6060,23 @@ SCHEME_V->tracing = 0; /* init NIL */ - set_typeflag (NIL, T_ATOM | T_MARK); + set_typeflag (NIL, T_SPECIAL | T_ATOM); set_car (NIL, NIL); set_cdr (NIL, NIL); /* init T */ - set_typeflag (S_T, T_ATOM | T_MARK); + set_typeflag (S_T, T_SPECIAL | T_ATOM); set_car (S_T, S_T); set_cdr (S_T, S_T); /* init F */ - set_typeflag (S_F, T_ATOM | T_MARK); + set_typeflag (S_F, T_SPECIAL | T_ATOM); set_car (S_F, S_F); set_cdr (S_F, S_F); /* init EOF_OBJ */ - set_typeflag (S_EOF, T_ATOM | T_MARK); + set_typeflag (S_EOF, T_SPECIAL | T_ATOM); set_car (S_EOF, S_EOF); set_cdr (S_EOF, S_EOF); /* init sink */ - set_typeflag (S_SINK, T_PAIR | T_MARK); + set_typeflag (S_SINK, T_PAIR); set_car (S_SINK, NIL); /* init c_nest */ @@ -6021,8 +6087,7 @@ new_frame_in_env (SCHEME_A_ NIL); SCHEME_V->global_env = SCHEME_V->envir; /* init else */ - x = mk_symbol (SCHEME_A_ "else"); - new_slot_in_env (SCHEME_A_ x, S_T); + new_slot_in_env (SCHEME_A_ mk_symbol (SCHEME_A_ "else"), S_T); { static const char *syntax_names[] = {