Separate lisp objects for functions with fixed and variable # arguments

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;
 }

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);

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));

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)
 }

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) {

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 = @'*';

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:

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;

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

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);

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

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("#<compiled-function ", stream);
 		if (x->cfun.name != Cnil)

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

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:

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

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); \

src/h/object.h

@@ -73,6 +73,7 @@ typedef enum {
 	t_bytecodes,
 	t_bclosure,
 	t_cfun,
+	t_cfunfixed,
 	t_cclosure,
 #ifdef CLOS
 	t_instance,