/* eval4.c Copyright (C) 1991-2002, Codemist Ltd */ /* * Bytecode interpreter/main interpreter interfaces */ /* * This code may be used and modified, and redistributed in binary * or source form, subject to the "CCL Public License", which should * accompany it. This license is a variant on the BSD license, and thus * permits use of code derived from this in either open and commercial * projects: but it does require that updates to this code be made * available back to the originators of the package. * Before merging other code in with this or linking this code * with other packages or libraries please check that the license terms * of the other material are compatible with those of this. */ /* Signature: 2ff31eb7 10-Oct-2002 */ #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) Lisp_Object MS_CDECL bytecoded0(Lisp_Object def, int nargs, ...) { Lisp_Object nil=C_nil; if (nargs != 0) return error(2, err_wrong_no_args, name_from(def), fixnum_of_int((int32)nargs)); push2(litvec, codevec); stackcheck1(2, def); /* * The "-2" a few lines down is discussed in the file bytes1.c. It is * part of the mechanism for allowing functions to have a few data bytes * at the start of the code-vector. */ #ifdef DEBUG if (trace_all) { trace_all = 0; push(def); freshline_trace(); trace_printf("Entering "); loop_print_trace(name_from(def)); trace_printf(" (no args)\n"); trace_all = 1; nil = C_nil; if (exception_pending()) { popv(3); return nil; } pop(def); } #endif def = bytestream_interpret(qcar(def)-2, qcdr(def), stack); nil = C_nil; if (exception_pending()) { flip_exception(); pop2(codevec, litvec); flip_exception(); return nil; } pop2(codevec, litvec); return def; } Lisp_Object bytecoded1(Lisp_Object def, Lisp_Object a) { Lisp_Object r; Lisp_Object nil = C_nil; push3(litvec, codevec, a); stackcheck1(3, def); #ifdef DEBUG if (trace_all) { trace_all = 0; push(def); freshline_trace(); trace_printf("Entering "); loop_print_trace(name_from(def)); trace_printf("\nArg1: "); loop_print_trace(stack[-1]); trace_printf("\n"); trace_all = 1; nil = C_nil; if (exception_pending()) { popv(4); return nil; } pop(def); } #endif r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-1); nil = C_nil; if (exception_pending()) { flip_exception(); /* * If bytestream_interpret handed back a failure code then the VERY LAST * thing that it did was to move stack down, in effect losing the argument * that had been passed to the bytesteam code. But nothing can touch the * stack between that action and here, so if I quickly increment the * stack pointer again I can find the argument again - or at least whetever * value the failed function left in that variable. Yes this does look * a little delicate, but I do like seeing argument values in my backtraces, * and the software stack involved here it totally under my control. * NOTE however that if the function I am calling here does a tail call * to something that is not directly bytecoded then the stack can be * clobbered, and the results will be garbage in the backtrace. */ stack++; pop3(a, codevec, litvec); if ((exit_reason & UNWIND_ERROR) != 0) { err_printf("Arg1: "); loop_print_error(a); err_printf("\n"); ignore_exception(); } flip_exception(); return nil; } pop2(codevec, litvec); return r; } Lisp_Object bytecoded2(Lisp_Object def, Lisp_Object a, Lisp_Object b) { Lisp_Object r; Lisp_Object nil = C_nil; push4(litvec, codevec, a, b); stackcheck1(4, def); #ifdef DEBUG if (trace_all) { trace_all = 0; push(def); freshline_trace(); trace_printf("Entering "); loop_print_trace(name_from(def)); trace_printf("\nArg1: "); loop_print_trace(stack[-2]); trace_printf("\n"); trace_printf("Arg2: "); loop_print_trace(stack[-1]); trace_printf("\n"); trace_all = 1; nil = C_nil; if (exception_pending()) { popv(5); return nil; } pop(def); } #endif r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-2); nil = C_nil; if (exception_pending()) { flip_exception(); stack += 2; if ((exit_reason & UNWIND_ERROR) != 0) { err_printf("Arg 1: "); loop_print_error(stack[-1]); err_printf("\n"); ignore_exception(); err_printf("Arg 2: "); loop_print_error(stack[0]); err_printf("\n"); ignore_exception(); } popv(2); pop2(codevec, litvec); flip_exception(); return nil; } pop2(codevec, litvec); return r; } Lisp_Object MS_CDECL bytecoded3(Lisp_Object def, int nargs, ...) { va_list aa; Lisp_Object r, a, b, c; Lisp_Object nil = C_nil; if (nargs != 3) return error(2, err_wrong_no_args, name_from(def), fixnum_of_int((int32)nargs)); va_start(aa, nargs); a = va_arg(aa, Lisp_Object); b = va_arg(aa, Lisp_Object); c = va_arg(aa, Lisp_Object); va_end(aa); push5(litvec, codevec, a, b, c); stackcheck1(5, def); #ifdef DEBUG if (trace_all) { trace_all = 0; push(def); freshline_trace(); trace_printf("Entering "); loop_print_trace(name_from(def)); trace_printf("\nArg1: "); loop_print_trace(stack[-3]); trace_printf("\n"); trace_printf("Arg2: "); loop_print_trace(stack[-2]); trace_printf("\n"); trace_printf("Arg3: "); loop_print_trace(stack[-1]); trace_printf("\n"); trace_all = 1; nil = C_nil; if (exception_pending()) { popv(6); return nil; } pop(def); } #endif r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-3); nil = C_nil; if (exception_pending()) { flip_exception(); stack += 3; if ((exit_reason & UNWIND_ERROR) != 0) { err_printf("Arg1: "); loop_print_error(stack[-2]); err_printf("\n"); ignore_exception(); err_printf("Arg2: "); loop_print_error(stack[-1]); err_printf("\n"); ignore_exception(); err_printf("Arg3: "); loop_print_error(stack[0]); err_printf("\n"); ignore_exception(); } popv(3); pop2(codevec, litvec); flip_exception(); return nil; } pop2(codevec, litvec); return r; } Lisp_Object MS_CDECL bytecodedn(Lisp_Object def, int nargs, ...) { /* * The messing about here is to get the (unknown number of) args * into a nice neat vector so that they can be indexed into. If I knew * that the args were in consecutive locations on the stack I could * probably save a copying operation. */ Lisp_Object r; Lisp_Object nil = C_nil; int i; Lisp_Object *stack_save = stack; va_list a; push2(litvec, codevec); if (nargs != 0) { va_start(a, nargs); push_args(a, nargs); } stackcheck1(stack-stack_save, def); r = qcar(def); if (nargs != ((unsigned char *)data_of_bps(r))[0]) { popv(nargs+2); return error(2, err_wrong_no_args, name_from(def), fixnum_of_int((int32)nargs)); } 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) /* * Note that in this display if a function had over 50 args then the * final bunch of them will be bundled up in to a list (as if for &rest). */ 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; } /* * Now I have carbon copies of the above, but with some print statements * inserted. These are installed when a function is marked for trace * output. */ Lisp_Object unpack_mv(Lisp_Object nil, Lisp_Object r) { Lisp_Object *p = &mv_1; exit_count = 0; *p = nil; while (r != nil) { *p++ = qcar(r); r = qcdr(r); exit_count++; } return mv_1; } Lisp_Object MS_CDECL tracebytecoded0(Lisp_Object def, int nargs, ...) { Lisp_Object r, nil=C_nil; if (nargs != 0) return error(2, err_wrong_no_args, name_from(def), fixnum_of_int((int32)nargs)); push3(litvec, codevec, def); freshline_trace(); trace_printf("Entering "); loop_print_trace(name_from(def)); trace_printf(" (no args)\n"); nil = C_nil; if (exception_pending()) { popv(3); return nil; } def = stack[0]; r = bytestream_interpret(qcar(def)-2, qcdr(def), stack); nil = C_nil; if (exception_pending()) { flip_exception(); popv(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 tracebytecoded1(Lisp_Object def, Lisp_Object a) { Lisp_Object r; Lisp_Object nil = C_nil; push4(litvec, codevec, def, a); freshline_trace(); trace_printf("Entering "); loop_print_trace(name_from(def)); nil = C_nil; if (exception_pending()) { flip_exception(); popv(2); pop2(codevec, litvec); flip_exception(); return nil; } trace_printf(" (1 arg)\nArg1: "); loop_print_trace(stack[0]); trace_printf("\n"); nil = C_nil; if (exception_pending()) { flip_exception(); popv(2); pop2(codevec, litvec); flip_exception(); return nil; } stackcheck0(4); def = stack[-1]; r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-1); nil = C_nil; if (exception_pending()) { flip_exception(); stack++; pop(a); popv(1); pop2(codevec, litvec); if ((exit_reason & UNWIND_ERROR) != 0) { err_printf("Arg1: "); loop_print_error(a); err_printf("\n"); ignore_exception(); } 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)); trace_printf(" = "); loop_print_trace(r); trace_printf("\n"); pop3(r, codevec, litvec); #ifdef COMMON r = unpack_mv(nil, r); #endif return r; } Lisp_Object tracebytecoded2(Lisp_Object def, Lisp_Object a, Lisp_Object b) { Lisp_Object r; Lisp_Object nil = C_nil; push5(litvec, codevec, def, a, b); freshline_trace(); trace_printf("Entering "); loop_print_trace(name_from(def)); nil = C_nil; if (exception_pending()) { flip_exception(); popv(3); pop2(codevec, litvec); flip_exception(); return nil; } trace_printf(" (2 args)\nArg1: "); loop_print_trace(stack[-1]); nil = C_nil; if (exception_pending()) { flip_exception(); popv(3); pop2(codevec, litvec); flip_exception(); return nil; } trace_printf("\nArg2: "); loop_print_trace(stack[0]); trace_printf("\n"); nil = C_nil; if (exception_pending()) { flip_exception(); popv(3); pop2(codevec, litvec); flip_exception(); return nil; } stackcheck0(5); def = stack[-2]; r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-2); nil = C_nil; if (exception_pending()) { flip_exception(); stack += 2; if ((exit_reason & UNWIND_ERROR) != 0) { err_printf("Arg1: "); loop_print_error(stack[-1]); err_printf("\n"); ignore_exception(); err_printf("Arg2: "); loop_print_error(stack[0]); err_printf("\n"); ignore_exception(); } popv(3); 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)); trace_printf(" = "); loop_print_trace(r); trace_printf("\n"); pop3(r, codevec, litvec); #ifdef COMMON r = unpack_mv(nil, r); #endif return r; } Lisp_Object MS_CDECL tracebytecoded3(Lisp_Object def, int nargs, ...) { va_list aa; Lisp_Object r, a, b, c; Lisp_Object nil = C_nil; if (nargs != 3) return error(2, err_wrong_no_args, name_from(def), fixnum_of_int((int32)nargs)); va_start(aa, nargs); a = va_arg(aa, Lisp_Object); b = va_arg(aa, Lisp_Object); c = va_arg(aa, Lisp_Object); va_end(aa); push2(litvec, codevec); push4(def, a, b, c); freshline_trace(); trace_printf("Entering "); loop_print_trace(name_from(def)); nil = C_nil; if (exception_pending()) { flip_exception(); popv(4); pop2(codevec, litvec); flip_exception(); return nil; } trace_printf(" (3 args)\nArg1: "); loop_print_trace(stack[-2]); nil = C_nil; if (exception_pending()) { flip_exception(); popv(4); pop2(codevec, litvec); flip_exception(); return nil; } trace_printf("\nArg2: "); loop_print_trace(stack[-1]); nil = C_nil; if (exception_pending()) { flip_exception(); popv(4); pop2(codevec, litvec); flip_exception(); return nil; } trace_printf("\nArg3: "); loop_print_trace(stack[0]); trace_printf("\n"); nil = C_nil; if (exception_pending()) { flip_exception(); popv(4); pop2(codevec, litvec); flip_exception(); return nil; } stackcheck0(6); def = stack[-3]; r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-3); nil = C_nil; if (exception_pending()) { flip_exception(); stack += 3; if ((exit_reason & UNWIND_ERROR) != 0) { err_printf("Arg1: "); loop_print_error(stack[-2]); err_printf("\n"); ignore_exception(); err_printf("Arg2: "); loop_print_error(stack[-1]); err_printf("\n"); ignore_exception(); err_printf("Arg3: "); loop_print_error(stack[0]); err_printf("\n"); ignore_exception(); } popv(4); 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)); trace_printf(" = "); loop_print_trace(r); trace_printf("\n"); pop3(r, codevec, litvec); #ifdef COMMON r = unpack_mv(nil, r); #endif return r; } Lisp_Object MS_CDECL tracebytecodedn(Lisp_Object def, int nargs, ...) { /* * The messing about here is to get the (unknown number of) args * into a nice neat vector so that they can be indexed into. If I knew * that the args were in consecutive locations on the stack I could * probably save a copying operation. */ Lisp_Object r; Lisp_Object nil = C_nil; int i; Lisp_Object *stack_save = stack; va_list a; push3(litvec, codevec, def); if (nargs != 0) { va_start(a, nargs); push_args(a, 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); if (nargs != ((unsigned char *)data_of_bps(r))[0]) { popv(nargs+3); return error(2, err_wrong_no_args, name_from(def), fixnum_of_int((int32)nargs)); } 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+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)); trace_printf(" = "); loop_print_trace(r); trace_printf("\n"); pop3(r, codevec, litvec); #ifdef COMMON r = unpack_mv(nil, r); #endif return r; } int doubled_execution = 0; Lisp_Object MS_CDECL double_bytecoded0(Lisp_Object def, int nargs, ...) { Lisp_Object nil=C_nil; if (nargs != 0) return error(2, err_wrong_no_args, name_from(def), fixnum_of_int((int32)nargs)); push2(litvec, codevec); stackcheck1(2, def); if (!doubled_execution) { push3(def, litvec, codevec); doubled_execution = 1; bytestream_interpret(qcar(def)-2, qcdr(def), stack); nil = C_nil; pop3(codevec, litvec, def); if (!exception_pending()) def = bytestream_interpret(qcar(def)-2, qcdr(def), stack); doubled_execution = 0; } else def = bytestream_interpret(qcar(def)-2, qcdr(def), stack); nil = C_nil; if (exception_pending()) { flip_exception(); pop2(codevec, litvec); flip_exception(); return nil; } pop2(codevec, litvec); return def; } Lisp_Object double_bytecoded1(Lisp_Object def, Lisp_Object a) { Lisp_Object r; Lisp_Object nil = C_nil; push3(litvec, codevec, a); stackcheck1(3, def); if (!doubled_execution) { push4(def, litvec, codevec, a); doubled_execution = 1; r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-1); nil = C_nil; pop3(codevec, litvec, def); if (!exception_pending()) r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-1); doubled_execution = 0; } else r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-1); nil = C_nil; if (exception_pending()) { flip_exception(); stack++; pop3(a, codevec, litvec); if ((exit_reason & UNWIND_ERROR) != 0) { err_printf("Arg1: "); loop_print_error(a); err_printf("\n"); ignore_exception(); } flip_exception(); return nil; } pop2(codevec, litvec); return r; } Lisp_Object double_bytecoded2(Lisp_Object def, Lisp_Object a, Lisp_Object b) { Lisp_Object r; Lisp_Object nil = C_nil; push4(litvec, codevec, a, b); stackcheck1(4, def); if (!doubled_execution) { push5(def, litvec, codevec, a, b); doubled_execution = 1; r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-2); nil = C_nil; pop3(codevec, litvec, def); if (!exception_pending()) r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-2); doubled_execution = 0; } else r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-2); nil = C_nil; if (exception_pending()) { flip_exception(); stack += 2; if ((exit_reason & UNWIND_ERROR) != 0) { err_printf("Arg 1: "); loop_print_error(stack[-1]); err_printf("\n"); ignore_exception(); err_printf("Arg 2: "); loop_print_error(stack[0]); err_printf("\n"); ignore_exception(); } popv(2); pop2(codevec, litvec); flip_exception(); return nil; } pop2(codevec, litvec); return r; } Lisp_Object MS_CDECL double_bytecoded3(Lisp_Object def, int nargs, ...) { va_list aa; Lisp_Object r, a, b, c; Lisp_Object nil = C_nil; if (nargs != 3) return error(2, err_wrong_no_args, name_from(def), fixnum_of_int((int32)nargs)); va_start(aa, nargs); a = va_arg(aa, Lisp_Object); b = va_arg(aa, Lisp_Object); c = va_arg(aa, Lisp_Object); va_end(aa); push5(litvec, codevec, a, b, c); stackcheck1(5, def); if (!doubled_execution) { push6(def, litvec, codevec, a, b, c); doubled_execution = 1; r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-3); nil = C_nil; pop3(codevec, litvec, def); if (!exception_pending()) r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-3); doubled_execution = 0; } else r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-3); nil = C_nil; if (exception_pending()) { flip_exception(); stack += 3; if ((exit_reason & UNWIND_ERROR) != 0) { err_printf("Arg1: "); loop_print_error(stack[-2]); err_printf("\n"); ignore_exception(); err_printf("Arg2: "); loop_print_error(stack[-1]); err_printf("\n"); ignore_exception(); err_printf("Arg3: "); loop_print_error(stack[0]); err_printf("\n"); ignore_exception(); } popv(3); pop2(codevec, litvec); flip_exception(); return nil; } pop2(codevec, litvec); return r; } Lisp_Object MS_CDECL double_bytecodedn(Lisp_Object def, int nargs, ...) { Lisp_Object r; Lisp_Object nil = C_nil; int i; Lisp_Object *stack_save = stack; va_list a; push2(litvec, codevec); if (nargs != 0) { va_start(a, nargs); push_args(a, nargs); } stackcheck1(stack-stack_save, def); r = qcar(def); if (nargs != ((unsigned char *)data_of_bps(r))[0]) { popv(nargs+2); return error(2, err_wrong_no_args, name_from(def), fixnum_of_int((int32)nargs)); } trace_printf("Function with > 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