1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768 |
- /*
- * eval4.c Copyright (C) 1991-96, Codemist Ltd
- *
- * Bytecode interpreter/main interpreter interfaces
- */
- /* Signature: 502ad14c 12-Mar-2000 */
- #include <stdarg.h>
- #include <string.h>
- #include <ctype.h>
- #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<trace_depth; i++) trace_printf(" ");
- trace_printf(s);
- trace_depth++;
- }
- static void trace_exiting(char *s)
- {
- int i;
- trace_depth--;
- trace_printf(s);
- }
- 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" on the next line 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_entering("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("Arg1: ");
- 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("Arg1: ");
- 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("Arg1: ");
- 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_entering("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_exiting("\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_entering("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_exiting("\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_entering("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_exiting("\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_entering("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_exiting("\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();
- trace_entering("Entering");
- 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_exiting("\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;
- 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;
- 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;
- 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<x; i++)
- { Lisp_Object w;
- pop(w);
- r = cons(w, r);
- nil = C_nil;
- if (exception_pending())
- { stack = save_stack;
- return nil;
- }
- }
- return onevalue(r);
- #else
- CSL_IGNORE(nil);
- return ncons(a);
- #endif
- }
- /*
- * In these tables there are some functions that would need adjusting
- * for a Common Lisp compiler, since they take different numbers of
- * args in Common and Standard Lisp.
- * This means, to be specific:
- *
- * Lgensym Lread Latan Ltruncate Lfloat
- * Lintern Lmacroexpand Lmacroexpand_1
- * Lrandom Lunintern Lappend Leqn Lgcd
- * Lgeq Lgreaterp Llcm Lleq Llessp
- * Lquotient
- *
- * In these cases (at least!) the Common Lisp version of the compiler will
- * need to avoid generating the call that uses this table.
- *
- * Some functions are missing from the list here because they seemed
- * critical enough to be awarded single-byte opcodes or because the
- * compiler always expands them away - car through cddddr are the main
- * cases, together with eq and equal.
- */
- n_args *zero_arg_functions[] =
- {
- Lbatchp, /* 0 */
- Ldate, /* 1 */
- Leject, /* 2 */
- Lerror0, /* 3 */
- Lgctime, /* 4 */
- Lgensym, /* 5 */
- Llposn, /* 6 */
- Lnext_random, /* 7 */
- Lposn, /* 8 */
- Lread, /* 9 */
- Lreadch, /* 10 */
- Lterpri, /* 11 */
- Ltime, /* 12 */
- Ltyi, /* 13 */
- Lload_spid, /* 14 */ /* ONLY used in compiled code */
- NULL
- };
- one_args *one_arg_functions[] =
- {
- Labsval, /* 0 */
- Ladd1, /* 1 */
- Latan, /* 2 */
- Lapply0, /* 3 */
- Latom, /* 4 */
- Lboundp, /* 5 */
- Lchar_code, /* 6 */
- Lclose, /* 7 */
- Lcodep, /* 8 */
- Lcompress, /* 9 */
- Lconstantp, /* 10 */
- Ldigitp, /* 11 */
- Lendp, /* 12 */
- Leval, /* 13 */
- Levenp, /* 14 */
- Levlis, /* 15 */
- Lexplode, /* 16 */
- Lexplode2lc, /* 17 */
- Lexplodec, /* 18 */
- Lfixp, /* 19 */
- Lfloat, /* 20 */
- Lfloatp, /* 21 */
- Lsymbol_specialp, /* 22 */
- Lgc, /* 23 */
- Lgensym1, /* 24 */
- Lgetenv, /* 25 */
- Lsymbol_globalp, /* 26 */
- Liadd1, /* 27 */
- Lsymbolp, /* 28 */
- Liminus, /* 29 */
- Liminusp, /* 30 */
- Lindirect, /* 31 */
- Lintegerp, /* 32 */
- Lintern, /* 33 */
- Lisub1, /* 34 */
- Llength, /* 35 */
- Llengthc, /* 36 */
- Llinelength, /* 37 */
- Lalpha_char_p, /* 38 */
- Lload_module, /* 39 */
- Llognot, /* 40 */
- Lmacroexpand, /* 41 */
- Lmacroexpand_1, /* 42 */
- Lmacro_function, /* 43 */
- Lget_bps, /* 44 */
- Lmake_global, /* 45 */
- Lsmkvect, /* 46 */
- Lmake_special, /* 47 */
- Lminus, /* 48 */
- Lminusp, /* 49 */
- Lmkvect, /* 50 */
- Lmodular_minus, /* 51 */
- Lmodular_number, /* 52 */
- Lmodular_reciprocal, /* 53 */
- Lnull, /* 54 */
- Loddp, /* 55 */
- Lonep, /* 56 */
- Lpagelength, /* 57 */
- Lconsp, /* 58 */
- Lplist, /* 59 */
- Lplusp, /* 60 */
- Lprin, /* 61 */
- Lprinc, /* 62 */
- Lprint, /* 63 */
- Lprintc, /* 64 */
- Lrandom, /* 65 */
- Lrational, /* 66 */
- Lrdf1, /* 67 */
- Lrds, /* 68 */
- Lremd, /* 69 */
- Lreverse, /* 70 */
- Lnreverse, /* 71 */
- Lwhitespace_char_p, /* 72 */
- Lset_small_modulus, /* 73 */
- Lxtab, /* 74 */
- Lspecial_char, /* 75 */
- Lspecial_form_p, /* 76 */
- Lspool, /* 77 */
- Lstop, /* 78 */
- Lstringp, /* 79 */
- Lsub1, /* 80 */
- Lsymbol_env, /* 81 */
- Lsymbol_function, /* 82 */
- Lsymbol_name, /* 83 */
- Lsymbol_value, /* 84 */
- Lsystem, /* 85 */
- Ltruncate, /* 86 */
- Lttab, /* 87 */
- Ltyo, /* 88 */
- Lunintern, /* 89 */
- Lunmake_global, /* 90 */
- Lunmake_special, /* 91 */
- Lupbv, /* 92 */
- Lsimple_vectorp, /* 93 */
- Lverbos, /* 94 */
- Lwrs, /* 95 */
- Lzerop, /* 96 */
- Lcar, /* 97 */
- Lcdr, /* 98 */
- Lcaar, /* 99 */
- Lcadr, /* 100 */
- Lcdar, /* 101 */
- Lcddr, /* 102 */
- Lcar, /* 103 */ /* Really QCAR (unchecked) */
- Lcdr, /* 104 */
- Lcaar, /* 105 */
- Lcadr, /* 106 */
- Lcdar, /* 107 */
- Lcddr, /* 108 */
- Lncons, /* 109 */
- Lnumberp, /* 110 */
- Lis_spid, /* 111 */ /* ONLY used in compiled code */
- Lspid_to_nil, /* 112 */ /* ONLY used in compiled code */
- Lmv_list, /* 113 */ /* ONLY used in compiled code */
- NULL
- };
- two_args *two_arg_functions[] =
- {
- Lappend, /* 0 */
- Lash, /* 1 */
- Lassoc, /* 2 */
- Latsoc, /* 3 */
- Ldeleq, /* 4 */
- Ldelete, /* 5 */
- Ldivide, /* 6 */
- Leqcar, /* 7 */
- Leql, /* 8 */
- Leqn, /* 9 */
- Lexpt, /* 10 */
- Lflag, /* 11 */
- Lflagpcar, /* 12 */
- Lgcd, /* 13 */
- Lgeq, /* 14 */
- Lgetv, /* 15 */
- Lgreaterp, /* 16 */
- Lidifference, /* 17 */
- Ligreaterp, /* 18 */
- Lilessp, /* 19 */
- Limax, /* 20 */
- Limin, /* 21 */
- Liplus2, /* 22 */
- Liquotient, /* 23 */
- Liremainder, /* 24 */
- Lirightshift, /* 25 */
- Litimes2, /* 26 */
- Llcm, /* 27 */
- Lleq, /* 28 */
- Llessp, /* 29 */
- Lmake_random_state, /* 30 */
- Lmax2, /* 31 */
- Lmember, /* 32 */
- Lmemq, /* 33 */
- Lmin2, /* 34 */
- Lmod, /* 35 */
- Lmodular_difference, /* 36 */
- Lmodular_expt, /* 37 */
- Lmodular_plus, /* 38 */
- Lmodular_quotient, /* 39 */
- Lmodular_times, /* 40 */
- Lnconc, /* 41 */
- Lneq, /* 42 */
- Lorderp, /* 43 */
- Lquotient, /* 44 */
- Lrem, /* 45 */
- Lremflag, /* 46 */
- Lremprop, /* 47 */
- Lrplaca, /* 48 */
- Lrplacd, /* 49 */
- Lsgetv, /* 50 */
- Lset, /* 51 */
- Lsmemq, /* 52 */
- Lsubla, /* 53 */
- Lsublis, /* 54 */
- Lsymbol_set_definition, /* 55 */
- Lsymbol_set_env, /* 56 */
- Ltimes2, /* 57 */
- Lxcons, /* 58 */
- Lequal, /* 59 */
- Leq, /* 60 */
- Lcons, /* 61 */
- Llist2, /* 62 */
- Lget, /* 63 */
- Lgetv, /* 64 */ /* QGETV */
- Lflagp, /* 65 */
- Lapply1, /* 66 */
- Ldifference2, /* 67 */
- Lplus2, /* 68 */
- Ltimes2, /* 69 */
- Lequalcar, /* 70 */
- Leq, /* 71 */ /* IEQUAL */
- NULL
- };
- n_args *three_arg_functions[] =
- {
- Lbpsputv, /* 0 */
- Lerrorsetn, /* 1 */
- Llist2star, /* 2 */
- Llist3, /* 3 */
- Lputprop, /* 4 */
- Lputv, /* 5 */
- Lsputv, /* 6 */
- Lsubst, /* 7 */
- Lapply2, /* 8 */
- Lacons, /* 9 */
- NULL
- };
- /* end of eval4.c */
|