diff --git a/src/c/all_symbols.d b/src/c/all_symbols.d index 1f82978fb..70cc5e96a 100644 --- a/src/c/all_symbols.d +++ b/src/c/all_symbols.d @@ -104,10 +104,9 @@ mangle_name(cl_object output, char *source, int l) @(return found output maxarg) } } else if (!Null(symbol)) { - cl_object fun; - fun = symbol->symbol.gfdef; - if (fun != OBJNULL && type_of(fun) == t_cfun && - fun->cfun.block == OBJNULL) { + cl_object fun = symbol->symbol.gfdef; + cl_type t = (fun == OBJNULL)? t_other : type_of(fun); + if ((t == t_cfun || t == t_cfunfixed) && fun->cfun.block == OBJNULL) { for (l = 0; l <= cl_num_symbols_in_core; l++) { cl_object s = (cl_object)(cl_symbols + l); if (fun == SYM_FUN(s)) { @@ -220,9 +219,13 @@ make_this_symbol(int i, cl_object s, int code, const char *name, if (form) { s->symbol.stype |= stp_special_form; } else if (fun) { - cl_object f = cl_make_cfun_va(fun, s, NULL); + cl_object f; + if (narg >= 0) { + f = cl_make_cfun(fun, s, NULL, narg); + } else { + f = cl_make_cfun_va(fun, s, NULL); + } SYM_FUN(s) = f; - f->cfun.narg = narg; } cl_num_symbols_in_core = i + 1; } diff --git a/src/c/alloc.d b/src/c/alloc.d index fae1dd5b0..0617c172b 100644 --- a/src/c/alloc.d +++ b/src/c/alloc.d @@ -379,6 +379,7 @@ ONCE_MORE: obj->bclosure.lex = Cnil; break; case t_cfun: + case t_cfunfixed: obj->cfun.name = OBJNULL; obj->cfun.block = NULL; break; @@ -743,6 +744,7 @@ init_alloc(void) init_tm(t_random, "$RANDOM-STATE", sizeof(struct ecl_random), 1); init_tm(t_readtable, "rREADTABLE", sizeof(struct ecl_readtable), 1); init_tm(t_cfun, "fCFUN", sizeof(struct ecl_cfun), 32); + init_tm(t_cfunfixed, "fCFUN", sizeof(struct ecl_cfun), 32); init_tm(t_cclosure, "cCCLOSURE", sizeof(struct ecl_cclosure), 1); #ifndef CLOS init_tm(t_structure, "SSTRUCTURE", sizeof(struct ecl_structure), 32); diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index 503a70633..4da6a0dc0 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -96,6 +96,7 @@ cl_alloc_object(cl_type t) case t_bytecodes: case t_bclosure: case t_cfun: + case t_cfunfixed: case t_cclosure: #ifdef CLOS case t_instance: @@ -244,6 +245,7 @@ init_alloc(void) init_tm(t_random, "RANDOM-STATE", sizeof(struct ecl_random)); init_tm(t_readtable, "READTABLE", sizeof(struct ecl_readtable)); init_tm(t_cfun, "CFUN", sizeof(struct ecl_cfun)); + init_tm(t_cfunfixed, "CFUN", sizeof(struct ecl_cfun)); init_tm(t_cclosure, "CCLOSURE", sizeof(struct ecl_cclosure)); #ifndef CLOS init_tm(t_structure, "STRUCTURE", sizeof(struct ecl_structure)); diff --git a/src/c/cfun.d b/src/c/cfun.d index c111880a5..abfbf9d0b 100644 --- a/src/c/cfun.d +++ b/src/c/cfun.d @@ -23,7 +23,7 @@ cl_make_cfun(void *c_function, cl_object name, cl_object cblock, int narg) { cl_object cf; - cf = cl_alloc_object(t_cfun); + cf = cl_alloc_object(t_cfunfixed); cf->cfun.entry = c_function; cf->cfun.name = name; cf->cfun.block = cblock; @@ -93,6 +93,7 @@ si_compiled_function_name(cl_object fun) case t_bytecodes: output = fun->bytecodes.name; break; case t_cfun: + case t_cfunfixed: output = fun->cfun.name; break; case t_cclosure: output = Cnil; break; @@ -122,6 +123,7 @@ cl_function_lambda_expression(cl_object fun) output = @list*(3, @'ext::lambda-block', name, output); break; case t_cfun: + case t_cfunfixed: name = fun->cfun.name; lex = Cnil; output = Cnil; @@ -152,12 +154,13 @@ si_compiled_function_block(cl_object fun) cl_object output; switch(type_of(fun)) { - case t_cfun: - output = fun->cfun.block; break; - case t_cclosure: - output = fun->cclosure.block; break; - default: - FEerror("~S is not a compiled-function.", 1, fun); - } - @(return output) + case t_cfun: + case t_cfunfixed: + output = fun->cfun.block; break; + case t_cclosure: + output = fun->cclosure.block; break; + default: + FEerror("~S is not a compiled-function.", 1, fun); + } + @(return output) } diff --git a/src/c/compiler.d b/src/c/compiler.d index 31c51fe07..e7f0d4b67 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -166,8 +166,7 @@ asm_end(cl_index beginning) { bytecodes->bytecodes.file = (file == OBJNULL)? Cnil : file; bytecodes->bytecodes.file_position = (position == OBJNULL)? Cnil : position; for (i = 0, code = (cl_opcode *)bytecodes->bytecodes.code; i < code_size; i++) { - code[i] = - (cl_fixnum)cl_env.stack[beginning+i]; + code[i] = (cl_opcode)(cl_fixnum)cl_env.stack[beginning+i]; } for (i=0; i < data_size; i++) { bytecodes->bytecodes.data[i] = CAR(ENV->constants); @@ -181,11 +180,11 @@ asm_end(cl_index beginning) { static void asm_arg(int n) { #ifdef WORDS_BIGENDIAN - asm_op((n >> 8)); + asm_op((n >> 8) & 0xFF); asm_op(n & 0xFF); #else asm_op(n & 0xFF); - asm_op((n >> 8)); + asm_op((n >> 8) & 0xFF); #endif } #else @@ -224,7 +223,7 @@ asm_complete(register int op, register cl_index pc) { FEprogram_error("Too large jump", 0); else { #ifdef ECL_SMALL_BYTECODES - char low = delta & 0xFF; + unsigned char low = delta & 0xFF; char high = delta >> 8; # ifdef WORDS_BIGENDIAN cl_env.stack[pc] = (cl_object)(cl_fixnum)high; @@ -1996,7 +1995,8 @@ for special form ~S.", 1, function); && function < (cl_object)(cl_symbols + cl_num_symbols_in_core)) { cl_object f = SYM_FUN(function); - if (f != OBJNULL && type_of(f) == t_cfun) { + cl_type t = (f == OBJNULL)? t_other : type_of(f); + if (t == t_cfunfixed) { cl_object args = ECL_CONS_CDR(stmt); cl_index n = ecl_length(args); if (f->cfun.narg == 1 && n == 1) { diff --git a/src/c/disassembler.d b/src/c/disassembler.d index e64720357..2abc91316 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -215,7 +215,7 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { else line_format = Cnil; BEGIN: - if (0) { + if (1) { line_no = MAKE_FIXNUM(vector-base); } else { line_no = @'*'; diff --git a/src/c/eval.d b/src/c/eval.d index cf8b6cea6..49e18bf1c 100644 --- a/src/c/eval.d +++ b/src/c/eval.d @@ -68,13 +68,11 @@ ecl_apply_from_stack_frame(cl_object frame, cl_object x) if (fun == OBJNULL || fun == Cnil) FEundefined_function(x); switch (type_of(fun)) { + case t_cfunfixed: + if (narg != (cl_index)fun->cfun.narg) + FEwrong_num_arguments(fun); + return APPLY_fixed(narg, (cl_objectfn_fixed)fun->cfun.entry, sp); case t_cfun: - if (fun->cfun.narg >= 0) { - if (narg != (cl_index)fun->cfun.narg) - FEwrong_num_arguments(fun); - return APPLY_fixed(narg, (cl_objectfn_fixed)fun->cfun.entry, - sp); - } return APPLY(narg, fun->cfun.entry, sp); case t_cclosure: return APPLY_closure(narg, fun->cclosure.entry, @@ -123,26 +121,25 @@ _ecl_link_call(cl_object sym, cl_objectfn *pLK, cl_object cblock, int narg, cl_v if (fun == OBJNULL) goto ERROR; switch (type_of(fun)) { + case t_cfunfixed: + if (narg != fun->cfun.narg) + FEwrong_num_arguments(fun); + frame = build_funcall_frame((cl_object)&frame_aux, args); + out = APPLY_fixed(narg, (cl_objectfn_fixed)fun->cfun.entry, + frame->frame.bottom); + break; case t_cfun: - if (fun->cfun.narg >= 0) { - if (narg != fun->cfun.narg) - FEwrong_num_arguments(fun); - frame = build_funcall_frame((cl_object)&frame_aux, args); - out = APPLY_fixed(narg, (cl_objectfn_fixed)fun->cfun.entry, - frame->frame.bottom); - } else { - if (pLK) { - si_put_sysprop(sym, @'si::link-from', - CONS(CONS(ecl_make_unsigned_integer((cl_index)pLK), - ecl_make_unsigned_integer((cl_index)*pLK)), - si_get_sysprop(sym, @'si::link-from'))); - *pLK = fun->cfun.entry; - cblock->cblock.links = - CONS(sym, cblock->cblock.links); - } - frame = build_funcall_frame((cl_object)&frame_aux, args); - out = APPLY(narg, fun->cfun.entry, frame->frame.bottom); + if (pLK) { + si_put_sysprop(sym, @'si::link-from', + CONS(CONS(ecl_make_unsigned_integer((cl_index)pLK), + ecl_make_unsigned_integer((cl_index)*pLK)), + si_get_sysprop(sym, @'si::link-from'))); + *pLK = fun->cfun.entry; + cblock->cblock.links = + CONS(sym, cblock->cblock.links); } + frame = build_funcall_frame((cl_object)&frame_aux, args); + out = APPLY(narg, fun->cfun.entry, frame->frame.bottom); break; #ifdef CLOS case t_instance: diff --git a/src/c/gbc.d b/src/c/gbc.d index 341cb6a6e..178250e28 100644 --- a/src/c/gbc.d +++ b/src/c/gbc.d @@ -364,6 +364,7 @@ BEGIN: break; case t_cfun: + case t_cfunfixed: mark_object(x->cfun.block); mark_next(x->cfun.name); break; diff --git a/src/c/instance.d b/src/c/instance.d index 901cb9b34..3969903f6 100644 --- a/src/c/instance.d +++ b/src/c/instance.d @@ -336,6 +336,7 @@ cl_class_of(cl_object x) case t_bytecodes: case t_bclosure: case t_cfun: + case t_cfunfixed: case t_cclosure: index = ECL_BUILTIN_FUNCTION; break; #ifdef ECL_THREADS diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 1694f5333..de4e3535b 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -556,9 +556,10 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) ECL_OFFSET_TABLE; typedef struct cl_env_struct *cl_env_ptr; const cl_env_ptr the_env = &cl_env; - cl_opcode *vector = pc; + register cl_opcode *vector = pc; cl_object *data = bytecodes->bytecodes.data; - cl_object reg0 = the_env->values[0], reg1, lex_env = env; + register cl_object reg0 = the_env->values[0]; + cl_object reg1, lex_env = env; struct ecl_stack_frame frame_aux; volatile struct ihs_frame ihs; ihs_push(&ihs, bytecodes, env); diff --git a/src/c/predicate.d b/src/c/predicate.d index 123e65868..0ba28b7ba 100644 --- a/src/c/predicate.d +++ b/src/c/predicate.d @@ -228,7 +228,8 @@ cl_functionp(cl_object x) cl_object output; t = type_of(x); - if (t == t_bytecodes || t == t_bclosure || t == t_cfun || t == t_cclosure + if (t == t_bytecodes || t == t_bclosure || t == t_cfun + || t == t_cfunfixed || t == t_cclosure #ifdef CLOS || (t == t_instance && x->instance.isgf) #endif @@ -243,7 +244,8 @@ cl_object cl_compiled_function_p(cl_object x) { cl_type t = type_of(x); - @(return ((t == t_bytecodes || t == t_bclosure || t == t_cfun || t == t_cclosure) ? Ct : Cnil)) + @(return ((t == t_bytecodes || t == t_bclosure || t == t_cfun + || t == t_cfunfixed || t == t_cclosure) ? Ct : Cnil)) } cl_object diff --git a/src/c/print.d b/src/c/print.d index 1852c6120..d0a9f48e6 100644 --- a/src/c/print.d +++ b/src/c/print.d @@ -1520,6 +1520,7 @@ si_write_ugly_object(cl_object x, cl_object stream) } break; case t_cfun: + case t_cfunfixed: if (ecl_print_readably()) FEprint_not_readable(x); write_str("#cfun.name != Cnil) diff --git a/src/c/reference.d b/src/c/reference.d index 5f79c897f..e00c5dbb4 100644 --- a/src/c/reference.d +++ b/src/c/reference.d @@ -112,7 +112,8 @@ cl_object si_coerce_to_function(cl_object fun) { cl_type t = type_of(fun); - if (!(t == t_cfun || t == t_cclosure || t == t_bytecodes || t == t_bclosure + if (!(t == t_cfun || t == t_cfunfixed || t == t_cclosure + || t == t_bytecodes || t == t_bclosure #ifdef CLOS || (t == t_instance && fun->instance.isgf) #endif diff --git a/src/c/stacks.d b/src/c/stacks.d index f076cd45d..a810ec51b 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -186,6 +186,7 @@ ihs_function_name(cl_object x) return y; case t_cfun: + case t_cfunfixed: return(x->cfun.name); default: diff --git a/src/c/typespec.d b/src/c/typespec.d index 23dec4e0e..62877da86 100644 --- a/src/c/typespec.d +++ b/src/c/typespec.d @@ -183,6 +183,7 @@ ecl_type_to_symbol(cl_type t) case t_bytecodes: case t_bclosure: case t_cfun: + case t_cfunfixed: case t_cclosure: return @'compiled-function'; #ifdef ECL_THREADS diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index fbf48c745..d4f429bfa 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -90,22 +90,37 @@ enum { }; #define MAX_OPARG 0x7FFF -#ifdef ECL_SMALL_BYTECODES -#define OPCODE_SIZE 1 -#define OPARG_SIZE sizeof(cl_oparg) -typedef char cl_opcode; -#else -#define OPCODE_SIZE 1 -#define OPARG_SIZE 1 -typedef int16_t cl_opcode; -#endif typedef int16_t cl_oparg; -#define READ_OPCODE(v) (*(cl_opcode *)(v)) -#define READ_OPARG(v) (*(cl_oparg *)(v)) -#define GET_OPCODE(v) (*((cl_opcode *)(v)++)) -#define GET_OPARG(r,v) { \ - r = *((cl_oparg *)(v)++); \ -} + +/* + * Note that in the small bytecodes case, we have to recompose a signed + * small integer out of its pieces. We have to be careful because the + * least significant byte has to be interpreted as unsigned, while the + * most significant byte carries a sign. + */ +#ifdef ECL_SMALL_BYTECODES + typedef signed char cl_opcode; +# define OPCODE_SIZE 1 +# define OPARG_SIZE 2 +# ifdef WORDS_BIGENDIAN +# define READ_OPARG(v) ((cl_fixnum)v[0] << 8) + (unsigned char)v[1] +# else +#if 0 +# define READ_OPARG(v) ((cl_fixnum)v[1] << 8) + (unsigned char)v[0] +#else +# define READ_OPARG(v) ((cl_oparg*)v)[0] +#endif +# endif +# define GET_OPARG(r,v) { r = READ_OPARG(v); v += 2; } +#else + typedef int16_t cl_opcode; +# define OPCODE_SIZE 1 +# define OPARG_SIZE 1 +# define READ_OPCODE(v) v[0] +# define READ_OPARG(v) v[0] +# define GET_OPARG(r,v) { r = READ_OPARG(v); v++; } +#endif +#define GET_OPCODE(v) *((v)++) #define GET_DATA(r,v,data) { \ cl_oparg ndx; \ GET_OPARG(ndx, v); \ diff --git a/src/h/object.h b/src/h/object.h index 80ed81e9b..b24bc882e 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -73,6 +73,7 @@ typedef enum { t_bytecodes, t_bclosure, t_cfun, + t_cfunfixed, t_cclosure, #ifdef CLOS t_instance,