/* * eval4.c Copyright (C) 1991-96, Codemist Ltd * * Bytecode interpreter/main interpreter interfaces */ /* Signature: 502ad14c 12-Mar-2000 */ #include #include #include #include "machine.h" #include "tags.h" #include "cslerror.h" #include "externs.h" #include "arith.h" #include "entries.h" #ifdef TIMEOUT #include "timeout.h" #endif #ifdef DEBUG int trace_all = 0; #endif #define name_from(def) elt(qcdr(def), 0) static void trace_entering(char *s) { int i; for (i=0; i 3 args not doubled\n"); r = bytestream_interpret(r-1, qcdr(def), stack-nargs); nil = C_nil; if (exception_pending()) { flip_exception(); stack += nargs; if ((exit_reason & UNWIND_ERROR) != 0) for (i=1; i<=nargs; i++) { err_printf("Arg%d: ", i); loop_print_error(stack[i-nargs]); err_printf("\n"); ignore_exception(); } popv(nargs); pop2(codevec, litvec); flip_exception(); return nil; } pop2(codevec, litvec); return r; } /* * The code that follows is just used to support compiled code that * has &optional or &rest arguments. */ Lisp_Object byteopt1(Lisp_Object def, Lisp_Object a) { return byteoptn(def, 1, a); } Lisp_Object byteopt2(Lisp_Object def, Lisp_Object a, Lisp_Object b) { return byteoptn(def, 2, a, b); } static Lisp_Object vbyteoptn(Lisp_Object def, int nargs, va_list a, Lisp_Object dflt) { Lisp_Object r; Lisp_Object nil = C_nil; int i, wantargs, wantopts; Lisp_Object *stack_save = stack; push2(litvec, codevec); /* * Maybe I should raise an exception (continuable error) if too many args * are provided - for now I just silently ignore the excess. */ if (nargs != 0) push_args(a, nargs); else va_end(a); stackcheck1(stack-stack_save, def); r = qcar(def); wantargs = ((unsigned char *)data_of_bps(r))[0]; wantopts = ((unsigned char *)data_of_bps(r))[1]; if (nargs < wantargs || nargs > wantargs+wantopts) { popv(nargs); pop2(codevec, litvec) return error(2, err_wrong_no_args, name_from(def), fixnum_of_int((int32)nargs)); } while (nargs < wantargs+wantopts) { push(dflt); /* Provide value for all optional args */ nargs++; } stackcheck1(stack-stack_save, def); r = qcar(def); r = bytestream_interpret(r, qcdr(def), stack-nargs); nil = C_nil; if (exception_pending()) { flip_exception(); stack += nargs; if ((exit_reason & UNWIND_ERROR) != 0) for (i=1; i<=nargs; i++) { err_printf("Arg%d: ", i); loop_print_error(stack[i-nargs]); err_printf("\n"); ignore_exception(); } popv(nargs); pop2(codevec, litvec); flip_exception(); return nil; } pop2(codevec, litvec); return r; } Lisp_Object MS_CDECL byteoptn(Lisp_Object def, int nargs, ...) { va_list a; va_start(a, nargs); return vbyteoptn(def, nargs, a, C_nil); } Lisp_Object hardopt1(Lisp_Object def, Lisp_Object a) { return hardoptn(def, 1, a); } Lisp_Object hardopt2(Lisp_Object def, Lisp_Object a, Lisp_Object b) { return hardoptn(def, 2, a, b); } Lisp_Object MS_CDECL hardoptn(Lisp_Object def, int nargs, ...) { va_list a; va_start(a, nargs); return vbyteoptn(def, nargs, a, SPID_NOARG); } Lisp_Object byteoptrest1(Lisp_Object def, Lisp_Object a) { return byteoptrestn(def, 1, a); } Lisp_Object byteoptrest2(Lisp_Object def, Lisp_Object a, Lisp_Object b) { return byteoptrestn(def, 2, a, b); } static Lisp_Object vbyterestn(Lisp_Object def, int nargs, va_list a, Lisp_Object dflt) { Lisp_Object r; Lisp_Object nil = C_nil; int i, wantargs, wantopts; Lisp_Object *stack_save = stack; push2(litvec, codevec); if (nargs != 0) push_args(a, nargs); else va_end(a); stackcheck1(stack-stack_save, def); r = qcar(def); wantargs = ((unsigned char *)data_of_bps(r))[0]; wantopts = ((unsigned char *)data_of_bps(r))[1]; if (nargs < wantargs) { popv(nargs+2); return error(2, err_wrong_no_args, name_from(def), fixnum_of_int((int32)nargs)); } while (nargs < wantargs+wantopts) { push(dflt); /* Provide value for all optional args */ nargs++; } { Lisp_Object rest = nil; while (nargs > wantargs+wantopts) { Lisp_Object w = stack[0]; stack[0] = def; rest = cons(w, rest); errexitn(nargs+2); pop(def); nargs--; } push(rest); nargs++; } stackcheck1(stack-stack_save, def); r = qcar(def); r = bytestream_interpret(r, qcdr(def), stack-nargs); nil = C_nil; if (exception_pending()) { flip_exception(); stack += nargs; if ((exit_reason & UNWIND_ERROR) != 0) for (i=1; i<=nargs; i++) { err_printf("Arg%d: ", i); loop_print_error(stack[i-nargs]); err_printf("\n"); ignore_exception(); } popv(nargs); pop2(codevec, litvec); flip_exception(); return nil; } pop2(codevec, litvec); return r; } Lisp_Object MS_CDECL byteoptrestn(Lisp_Object def, int nargs, ...) { va_list a; va_start(a, nargs); return vbyterestn(def, nargs, a, C_nil); } Lisp_Object hardoptrest1(Lisp_Object def, Lisp_Object a) { return hardoptrestn(def, 1, a); } Lisp_Object hardoptrest2(Lisp_Object def, Lisp_Object a, Lisp_Object b) { return hardoptrestn(def, 2, a, b); } Lisp_Object MS_CDECL hardoptrestn(Lisp_Object def, int nargs, ...) { va_list a; va_start(a, nargs); return vbyterestn(def, nargs, a, SPID_NOARG); } /* * Next the execution-doubling versions of the &opt/&rest interfaces */ Lisp_Object double_byteopt1(Lisp_Object def, Lisp_Object a) { return double_byteoptn(def, 1, a); } Lisp_Object double_byteopt2(Lisp_Object def, Lisp_Object a, Lisp_Object b) { return double_byteoptn(def, 2, a, b); } static Lisp_Object double_vbyteoptn(Lisp_Object def, int nargs, va_list a, Lisp_Object dflt) { Lisp_Object r; Lisp_Object nil = C_nil; int i, wantargs, wantopts; Lisp_Object *stack_save = stack; push2(litvec, codevec); /* * Maybe I should raise an exception (continuable error) if too many args * are provided - for now I just silently ignore th excess. */ if (nargs != 0) push_args(a, nargs); else va_end(a); stackcheck1(stack-stack_save, def); r = qcar(def); wantargs = ((unsigned char *)data_of_bps(r))[0]; wantopts = ((unsigned char *)data_of_bps(r))[1]; if (nargs < wantargs || nargs > wantargs+wantopts) { popv(nargs); pop2(codevec, litvec) return error(2, err_wrong_no_args, name_from(def), fixnum_of_int((int32)nargs)); } while (nargs < wantargs+wantopts) { push(dflt); /* Provide value for all optional args */ nargs++; } stackcheck1(stack-stack_save, def); trace_printf("Function with simple &opt arg not doubled\n"); r = qcar(def); r = bytestream_interpret(r, qcdr(def), stack-nargs); nil = C_nil; if (exception_pending()) { flip_exception(); stack += nargs; if ((exit_reason & UNWIND_ERROR) != 0) for (i=1; i<=nargs; i++) { err_printf("Arg%d: ", i); loop_print_error(stack[i-nargs]); err_printf("\n"); ignore_exception(); } popv(nargs); pop2(codevec, litvec); flip_exception(); return nil; } pop2(codevec, litvec); return r; } Lisp_Object MS_CDECL double_byteoptn(Lisp_Object def, int nargs, ...) { va_list a; va_start(a, nargs); return double_vbyteoptn(def, nargs, a, C_nil); } Lisp_Object double_hardopt1(Lisp_Object def, Lisp_Object a) { return double_hardoptn(def, 1, a); } Lisp_Object double_hardopt2(Lisp_Object def, Lisp_Object a, Lisp_Object b) { return double_hardoptn(def, 2, a, b); } Lisp_Object MS_CDECL double_hardoptn(Lisp_Object def, int nargs, ...) { va_list a; va_start(a, nargs); return double_vbyteoptn(def, nargs, a, SPID_NOARG); } Lisp_Object double_byteoptrest1(Lisp_Object def, Lisp_Object a) { return double_byteoptrestn(def, 1, a); } Lisp_Object double_byteoptrest2(Lisp_Object def, Lisp_Object a, Lisp_Object b) { return double_byteoptrestn(def, 2, a, b); } static Lisp_Object double_vbyterestn(Lisp_Object def, int nargs, va_list a, Lisp_Object dflt) { Lisp_Object r; Lisp_Object nil = C_nil; int i, wantargs, wantopts; Lisp_Object *stack_save = stack; push2(litvec, codevec); if (nargs != 0) push_args(a, nargs); else va_end(a); stackcheck1(stack-stack_save, def); r = qcar(def); wantargs = ((unsigned char *)data_of_bps(r))[0]; wantopts = ((unsigned char *)data_of_bps(r))[1]; if (nargs < wantargs) { popv(nargs+2); return error(2, err_wrong_no_args, name_from(def), fixnum_of_int((int32)nargs)); } while (nargs < wantargs+wantopts) { push(dflt); /* Provide value for all optional args */ nargs++; } { Lisp_Object rest = nil; while (nargs > wantargs+wantopts) { Lisp_Object w = stack[0]; stack[0] = def; rest = cons(w, rest); errexitn(nargs+2); pop(def); nargs--; } push(rest); nargs++; } stackcheck1(stack-stack_save, def); trace_printf("Function with simple &rest arg not doubled\n"); r = qcar(def); r = bytestream_interpret(r, qcdr(def), stack-nargs); nil = C_nil; if (exception_pending()) { flip_exception(); stack += nargs; if ((exit_reason & UNWIND_ERROR) != 0) for (i=1; i<=nargs; i++) { err_printf("Arg%d: ", i); loop_print_error(stack[i-nargs]); err_printf("\n"); ignore_exception(); } popv(nargs); pop2(codevec, litvec); flip_exception(); return nil; } pop2(codevec, litvec); return r; } Lisp_Object MS_CDECL double_byteoptrestn(Lisp_Object def, int nargs, ...) { va_list a; va_start(a, nargs); return double_vbyterestn(def, nargs, a, C_nil); } Lisp_Object double_hardoptrest1(Lisp_Object def, Lisp_Object a) { return double_hardoptrestn(def, 1, a); } Lisp_Object double_hardoptrest2(Lisp_Object def, Lisp_Object a, Lisp_Object b) { return double_hardoptrestn(def, 2, a, b); } Lisp_Object MS_CDECL double_hardoptrestn(Lisp_Object def, int nargs, ...) { va_list a; va_start(a, nargs); return double_vbyterestn(def, nargs, a, SPID_NOARG); } Lisp_Object tracebyteopt1(Lisp_Object def, Lisp_Object a) { return tracebyteoptn(def, 1, a); } Lisp_Object tracebyteopt2(Lisp_Object def, Lisp_Object a, Lisp_Object b) { return tracebyteoptn(def, 2, a, b); } static Lisp_Object vtracebyteoptn(Lisp_Object def, int nargs, va_list a, Lisp_Object dflt) { Lisp_Object r; Lisp_Object nil = C_nil; int i, wantargs, wantopts; Lisp_Object *stack_save = stack; push3(litvec, codevec, def); /* * Maybe I should raise an exception (continuable error) if too many args * are provided - for now I just silently ignore th excess. */ if (nargs != 0) push_args(a, nargs); else va_end(a); stackcheck1(stack-stack_save, def); r = qcar(def); wantargs = ((unsigned char *)data_of_bps(r))[0]; wantopts = ((unsigned char *)data_of_bps(r))[1]; if (nargs < wantargs || nargs > wantargs+wantopts) { popv(nargs+1); pop2(codevec, litvec) return error(2, err_wrong_no_args, name_from(def), fixnum_of_int((int32)nargs)); } while (nargs < wantargs+wantopts) { push(dflt); /* Provide value for all optional args */ nargs++; } stackcheck1(stack-stack_save, def); freshline_trace(); loop_print_trace(name_from(def)); trace_printf(" (%d args)\n", nargs); for (i=1; i<=nargs; i++) { trace_printf("Arg%d: ", i); loop_print_trace(stack[i-nargs]); trace_printf("\n"); } def = stack[-nargs]; r = qcar(def); r = bytestream_interpret(r, qcdr(def), stack-nargs); nil = C_nil; if (exception_pending()) { flip_exception(); stack += nargs; if ((exit_reason & UNWIND_ERROR) != 0) for (i=1; i<=nargs; i++) { err_printf("Arg%d: ", i); loop_print_error(stack[i-nargs]); err_printf("\n"); ignore_exception(); } popv(nargs+1); pop2(codevec, litvec); flip_exception(); return nil; } #ifdef COMMON r = Lmv_list(nil, r); if (exception_pending()) { flip_exception(); popv(1); pop2(codevec, litvec); flip_exception(); return nil; } #endif pop(def); push(r); freshline_trace(); loop_print_trace(name_from(def)); nil = C_nil; if (!exception_pending()) { trace_printf(" = "); loop_print_trace(r); trace_printf("\n"); } if (exception_pending()) { flip_exception(); popv(1); pop2(codevec, litvec); flip_exception(); return nil; } pop3(r, codevec, litvec); #ifdef COMMON r = unpack_mv(nil, r); #endif return r; } Lisp_Object MS_CDECL tracebyteoptn(Lisp_Object def, int nargs, ...) { va_list a; va_start(a, nargs); return vtracebyteoptn(def, nargs, a, C_nil); } Lisp_Object tracehardopt1(Lisp_Object def, Lisp_Object a) { return tracehardoptn(def, 1, a); } Lisp_Object tracehardopt2(Lisp_Object def, Lisp_Object a, Lisp_Object b) { return tracehardoptn(def, 2, a, b); } Lisp_Object MS_CDECL tracehardoptn(Lisp_Object def, int nargs, ...) { va_list a; va_start(a, nargs); return vtracebyteoptn(def, nargs, a, SPID_NOARG); } Lisp_Object tracebyteoptrest1(Lisp_Object def, Lisp_Object a) { return tracebyteoptrestn(def, 1, a); } Lisp_Object tracebyteoptrest2(Lisp_Object def, Lisp_Object a, Lisp_Object b) { return tracebyteoptrestn(def, 2, a, b); } static Lisp_Object vtracebyterestn(Lisp_Object def, int nargs, va_list a, Lisp_Object dflt) { Lisp_Object r; Lisp_Object nil = C_nil; int i, wantargs, wantopts; Lisp_Object *stack_save = stack; push3(litvec, codevec, def); if (nargs != 0) push_args(a, nargs); else va_end(a); stackcheck1(stack-stack_save, def); r = qcar(def); wantargs = ((unsigned char *)data_of_bps(r))[0]; wantopts = ((unsigned char *)data_of_bps(r))[1]; if (nargs < wantargs) { popv(nargs+2); return error(2, err_wrong_no_args, name_from(def), fixnum_of_int((int32)nargs)); } while (nargs < wantargs+wantopts) { push(dflt); /* Provide value for all optional args */ nargs++; } { Lisp_Object rest = nil; while (nargs > wantargs+wantopts) { Lisp_Object w = stack[0]; stack[0] = def; rest = cons(w, rest); errexitn(nargs+2); pop(def); nargs--; } push(rest); nargs++; } stackcheck1(stack-stack_save, def); freshline_trace(); loop_print_trace(name_from(def)); trace_printf(" (%d args)\n", nargs); for (i=1; i<=nargs; i++) { trace_printf("Arg%d: ", i); loop_print_trace(stack[i-nargs]); trace_printf("\n"); } def = stack[-nargs]; r = qcar(def); r = bytestream_interpret(r, qcdr(def), stack-nargs); nil = C_nil; if (exception_pending()) { flip_exception(); stack += nargs; if ((exit_reason & UNWIND_ERROR) != 0) for (i=1; i<=nargs; i++) { err_printf("Arg%d: ", i); loop_print_error(stack[i-nargs]); err_printf("\n"); ignore_exception(); } popv(nargs+1); pop2(codevec, litvec); flip_exception(); return nil; } #ifdef COMMON r = Lmv_list(nil, r); if (exception_pending()) { flip_exception(); popv(1); pop2(codevec, litvec); flip_exception(); return nil; } #endif pop(def); push(r); freshline_trace(); loop_print_trace(name_from(def)); nil = C_nil; if (!exception_pending()) { trace_printf(" = "); loop_print_trace(r); trace_printf("\n"); } if (exception_pending()) { flip_exception(); popv(1); pop2(codevec, litvec); flip_exception(); return nil; } pop3(r, codevec, litvec); #ifdef COMMON r = unpack_mv(nil, r); #endif return r; } Lisp_Object MS_CDECL tracebyteoptrestn(Lisp_Object def, int nargs, ...) { va_list a; va_start(a, nargs); return vtracebyterestn(def, nargs, a, C_nil); } Lisp_Object tracehardoptrest1(Lisp_Object def, Lisp_Object a) { return tracehardoptrestn(def, 1, a); } Lisp_Object tracehardoptrest2(Lisp_Object def, Lisp_Object a, Lisp_Object b) { return tracehardoptrestn(def, 2, a, b); } Lisp_Object MS_CDECL tracehardoptrestn(Lisp_Object def, int nargs, ...) { va_list a; va_start(a, nargs); return vtracebyterestn(def, nargs, a, SPID_NOARG); } static Lisp_Object Lis_spid(Lisp_Object nil, Lisp_Object a) { /* Used in compilation for optional args */ return onevalue(Lispify_predicate(is_spid(a))); } static Lisp_Object Lspid_to_nil(Lisp_Object nil, Lisp_Object a) { /* Used in compilation for optional args */ if (is_spid(a)) a = nil; return onevalue(a); } static Lisp_Object MS_CDECL Lload_spid(Lisp_Object nil, int nargs, ...) { /* Used in compilation of UNWIND-PROTECT */ CSL_IGNORE(nil); CSL_IGNORE(nargs); return onevalue(SPID_PROTECT); } Lisp_Object Lmv_list(Lisp_Object nil, Lisp_Object a) /* * This does a (multiple-value-list A) on just one form. It must be used * carefully so that the value-count information does not get lost between * the evaluation of A and calling this code. */ { #ifdef COMMON Lisp_Object r, *save_stack = stack; int i, x = exit_count; stackcheck1(0, a); if (x > 0) push(a); for (i=2; i<=x; i++) push((&work_0)[i]); r = nil; for (i=0; i