Artifact fb24d04f7cd85c1ebb76b4ed66c18270fdfff917c5e3e97390194e1bb05acf47:
- Executable file
r38/lisp/csl/cslbase/bytes1.c
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 161696) [annotate] [blame] [check-ins using] [more...]
/* * bytes1.c Copyright (C) 1991-2007, Codemist Ltd * * * Bytecode interpreter for Lisp */ /* * 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: 31c96cb4 18-Jan-2007 */ #include "headers.h" #if defined DEMO_MODE || defined DEMO_BUILD #include "demobyte.h" /* Alternate bytecode mapping used by demo version */ #else #include "bytes.h" #endif /* * I put all the code that handles property lists in this file since then * I can arrange that the option that allows me to count the number of byte * opcodes that are executed also lets me collect statistics on which * indicators are most heavily used with PUT and GET. */ void record_get(Lisp_Object tag, CSLbool found) { #ifdef RECORD_GET Lisp_Object nil = C_nil; Lisp_Object w; push(tag); w = Lget_hash_2(nil, tag, get_counts); pop(tag); errexitv(); if (w == nil) { w = cons_no_gc(fixnum_of_int(0), fixnum_of_int(0)); push(w); Lput_hash(nil, 3, tag, get_counts, w); pop(w); errexitv(); } if (found) qcar(w) += 0x10; else qcdr(w) += 0x10; #endif } /* * Here is a short essay on the interaction between flags and properties. * It is written because the issue appears to be delicate, especially in the * face of a scheme that I use to speed things up. * (a) If you use FLAG, REMFLAG and FLAGP with some indicator then that * indicator is known as a flag. * (b) If you use PUT, REMPROP and GET with an indicator then what you * have is a property. * (c) Providing the names of flags and properties are disjoint no difficulty * whatever should arise. * (d) If you use PLIST to gain direct access to a property list then flags * are visible as pairs (tag . t) and properties as (tag . value). * (e) Using RPLACx operations on the result of PLIST may cause system * damage. It is to be considered illegal. Also changes made that * way may not be matched in any accelerating caches that I keep. * (f) After (FLAG '(id) 'tag) [when id did not previously have any flags * or properties] a call (GET 'id 'tag) will return t. * (g) After (PUT 'id 'tag 'anything) a call (FLAGP 'id 'tag) will return t * whatever the value of "anything". A call (GET 'id 'tag) will return * the saved value (which might be nil). Thus FLAGP can be thought of * as a function that tests if a given property is attached to a * symbol. * (h) As a consequence of (g) REMPROP and REMFLAG are really the same * operation. */ #ifndef COMMON Lisp_Object get(Lisp_Object a, Lisp_Object b) { Lisp_Object pl, prev, w, nil = C_nil; int n; /* * In CSL mode plists are structured like association lists, and * NOT as lists with alternate tags and values. There is also * a bitmap that can provide a fast test for the presence of a * property... */ if (!symbolp(a)) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } if (symbolp(b) && (n = header_fastget(qheader(b))) != 0) { if ((w = qfastgets(a)) == nil) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } w = elt(w, n-1); if (w == SPID_NOPROP) w = nil; #ifdef RECORD_GET push(w); record_get(b, w != nil); pop(w); errexit(); #endif return onevalue(w); } pl = qplist(a); if (pl == nil) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } w = qcar(pl); if (qcar(w) == b) { #ifdef RECORD_GET push(w); record_get(b, YES); pop(w); errexit(); #endif return onevalue(qcdr(w)); } pl = qcdr(pl); if (pl == nil) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } w = qcar(pl); if (qcar(w) == b) { #ifdef RECORD_GET push(w); record_get(b, YES); pop(w); errexit(); #endif return onevalue(qcdr(w)); } prev = pl; pl = qcdr(pl); if (pl == prev) return aerror("looped up plist in get"); if (pl == nil) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } for (;;) { w = qcar(pl); /* * If I find the item anywhere beyond the first two places in the plist I * migrate it up to the front so that next time will be faster */ if (qcar(w) == b) { qcdr(prev) = qcdr(pl); qcdr(pl) = qplist(a); qplist(a) = pl; #ifdef RECORD_GET push(w); record_get(b, YES); pop(w); errexit(); #endif return onevalue(qcdr(w)); } prev = pl; pl = qcdr(pl); if (pl == prev) return aerror("looped up plist in get"); if (pl == nil) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } } } Lisp_Object putprop(Lisp_Object a, Lisp_Object b, Lisp_Object c) { Lisp_Object nil = C_nil; Lisp_Object pl; int n; if (!symbolp(a)) return c; if (symbolp(b) && (n = header_fastget(qheader(b))) != 0) { pl = qfastgets(a); if (pl == nil) { push3(a, b, c); pl = getvector_init(CELL+CELL*fastget_size, SPID_NOPROP); pop3(c, b, a); errexit(); qfastgets(a) = pl; } elt(pl, n-1) = c; return c; /* NB the property is NOT on the plist */ } pl = qplist(a); while (pl != nil) { Lisp_Object w = qcar(pl); if (qcar(w) == b) { qcdr(w) = c; return c; } else pl = qcdr(pl); } stackcheck3(0, a, b, c); nil = C_nil; push2(a, c); b = acons(b, c, qplist(a)); pop2(c, a); errexit(); qplist(a) = b; return c; } static Lisp_Object remprop(Lisp_Object a, Lisp_Object b) { Lisp_Object pl, prevp; Lisp_Object nil = C_nil; int n; if (!symbolp(a)) return nil; if (symbolp(b) && (n = header_fastget(qheader(b))) != 0) { pl = qfastgets(a); if (pl != nil) elt(pl, n-1) = SPID_NOPROP; return nil; } prevp = nil; pl = qplist(a); while (pl != nil) { Lisp_Object w = qcar(pl); if (qcar(w) == b) { pl = qcdr(pl); if (prevp == nil) qplist(a) = pl; else qcdr(prevp) = pl; return qcdr(w); } prevp = pl; pl = qcdr(prevp); if (pl == prevp) return aerror("looped up plist in remprop"); } return nil; } #else /* in a COMMON world I have to use flat plists */ Lisp_Object get(Lisp_Object a, Lisp_Object b, Lisp_Object c) { Lisp_Object nil = C_nil; Lisp_Object pl; int n; if (!symbolp(a)) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return c; } if (symbolp(b) && (n = header_fastget(qheader(b))) != 0) { if ((pl = qfastgets(a)) == nil) { #ifdef RECORD_GET push(c); record_get(b, NO); pop(c); errexit(); #endif return onevalue(c); } pl = elt(pl, n-1); if (pl == SPID_NOPROP) { #ifdef RECORD_GET push(c); record_get(b, NO); pop(c); errexit(); #endif return onevalue(c); } #ifdef RECORD_GET push(pl); record_get(b, YES); pop(pl); errexit(); #endif return onevalue(pl); } pl = qplist(a); while (pl != nil) { if (qcar(pl) == b) { #ifdef RECORD_GET push(pl); record_get(b, YES); pop(pl); errexit(); #endif return qcar(qcdr(pl)); } else pl = qcdr(qcdr(pl)); } #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return c; } Lisp_Object putprop(Lisp_Object a, Lisp_Object b, Lisp_Object c) { Lisp_Object nil = C_nil; Lisp_Object pl; int n; if (!symbolp(a)) return c; if (symbolp(b) && (n = header_fastget(qheader(b))) != 0) { pl = qfastgets(a); if (pl == nil) { push3(a, b, c); pl = getvector_init(CELL+CELL*fastget_size, SPID_NOPROP); pop3(c, b, a); errexit(); qfastgets(a) = pl; } elt(pl, n-1) = c; return c; /* NB the property in NOT on the plist */ } pl = qplist(a); while (pl != nil) { if (qcar(pl) == b) { pl = qcdr(pl); qcar(pl) = c; return c; } else pl = qcdr(qcdr(pl)); } stackcheck3(0, a, b, c); nil = C_nil; push2(a, c); b = list2star(b, c, qplist(a)); pop2(c, a); errexit(); qplist(a) = b; return c; } static Lisp_Object remprop(Lisp_Object a, Lisp_Object b) { Lisp_Object nil = C_nil; Lisp_Object pl, prevp = nil; int n; if (!symbolp(a)) return nil; if (symbolp(b) && (n = header_fastget(qheader(b))) != 0) { pl = qfastgets(a); if (pl != nil) elt(pl, n-1) = SPID_NOPROP; return nil; } pl = qplist(a); while (pl != nil) { if (qcar(pl) == b) { Lisp_Object v = qcdr(pl); pl = qcdr(v); if (prevp == nil) qplist(a) = pl; else qcdr(prevp) = pl; return lisp_true; } prevp = qcdr(pl); pl = qcdr(prevp); if (pl == prevp) return aerror("looped up plist in remprop (1)"); } return nil; } #endif /* end of property list stuff */ #ifndef COMMON Lisp_Object Lget(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { Lisp_Object pl, prev, w; int n; /* * In CSL mode plists are structured like association lists, and * NOT as lists with alternate tags and values. There is also * a bitmap that can provide a fast test for the presence of a * property... */ if (!symbolp(a)) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } if (symbolp(b) && (n = header_fastget(qheader(b))) != 0) { if ((w = qfastgets(a)) == nil) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } w = elt(w, n-1); if (w == SPID_NOPROP) w = nil; #ifdef RECORD_GET push(w); record_get(b, w != nil); pop(w); errexit(); #endif return onevalue(w); } pl = qplist(a); if (pl == nil) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } w = qcar(pl); if (qcar(w) == b) { #ifdef RECORD_GET push(w); record_get(b, YES); pop(w); errexit(); #endif return onevalue(qcdr(w)); } pl = qcdr(pl); if (pl == nil) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } w = qcar(pl); if (qcar(w) == b) { #ifdef RECORD_GET push(w); record_get(b, YES); pop(w); errexit(); #endif return onevalue(qcdr(w)); } prev = pl; pl = qcdr(pl); if (pl == prev) return aerror("looped up plist in Lget"); if (pl == nil) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } for (;;) { w = qcar(pl); /* * If I find the item anywhere beyond the first two places in the plist I * migrate it up to the front so that next time will be faster */ if (qcar(w) == b) { qcdr(prev) = qcdr(pl); qcdr(pl) = qplist(a); qplist(a) = pl; #ifdef RECORD_GET push(w); record_get(b, YES); pop(w); errexit(); #endif return onevalue(qcdr(w)); } prev = pl; pl = qcdr(pl); if (pl == prev) return aerror("looped up plist in Lget"); if (pl == nil) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } } } #else Lisp_Object MS_CDECL Lget_3(Lisp_Object nil, int nargs, ...) { va_list aa; Lisp_Object a, b, c; CSL_IGNORE(nil); if (nargs != 3) return aerror("get"); 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); return onevalue(get(a, b, c)); } Lisp_Object Lget(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { return onevalue(get(a, b, nil)); } #endif Lisp_Object MS_CDECL Lputprop(Lisp_Object nil, int nargs, ...) { va_list aa; Lisp_Object a, b, c; argcheck(nargs, 3, "put"); CSL_IGNORE(nil); 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); a = putprop(a, b, c); errexit(); return onevalue(a); } #ifdef COMMON Lisp_Object Lflagp(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { a = get(a, b, unset_var); errexit(); return onevalue(a == unset_var ? nil : lisp_true); } Lisp_Object Lflagpcar(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { /* Fairly heavily used by Reduce test file - hence in here */ if (!consp(a)) return onevalue(nil); a = qcar(a); a = get(a, b, unset_var); errexit(); return onevalue(a == unset_var ? nil : lisp_true); } Lisp_Object Lflag(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { while (consp(a)) { Lisp_Object v = qcar(a); a = qcdr(a); if (!symbolp(v)) continue; push2(a, b); putprop(v, b, lisp_true); pop2(b, a); errexit(); } return onevalue(nil); } Lisp_Object Lremflag(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { while (consp(a)) { Lisp_Object v = qcar(a); a = qcdr(a); if (!symbolp(v)) continue; push2(a, b); remprop(v, b); pop2(b, a); errexit(); } return onevalue(nil); } #else Lisp_Object Lflagp(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { Lisp_Object pl, prev, w; int n; if (!symbolp(a)) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } if (symbolp(b) && (n = header_fastget(qheader(b))) != 0) { if ((w = qfastgets(a)) == nil) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } w = elt(w, n-1); if (w == SPID_NOPROP) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } #ifdef RECORD_GET record_get(b, YES); errexit(); #endif return onevalue(lisp_true); } pl = qplist(a); if (pl == nil) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } w = qcar(pl); if (qcar(w) == b) { #ifdef RECORD_GET record_get(b, YES); errexit(); #endif return onevalue(lisp_true); } pl = qcdr(pl); if (pl == nil) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } w = qcar(pl); if (qcar(w) == b) { #ifdef RECORD_GET record_get(b, YES); errexit(); #endif return onevalue(lisp_true); } prev = pl; pl = qcdr(pl); if (pl == prev) return aerror("looped up plist in Lflagp"); if (pl == nil) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } for (;;) { w = qcar(pl); /* * If I find the item anywhere beyond the first two places in the plist I * migrate it up to the front so that next time will be faster */ if (qcar(w) == b) { qcdr(prev) = qcdr(pl); qcdr(pl) = qplist(a); qplist(a) = pl; #ifdef RECORD_GET record_get(b, YES); errexit(); #endif return onevalue(lisp_true); } prev = pl; pl = qcdr(pl); if (pl == prev) return aerror("looped up plist in Lflagp"); if (pl == nil) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } } } Lisp_Object Lflagpcar(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { Lisp_Object pl, prev, w; int n; /* Fairly heavily used by Reduce test file - hence in here */ if (a != nil) { if (!consp(a)) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } a = qcar(a); if (!symbolp(a)) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } } if (symbolp(b) && (n = header_fastget(qheader(b))) != 0) { if ((w = qfastgets(a)) == nil) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } w = elt(w, n-1); if (w == SPID_NOPROP) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } #ifdef RECORD_GET record_get(b, YES); errexit(); #endif return onevalue(lisp_true); } pl = qplist(a); if (pl == nil) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } w = qcar(pl); if (qcar(w) == b) { #ifdef RECORD_GET record_get(b, YES); errexit(); #endif return onevalue(lisp_true); } pl = qcdr(pl); if (pl == nil) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } w = qcar(pl); if (qcar(w) == b) { #ifdef RECORD_GET record_get(b, YES); errexit(); #endif return onevalue(lisp_true); } prev = pl; pl = qcdr(pl); if (pl == prev) return aerror("looped up plist in flagpcar"); if (pl == nil) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } for (;;) { w = qcar(pl); /* * If I find the item anywhere beyond the first two places in the plist I * migrate it up to the front so that next time will be faster */ if (qcar(w) == b) { qcdr(prev) = qcdr(pl); qcdr(pl) = qplist(a); qplist(a) = pl; #ifdef RECORD_GET record_get(b, YES); errexit(); #endif return onevalue(lisp_true); } prev = pl; pl = qcdr(pl); if (pl == prev) return aerror("looped up plist in flagpcar"); if (pl == nil) { #ifdef RECORD_GET record_get(b, NO); errexit(); #endif return onevalue(nil); } } } Lisp_Object Lflag(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { int n = 0; if (symbolp(b)) n = header_fastget(qheader(b)); while (consp(a)) { Lisp_Object v = qcar(a), pl; a = qcdr(a); if (!symbolp(v)) continue; /* * I store FLAGS just as if they were PROPERTIES that have the value * T, so after (flag '(a b c) 'd) if anybody goes (get 'a 'd) they get back * the value T. */ if (n) { pl = qfastgets(v); if (pl == nil) { push2(v, b); pl = getvector_init(CELL+CELL*fastget_size, SPID_NOPROP); pop2(b, v); errexit(); qfastgets(v) = pl; } elt(pl, n-1) = lisp_true; continue; } push2(a, b); pl = qplist(v); while (pl != nil) { Lisp_Object w = qcar(pl); if (qcar(w) == b) { qcdr(w) = lisp_true; goto already_flagged; } else pl = qcdr(pl); } push(v); b = acons(b, lisp_true, qplist(v)); errexitn(3); pop(v); qplist(v) = b; already_flagged: pop2(b, a); } return onevalue(nil); } Lisp_Object Lremflag(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { int n = 0; if (symbolp(b)) n = header_fastget(qheader(b)); while (consp(a)) { Lisp_Object pl, prevp, v = qcar(a); a = qcdr(a); if (!symbolp(v)) continue; if (n) { pl = qfastgets(v); if (pl != nil) elt(pl, n-1) = SPID_NOPROP; continue; } prevp = nil; pl = qplist(v); while (pl != nil) { Lisp_Object w = qcar(pl); if (qcar(w) == b) { pl = qcdr(pl); if (prevp == nil) qplist(v) = pl; else qcdr(prevp) = pl; break; } prevp = pl; pl = qcdr(prevp); if (pl == prevp) return aerror("looped up plist in remflag"); } } return onevalue(nil); } #endif Lisp_Object Lremprop(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { CSL_IGNORE(nil); return onevalue(remprop(a, b)); } Lisp_Object Lplist(Lisp_Object nil, Lisp_Object a) { Lisp_Object r; int i; CSL_IGNORE(nil); if (!symbolp(a)) return aerror1("plist", a); r = qplist(a); a = qfastgets(a); if (a == nil) return onevalue(r); for (i=0; i<fastget_size; i++) { Lisp_Object w = elt(a, i); if (w != SPID_NOPROP) { push(a); #ifdef COMMON r = list2star(elt(fastget_names, i), w, r); #else r = acons(elt(fastget_names, i), w, r); #endif pop(a); errexit(); } } return onevalue(r); } #ifndef NO_BYTECOUNT /* * Unless NO_BYTECOUNT is set I keep two sorts of counts - first * ones that show how many bytecodes are executed in each separate * piece of code that the user runs. These can be inspected by * calling MAPSTORE. Then ones that show (overall) which particular * byte opcodes are most heavily used. This information is displayed * when you call BYTECOUNTS. */ extern int profile_count_mode; #define OPCOUNT (profile_count_mode ? 1 : opcodes) #if !defined DEMO_MODE && !defined DEMO_BUILD #include "opnames.c" #endif static int32_t total = 0, frequencies[256]; #endif Lisp_Object MS_CDECL bytecounts(Lisp_Object nil, int nargs, ...) { int32_t i; #ifdef RECORD_GET int32_t size; Lisp_Object v; double tot; #endif argcheck(nargs, 0, "bytecounts"); #ifdef NO_BYTECOUNT i = 0; trace_printf("bytecode statistics not available\n"); #else #if defined DEMO_MODE || defined DEMO_BUILD i = 0; trace_printf("bytecode statistics not available in demo version\n"); #else trace_printf("\nFrequencies of each bytecode (%ld total)", total); if (total == 0) total = 1; for (i=0; i<256; i++) { if ((i & 3) == 0) trace_printf("\n"); trace_printf("%-9.9s%7.4f ", opnames[i], 100.0*(double)frequencies[i]/(double)total); } trace_printf("\n"); #endif #endif #ifdef RECORD_GET v = elt(get_counts, 4); if (v == nil) return onevalue(nil); size = length_of_header(vechdr(v)); size = (size - CELL)/CELL; term_printf("\n %%SCORE TOTAL NOTFOUND INDICATOR-NAME\n"); tot = 0.0; for (i=1; i<size; i+=2) { Lisp_Object key = elt(v, i), val = elt(v, i+1); int32_t yes, no; if (key == SPID_HASH0 || key == SPID_HASH1) continue; yes = no = 0; if (consp(val)) yes = int_of_fixnum(qcar(val)), no = int_of_fixnum(qcdr(val)); tot += (double)(yes+2*no); } tot /= 100.0; for (i=1; i<size; i+=2) { Lisp_Object key = elt(v, i), val = elt(v, i+1); int32_t yes, no; if (key == SPID_HASH0 || key == SPID_HASH1) continue; yes = no = 0; if (consp(val)) yes = int_of_fixnum(qcar(val)), no = int_of_fixnum(qcdr(val)); trace_printf("%7.2f %10d %10d ", (double)(yes+2*no)/tot, yes+no, no); errexit(); loop_print_trace(key); trace_printf("\n"); } v = Lmkhash(nil, 3, fixnum_of_int(5), fixnum_of_int(0), nil); errexit(); get_counts = v; #endif return onevalue(nil); } Lisp_Object *C_stack; /* * Throughout most of the system I use the name "stack" as a synonym for * the external variable "C_stack", but in the main byte-code interpreter * loop I disable that mapping and use a register variable as stack * pointer, updating the extern value from time to time as necessary. * pointer, updating the extern value from time to time as necessary. It * may in fact be that current good optimising compilers make this hackery * unnecessary... */ #undef stack static int CSLerrcode; static Lisp_Object *do_freebind(Lisp_Object bvec, Lisp_Object *stack) { int32_t n, k; n = length_of_header(vechdr(bvec)); for (k=CELL; k<n; k+=CELL) { Lisp_Object v = *(Lisp_Object *)((intptr_t)bvec + k - TAG_VECTOR); push(qvalue(v)); qvalue(v) = C_nil; } /* * TAG_FBIND is a value that can NEVER occur elsewhere in the Lisp system, * and so it unambiguously marks a block of fluid bindings on that stack. */ push2(bvec, (Lisp_Object)SPID_FBIND); return stack; } static Lisp_Object *do_freerstr(Lisp_Object *stack) { Lisp_Object bv; int32_t n; popv(1); pop(bv); n = length_of_header(vechdr(bv)); while (n>CELL) { Lisp_Object v = *(Lisp_Object *)((intptr_t)bv + n - (CELL + TAG_VECTOR)); n -= CELL; pop(qvalue(v)); } return stack; } /* * If OUT_OF_LINE is defined than various fragments of code are written * as subroutines called from the main body of bytestream_interpret. * This may hurt speed a little, but reduces the size of the one huge * function in this file, and may be useful either when memory is at * a huge premium (ugh) or [more plausibly] when C compilers get very * unhappy with the bulk of the code when all written out in place. * The default case I leave (with OUT_OF_LINE undefined) is the one that * prefers a few percent speed-up to a fraction of a percent space * saving. */ #ifdef OUT_OF_LINE static Lisp_Object poll_jump_back(Lisp_Object *stack, Lisp_Object A_reg) { Lisp_Object nil = C_nil; if (--countdown < 0) deal_with_tick(); C_stack = stack; if (stack >= stacklimit) { A_reg = reclaim(A_reg, "stack", GC_STACK, 0); nil = C_nil; if (exception_pending()) return SPID_ERROR; } return A_reg; } #endif #ifdef COMMON static Lisp_Object *do_pvbind(Lisp_Object vals, Lisp_Object vars, Lisp_Object *stack) { Lisp_Object val, var, nil = C_nil; push4(nil, SPID_PVBIND, vars, vals); while (consp(vars)) { var = qcar(vars); vars = qcdr(vars); if (!symbolp(var) || var == nil) continue; push(vars); C_stack = stack; var = acons(var, qvalue(var), stack[-4]); stack = C_stack; nil = C_nil; if (exception_pending()) { popv(2); return stack; } stack[-4] = var; pop(vars); } pop2(vals, vars); while (consp(vars)) { if (consp(vals)) val = qcar(vals), vals = qcdr(vals); else val = unset_var; var = qcar(vars); if (symbolp(var) && var != nil) qvalue(var) = val; vars = qcdr(vars); } return stack; } static Lisp_Object *do_pvrestore(Lisp_Object *stack) { Lisp_Object w, nil = C_nil; popv(1); pop(w); while (w != nil) { Lisp_Object q = qcar(w); qvalue(qcar(q)) = qcdr(q); w = qcdr(w); } return stack; } #endif static Lisp_Object encapsulate_sp(Lisp_Object *sp) /* * Creates a boxed up representation of a pointer into the stack. */ { Lisp_Object w = getvector(TAG_VECTOR, TYPE_SP, 2*CELL); Lisp_Object nil; errexit(); elt(w, 0) = (Lisp_Object)sp; return w; } static void trace_print_0(Lisp_Object name, Lisp_Object *stack) { freshline_trace(); trace_printf("Tail calling "); loop_print_trace(name); trace_printf(" (no args) from "); loop_print_trace(*stack); trace_printf("\n"); } static void trace_print_1(Lisp_Object name, Lisp_Object *stack) { freshline_trace(); trace_printf("Tail calling "); loop_print_trace(name); trace_printf(" (1 arg) from "); loop_print_trace(*stack); trace_printf("\n"); trace_printf("Arg1: "); loop_print_trace(stack[-3]); trace_printf("\n"); } static void trace_print_2(Lisp_Object name, Lisp_Object *stack) { freshline_trace(); trace_printf("Tail calling "); loop_print_trace(name); trace_printf(" (2 args) from "); loop_print_trace(*stack); trace_printf("\n"); trace_printf("Arg1: "); loop_print_trace(stack[-4]); trace_printf("\nArg2: "); loop_print_trace(stack[-3]); trace_printf("\n"); } static void trace_print_3(Lisp_Object name, Lisp_Object *stack) { freshline_trace(); trace_printf("Tail calling "); loop_print_trace(name); trace_printf(" (3 args) from "); loop_print_trace(*stack); trace_printf("\n"); trace_printf("Arg1: "); loop_print_trace(stack[-5]); trace_printf("\nArg2: "); loop_print_trace(stack[-4]); trace_printf("\nArg3: "); loop_print_trace(stack[-3]); trace_printf("\n"); } #define save_pc() pc = (unsigned int)(ppc - \ (unsigned char *)data_of_bps(codevec)) #define restore_pc() ppc = (unsigned char *)data_of_bps(codevec) + pc #ifdef MEMORY_TRACE #define next_byte (cmemory_reference((intptr_t)ppc), *ppc++) #else #define next_byte *ppc++ #endif Lisp_Object bytestream_interpret(Lisp_Object code, Lisp_Object lit, Lisp_Object *entry_stack) { register unsigned char *ppc; register Lisp_Object A_reg; Lisp_Object nil = C_nil; Lisp_Object *stack = C_stack; /* * The variables above this line are by a significant margin the * most important ones for this code. It may be useful to use * 'register' declarations even with good optimising compilers, since * the structure of a bytestream interpreter can draw too much attention to * individual cases and not enough to the full outer loop. Here the most * common paths are the "switch (*ppc++)" and various of the very short * and simple opcodes that are dispatched to. */ Lisp_Object r1, r2, r3; one_args *f1; two_args *f2; n_args *f345; unsigned int fname, pc, w; int32_t n, k; unsigned char *xppc; /* * I declare all the other variables I need here up at the top of the function * since at least on some C compilers putting the declarations more locally * seems to be unexpectedly costly. In some cases moving the stack pointer * may be a pain, in others code like * { int x; ...} { int x; ... } { int x; ... } * end up allocating three stack locations (one for each instance of x) and * hence makes this function overall have much to big a stack frame. */ #ifndef NO_BYTECOUNT int32_t opcodes = 30; /* Attribute 30-bytecode overhead to entry sequence */ #endif #ifdef DEBUG /* * ffname will (at least until a garbage collection occurs) point to the * (C) string that is the name of the function being interpreted. This is * jolly useful if one is in a debugger trying to understand what has * been going on! Note that the executable code here does not use this * variable at all: it is JUST so that I have a simple "char *" variable * that a symbolic debugger can inspect to find my function name without * me having to mess about too much. */ char *ffname = &celt(qpname(elt(lit, 0)), 0); /* DEBUG */ CSL_IGNORE(ffname); #endif /* * The byte-stream interpreter here uses the lisp stack and two * special registers, called A, and B which act as a mini stack. */ #ifdef CHECK_STACK if (check_stack(ffname,__LINE__)) return aerror("stack overflow"); #endif litvec = lit; /* * The next lines are used to allow for functions with > 3 args, and for * &optional and &rest cases. Some of these need one or two bytes at the * start of the code-vector to indicate just how many arguments are * expected. In such cases the byte program-counter must start off * positioned just beyond these extra bytes. The way that a code pointer * is packed in CSL means that for garbage collection a code-pointer is * stored with bottom 4 bits '0010', and it can address to a resolution of * one word (4 bytes). However, the actual argument passed into this code * does not have to be garbage-collector safe until there is the first * chance of a garbage collection, and I exploit that to allow for 0, 1 * 2 or 3 initial information bytes. The ((code & ~3) + 2) restores * proper tagging, and (code & 3) holds an offset. */ ppc = (unsigned char *)data_of_bps(code); ppc = ppc + ((int32_t)code & 3); codevec = (Lisp_Object)(((int32_t)code & ~3) + 2); /* * I am careful to reload stack from C_stack after any * function call, to allow that the garbage collector may relocate the * whole stack region. But at present I do not protect entry_stack in * this way, so if the garbage collector moves my stack and subsequently * I take an error exit I will get in a big mess. At present the garbage * collector is not that enthusiastic, so the problem will not arise. If * I was sure it NEVER would I could avoid a few cases of "stack = C_stack" * here and speed things up by some utterly insignificant amount. */ A_reg = nil; for (;;) { #ifndef NO_BYTECOUNT opcodes++; total++; frequencies[*ppc]++; #endif /* * With at least some compilers (eg Watcom) if I cast the value obtained here * to something other than unsigned char I get worse code, because the fact * that the switch range is exactly 0-255 and my control value must be in that * range gets lost. */ switch (next_byte) { /* * I give labels for all 256 possible cases here so that a sufficiently * clever compiler can understand that there is no "default" that can possibly * be activated. */ case OP_SPARE1: case OP_SPARE2: default: /* * Here I have an unrecognised opcode - the result of a compiler error */ err_printf("\nUnrecognized opcode byte %x\n", *(ppc-1)); aerror("compiler failure"); nil = C_nil; C_stack = stack; goto error_exit; case OP_LOC0EXIT: A_reg = stack[0]; #ifdef COMMON /* * At a load of places here I set exit_count to 1 so that if I then return * it will be clear how many values are involved. As currently organized * this FAILS to set the number of values in cases like * (setq a (values 1 2 3)) * and * (cond * ((values 1 2 3))) * where in each case the 3 values shown will be (improperly) preserved. * I suspect that hardly anybody minds if too many values are occasionally * returned, and so will NOT put the overhead of extra reference to * exit_count after STORE instructions or conditional branches. */ exit_count = 1; #endif #ifndef NO_BYTECOUNT qcount(elt(litvec, 0)) += OPCOUNT; #endif C_stack = entry_stack; return A_reg; case OP_LOC1EXIT: A_reg = stack[-1]; #ifdef COMMON exit_count = 1; #endif #ifndef NO_BYTECOUNT qcount(elt(litvec, 0)) += OPCOUNT; #endif C_stack = entry_stack; return A_reg; case OP_LOC2EXIT: A_reg = stack[-2]; #ifdef COMMON exit_count = 1; #endif #ifndef NO_BYTECOUNT qcount(elt(litvec, 0)) += OPCOUNT; #endif C_stack = entry_stack; return A_reg; case OP_NILEXIT: #ifndef NO_BYTECOUNT qcount(elt(litvec, 0)) += OPCOUNT; #endif C_stack = entry_stack; return onevalue(nil); case OP_FREEBIND: stack = do_freebind(elt(litvec, next_byte), stack); continue; case OP_FREERSTR: stack = do_freerstr(stack); continue; #ifdef COMMON case OP_PVBIND: save_pc(); stack = do_pvbind(A_reg, B_reg, stack); nil = C_nil; if (exception_pending()) goto error_exit; restore_pc(); continue; case OP_PVRESTORE: stack = do_pvrestore(stack); continue; #endif case OP_STOREFREE: qvalue(elt(litvec, next_byte)) = A_reg; /* store into special var */ continue; case OP_STOREFREE1: qvalue(elt(litvec, 1)) = A_reg; continue; case OP_STOREFREE2: qvalue(elt(litvec, 2)) = A_reg; continue; case OP_STOREFREE3: qvalue(elt(litvec, 3)) = A_reg; continue; case OP_PUSHNILS: n = next_byte; for (k=0; k<n; k++) push(nil); continue; case OP_VNIL: B_reg = A_reg; A_reg = nil; #ifdef COMMON exit_count = 1; #endif continue; case OP_SWOP: r1 = B_reg; B_reg = A_reg; A_reg = r1; #ifdef COMMON exit_count = 1; #endif continue; case OP_NCONS: /* A_reg = cons(A_reg, nil); */ #ifndef OUT_OF_LINE /* NB preserves B register */ r1 = (Lisp_Object)((char *)fringe - sizeof(Cons_Cell)); qcar(r1) = A_reg; qcdr(r1) = nil; fringe = r1; if ((char *)r1 <= (char *)heaplimit) { push(B_reg); save_pc(); C_stack = stack; A_reg = reclaim((Lisp_Object)((char *)r1 + TAG_CONS), "bytecoded ncons", GC_CONS, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ restore_pc(); pop(B_reg); } else A_reg = (Lisp_Object)((char *)r1 + TAG_CONS); #else /* * What this example shows is that IN_LINE is not always such a bad deal. * Making everything safe across the potential garbage collection here * is a big mess! */ push(B_reg); save_pc(); C_stack = stack; A_reg = ncons(A_reg); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ restore_pc(); pop(B_reg); #endif #ifdef COMMON exit_count = 1; #endif continue; case OP_XCONS: /* A_reg = cons(A_reg, B_reg); */ #ifndef OUT_OF_LINE r1 = (Lisp_Object)((char *)fringe - sizeof(Cons_Cell)); qcar(r1) = A_reg; qcdr(r1) = B_reg; fringe = r1; if ((char *)r1 <= (char *)heaplimit) { save_pc(); C_stack = stack; A_reg = reclaim((Lisp_Object)((char *)r1 + TAG_CONS), "bytecoded xcons", GC_CONS, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ restore_pc(); } else A_reg = (Lisp_Object)((char *)r1 + TAG_CONS); #else save_pc(); C_stack = stack; A_reg = cons(A_reg, B_reg); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ restore_pc(); #endif #ifdef COMMON exit_count = 1; #endif continue; case OP_LIST2: /* A_reg = cons(B_reg, cons(A_reg, nil)); */ #ifndef OUT_OF_LINE r1 = (Lisp_Object)((char *)fringe - 2*sizeof(Cons_Cell)); qcar(r1) = B_reg; qcdr(r1) = (Lisp_Object)((char *)r1 + sizeof(Cons_Cell) + TAG_CONS); qcar((Lisp_Object)((char *)r1+sizeof(Cons_Cell))) = A_reg; qcdr((Lisp_Object)((char *)r1+sizeof(Cons_Cell))) = nil; fringe = r1; if ((char *)r1 <= (char *)heaplimit) { save_pc(); C_stack = stack; A_reg = reclaim((Lisp_Object)((char *)r1 + TAG_CONS), "bytecoded list2", GC_CONS, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); } else A_reg = (Lisp_Object)((char *)r1 + TAG_CONS); #else save_pc(); C_stack = stack; A_reg = list2(B_reg, A_reg); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ restore_pc(); #endif #ifdef COMMON exit_count = 1; #endif continue; case OP_ACONS: /* A_reg = acons(pop(), B_reg, A_reg); */ /* = (pop() . B) . A */ #ifndef OUT_OF_LINE r1 = (Lisp_Object)((char *)fringe - 2*sizeof(Cons_Cell)); qcar(r1) = (Lisp_Object)((char *)r1 + sizeof(Cons_Cell) + TAG_CONS); qcdr(r1) = A_reg; pop(qcar((Lisp_Object)((char *)r1+sizeof(Cons_Cell)))); qcdr((Lisp_Object)((char *)r1+sizeof(Cons_Cell))) = B_reg; fringe = r1; if ((char *)r1 <= (char *)heaplimit) { save_pc(); C_stack = stack; A_reg = reclaim((Lisp_Object)((char *)r1 + TAG_CONS), "bytecoded acons", GC_CONS, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); } else A_reg = (Lisp_Object)((char *)r1 + TAG_CONS); #else pop(r1); save_pc(); C_stack = stack; A_reg = acons(r1, B_reg, A_reg); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ restore_pc(); #endif #ifdef COMMON exit_count = 1; #endif continue; /* * For the next two opcodes the first argument to the current function * must have been an environment pointer as set up with CLOSURE. I do * not check that I have a closure object - perhaps I can excuse that by * claiming that all creation and management of encapsulated closures * will have been introduced by the compiler, which I propose to trust! * (actually as of April 2002 I think there may be bugs I need to fix...) */ case OP_LOADLEX: r1 = elt(stack[1-(int)next_byte], 0); B_reg = A_reg; w = next_byte; /* Number of levels to chain */ while (w != 0) r1 = ((Lisp_Object *)r1)[1], w--; A_reg = ((Lisp_Object *)r1)[next_byte]; #ifdef COMMON exit_count = 1; #endif continue; case OP_STORELEX: r1 = elt(stack[1-(int)next_byte], 0); w = next_byte; /* Number of levels to chain */ while (w != 0) r1 = ((Lisp_Object *)r1)[1], w--; ((Lisp_Object *)r1)[next_byte] = A_reg; continue; case OP_CLOSURE: push2(B_reg, A_reg); /* * This will be the address where the first arg of this function lives on * the stack. It provides a hook for the called function to access lexical * variables. */ w = next_byte; goto create_closure; case OP_BIGSTACK: /* LOADLOC, STORELOC, CLOSURE etc */ /* * This opcode allows me to support functions that use up to * 2047-deep stack frames using LOADLEX and STORELEX, or * up to 4095 deep if just using LOADLOC and STORELOC. I hope * that such cases are very uncommon, but examples have been * shown to me where my previous limit of 256-item frames was * inadequate. The BIGSTACK opcode is followed by a byte that * contains a few bits selecting which operation is to be * performed, plus an extension to the address byte that follows. */ w = next_byte; /* contains sub-opcode */ switch (w & 0xc0) { case 0x00: /* LOADLOC extended */ B_reg = A_reg; w = (w & 0x3f) << 8; A_reg = stack[-(int)(w + next_byte)]; #ifdef COMMON exit_count = 1; #endif continue; case 0x40: /* STORELOC extended */ w = (w & 0x3f) << 8; stack[-(int)(w + next_byte)] = A_reg; continue; case 0x80: /* CLOSURE extended */ push2(B_reg, A_reg); w = ((w & 0x3f) << 8) + next_byte; goto create_closure; case 0xc0: /* LOADLEX, STORELEX extended */ n = next_byte; k = next_byte; n = (n << 4) | (k >> 4); k = ((k & 0xf) << 8) | next_byte; r1 = elt(stack[1-n], 0); B_reg = A_reg; n = w & 0x1f; while (n != 0) r1 = ((Lisp_Object *)r1)[1], n--; if ((w & 0x20) == 0) { A_reg = ((Lisp_Object *)r1)[k]; #ifdef COMMON exit_count = 1; #endif } else ((Lisp_Object *)r1)[k] = A_reg; continue; } case OP_LIST2STAR: /* A_reg = list2!*(pop(), B_reg, A_reg); */ /* = pop() . (B . A) */ #ifndef OUT_OF_LINE r1 = (Lisp_Object)((char *)fringe - 2*sizeof(Cons_Cell)); pop(qcar(r1)); qcdr(r1) = (Lisp_Object)((char *)r1 + sizeof(Cons_Cell) + TAG_CONS); qcar((Lisp_Object)((char *)r1+sizeof(Cons_Cell))) = B_reg; qcdr((Lisp_Object)((char *)r1+sizeof(Cons_Cell))) = A_reg; fringe = r1; if ((char *)r1 <= (char *)heaplimit) { save_pc(); C_stack = stack; A_reg = reclaim((Lisp_Object)((char *)r1 + TAG_CONS), "bytecoded list2*", GC_CONS, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); } else A_reg = (Lisp_Object)((char *)r1 + TAG_CONS); #else pop(r1); save_pc(); C_stack = stack; A_reg = list2star(r1, B_reg, A_reg); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ restore_pc(); #endif #ifdef COMMON exit_count = 1; #endif continue; case OP_LIST3: /* A_reg = list3(pop(), B_reg, A_reg); */ /* = pop() . (B . (A . nil)) */ #ifndef OUT_OF_LINE r1 = (Lisp_Object)((char *)fringe - 3*sizeof(Cons_Cell)); pop(qcar(r1)); qcdr(r1) = (Lisp_Object)((char *)r1 + sizeof(Cons_Cell) + TAG_CONS); qcar((Lisp_Object)((char *)r1+sizeof(Cons_Cell))) = B_reg; qcdr((Lisp_Object)((char *)r1+sizeof(Cons_Cell))) = (Lisp_Object)((char *)r1 + 2*sizeof(Cons_Cell) + TAG_CONS); qcar((Lisp_Object)((char *)r1+2*sizeof(Cons_Cell))) = A_reg; qcdr((Lisp_Object)((char *)r1+2*sizeof(Cons_Cell))) = nil; fringe = r1; if ((char *)r1 <= (char *)heaplimit) { save_pc(); C_stack = stack; A_reg = reclaim((Lisp_Object)((char *)r1 + TAG_CONS), "bytecoded list3", GC_CONS, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); } else A_reg = (Lisp_Object)((char *)r1 + TAG_CONS); #else pop(r1); save_pc(); C_stack = stack; A_reg = list3(r1, B_reg, A_reg); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ restore_pc(); #endif #ifdef COMMON exit_count = 1; #endif continue; case OP_ADD1: if (is_fixnum(A_reg) && A_reg != fixnum_of_int(0x07ffffff)) { A_reg += 0x10; #ifdef COMMON exit_count = 1; #endif continue; } /* * I drop through in the case of floating, bignum or error arithmetic. */ save_pc(); C_stack = stack; A_reg = plus2(A_reg, fixnum_of_int(1)); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #ifdef COMMON exit_count = 1; #endif continue; case OP_PLUS2: if (is_fixnum(A_reg) && is_fixnum(B_reg)) { n = int_of_fixnum(A_reg) + int_of_fixnum(B_reg); k = n & fix_mask; if (k == 0 || k == fix_mask) { A_reg = fixnum_of_int(n); #ifdef COMMON exit_count = 1; #endif continue; } } /* * I drop through in the case of floating, bignum or error arithmetic. */ save_pc(); C_stack = stack; A_reg = plus2(B_reg, A_reg); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #ifdef COMMON exit_count = 1; #endif continue; case OP_SUB1: if (is_fixnum(A_reg) && A_reg != fixnum_of_int(~0x07ffffff)) { A_reg -= 0x10; #ifdef COMMON exit_count = 1; #endif continue; } /* * I drop through in the case of floating, bignum or error arithmetic. */ save_pc(); C_stack = stack; A_reg = plus2(A_reg, fixnum_of_int(-1)); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #ifdef COMMON exit_count = 1; #endif continue; case OP_DIFFERENCE: if (is_fixnum(A_reg) && is_fixnum(B_reg)) { n = int_of_fixnum(B_reg) - int_of_fixnum(A_reg); k = n & fix_mask; if (k == 0 || k == fix_mask) { A_reg = fixnum_of_int(n); #ifdef COMMON exit_count = 1; #endif continue; } } /* * Although computing A-B as A+(-B) is a bit clumsy here, it is only * done when there is a bignum or float involved - the important case * where everything is a small integer is handled directly in-line. */ save_pc(); push(B_reg); C_stack = stack; A_reg = negate(A_reg); stack = C_stack; pop(B_reg); C_stack = stack; nil = C_nil; if (exception_pending()) goto error_exit; A_reg = plus2(B_reg, A_reg); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #ifdef COMMON exit_count = 1; #endif continue; case OP_TIMES2: /* * I do not in-line even the integer case here, since overflow checking * is a slight mess. */ save_pc(); C_stack = stack; A_reg = times2(B_reg, A_reg); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #ifdef COMMON exit_count = 1; #endif continue; case OP_LESSP: if (is_fixnum(B_reg) && is_fixnum(A_reg)) w = B_reg < A_reg; else { save_pc(); C_stack = stack; w = lessp2(B_reg, A_reg); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); } A_reg = Lispify_predicate(w); #ifdef COMMON exit_count = 1; #endif continue; case OP_GREATERP: if (is_fixnum(B_reg) && is_fixnum(A_reg)) w = B_reg > A_reg; else { save_pc(); C_stack = stack; w = lessp2(A_reg, B_reg); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); } A_reg = Lispify_predicate(w); #ifdef COMMON exit_count = 1; #endif continue; case OP_FLAGP: /* A = flagp(B, A) */ #ifdef COMMON save_pc(); C_stack = stack; A_reg = get(B_reg, A_reg, unset_var); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); if (A_reg == unset_var) A_reg = nil; else A_reg = lisp_true; exit_count = 1; continue; #else #ifndef OUT_OF_LINE if (!symbolp(B_reg)) { #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(A_reg, NO); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif A_reg = nil; continue; } else if (symbolp(A_reg) && (n = header_fastget(qheader(A_reg))) != 0) { r1 = qfastgets(B_reg); if (r1 == nil) { #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(A_reg, NO); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif continue; } r1 = elt(r1, n-1); #ifdef RECORD_GET push(r1); save_pc(); C_stack = stack; record_get(A_reg, r1 != SPID_NOPROP); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); pop(r1); #endif if (r1 == SPID_NOPROP) A_reg = nil; else A_reg = lisp_true; continue; } else { r1 = qplist(B_reg); if (r1 == nil) { #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(A_reg, NO); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif A_reg = nil; continue; } r3 = qcar(r1); if (qcar(r3) == A_reg) { #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(A_reg, YES); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif A_reg = lisp_true; continue; } r1 = qcdr(r1); if (r1 == nil) { #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(A_reg, NO); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif A_reg = nil; continue; } r3 = qcar(r1); if (qcar(r3) == A_reg) { #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(A_reg, YES); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif A_reg = lisp_true; continue; } r2 = r1; r1 = qcdr(r1); if (r1 == nil) { #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(A_reg, NO); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif A_reg = nil; continue; } for (;;) { r3 = qcar(r1); if (qcar(r3) == A_reg) { qcdr(r2) = qcdr(r1); qcdr(r1) = qplist(B_reg); qplist(B_reg) = r1; #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(A_reg, NO); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif A_reg = lisp_true; break; } r2 = r1; r1 = qcdr(r1); if (r1 == nil) { #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(A_reg, NO); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif A_reg = nil; break; } } } continue; #else A_reg = Lflagp(nil, B_reg, A_reg); nil = C_nil; if (exception_pending()) goto error_exit; exit_count = 1; continue; #endif #endif case OP_APPLY1: save_pc(); if (is_symbol(B_reg)) /* can optimise this case, I guess */ { f1 = qfn1(B_reg); #ifdef DEBUG if (f1 == NULL) { term_printf("Illegal function\n"); my_exit(EXIT_FAILURE); } #endif push(B_reg); C_stack = stack; A_reg = f1(qenv(B_reg), A_reg); nil = C_nil; if (exception_pending()) goto stack_apply_error; stack = C_stack; popv(1); restore_pc(); continue; } push(A_reg); C_stack = stack; A_reg = apply(B_reg, 1, nil, B_reg); nil = C_nil; if (exception_pending()) goto apply_error; stack = C_stack; restore_pc(); continue; case OP_APPLY2: save_pc(); r2 = *stack; if (is_symbol(r2)) /* can optimise this case, I guess */ { f2 = qfn2(r2); #ifdef DEBUG if (f2 == NULL) { term_printf("Illegal function\n"); my_exit(EXIT_FAILURE); } #endif C_stack = stack; A_reg = f2(qenv(r2), B_reg, A_reg); nil = C_nil; if (exception_pending()) goto stack_apply_error; stack = C_stack; popv(1); restore_pc(); continue; } *stack = B_reg; push(A_reg); C_stack = stack; A_reg = apply(r2, 2, nil, r2); nil = C_nil; if (exception_pending()) goto apply_error; stack = C_stack; restore_pc(); continue; case OP_APPLY3: save_pc(); pop(r1); r2 = *stack; if (is_symbol(r2)) /* can optimise this case, I guess */ { f345 = qfnn(r2); #ifdef DEBUG if (f345 == NULL) { term_printf("Illegal function\n"); my_exit(EXIT_FAILURE); } #endif C_stack = stack; A_reg = f345(qenv(r2), 3, r1, B_reg, A_reg); nil = C_nil; if (exception_pending()) goto stack_apply_error; stack = C_stack; popv(1); restore_pc(); continue; } *stack = r1; push2(B_reg, A_reg); C_stack = stack; A_reg = apply(r2, 3, nil, r2); nil = C_nil; if (exception_pending()) goto apply_error; stack = C_stack; restore_pc(); continue; case OP_APPLY4: /* * It is not yet clear that APPLY4 is important enough to justify the * mess it would involve here... */ err_printf("\nAPPLY4 not implemented yet\n"); aerror("unfinished work in bytes1.c"); nil = C_nil; C_stack = stack; goto error_exit; #ifdef COMMON #define EQUAL cl_equal #else #define EQUAL equal #endif case OP_EQUAL: /* A = equal(B, A) */ A_reg = EQUAL(B_reg, A_reg) ? lisp_true : nil; nil = C_nil; if (exception_pending()) goto error_exit; #ifdef COMMON exit_count = 1; #endif continue; case OP_EQ: /* A = eq(B, A) */ if (A_reg == B_reg) A_reg = lisp_true; else A_reg = nil; #ifdef COMMON exit_count = 1; #endif continue; case OP_NUMBERP: /* A = numberp(A) */ A_reg = Lispify_predicate(is_number(A_reg)); #ifdef COMMON exit_count = 1; #endif continue; case OP_QGETV: /* A_reg = getv(B_reg, A_reg) */ /* * Note - this is an UNCHECKED vector access, used when carcheck(nil) has * been selected because the user prefers speed to security. This is in * here because the Reduce factoriser test uses getv VERY heavily indeed * and both use of a special opcode here and removal of the checking make * noticable differences to performance. */ A_reg = *(Lisp_Object *)( (char *)B_reg + (CELL - TAG_VECTOR) + (CELL*int_of_fixnum(A_reg))); #ifdef COMMON exit_count = 1; #endif continue; case OP_GETV: /* A_reg = getv(B_reg, A_reg) */ #ifndef OUT_OF_LINE if (!(is_vector(B_reg)) || vector_holds_binary(k = vechdr(B_reg))) { aerror1("getv", B_reg); nil = C_nil; goto error_exit; } else if (!is_fixnum(A_reg)) { aerror1("getv offset not fixnum", A_reg); nil = C_nil; goto error_exit; } k = (length_of_header(k) - CELL)/CELL; n = int_of_fixnum(A_reg); if (n < 0 || n >= k) { aerror1("getv index range", A_reg); nil = C_nil; goto error_exit; } A_reg = *(Lisp_Object *)( (char *)B_reg + (CELL - TAG_VECTOR) + CELL*int_of_fixnum(A_reg)); #else save_pc(); C_stack = stack; A_reg = Lgetv(nil, B_reg, A_reg); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ restore_pc(); #endif #ifdef COMMON exit_count = 1; #endif continue; case OP_QGETVN: /* A_reg = getv(A_reg, n) */ /* * Note - this is an UNCHECKED vector access, and only applicable to simple * vectors that hold general Lisp data. The offset is passed in the * byte stream. It is expected that it will help with code that passes * around vectors of guff and use (getv vvv 0) etc (aka svref) to * grab stuff out. */ A_reg = *(Lisp_Object *)( (char *)A_reg + (CELL - TAG_VECTOR) + (CELL*(next_byte))); #ifdef COMMON exit_count = 1; #endif continue; case OP_EQCAR: if (car_legal(B_reg) && A_reg == qcar(B_reg)) A_reg = lisp_true; else A_reg = nil; #ifdef COMMON exit_count = 1; #endif continue; case OP_LENGTH: save_pc(); C_stack = stack; A_reg = Llength(nil, A_reg); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #ifdef COMMON exit_count = 1; #endif continue; /* * The following combinations feel a little odd, but ONE of them showed up * very clearly in REDUCE tests, and adding the other few seems liable * (on sentiment, not measurement!) to make reasonable sense. */ case OP_LOC0LOC1: B_reg = stack[-0]; A_reg = stack[-1]; #ifdef COMMON exit_count = 1; #endif continue; case OP_LOC1LOC2: B_reg = stack[-1]; A_reg = stack[-2]; #ifdef COMMON exit_count = 1; #endif continue; case OP_LOC2LOC3: B_reg = stack[-2]; A_reg = stack[-3]; #ifdef COMMON exit_count = 1; #endif continue; case OP_LOC1LOC0: B_reg = stack[-1]; A_reg = stack[-0]; #ifdef COMMON exit_count = 1; #endif continue; case OP_LOC2LOC1: B_reg = stack[-2]; A_reg = stack[-1]; #ifdef COMMON exit_count = 1; #endif continue; case OP_LOC3LOC2: B_reg = stack[-3]; A_reg = stack[-2]; #ifdef COMMON exit_count = 1; #endif continue; case OP_CDRLOC0: B_reg = A_reg; A_reg = stack[-0]; if (car_legal(A_reg)) { A_reg = qcdr(A_reg); #ifdef COMMON exit_count = 1; #endif continue; } CSLerrcode = err_bad_cdr; C_stack = stack; goto error_1_A; case OP_CDRLOC1: B_reg = A_reg; A_reg = stack[-1]; if (car_legal(A_reg)) { A_reg = qcdr(A_reg); #ifdef COMMON exit_count = 1; #endif continue; } CSLerrcode = err_bad_cdr; C_stack = stack; goto error_1_A; case OP_CDRLOC2: B_reg = A_reg; A_reg = stack[-2]; if (car_legal(A_reg)) { A_reg = qcdr(A_reg); #ifdef COMMON exit_count = 1; #endif continue; } CSLerrcode = err_bad_cdr; C_stack = stack; goto error_1_A; case OP_CDRLOC3: B_reg = A_reg; A_reg = stack[-3]; if (car_legal(A_reg)) { A_reg = qcdr(A_reg); #ifdef COMMON exit_count = 1; #endif continue; } CSLerrcode = err_bad_cdr; C_stack = stack; goto error_1_A; case OP_CDRLOC4: B_reg = A_reg; A_reg = stack[-4]; if (car_legal(A_reg)) { A_reg = qcdr(A_reg); #ifdef COMMON exit_count = 1; #endif continue; } CSLerrcode = err_bad_cdr; C_stack = stack; goto error_1_A; case OP_CDRLOC5: B_reg = A_reg; A_reg = stack[-5]; if (car_legal(A_reg)) { A_reg = qcdr(A_reg); #ifdef COMMON exit_count = 1; #endif continue; } CSLerrcode = err_bad_cdr; C_stack = stack; goto error_1_A; case OP_CAARLOC0: B_reg = A_reg; A_reg = stack[-0]; goto caar; case OP_CAARLOC1: B_reg = A_reg; A_reg = stack[-1]; goto caar; case OP_CAARLOC2: B_reg = A_reg; A_reg = stack[-2]; goto caar; case OP_CAARLOC3: B_reg = A_reg; A_reg = stack[-3]; goto caar; case OP_CAAR: goto caar; case OP_CADR: if (car_legal(A_reg)) A_reg = qcdr(A_reg); else { CSLerrcode = err_bad_cdr; C_stack = stack; goto error_1_A; } if (car_legal(A_reg)) { A_reg = qcar(A_reg); #ifdef COMMON exit_count = 1; #endif continue; } CSLerrcode = err_bad_car; C_stack = stack; goto error_1_A; case OP_CDAR: if (car_legal(A_reg)) A_reg = qcar(A_reg); else { CSLerrcode = err_bad_car; C_stack = stack; goto error_1_A; } if (car_legal(A_reg)) { A_reg = qcdr(A_reg); #ifdef COMMON exit_count = 1; #endif continue; } CSLerrcode = err_bad_cdr; C_stack = stack; goto error_1_A; case OP_CDDR: if (car_legal(A_reg)) A_reg = qcdr(A_reg); else { CSLerrcode = err_bad_cdr; C_stack = stack; goto error_1_A; } if (car_legal(A_reg)) { A_reg = qcdr(A_reg); #ifdef COMMON exit_count = 1; #endif continue; } CSLerrcode = err_bad_cdr; C_stack = stack; goto error_1_A; /* * The ICASE opcode is followed by a byte (n say) that indicates the number * of cases that follow, followed by n+1 double-byte label values. * If these addresses are called L<dflt>, L<0>, L<1>, ... L<n-1> then if the * A register contains an integer in the range 0 <= k < n then control is * transferred to L<k>, while if the A register does not hold an integer or * if its value is out of range then control goes to L<dflt>. */ case OP_ICASE: w = next_byte; if (is_fixnum(A_reg) && (n = int_of_fixnum(A_reg)) >= 0 && n < (int)w) ppc += 2*n + 2; w = next_byte; /* * I support backwards jumps here by setting their top bit. At present I do * poll for interrupts on a backwards case-branch. And the encoding used means * that case branches can not reach quite as far as regular jumps. */ if (w & 0x80) ppc = ppc - (((w & 0x7f) << 8) + *ppc); else ppc = ppc + (w << 8) + *ppc; continue; /* * There are a bunch of special-case jumps here - they are only * provided with the variants that jump forwards by small offsets, * but are expected to pick up a useful number of cases (for both speed and * compactness) all the same. */ case OP_JUMPL0NIL: xppc = ppc; ppc++; if (stack[0] == nil) ppc = ppc + *xppc; continue; case OP_JUMPL0T: xppc = ppc; ppc++; if (stack[0] != nil) ppc = ppc + *xppc; continue; case OP_JUMPL1NIL: xppc = ppc; ppc++; if (stack[-1] == nil) ppc = ppc + *xppc; continue; case OP_JUMPL1T: xppc = ppc; ppc++; if (stack[-1] != nil) ppc = ppc + *xppc; continue; case OP_JUMPL2NIL: xppc = ppc; ppc++; if (stack[-2] == nil) ppc = ppc + *xppc; continue; case OP_JUMPL2T: xppc = ppc; ppc++; if (stack[-2] != nil) ppc = ppc + *xppc; continue; case OP_JUMPL3NIL: xppc = ppc; ppc++; if (stack[-3] == nil) ppc = ppc + *xppc; continue; case OP_JUMPL3T: xppc = ppc; ppc++; if (stack[-3] != nil) ppc = ppc + *xppc; continue; case OP_JUMPL4NIL: xppc = ppc; ppc++; if (stack[-4] == nil) ppc = ppc + *xppc; continue; case OP_JUMPL4T: xppc = ppc; ppc++; if (stack[-4] != nil) ppc = ppc + *xppc; continue; case OP_JUMPL0ATOM: xppc = ppc; ppc++; if (!consp(stack[0])) ppc = ppc + *xppc; continue; case OP_JUMPL0NATOM: xppc = ppc; ppc++; if (consp(stack[0])) ppc = ppc + *xppc; continue; case OP_JUMPL1ATOM: xppc = ppc; ppc++; if (!consp(stack[-1])) ppc = ppc + *xppc; continue; case OP_JUMPL1NATOM: xppc = ppc; ppc++; if (consp(stack[-1])) ppc = ppc + *xppc; continue; case OP_JUMPL2ATOM: xppc = ppc; ppc++; if (!consp(stack[-2])) ppc = ppc + *xppc; continue; case OP_JUMPL2NATOM: xppc = ppc; ppc++; if (consp(stack[-2])) ppc = ppc + *xppc; continue; case OP_JUMPL3ATOM: xppc = ppc; ppc++; if (!consp(stack[-3])) ppc = ppc + *xppc; continue; case OP_JUMPL3NATOM: xppc = ppc; ppc++; if (consp(stack[-3])) ppc = ppc + *xppc; continue; case OP_JUMPST0NIL: xppc = ppc; ppc++; if ((stack[0] = A_reg) == nil) ppc = ppc + *xppc; continue; case OP_JUMPST0T: xppc = ppc; ppc++; if ((stack[0] = A_reg) != nil) ppc = ppc + *xppc; continue; case OP_JUMPST1NIL: xppc = ppc; ppc++; if ((stack[-1] = A_reg) == nil) ppc = ppc + *xppc; continue; case OP_JUMPST1T: xppc = ppc; ppc++; if ((stack[-1] = A_reg) != nil) ppc = ppc + *xppc; continue; case OP_JUMPST2NIL: xppc = ppc; ppc++; if ((stack[-2] = A_reg) == nil) ppc = ppc + *xppc; continue; case OP_JUMPST2T: xppc = ppc; ppc++; if ((stack[-2] = A_reg) != nil) ppc = ppc + *xppc; continue; case OP_JUMPFREE1NIL: xppc = ppc; ppc++; if (qvalue(elt(litvec, 1)) == nil) ppc = ppc + *xppc; continue; case OP_JUMPFREE1T: xppc = ppc; ppc++; if (qvalue(elt(litvec, 1)) != nil) ppc = ppc + *xppc; continue; case OP_JUMPFREE2NIL: xppc = ppc; ppc++; if (qvalue(elt(litvec, 2)) == nil) ppc = ppc + *xppc; continue; case OP_JUMPFREE2T: xppc = ppc; ppc++; if (qvalue(elt(litvec, 2)) != nil) ppc = ppc + *xppc; continue; case OP_JUMPFREE3NIL: xppc = ppc; ppc++; if (qvalue(elt(litvec, 3)) == nil) ppc = ppc + *xppc; continue; case OP_JUMPFREE3T: xppc = ppc; ppc++; if (qvalue(elt(litvec, 3)) != nil) ppc = ppc + *xppc; continue; case OP_JUMPFREE4NIL: xppc = ppc; ppc++; if (qvalue(elt(litvec, 4)) == nil) ppc = ppc + *xppc; continue; case OP_JUMPFREE4T: xppc = ppc; ppc++; if (qvalue(elt(litvec, 4)) != nil) ppc = ppc + *xppc; continue; case OP_JUMPLIT1EQ: xppc = ppc; ppc++; if (elt(litvec, 1) == A_reg) ppc = ppc + *xppc; continue; case OP_JUMPLIT1NE: xppc = ppc; ppc++; if (elt(litvec, 1) != A_reg) ppc = ppc + *xppc; continue; case OP_JUMPLIT2EQ: xppc = ppc; ppc++; if (elt(litvec, 2) == A_reg) ppc = ppc + *xppc; continue; case OP_JUMPLIT2NE: xppc = ppc; ppc++; if (elt(litvec, 2) != A_reg) ppc = ppc + *xppc; continue; case OP_JUMPLIT3EQ: xppc = ppc; ppc++; if (elt(litvec, 3) == A_reg) ppc = ppc + *xppc; continue; case OP_JUMPLIT3NE: xppc = ppc; ppc++; if (elt(litvec, 3) != A_reg) ppc = ppc + *xppc; continue; case OP_JUMPLIT4EQ: xppc = ppc; ppc++; if (elt(litvec, 4) == A_reg) ppc = ppc + *xppc; continue; case OP_JUMPLIT4NE: xppc = ppc; ppc++; if (elt(litvec, 4) != A_reg) ppc = ppc + *xppc; continue; case OP_JUMPFREENIL: w = next_byte; xppc = ppc; ppc++; if (qvalue(elt(litvec, w)) == nil) ppc = ppc + *xppc; continue; case OP_JUMPFREET: w = next_byte; xppc = ppc; ppc++; if (qvalue(elt(litvec, w)) != nil) ppc = ppc + *xppc; continue; case OP_JUMPLITEQ: w = next_byte; xppc = ppc; ppc++; if (elt(litvec, w) == A_reg) ppc = ppc + *xppc; continue; case OP_JUMPLITNE: w = next_byte; xppc = ppc; ppc++; if (elt(litvec, w) != A_reg) ppc = ppc + *xppc; continue; case OP_JUMPB1NIL: f1 = one_arg_functions[next_byte]; save_pc(); C_stack = stack; A_reg = f1(nil, A_reg); nil = C_nil; if (exception_pending()) goto call_error_exit; stack = C_stack; restore_pc(); xppc = ppc; ppc++; if (A_reg == nil) ppc = ppc + *xppc; continue; case OP_JUMPB1T: f1 = one_arg_functions[next_byte]; save_pc(); C_stack = stack; A_reg = f1(nil, A_reg); nil = C_nil; if (exception_pending()) goto call_error_exit; stack = C_stack; restore_pc(); xppc = ppc; ppc++; if (A_reg != nil) ppc = ppc + *xppc; continue; case OP_JUMPB2NIL: f2 = two_arg_functions[next_byte]; save_pc(); C_stack = stack; A_reg = f2(nil, B_reg, A_reg); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); xppc = ppc; ppc++; if (A_reg == nil) ppc = ppc + *xppc; continue; case OP_JUMPB2T: f2 = two_arg_functions[next_byte]; save_pc(); C_stack = stack; A_reg = f2(nil, B_reg, A_reg); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); xppc = ppc; ppc++; if (A_reg != nil) ppc = ppc + *xppc; continue; case OP_JUMPEQCAR: /* jump if eqcar(A, <some literal>) */ w = next_byte; xppc = ppc; ppc++; if (car_legal(A_reg) && elt(litvec, w) == qcar(A_reg)) ppc = ppc + *xppc; continue; case OP_JUMPNEQCAR: w = next_byte; xppc = ppc; ppc++; if (!car_legal(A_reg) || elt(litvec, w) != qcar(A_reg)) ppc = ppc + *xppc; continue; case OP_JUMPFLAGP: w = next_byte; xppc = ppc; ppc++; if (!symbolp(A_reg)) continue; else #ifdef COMMON { save_pc(); C_stack = stack; r1 = get(A_reg, elt(litvec, w), unset_var); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); if (r1 != unset_var) ppc = ppc + *xppc; continue; } #else #ifndef OUT_OF_LINE B_reg = elt(litvec, w); if (symbolp(B_reg) && (n = header_fastget(qheader(B_reg))) != 0) { r1 = qfastgets(A_reg); if (r1 == nil) { #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(B_reg, NO); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif continue; } r1 = elt(r1, n-1); #ifdef RECORD_GET push(r1); save_pc(); C_stack = stack; record_get(B_reg, r1 != SPID_NOPROP); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); pop(r1); #endif if (r1 != SPID_NOPROP) ppc = ppc + *xppc; continue; } r1 = qplist(A_reg); if (r1 == nil) { #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(B_reg, NO); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif continue; } r3 = qcar(r1); if (qcar(r3) == B_reg) { ppc = ppc + *xppc; #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(B_reg, YES); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif continue; } r1 = qcdr(r1); if (r1 == nil) { #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(B_reg, NO); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif continue; } r3 = qcar(r1); if (qcar(r3) == B_reg) { ppc = ppc + *xppc; #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(B_reg, YES); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif continue; } r2 = r1; r1 = qcdr(r1); if (r1 == nil) { #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(B_reg, NO); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif continue; } for (;;) { r3 = qcar(r1); if (qcar(r3) == B_reg) { qcdr(r2) = qcdr(r1); qcdr(r1) = qplist(A_reg); qplist(A_reg) = r1; ppc = ppc + *xppc; #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(B_reg, YES); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif break; } r2 = r1; r1 = qcdr(r1); if (r1 == nil) { #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(B_reg, NO); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif break; } } continue; #else r1 = Lflagp(nil, A_reg, elt(litvec, w)); nil = C_nil; if (exception_pending()) goto error_exit; if (r1 != nil) ppc = ppc + *xppc; continue; #endif #endif case OP_JUMPNFLAGP: w = next_byte; xppc = ppc; ppc++; if (!symbolp(A_reg)) { ppc = ppc + *xppc; continue; } else #ifdef COMMON { save_pc(); C_stack = stack; r1 = get(A_reg, elt(litvec, w), unset_var); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); if (r1 == unset_var) ppc = ppc + *xppc; continue; } #else #ifndef OUT_OF_LINE B_reg = elt(litvec, w); if (symbolp(B_reg) && (n = header_fastget(qheader(B_reg))) != 0) { r1 = qfastgets(A_reg); if (r1 == nil) { #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(B_reg, NO); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif ppc = ppc + *xppc; continue; } r1 = elt(r1, n-1); #ifdef RECORD_GET push(r1); save_pc(); C_stack = stack; record_get(B_reg, r1 != SPID_NOPROP); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); pop(r1); #endif if (r1 == SPID_NOPROP) ppc = ppc + *xppc; continue; } r1 = qplist(A_reg); if (r1 == nil) { ppc = ppc + *xppc; #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(B_reg, NO); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif continue; } r3 = qcar(r1); if (qcar(r3) == B_reg) { #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(B_reg, YES); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif continue; } r1 = qcdr(r1); if (r1 == nil) { ppc = ppc + *xppc; #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(B_reg, NO); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif continue; } r3 = qcar(r1); if (qcar(r3) == B_reg) { #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(B_reg, YES); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif continue; } r2 = r1; r1 = qcdr(r1); if (r1 == nil) { ppc = ppc + *xppc; #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(B_reg, NO); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif continue; } for (;;) { r3 = qcar(r1); if (qcar(r3) == B_reg) { qcdr(r2) = qcdr(r1); qcdr(r1) = qplist(A_reg); qplist(A_reg) = r1; #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(B_reg, YES); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif break; } r2 = r1; r1 = qcdr(r1); if (r1 == nil) { ppc = ppc + *xppc; #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(B_reg, NO); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif break; } } continue; #else r1 = Lflagp(nil, A_reg, elt(litvec, w)); nil = C_nil; if (exception_pending()) goto error_exit; if (r1 == nil) ppc = ppc + *xppc; continue; #endif #endif /* * Now the general jumps. Each has four variants - forwards and backwards * and long and short offsets. Backwards jumps poll for interrupts so that * all loops will be interruptible. */ case OP_JUMPATOM: xppc = ppc; ppc++; if (!consp(A_reg)) ppc = ppc + *xppc; continue; case OP_JUMPATOM_B: xppc = ppc; ppc++; if (!consp(A_reg)) { ppc = ppc - *xppc; #ifndef OUT_OF_LINE if (--countdown < 0) deal_with_tick(); if (stack >= stacklimit) { C_stack = stack; A_reg = reclaim(A_reg, "stack", GC_STACK, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ } #else if ((A_reg = poll_jump_back(stack, A_reg)) == SPID_ERROR) goto error_exit; stack = C_stack; #endif } continue; case OP_JUMPNATOM: xppc = ppc; ppc++; if (consp(A_reg)) ppc = ppc + *xppc; continue; case OP_JUMPNATOM_B: xppc = ppc; ppc++; if (consp(A_reg)) { ppc = ppc - *xppc; #ifndef OUT_OF_LINE if (--countdown < 0) deal_with_tick(); if (stack >= stacklimit) { C_stack = stack; A_reg = reclaim(A_reg, "stack", GC_STACK, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ } #else if ((A_reg = poll_jump_back(stack, A_reg)) == SPID_ERROR) goto error_exit; stack = C_stack; #endif } continue; case OP_JUMPEQ: xppc = ppc; ppc++; if (A_reg == B_reg) ppc = ppc + *xppc; continue; case OP_JUMPEQ_B: xppc = ppc; ppc++; if (A_reg == B_reg) { ppc = ppc - *xppc; #ifndef OUT_OF_LINE if (--countdown < 0) deal_with_tick(); if (stack >= stacklimit) { C_stack = stack; A_reg = reclaim(A_reg, "stack", GC_STACK, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ } #else if ((A_reg = poll_jump_back(stack, A_reg)) == SPID_ERROR) goto error_exit; stack = C_stack; #endif } continue; case OP_JUMPNE: xppc = ppc; ppc++; if (A_reg != B_reg) ppc = ppc + *xppc; continue; case OP_JUMPNE_B: xppc = ppc; ppc++; if (A_reg != B_reg) { ppc = ppc - *xppc; #ifndef OUT_OF_LINE if (--countdown < 0) deal_with_tick(); if (stack >= stacklimit) { C_stack = stack; A_reg = reclaim(A_reg, "stack", GC_STACK, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ } #else if ((A_reg = poll_jump_back(stack, A_reg)) == SPID_ERROR) goto error_exit; stack = C_stack; #endif } continue; case OP_JUMPEQUAL: xppc = ppc; ppc++; if (EQUAL(A_reg, B_reg)) ppc = ppc + *xppc; continue; case OP_JUMPEQUAL_B: xppc = ppc; ppc++; if (EQUAL(A_reg, B_reg)) { ppc = ppc - *xppc; #ifndef OUT_OF_LINE if (--countdown < 0) deal_with_tick(); if (stack >= stacklimit) { C_stack = stack; A_reg = reclaim(A_reg, "stack", GC_STACK, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ } #else if ((A_reg = poll_jump_back(stack, A_reg)) == SPID_ERROR) goto error_exit; stack = C_stack; #endif } continue; case OP_JUMPNEQUAL: xppc = ppc; ppc++; if (!EQUAL(A_reg, B_reg)) ppc = ppc + *xppc; continue; case OP_JUMPNEQUAL_B: xppc = ppc; ppc++; if (!EQUAL(A_reg, B_reg)) { ppc = ppc - *xppc; #ifndef OUT_OF_LINE if (--countdown < 0) deal_with_tick(); if (stack >= stacklimit) { C_stack = stack; A_reg = reclaim(A_reg, "stack", GC_STACK, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ } #else if ((A_reg = poll_jump_back(stack, A_reg)) == SPID_ERROR) goto error_exit; stack = C_stack; #endif } continue; case OP_JUMP: ppc = ppc + *ppc + 1; continue; case OP_JUMP_B: ppc = ppc - *ppc + 1; #ifndef OUT_OF_LINE if (--countdown < 0) deal_with_tick(); if (stack >= stacklimit) { C_stack = stack; A_reg = reclaim(A_reg, "stack", GC_STACK, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ } #else if ((A_reg = poll_jump_back(stack, A_reg)) == SPID_ERROR) goto error_exit; stack = C_stack; #endif continue; case OP_JUMPATOM_L: w = next_byte; xppc = ppc; ppc++; if (!consp(A_reg)) ppc = ppc + ((w << 8) + *xppc); continue; case OP_JUMPATOM_BL: w = next_byte; xppc = ppc; ppc++; if (!consp(A_reg)) { ppc = ppc - ((w << 8) + *xppc); #ifndef OUT_OF_LINE if (--countdown < 0) deal_with_tick(); if (stack >= stacklimit) { C_stack = stack; A_reg = reclaim(A_reg, "stack", GC_STACK, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ } #else if ((A_reg = poll_jump_back(stack, A_reg)) == SPID_ERROR) goto error_exit; stack = C_stack; #endif } continue; case OP_JUMPNATOM_L: w = next_byte; xppc = ppc; ppc++; if (consp(A_reg)) ppc = ppc + ((w << 8) + *xppc); continue; case OP_JUMPNATOM_BL: w = next_byte; xppc = ppc; ppc++; if (consp(A_reg)) { ppc = ppc - ((w << 8) + *xppc); #ifndef OUT_OF_LINE if (--countdown < 0) deal_with_tick(); if (stack >= stacklimit) { C_stack = stack; A_reg = reclaim(A_reg, "stack", GC_STACK, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ } #else if ((A_reg = poll_jump_back(stack, A_reg)) == SPID_ERROR) goto error_exit; stack = C_stack; #endif } continue; case OP_JUMPEQ_L: w = next_byte; xppc = ppc; ppc++; if (A_reg == B_reg) ppc = ppc + ((w << 8) + *xppc); continue; case OP_JUMPEQ_BL: w = next_byte; xppc = ppc; ppc++; if (A_reg == B_reg) { ppc = ppc - ((w << 8) + *xppc); #ifndef OUT_OF_LINE if (--countdown < 0) deal_with_tick(); if (stack >= stacklimit) { C_stack = stack; A_reg = reclaim(A_reg, "stack", GC_STACK, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ } #else if ((A_reg = poll_jump_back(stack, A_reg)) == SPID_ERROR) goto error_exit; stack = C_stack; #endif } continue; case OP_JUMPNE_L: w = next_byte; xppc = ppc; ppc++; if (A_reg != B_reg) ppc = ppc + ((w << 8) + *xppc); continue; case OP_JUMPNE_BL: w = next_byte; xppc = ppc; ppc++; if (A_reg != B_reg) { ppc = ppc - ((w << 8) + *xppc); #ifndef OUT_OF_LINE if (--countdown < 0) deal_with_tick(); if (stack >= stacklimit) { C_stack = stack; A_reg = reclaim(A_reg, "stack", GC_STACK, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ } #else if ((A_reg = poll_jump_back(stack, A_reg)) == SPID_ERROR) goto error_exit; stack = C_stack; #endif } continue; case OP_JUMPEQUAL_L: w = next_byte; xppc = ppc; ppc++; if (EQUAL(A_reg, B_reg)) ppc = ppc + ((w << 8) + *xppc); continue; case OP_JUMPEQUAL_BL: w = next_byte; xppc = ppc; ppc++; if (EQUAL(A_reg, B_reg)) { ppc = ppc - ((w << 8) + *xppc); #ifndef OUT_OF_LINE if (--countdown < 0) deal_with_tick(); if (stack >= stacklimit) { C_stack = stack; A_reg = reclaim(A_reg, "stack", GC_STACK, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ } #else if ((A_reg = poll_jump_back(stack, A_reg)) == SPID_ERROR) goto error_exit; stack = C_stack; #endif } continue; case OP_JUMPNEQUAL_L: w = next_byte; xppc = ppc; ppc++; if (!EQUAL(A_reg, B_reg)) ppc = ppc + ((w << 8) + *xppc); continue; case OP_JUMPNEQUAL_BL: w = next_byte; xppc = ppc; ppc++; if (!EQUAL(A_reg, B_reg)) { ppc = ppc - ((w << 8) + *xppc); #ifndef OUT_OF_LINE if (--countdown < 0) deal_with_tick(); if (stack >= stacklimit) { C_stack = stack; A_reg = reclaim(A_reg, "stack", GC_STACK, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ } #else if ((A_reg = poll_jump_back(stack, A_reg)) == SPID_ERROR) goto error_exit; stack = C_stack; #endif } continue; case OP_JUMP_L: w = next_byte; ppc = ppc + ((w << 8) + *ppc) + 1; continue; case OP_JUMP_BL: w = next_byte; ppc = ppc - ((w << 8) + *ppc) + 1; #ifndef OUT_OF_LINE if (--countdown < 0) deal_with_tick(); if (stack >= stacklimit) { C_stack = stack; A_reg = reclaim(A_reg, "stack", GC_STACK, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ } #else if ((A_reg = poll_jump_back(stack, A_reg)) == SPID_ERROR) goto error_exit; stack = C_stack; #endif continue; case OP_CATCH: w = (unsigned int)((ppc + *ppc) - (unsigned char *)data_of_bps(codevec)); ppc++; goto catcher; case OP_CATCH_B: w = (unsigned int)((ppc - *ppc) - (unsigned char *)data_of_bps(codevec)); ppc++; goto catcher; case OP_CATCH_L: w = next_byte; w = (unsigned int)((ppc + (w << 8) + *ppc) - (unsigned char *)data_of_bps(codevec)); ppc++; goto catcher; case OP_CATCH_BL: w = next_byte; w = (unsigned int)((ppc - ((w << 8) + *ppc)) - (unsigned char *)data_of_bps(codevec)); ppc++; goto catcher; case OP_UNCATCH: popv(1); pop(r1); popv(1); catch_tags = qcdr(r1); qcar(r1) = r1; qcdr(r1) = nil; continue; case OP_PROTECT: /* * This is used to support UNWIND-PROTECT. * This needs to save A_reg, all the multiple-result registers, * and the exit_count. Also something to indicate that there had not been * an error. */ popv(3); #ifdef COMMON A_reg = Lmv_list(nil, A_reg); nil = C_nil; if (exception_pending()) goto error_exit; #endif push3(nil, fixnum_of_int(UNWIND_NULL), A_reg); continue; case OP_UNPROTECT: /* * This must restore all the results (including exit_count). If the * PROTECT had been done by an unwinding then exit_reason and exit_tag * must also be restored, and the unwind condition must be re-instated. */ pop3(A_reg, B_reg, exit_tag); exit_reason = int_of_fixnum(B_reg); #ifdef COMMON /* * Here I have multiple values to restore. */ exit_count = 0; B_reg = A_reg; A_reg = nil; if (consp(B_reg)) { A_reg = qcar(B_reg); B_reg = qcdr(B_reg); exit_count++; while (consp(B_reg)) { (&mv_1)[exit_count++] = qcar(B_reg); B_reg = qcdr(B_reg); } } #endif exit_value = A_reg; if (exit_reason != UNWIND_NULL) goto pop_stack_and_exit; continue; case OP_THROW: pop(r1); /* the tag to throw to */ for (r2 = catch_tags; r2!=nil; r2=qcdr(r2)) if (r1 == qcar(r2)) break; if (r2==nil) { aerror1("throw: tag not found", r1); nil = C_nil; goto error_exit; } catch_tags = qcdr(r2); exit_tag = r2; exit_value = A_reg; exit_reason = UNWIND_THROW; flip_exception(); /* * NOTE WELL: this means that at error_exit (after all the possible cases * where something I call returns with NIL marked) it is essential to check * for THROW as well as just error returns. */ goto error_exit; /* * I expect that calling functions with 0, 1, 2 or 3 arguments will * be enormously important for Lisp, and so separate opcodes are provided * for these cases. The operand in each case selects the function to be * called, which MUST be a symbol (loaded from the literal vector), * and arguments are taken from A and B as necessary. If several * arguments are needed the first argument will be loaded first, and thus * it is the LAST argument that end up in the A register. */ case OP_CALL0_0: /* Calling myself... */ fname = 0; goto call0; case OP_CALL0_1: fname = 1; goto call0; case OP_CALL0_2: fname = 2; goto call0; case OP_CALL0_3: fname = 3; goto call0; case OP_CALL0: fname = next_byte; goto call0; case OP_JCALL: /* * This version has the number of args and the target packed into a * single operand byte. JCALLN is functionally similar but allows * for more extreme cases by using one byte to specify the target * and another to give the number of arguments being passed. */ w = next_byte; fname = w & 0x1f; w = (w >> 5) & 0x7; switch (w) { case 0: goto jcall0; case 1: goto jcall1; case 2: goto jcall2; case 3: goto jcall3; default:goto jcalln; } case OP_JCALLN: fname = next_byte; w = next_byte; switch (w) { case 0: goto jcall0; case 1: goto jcall1; case 2: goto jcall2; case 3: goto jcall3; default:goto jcalln; } case OP_BIGCALL: /* * This provides for calls (and a few other operations!) where the literal * to be referenced is beyond position 256 in the literal vector. The * encoding is that BIGCALL is followed by two bytes. The top half of the * first of these is a sub opcode, while the remaining 12 bits provide * support for literal vectors with up to 4096 elements. At present I * will just not support code bigger than that. Note that if I were feeling * keen here I could easily arrange that the 12-bit offset here started at * 256 and went on upwards. But for simplicity in a first version I will * leave a bit of redundancy. */ w = next_byte; fname = next_byte + ((w & 0xf) << 8); switch (w >> 4) { case 0: goto call0; case 1: goto call1; case 2: goto call2; case 3: goto call3; case 4: /* * Here I write out a variant on the CALLN code. */ push2(B_reg, A_reg); save_pc(); C_stack = stack; A_reg = elt(litvec, fname); A_reg = apply(A_reg, (int)(*ppc), nil, A_reg); nil = C_nil; if (exception_pending()) goto ncall_error_exit; stack = C_stack; /* args were popped by apply */ restore_pc(); ppc++; continue; case 5: goto call2r; /* * sub-opcodes 6 and 7 are use for LOADFREE and STOREFREE - this is a bit * odd but fits the required operations tightly into the opcode map. */ case 6: B_reg = A_reg; A_reg = qvalue(elt(litvec, fname)); #ifdef COMMON exit_count = 1; #endif continue; case 7: qvalue(elt(litvec, fname)) = A_reg; /* store into special var */ continue; case 8: goto jcall0; case 9: goto jcall1; case 10:goto jcall2; case 11:goto jcall3; /* The codes for big JCALLs take a further byte that give the number of args */ case 12:w = next_byte; goto jcalln; /* * Codes 13 and 14 do FREEBIND and LITGET, which completes the list of * byte operations that access big literals. */ case 13:stack = do_freebind(elt(litvec, fname), stack); continue; case 14:B_reg = A_reg; A_reg = elt(litvec, fname); goto perform_get; /* * Code 15 is LOADLIT with a long offset, which may be used as an alternative * to the LOADLIT/QGETVN mechanism that I otherwise support. */ case 15:B_reg = A_reg; A_reg = elt(litvec, fname); #ifdef COMMON exit_count = 1; #endif continue; } case OP_CALL1_0: /* * Note that this is spotted and treated as a direct call to the * current function (because offset zero in the literal vector is reserved * for the name of the function). I can NOT avoid the overhead of stacking * and restoring codevec and litvec here, even the values used in the called * function are the same as the present ones, because the lower level call * might itself do a JCALL and corrupt them! Also I know that the current * function is bytecoded, so I avoid the overhead of (re-)discovering that. */ push3(codevec, litvec, A_reg); /* the argument */ save_pc(); C_stack = stack; if (--countdown < 0) deal_with_tick(); if (stack >= stacklimit) { reclaim(nil, "stack", GC_STACK, 0); nil = C_nil; if (exception_pending()) goto callself_error_exit; } A_reg = bytestream_interpret(codevec-2, litvec, stack-1); nil = C_nil; if (exception_pending()) goto callself_error_exit; stack = C_stack; pop2(litvec, codevec); restore_pc(); continue; case OP_CALL1_1: fname = 1; goto call1; case OP_CALL1_2: fname = 2; goto call1; case OP_CALL1_3: fname = 3; goto call1; case OP_CALL1_4: fname = 4; goto call1; case OP_CALL1_5: fname = 5; goto call1; case OP_CALL1: fname = next_byte; goto call1; case OP_CALL2_0: push4(codevec, litvec, B_reg, A_reg); save_pc(); C_stack = stack; if (--countdown < 0) deal_with_tick(); if (stack >= stacklimit) { reclaim(nil, "stack", GC_STACK, 0); nil = C_nil; if (exception_pending()) goto callself_error_exit; } A_reg = bytestream_interpret(codevec-2, litvec, stack-2); nil = C_nil; if (exception_pending()) goto callself_error_exit; stack = C_stack; pop2(litvec, codevec); restore_pc(); continue; case OP_CALL2_1: fname = 1; goto call2; case OP_CALL2_2: fname = 2; goto call2; case OP_CALL2_3: fname = 3; goto call2; case OP_CALL2_4: fname = 4; goto call2; case OP_CALL2: fname = next_byte; goto call2; case OP_CALL2R: fname = next_byte; goto call2r; case OP_CALL3: fname = next_byte; goto call3; case OP_CALLN: /* * Here the first post-byte indicates the function to be called, * and the second is the number of args (>= 4) to be passed. All but the * last two args have been pushed onto the stack already. The last two are * in A and B. */ push2(B_reg, A_reg); save_pc(); C_stack = stack; A_reg = elt(litvec, *ppc); /* * Note that I never need to call something with 0, 1, 2 or 3 args here. */ A_reg = apply(A_reg, (int)(*(ppc+1)), nil, A_reg); nil = C_nil; if (exception_pending()) goto ncall_error_exit; stack = C_stack; /* args were popped by apply */ restore_pc(); ppc = ppc + 2; continue; case OP_BUILTIN0: f345 = zero_arg_functions[next_byte]; /* BUILTIN0: A=fn() */ save_pc(); C_stack = stack; A_reg = f345(nil, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); continue; case OP_BUILTIN2R: f2 = two_arg_functions[next_byte]; /* BUILTIN2R: A=fn(A,B); NOTE arg order reversed */ save_pc(); C_stack = stack; A_reg = f2(nil, A_reg, B_reg); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); continue; case OP_BUILTIN3: f345 = three_arg_functions[next_byte]; /* CALL3: A=fn(pop(),B,A); */ save_pc(); pop(r1); C_stack = stack; A_reg = f345(nil, 3, r1, B_reg, A_reg); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); continue; /* * Now here in a neat block I will have the cases that seem to occur most * frequently, at least when I tested things running REDUCE. By collecting * these together I hope to (slightly) improve the cache locality behaviour * for this code - maybe... */ case OP_LOADLOC: B_reg = A_reg; A_reg = stack[-(int)next_byte]; #ifdef COMMON exit_count = 1; #endif continue; case OP_LOADLOC0: B_reg = A_reg; A_reg = stack[-0]; #ifdef COMMON exit_count = 1; #endif continue; case OP_LOADLOC1: B_reg = A_reg; A_reg = stack[-1]; #ifdef COMMON exit_count = 1; #endif continue; case OP_LOADLOC2: B_reg = A_reg; A_reg = stack[-2]; #ifdef COMMON exit_count = 1; #endif continue; case OP_LOADLOC3: B_reg = A_reg; A_reg = stack[-3]; #ifdef COMMON exit_count = 1; #endif continue; case OP_LOADLOC4: B_reg = A_reg; A_reg = stack[-4]; #ifdef COMMON exit_count = 1; #endif continue; case OP_LOADLOC5: B_reg = A_reg; A_reg = stack[-5]; #ifdef COMMON exit_count = 1; #endif continue; case OP_LOADLOC6: B_reg = A_reg; A_reg = stack[-6]; #ifdef COMMON exit_count = 1; #endif continue; case OP_LOADLOC7: B_reg = A_reg; A_reg = stack[-7]; #ifdef COMMON exit_count = 1; #endif continue; case OP_LOADLOC8: B_reg = A_reg; A_reg = stack[-8]; #ifdef COMMON exit_count = 1; #endif continue; case OP_LOADLOC9: B_reg = A_reg; A_reg = stack[-9]; #ifdef COMMON exit_count = 1; #endif continue; case OP_LOADLOC10: B_reg = A_reg; A_reg = stack[-10]; #ifdef COMMON exit_count = 1; #endif continue; case OP_LOADLOC11: B_reg = A_reg; A_reg = stack[-11]; #ifdef COMMON exit_count = 1; #endif continue; case OP_CAR: if (car_legal(A_reg)) { A_reg = qcar(A_reg); #ifdef COMMON exit_count = 1; #endif continue; } CSLerrcode = err_bad_car; C_stack = stack; goto error_1_A; case OP_CARLOC0: B_reg = A_reg; A_reg = stack[-0]; if (car_legal(A_reg)) { A_reg = qcar(A_reg); #ifdef COMMON exit_count = 1; #endif continue; } CSLerrcode = err_bad_car; C_stack = stack; goto error_1_A; case OP_CARLOC1: B_reg = A_reg; A_reg = stack[-1]; if (car_legal(A_reg)) { A_reg = qcar(A_reg); #ifdef COMMON exit_count = 1; #endif continue; } CSLerrcode = err_bad_car; C_stack = stack; goto error_1_A; case OP_CARLOC2: B_reg = A_reg; A_reg = stack[-2]; if (car_legal(A_reg)) { A_reg = qcar(A_reg); #ifdef COMMON exit_count = 1; #endif continue; } CSLerrcode = err_bad_car; C_stack = stack; goto error_1_A; case OP_CARLOC3: B_reg = A_reg; A_reg = stack[-3]; if (car_legal(A_reg)) { A_reg = qcar(A_reg); #ifdef COMMON exit_count = 1; #endif continue; } CSLerrcode = err_bad_car; C_stack = stack; goto error_1_A; case OP_CARLOC4: B_reg = A_reg; A_reg = stack[-4]; if (car_legal(A_reg)) { A_reg = qcar(A_reg); #ifdef COMMON exit_count = 1; #endif continue; } CSLerrcode = err_bad_car; C_stack = stack; goto error_1_A; case OP_CARLOC5: B_reg = A_reg; A_reg = stack[-5]; if (car_legal(A_reg)) { A_reg = qcar(A_reg); #ifdef COMMON exit_count = 1; #endif continue; } CSLerrcode = err_bad_car; C_stack = stack; goto error_1_A; case OP_CARLOC6: B_reg = A_reg; A_reg = stack[-6]; if (car_legal(A_reg)) { A_reg = qcar(A_reg); #ifdef COMMON exit_count = 1; #endif continue; } CSLerrcode = err_bad_car; C_stack = stack; goto error_1_A; case OP_CARLOC7: B_reg = A_reg; A_reg = stack[-7]; if (car_legal(A_reg)) { A_reg = qcar(A_reg); #ifdef COMMON exit_count = 1; #endif continue; } CSLerrcode = err_bad_car; C_stack = stack; goto error_1_A; case OP_CARLOC8: B_reg = A_reg; A_reg = stack[-8]; if (car_legal(A_reg)) { A_reg = qcar(A_reg); #ifdef COMMON exit_count = 1; #endif continue; } CSLerrcode = err_bad_car; C_stack = stack; goto error_1_A; case OP_CARLOC9: B_reg = A_reg; A_reg = stack[-9]; if (car_legal(A_reg)) { A_reg = qcar(A_reg); #ifdef COMMON exit_count = 1; #endif continue; } CSLerrcode = err_bad_car; C_stack = stack; goto error_1_A; case OP_CARLOC10: B_reg = A_reg; A_reg = stack[-10]; if (car_legal(A_reg)) { A_reg = qcar(A_reg); #ifdef COMMON exit_count = 1; #endif continue; } CSLerrcode = err_bad_car; C_stack = stack; goto error_1_A; case OP_CARLOC11: B_reg = A_reg; A_reg = stack[-11]; if (car_legal(A_reg)) { A_reg = qcar(A_reg); #ifdef COMMON exit_count = 1; #endif continue; } CSLerrcode = err_bad_car; C_stack = stack; goto error_1_A; case OP_CDR: if (car_legal(A_reg)) { A_reg = qcdr(A_reg); #ifdef COMMON exit_count = 1; #endif continue; } CSLerrcode = err_bad_cdr; C_stack = stack; goto error_1_A; case OP_STORELOC: stack[-(int)next_byte] = A_reg; /* NB this opcode does not pop the A/B stack */ continue; case OP_STORELOC0: stack[-0] = A_reg; continue; case OP_STORELOC1: stack[-1] = A_reg; continue; case OP_STORELOC2: stack[-2] = A_reg; continue; case OP_STORELOC3: stack[-3] = A_reg; continue; case OP_STORELOC4: stack[-4] = A_reg; continue; case OP_STORELOC5: stack[-5] = A_reg; continue; case OP_STORELOC6: stack[-6] = A_reg; continue; case OP_STORELOC7: stack[-7] = A_reg; continue; case OP_LOADLIT: /* * Associated with each body of byte-codes there is a literal vector, * and this opcode loads values from same. The literal vector has a * header word and is tagged as a Lisp vector. */ B_reg = A_reg; A_reg = elt(litvec, next_byte); #ifdef COMMON exit_count = 1; #endif continue; case OP_LOADLIT1: B_reg = A_reg; A_reg = elt(litvec, 1); #ifdef COMMON exit_count = 1; #endif continue; case OP_LOADLIT2: B_reg = A_reg; A_reg = elt(litvec, 2); #ifdef COMMON exit_count = 1; #endif continue; case OP_LOADLIT3: B_reg = A_reg; A_reg = elt(litvec, 3); #ifdef COMMON exit_count = 1; #endif continue; case OP_LOADLIT4: B_reg = A_reg; A_reg = elt(litvec, 4); #ifdef COMMON exit_count = 1; #endif continue; case OP_LOADLIT5: B_reg = A_reg; A_reg = elt(litvec, 5); #ifdef COMMON exit_count = 1; #endif continue; case OP_LOADLIT6: B_reg = A_reg; A_reg = elt(litvec, 6); #ifdef COMMON exit_count = 1; #endif continue; case OP_LOADLIT7: B_reg = A_reg; A_reg = elt(litvec, 7); #ifdef COMMON exit_count = 1; #endif continue; case OP_LOADFREE: /* * Load the value of a free (GLOBAL, SPECIAL, FLUID) variable */ B_reg = A_reg; A_reg = qvalue(elt(litvec, next_byte)); #ifdef COMMON exit_count = 1; #endif continue; case OP_LOADFREE1: B_reg = A_reg; A_reg = qvalue(elt(litvec, 1)); #ifdef COMMON exit_count = 1; #endif continue; case OP_LOADFREE2: B_reg = A_reg; A_reg = qvalue(elt(litvec, 2)); #ifdef COMMON exit_count = 1; #endif continue; case OP_LOADFREE3: B_reg = A_reg; A_reg = qvalue(elt(litvec, 3)); #ifdef COMMON exit_count = 1; #endif continue; case OP_LOADFREE4: B_reg = A_reg; A_reg = qvalue(elt(litvec, 4)); #ifdef COMMON exit_count = 1; #endif continue; case OP_JUMPNIL: xppc = ppc; ppc++; if (A_reg == nil) ppc = ppc + *xppc; continue; case OP_JUMPNIL_B: xppc = ppc; ppc++; if (A_reg == nil) { ppc = ppc - *xppc; /* * To ensure that all code is interruptable I poll on every backwards * jump. The SIGINT event simulates a stack overflow, and the * consequent entry to the garbage collector then handles the event. */ #ifndef OUT_OF_LINE if (--countdown < 0) deal_with_tick(); if (stack >= stacklimit) { C_stack = stack; A_reg = reclaim(A_reg, "stack", GC_STACK, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ } #else if ((A_reg = poll_jump_back(stack, A_reg)) == SPID_ERROR) goto error_exit; stack = C_stack; #endif } continue; case OP_JUMPT: xppc = ppc; ppc++; if (A_reg != nil) ppc = ppc + *xppc; continue; case OP_JUMPT_B: xppc = ppc; ppc++; if (A_reg != nil) { ppc = ppc - *xppc; #ifndef OUT_OF_LINE if (--countdown < 0) deal_with_tick(); if (stack >= stacklimit) { C_stack = stack; A_reg = reclaim(A_reg, "stack", GC_STACK, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ } #else if ((A_reg = poll_jump_back(stack, A_reg)) == SPID_ERROR) goto error_exit; stack = C_stack; #endif } continue; case OP_JUMPNIL_L: w = next_byte; xppc = ppc; ppc++; if (A_reg == nil) ppc = ppc + ((w << 8) + *xppc); continue; case OP_JUMPNIL_BL: w = next_byte; xppc = ppc; ppc++; if (A_reg == nil) { ppc = ppc - ((w << 8) + *xppc); #ifndef OUT_OF_LINE if (--countdown < 0) deal_with_tick(); if (stack >= stacklimit) { C_stack = stack; A_reg = reclaim(A_reg, "stack", GC_STACK, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ } #else if ((A_reg = poll_jump_back(stack, A_reg)) == SPID_ERROR) goto error_exit; stack = C_stack; #endif } continue; case OP_JUMPT_L: w = next_byte; xppc = ppc; ppc++; if (A_reg != nil) ppc = ppc + ((w << 8) + *xppc); continue; case OP_JUMPT_BL: w = next_byte; xppc = ppc; ppc++; if (A_reg != nil) { ppc = ppc - ((w << 8) + *xppc); #ifndef OUT_OF_LINE if (--countdown < 0) deal_with_tick(); if (stack >= stacklimit) { C_stack = stack; A_reg = reclaim(A_reg, "stack", GC_STACK, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ } #else if ((A_reg = poll_jump_back(stack, A_reg)) == SPID_ERROR) goto error_exit; stack = C_stack; #endif } continue; case OP_BUILTIN1: f1 = one_arg_functions[next_byte]; /* BUILTIN1: A=fn(A); */ save_pc(); C_stack = stack; A_reg = f1(nil, A_reg); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); continue; case OP_BUILTIN2: f2 = two_arg_functions[next_byte]; /* BUILTIN2: A=fn(B,A); */ save_pc(); C_stack = stack; A_reg = f2(nil, B_reg, A_reg); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); continue; case OP_EXIT: /* * Here I assume that exit_count has been set up already. Note also that * there is no need to do any LOSE operations just before an EXIT since the * stack gets reset automatically here. */ #ifndef NO_BYTECOUNT qcount(elt(litvec, 0)) += OPCOUNT; #endif C_stack = entry_stack; return A_reg; case OP_PUSH: push(A_reg); continue; case OP_PUSHNIL: push(nil); continue; case OP_PUSHNIL2: push2(nil, nil); continue; case OP_PUSHNIL3: push3(nil, nil, nil); continue; case OP_POP: B_reg = A_reg; pop(A_reg); #ifdef COMMON exit_count = 1; #endif continue; case OP_LOSE: popv(1); continue; case OP_LOSE2: popv(2); continue; case OP_LOSE3: popv(3); continue; case OP_LOSES: popv(next_byte); continue; case OP_CONS: /* A_reg = cons(B_reg, A_reg); */ #ifndef OUT_OF_LINE r1 = (Lisp_Object)((char *)fringe - sizeof(Cons_Cell)); qcar(r1) = B_reg; qcdr(r1) = A_reg; fringe = r1; if ((char *)r1 <= (char *)heaplimit) { save_pc(); C_stack = stack; A_reg = reclaim((Lisp_Object)((char *)r1 + TAG_CONS), "bytecoded cons", GC_CONS, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ restore_pc(); } else A_reg = (Lisp_Object)((char *)r1 + TAG_CONS); #else save_pc(); C_stack = stack; A_reg = cons(B_reg, A_reg); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ restore_pc(); #endif #ifdef DEBUG if (((int)A_reg & (2*CELL-1)) != 0) { term_printf("badly aligned CONS\n"); ensure_screen(); abort(); } #endif #ifdef COMMON exit_count = 1; #endif continue; /* * FASTGET n * 0 <= n < 64 (GET A_reg property_n) * 64 <= n < 128 (GET A_reg property_n B_reg) * 128 <= n < 192 (FLAGP A_reg property_n) */ case OP_FASTGET: w = next_byte; #ifdef RECORD_GET n = 0; #endif if (symbolp(A_reg)) { r1 = qfastgets(A_reg); if (r1 == nil) { if (w & 0x40) A_reg = B_reg; else A_reg = nil; } else { A_reg = elt(r1, w & 0x7f); if (A_reg == SPID_NOPROP) { if (w & 0x40) A_reg = B_reg; else A_reg = nil; #ifdef RECORD_GET n = 1; #endif } else if (w & 0x80) A_reg = lisp_true; } } else A_reg = nil; #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(elt(fastget_names, w & 0x7f), n); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif continue; case OP_LITGET: B_reg = A_reg; A_reg = elt(litvec, next_byte); goto perform_get; case OP_GET: /* A = get(B, A) */ goto perform_get; } /* * Now various code-fragments that want to be inside the "for (;;)" loop * but outside the "switch". */ perform_get: #ifdef COMMON /* * This direct byte code supports the 2-argument version of GET. The * 3-arg version should be done as a regular general call. */ save_pc(); C_stack = stack; A_reg = get(B_reg, A_reg, nil); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); exit_count = 1; continue; #else #ifndef OUT_OF_LINE /* * Get is very heavily used - so I have in-lined it here since it is fairly * short code and ought not to overload register allocation. See "fns1.c" * for the regular version of this code. */ if (!symbolp(B_reg)) { #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(A_reg, NO); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif A_reg = nil; continue; } else { if (symbolp(A_reg) && (n = header_fastget(qheader(A_reg))) != 0) { if ((r1 = qfastgets(B_reg)) == nil) { #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(A_reg, NO); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif continue; } #ifdef RECORD_GET push(r1); save_pc(); C_stack = stack; record_get(A_reg, elt(r1, n-1) != nil); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); pop(r1); #endif A_reg = elt(r1, n-1); if (A_reg == SPID_NOPROP) A_reg = nil; continue; } /* * I write out the check on the first two items in the property list * longhand, expecting that a match will most often occur there. If * I get a match later on I will migrate the entry to the front of the list. */ r1 = qplist(B_reg); if (r1 == nil) { #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(A_reg, NO); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif A_reg = nil; continue; } r3 = qcar(r1); if (qcar(r3) == A_reg) { #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(A_reg, YES); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif A_reg = qcdr(r3); continue; } r1 = qcdr(r1); if (r1 == nil) { #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(A_reg, NO); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif A_reg = nil; continue; } r3 = qcar(r1); if (qcar(r3) == A_reg) { #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(A_reg, YES); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif A_reg = qcdr(r3); continue; } r2 = r1; r1 = qcdr(r1); if (r1 == nil) { #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(A_reg, NO); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif A_reg = nil; continue; } for (;;) { r3 = qcar(r1); if (qcar(r3) == A_reg) { qcdr(r2) = qcdr(r1); qcdr(r1) = qplist(B_reg); qplist(B_reg) = r1; #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(A_reg, YES); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif A_reg = qcdr(r3); break; } r2 = r1; r1 = qcdr(r1); if (r1 == nil) { #ifdef RECORD_GET save_pc(); C_stack = stack; record_get(A_reg, NO); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); #endif A_reg = nil; break; } } } continue; #else save_pc(); C_stack = stack; A_reg = get(B_reg, A_reg); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; restore_pc(); exit_count = 1; continue; #endif #endif caar: if (car_legal(A_reg)) A_reg = qcar(A_reg); else { CSLerrcode = err_bad_car; C_stack = stack; goto error_1_A; } if (car_legal(A_reg)) { A_reg = qcar(A_reg); #ifdef COMMON exit_count = 1; #endif continue; } CSLerrcode = err_bad_car; C_stack = stack; goto error_1_A; catcher: A_reg = cons(A_reg, catch_tags); nil = C_nil; if (exception_pending()) goto error_exit; catch_tags = A_reg; push3(fixnum_of_int(w+1), catch_tags, SPID_CATCH); continue; call0: r1 = elt(litvec, fname); /* * NB I set fname to be the literal-vector offset in the line above so that * it will be possible to find the name of the function that was called * if I have to display a backtrace. */ f345 = qfnn(r1); /* CALL0: A=fn() */ #ifdef DEBUG if (f345 == NULL) { term_printf("Illegal function\n"); my_exit(EXIT_FAILURE); } #endif save_pc(); C_stack = stack; A_reg = f345(qenv(r1), 0); nil = C_nil; if (exception_pending()) goto call_error_exit; stack = C_stack; restore_pc(); continue; jcall0: r1 = elt(litvec, fname); f345 = qfnn(r1); #ifdef DEBUG if (f345 == NULL) { term_printf("Illegal function\n"); my_exit(EXIT_FAILURE); } #endif #ifndef NO_BYTECOUNT qcount(elt(litvec, 0)) += OPCOUNT; opcodes = 30; #endif /* * The issue here is cases such as * (de f1 (x) (f2 x)) * (de f2 (x) (f1 x)) * where the bodies of the functions so not do enough work that polling * for interrupts or for window-system updates will happen. Thus it seems * I need to perform a polling operation as part of the tail-call sequence. */ #ifndef OUT_OF_LINE if (--countdown < 0) deal_with_tick(); if (stack >= stacklimit) { C_stack = stack; A_reg = reclaim(A_reg, "stack", GC_STACK, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ } #else if ((A_reg = poll_jump_back(stack, A_reg)) == SPID_ERROR) goto error_exit; stack = C_stack; #endif if (f345 == bytecoded0) { lit = qenv(r1); codevec = qcar(lit); litvec = qcdr(lit); stack = entry_stack; ppc = (unsigned char *)data_of_bps(codevec); continue; } else if (f345 == tracebytecoded0) { r2 = elt(litvec, 0); lit = qenv(r1); codevec = qcar(lit); litvec = qcdr(lit); /* * I make TRACECODED a special case, in effect writing it out in-line * here, to avoid some ugly confusion with backtraces following tail calls. */ stack = entry_stack; push3(litvec, codevec, r2); C_stack = stack; trace_print_0(elt(litvec, 0), stack); nil = C_nil; if (exception_pending()) goto error_exit; popv(1); pop2(codevec, litvec); ppc = (unsigned char *)data_of_bps(codevec); continue; } C_stack = entry_stack; return f345(qenv(r1), 0); call1: r1 = elt(litvec, fname); f1 = qfn1(r1); #ifdef DEBUG if (f1 == NULL) { term_printf("Illegal function\n"); my_exit(EXIT_FAILURE); } #endif /* CALL1: A=fn(A); */ save_pc(); C_stack = stack; A_reg = f1(qenv(r1), A_reg); nil = C_nil; if (exception_pending()) goto call_error_exit; stack = C_stack; restore_pc(); continue; jcall1: r1 = elt(litvec, fname); f1 = qfn1(r1); #ifdef DEBUG if (f1 == NULL) { term_printf("Illegal function\n"); my_exit(EXIT_FAILURE); } #endif #ifndef NO_BYTECOUNT qcount(elt(litvec, 0)) += OPCOUNT; opcodes = 30; #endif /* * The issue here is cases such as * (de f1 (x) (f2 x)) * (de f2 (x) (f1 x)) * where the bodies of the functions so not do enough work that polling * for interrupts or for window-system updates will happen. Thus it seems * I need to perform a polling operation as part of the tail-call sequence. */ #ifndef OUT_OF_LINE if (--countdown < 0) deal_with_tick(); if (stack >= stacklimit) { C_stack = stack; A_reg = reclaim(A_reg, "stack", GC_STACK, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ } #else if ((A_reg = poll_jump_back(stack, A_reg)) == SPID_ERROR) goto error_exit; stack = C_stack; #endif if (f1 == bytecoded1) { lit = qenv(r1); codevec = qcar(lit); litvec = qcdr(lit); stack = entry_stack; push(A_reg); ppc = (unsigned char *)data_of_bps(codevec); continue; } else if (f1 == tracebytecoded1) { r2 = elt(litvec, 0); lit = qenv(r1); codevec = qcar(lit); litvec = qcdr(lit); stack = entry_stack; push(A_reg); push3(litvec, codevec, r2); C_stack = stack; trace_print_1(elt(litvec, 0), stack); nil = C_nil; if (exception_pending()) goto error_exit; popv(1); pop2(codevec, litvec); ppc = (unsigned char *)data_of_bps(codevec); continue; } C_stack = entry_stack; return f1(qenv(r1), A_reg); call2: r1 = elt(litvec, fname); f2 = qfn2(r1); #ifdef DEBUG if (f2 == NULL) { term_printf("Illegal function\n"); my_exit(EXIT_FAILURE); } #endif /* CALL2: A=fn(B,A); */ save_pc(); C_stack = stack; A_reg = f2(qenv(r1), B_reg, A_reg); nil = C_nil; if (exception_pending()) goto call_error_exit; stack = C_stack; restore_pc(); continue; call2r: r1 = elt(litvec, fname); f2 = qfn2(r1); #ifdef DEBUG if (f2 == NULL) { term_printf("Illegal function\n"); my_exit(EXIT_FAILURE); } #endif /* CALL2R: A=fn(A,B); NOTE arg order reversed */ save_pc(); C_stack = stack; A_reg = f2(qenv(r1), A_reg, B_reg); nil = C_nil; if (exception_pending()) goto call_error_exit; stack = C_stack; restore_pc(); continue; jcall2: r1 = elt(litvec, fname); f2 = qfn2(r1); #ifdef DEBUG if (f2 == NULL) { term_printf("Illegal function\n"); my_exit(EXIT_FAILURE); } #endif #ifndef NO_BYTECOUNT qcount(elt(litvec, 0)) += OPCOUNT; opcodes = 30; #endif /* * The issue here is cases such as * (de f1 (x) (f2 x)) * (de f2 (x) (f1 x)) * where the bodies of the functions so not do enough work that polling * for interrupts or for window-system updates will happen. Thus it seems * I need to perform a polling operation as part of the tail-call sequence. */ #ifndef OUT_OF_LINE if (--countdown < 0) deal_with_tick(); if (stack >= stacklimit) { C_stack = stack; A_reg = reclaim(A_reg, "stack", GC_STACK, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ } #else if ((A_reg = poll_jump_back(stack, A_reg)) == SPID_ERROR) goto error_exit; stack = C_stack; #endif if (f2 == bytecoded2) { lit = qenv(r1); codevec = qcar(lit); litvec = qcdr(lit); stack = entry_stack; push2(B_reg, A_reg); ppc = (unsigned char *)data_of_bps(codevec); continue; } else if (f2 == tracebytecoded2) { r2 = elt(litvec, 0); lit = qenv(r1); codevec = qcar(lit); litvec = qcdr(lit); stack = entry_stack; push2(B_reg, A_reg); push3(litvec, codevec, r2); C_stack = stack; trace_print_2(elt(litvec, 0), stack); nil = C_nil; if (exception_pending()) goto error_exit; popv(1); pop2(codevec, litvec); ppc = (unsigned char *)data_of_bps(codevec); continue; } C_stack = entry_stack; return f2(qenv(r1), B_reg, A_reg); call3: r1 = elt(litvec, fname); f345 = qfnn(r1); #ifdef DEBUG if (f345 == NULL) { term_printf("Illegal function\n"); my_exit(EXIT_FAILURE); } #endif /* CALL3: A=fn(pop(),B,A); */ save_pc(); pop(r2); C_stack = stack; A_reg = f345(qenv(r1), 3, r2, B_reg, A_reg); nil = C_nil; if (exception_pending()) goto call_error_exit; stack = C_stack; restore_pc(); continue; jcall3: r1 = elt(litvec, fname); f345 = qfnn(r1); #ifdef DEBUG if (f345 == NULL) { term_printf("Illegal function\n"); my_exit(EXIT_FAILURE); } #endif pop(r2); #ifndef NO_BYTECOUNT qcount(elt(litvec, 0)) += OPCOUNT; opcodes = 30; #endif /* * The issue here is cases such as * (de f1 (x) (f2 x)) * (de f2 (x) (f1 x)) * where the bodies of the functions so not do enough work that polling * for interrupts or for window-system updates will happen. Thus it seems * I need to perform a polling operation as part of the tail-call sequence. */ #ifndef OUT_OF_LINE if (--countdown < 0) deal_with_tick(); if (stack >= stacklimit) { C_stack = stack; A_reg = reclaim(A_reg, "stack", GC_STACK, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ } #else if ((A_reg = poll_jump_back(stack, A_reg)) == SPID_ERROR) goto error_exit; stack = C_stack; #endif if (f345 == bytecoded3) { lit = qenv(r1); codevec = qcar(lit); litvec = qcdr(lit); stack = entry_stack; push3(r2, B_reg, A_reg); ppc = (unsigned char *)data_of_bps(codevec); continue; } else if (f345 == tracebytecoded3) { r3 = elt(litvec, 0); lit = qenv(r1); codevec = qcar(lit); litvec = qcdr(lit); stack = entry_stack; push3(r2, B_reg, A_reg); push3(litvec, codevec, r3); C_stack = stack; trace_print_3(elt(litvec, 0), stack); nil = C_nil; if (exception_pending()) goto error_exit; popv(1); pop2(codevec, litvec); ppc = (unsigned char *)data_of_bps(codevec); continue; } C_stack = entry_stack; return f345(qenv(r1), 3, r2, B_reg, A_reg); jcalln: #ifndef NO_BYTECOUNT qcount(elt(litvec, 0)) += OPCOUNT; opcodes = 30; #endif /* * The issue here is cases such as * (de f1 (x) (f2 x)) * (de f2 (x) (f1 x)) * where the bodies of the functions so not do enough work that polling * for interrupts or for window-system updates will happen. Thus it seems * I need to perform a polling operation as part of the tail-call sequence. */ #ifndef OUT_OF_LINE if (--countdown < 0) deal_with_tick(); if (stack >= stacklimit) { C_stack = stack; A_reg = reclaim(A_reg, "stack", GC_STACK, 0); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ } #else if ((A_reg = poll_jump_back(stack, A_reg)) == SPID_ERROR) goto error_exit; stack = C_stack; #endif /* * here I could shuffle the stack down quite a lot... */ push2(B_reg, A_reg); C_stack = stack; A_reg = elt(litvec, fname); /* * Also if the function is byte-coded I can enter it more directly. * It is strongly desirable that I do so so that backtraces will work * better. */ A_reg = apply(A_reg, (int)w, nil, A_reg); nil = C_nil; if (exception_pending()) goto ncall_error_exit; #ifndef NO_BYTECOUNT qcount(elt(litvec, 0)) += OPCOUNT; #endif C_stack = entry_stack; return A_reg; create_closure: save_pc(); A_reg = encapsulate_sp(&stack[-2-(int)w]); nil = C_nil; if (exception_pending()) goto error_exit; pop(B_reg); C_stack = stack; A_reg = list2star(cfunarg, B_reg, A_reg); nil = C_nil; if (exception_pending()) goto error_exit; stack = C_stack; /* may have been changed by GC */ restore_pc(); pop(B_reg); continue; /*****************************************************************************/ call_error_exit: flip_exception(); C_stack = stack; goto pop_stack_and_exit; ncall_error_exit: flip_exception(); goto pop_stack_and_exit; callself_error_exit: flip_exception(); goto pop_stack_and_exit; stack_apply_error: { flip_exception(); stack = C_stack; pop(r1); C_stack = stack; /* * I suspect that the next few lines are UNHELPFUL now, so maybe I should * get rid of them... */ if ((exit_reason & UNWIND_ERROR) != 0) { err_printf("apply: "); loop_print_error(r1); err_printf("\n"); nil = C_nil; if (exception_pending()) flip_exception(); } } goto pop_stack_and_exit; apply_error: flip_exception(); C_stack = stack; /* * I suspect that the next few lines are UNHELPFUL now, so maybe I should * get rid of them... */ if ((exit_reason & UNWIND_ERROR) != 0) { err_printf("apply: "); loop_print_error(A_reg); err_printf("\n"); nil = C_nil; if (exception_pending()) flip_exception(); } goto pop_stack_and_exit; error_exit: flip_exception(); goto pop_stack_and_exit; error_1_A: C_stack = stack; error(1, CSLerrcode, A_reg); nil = C_nil; flip_exception(); goto pop_stack_and_exit; pop_stack_and_exit: stack = C_stack; /* * What follows is my current guess for a good diagnostic... */ if ((exit_reason & UNWIND_ERROR) != 0) { err_printf("Inside: "); loop_print_error(elt(litvec, 0)); err_printf("\n"); nil = C_nil; if (exception_pending()) flip_exception(); } /* * Here I need to scan down the current stack-frame looking for either a * CATCH or an UNWIND-PROTECT marker. */ for (;;) { unwind_stack(entry_stack, YES); if (C_stack == entry_stack) { w = 0; break; } /* Here I have a CATCH/UNWIND record within the current function */ stack = C_stack; pop2(r1, r2); C_stack = stack; /* * If the tag matches exit_tag then I must reset pc based on offset (r2) * and continue. NB need to restore A_reg from exit_value. */ w = int_of_fixnum(r2); if (qcar(r1) == SPID_PROTECT) { /* This is an UNWIND catcher */ push2(exit_tag, fixnum_of_int(exit_reason)); #ifdef COMMON C_stack = stack; A_reg = Lmv_list(nil, exit_value); nil = C_nil; if (exception_pending()) goto error_exit; #endif push(A_reg); ppc = (unsigned char *)data_of_bps(codevec) + w; w = 1; break; } else if (exit_reason == UNWIND_THROW && r1 == exit_tag) { ppc = (unsigned char *)data_of_bps(codevec) + w; w = 1; break; } } if (w) { A_reg = exit_value; continue; } #ifndef NO_BYTECOUNT qcount(elt(litvec, 0)) += OPCOUNT; #endif C_stack = entry_stack; flip_exception(); return nil; } } /* end of bytes1.c */