@@ -1,3499 +1,3499 @@ -/* fns2.c Copyright (C) 1989-96 Codemist Ltd */ - -/* - * Basic functions part 2. - */ - -/* Signature: 31f63691 12-Mar-2000 */ - -#include -#include -#include - -#include "machine.h" -#include "tags.h" -#include "cslerror.h" -#include "externs.h" -#include "read.h" -#include "entries.h" -#include "arith.h" -#ifdef COMMON -#include "clsyms.h" -#endif -#ifdef TIMEOUT -#include "timeout.h" -#endif - -#ifdef SOCKETS -#include "sockhdr.h" -#endif - -Lisp_Object getcodevector(int32 type, int32 size) -{ -/* - * type is the code (e.g. TYPE_BPS) that gets packed, together with - * the size, into a header word. - * size is measured in bytes and must allow space for the header word. - * This obtains space in the BPS area - */ - Lisp_Object nil = C_nil; -#ifdef CHECK_FOR_CORRUPT_HEAP - validate_all(); -#endif - for (;;) - { int32 alloc_size = (int32)doubleword_align_up(size); - char *cf = (char *)codefringe, *cl = (char *)codelimit; - unsigned int free = cf - cl; - char *r; - if (alloc_size > (int32)free) - { char msg[40]; - sprintf(msg, "codevector %ld", (long)size); - reclaim(nil, msg, GC_BPS, alloc_size); - errexit(); - continue; - } - r = cf - alloc_size; - codefringe = (Lisp_Object)r; - *((Header *)r) = type + (size << 10) + TAG_ODDS; - return TAG_BPS + - (((int32)(r - cl + 12) & (PAGE_POWER_OF_TWO-4)) << 6) + - (((int32)(bps_pages_count-1))<<(PAGE_BITS+6)); /* Wow! Obscure!! */ - } -} - -Lisp_Object Lget_bps(Lisp_Object nil, Lisp_Object n) -{ - int32 n1; - if (!is_fixnum(n) || (int32)n<0) return aerror1("get-bps", n); - n1 = int_of_fixnum(n); - n = getcodevector(TYPE_BPS, n1+4); - errexit(); - return onevalue(n); -} - -Lisp_Object get_native_code_vector(int32 size) -{ -/* - * Create some space for native code and return a handle that identifies - * its start point. size is measured in bytes. - */ - Lisp_Object nil = C_nil; - if (size <= 0) size = 8; - for (;;) - { int32 alloc_size = (int32)doubleword_align_up(size); - int32 cf = native_fringe; - int32 free = CSL_PAGE_SIZE - cf - 0x100; /* 256 bytes to be safe */ -/* - * When I start up a cold CSL I will have native_fringe set to zero and - * native_pages_count also zero, indicating that there is none of this stuff - * active. - */ - if (native_fringe == 0 || alloc_size > free) - { char msg[40]; - sprintf(msg, "native code %ld", (long)size); - reclaim(nil, msg, GC_NATIVE, alloc_size); - errexit(); - continue; - } - free = (int32)native_pages[native_pages_count-1]; - free = doubleword_align_up(free); -/* - * I put the number of bytes in this block as the first word of the chunk - * of memory, and arrange that there is a zero in what would be the first - * word of unused space. Provided the user does not clobber bytes 0 to 4 - * or the block this is enough to allow restart code to scan through all - * native code segments. - */ - *(int32 *)(free+native_fringe) = alloc_size; - *(int32 *)(free+native_fringe+alloc_size) = 0; - native_fringe += alloc_size; - native_pages_changed = 1; - return Lcons(nil, - fixnum_of_int(native_pages_count-1), - fixnum_of_int(cf)); - } -} - -Lisp_Object Lget_native(Lisp_Object nil, Lisp_Object n) -{ - int32 n1; - if (!is_fixnum(n) || (int32)n<0) return aerror1("get-native", n); - n1 = int_of_fixnum(n); - n = get_native_code_vector(n1); - errexit(); - return onevalue(n); -} - -int do_not_kill_native_code = 0; - -void set_fns(Lisp_Object a, one_args *f1, two_args *f2, n_args *fn) -{ - Lisp_Object nil = C_nil; - Lisp_Object w1, w2, w3 = nil; -/* - * If I redefine a function for any reason (except to set trace options - * on a bytecoded definition) I will discard any native-coded definitions - * by splicing them out of the record. I provide a global variable to - * defeat this behaviour (ugh). - */ - if (!do_not_kill_native_code) - { for (w1 = native_code; w1!=nil; w1=qcdr(w1)) - { w2 = qcar(w1); - if (qcar(w2) == a) break; - w3 = w1; - } - if (w1 != nil) - { w1 = qcdr(w1); - if (w3 == nil) native_code = w1; - else qcdr(w3) = w1; - } - } - if ((qheader(a) & (SYM_C_DEF | SYM_CODEPTR)) == - (SYM_C_DEF | SYM_CODEPTR)) - { -#ifdef NOISY_RE_PROTECTED_FNS - trace_printf("+++ protected function "); - prin_to_trace(a); - trace_printf(" not redefined\n"); -#endif - return; - } - ifn1(a) = (int32)f1; - ifn2(a) = (int32)f2; - ifnn(a) = (int32)fn; -} - -#ifdef HIDE_USELESS_SYMBOL_ENVIRONMENTS - -static CSLbool interpreter_entry(Lisp_Object a) -/* - * If a function will be handled by the interpreter, including the case - * of it being undefined, then the fn1() cell will tell me so. - */ -{ - return ( - qfn1(a) == interpreted1 || - qfn1(a) == traceinterpreted1 || - qfn1(a) == double_interpreted1 || - qfn1(a) == funarged1 || - qfn1(a) == tracefunarged1 || - qfn1(a) == double_funarged1 || - qfn1(a) == undefined1); -} - -#endif - -static char *show_fn(void *p) -{ - int i; - for (i=0; i MAX_FASTGET_SIZE)) return aerror1("symbol-make-fastget", a); - term_printf("+++ Fastget size was %d, now %d\n", n1, n); - fastget_size = n; - return onevalue(fixnum_of_int(n1)); -} - -Lisp_Object Lsymbol_make_fastget(Lisp_Object nil, Lisp_Object a, Lisp_Object n) -{ - int32 n1, p, q; - Header h; - if (!symbolp(a)) return onevalue(nil); - h = qheader(a); - p = header_fastget(h); - if (is_fixnum(n)) - { n1 = int_of_fixnum(n); - if (n1 < -1 || n1 >= fastget_size) - return aerror1("symbol-make-fastget", n); - trace_printf("+++ Use fastget slot %d for ", n1); - loop_print_trace(a); - errexit(); - trace_printf("\n"); - if (p != 0) elt(fastget_names, p-1) = SPID_NOPROP; - q = (n1 + 1) & 0x3f; - h = (h & ~SYM_FASTGET_MASK) | (q << SYM_FASTGET_SHIFT); - qheader(a) = h; - if (q != 0) elt(fastget_names, q-1) = a; - } - if (p == 0) return onevalue(nil); - else return onevalue(fixnum_of_int(p - 1)); -} - -static Lisp_Object deleqip(Lisp_Object a, Lisp_Object l) -/* - * This deletes the item a (tested for using EQ) from the list l, - * assuming that the list is nil-terminated and that the item a - * occurs at most once. It overwrites the list l in the process. - */ -{ - Lisp_Object nil = C_nil, w, r; - if (l == nil) return nil; - if (qcar(l) == a) return qcdr(l); - r = l; - while (w = l, (l = qcdr(l)) != nil) - { if (qcar(l) == a) - { qcdr(w) = qcdr(l); - return r; - } - } - return r; -} - -void lose_C_def(Lisp_Object a) -{ -/* - * None of the code here can cause garbage collection. - */ -#ifdef COMMON - Lisp_Object nil = C_nil; - Lisp_Object b = get(a, unset_var, nil), c; -#else - nil_as_base - Lisp_Object b = get(a, unset_var), c; -#endif - Lremprop(C_nil, a, unset_var); - qheader(a) &= ~SYM_C_DEF; -#ifdef COMMON - c = get(b, work_symbol, nil); -#else - c = get(b, work_symbol); -#endif - c = deleqip(a, c); - if (c == C_nil) Lremprop(C_nil, b, work_symbol); - else putprop(b, work_symbol, c); -} - -/* - * (symbol-set-native fn args bpsbase offset env) - * where bpsbase is as handed back by (make-native nnn) and offset is - * the offset in this block to enter at. - * If args has the actual arg count in its bottom byte. Usually the - * rest of it will be zero, and then one function cell is set to point to the - * given entrypoint and the other two are set to point at error handlers. - * If any bits in args beyond that are set then this call only changes the - * directly specified function cell, and the others are left in whatever state - * they were. If several of the fuction cells are to be filled in (eg to cope - * with &optional or &rest arguments) then a simple call with args<256 must - * be made first, followed by the calls (args>=256) that fill in the other - * two cells. - * The first time that symbol-set-native is called on a function that - * function MUST have a byte coded definition, and this definition is - * picked up and stored away, so that if (preserve) is called the bytecoded - * definition will be available for use on systems with different - * architectures. To make things tolerably consistent with that any operation - * that installs a new bytecoded (or for that matter other) definition - * will clear away any native-compiled versions of the function. - * - * The native code that is installed will be expected to have relocation - * records starting at the start of bpsbase, and these will be activated, - * filling in references from the bps to other executable parts of Lisp. - * Passing bad arguments to this function provide a quick and easy way to - * cayse UTTER havoc. Therefore I disable its use in server applications. - */ - -Lisp_Object MS_CDECL Lsymbol_set_native(Lisp_Object nil, int nargs, ...) -{ - va_list a; - Lisp_Object fn, args, bpsbase, offset, env, w1, w2, w3; - int32 pagenumber, page, bps, address, t_p, arginfo; -#ifdef SOCKETS -/* - * Security measure - deny symbol-set-native to remote users - */ - if (socket_server != 0) return aerror("symbol-set-native"); -#endif - argcheck(nargs, 5, "symbol-set-native"); - va_start(a, nargs); - fn = va_arg(a, Lisp_Object); - args = va_arg(a, Lisp_Object); - bpsbase = va_arg(a, Lisp_Object); - offset = va_arg(a, Lisp_Object); - env = va_arg(a, Lisp_Object); - va_end(a); - if (!is_symbol(fn) || - (qheader(fn) & (SYM_SPECIAL_FORM | SYM_CODEPTR)) != 0) - return aerror1("symbol-set-native", fn); - if (!is_fixnum(args)) return aerror1("symbol-set-native", args); - if (!consp(bpsbase) || - !is_fixnum(qcar(bpsbase)) || - !is_fixnum(qcdr(bpsbase))) - return aerror1("symbol-set-native", bpsbase); - if (!is_fixnum(offset)) return aerror1("symbol-set-native", offset); - nargs = int_of_fixnum(args); - pagenumber = int_of_fixnum(qcar(bpsbase)); - if (pagenumber<0 || pagenumber>=native_pages_count) - return aerror1("symbol-set-native", bpsbase); - bps = int_of_fixnum(qcdr(bpsbase)); - address = bps+int_of_fixnum(offset); - if (address<8 || address>=CSL_PAGE_SIZE) - return aerror1("symbol-set-native", offset); - page = (int32)native_pages[pagenumber]; - page = doubleword_align_up(page); - bps = page + bps; - relocate_native_function((unsigned char *)bps); -/* - * Here I need to push the info I have just collected onto - * the native_code list since otherwise things will not be re-loaded in - * from a checkpoint image. Also if the function is at present byte-coded - * I need to record that info about it in native_code. - */ - w1 = native_code; - while (w1!=nil) - { w2 = qcar(w1); - if (qcar(w2) == fn) break; - w1 = qcdr(w1); - } - if (w1 == nil) - { -/* - * Here the function has not been seen as native code ever before, so it has - * not been entered into the list. Do something about that... - */ - push2(env, fn); - args = Lsymbol_argcount(nil, fn); - errexitn(2); - if (args == nil) - return aerror1("No bytecode definition found for", fn); -/* - * Now I have to reverse the information that symbol_argcount gave me - * to get the single numeric code as wanted by symbol_set_definition. - * Oh what a mess. - */ - if (is_fixnum(args)) arginfo = int_of_fixnum(args); - else - { arginfo = int_of_fixnum(qcar(args)); - args = qcdr(args); - arginfo |= ((int_of_fixnum(qcar(args)) - arginfo) << 8); - args = qcdr(args); - arginfo |= int_of_fixnum(qcar(args)) << 16; - } - fn = stack[0]; - w2 = list2(fn, fixnum_of_int(arginfo)); - errexitn(2); - w2 = cons(w2, native_code); - errexitn(2); - native_code = w2; - w2 = qcar(w2); - pop2(fn, env); - } - w2 = qcdr(w2); /* {nargs,(type . offset . env),...} */ -/* - * If I was defining this function in the simple way I should clear any - * previous version (for this machine architecture) from the record. - * Just at present this does not release the memory, but at some stage - * in the future I may arrange to compact away old code when I do a - * preserve operation (say). - */ - if (nargs <= 0xff) - { w1 = w3 = w2; - for (w1=qcdr(w2); w1!=nil; w1=qcdr(w1)) - { w3 = qcar(w1); - if (qcar(w3) == fixnum_of_int(native_code_tag)) break; - w3 = w1; - } - if (w1 != nil) qcdr(w3) = qcdr(w1); - } -/* - * w2 is still the entry for this function in the native code list. It - * needs to have an entry of type 0 (ie for bytecoded) and so the next - * thing to do is to check that such an entry exists and if not to create - * it. - */ - w1 = w2; - while ((w1 = qcdr(w1)) != nil) - { w3 = qcar(w1); - if (qcar(w3) == fixnum_of_int(0)) break; - w1 = qcdr(w1); - } - if (w1 == nil) - { -/* - * This is where there was no bytecode entry on the native code list - * for this function, so I had better create one for it. Note that only - * one such entry will ever be stored so it does not matter much where on - * the list it goes. I suspect that the list ought always to be empty - * in this case anyway. - */ - push3(fn, env, w2); - w1 = list2star(fixnum_of_int(0), fixnum_of_int(0), qenv(fn)); - errexitn(3); - w2 = stack[0]; - w1 = cons(w1, qcdr(w2)); - errexitn(3); - pop3(w2, env, fn); - qcdr(w2) = w1; - } -/* - * Now the list of native code associated with this function certainly holds - * a byte-coded definition (and for sanity that had better be consistent - * with the native code I am installing now, but that is not something - * that can be checked at this level). Put in an entry referring to the - * current gubbins. - */ - push3(w2, fn, env); -/* - * now I pack the code type, arg category and offset into the - * single fixnum that that information has to end up in. - */ - t_p = (native_code_tag << 20); - if ((nargs & 0xffffff00) != 0) - { - switch (nargs & 0xff) - { - case 1: t_p |= (1<<18); break; - case 2: t_p |= (2<<18); break; - default:t_p |= (3<<18); break; - } - } - t_p |= (pagenumber & 0x3ffff); - w1 = list2star(fixnum_of_int(t_p), fixnum_of_int(address), env); - errexitn(3); - w1 = ncons(w1); - pop3(env, fn, w2); - errexit(); - while ((w3 = qcdr(w2)) != nil) w2 = w3; /* Tag onto the END */ - qcdr(w2) = w1; - qheader(fn) &= ~SYM_TRACED; - address = page + address; -/* - * The code here must do just about the equivalent to that in restart.c - */ - switch (nargs & 0xff) - { -case 0: ifnn(fn) = address; - if (nargs<=0xff) - ifn1(fn) = (int32)wrong_no_0a, ifn2(fn) = (int32)wrong_no_0b; - break; -case 1: ifn1(fn) = address; - if (nargs<=0xff) - ifn2(fn) = (int32)too_many_1, ifnn(fn) = (int32)wrong_no_1; - break; -case 2: ifn2(fn) = address; - if (nargs<=0xff) - ifn1(fn) = (int32)too_few_2, ifnn(fn) = (int32)wrong_no_2; - break; -case 3: ifnn(fn) = address; - if (nargs<=0xff) - ifn1(fn) = (int32)wrong_no_3a, ifn2(fn) = (int32)wrong_no_3b; - break; -default: ifnn(fn) = address; - if (nargs<=0xff) - ifn1(fn) = (int32)wrong_no_na, ifn2(fn) = (int32)wrong_no_nb; - break; - } - qenv(fn) = env; - return onevalue(fn); -} - -static CSLbool restore_fn_cell(Lisp_Object a, char *name, - int32 len, setup_type const s[]) -{ - int i; - for (i=0; s[i].name != NULL; i++) - { if (strlen(s[i].name) == len && - memcmp(name, s[i].name, len) == 0) break; - } - if (s[i].name == NULL) return NO; - set_fns(a, s[i].one, s[i].two, s[i].n); - return YES; -} - -static Lisp_Object Lrestore_c_code(Lisp_Object nil, Lisp_Object a) -{ - char *name; - int32 len; - Lisp_Object pn; - if (!symbolp(a)) return aerror1("restore-c-code", a); - push(a); - pn = get_pname(a); - pop(a); - errexit(); - name = (char *)&celt(pn, 0); - len = length_of_header(vechdr(pn)) - 4; - if (restore_fn_cell(a, name, len, u01_setup) || - restore_fn_cell(a, name, len, u02_setup) || - restore_fn_cell(a, name, len, u03_setup) || - restore_fn_cell(a, name, len, u04_setup) || - restore_fn_cell(a, name, len, u05_setup) || - restore_fn_cell(a, name, len, u06_setup) || - restore_fn_cell(a, name, len, u07_setup) || - restore_fn_cell(a, name, len, u08_setup) || - restore_fn_cell(a, name, len, u09_setup) || - restore_fn_cell(a, name, len, u10_setup) || - restore_fn_cell(a, name, len, u11_setup) || - restore_fn_cell(a, name, len, u12_setup)) - { Lisp_Object env; - push(a); -#ifdef COMMON - env = get(a, funarg, nil); -#else - env = get(a, funarg); -#endif - pop(a); - errexit(); - qenv(a) = env; - return onevalue(a); - } - else return onevalue(nil); -} - -Lisp_Object Lsymbol_set_definition(Lisp_Object nil, - Lisp_Object a, Lisp_Object b) -/* - * The odd case here is where the second argument represents a freshly - * created bit of compiled code. In which case the structure is - * (nargs . codevec . envvec) - * where nargs is an integer indicating the number of arguments, codevec - * is a vector of bytecodes, and envvec is something to go in the - * environment cell of the symbol. - * Here the low 8 bits of nargs indicate the number of required arguments. - * The next 8 bits give the number of optional arguments, and the next - * two bits are flags. Of these, the first is set if any of the optional - * arguments has an initform or supplied-p associate, and the other - * indicates that a "&rest" argument is required. - * Bits beyond that (if non-zero) indicate that the function definition - * is of the form (defun f1 (a b c) (f2 a b)) and the number coded is the - * length of the function body. - * Standard Lisp does not need &optional or &rest arguments, but it turned - * out to be pretty easy to make the bytecode compiler support them. - */ -{ - if (!is_symbol(a) || -/* - * Something flagged with the CODEPTR bit is a gensym manufactured to - * stand for a compiled-code object. It should NOT be reset! - */ - (qheader(a) & (SYM_SPECIAL_FORM | SYM_CODEPTR)) != 0) - { if (qheader(a) & SYM_C_DEF) return onevalue(nil); - return aerror1("symbol-set-definition", a); - } - qheader(a) &= ~SYM_TRACED; - set_fns(a, undefined1, undefined2, undefinedn); /* Tidy up first */ - qenv(a) = a; - if ((qheader(a) & SYM_C_DEF) != 0) lose_C_def(a); - if (b == nil) return onevalue(b); /* set defn to nil to undefine */ - else if (symbolp(b)) - { -/* - * One could imagine a view that the second arg to symbol-set-definition - * had to be a codepointer object. I will be kind (?) and permit the NAME - * of a function too. However for the second arg to be a macro or a - * special form would still be a calamity. - * if ((qheader(b) & SYM_CODEPTR) == 0) - * return aerror1("symbol-set-definition", b); - */ - if ((qheader(b) & (SYM_SPECIAL_FORM | SYM_MACRO)) != 0) - return aerror1("symbol-set-definition", b); - qheader(a) = qheader(a) & ~SYM_MACRO; - { set_fns(a, qfn1(b), qfn2(b), qfnn(b)); - qenv(a) = qenv(b); -/* - * In order that checkpoint files can be made there is some very - * ugly fooling around here for functions that are defined in the C coded - * kernel. Sorry. - */ - if ((qheader(b) & SYM_C_DEF) != 0) - { -#ifdef COMMON - Lisp_Object c = get(b, unset_var, nil); -#else - Lisp_Object c = get(b, unset_var); -#endif - if (c == nil) c = b; - push2(c, a); - putprop(a, unset_var, c); - errexitn(2); - pop(a); -#ifdef COMMON - a = cons(a, get(stack[0], work_symbol, nil)); -#else - a = cons(a, get(stack[0], work_symbol)); -#endif - errexitn(1); - putprop(stack[0], work_symbol, a); - pop(b); - errexit(); - } - } - } - else if (!consp(b)) return aerror1("symbol-set-definition", b); - else if (is_fixnum(qcar(b))) - { int32 nargs = (int)int_of_fixnum(qcar(b)), nopts, flagbits, ntail; - nopts = nargs >> 8; - flagbits = nopts >> 8; - ntail = flagbits >> 2; - nargs &= 0xff; - nopts &= 0xff; - flagbits &= 3; - if (ntail != 0) - { switch (100*nargs + ntail-1) - { - case 300: set_fns(a, wrong_no_na, wrong_no_nb, f3_as_0); break; - case 301: set_fns(a, wrong_no_na, wrong_no_nb, f3_as_1); break; - case 302: set_fns(a, wrong_no_na, wrong_no_nb, f3_as_2); break; - case 303: set_fns(a, wrong_no_na, wrong_no_nb, f3_as_3); break; - case 200: set_fns(a, too_few_2, f2_as_0, wrong_no_2); break; - case 201: set_fns(a, too_few_2, f2_as_1, wrong_no_2); break; - case 202: set_fns(a, too_few_2, f2_as_2, wrong_no_2); break; - case 100: set_fns(a, f1_as_0, too_many_1, wrong_no_1); break; - case 101: set_fns(a, f1_as_1, too_many_1, wrong_no_1); break; - case 000: set_fns(a, wrong_no_na, wrong_no_nb, f0_as_0); break; - } - b = qcdr(b); - } - else if (flagbits != 0 || nopts != 0) - { if ((qheader(a) & SYM_TRACED) == 0) switch(flagbits) - { - default: - case 0: /* easy case optional arguments */ - set_fns(a, byteopt1, byteopt2, byteoptn); break; - case 1: /* optional args, but non-nil default, or supplied-p extra */ - set_fns(a, hardopt1, hardopt2, hardoptn); break; - case 2: /* easy opt args, but also a &rest arg */ - set_fns(a, byteoptrest1, byteoptrest2, byteoptrestn); break; - case 3: /* complicated &options and &rest */ - set_fns(a, hardoptrest1, hardoptrest2, hardoptrestn); break; - } - else switch (flagbits) - { - default: - case 0: /* easy case optional arguments */ - set_fns(a, tracebyteopt1, tracebyteopt2, tracebyteoptn); break; - case 1: /* optional args, but non-nil default, or supplied-p extra */ - set_fns(a, tracehardopt1, tracehardopt2, tracehardoptn); break; - case 2: /* easy opt args, but also a &rest arg */ - set_fns(a, tracebyteoptrest1, tracebyteoptrest2, tracebyteoptrestn); break; - case 3: /* complicated &options and &rest */ - set_fns(a, tracehardoptrest1, tracehardoptrest2, tracehardoptrestn); break; - } - } - else - { if (nargs > 4) nargs = 4; - if ((qheader(a) & SYM_TRACED) != 0) nargs += 5; - qheader(a) = qheader(a) & ~SYM_MACRO; - switch (nargs) - { - case 0: set_fns(a, wrong_no_0a, wrong_no_0b, bytecoded0); - break; - case 1: set_fns(a, bytecoded1, too_many_1, wrong_no_1); - break; - case 2: set_fns(a, too_few_2, bytecoded2, wrong_no_2); - break; - case 3: set_fns(a, wrong_no_3a, wrong_no_3b, bytecoded3); - break; - default: - case 4: set_fns(a, wrong_no_na, wrong_no_nb, bytecodedn); - break; - - case 5+0: set_fns(a, wrong_no_0a, wrong_no_0b, tracebytecoded0); - break; - case 5+1: set_fns(a, tracebytecoded1, too_many_1, wrong_no_1); - break; - case 5+2: set_fns(a, too_few_2, tracebytecoded2, wrong_no_2); - break; - case 5+3: set_fns(a, wrong_no_3a, wrong_no_3b, tracebytecoded3); - break; - case 5+4: set_fns(a, wrong_no_na, wrong_no_nb, tracebytecodedn); - break; - } - } - qenv(a) = qcdr(b); - } - else if (qcar(b) == lambda) - { Lisp_Object bvl = qcar(qcdr(b)); - int nargs = 0; - while (consp(bvl)) nargs++, bvl = qcdr(bvl); - qheader(a) = qheader(a) & ~SYM_MACRO; - if ((qheader(a) & SYM_TRACED) != 0) - set_fns(a, traceinterpreted1, traceinterpreted2, traceinterpretedn); - else set_fns(a, interpreted1, interpreted2, interpretedn); - qenv(a) = qcdr(b); - if (qvalue(comp_symbol) != nil && - qfn1(compiler_symbol) != undefined1) - { push(a); - a = ncons(a); - errexitn(1); - (qfn1(compiler_symbol))(qenv(compiler_symbol), a); - pop(a); - errexit(); - } - } - else if (qcar(b) == funarg) - { Lisp_Object bvl = qcar(qcdr(b)); - int nargs = 0; - while (consp(bvl)) nargs++, bvl = qcdr(bvl); - qheader(a) = qheader(a) & ~SYM_MACRO; - if ((qheader(a) & SYM_TRACED) != 0) - set_fns(a, tracefunarged1, tracefunarged2, tracefunargedn); - else set_fns(a, funarged1, funarged2, funargedn); - qenv(a) = qcdr(b); - } - else return aerror1("symbol-set-definition", b); - return onevalue(b); -} - -Lisp_Object Lgetd(Lisp_Object nil, Lisp_Object a) -{ - Header h; - Lisp_Object type; - CSL_IGNORE(nil); - if (a == nil) return onevalue(nil); - else if (!is_symbol(a)) return onevalue(nil); - h = qheader(a); - if ((h & SYM_SPECIAL_FORM) != 0) type = fexpr_symbol; - else if ((h & SYM_MACRO) != 0) - { a = cons(lambda, qenv(a)); - errexit(); - type = macro_symbol; - } - else - { a = Lsymbol_function(nil, a); - errexit(); - if (a == nil) return onevalue(nil); - type = expr_symbol; - } - a = cons(type, a); - errexit(); - return onevalue(a); -} - -Lisp_Object Lremd(Lisp_Object nil, Lisp_Object a) -{ - Lisp_Object res; - CSL_IGNORE(nil); - if (!is_symbol(a) || - (qheader(a) & SYM_SPECIAL_FORM) != 0) - return aerror1("remd", a); - if ((qheader(a) & (SYM_C_DEF | SYM_CODEPTR)) == - (SYM_C_DEF | SYM_CODEPTR)) return onevalue(nil); - res = Lgetd(nil, a); - errexit(); - if (res == nil) return onevalue(nil); /* no definition to remove */ -/* - * I treat an explicit use of remd as a redefinition, and ensure that - * restarting a preserved image will not put the definition back. - */ - qheader(a) = qheader(a) & ~SYM_MACRO; - if ((qheader(a) & SYM_C_DEF) != 0) lose_C_def(a); - set_fns(a, undefined1, undefined2, undefinedn); - qenv(a) = a; - return onevalue(res); -} - -/* - * For set-autoload the first argument must be a symbol that will name - * a function, the second arg is either an atom or a list of atoms, each - * of which specified a module to be loaded if the names function is - * called. Loading the modules is expected to instate a definition for the - * function involved. This function is arranged so it does NOT do anything - * if the function being set for autoloading is already defined. This is - * on the supposition that the existing definition is in fact the desired - * one, say because the relevant module happens to have been loaded already. - * An explicit use of remd first can be used to ensure that no previous - * definition is present and thus that a real autoload stub will be instated, - * if that is what you really want. - */ - -Lisp_Object Lset_autoload(Lisp_Object nil, Lisp_Object a, Lisp_Object b) -{ - Lisp_Object res; - CSL_IGNORE(nil); - if (!is_symbol(a) || - (qheader(a) & SYM_SPECIAL_FORM) != 0) - return aerror1("set-autoload", a); - if (!(qfn1(a) == undefined1 && qfn2(a) == undefined2 && - qfnn(a) == undefinedn)) return onevalue(nil); - if ((qheader(a) & (SYM_C_DEF | SYM_CODEPTR)) == - (SYM_C_DEF | SYM_CODEPTR)) return onevalue(nil); - push2(a, b); - if (consp(b)) res = cons(a, b); - else res = list2(a, b); - pop2(b, a); - errexit(); -/* - * I treat an explicit use of set-autoload as a redefinition, and ensure that - * restarting a preserved image will not put the definition back. Note that - * I will not allow autoloadable macros... - */ - qheader(a) = qheader(a) & ~SYM_MACRO; - if ((qheader(a) & SYM_C_DEF) != 0) lose_C_def(a); - set_fns(a, autoload1, autoload2, autoloadn); - qenv(a) = res; - return onevalue(res); -} - -#define pack_funtable(a, n) ((((int32)(a)) << 16) | (n)) -#define funtable_nargs(u) ((u) >> 16) -#define funtable_index(u) ((u) & 0xffffU) - -static one_args *displaced1 = NULL; -static two_args *displaced2; -static n_args *displacedn; -static unsigned32 table_entry; - -static void trace_entering(char *s) -{ - int i; - for (i=0; i 15 args: not supported"); - } - popv(nargs); - pop(name); - errexit(); - push(r); - freshline_trace(); - loop_print_trace(name); - trace_printf(" = "); - loop_print_trace(r); - trace_exiting("\n"); - pop(r); - return onevalue(r); -} - -#define NOT_FOUND 100 - -static unsigned32 find_built_in_function(one_args *f1, - two_args *f2, - n_args *fn) -/* - * This take the entrypoint of a function and tries to identify it - * by scanning the tables used by the bytecode interpreter. If the - * function is found a record is returned indicating how many args - * it takes, and what its index is in the relevant table. The code - * is returned to indicate failure if the function - * is not found. - */ -{ - int32 index; - for (index=0; zero_arg_functions[index]!=NULL; index++) - if (fn == zero_arg_functions[index]) return pack_funtable(0, index); - for (index=0; one_arg_functions[index]!=NULL; index++) - if (f1 == one_arg_functions[index]) return pack_funtable(1, index); - for (index=0; two_arg_functions[index]!=NULL; index++) - if (f2 == two_arg_functions[index]) return pack_funtable(2, index); - for (index=0; three_arg_functions[index]!=NULL; index++) - if (fn == three_arg_functions[index]) return pack_funtable(3, index); - return pack_funtable(NOT_FOUND, NOT_FOUND); -} - -Lisp_Object Ltrace_all(Lisp_Object nil, Lisp_Object a) -{ -#ifdef DEBUG - if (a == nil) trace_all = 0; - else trace_all = 1; - return onevalue(nil); -#else - return aerror("trace-all only supported in DEBUG version"); -#endif -} - -Lisp_Object Ltrace(Lisp_Object nil, Lisp_Object a) -{ - Lisp_Object w = a; - if (symbolp(a)) - { a = ncons(a); - errexit(); - w = a; - } - while (consp(w)) - { Lisp_Object s = qcar(w); - w = qcdr(w); - if (symbolp(s)) - { one_args *f1 = qfn1(s); - two_args *f2 = qfn2(s); - n_args *fn = qfnn(s); - int fixenv = 0, done = 0; - if (f1 == undefined1) - { freshline_debug(); - debug_printf("+++ "); - loop_print_debug(s); - debug_printf(" not yet defined\n"); - continue; - } - qheader(s) |= SYM_TRACED; - if (f1 == interpreted1) - { set_fns(s, traceinterpreted1, traceinterpreted2, traceinterpretedn); - fixenv = done = 1; - } - if (f1 == funarged1) - { set_fns(s, tracefunarged1, tracefunarged2, tracefunargedn); - fixenv = done = 1; - } - if (fn == bytecoded0) ifnn(s) = (int32)tracebytecoded0, done = 1; - if (f1 == bytecoded1) ifn1(s) = (int32)tracebytecoded1, done = 1; - if (f2 == bytecoded2) ifn2(s) = (int32)tracebytecoded2, done = 1; - if (fn == bytecoded3) ifnn(s) = (int32)tracebytecoded3, done = 1; - if (fn == bytecodedn) ifnn(s) = (int32)tracebytecodedn, done = 1; - if (f1 == byteopt1) ifn1(s) = (int32)tracebyteopt1, done = 1; - if (f2 == byteopt2) ifn2(s) = (int32)tracebyteopt2, done = 1; - if (fn == byteoptn) ifnn(s) = (int32)tracebyteoptn, done = 1; - if (f1 == hardopt1) ifn1(s) = (int32)tracehardopt1, done = 1; - if (f2 == hardopt2) ifn2(s) = (int32)tracehardopt2, done = 1; - if (fn == hardoptn) ifnn(s) = (int32)tracehardoptn, done = 1; - if (f1 == byteoptrest1) ifn1(s) = (int32)tracebyteoptrest1, done = 1; - if (f2 == byteoptrest2) ifn2(s) = (int32)tracebyteoptrest2, done = 1; - if (fn == byteoptrestn) ifnn(s) = (int32)tracebyteoptrestn, done = 1; - if (f1 == hardoptrest1) ifn1(s) = (int32)tracehardoptrest1, done = 1; - if (f2 == hardoptrest2) ifn2(s) = (int32)tracehardoptrest2, done = 1; - if (fn == hardoptrestn) ifnn(s) = (int32)tracehardoptrestn, done = 1; - if (fixenv) - { push2(a, s); - a = cons(s, qenv(s)); - errexitn(2); - pop(s); - qenv(s) = a; - pop(a); - } - if (done) continue; -/* - * I permit the tracing of just one function from the kernel, and achieve - * this by installing a wrapper function in place of the real definition. - * Indeed this is just like Lisp-level embedding, except that I can get at the - * entrypoint table used by the bytecode interpreter and so trap calls made - * via there, and I can use that table to tell me how many arguments the - * traced function needed. - */ - if (displaced1 == NULL) - { int nargs = funtable_nargs(table_entry); -/* - * Remember what function was being traced, so that it can eventually be - * invoked, and its name printed. - */ - displaced1 = f1; - displaced2 = f2; - displacedn = fn; - tracedfn = s; -/* - * This makes calls via the regular interpreter see the traced version... - */ - set_fns(s, traced1_function, traced2_function, - tracedn_function); - table_entry = find_built_in_function(f1, f2, fn); - nargs = funtable_nargs(table_entry); - table_entry = funtable_index(table_entry); - if (nargs != NOT_FOUND) - { -/* - * .. and now I make calls via short-form bytecodes do likewise. - */ - switch (nargs) - { - default: - case 0: zero_arg_functions[funtable_index(table_entry)] = - tracedn_function; - break; - case 1: one_arg_functions[funtable_index(table_entry)] = - traced1_function; - break; - case 2: two_arg_functions[funtable_index(table_entry)] = - traced2_function; - break; - case 3: three_arg_functions[funtable_index(table_entry)] = - tracedn_function; - break; - } - } - } - continue; - } - } - return onevalue(a); -} - -Lisp_Object Luntrace(Lisp_Object nil, Lisp_Object a) -{ - Lisp_Object w = a; - CSL_IGNORE(nil); - if (symbolp(a)) - { a = ncons(a); - errexit(); - w = a; - } - while (consp(w)) - { Lisp_Object s = qcar(w); - w = qcdr(w); - if (symbolp(s)) - { one_args *f1 = qfn1(s); - two_args *f2 = qfn2(s); - n_args *fn = qfnn(s); - if (f1 == traceinterpreted1) - { set_fns(a, interpreted1, interpreted2, interpretedn); - qenv(s) = qcdr(qenv(s)); - } - else if (f1 == tracefunarged1) - { set_fns(s, funarged1, funarged2, funargedn); - qenv(s) = qcdr(qenv(s)); - } - if (f1 == tracebytecoded1) ifn1(s) = (int32)bytecoded1; - if (f2 == tracebytecoded2) ifn2(s) = (int32)bytecoded2; - if (fn == tracebytecoded0) ifnn(s) = (int32)bytecoded0; - if (fn == tracebytecoded3) ifnn(s) = (int32)bytecoded3; - if (fn == tracebytecodedn) ifnn(s) = (int32)bytecodedn; - if (f1 == tracebyteopt1) ifn1(s) = (int32)byteopt1; - if (f2 == tracebyteopt2) ifn2(s) = (int32)byteopt2; - if (fn == tracebyteoptn) ifnn(s) = (int32)byteoptn; - if (f1 == tracebyteoptrest1) ifn1(s) = (int32)byteoptrest1; - if (f2 == tracebyteoptrest2) ifn2(s) = (int32)byteoptrest2; - if (fn == tracebyteoptrestn) ifnn(s) = (int32)byteoptrestn; - if (f1 == tracehardopt1) ifn1(s) = (int32)hardopt1; - if (f2 == tracehardopt2) ifn2(s) = (int32)hardopt2; - if (fn == tracehardoptn) ifnn(s) = (int32)hardoptn; - if (f1 == tracehardoptrest1) ifn1(s) = (int32)hardoptrest1; - if (f2 == tracehardoptrest2) ifn2(s) = (int32)hardoptrest2; - if (fn == tracehardoptrestn) ifnn(s) = (int32)hardoptrestn; - if (f1 == traced1_function) - { int nargs = funtable_nargs(table_entry); - set_fns(s, displaced1, displaced2, displacedn); - if (nargs != NOT_FOUND) - switch (nargs) - { - default: - case 0: zero_arg_functions[funtable_index(table_entry)] = - displacedn; - break; - case 1: one_arg_functions[funtable_index(table_entry)] = - displaced1; - break; - case 2: two_arg_functions[funtable_index(table_entry)] = - displaced2; - break; - case 3: three_arg_functions[funtable_index(table_entry)] = - displacedn; - break; - } - displaced1 = NULL; - displaced2 = NULL; - displacedn = NULL; - } - qheader(s) &= ~SYM_TRACED; - } - } - return onevalue(a); -} - -Lisp_Object Ldouble(Lisp_Object nil, Lisp_Object a) -{ - Lisp_Object w = a; - if (symbolp(a)) - { a = ncons(a); - errexit(); - w = a; - } - while (consp(w)) - { Lisp_Object s = qcar(w); - w = qcdr(w); - if (symbolp(s)) - { one_args *f1 = qfn1(s); - two_args *f2 = qfn2(s); - n_args *fn = qfnn(s); - int fixenv = 0, done = 0; - if (f1 == undefined1) continue; - if (f1 == interpreted1) - { set_fns(s, double_interpreted1, double_interpreted2, double_interpretedn); - fixenv = done = 1; - } - if (f1 == funarged1) - { set_fns(s, double_funarged1, double_funarged2, double_funargedn); - fixenv = done = 1; - } - if (fn == bytecoded0) ifnn(s) = (int32)double_bytecoded0, done = 1; - if (f1 == bytecoded1) ifn1(s) = (int32)double_bytecoded1, done = 1; - if (f2 == bytecoded2) ifn2(s) = (int32)double_bytecoded2, done = 1; - if (fn == bytecoded3) ifnn(s) = (int32)double_bytecoded3, done = 1; - if (fn == bytecodedn) ifnn(s) = (int32)double_bytecodedn, done = 1; - if (f1 == byteopt1) ifn1(s) = (int32)double_byteopt1, done = 1; - if (f2 == byteopt2) ifn2(s) = (int32)double_byteopt2, done = 1; - if (fn == byteoptn) ifnn(s) = (int32)double_byteoptn, done = 1; - if (f1 == hardopt1) ifn1(s) = (int32)double_hardopt1, done = 1; - if (f2 == hardopt2) ifn2(s) = (int32)double_hardopt2, done = 1; - if (fn == hardoptn) ifnn(s) = (int32)double_hardoptn, done = 1; - if (f1 == byteoptrest1) ifn1(s) = (int32)double_byteoptrest1, done = 1; - if (f2 == byteoptrest2) ifn2(s) = (int32)double_byteoptrest2, done = 1; - if (fn == byteoptrestn) ifnn(s) = (int32)double_byteoptrestn, done = 1; - if (f1 == hardoptrest1) ifn1(s) = (int32)double_hardoptrest1, done = 1; - if (f2 == hardoptrest2) ifn2(s) = (int32)double_hardoptrest2, done = 1; - if (fn == hardoptrestn) ifnn(s) = (int32)double_hardoptrestn, done = 1; - if (fixenv) - { push2(a, s); - a = cons(s, qenv(s)); - errexitn(2); - pop(s); - qenv(s) = a; - pop(a); - } - if (done) continue; - debug_printf("Unable to execution-double: "); loop_print_debug(s); - trace_printf("\n"); - continue; - } - } - return onevalue(a); -} - -Lisp_Object Lundouble(Lisp_Object nil, Lisp_Object a) -{ - Lisp_Object w = a; - CSL_IGNORE(nil); - if (symbolp(a)) - { a = ncons(a); - errexit(); - w = a; - } - while (consp(w)) - { Lisp_Object s = qcar(w); - w = qcdr(w); - if (symbolp(s)) - { one_args *f1 = qfn1(s); - two_args *f2 = qfn2(s); - n_args *fn = qfnn(s); - if (f1 == double_interpreted1) - { set_fns(a, interpreted1, interpreted2, interpretedn); - qenv(s) = qcdr(qenv(s)); - } - else if (f1 == double_funarged1) - { set_fns(s, funarged1, funarged2, funargedn); - qenv(s) = qcdr(qenv(s)); - } - else if (f1 == double_bytecoded1) ifn1(s) = (int32)bytecoded1; - else if (f2 == double_bytecoded2) ifn2(s) = (int32)bytecoded2; - else if (fn == double_bytecoded0) ifnn(s) = (int32)bytecoded0; - else if (fn == double_bytecoded3) ifnn(s) = (int32)bytecoded3; - else if (fn == double_bytecodedn) ifnn(s) = (int32)bytecodedn; - else if (f1 == double_byteopt1) ifn1(s) = (int32)byteopt1; - else if (f2 == double_byteopt2) ifn2(s) = (int32)byteopt2; - else if (fn == double_byteoptn) ifnn(s) = (int32)byteoptn; - else if (f1 == double_byteoptrest1) ifn1(s) = (int32)byteoptrest1; - else if (f2 == double_byteoptrest2) ifn2(s) = (int32)byteoptrest2; - else if (fn == double_byteoptrestn) ifnn(s) = (int32)byteoptrestn; - else if (f1 == double_hardopt1) ifn1(s) = (int32)hardopt1; - else if (f2 == double_hardopt2) ifn2(s) = (int32)hardopt2; - else if (fn == double_hardoptn) ifnn(s) = (int32)hardoptn; - else if (f1 == double_hardoptrest1) ifn1(s) = (int32)hardoptrest1; - else if (f2 == double_hardoptrest2) ifn2(s) = (int32)hardoptrest2; - else if (fn == double_hardoptrestn) ifnn(s) = (int32)hardoptrestn; - } - } - return onevalue(a); -} - -Lisp_Object Lmacro_function(Lisp_Object nil, Lisp_Object a) -{ - if (!symbolp(a)) return onevalue(nil); - else if ((qheader(a) & SYM_MACRO) == 0) return onevalue(nil); -/* If the MACRO bit is set in the header I know there is a definition */ - else return onevalue(cons(lambda, qenv(a))); -} - - -Lisp_Object get_pname(Lisp_Object a) -{ - Lisp_Object name = qpname(a); -#ifndef COMMON -/* - * When a gensym is first created its pname field points at a string that - * will form the base of its name, and a magic bit is set in its header. - * If at some stage it is necessary to inspect the print name (mainly in - * order to print the symbol) it becomes necessary to create a new string - * and insert a serial number. Doing things this way means that the serial - * numbers that users see will tend to be smaller, and space for per-gensym - * strings does not get allocated unless really needed. The down side is - * that every time I want to grab the pname of anything I have to check for - * this case and admit the possibility of garbage collection or even - * failure. - */ - if (qheader(a) & SYM_UNPRINTED_GENSYM) - { unsigned32 len; - Lisp_Object nil = C_nil; - char genname[64]; - len = length_of_header(vechdr(name)) - 4; - if (len > 60) len = 60; /* Unpublished truncation of the string */ - sprintf(genname, "%.*s%lu", (int)len, - (char *)name + (4 - TAG_VECTOR), (long)gensym_ser++); - push(a); - name = make_string(genname); - pop(a); - errexit(); - qpname(a) = name; - qheader(a) &= ~SYM_UNPRINTED_GENSYM; - } -#endif - return name; -} - -Lisp_Object Lsymbol_name(Lisp_Object nil, Lisp_Object a) -{ - if (!symbolp(a)) return aerror1("symbol-name", a); - a = get_pname(a); - errexit(); - return onevalue(a); -} - -#ifdef COMMON - -Lisp_Object Lsymbol_package(Lisp_Object nil, Lisp_Object a) -{ - if (!symbolp(a)) return aerror1("symbol-package", a); - a = qpackage(a); - return onevalue(a); -} - -#endif - -static Lisp_Object Lrestart_csl2(Lisp_Object nil, - Lisp_Object a, Lisp_Object b) -/* - * If the argument is given as nil then this is a cold-start, and when - * I begin again it would be a VERY good idea to do a (load!-module 'compat) - * rather promptly (otherwise some Lisp functions will not work at all). - * I do not automate that because this function is intended for use in - * delicate system rebuilding contexts and I want the user to have ultimate - * control. (restart!-csl t) reloads a heap-image in the normal way. - * (restart!-csl 'xx) where xx is neither nil nor t starts by reloading a - * heap image, but then it looks for a function with the same name as xx - * (since a heap image is reloaded it is NOT easy (possible?) to keep the - * symbol) and calls it as a function. Finally the case - * (restart!-csl '(module fn)) restart the system, then calls load-module - * on the named module and finally calls the given restart function. - * This last option can be useful since otherwise the function to be called - * in (restart!-csl 'xx) would need to be in the base image as re-loaded. - */ -{ - int n; - char *v; -#ifdef SOCKETS -/* - * Security measure - deny restart-csl to remote users - */ - if (socket_server != 0) return aerror("restart-csl"); -#endif - n = 0; - v = NULL; -/* - * A comment seems in order here. The case b==SPID_NOARG should only - * arise if I came from Lrestart_csl: it indicates that there was - * no second argument provided. - */ - if (b != SPID_NOARG) - { Lisp_Object b1 = b = Lexploden(nil, b); - errexit(); - while (b1 != nil) - { n++; /* number of chars of arg */ - b1 = qcdr(b1); - } - v = (char *)malloc(n+1); - if (v == NULL) return aerror("space exhausted in restart-csl"); - n = 0; - while (b != nil) - { v[n++] = int_of_fixnum(qcar(b)); - b = qcdr(b); - } - v[n] = 0; - } - term_printf("\nThe system is about to do a restart...\n"); -/* Almost all unpicking of the argument is done back in csl.c */ - exit_value = a; - exit_tag = fixnum_of_int(2); /* Flag to say "restart" */ - exit_reason = UNWIND_RESTART; - exit_charvec = v; - flip_exception(); - return nil; -} - -static Lisp_Object Lrestart_csl(Lisp_Object nil, Lisp_Object a) -{ - return Lrestart_csl2(nil, a, SPID_NOARG); -} - -static Lisp_Object Lpreserve(Lisp_Object nil, - Lisp_Object startup, Lisp_Object banner) -/* - * (preserve ) saves a Lisp image in a standard place - * and arranges that when restarted the saved image will call the specified - * startup function. In the process of doing all this it unwinds down to - * the top level of Lisp. If a startup function is not given then the - * previously active one is used. If nil is specified then the previously - * active startup function is retained. If banner is non-nil (well really - * I want a string) is is a message of up to 40 characters to display - * when the system restart. - */ -{ - char filename[LONGEST_LEGAL_FILENAME]; - CSLbool failed; -#ifdef SOCKETS -/* - * Security measure - deny preserve to remote users - */ - if (socket_server != 0) return aerror("preserve"); -#endif - if (startup != nil) supervisor = startup; - failed = Iwriterootp(filename); /* Can I open image file for writing? */ - term_printf("\nThe system will be preserved on file \"%s\"\n", filename); - if (failed) return aerror("preserve"); - exit_count = 0; - nil = C_nil; - exit_value = banner; - exit_tag = fixnum_of_int(1); /* Flag to say "preserve" */ - exit_reason = UNWIND_RESTART; - flip_exception(); - return nil; -} - -static Lisp_Object MS_CDECL Lpreserve_0(Lisp_Object nil, int nargs, ...) -{ - argcheck(nargs, 0, "preserve"); - return Lpreserve(nil, nil, nil); -} - -static Lisp_Object Lpreserve_1(Lisp_Object nil, Lisp_Object startup) -{ - return Lpreserve(nil, startup, nil); -} - - -/* - * This is an experimental addition - a version of PRESERVE that allows - * CSL to continue executing after it has written out an image file. - */ - -static Lisp_Object Lcheckpoint(Lisp_Object nil, - Lisp_Object startup, Lisp_Object banner) -{ - char filename[LONGEST_LEGAL_FILENAME]; - CSLbool failed = 0; - char *msg = ""; -#ifdef SOCKETS -/* - * Security measure - deny checkpoint to remote users - */ - if (socket_server != 0) return aerror("checkpoint"); -#endif - if (startup != nil) supervisor = startup; - failed = Iwriterootp(filename); /* Can I open image file for writing? */ - term_printf("\nThe system will be preserved on file \"%s\"\n", filename); - if (failed) return aerror("checkpoint"); - if (is_vector(banner) && - type_of_header(vechdr(banner)) == TYPE_STRING) - msg = &celt(banner, 0); -/* - * Note, with some degree of nervousness, that things on the C stack will - * be updated by the garbage collection that happens during the processing - * of the call to preserve(), but they will be neither adjusted into - * relative addresses nor unadjusted (and hence restored) by in the - * image-writing. But the image writing will not actually move any data - * around so all is still OK, I hope! - */ - push5(codevec, litvec, catch_tags, faslvec, faslgensyms); - preserve(msg); - nil = C_nil; - if (exception_pending()) failed = 1, flip_exception(); - adjust_all(); - pop5(faslgensyms, faslvec, catch_tags, litvec, codevec); - eq_hash_tables = eq_hash_table_list; - equal_hash_tables = equal_hash_table_list; - eq_hash_table_list = equal_hash_table_list = nil; - { Lisp_Object qq; - for (qq = eq_hash_tables; qq!=nil; qq=qcdr(qq)) - rehash_this_table(qcar(qq)); - for (qq = equal_hash_tables; qq!=nil; qq=qcdr(qq)) - rehash_this_table(qcar(qq)); - } - set_up_functions(YES); - if (failed) return aerror("checkpoint"); - return onevalue(nil); -} - -static Lisp_Object MS_CDECL Lcheckpoint_0(Lisp_Object nil, int nargs, ...) -{ - argcheck(nargs, 0, "checkpoint"); - return Lcheckpoint(nil, nil, nil); -} - -static Lisp_Object Lcheckpoint_1(Lisp_Object nil, Lisp_Object startup) -{ - return Lcheckpoint(nil, startup, nil); -} - - -#ifdef COMMON -static CSLbool eql_numbers(Lisp_Object a, Lisp_Object b) -/* - * This is only called from eql, and then only when a and b are both tagged - * as ratios or complex numbers. - */ -{ - Lisp_Object p, q; - p = *(Lisp_Object *)(a + (4 - TAG_NUMBERS)); - q = *(Lisp_Object *)(b + (4 - TAG_NUMBERS)); - if (!eql(p, q)) return NO; - p = *(Lisp_Object *)(a + (8 - TAG_NUMBERS)); - q = *(Lisp_Object *)(b + (8 - TAG_NUMBERS)); - return eql(p, q); -} -#endif - -CSLbool eql_fn(Lisp_Object a, Lisp_Object b) -/* - * This seems incredible - all the messing about that is needed to - * check that numeric values compare properly. Ugh. - */ -{ -/* - * (these tests done before eql_fn is called). - * if (a == b) return YES; - * if ((((int32)a ^ (int32)b) & TAG_BITS) != 0) return NO; - * - * Actually in Common Lisp mode where I have short floats as immediate data - * I have further pain here with (eql 0.0 -0.0). - */ -#ifdef COMMON - if ((a == TAG_SFLOAT && b == (TAG_SFLOAT|0x80000000)) || - (a == (TAG_SFLOAT|0x80000000) && b == TAG_SFLOAT) return YES; -#endif - if (!is_number(a) || is_immed_or_cons(a)) return NO; - if (is_bfloat(a)) - { Header h = flthdr(a); - if (h != flthdr(b)) return NO; - h = length_of_header(h); -#ifdef COMMON - if (h == 8) /* Single float */ - { -#ifdef OLD_CODE - if (*(int32 *)(a + (4 - TAG_BOXFLOAT)) != - *(int32 *)(b + (4 - TAG_BOXFLOAT))) return NO; - else return YES; -#else - return (single_float_val(a) == single_float_val(b)); -#endif - } - else -#endif -/* - * For the moment I view all non-single floats as double floats. Extra - * stuff will be needed here if I ever implement long floats as 3-word - * objects. - */ - { -#ifdef OLD_CODE - if ((*(int32 *)((char *)a + (8 - TAG_BOXFLOAT)) != - *(int32 *)((char *)b + (8 - TAG_BOXFLOAT))) || - (*(int32 *)((char *)a + (12 - TAG_BOXFLOAT)) != - *(int32 *)((char *)b + (12 - TAG_BOXFLOAT)))) return NO; - else return YES; -#else - return (double_float_val(a) == double_float_val(b)); -#endif - } - } - else /* ratio, complex or bignum */ - { Header h = numhdr(a); - if (h != numhdr(b)) return NO; - if (type_of_header(h) == TYPE_BIGNUM) - { int32 hh = (int32)length_of_header(h) - TAG_NUMBERS; - while (hh > (4 - TAG_NUMBERS)) - { hh -= 4; - if (*(Lisp_Object *)((char *)a + hh) != - *(Lisp_Object *)((char *)b + hh)) - return NO; - } - return YES; - } -#ifdef COMMON - else return eql_numbers(a, b); -#else - else return NO; -#endif - } -} - -static CSLbool cl_vec_equal(Lisp_Object a, Lisp_Object b) -/* - * here a and b are known to be vectors or arrays. This should compare - * them following the Common Lisp recipe, where strings or bitvectors - * (simple or complex) have their contents compared, while all other types of - * vector or array are tested using EQ. - */ -{ - Header ha = vechdr(a), hb = vechdr(b); - int32 offa = 0, offb = 0; - int ta = type_of_header(ha), tb = type_of_header(hb); - int32 la = length_of_header(ha), lb = length_of_header(hb); -#ifdef COMMON - if (header_of_bitvector(ha)) ta = TYPE_BITVEC1; - if (header_of_bitvector(hb)) tb = TYPE_BITVEC1; -#endif - switch (ta) - { -/* -case TYPE_ARRAY: -/* My moan here is that, as noted above, I ought to process even - * non-simple strings and bit-vectors by comparing contents, but as a - * matter of idleness I have not yet got around to that. In fact if I get - * arrays to compare here I will pretend that they are not strings or - * bit-vectors and compare using EQ... - */ -case TYPE_STRING: - switch (tb) - { -/* /* - case TYPE_ARRAY: -*/ - case TYPE_STRING: - goto compare_strings; - default:return NO; - } -#ifdef COMMON -case TYPE_BITVEC1: - switch (tb) - { -/* /* - case TYPE_ARRAY: -*/ - case TYPE_BITVEC1: - goto compare_bits; - default:return NO; - } -#endif -default: return (a == b); - } -compare_strings: - if (la != lb) return NO; - while (la > 0) - { la--; - if (*((char *)a + la + offa - TAG_VECTOR) != - *((char *)b + la + offb - TAG_VECTOR)) return NO; - } - return YES; -#ifdef COMMON -compare_bits: - if (la != lb) return NO; - while (la > 0) - { la--; - if (*((char *)a + la + offa - TAG_VECTOR) != - *((char *)b + la + offb - TAG_VECTOR)) return NO; - } - return YES; -#endif -} - -CSLbool cl_equal_fn(Lisp_Object a, Lisp_Object b) -/* - * a and b are not EQ at this stage.. I guarantee to have checked that - * before entering this general purpose code. - */ -{ - Lisp_Object nil = C_nil; - CSL_IGNORE(nil); -/* - * The for loop at the top here is so that cl_equal can iterate along the - * length of linear lists. - */ -#ifdef CHECK_STACK - if (check_stack(__FILE__,__LINE__)) - { err_printf("Stack too deep in cl_equal\n"); - my_exit(EXIT_FAILURE); - } -#endif - for (;;) - { - int32 ta = (int32)a & TAG_BITS; - if (ta == TAG_CONS -#ifdef COMMON - && a != nil -#endif - ) - { if (!consp(b) -#ifdef COMMON - || b == nil -#endif - ) return NO; - else - { Lisp_Object ca = qcar(a), cb = qcar(b); - if (ca == cb) - { a = qcdr(a); - b = qcdr(b); - if (a == b) return YES; - continue; - } -/* - * And here, because cl_equal() seems to be a very important low-level - * primitive, I unwind one level of the recursion that would arise - * with nested lists. - */ - for (;;) - { - int32 tca = (int32)ca & TAG_BITS; - if (tca == TAG_CONS -#ifdef COMMON - && ca != nil -#endif - ) - { if (!consp(cb) -#ifdef COMMON - || cb == nil -#endif - ) return NO; - else - { Lisp_Object cca = qcar(ca), ccb = qcar(cb); - if (cca == ccb) - { ca = qcdr(ca); - cb = qcdr(cb); - if (ca == cb) break; - continue; - } -/* - * Do a real recursion when I get down to args like - * ((x ...) ...) ((y ...) ...) - */ - if (!cl_equal(cca, ccb)) return NO; - ca = qcdr(ca); - cb = qcdr(cb); - if (ca == cb) break; - continue; - } - } - else if (tca <= TAG_SYMBOL || - ((int32)cb & TAG_BITS) != tca) return NO; - else switch (tca) - { - case TAG_NUMBERS: - { Header h = numhdr(ca); - if (h != numhdr(cb)) return NO; - if (type_of_header(h) == TYPE_BIGNUM) - { int32 hh = (int32)length_of_header(h) - TAG_NUMBERS; - while (hh > (4 - TAG_NUMBERS)) - { hh -= 4; - if (*(Lisp_Object *)((char *)ca + hh) != - *(Lisp_Object *)((char *)cb + hh)) - return NO; - } - break; - } -#ifdef COMMON - else if (!eql_numbers(ca, cb)) return NO; - else break; -#else - else return NO; -#endif - } - case TAG_VECTOR: - if (!cl_vec_equal(ca, cb)) return NO; - break; - default: - case TAG_BOXFLOAT: - { Header h = flthdr(ca); - if (h != flthdr(cb)) return NO; - h = length_of_header(h); -#ifdef COMMON - if (h == 8) /* Single float */ - { -#ifdef OLD_CODE - if (*(int32 *)(ca + (4 - TAG_BOXFLOAT)) != - *(int32 *)(cb + (4 - TAG_BOXFLOAT))) - return NO; -#else - if (single_float_val(ca) != - single_float_val(cb)) return NO; -#endif - else break; - } - else -#endif - { -#ifdef OLD_CODE - if ((*(int32 *)((char *)ca + - (8 - TAG_BOXFLOAT)) != - *(int32 *)((char *)cb + - (8 - TAG_BOXFLOAT))) || - (*(int32 *)((char *)ca + - (12 - TAG_BOXFLOAT)) != - *(int32 *)((char *)cb + - (12 - TAG_BOXFLOAT)))) return NO; -#else - if (double_float_val(ca) != - double_float_val(cb)) return NO; -#endif - else break; - } - } - } - break; /* out of the for (;;) loop */ - } - a = qcdr(a); - b = qcdr(b); - if (a == b) return YES; - continue; - } - } - else if (ta <= TAG_SYMBOL || - ((int32)b & TAG_BITS) != ta) return NO; - else switch (ta) - { - case TAG_NUMBERS: - { Header h = numhdr(a); - if (h != numhdr(b)) return NO; - if (type_of_header(h) == TYPE_BIGNUM) - { int32 hh = (int32)length_of_header(h) - TAG_NUMBERS; - while (hh > (4 - TAG_NUMBERS)) - { hh -= 4; - if (*(Lisp_Object *)((char *)a + hh) != - *(Lisp_Object *)((char *)b + hh)) - return NO; - } - return YES; - } -#ifdef COMMON - else return eql_numbers(a, b); - -#else - else return NO; -#endif - } - case TAG_VECTOR: - return cl_vec_equal(a, b); - default: - case TAG_BOXFLOAT: - { Header h = flthdr(a); - if (h != flthdr(b)) return NO; - h = length_of_header(h); -#ifdef COMMON - if (h == 8) /* Single float */ - { -#ifdef OLD_CODE - if (*(int32 *)(a + (4 - TAG_BOXFLOAT)) != - *(int32 *)(b + (4 - TAG_BOXFLOAT))) return NO; -#else - if (single_float_val(a) != single_float_val(b)) - return NO; -#endif - else return YES; - } - else -#endif -/* - * For the moment I view all non-single floats as double floats. Extra - * stuff will be needed here if I ever implement long floats as 3-word - * objects. - */ - { -#ifdef OLD_CODE - if ((*(int32 *)((char *)a + (8 - TAG_BOXFLOAT)) != - *(int32 *)((char *)b + (8 - TAG_BOXFLOAT))) || - (*(int32 *)((char *)a + (12 - TAG_BOXFLOAT)) != - *(int32 *)((char *)b + (12 - TAG_BOXFLOAT)))) - return NO; -#else - if (double_float_val(a) != double_float_val(b)) - return NO; -#endif - else return YES; - } - } - } - } -} - -static CSLbool vec_equal(Lisp_Object a, Lisp_Object b); - -#ifdef TRACED_EQUAL -#define LOG_SIZE 10000 -typedef struct equal_record -{ - char file[24]; - int line; - int depth; - int count; -} equal_record; - -static equal_record equal_counts[LOG_SIZE]; - -static void record_equal(char *file, int line, int depth) -{ - int hash = 169*line + depth; - char *p = file; - while (*p != 0) hash = 168*hash + (*p++ & 0xff); - hash = ((169*hash) & 0x7fffffff) % LOG_SIZE; - while (equal_counts[hash].count != 0) - { if (equal_counts[hash].line == line && - equal_counts[hash].depth == depth && - strncmp(equal_counts[hash].file, file, 24) == 0) - { equal_counts[hash].count++; - return; - } - hash = (hash + 1) % LOG_SIZE; - } - strncpy(equal_counts[hash].file, file, 24); - equal_counts[hash].line = line; - equal_counts[hash].depth = depth; - equal_counts[hash].count = 1; - return; -} - -void dump_equals() -{ - int i; - FILE *log = fopen("equal.log", "w"); - if (log == NULL) log = stdout; - fprintf(log, "\nCalls to equal...\n"); - for (i=0; i (4 - TAG_NUMBERS)) - { hh -= 4; - if (*(Lisp_Object *)((char *)ca + hh) != - *(Lisp_Object *)((char *)cb + hh)) - return NO; - } - break; - } -#ifdef COMMON - else if (!eql_numbers(ca, cb)) return NO; - else break; -#else - else return NO; -#endif - } - case TAG_VECTOR: - if (!vec_equal(ca, cb)) return NO; - break; - default: - case TAG_BOXFLOAT: - { Header h = flthdr(ca); - if (h != flthdr(cb)) return NO; - h = length_of_header(h); -#ifdef COMMON - if (h == 8) /* Single float */ - { -#ifdef OLD_CODE - if (*(int32 *)(ca + (4 - TAG_BOXFLOAT)) != - *(int32 *)(cb + (4 - TAG_BOXFLOAT))) - return NO; -#else - if (single_float_val(ca) != - single_float_val(cb)) return NO; -#endif - else break; - } - else -#endif - { -#ifdef OLD_CODE - if ((*(int32 *)((char *)ca + - (8 - TAG_BOXFLOAT)) != - *(int32 *)((char *)cb + - (8 - TAG_BOXFLOAT))) || - (*(int32 *)((char *)ca + - (12 - TAG_BOXFLOAT)) != - *(int32 *)((char *)cb + - (12 - TAG_BOXFLOAT)))) return NO; -#else - if (double_float_val(ca) != - double_float_val(cb)) return NO; -#endif - - else break; - } - } - } - break; /* out of the for (;;) loop */ - } - a = qcdr(a); - b = qcdr(b); - if (a == b) return YES; - continue; - } - } - else if (ta <= TAG_SYMBOL || - ((int32)b & TAG_BITS) != ta) return NO; - else switch (ta) - { - case TAG_NUMBERS: - { Header h = numhdr(a); - if (h != numhdr(b)) return NO; - if (type_of_header(h) == TYPE_BIGNUM) - { int32 hh = (int32)length_of_header(h) - TAG_NUMBERS; - while (hh > (4 - TAG_NUMBERS)) - { hh -= 4; - if (*(Lisp_Object *)((char *)a + hh) != - *(Lisp_Object *)((char *)b + hh)) - return NO; - } - return YES; - } -#ifdef COMMON - else return eql_numbers(a, b); - -#else - else return NO; -#endif - } - case TAG_VECTOR: - return vec_equal(a, b); - default: - case TAG_BOXFLOAT: - { Header h = flthdr(a); - if (h != flthdr(b)) return NO; - h = length_of_header(h); -#ifdef COMMON - if (h == 8) /* Single float */ - { -#ifdef OLD_CODE - if (*(int32 *)(a + (4 - TAG_BOXFLOAT)) != - *(int32 *)(b + (4 - TAG_BOXFLOAT))) return NO; -#else - if (single_float_val(a) != single_float_val(b)) - return NO; -#endif - else return YES; - } - else -#endif -/* - * For the moment I view all non-single floats as double floats. Extra - * stuff will be needed here if I ever implement long floats as 3-word - * objects. - */ - { -#ifdef OLD_CODE - if ((*(int32 *)((char *)a + (8 - TAG_BOXFLOAT)) != - *(int32 *)((char *)b + (8 - TAG_BOXFLOAT))) || - (*(int32 *)((char *)a + (12 - TAG_BOXFLOAT)) != - *(int32 *)((char *)b + (12 - TAG_BOXFLOAT)))) - return NO; -#else - if (double_float_val(a) != double_float_val(b)) - return NO; -#endif - else return YES; - } - } - } - } -} - -#ifdef TRACED_EQUAL -#undef equal_fn -#define equal_fn(a, b) traced_equal(a, b, __FILE__, __LINE__, 0) -#endif - -static CSLbool vec_equal(Lisp_Object a, Lisp_Object b) -/* - * Here a and b are known to be vectors. Compare using recursive calls to - * EQUAL on all components. - */ -{ - Header ha = vechdr(a), hb = vechdr(b); - int32 l; - if (ha != hb) return NO; - l = (int32)doubleword_align_up(length_of_header(ha)); - if (vector_holds_binary(ha)) - { while ((l -= 4) != 0) - if (*((int32 *)((char *)a + l - TAG_VECTOR)) != - *((int32 *)((char *)b + l - TAG_VECTOR))) return NO; - return YES; - } - else - { if (is_mixed_header(ha)) - { while (l > 16) - { unsigned32 ea = *((unsigned32 *)((char *)a + l - TAG_VECTOR - 4)), - eb = *((unsigned32 *)((char *)b + l - TAG_VECTOR - 4)); - if (ea != eb) return NO; - l -= 4; - } - } - while ((l -= 4) != 0) - { Lisp_Object ea = *((Lisp_Object *)((char *)a + l - TAG_VECTOR)), - eb = *((Lisp_Object *)((char *)b + l - TAG_VECTOR)); - if (ea == eb) continue; - if (!equal(ea, eb)) return NO; - } - return YES; - } -} - -CSLbool equalp(Lisp_Object a, Lisp_Object b) -/* - * a and b are not EQ at this stage.. I guarantee to have checked that - * before entering this general purpose code. - */ -{ - Lisp_Object nil = C_nil; - CSL_IGNORE(nil); -/* - * The for loop at the top here is so that equalp can iterate along the - * length of linear lists. - */ -#ifdef CHECK_STACK - if (check_stack(__FILE__,__LINE__)) - { err_printf("Stack too deep in equalp\n"); - my_exit(EXIT_FAILURE); - } -#endif - for (;;) - { - int32 ta = (int32)a & TAG_BITS; - if (ta == TAG_CONS -#ifdef COMMON - && a != nil -#endif - ) - { if (!consp(b) -#ifdef COMMON - || b == nil -#endif - ) return NO; - else - { Lisp_Object ca = qcar(a), cb = qcar(b); - if (ca == cb) - { a = qcdr(a); - b = qcdr(b); - if (a == b) return YES; - continue; - } -/* - * And here, because equalp() seems to be a very important low-level - * primitive, I unwind one level of the recursion that would arise - * with nested lists. - */ - for (;;) - { - int32 tca = (int32)ca & TAG_BITS; - if (tca == TAG_CONS -#ifdef COMMON - && ca != nil -#endif - ) - { if (!consp(cb) -#ifdef COMMON - || cb == nil -#endif - ) return NO; - else - { Lisp_Object cca = qcar(ca), ccb = qcar(cb); - if (cca == ccb) - { ca = qcdr(ca); - cb = qcdr(cb); - if (ca == cb) break; - continue; - } -/* - * Do a real recursion when I get down to args like - * ((x ...) ...) ((y ...) ...) - */ - if (!equalp(cca, ccb)) return NO; - ca = qcdr(ca); - cb = qcdr(cb); - if (ca == cb) break; - continue; - } - } - else if (tca <= TAG_SYMBOL || - ((int32)cb & TAG_BITS) != tca) return NO; - else switch (tca) - { - case TAG_NUMBERS: - { Header h = numhdr(ca); - if (h != numhdr(cb)) return NO; - if (type_of_header(h) == TYPE_BIGNUM) - { int32 hh = (int32)length_of_header(h) - TAG_NUMBERS; - while (hh > (4 - TAG_NUMBERS)) - { hh -= 4; - if (*(Lisp_Object *)((char *)ca + hh) != - *(Lisp_Object *)((char *)cb + hh)) - return NO; - } - break; - } -#ifdef COMMON - else if (!eql_numbers(ca, cb)) return NO; - else break; -#else - else return NO; -#endif - } - case TAG_VECTOR: -/* /* At present vec_equal() is not right here */ - if (!vec_equal(ca, cb)) return NO; - break; - default: - case TAG_BOXFLOAT: - { Header h = flthdr(ca); - if (h != flthdr(cb)) return NO; - h = length_of_header(h); -#ifdef COMMON - if (h == 8) /* Single float */ - { -#ifdef OLD_CODE - if (*(int32 *)(ca + (4 - TAG_BOXFLOAT)) != - *(int32 *)(cb + (4 - TAG_BOXFLOAT))) - return NO; -#else - if (single_float_val(ca) != - single_float_val(cb)) return NO; -#endif - - else break; - } - else -#endif - { -#ifdef OLD_CODE - if ((*(int32 *)((char *)ca + - (8 - TAG_BOXFLOAT)) != - *(int32 *)((char *)cb + - (8 - TAG_BOXFLOAT))) || - (*(int32 *)((char *)ca + - (12 - TAG_BOXFLOAT)) != - *(int32 *)((char *)cb + - (12 - TAG_BOXFLOAT)))) return NO; -#else - if (double_float_val(ca) != - double_float_val(cb)) return NO; -#endif - else break; - } - } - } - break; /* out of the for (;;) loop */ - } - a = qcdr(a); - b = qcdr(b); - if (a == b) return YES; - continue; - } - } - else if (ta <= TAG_SYMBOL || - ((int32)b & TAG_BITS) != ta) return NO; - else switch (ta) - { - case TAG_NUMBERS: - { Header h = numhdr(a); - if (h != numhdr(b)) return NO; - if (type_of_header(h) == TYPE_BIGNUM) - { int32 hh = (int32)length_of_header(h) - TAG_NUMBERS; - while (hh > (4 - TAG_NUMBERS)) - { hh -= 4; - if (*(Lisp_Object *)((char *)a + hh) != - *(Lisp_Object *)((char *)b + hh)) - return NO; - } - return YES; - } -#ifdef COMMON - else return eql_numbers(a, b); - -#else - else return NO; -#endif - } - case TAG_VECTOR: -/* /* wrong for Common Lisp */ - return vec_equal(a, b); - default: - case TAG_BOXFLOAT: - { Header h = flthdr(a); - if (h != flthdr(b)) return NO; - h = length_of_header(h); -#ifdef COMMON - if (h == 8) /* Single float */ - { -#ifdef OLD_CODE - if (*(int32 *)(a + (4 - TAG_BOXFLOAT)) != - *(int32 *)(b + (4 - TAG_BOXFLOAT))) return NO; -#else - if (single_float_val(a) != single_float_val(b)) - return NO; -#endif - else return YES; - } - else -#endif -/* - * For the moment I view all non-single floats as double floats. Extra - * stuff will be needed here if I ever implement long floats as 3-word - * objects. - */ - { -#ifdef OLD_CODE - if ((*(int32 *)((char *)a + (8 - TAG_BOXFLOAT)) != - *(int32 *)((char *)b + (8 - TAG_BOXFLOAT))) || - (*(int32 *)((char *)a + (12 - TAG_BOXFLOAT)) != - *(int32 *)((char *)b + (12 - TAG_BOXFLOAT)))) - return NO; -#else - if (double_float_val(a) != double_float_val(b)) - return NO; -#endif - - else return YES; - } - } - } - } -} - -Lisp_Object Leq(Lisp_Object nil, Lisp_Object a, Lisp_Object b) -{ - return onevalue(Lispify_predicate(a == b)); -} - -Lisp_Object Leql(Lisp_Object nil, - Lisp_Object a, Lisp_Object b) -{ - return onevalue(Lispify_predicate(eql(a, b))); -} - -Lisp_Object Leqcar(Lisp_Object nil, - Lisp_Object a, Lisp_Object b) -{ - if (!consp(a)) return onevalue(nil); - a = qcar(a); -#ifdef COMMON - return onevalue(Lispify_predicate(eql(a, b))); -#else - return onevalue(Lispify_predicate(a == b)); -#endif -} - -Lisp_Object Lequalcar(Lisp_Object nil, - Lisp_Object a, Lisp_Object b) -{ - if (!consp(a)) return onevalue(nil); - a = qcar(a); - if (a == b) return lisp_true; - else return onevalue(Lispify_predicate(equal(a, b))); -} - -Lisp_Object Lcl_equal(Lisp_Object nil, Lisp_Object a, Lisp_Object b) -{ - if (a == b) return onevalue(lisp_true); - else return onevalue(Lispify_predicate(cl_equal(a, b))); -} - -Lisp_Object Lequal(Lisp_Object nil, Lisp_Object a, Lisp_Object b) -{ - if (a == b) return onevalue(lisp_true); - else return onevalue(Lispify_predicate(equal(a, b))); -} - -Lisp_Object Lequalp(Lisp_Object nil, Lisp_Object a, Lisp_Object b) -{ - if (a == b) return onevalue(lisp_true); - else return onevalue(Lispify_predicate(equalp(a, b))); -} - -Lisp_Object Lneq(Lisp_Object nil, - Lisp_Object a, Lisp_Object b) -{ - CSLbool r; -#ifdef COMMON - r = cl_equal(a, b); -#else - r = equal(a, b); -#endif - return onevalue(Lispify_predicate(!r)); -} - -Lisp_Object Lnull(Lisp_Object nil, Lisp_Object a) -{ - return onevalue(Lispify_predicate(a == nil)); -} - -Lisp_Object Lendp(Lisp_Object nil, Lisp_Object a) -{ - if (a == nil) return onevalue(lisp_true); - else if (is_cons(a)) return onevalue(nil); - else return error(1, err_bad_endp, a); -} - -Lisp_Object Lnreverse(Lisp_Object nil, Lisp_Object a) -{ - Lisp_Object b = nil; -#ifdef COMMON - if (is_vector(a)) - { int32 n = Llength(nil, a) - 0x10; - int32 i = TAG_FIXNUM; - while (n > i) - { Lisp_Object w = Laref2(nil, a, i); - Laset(nil, 3, a, i, Laref2(nil, a, n)); - Laset(nil, 3, a, n, w); - i += 0x10; - n -= 0x10; - } - return onevalue(a); - } -#endif - while (consp(a)) - { Lisp_Object c = a; - a = qcdr(a); - qcdr(c) = b; - b = c; - } - return onevalue(b); -} - -#ifdef COMMON - -/* - * nreverse0 is like nreverse except that if its input is atomic it gets - * returned intact rather than being converted to nil. - */ - -Lisp_Object Lnreverse0(Lisp_Object nil, Lisp_Object a) -{ - Lisp_Object b = nil; - if (!consp(a)) return onevalue(a); - b = a; - a = qcdr(a); - qcdr(b) = nil; - while (consp(a)) - { Lisp_Object c = a; - a = qcdr(a); - qcdr(c) = b; - b = c; - } - return onevalue(b); -} - -#endif - -Lisp_Object Lreverse(Lisp_Object nil, Lisp_Object a) -{ - Lisp_Object r; - stackcheck1(0, a); - nil = C_nil; - r = nil; - while (consp(a)) - { push(a); - r = cons(qcar(a), r); - pop(a); - errexit(); - a = qcdr(a); - } - return onevalue(r); -} - -Lisp_Object Lassoc(Lisp_Object nil, Lisp_Object a, Lisp_Object b) -{ -#ifdef TRACED_EQUAL - Lisp_Object save_b = b; - int pos = 0; -#endif - if (is_symbol(a) || is_fixnum(a)) - { while (consp(b)) - { Lisp_Object c = qcar(b); - if (consp(c) && a == qcar(c)) return onevalue(c); - b = qcdr(b); - } - return onevalue(nil); - } - while (consp(b)) - { Lisp_Object c = qcar(b); - if (consp(c)) - { Lisp_Object cc = qcar(c); -#ifdef COMMON - if (cl_equal(a, cc)) return onevalue(c); -#else - if (equal(a, cc)) - { -#ifdef TRACED_EQUAL - trace_printf("Assoc YES %3d %3d ", pos, int_of_fixnum(Llength(nil,save_b))); - prin_to_stdout(a); trace_printf("\n"); -#endif - return onevalue(c); - } -#endif - } - b = qcdr(b); -#ifdef TRACED_EQUAL - pos++; -#endif - } -#ifdef TRACED_EQUAL - trace_printf("Assoc NO %3d %3d ", pos, int_of_fixnum(Llength(nil,save_b))); - prin_to_stdout(a); trace_printf("\n"); -#endif - return onevalue(nil); -} - -Lisp_Object Latsoc(Lisp_Object nil, Lisp_Object a, Lisp_Object b) -{ -#ifdef COMMON - if (is_symbol(a) || is_fixnum(a)) - { while (consp(b)) - { Lisp_Object c = qcar(b); - if (consp(c) && a == qcar(c)) return onevalue(c); - b = qcdr(b); - } - return onevalue(nil); - } -#endif - while (consp(b)) - { Lisp_Object c = qcar(b); -/* - * eql() can neither fail nor call the garbage collector, so I do - * not need to stack things here. - */ -#ifdef COMMON - if (consp(c) && eql(a, qcar(c))) return onevalue(c); -#else - if (consp(c) && a == qcar(c)) return onevalue(c); -#endif - b = qcdr(b); - } - return onevalue(nil); -} - -Lisp_Object Lmember(Lisp_Object nil, Lisp_Object a, Lisp_Object b) -{ - if (is_symbol(a) || is_fixnum(a)) - { while (consp(b)) - { if (a == qcar(b)) return onevalue(b); - b = qcdr(b); - } - return onevalue(nil); - } - while (consp(b)) - { Lisp_Object cb = qcar(b); -#ifdef COMMON - if (cl_equal(a, cb)) return onevalue(b); -#else - if (equal(a, cb)) return onevalue(b); -#endif - b = qcdr(b); - } - return onevalue(nil); -} - -Lisp_Object Lmemq(Lisp_Object nil, Lisp_Object a, Lisp_Object b) -{ -#ifdef COMMON - if (is_symbol(a) || is_fixnum(a)) - { while (consp(b)) - { if (a == qcar(b)) return onevalue(b); - b = qcdr(b); - } - return onevalue(nil); - } -#endif - while (consp(b)) -/* - * Note that eql() can never fail, and so checking for errors - * and stacking a and b across the call to it is not necessary. - */ - { -#ifdef COMMON - if (eql(a, qcar(b))) return onevalue(b); -#else - if (a == qcar(b)) return onevalue(b); -#endif - b = qcdr(b); - } - return onevalue(nil); -} - -static CSLbool smemq(Lisp_Object a, Lisp_Object b) -{ -/* - * /* This is a bit worrying - it can use C recursion to arbitrary - * depth without any checking for overflow, and hence it can ESCAPE - * if (e.g.) given cyclic structures. Some alteration is needed. As - * things stand the code can never give wrong answers via GC rearrangement - - * the problem is closer to being that it can never call the GC. - */ -#ifdef COMMON - Lisp_Object nil = C_nil; -#else - nil_as_base -#endif - while (consp(b)) - { Lisp_Object w = qcar(b); - if (w == quote_symbol) return NO; - else if (smemq(a, w)) return YES; - else b = qcdr(b); - } - return (a == b); -} - -Lisp_Object Lsmemq(Lisp_Object nil, Lisp_Object a, Lisp_Object b) -{ - CSLbool r; - r = smemq(a, b); - errexit(); - return onevalue(Lispify_predicate(r)); -} - -/* - * (defun contained (x y) - * (cond ((atom y) (equal x y)) - * ((equal x y) 't) - * ('t (or (contained x (car y)) (contained x (cdr y)))))) - */ - -static CSLbool containedeq(Lisp_Object nil, Lisp_Object x, Lisp_Object y) -{ - while (consp(y)) - { if (containedeq(nil, x, qcar(y))) return YES; - y = qcdr(y); - } - return (x == y); -} - -static CSLbool containedequal(Lisp_Object nil, Lisp_Object x, Lisp_Object y) -{ - while (consp(y)) - { if (equal(x, y)) return YES; - if (containedequal(nil, x, qcar(y))) return YES; - y = qcdr(y); - } - return equal(x, y); -} - -static Lisp_Object Lcontained(Lisp_Object nil, Lisp_Object x, Lisp_Object y) -{ - CSLbool r; - if (is_symbol(x) || is_fixnum(x)) r = containedeq(nil, x, y); - else r = containedequal(nil, x, y); - errexit(); - return onevalue(Lispify_predicate(r)); -} - -Lisp_Object Llast(Lisp_Object nil, Lisp_Object a) -{ - Lisp_Object b; - if (!consp(a)) return aerror1("last", a); - while (b = qcdr(a), consp(b)) a = b; - return onevalue(qcar(a)); -} - -Lisp_Object Llastpair(Lisp_Object nil, Lisp_Object a) -{ - Lisp_Object b; - if (!consp(a)) return onevalue(a); /* aerror1("lastpair", a); */ - while (b = qcdr(a), consp(b)) a = b; - return onevalue(a); -} - -Lisp_Object Llength(Lisp_Object nil, Lisp_Object a) -{ - if (a == nil) return onevalue(fixnum_of_int(0)); - if (is_cons(a)) - { Lisp_Object n; -/* - * Possibly I should do something to trap cyclic lists.. ? - */ - n = fixnum_of_int(1); -/* - * I have unrolled the loop here 4 times since I expect length to be - * tolerably heavily used. Look at the assembly code generated for - * this to see if it was useful or counterproductive! - */ - for (;;) - { a = qcdr(a); - if (!consp(a)) return onevalue(n); - a = qcdr(a); - if (!consp(a)) return onevalue((Lisp_Object)((int32)n + (1 << 4))); - a = qcdr(a); - if (!consp(a)) return onevalue((Lisp_Object)((int32)n + (2 << 4))); - a = qcdr(a); - if (!consp(a)) return onevalue((Lisp_Object)((int32)n + (3 << 4))); - n = (Lisp_Object)((int32)n + (4 << 4)); - } - } -#ifndef COMMON - return onevalue(fixnum_of_int(0)); /* aerror("length");??? */ -#else -/* - * Common Lisp expects length to find the length of vectors - * as well as lists. - */ - else if (!is_vector(a)) return aerror1("length", a); - else - { Header h = vechdr(a); - int32 n = length_of_header(h) - 4; - if (type_of_header(h) == TYPE_ARRAY) - { Lisp_Object dims = elt(a, 1); - Lisp_Object fillp = elt(a, 5); - if (consp(dims) && !consp(qcdr(dims))) dims = qcar(dims); - else return aerror1("length", a); /* Not one-dimensional */ - if (is_fixnum(fillp)) dims = fillp; - return onevalue(dims); - } - if (header_of_bitvector(h)) - { n = (n - 1)*8; -/* Dodgy constant on next line - critically dependent on tag codes used! */ - n += ((h & 0x380) >> 7) + 1; - } - else if (type_of_header(h) != TYPE_STRING) n = n >> 2; - return onevalue(fixnum_of_int(n)); - } -#endif -} - -#ifdef COMMON - -Lisp_Object MS_CDECL Lappend_n(Lisp_Object nil, int nargs, ...) -{ - va_list a; - int i; - Lisp_Object r; - if (nargs == 0) return onevalue(nil); - va_start(a, nargs); - push_args(a, nargs); -/* - * The actual args have been passed a C args - I can not afford to - * risk garbage collection until they have all been moved somewhere safe, - * and here that safe place is the Lisp stack. I have to delay checking for - * overflow on same until all args have been pushed. - */ - stackcheck0(nargs); - nil = C_nil; - r = nil; -/* - * rearrange order of items on the stack... - * The idea is that I will then reverse-copy the args in the order a1, - * a2 , ... to make a result list. But I want to pop the stack as soon as - * I can, so I need arg1 on the TOP of the stack. - */ - for (i = 0; 2*i+1 +#include +#include + +#include "machine.h" +#include "tags.h" +#include "cslerror.h" +#include "externs.h" +#include "read.h" +#include "entries.h" +#include "arith.h" +#ifdef COMMON +#include "clsyms.h" +#endif +#ifdef TIMEOUT +#include "timeout.h" +#endif + +#ifdef SOCKETS +#include "sockhdr.h" +#endif + +Lisp_Object getcodevector(int32 type, int32 size) +{ +/* + * type is the code (e.g. TYPE_BPS) that gets packed, together with + * the size, into a header word. + * size is measured in bytes and must allow space for the header word. + * This obtains space in the BPS area + */ + Lisp_Object nil = C_nil; +#ifdef CHECK_FOR_CORRUPT_HEAP + validate_all(); +#endif + for (;;) + { int32 alloc_size = (int32)doubleword_align_up(size); + char *cf = (char *)codefringe, *cl = (char *)codelimit; + unsigned int free = cf - cl; + char *r; + if (alloc_size > (int32)free) + { char msg[40]; + sprintf(msg, "codevector %ld", (long)size); + reclaim(nil, msg, GC_BPS, alloc_size); + errexit(); + continue; + } + r = cf - alloc_size; + codefringe = (Lisp_Object)r; + *((Header *)r) = type + (size << 10) + TAG_ODDS; + return TAG_BPS + + (((int32)(r - cl + 12) & (PAGE_POWER_OF_TWO-4)) << 6) + + (((int32)(bps_pages_count-1))<<(PAGE_BITS+6)); /* Wow! Obscure!! */ + } +} + +Lisp_Object Lget_bps(Lisp_Object nil, Lisp_Object n) +{ + int32 n1; + if (!is_fixnum(n) || (int32)n<0) return aerror1("get-bps", n); + n1 = int_of_fixnum(n); + n = getcodevector(TYPE_BPS, n1+4); + errexit(); + return onevalue(n); +} + +Lisp_Object get_native_code_vector(int32 size) +{ +/* + * Create some space for native code and return a handle that identifies + * its start point. size is measured in bytes. + */ + Lisp_Object nil = C_nil; + if (size <= 0) size = 8; + for (;;) + { int32 alloc_size = (int32)doubleword_align_up(size); + int32 cf = native_fringe; + int32 free = CSL_PAGE_SIZE - cf - 0x100; /* 256 bytes to be safe */ +/* + * When I start up a cold CSL I will have native_fringe set to zero and + * native_pages_count also zero, indicating that there is none of this stuff + * active. + */ + if (native_fringe == 0 || alloc_size > free) + { char msg[40]; + sprintf(msg, "native code %ld", (long)size); + reclaim(nil, msg, GC_NATIVE, alloc_size); + errexit(); + continue; + } + free = (int32)native_pages[native_pages_count-1]; + free = doubleword_align_up(free); +/* + * I put the number of bytes in this block as the first word of the chunk + * of memory, and arrange that there is a zero in what would be the first + * word of unused space. Provided the user does not clobber bytes 0 to 4 + * or the block this is enough to allow restart code to scan through all + * native code segments. + */ + *(int32 *)(free+native_fringe) = alloc_size; + *(int32 *)(free+native_fringe+alloc_size) = 0; + native_fringe += alloc_size; + native_pages_changed = 1; + return Lcons(nil, + fixnum_of_int(native_pages_count-1), + fixnum_of_int(cf)); + } +} + +Lisp_Object Lget_native(Lisp_Object nil, Lisp_Object n) +{ + int32 n1; + if (!is_fixnum(n) || (int32)n<0) return aerror1("get-native", n); + n1 = int_of_fixnum(n); + n = get_native_code_vector(n1); + errexit(); + return onevalue(n); +} + +int do_not_kill_native_code = 0; + +void set_fns(Lisp_Object a, one_args *f1, two_args *f2, n_args *fn) +{ + Lisp_Object nil = C_nil; + Lisp_Object w1, w2, w3 = nil; +/* + * If I redefine a function for any reason (except to set trace options + * on a bytecoded definition) I will discard any native-coded definitions + * by splicing them out of the record. I provide a global variable to + * defeat this behaviour (ugh). + */ + if (!do_not_kill_native_code) + { for (w1 = native_code; w1!=nil; w1=qcdr(w1)) + { w2 = qcar(w1); + if (qcar(w2) == a) break; + w3 = w1; + } + if (w1 != nil) + { w1 = qcdr(w1); + if (w3 == nil) native_code = w1; + else qcdr(w3) = w1; + } + } + if ((qheader(a) & (SYM_C_DEF | SYM_CODEPTR)) == + (SYM_C_DEF | SYM_CODEPTR)) + { +#ifdef NOISY_RE_PROTECTED_FNS + trace_printf("+++ protected function "); + prin_to_trace(a); + trace_printf(" not redefined\n"); +#endif + return; + } + ifn1(a) = (int32)f1; + ifn2(a) = (int32)f2; + ifnn(a) = (int32)fn; +} + +#ifdef HIDE_USELESS_SYMBOL_ENVIRONMENTS + +static CSLbool interpreter_entry(Lisp_Object a) +/* + * If a function will be handled by the interpreter, including the case + * of it being undefined, then the fn1() cell will tell me so. + */ +{ + return ( + qfn1(a) == interpreted1 || + qfn1(a) == traceinterpreted1 || + qfn1(a) == double_interpreted1 || + qfn1(a) == funarged1 || + qfn1(a) == tracefunarged1 || + qfn1(a) == double_funarged1 || + qfn1(a) == undefined1); +} + +#endif + +static char *show_fn(void *p) +{ + int i; + for (i=0; i MAX_FASTGET_SIZE)) return aerror1("symbol-make-fastget", a); + term_printf("+++ Fastget size was %d, now %d\n", n1, n); + fastget_size = n; + return onevalue(fixnum_of_int(n1)); +} + +Lisp_Object Lsymbol_make_fastget(Lisp_Object nil, Lisp_Object a, Lisp_Object n) +{ + int32 n1, p, q; + Header h; + if (!symbolp(a)) return onevalue(nil); + h = qheader(a); + p = header_fastget(h); + if (is_fixnum(n)) + { n1 = int_of_fixnum(n); + if (n1 < -1 || n1 >= fastget_size) + return aerror1("symbol-make-fastget", n); + trace_printf("+++ Use fastget slot %d for ", n1); + loop_print_trace(a); + errexit(); + trace_printf("\n"); + if (p != 0) elt(fastget_names, p-1) = SPID_NOPROP; + q = (n1 + 1) & 0x3f; + h = (h & ~SYM_FASTGET_MASK) | (q << SYM_FASTGET_SHIFT); + qheader(a) = h; + if (q != 0) elt(fastget_names, q-1) = a; + } + if (p == 0) return onevalue(nil); + else return onevalue(fixnum_of_int(p - 1)); +} + +static Lisp_Object deleqip(Lisp_Object a, Lisp_Object l) +/* + * This deletes the item a (tested for using EQ) from the list l, + * assuming that the list is nil-terminated and that the item a + * occurs at most once. It overwrites the list l in the process. + */ +{ + Lisp_Object nil = C_nil, w, r; + if (l == nil) return nil; + if (qcar(l) == a) return qcdr(l); + r = l; + while (w = l, (l = qcdr(l)) != nil) + { if (qcar(l) == a) + { qcdr(w) = qcdr(l); + return r; + } + } + return r; +} + +void lose_C_def(Lisp_Object a) +{ +/* + * None of the code here can cause garbage collection. + */ +#ifdef COMMON + Lisp_Object nil = C_nil; + Lisp_Object b = get(a, unset_var, nil), c; +#else + nil_as_base + Lisp_Object b = get(a, unset_var), c; +#endif + Lremprop(C_nil, a, unset_var); + qheader(a) &= ~SYM_C_DEF; +#ifdef COMMON + c = get(b, work_symbol, nil); +#else + c = get(b, work_symbol); +#endif + c = deleqip(a, c); + if (c == C_nil) Lremprop(C_nil, b, work_symbol); + else putprop(b, work_symbol, c); +} + +/* + * (symbol-set-native fn args bpsbase offset env) + * where bpsbase is as handed back by (make-native nnn) and offset is + * the offset in this block to enter at. + * If args has the actual arg count in its bottom byte. Usually the + * rest of it will be zero, and then one function cell is set to point to the + * given entrypoint and the other two are set to point at error handlers. + * If any bits in args beyond that are set then this call only changes the + * directly specified function cell, and the others are left in whatever state + * they were. If several of the fuction cells are to be filled in (eg to cope + * with &optional or &rest arguments) then a simple call with args<256 must + * be made first, followed by the calls (args>=256) that fill in the other + * two cells. + * The first time that symbol-set-native is called on a function that + * function MUST have a byte coded definition, and this definition is + * picked up and stored away, so that if (preserve) is called the bytecoded + * definition will be available for use on systems with different + * architectures. To make things tolerably consistent with that any operation + * that installs a new bytecoded (or for that matter other) definition + * will clear away any native-compiled versions of the function. + * + * The native code that is installed will be expected to have relocation + * records starting at the start of bpsbase, and these will be activated, + * filling in references from the bps to other executable parts of Lisp. + * Passing bad arguments to this function provide a quick and easy way to + * cayse UTTER havoc. Therefore I disable its use in server applications. + */ + +Lisp_Object MS_CDECL Lsymbol_set_native(Lisp_Object nil, int nargs, ...) +{ + va_list a; + Lisp_Object fn, args, bpsbase, offset, env, w1, w2, w3; + int32 pagenumber, page, bps, address, t_p, arginfo; +#ifdef SOCKETS +/* + * Security measure - deny symbol-set-native to remote users + */ + if (socket_server != 0) return aerror("symbol-set-native"); +#endif + argcheck(nargs, 5, "symbol-set-native"); + va_start(a, nargs); + fn = va_arg(a, Lisp_Object); + args = va_arg(a, Lisp_Object); + bpsbase = va_arg(a, Lisp_Object); + offset = va_arg(a, Lisp_Object); + env = va_arg(a, Lisp_Object); + va_end(a); + if (!is_symbol(fn) || + (qheader(fn) & (SYM_SPECIAL_FORM | SYM_CODEPTR)) != 0) + return aerror1("symbol-set-native", fn); + if (!is_fixnum(args)) return aerror1("symbol-set-native", args); + if (!consp(bpsbase) || + !is_fixnum(qcar(bpsbase)) || + !is_fixnum(qcdr(bpsbase))) + return aerror1("symbol-set-native", bpsbase); + if (!is_fixnum(offset)) return aerror1("symbol-set-native", offset); + nargs = int_of_fixnum(args); + pagenumber = int_of_fixnum(qcar(bpsbase)); + if (pagenumber<0 || pagenumber>=native_pages_count) + return aerror1("symbol-set-native", bpsbase); + bps = int_of_fixnum(qcdr(bpsbase)); + address = bps+int_of_fixnum(offset); + if (address<8 || address>=CSL_PAGE_SIZE) + return aerror1("symbol-set-native", offset); + page = (int32)native_pages[pagenumber]; + page = doubleword_align_up(page); + bps = page + bps; + relocate_native_function((unsigned char *)bps); +/* + * Here I need to push the info I have just collected onto + * the native_code list since otherwise things will not be re-loaded in + * from a checkpoint image. Also if the function is at present byte-coded + * I need to record that info about it in native_code. + */ + w1 = native_code; + while (w1!=nil) + { w2 = qcar(w1); + if (qcar(w2) == fn) break; + w1 = qcdr(w1); + } + if (w1 == nil) + { +/* + * Here the function has not been seen as native code ever before, so it has + * not been entered into the list. Do something about that... + */ + push2(env, fn); + args = Lsymbol_argcount(nil, fn); + errexitn(2); + if (args == nil) + return aerror1("No bytecode definition found for", fn); +/* + * Now I have to reverse the information that symbol_argcount gave me + * to get the single numeric code as wanted by symbol_set_definition. + * Oh what a mess. + */ + if (is_fixnum(args)) arginfo = int_of_fixnum(args); + else + { arginfo = int_of_fixnum(qcar(args)); + args = qcdr(args); + arginfo |= ((int_of_fixnum(qcar(args)) - arginfo) << 8); + args = qcdr(args); + arginfo |= int_of_fixnum(qcar(args)) << 16; + } + fn = stack[0]; + w2 = list2(fn, fixnum_of_int(arginfo)); + errexitn(2); + w2 = cons(w2, native_code); + errexitn(2); + native_code = w2; + w2 = qcar(w2); + pop2(fn, env); + } + w2 = qcdr(w2); /* {nargs,(type . offset . env),...} */ +/* + * If I was defining this function in the simple way I should clear any + * previous version (for this machine architecture) from the record. + * Just at present this does not release the memory, but at some stage + * in the future I may arrange to compact away old code when I do a + * preserve operation (say). + */ + if (nargs <= 0xff) + { w1 = w3 = w2; + for (w1=qcdr(w2); w1!=nil; w1=qcdr(w1)) + { w3 = qcar(w1); + if (qcar(w3) == fixnum_of_int(native_code_tag)) break; + w3 = w1; + } + if (w1 != nil) qcdr(w3) = qcdr(w1); + } +/* + * w2 is still the entry for this function in the native code list. It + * needs to have an entry of type 0 (ie for bytecoded) and so the next + * thing to do is to check that such an entry exists and if not to create + * it. + */ + w1 = w2; + while ((w1 = qcdr(w1)) != nil) + { w3 = qcar(w1); + if (qcar(w3) == fixnum_of_int(0)) break; + w1 = qcdr(w1); + } + if (w1 == nil) + { +/* + * This is where there was no bytecode entry on the native code list + * for this function, so I had better create one for it. Note that only + * one such entry will ever be stored so it does not matter much where on + * the list it goes. I suspect that the list ought always to be empty + * in this case anyway. + */ + push3(fn, env, w2); + w1 = list2star(fixnum_of_int(0), fixnum_of_int(0), qenv(fn)); + errexitn(3); + w2 = stack[0]; + w1 = cons(w1, qcdr(w2)); + errexitn(3); + pop3(w2, env, fn); + qcdr(w2) = w1; + } +/* + * Now the list of native code associated with this function certainly holds + * a byte-coded definition (and for sanity that had better be consistent + * with the native code I am installing now, but that is not something + * that can be checked at this level). Put in an entry referring to the + * current gubbins. + */ + push3(w2, fn, env); +/* + * now I pack the code type, arg category and offset into the + * single fixnum that that information has to end up in. + */ + t_p = (native_code_tag << 20); + if ((nargs & 0xffffff00) != 0) + { + switch (nargs & 0xff) + { + case 1: t_p |= (1<<18); break; + case 2: t_p |= (2<<18); break; + default:t_p |= (3<<18); break; + } + } + t_p |= (pagenumber & 0x3ffff); + w1 = list2star(fixnum_of_int(t_p), fixnum_of_int(address), env); + errexitn(3); + w1 = ncons(w1); + pop3(env, fn, w2); + errexit(); + while ((w3 = qcdr(w2)) != nil) w2 = w3; /* Tag onto the END */ + qcdr(w2) = w1; + qheader(fn) &= ~SYM_TRACED; + address = page + address; +/* + * The code here must do just about the equivalent to that in restart.c + */ + switch (nargs & 0xff) + { +case 0: ifnn(fn) = address; + if (nargs<=0xff) + ifn1(fn) = (int32)wrong_no_0a, ifn2(fn) = (int32)wrong_no_0b; + break; +case 1: ifn1(fn) = address; + if (nargs<=0xff) + ifn2(fn) = (int32)too_many_1, ifnn(fn) = (int32)wrong_no_1; + break; +case 2: ifn2(fn) = address; + if (nargs<=0xff) + ifn1(fn) = (int32)too_few_2, ifnn(fn) = (int32)wrong_no_2; + break; +case 3: ifnn(fn) = address; + if (nargs<=0xff) + ifn1(fn) = (int32)wrong_no_3a, ifn2(fn) = (int32)wrong_no_3b; + break; +default: ifnn(fn) = address; + if (nargs<=0xff) + ifn1(fn) = (int32)wrong_no_na, ifn2(fn) = (int32)wrong_no_nb; + break; + } + qenv(fn) = env; + return onevalue(fn); +} + +static CSLbool restore_fn_cell(Lisp_Object a, char *name, + int32 len, setup_type const s[]) +{ + int i; + for (i=0; s[i].name != NULL; i++) + { if (strlen(s[i].name) == len && + memcmp(name, s[i].name, len) == 0) break; + } + if (s[i].name == NULL) return NO; + set_fns(a, s[i].one, s[i].two, s[i].n); + return YES; +} + +static Lisp_Object Lrestore_c_code(Lisp_Object nil, Lisp_Object a) +{ + char *name; + int32 len; + Lisp_Object pn; + if (!symbolp(a)) return aerror1("restore-c-code", a); + push(a); + pn = get_pname(a); + pop(a); + errexit(); + name = (char *)&celt(pn, 0); + len = length_of_header(vechdr(pn)) - 4; + if (restore_fn_cell(a, name, len, u01_setup) || + restore_fn_cell(a, name, len, u02_setup) || + restore_fn_cell(a, name, len, u03_setup) || + restore_fn_cell(a, name, len, u04_setup) || + restore_fn_cell(a, name, len, u05_setup) || + restore_fn_cell(a, name, len, u06_setup) || + restore_fn_cell(a, name, len, u07_setup) || + restore_fn_cell(a, name, len, u08_setup) || + restore_fn_cell(a, name, len, u09_setup) || + restore_fn_cell(a, name, len, u10_setup) || + restore_fn_cell(a, name, len, u11_setup) || + restore_fn_cell(a, name, len, u12_setup)) + { Lisp_Object env; + push(a); +#ifdef COMMON + env = get(a, funarg, nil); +#else + env = get(a, funarg); +#endif + pop(a); + errexit(); + qenv(a) = env; + return onevalue(a); + } + else return onevalue(nil); +} + +Lisp_Object Lsymbol_set_definition(Lisp_Object nil, + Lisp_Object a, Lisp_Object b) +/* + * The odd case here is where the second argument represents a freshly + * created bit of compiled code. In which case the structure is + * (nargs . codevec . envvec) + * where nargs is an integer indicating the number of arguments, codevec + * is a vector of bytecodes, and envvec is something to go in the + * environment cell of the symbol. + * Here the low 8 bits of nargs indicate the number of required arguments. + * The next 8 bits give the number of optional arguments, and the next + * two bits are flags. Of these, the first is set if any of the optional + * arguments has an initform or supplied-p associate, and the other + * indicates that a "&rest" argument is required. + * Bits beyond that (if non-zero) indicate that the function definition + * is of the form (defun f1 (a b c) (f2 a b)) and the number coded is the + * length of the function body. + * Standard Lisp does not need &optional or &rest arguments, but it turned + * out to be pretty easy to make the bytecode compiler support them. + */ +{ + if (!is_symbol(a) || +/* + * Something flagged with the CODEPTR bit is a gensym manufactured to + * stand for a compiled-code object. It should NOT be reset! + */ + (qheader(a) & (SYM_SPECIAL_FORM | SYM_CODEPTR)) != 0) + { if (qheader(a) & SYM_C_DEF) return onevalue(nil); + return aerror1("symbol-set-definition", a); + } + qheader(a) &= ~SYM_TRACED; + set_fns(a, undefined1, undefined2, undefinedn); /* Tidy up first */ + qenv(a) = a; + if ((qheader(a) & SYM_C_DEF) != 0) lose_C_def(a); + if (b == nil) return onevalue(b); /* set defn to nil to undefine */ + else if (symbolp(b)) + { +/* + * One could imagine a view that the second arg to symbol-set-definition + * had to be a codepointer object. I will be kind (?) and permit the NAME + * of a function too. However for the second arg to be a macro or a + * special form would still be a calamity. + * if ((qheader(b) & SYM_CODEPTR) == 0) + * return aerror1("symbol-set-definition", b); + */ + if ((qheader(b) & (SYM_SPECIAL_FORM | SYM_MACRO)) != 0) + return aerror1("symbol-set-definition", b); + qheader(a) = qheader(a) & ~SYM_MACRO; + { set_fns(a, qfn1(b), qfn2(b), qfnn(b)); + qenv(a) = qenv(b); +/* + * In order that checkpoint files can be made there is some very + * ugly fooling around here for functions that are defined in the C coded + * kernel. Sorry. + */ + if ((qheader(b) & SYM_C_DEF) != 0) + { +#ifdef COMMON + Lisp_Object c = get(b, unset_var, nil); +#else + Lisp_Object c = get(b, unset_var); +#endif + if (c == nil) c = b; + push2(c, a); + putprop(a, unset_var, c); + errexitn(2); + pop(a); +#ifdef COMMON + a = cons(a, get(stack[0], work_symbol, nil)); +#else + a = cons(a, get(stack[0], work_symbol)); +#endif + errexitn(1); + putprop(stack[0], work_symbol, a); + pop(b); + errexit(); + } + } + } + else if (!consp(b)) return aerror1("symbol-set-definition", b); + else if (is_fixnum(qcar(b))) + { int32 nargs = (int)int_of_fixnum(qcar(b)), nopts, flagbits, ntail; + nopts = nargs >> 8; + flagbits = nopts >> 8; + ntail = flagbits >> 2; + nargs &= 0xff; + nopts &= 0xff; + flagbits &= 3; + if (ntail != 0) + { switch (100*nargs + ntail-1) + { + case 300: set_fns(a, wrong_no_na, wrong_no_nb, f3_as_0); break; + case 301: set_fns(a, wrong_no_na, wrong_no_nb, f3_as_1); break; + case 302: set_fns(a, wrong_no_na, wrong_no_nb, f3_as_2); break; + case 303: set_fns(a, wrong_no_na, wrong_no_nb, f3_as_3); break; + case 200: set_fns(a, too_few_2, f2_as_0, wrong_no_2); break; + case 201: set_fns(a, too_few_2, f2_as_1, wrong_no_2); break; + case 202: set_fns(a, too_few_2, f2_as_2, wrong_no_2); break; + case 100: set_fns(a, f1_as_0, too_many_1, wrong_no_1); break; + case 101: set_fns(a, f1_as_1, too_many_1, wrong_no_1); break; + case 000: set_fns(a, wrong_no_na, wrong_no_nb, f0_as_0); break; + } + b = qcdr(b); + } + else if (flagbits != 0 || nopts != 0) + { if ((qheader(a) & SYM_TRACED) == 0) switch(flagbits) + { + default: + case 0: /* easy case optional arguments */ + set_fns(a, byteopt1, byteopt2, byteoptn); break; + case 1: /* optional args, but non-nil default, or supplied-p extra */ + set_fns(a, hardopt1, hardopt2, hardoptn); break; + case 2: /* easy opt args, but also a &rest arg */ + set_fns(a, byteoptrest1, byteoptrest2, byteoptrestn); break; + case 3: /* complicated &options and &rest */ + set_fns(a, hardoptrest1, hardoptrest2, hardoptrestn); break; + } + else switch (flagbits) + { + default: + case 0: /* easy case optional arguments */ + set_fns(a, tracebyteopt1, tracebyteopt2, tracebyteoptn); break; + case 1: /* optional args, but non-nil default, or supplied-p extra */ + set_fns(a, tracehardopt1, tracehardopt2, tracehardoptn); break; + case 2: /* easy opt args, but also a &rest arg */ + set_fns(a, tracebyteoptrest1, tracebyteoptrest2, tracebyteoptrestn); break; + case 3: /* complicated &options and &rest */ + set_fns(a, tracehardoptrest1, tracehardoptrest2, tracehardoptrestn); break; + } + } + else + { if (nargs > 4) nargs = 4; + if ((qheader(a) & SYM_TRACED) != 0) nargs += 5; + qheader(a) = qheader(a) & ~SYM_MACRO; + switch (nargs) + { + case 0: set_fns(a, wrong_no_0a, wrong_no_0b, bytecoded0); + break; + case 1: set_fns(a, bytecoded1, too_many_1, wrong_no_1); + break; + case 2: set_fns(a, too_few_2, bytecoded2, wrong_no_2); + break; + case 3: set_fns(a, wrong_no_3a, wrong_no_3b, bytecoded3); + break; + default: + case 4: set_fns(a, wrong_no_na, wrong_no_nb, bytecodedn); + break; + + case 5+0: set_fns(a, wrong_no_0a, wrong_no_0b, tracebytecoded0); + break; + case 5+1: set_fns(a, tracebytecoded1, too_many_1, wrong_no_1); + break; + case 5+2: set_fns(a, too_few_2, tracebytecoded2, wrong_no_2); + break; + case 5+3: set_fns(a, wrong_no_3a, wrong_no_3b, tracebytecoded3); + break; + case 5+4: set_fns(a, wrong_no_na, wrong_no_nb, tracebytecodedn); + break; + } + } + qenv(a) = qcdr(b); + } + else if (qcar(b) == lambda) + { Lisp_Object bvl = qcar(qcdr(b)); + int nargs = 0; + while (consp(bvl)) nargs++, bvl = qcdr(bvl); + qheader(a) = qheader(a) & ~SYM_MACRO; + if ((qheader(a) & SYM_TRACED) != 0) + set_fns(a, traceinterpreted1, traceinterpreted2, traceinterpretedn); + else set_fns(a, interpreted1, interpreted2, interpretedn); + qenv(a) = qcdr(b); + if (qvalue(comp_symbol) != nil && + qfn1(compiler_symbol) != undefined1) + { push(a); + a = ncons(a); + errexitn(1); + (qfn1(compiler_symbol))(qenv(compiler_symbol), a); + pop(a); + errexit(); + } + } + else if (qcar(b) == funarg) + { Lisp_Object bvl = qcar(qcdr(b)); + int nargs = 0; + while (consp(bvl)) nargs++, bvl = qcdr(bvl); + qheader(a) = qheader(a) & ~SYM_MACRO; + if ((qheader(a) & SYM_TRACED) != 0) + set_fns(a, tracefunarged1, tracefunarged2, tracefunargedn); + else set_fns(a, funarged1, funarged2, funargedn); + qenv(a) = qcdr(b); + } + else return aerror1("symbol-set-definition", b); + return onevalue(b); +} + +Lisp_Object Lgetd(Lisp_Object nil, Lisp_Object a) +{ + Header h; + Lisp_Object type; + CSL_IGNORE(nil); + if (a == nil) return onevalue(nil); + else if (!is_symbol(a)) return onevalue(nil); + h = qheader(a); + if ((h & SYM_SPECIAL_FORM) != 0) type = fexpr_symbol; + else if ((h & SYM_MACRO) != 0) + { a = cons(lambda, qenv(a)); + errexit(); + type = macro_symbol; + } + else + { a = Lsymbol_function(nil, a); + errexit(); + if (a == nil) return onevalue(nil); + type = expr_symbol; + } + a = cons(type, a); + errexit(); + return onevalue(a); +} + +Lisp_Object Lremd(Lisp_Object nil, Lisp_Object a) +{ + Lisp_Object res; + CSL_IGNORE(nil); + if (!is_symbol(a) || + (qheader(a) & SYM_SPECIAL_FORM) != 0) + return aerror1("remd", a); + if ((qheader(a) & (SYM_C_DEF | SYM_CODEPTR)) == + (SYM_C_DEF | SYM_CODEPTR)) return onevalue(nil); + res = Lgetd(nil, a); + errexit(); + if (res == nil) return onevalue(nil); /* no definition to remove */ +/* + * I treat an explicit use of remd as a redefinition, and ensure that + * restarting a preserved image will not put the definition back. + */ + qheader(a) = qheader(a) & ~SYM_MACRO; + if ((qheader(a) & SYM_C_DEF) != 0) lose_C_def(a); + set_fns(a, undefined1, undefined2, undefinedn); + qenv(a) = a; + return onevalue(res); +} + +/* + * For set-autoload the first argument must be a symbol that will name + * a function, the second arg is either an atom or a list of atoms, each + * of which specified a module to be loaded if the names function is + * called. Loading the modules is expected to instate a definition for the + * function involved. This function is arranged so it does NOT do anything + * if the function being set for autoloading is already defined. This is + * on the supposition that the existing definition is in fact the desired + * one, say because the relevant module happens to have been loaded already. + * An explicit use of remd first can be used to ensure that no previous + * definition is present and thus that a real autoload stub will be instated, + * if that is what you really want. + */ + +Lisp_Object Lset_autoload(Lisp_Object nil, Lisp_Object a, Lisp_Object b) +{ + Lisp_Object res; + CSL_IGNORE(nil); + if (!is_symbol(a) || + (qheader(a) & SYM_SPECIAL_FORM) != 0) + return aerror1("set-autoload", a); + if (!(qfn1(a) == undefined1 && qfn2(a) == undefined2 && + qfnn(a) == undefinedn)) return onevalue(nil); + if ((qheader(a) & (SYM_C_DEF | SYM_CODEPTR)) == + (SYM_C_DEF | SYM_CODEPTR)) return onevalue(nil); + push2(a, b); + if (consp(b)) res = cons(a, b); + else res = list2(a, b); + pop2(b, a); + errexit(); +/* + * I treat an explicit use of set-autoload as a redefinition, and ensure that + * restarting a preserved image will not put the definition back. Note that + * I will not allow autoloadable macros... + */ + qheader(a) = qheader(a) & ~SYM_MACRO; + if ((qheader(a) & SYM_C_DEF) != 0) lose_C_def(a); + set_fns(a, autoload1, autoload2, autoloadn); + qenv(a) = res; + return onevalue(res); +} + +#define pack_funtable(a, n) ((((int32)(a)) << 16) | (n)) +#define funtable_nargs(u) ((u) >> 16) +#define funtable_index(u) ((u) & 0xffffU) + +static one_args *displaced1 = NULL; +static two_args *displaced2; +static n_args *displacedn; +static unsigned32 table_entry; + +static void trace_entering(char *s) +{ + int i; + for (i=0; i 15 args: not supported"); + } + popv(nargs); + pop(name); + errexit(); + push(r); + freshline_trace(); + loop_print_trace(name); + trace_printf(" = "); + loop_print_trace(r); + trace_exiting("\n"); + pop(r); + return onevalue(r); +} + +#define NOT_FOUND 100 + +static unsigned32 find_built_in_function(one_args *f1, + two_args *f2, + n_args *fn) +/* + * This take the entrypoint of a function and tries to identify it + * by scanning the tables used by the bytecode interpreter. If the + * function is found a record is returned indicating how many args + * it takes, and what its index is in the relevant table. The code + * is returned to indicate failure if the function + * is not found. + */ +{ + int32 index; + for (index=0; zero_arg_functions[index]!=NULL; index++) + if (fn == zero_arg_functions[index]) return pack_funtable(0, index); + for (index=0; one_arg_functions[index]!=NULL; index++) + if (f1 == one_arg_functions[index]) return pack_funtable(1, index); + for (index=0; two_arg_functions[index]!=NULL; index++) + if (f2 == two_arg_functions[index]) return pack_funtable(2, index); + for (index=0; three_arg_functions[index]!=NULL; index++) + if (fn == three_arg_functions[index]) return pack_funtable(3, index); + return pack_funtable(NOT_FOUND, NOT_FOUND); +} + +Lisp_Object Ltrace_all(Lisp_Object nil, Lisp_Object a) +{ +#ifdef DEBUG + if (a == nil) trace_all = 0; + else trace_all = 1; + return onevalue(nil); +#else + return aerror("trace-all only supported in DEBUG version"); +#endif +} + +Lisp_Object Ltrace(Lisp_Object nil, Lisp_Object a) +{ + Lisp_Object w = a; + if (symbolp(a)) + { a = ncons(a); + errexit(); + w = a; + } + while (consp(w)) + { Lisp_Object s = qcar(w); + w = qcdr(w); + if (symbolp(s)) + { one_args *f1 = qfn1(s); + two_args *f2 = qfn2(s); + n_args *fn = qfnn(s); + int fixenv = 0, done = 0; + if (f1 == undefined1) + { freshline_debug(); + debug_printf("+++ "); + loop_print_debug(s); + debug_printf(" not yet defined\n"); + continue; + } + qheader(s) |= SYM_TRACED; + if (f1 == interpreted1) + { set_fns(s, traceinterpreted1, traceinterpreted2, traceinterpretedn); + fixenv = done = 1; + } + if (f1 == funarged1) + { set_fns(s, tracefunarged1, tracefunarged2, tracefunargedn); + fixenv = done = 1; + } + if (fn == bytecoded0) ifnn(s) = (int32)tracebytecoded0, done = 1; + if (f1 == bytecoded1) ifn1(s) = (int32)tracebytecoded1, done = 1; + if (f2 == bytecoded2) ifn2(s) = (int32)tracebytecoded2, done = 1; + if (fn == bytecoded3) ifnn(s) = (int32)tracebytecoded3, done = 1; + if (fn == bytecodedn) ifnn(s) = (int32)tracebytecodedn, done = 1; + if (f1 == byteopt1) ifn1(s) = (int32)tracebyteopt1, done = 1; + if (f2 == byteopt2) ifn2(s) = (int32)tracebyteopt2, done = 1; + if (fn == byteoptn) ifnn(s) = (int32)tracebyteoptn, done = 1; + if (f1 == hardopt1) ifn1(s) = (int32)tracehardopt1, done = 1; + if (f2 == hardopt2) ifn2(s) = (int32)tracehardopt2, done = 1; + if (fn == hardoptn) ifnn(s) = (int32)tracehardoptn, done = 1; + if (f1 == byteoptrest1) ifn1(s) = (int32)tracebyteoptrest1, done = 1; + if (f2 == byteoptrest2) ifn2(s) = (int32)tracebyteoptrest2, done = 1; + if (fn == byteoptrestn) ifnn(s) = (int32)tracebyteoptrestn, done = 1; + if (f1 == hardoptrest1) ifn1(s) = (int32)tracehardoptrest1, done = 1; + if (f2 == hardoptrest2) ifn2(s) = (int32)tracehardoptrest2, done = 1; + if (fn == hardoptrestn) ifnn(s) = (int32)tracehardoptrestn, done = 1; + if (fixenv) + { push2(a, s); + a = cons(s, qenv(s)); + errexitn(2); + pop(s); + qenv(s) = a; + pop(a); + } + if (done) continue; +/* + * I permit the tracing of just one function from the kernel, and achieve + * this by installing a wrapper function in place of the real definition. + * Indeed this is just like Lisp-level embedding, except that I can get at the + * entrypoint table used by the bytecode interpreter and so trap calls made + * via there, and I can use that table to tell me how many arguments the + * traced function needed. + */ + if (displaced1 == NULL) + { int nargs = funtable_nargs(table_entry); +/* + * Remember what function was being traced, so that it can eventually be + * invoked, and its name printed. + */ + displaced1 = f1; + displaced2 = f2; + displacedn = fn; + tracedfn = s; +/* + * This makes calls via the regular interpreter see the traced version... + */ + set_fns(s, traced1_function, traced2_function, + tracedn_function); + table_entry = find_built_in_function(f1, f2, fn); + nargs = funtable_nargs(table_entry); + table_entry = funtable_index(table_entry); + if (nargs != NOT_FOUND) + { +/* + * .. and now I make calls via short-form bytecodes do likewise. + */ + switch (nargs) + { + default: + case 0: zero_arg_functions[funtable_index(table_entry)] = + tracedn_function; + break; + case 1: one_arg_functions[funtable_index(table_entry)] = + traced1_function; + break; + case 2: two_arg_functions[funtable_index(table_entry)] = + traced2_function; + break; + case 3: three_arg_functions[funtable_index(table_entry)] = + tracedn_function; + break; + } + } + } + continue; + } + } + return onevalue(a); +} + +Lisp_Object Luntrace(Lisp_Object nil, Lisp_Object a) +{ + Lisp_Object w = a; + CSL_IGNORE(nil); + if (symbolp(a)) + { a = ncons(a); + errexit(); + w = a; + } + while (consp(w)) + { Lisp_Object s = qcar(w); + w = qcdr(w); + if (symbolp(s)) + { one_args *f1 = qfn1(s); + two_args *f2 = qfn2(s); + n_args *fn = qfnn(s); + if (f1 == traceinterpreted1) + { set_fns(a, interpreted1, interpreted2, interpretedn); + qenv(s) = qcdr(qenv(s)); + } + else if (f1 == tracefunarged1) + { set_fns(s, funarged1, funarged2, funargedn); + qenv(s) = qcdr(qenv(s)); + } + if (f1 == tracebytecoded1) ifn1(s) = (int32)bytecoded1; + if (f2 == tracebytecoded2) ifn2(s) = (int32)bytecoded2; + if (fn == tracebytecoded0) ifnn(s) = (int32)bytecoded0; + if (fn == tracebytecoded3) ifnn(s) = (int32)bytecoded3; + if (fn == tracebytecodedn) ifnn(s) = (int32)bytecodedn; + if (f1 == tracebyteopt1) ifn1(s) = (int32)byteopt1; + if (f2 == tracebyteopt2) ifn2(s) = (int32)byteopt2; + if (fn == tracebyteoptn) ifnn(s) = (int32)byteoptn; + if (f1 == tracebyteoptrest1) ifn1(s) = (int32)byteoptrest1; + if (f2 == tracebyteoptrest2) ifn2(s) = (int32)byteoptrest2; + if (fn == tracebyteoptrestn) ifnn(s) = (int32)byteoptrestn; + if (f1 == tracehardopt1) ifn1(s) = (int32)hardopt1; + if (f2 == tracehardopt2) ifn2(s) = (int32)hardopt2; + if (fn == tracehardoptn) ifnn(s) = (int32)hardoptn; + if (f1 == tracehardoptrest1) ifn1(s) = (int32)hardoptrest1; + if (f2 == tracehardoptrest2) ifn2(s) = (int32)hardoptrest2; + if (fn == tracehardoptrestn) ifnn(s) = (int32)hardoptrestn; + if (f1 == traced1_function) + { int nargs = funtable_nargs(table_entry); + set_fns(s, displaced1, displaced2, displacedn); + if (nargs != NOT_FOUND) + switch (nargs) + { + default: + case 0: zero_arg_functions[funtable_index(table_entry)] = + displacedn; + break; + case 1: one_arg_functions[funtable_index(table_entry)] = + displaced1; + break; + case 2: two_arg_functions[funtable_index(table_entry)] = + displaced2; + break; + case 3: three_arg_functions[funtable_index(table_entry)] = + displacedn; + break; + } + displaced1 = NULL; + displaced2 = NULL; + displacedn = NULL; + } + qheader(s) &= ~SYM_TRACED; + } + } + return onevalue(a); +} + +Lisp_Object Ldouble(Lisp_Object nil, Lisp_Object a) +{ + Lisp_Object w = a; + if (symbolp(a)) + { a = ncons(a); + errexit(); + w = a; + } + while (consp(w)) + { Lisp_Object s = qcar(w); + w = qcdr(w); + if (symbolp(s)) + { one_args *f1 = qfn1(s); + two_args *f2 = qfn2(s); + n_args *fn = qfnn(s); + int fixenv = 0, done = 0; + if (f1 == undefined1) continue; + if (f1 == interpreted1) + { set_fns(s, double_interpreted1, double_interpreted2, double_interpretedn); + fixenv = done = 1; + } + if (f1 == funarged1) + { set_fns(s, double_funarged1, double_funarged2, double_funargedn); + fixenv = done = 1; + } + if (fn == bytecoded0) ifnn(s) = (int32)double_bytecoded0, done = 1; + if (f1 == bytecoded1) ifn1(s) = (int32)double_bytecoded1, done = 1; + if (f2 == bytecoded2) ifn2(s) = (int32)double_bytecoded2, done = 1; + if (fn == bytecoded3) ifnn(s) = (int32)double_bytecoded3, done = 1; + if (fn == bytecodedn) ifnn(s) = (int32)double_bytecodedn, done = 1; + if (f1 == byteopt1) ifn1(s) = (int32)double_byteopt1, done = 1; + if (f2 == byteopt2) ifn2(s) = (int32)double_byteopt2, done = 1; + if (fn == byteoptn) ifnn(s) = (int32)double_byteoptn, done = 1; + if (f1 == hardopt1) ifn1(s) = (int32)double_hardopt1, done = 1; + if (f2 == hardopt2) ifn2(s) = (int32)double_hardopt2, done = 1; + if (fn == hardoptn) ifnn(s) = (int32)double_hardoptn, done = 1; + if (f1 == byteoptrest1) ifn1(s) = (int32)double_byteoptrest1, done = 1; + if (f2 == byteoptrest2) ifn2(s) = (int32)double_byteoptrest2, done = 1; + if (fn == byteoptrestn) ifnn(s) = (int32)double_byteoptrestn, done = 1; + if (f1 == hardoptrest1) ifn1(s) = (int32)double_hardoptrest1, done = 1; + if (f2 == hardoptrest2) ifn2(s) = (int32)double_hardoptrest2, done = 1; + if (fn == hardoptrestn) ifnn(s) = (int32)double_hardoptrestn, done = 1; + if (fixenv) + { push2(a, s); + a = cons(s, qenv(s)); + errexitn(2); + pop(s); + qenv(s) = a; + pop(a); + } + if (done) continue; + debug_printf("Unable to execution-double: "); loop_print_debug(s); + trace_printf("\n"); + continue; + } + } + return onevalue(a); +} + +Lisp_Object Lundouble(Lisp_Object nil, Lisp_Object a) +{ + Lisp_Object w = a; + CSL_IGNORE(nil); + if (symbolp(a)) + { a = ncons(a); + errexit(); + w = a; + } + while (consp(w)) + { Lisp_Object s = qcar(w); + w = qcdr(w); + if (symbolp(s)) + { one_args *f1 = qfn1(s); + two_args *f2 = qfn2(s); + n_args *fn = qfnn(s); + if (f1 == double_interpreted1) + { set_fns(a, interpreted1, interpreted2, interpretedn); + qenv(s) = qcdr(qenv(s)); + } + else if (f1 == double_funarged1) + { set_fns(s, funarged1, funarged2, funargedn); + qenv(s) = qcdr(qenv(s)); + } + else if (f1 == double_bytecoded1) ifn1(s) = (int32)bytecoded1; + else if (f2 == double_bytecoded2) ifn2(s) = (int32)bytecoded2; + else if (fn == double_bytecoded0) ifnn(s) = (int32)bytecoded0; + else if (fn == double_bytecoded3) ifnn(s) = (int32)bytecoded3; + else if (fn == double_bytecodedn) ifnn(s) = (int32)bytecodedn; + else if (f1 == double_byteopt1) ifn1(s) = (int32)byteopt1; + else if (f2 == double_byteopt2) ifn2(s) = (int32)byteopt2; + else if (fn == double_byteoptn) ifnn(s) = (int32)byteoptn; + else if (f1 == double_byteoptrest1) ifn1(s) = (int32)byteoptrest1; + else if (f2 == double_byteoptrest2) ifn2(s) = (int32)byteoptrest2; + else if (fn == double_byteoptrestn) ifnn(s) = (int32)byteoptrestn; + else if (f1 == double_hardopt1) ifn1(s) = (int32)hardopt1; + else if (f2 == double_hardopt2) ifn2(s) = (int32)hardopt2; + else if (fn == double_hardoptn) ifnn(s) = (int32)hardoptn; + else if (f1 == double_hardoptrest1) ifn1(s) = (int32)hardoptrest1; + else if (f2 == double_hardoptrest2) ifn2(s) = (int32)hardoptrest2; + else if (fn == double_hardoptrestn) ifnn(s) = (int32)hardoptrestn; + } + } + return onevalue(a); +} + +Lisp_Object Lmacro_function(Lisp_Object nil, Lisp_Object a) +{ + if (!symbolp(a)) return onevalue(nil); + else if ((qheader(a) & SYM_MACRO) == 0) return onevalue(nil); +/* If the MACRO bit is set in the header I know there is a definition */ + else return onevalue(cons(lambda, qenv(a))); +} + + +Lisp_Object get_pname(Lisp_Object a) +{ + Lisp_Object name = qpname(a); +#ifndef COMMON +/* + * When a gensym is first created its pname field points at a string that + * will form the base of its name, and a magic bit is set in its header. + * If at some stage it is necessary to inspect the print name (mainly in + * order to print the symbol) it becomes necessary to create a new string + * and insert a serial number. Doing things this way means that the serial + * numbers that users see will tend to be smaller, and space for per-gensym + * strings does not get allocated unless really needed. The down side is + * that every time I want to grab the pname of anything I have to check for + * this case and admit the possibility of garbage collection or even + * failure. + */ + if (qheader(a) & SYM_UNPRINTED_GENSYM) + { unsigned32 len; + Lisp_Object nil = C_nil; + char genname[64]; + len = length_of_header(vechdr(name)) - 4; + if (len > 60) len = 60; /* Unpublished truncation of the string */ + sprintf(genname, "%.*s%lu", (int)len, + (char *)name + (4 - TAG_VECTOR), (long)gensym_ser++); + push(a); + name = make_string(genname); + pop(a); + errexit(); + qpname(a) = name; + qheader(a) &= ~SYM_UNPRINTED_GENSYM; + } +#endif + return name; +} + +Lisp_Object Lsymbol_name(Lisp_Object nil, Lisp_Object a) +{ + if (!symbolp(a)) return aerror1("symbol-name", a); + a = get_pname(a); + errexit(); + return onevalue(a); +} + +#ifdef COMMON + +Lisp_Object Lsymbol_package(Lisp_Object nil, Lisp_Object a) +{ + if (!symbolp(a)) return aerror1("symbol-package", a); + a = qpackage(a); + return onevalue(a); +} + +#endif + +static Lisp_Object Lrestart_csl2(Lisp_Object nil, + Lisp_Object a, Lisp_Object b) +/* + * If the argument is given as nil then this is a cold-start, and when + * I begin again it would be a VERY good idea to do a (load!-module 'compat) + * rather promptly (otherwise some Lisp functions will not work at all). + * I do not automate that because this function is intended for use in + * delicate system rebuilding contexts and I want the user to have ultimate + * control. (restart!-csl t) reloads a heap-image in the normal way. + * (restart!-csl 'xx) where xx is neither nil nor t starts by reloading a + * heap image, but then it looks for a function with the same name as xx + * (since a heap image is reloaded it is NOT easy (possible?) to keep the + * symbol) and calls it as a function. Finally the case + * (restart!-csl '(module fn)) restart the system, then calls load-module + * on the named module and finally calls the given restart function. + * This last option can be useful since otherwise the function to be called + * in (restart!-csl 'xx) would need to be in the base image as re-loaded. + */ +{ + int n; + char *v; +#ifdef SOCKETS +/* + * Security measure - deny restart-csl to remote users + */ + if (socket_server != 0) return aerror("restart-csl"); +#endif + n = 0; + v = NULL; +/* + * A comment seems in order here. The case b==SPID_NOARG should only + * arise if I came from Lrestart_csl: it indicates that there was + * no second argument provided. + */ + if (b != SPID_NOARG) + { Lisp_Object b1 = b = Lexploden(nil, b); + errexit(); + while (b1 != nil) + { n++; /* number of chars of arg */ + b1 = qcdr(b1); + } + v = (char *)malloc(n+1); + if (v == NULL) return aerror("space exhausted in restart-csl"); + n = 0; + while (b != nil) + { v[n++] = int_of_fixnum(qcar(b)); + b = qcdr(b); + } + v[n] = 0; + } + term_printf("\nThe system is about to do a restart...\n"); +/* Almost all unpicking of the argument is done back in csl.c */ + exit_value = a; + exit_tag = fixnum_of_int(2); /* Flag to say "restart" */ + exit_reason = UNWIND_RESTART; + exit_charvec = v; + flip_exception(); + return nil; +} + +static Lisp_Object Lrestart_csl(Lisp_Object nil, Lisp_Object a) +{ + return Lrestart_csl2(nil, a, SPID_NOARG); +} + +static Lisp_Object Lpreserve(Lisp_Object nil, + Lisp_Object startup, Lisp_Object banner) +/* + * (preserve ) saves a Lisp image in a standard place + * and arranges that when restarted the saved image will call the specified + * startup function. In the process of doing all this it unwinds down to + * the top level of Lisp. If a startup function is not given then the + * previously active one is used. If nil is specified then the previously + * active startup function is retained. If banner is non-nil (well really + * I want a string) is is a message of up to 40 characters to display + * when the system restart. + */ +{ + char filename[LONGEST_LEGAL_FILENAME]; + CSLbool failed; +#ifdef SOCKETS +/* + * Security measure - deny preserve to remote users + */ + if (socket_server != 0) return aerror("preserve"); +#endif + if (startup != nil) supervisor = startup; + failed = Iwriterootp(filename); /* Can I open image file for writing? */ + term_printf("\nThe system will be preserved on file \"%s\"\n", filename); + if (failed) return aerror("preserve"); + exit_count = 0; + nil = C_nil; + exit_value = banner; + exit_tag = fixnum_of_int(1); /* Flag to say "preserve" */ + exit_reason = UNWIND_RESTART; + flip_exception(); + return nil; +} + +static Lisp_Object MS_CDECL Lpreserve_0(Lisp_Object nil, int nargs, ...) +{ + argcheck(nargs, 0, "preserve"); + return Lpreserve(nil, nil, nil); +} + +static Lisp_Object Lpreserve_1(Lisp_Object nil, Lisp_Object startup) +{ + return Lpreserve(nil, startup, nil); +} + + +/* + * This is an experimental addition - a version of PRESERVE that allows + * CSL to continue executing after it has written out an image file. + */ + +static Lisp_Object Lcheckpoint(Lisp_Object nil, + Lisp_Object startup, Lisp_Object banner) +{ + char filename[LONGEST_LEGAL_FILENAME]; + CSLbool failed = 0; + char *msg = ""; +#ifdef SOCKETS +/* + * Security measure - deny checkpoint to remote users + */ + if (socket_server != 0) return aerror("checkpoint"); +#endif + if (startup != nil) supervisor = startup; + failed = Iwriterootp(filename); /* Can I open image file for writing? */ + term_printf("\nThe system will be preserved on file \"%s\"\n", filename); + if (failed) return aerror("checkpoint"); + if (is_vector(banner) && + type_of_header(vechdr(banner)) == TYPE_STRING) + msg = &celt(banner, 0); +/* + * Note, with some degree of nervousness, that things on the C stack will + * be updated by the garbage collection that happens during the processing + * of the call to preserve(), but they will be neither adjusted into + * relative addresses nor unadjusted (and hence restored) by in the + * image-writing. But the image writing will not actually move any data + * around so all is still OK, I hope! + */ + push5(codevec, litvec, catch_tags, faslvec, faslgensyms); + preserve(msg); + nil = C_nil; + if (exception_pending()) failed = 1, flip_exception(); + adjust_all(); + pop5(faslgensyms, faslvec, catch_tags, litvec, codevec); + eq_hash_tables = eq_hash_table_list; + equal_hash_tables = equal_hash_table_list; + eq_hash_table_list = equal_hash_table_list = nil; + { Lisp_Object qq; + for (qq = eq_hash_tables; qq!=nil; qq=qcdr(qq)) + rehash_this_table(qcar(qq)); + for (qq = equal_hash_tables; qq!=nil; qq=qcdr(qq)) + rehash_this_table(qcar(qq)); + } + set_up_functions(YES); + if (failed) return aerror("checkpoint"); + return onevalue(nil); +} + +static Lisp_Object MS_CDECL Lcheckpoint_0(Lisp_Object nil, int nargs, ...) +{ + argcheck(nargs, 0, "checkpoint"); + return Lcheckpoint(nil, nil, nil); +} + +static Lisp_Object Lcheckpoint_1(Lisp_Object nil, Lisp_Object startup) +{ + return Lcheckpoint(nil, startup, nil); +} + + +#ifdef COMMON +static CSLbool eql_numbers(Lisp_Object a, Lisp_Object b) +/* + * This is only called from eql, and then only when a and b are both tagged + * as ratios or complex numbers. + */ +{ + Lisp_Object p, q; + p = *(Lisp_Object *)(a + (4 - TAG_NUMBERS)); + q = *(Lisp_Object *)(b + (4 - TAG_NUMBERS)); + if (!eql(p, q)) return NO; + p = *(Lisp_Object *)(a + (8 - TAG_NUMBERS)); + q = *(Lisp_Object *)(b + (8 - TAG_NUMBERS)); + return eql(p, q); +} +#endif + +CSLbool eql_fn(Lisp_Object a, Lisp_Object b) +/* + * This seems incredible - all the messing about that is needed to + * check that numeric values compare properly. Ugh. + */ +{ +/* + * (these tests done before eql_fn is called). + * if (a == b) return YES; + * if ((((int32)a ^ (int32)b) & TAG_BITS) != 0) return NO; + * + * Actually in Common Lisp mode where I have short floats as immediate data + * I have further pain here with (eql 0.0 -0.0). + */ +#ifdef COMMON + if ((a == TAG_SFLOAT && b == (TAG_SFLOAT|0x80000000)) || + (a == (TAG_SFLOAT|0x80000000) && b == TAG_SFLOAT) return YES; +#endif + if (!is_number(a) || is_immed_or_cons(a)) return NO; + if (is_bfloat(a)) + { Header h = flthdr(a); + if (h != flthdr(b)) return NO; + h = length_of_header(h); +#ifdef COMMON + if (h == 8) /* Single float */ + { +#ifdef OLD_CODE + if (*(int32 *)(a + (4 - TAG_BOXFLOAT)) != + *(int32 *)(b + (4 - TAG_BOXFLOAT))) return NO; + else return YES; +#else + return (single_float_val(a) == single_float_val(b)); +#endif + } + else +#endif +/* + * For the moment I view all non-single floats as double floats. Extra + * stuff will be needed here if I ever implement long floats as 3-word + * objects. + */ + { +#ifdef OLD_CODE + if ((*(int32 *)((char *)a + (8 - TAG_BOXFLOAT)) != + *(int32 *)((char *)b + (8 - TAG_BOXFLOAT))) || + (*(int32 *)((char *)a + (12 - TAG_BOXFLOAT)) != + *(int32 *)((char *)b + (12 - TAG_BOXFLOAT)))) return NO; + else return YES; +#else + return (double_float_val(a) == double_float_val(b)); +#endif + } + } + else /* ratio, complex or bignum */ + { Header h = numhdr(a); + if (h != numhdr(b)) return NO; + if (type_of_header(h) == TYPE_BIGNUM) + { int32 hh = (int32)length_of_header(h) - TAG_NUMBERS; + while (hh > (4 - TAG_NUMBERS)) + { hh -= 4; + if (*(Lisp_Object *)((char *)a + hh) != + *(Lisp_Object *)((char *)b + hh)) + return NO; + } + return YES; + } +#ifdef COMMON + else return eql_numbers(a, b); +#else + else return NO; +#endif + } +} + +static CSLbool cl_vec_equal(Lisp_Object a, Lisp_Object b) +/* + * here a and b are known to be vectors or arrays. This should compare + * them following the Common Lisp recipe, where strings or bitvectors + * (simple or complex) have their contents compared, while all other types of + * vector or array are tested using EQ. + */ +{ + Header ha = vechdr(a), hb = vechdr(b); + int32 offa = 0, offb = 0; + int ta = type_of_header(ha), tb = type_of_header(hb); + int32 la = length_of_header(ha), lb = length_of_header(hb); +#ifdef COMMON + if (header_of_bitvector(ha)) ta = TYPE_BITVEC1; + if (header_of_bitvector(hb)) tb = TYPE_BITVEC1; +#endif + switch (ta) + { +/* +case TYPE_ARRAY: +/* My moan here is that, as noted above, I ought to process even + * non-simple strings and bit-vectors by comparing contents, but as a + * matter of idleness I have not yet got around to that. In fact if I get + * arrays to compare here I will pretend that they are not strings or + * bit-vectors and compare using EQ... + */ +case TYPE_STRING: + switch (tb) + { +/* /* + case TYPE_ARRAY: +*/ + case TYPE_STRING: + goto compare_strings; + default:return NO; + } +#ifdef COMMON +case TYPE_BITVEC1: + switch (tb) + { +/* /* + case TYPE_ARRAY: +*/ + case TYPE_BITVEC1: + goto compare_bits; + default:return NO; + } +#endif +default: return (a == b); + } +compare_strings: + if (la != lb) return NO; + while (la > 0) + { la--; + if (*((char *)a + la + offa - TAG_VECTOR) != + *((char *)b + la + offb - TAG_VECTOR)) return NO; + } + return YES; +#ifdef COMMON +compare_bits: + if (la != lb) return NO; + while (la > 0) + { la--; + if (*((char *)a + la + offa - TAG_VECTOR) != + *((char *)b + la + offb - TAG_VECTOR)) return NO; + } + return YES; +#endif +} + +CSLbool cl_equal_fn(Lisp_Object a, Lisp_Object b) +/* + * a and b are not EQ at this stage.. I guarantee to have checked that + * before entering this general purpose code. + */ +{ + Lisp_Object nil = C_nil; + CSL_IGNORE(nil); +/* + * The for loop at the top here is so that cl_equal can iterate along the + * length of linear lists. + */ +#ifdef CHECK_STACK + if (check_stack(__FILE__,__LINE__)) + { err_printf("Stack too deep in cl_equal\n"); + my_exit(EXIT_FAILURE); + } +#endif + for (;;) + { + int32 ta = (int32)a & TAG_BITS; + if (ta == TAG_CONS +#ifdef COMMON + && a != nil +#endif + ) + { if (!consp(b) +#ifdef COMMON + || b == nil +#endif + ) return NO; + else + { Lisp_Object ca = qcar(a), cb = qcar(b); + if (ca == cb) + { a = qcdr(a); + b = qcdr(b); + if (a == b) return YES; + continue; + } +/* + * And here, because cl_equal() seems to be a very important low-level + * primitive, I unwind one level of the recursion that would arise + * with nested lists. + */ + for (;;) + { + int32 tca = (int32)ca & TAG_BITS; + if (tca == TAG_CONS +#ifdef COMMON + && ca != nil +#endif + ) + { if (!consp(cb) +#ifdef COMMON + || cb == nil +#endif + ) return NO; + else + { Lisp_Object cca = qcar(ca), ccb = qcar(cb); + if (cca == ccb) + { ca = qcdr(ca); + cb = qcdr(cb); + if (ca == cb) break; + continue; + } +/* + * Do a real recursion when I get down to args like + * ((x ...) ...) ((y ...) ...) + */ + if (!cl_equal(cca, ccb)) return NO; + ca = qcdr(ca); + cb = qcdr(cb); + if (ca == cb) break; + continue; + } + } + else if (tca <= TAG_SYMBOL || + ((int32)cb & TAG_BITS) != tca) return NO; + else switch (tca) + { + case TAG_NUMBERS: + { Header h = numhdr(ca); + if (h != numhdr(cb)) return NO; + if (type_of_header(h) == TYPE_BIGNUM) + { int32 hh = (int32)length_of_header(h) - TAG_NUMBERS; + while (hh > (4 - TAG_NUMBERS)) + { hh -= 4; + if (*(Lisp_Object *)((char *)ca + hh) != + *(Lisp_Object *)((char *)cb + hh)) + return NO; + } + break; + } +#ifdef COMMON + else if (!eql_numbers(ca, cb)) return NO; + else break; +#else + else return NO; +#endif + } + case TAG_VECTOR: + if (!cl_vec_equal(ca, cb)) return NO; + break; + default: + case TAG_BOXFLOAT: + { Header h = flthdr(ca); + if (h != flthdr(cb)) return NO; + h = length_of_header(h); +#ifdef COMMON + if (h == 8) /* Single float */ + { +#ifdef OLD_CODE + if (*(int32 *)(ca + (4 - TAG_BOXFLOAT)) != + *(int32 *)(cb + (4 - TAG_BOXFLOAT))) + return NO; +#else + if (single_float_val(ca) != + single_float_val(cb)) return NO; +#endif + else break; + } + else +#endif + { +#ifdef OLD_CODE + if ((*(int32 *)((char *)ca + + (8 - TAG_BOXFLOAT)) != + *(int32 *)((char *)cb + + (8 - TAG_BOXFLOAT))) || + (*(int32 *)((char *)ca + + (12 - TAG_BOXFLOAT)) != + *(int32 *)((char *)cb + + (12 - TAG_BOXFLOAT)))) return NO; +#else + if (double_float_val(ca) != + double_float_val(cb)) return NO; +#endif + else break; + } + } + } + break; /* out of the for (;;) loop */ + } + a = qcdr(a); + b = qcdr(b); + if (a == b) return YES; + continue; + } + } + else if (ta <= TAG_SYMBOL || + ((int32)b & TAG_BITS) != ta) return NO; + else switch (ta) + { + case TAG_NUMBERS: + { Header h = numhdr(a); + if (h != numhdr(b)) return NO; + if (type_of_header(h) == TYPE_BIGNUM) + { int32 hh = (int32)length_of_header(h) - TAG_NUMBERS; + while (hh > (4 - TAG_NUMBERS)) + { hh -= 4; + if (*(Lisp_Object *)((char *)a + hh) != + *(Lisp_Object *)((char *)b + hh)) + return NO; + } + return YES; + } +#ifdef COMMON + else return eql_numbers(a, b); + +#else + else return NO; +#endif + } + case TAG_VECTOR: + return cl_vec_equal(a, b); + default: + case TAG_BOXFLOAT: + { Header h = flthdr(a); + if (h != flthdr(b)) return NO; + h = length_of_header(h); +#ifdef COMMON + if (h == 8) /* Single float */ + { +#ifdef OLD_CODE + if (*(int32 *)(a + (4 - TAG_BOXFLOAT)) != + *(int32 *)(b + (4 - TAG_BOXFLOAT))) return NO; +#else + if (single_float_val(a) != single_float_val(b)) + return NO; +#endif + else return YES; + } + else +#endif +/* + * For the moment I view all non-single floats as double floats. Extra + * stuff will be needed here if I ever implement long floats as 3-word + * objects. + */ + { +#ifdef OLD_CODE + if ((*(int32 *)((char *)a + (8 - TAG_BOXFLOAT)) != + *(int32 *)((char *)b + (8 - TAG_BOXFLOAT))) || + (*(int32 *)((char *)a + (12 - TAG_BOXFLOAT)) != + *(int32 *)((char *)b + (12 - TAG_BOXFLOAT)))) + return NO; +#else + if (double_float_val(a) != double_float_val(b)) + return NO; +#endif + else return YES; + } + } + } + } +} + +static CSLbool vec_equal(Lisp_Object a, Lisp_Object b); + +#ifdef TRACED_EQUAL +#define LOG_SIZE 10000 +typedef struct equal_record +{ + char file[24]; + int line; + int depth; + int count; +} equal_record; + +static equal_record equal_counts[LOG_SIZE]; + +static void record_equal(char *file, int line, int depth) +{ + int hash = 169*line + depth; + char *p = file; + while (*p != 0) hash = 168*hash + (*p++ & 0xff); + hash = ((169*hash) & 0x7fffffff) % LOG_SIZE; + while (equal_counts[hash].count != 0) + { if (equal_counts[hash].line == line && + equal_counts[hash].depth == depth && + strncmp(equal_counts[hash].file, file, 24) == 0) + { equal_counts[hash].count++; + return; + } + hash = (hash + 1) % LOG_SIZE; + } + strncpy(equal_counts[hash].file, file, 24); + equal_counts[hash].line = line; + equal_counts[hash].depth = depth; + equal_counts[hash].count = 1; + return; +} + +void dump_equals() +{ + int i; + FILE *log = fopen("equal.log", "w"); + if (log == NULL) log = stdout; + fprintf(log, "\nCalls to equal...\n"); + for (i=0; i (4 - TAG_NUMBERS)) + { hh -= 4; + if (*(Lisp_Object *)((char *)ca + hh) != + *(Lisp_Object *)((char *)cb + hh)) + return NO; + } + break; + } +#ifdef COMMON + else if (!eql_numbers(ca, cb)) return NO; + else break; +#else + else return NO; +#endif + } + case TAG_VECTOR: + if (!vec_equal(ca, cb)) return NO; + break; + default: + case TAG_BOXFLOAT: + { Header h = flthdr(ca); + if (h != flthdr(cb)) return NO; + h = length_of_header(h); +#ifdef COMMON + if (h == 8) /* Single float */ + { +#ifdef OLD_CODE + if (*(int32 *)(ca + (4 - TAG_BOXFLOAT)) != + *(int32 *)(cb + (4 - TAG_BOXFLOAT))) + return NO; +#else + if (single_float_val(ca) != + single_float_val(cb)) return NO; +#endif + else break; + } + else +#endif + { +#ifdef OLD_CODE + if ((*(int32 *)((char *)ca + + (8 - TAG_BOXFLOAT)) != + *(int32 *)((char *)cb + + (8 - TAG_BOXFLOAT))) || + (*(int32 *)((char *)ca + + (12 - TAG_BOXFLOAT)) != + *(int32 *)((char *)cb + + (12 - TAG_BOXFLOAT)))) return NO; +#else + if (double_float_val(ca) != + double_float_val(cb)) return NO; +#endif + + else break; + } + } + } + break; /* out of the for (;;) loop */ + } + a = qcdr(a); + b = qcdr(b); + if (a == b) return YES; + continue; + } + } + else if (ta <= TAG_SYMBOL || + ((int32)b & TAG_BITS) != ta) return NO; + else switch (ta) + { + case TAG_NUMBERS: + { Header h = numhdr(a); + if (h != numhdr(b)) return NO; + if (type_of_header(h) == TYPE_BIGNUM) + { int32 hh = (int32)length_of_header(h) - TAG_NUMBERS; + while (hh > (4 - TAG_NUMBERS)) + { hh -= 4; + if (*(Lisp_Object *)((char *)a + hh) != + *(Lisp_Object *)((char *)b + hh)) + return NO; + } + return YES; + } +#ifdef COMMON + else return eql_numbers(a, b); + +#else + else return NO; +#endif + } + case TAG_VECTOR: + return vec_equal(a, b); + default: + case TAG_BOXFLOAT: + { Header h = flthdr(a); + if (h != flthdr(b)) return NO; + h = length_of_header(h); +#ifdef COMMON + if (h == 8) /* Single float */ + { +#ifdef OLD_CODE + if (*(int32 *)(a + (4 - TAG_BOXFLOAT)) != + *(int32 *)(b + (4 - TAG_BOXFLOAT))) return NO; +#else + if (single_float_val(a) != single_float_val(b)) + return NO; +#endif + else return YES; + } + else +#endif +/* + * For the moment I view all non-single floats as double floats. Extra + * stuff will be needed here if I ever implement long floats as 3-word + * objects. + */ + { +#ifdef OLD_CODE + if ((*(int32 *)((char *)a + (8 - TAG_BOXFLOAT)) != + *(int32 *)((char *)b + (8 - TAG_BOXFLOAT))) || + (*(int32 *)((char *)a + (12 - TAG_BOXFLOAT)) != + *(int32 *)((char *)b + (12 - TAG_BOXFLOAT)))) + return NO; +#else + if (double_float_val(a) != double_float_val(b)) + return NO; +#endif + else return YES; + } + } + } + } +} + +#ifdef TRACED_EQUAL +#undef equal_fn +#define equal_fn(a, b) traced_equal(a, b, __FILE__, __LINE__, 0) +#endif + +static CSLbool vec_equal(Lisp_Object a, Lisp_Object b) +/* + * Here a and b are known to be vectors. Compare using recursive calls to + * EQUAL on all components. + */ +{ + Header ha = vechdr(a), hb = vechdr(b); + int32 l; + if (ha != hb) return NO; + l = (int32)doubleword_align_up(length_of_header(ha)); + if (vector_holds_binary(ha)) + { while ((l -= 4) != 0) + if (*((int32 *)((char *)a + l - TAG_VECTOR)) != + *((int32 *)((char *)b + l - TAG_VECTOR))) return NO; + return YES; + } + else + { if (is_mixed_header(ha)) + { while (l > 16) + { unsigned32 ea = *((unsigned32 *)((char *)a + l - TAG_VECTOR - 4)), + eb = *((unsigned32 *)((char *)b + l - TAG_VECTOR - 4)); + if (ea != eb) return NO; + l -= 4; + } + } + while ((l -= 4) != 0) + { Lisp_Object ea = *((Lisp_Object *)((char *)a + l - TAG_VECTOR)), + eb = *((Lisp_Object *)((char *)b + l - TAG_VECTOR)); + if (ea == eb) continue; + if (!equal(ea, eb)) return NO; + } + return YES; + } +} + +CSLbool equalp(Lisp_Object a, Lisp_Object b) +/* + * a and b are not EQ at this stage.. I guarantee to have checked that + * before entering this general purpose code. + */ +{ + Lisp_Object nil = C_nil; + CSL_IGNORE(nil); +/* + * The for loop at the top here is so that equalp can iterate along the + * length of linear lists. + */ +#ifdef CHECK_STACK + if (check_stack(__FILE__,__LINE__)) + { err_printf("Stack too deep in equalp\n"); + my_exit(EXIT_FAILURE); + } +#endif + for (;;) + { + int32 ta = (int32)a & TAG_BITS; + if (ta == TAG_CONS +#ifdef COMMON + && a != nil +#endif + ) + { if (!consp(b) +#ifdef COMMON + || b == nil +#endif + ) return NO; + else + { Lisp_Object ca = qcar(a), cb = qcar(b); + if (ca == cb) + { a = qcdr(a); + b = qcdr(b); + if (a == b) return YES; + continue; + } +/* + * And here, because equalp() seems to be a very important low-level + * primitive, I unwind one level of the recursion that would arise + * with nested lists. + */ + for (;;) + { + int32 tca = (int32)ca & TAG_BITS; + if (tca == TAG_CONS +#ifdef COMMON + && ca != nil +#endif + ) + { if (!consp(cb) +#ifdef COMMON + || cb == nil +#endif + ) return NO; + else + { Lisp_Object cca = qcar(ca), ccb = qcar(cb); + if (cca == ccb) + { ca = qcdr(ca); + cb = qcdr(cb); + if (ca == cb) break; + continue; + } +/* + * Do a real recursion when I get down to args like + * ((x ...) ...) ((y ...) ...) + */ + if (!equalp(cca, ccb)) return NO; + ca = qcdr(ca); + cb = qcdr(cb); + if (ca == cb) break; + continue; + } + } + else if (tca <= TAG_SYMBOL || + ((int32)cb & TAG_BITS) != tca) return NO; + else switch (tca) + { + case TAG_NUMBERS: + { Header h = numhdr(ca); + if (h != numhdr(cb)) return NO; + if (type_of_header(h) == TYPE_BIGNUM) + { int32 hh = (int32)length_of_header(h) - TAG_NUMBERS; + while (hh > (4 - TAG_NUMBERS)) + { hh -= 4; + if (*(Lisp_Object *)((char *)ca + hh) != + *(Lisp_Object *)((char *)cb + hh)) + return NO; + } + break; + } +#ifdef COMMON + else if (!eql_numbers(ca, cb)) return NO; + else break; +#else + else return NO; +#endif + } + case TAG_VECTOR: +/* /* At present vec_equal() is not right here */ + if (!vec_equal(ca, cb)) return NO; + break; + default: + case TAG_BOXFLOAT: + { Header h = flthdr(ca); + if (h != flthdr(cb)) return NO; + h = length_of_header(h); +#ifdef COMMON + if (h == 8) /* Single float */ + { +#ifdef OLD_CODE + if (*(int32 *)(ca + (4 - TAG_BOXFLOAT)) != + *(int32 *)(cb + (4 - TAG_BOXFLOAT))) + return NO; +#else + if (single_float_val(ca) != + single_float_val(cb)) return NO; +#endif + + else break; + } + else +#endif + { +#ifdef OLD_CODE + if ((*(int32 *)((char *)ca + + (8 - TAG_BOXFLOAT)) != + *(int32 *)((char *)cb + + (8 - TAG_BOXFLOAT))) || + (*(int32 *)((char *)ca + + (12 - TAG_BOXFLOAT)) != + *(int32 *)((char *)cb + + (12 - TAG_BOXFLOAT)))) return NO; +#else + if (double_float_val(ca) != + double_float_val(cb)) return NO; +#endif + else break; + } + } + } + break; /* out of the for (;;) loop */ + } + a = qcdr(a); + b = qcdr(b); + if (a == b) return YES; + continue; + } + } + else if (ta <= TAG_SYMBOL || + ((int32)b & TAG_BITS) != ta) return NO; + else switch (ta) + { + case TAG_NUMBERS: + { Header h = numhdr(a); + if (h != numhdr(b)) return NO; + if (type_of_header(h) == TYPE_BIGNUM) + { int32 hh = (int32)length_of_header(h) - TAG_NUMBERS; + while (hh > (4 - TAG_NUMBERS)) + { hh -= 4; + if (*(Lisp_Object *)((char *)a + hh) != + *(Lisp_Object *)((char *)b + hh)) + return NO; + } + return YES; + } +#ifdef COMMON + else return eql_numbers(a, b); + +#else + else return NO; +#endif + } + case TAG_VECTOR: +/* /* wrong for Common Lisp */ + return vec_equal(a, b); + default: + case TAG_BOXFLOAT: + { Header h = flthdr(a); + if (h != flthdr(b)) return NO; + h = length_of_header(h); +#ifdef COMMON + if (h == 8) /* Single float */ + { +#ifdef OLD_CODE + if (*(int32 *)(a + (4 - TAG_BOXFLOAT)) != + *(int32 *)(b + (4 - TAG_BOXFLOAT))) return NO; +#else + if (single_float_val(a) != single_float_val(b)) + return NO; +#endif + else return YES; + } + else +#endif +/* + * For the moment I view all non-single floats as double floats. Extra + * stuff will be needed here if I ever implement long floats as 3-word + * objects. + */ + { +#ifdef OLD_CODE + if ((*(int32 *)((char *)a + (8 - TAG_BOXFLOAT)) != + *(int32 *)((char *)b + (8 - TAG_BOXFLOAT))) || + (*(int32 *)((char *)a + (12 - TAG_BOXFLOAT)) != + *(int32 *)((char *)b + (12 - TAG_BOXFLOAT)))) + return NO; +#else + if (double_float_val(a) != double_float_val(b)) + return NO; +#endif + + else return YES; + } + } + } + } +} + +Lisp_Object Leq(Lisp_Object nil, Lisp_Object a, Lisp_Object b) +{ + return onevalue(Lispify_predicate(a == b)); +} + +Lisp_Object Leql(Lisp_Object nil, + Lisp_Object a, Lisp_Object b) +{ + return onevalue(Lispify_predicate(eql(a, b))); +} + +Lisp_Object Leqcar(Lisp_Object nil, + Lisp_Object a, Lisp_Object b) +{ + if (!consp(a)) return onevalue(nil); + a = qcar(a); +#ifdef COMMON + return onevalue(Lispify_predicate(eql(a, b))); +#else + return onevalue(Lispify_predicate(a == b)); +#endif +} + +Lisp_Object Lequalcar(Lisp_Object nil, + Lisp_Object a, Lisp_Object b) +{ + if (!consp(a)) return onevalue(nil); + a = qcar(a); + if (a == b) return lisp_true; + else return onevalue(Lispify_predicate(equal(a, b))); +} + +Lisp_Object Lcl_equal(Lisp_Object nil, Lisp_Object a, Lisp_Object b) +{ + if (a == b) return onevalue(lisp_true); + else return onevalue(Lispify_predicate(cl_equal(a, b))); +} + +Lisp_Object Lequal(Lisp_Object nil, Lisp_Object a, Lisp_Object b) +{ + if (a == b) return onevalue(lisp_true); + else return onevalue(Lispify_predicate(equal(a, b))); +} + +Lisp_Object Lequalp(Lisp_Object nil, Lisp_Object a, Lisp_Object b) +{ + if (a == b) return onevalue(lisp_true); + else return onevalue(Lispify_predicate(equalp(a, b))); +} + +Lisp_Object Lneq(Lisp_Object nil, + Lisp_Object a, Lisp_Object b) +{ + CSLbool r; +#ifdef COMMON + r = cl_equal(a, b); +#else + r = equal(a, b); +#endif + return onevalue(Lispify_predicate(!r)); +} + +Lisp_Object Lnull(Lisp_Object nil, Lisp_Object a) +{ + return onevalue(Lispify_predicate(a == nil)); +} + +Lisp_Object Lendp(Lisp_Object nil, Lisp_Object a) +{ + if (a == nil) return onevalue(lisp_true); + else if (is_cons(a)) return onevalue(nil); + else return error(1, err_bad_endp, a); +} + +Lisp_Object Lnreverse(Lisp_Object nil, Lisp_Object a) +{ + Lisp_Object b = nil; +#ifdef COMMON + if (is_vector(a)) + { int32 n = Llength(nil, a) - 0x10; + int32 i = TAG_FIXNUM; + while (n > i) + { Lisp_Object w = Laref2(nil, a, i); + Laset(nil, 3, a, i, Laref2(nil, a, n)); + Laset(nil, 3, a, n, w); + i += 0x10; + n -= 0x10; + } + return onevalue(a); + } +#endif + while (consp(a)) + { Lisp_Object c = a; + a = qcdr(a); + qcdr(c) = b; + b = c; + } + return onevalue(b); +} + +#ifdef COMMON + +/* + * nreverse0 is like nreverse except that if its input is atomic it gets + * returned intact rather than being converted to nil. + */ + +Lisp_Object Lnreverse0(Lisp_Object nil, Lisp_Object a) +{ + Lisp_Object b = nil; + if (!consp(a)) return onevalue(a); + b = a; + a = qcdr(a); + qcdr(b) = nil; + while (consp(a)) + { Lisp_Object c = a; + a = qcdr(a); + qcdr(c) = b; + b = c; + } + return onevalue(b); +} + +#endif + +Lisp_Object Lreverse(Lisp_Object nil, Lisp_Object a) +{ + Lisp_Object r; + stackcheck1(0, a); + nil = C_nil; + r = nil; + while (consp(a)) + { push(a); + r = cons(qcar(a), r); + pop(a); + errexit(); + a = qcdr(a); + } + return onevalue(r); +} + +Lisp_Object Lassoc(Lisp_Object nil, Lisp_Object a, Lisp_Object b) +{ +#ifdef TRACED_EQUAL + Lisp_Object save_b = b; + int pos = 0; +#endif + if (is_symbol(a) || is_fixnum(a)) + { while (consp(b)) + { Lisp_Object c = qcar(b); + if (consp(c) && a == qcar(c)) return onevalue(c); + b = qcdr(b); + } + return onevalue(nil); + } + while (consp(b)) + { Lisp_Object c = qcar(b); + if (consp(c)) + { Lisp_Object cc = qcar(c); +#ifdef COMMON + if (cl_equal(a, cc)) return onevalue(c); +#else + if (equal(a, cc)) + { +#ifdef TRACED_EQUAL + trace_printf("Assoc YES %3d %3d ", pos, int_of_fixnum(Llength(nil,save_b))); + prin_to_stdout(a); trace_printf("\n"); +#endif + return onevalue(c); + } +#endif + } + b = qcdr(b); +#ifdef TRACED_EQUAL + pos++; +#endif + } +#ifdef TRACED_EQUAL + trace_printf("Assoc NO %3d %3d ", pos, int_of_fixnum(Llength(nil,save_b))); + prin_to_stdout(a); trace_printf("\n"); +#endif + return onevalue(nil); +} + +Lisp_Object Latsoc(Lisp_Object nil, Lisp_Object a, Lisp_Object b) +{ +#ifdef COMMON + if (is_symbol(a) || is_fixnum(a)) + { while (consp(b)) + { Lisp_Object c = qcar(b); + if (consp(c) && a == qcar(c)) return onevalue(c); + b = qcdr(b); + } + return onevalue(nil); + } +#endif + while (consp(b)) + { Lisp_Object c = qcar(b); +/* + * eql() can neither fail nor call the garbage collector, so I do + * not need to stack things here. + */ +#ifdef COMMON + if (consp(c) && eql(a, qcar(c))) return onevalue(c); +#else + if (consp(c) && a == qcar(c)) return onevalue(c); +#endif + b = qcdr(b); + } + return onevalue(nil); +} + +Lisp_Object Lmember(Lisp_Object nil, Lisp_Object a, Lisp_Object b) +{ + if (is_symbol(a) || is_fixnum(a)) + { while (consp(b)) + { if (a == qcar(b)) return onevalue(b); + b = qcdr(b); + } + return onevalue(nil); + } + while (consp(b)) + { Lisp_Object cb = qcar(b); +#ifdef COMMON + if (cl_equal(a, cb)) return onevalue(b); +#else + if (equal(a, cb)) return onevalue(b); +#endif + b = qcdr(b); + } + return onevalue(nil); +} + +Lisp_Object Lmemq(Lisp_Object nil, Lisp_Object a, Lisp_Object b) +{ +#ifdef COMMON + if (is_symbol(a) || is_fixnum(a)) + { while (consp(b)) + { if (a == qcar(b)) return onevalue(b); + b = qcdr(b); + } + return onevalue(nil); + } +#endif + while (consp(b)) +/* + * Note that eql() can never fail, and so checking for errors + * and stacking a and b across the call to it is not necessary. + */ + { +#ifdef COMMON + if (eql(a, qcar(b))) return onevalue(b); +#else + if (a == qcar(b)) return onevalue(b); +#endif + b = qcdr(b); + } + return onevalue(nil); +} + +static CSLbool smemq(Lisp_Object a, Lisp_Object b) +{ +/* + * /* This is a bit worrying - it can use C recursion to arbitrary + * depth without any checking for overflow, and hence it can ESCAPE + * if (e.g.) given cyclic structures. Some alteration is needed. As + * things stand the code can never give wrong answers via GC rearrangement - + * the problem is closer to being that it can never call the GC. + */ +#ifdef COMMON + Lisp_Object nil = C_nil; +#else + nil_as_base +#endif + while (consp(b)) + { Lisp_Object w = qcar(b); + if (w == quote_symbol) return NO; + else if (smemq(a, w)) return YES; + else b = qcdr(b); + } + return (a == b); +} + +Lisp_Object Lsmemq(Lisp_Object nil, Lisp_Object a, Lisp_Object b) +{ + CSLbool r; + r = smemq(a, b); + errexit(); + return onevalue(Lispify_predicate(r)); +} + +/* + * (defun contained (x y) + * (cond ((atom y) (equal x y)) + * ((equal x y) 't) + * ('t (or (contained x (car y)) (contained x (cdr y)))))) + */ + +static CSLbool containedeq(Lisp_Object nil, Lisp_Object x, Lisp_Object y) +{ + while (consp(y)) + { if (containedeq(nil, x, qcar(y))) return YES; + y = qcdr(y); + } + return (x == y); +} + +static CSLbool containedequal(Lisp_Object nil, Lisp_Object x, Lisp_Object y) +{ + while (consp(y)) + { if (equal(x, y)) return YES; + if (containedequal(nil, x, qcar(y))) return YES; + y = qcdr(y); + } + return equal(x, y); +} + +static Lisp_Object Lcontained(Lisp_Object nil, Lisp_Object x, Lisp_Object y) +{ + CSLbool r; + if (is_symbol(x) || is_fixnum(x)) r = containedeq(nil, x, y); + else r = containedequal(nil, x, y); + errexit(); + return onevalue(Lispify_predicate(r)); +} + +Lisp_Object Llast(Lisp_Object nil, Lisp_Object a) +{ + Lisp_Object b; + if (!consp(a)) return aerror1("last", a); + while (b = qcdr(a), consp(b)) a = b; + return onevalue(qcar(a)); +} + +Lisp_Object Llastpair(Lisp_Object nil, Lisp_Object a) +{ + Lisp_Object b; + if (!consp(a)) return onevalue(a); /* aerror1("lastpair", a); */ + while (b = qcdr(a), consp(b)) a = b; + return onevalue(a); +} + +Lisp_Object Llength(Lisp_Object nil, Lisp_Object a) +{ + if (a == nil) return onevalue(fixnum_of_int(0)); + if (is_cons(a)) + { Lisp_Object n; +/* + * Possibly I should do something to trap cyclic lists.. ? + */ + n = fixnum_of_int(1); +/* + * I have unrolled the loop here 4 times since I expect length to be + * tolerably heavily used. Look at the assembly code generated for + * this to see if it was useful or counterproductive! + */ + for (;;) + { a = qcdr(a); + if (!consp(a)) return onevalue(n); + a = qcdr(a); + if (!consp(a)) return onevalue((Lisp_Object)((int32)n + (1 << 4))); + a = qcdr(a); + if (!consp(a)) return onevalue((Lisp_Object)((int32)n + (2 << 4))); + a = qcdr(a); + if (!consp(a)) return onevalue((Lisp_Object)((int32)n + (3 << 4))); + n = (Lisp_Object)((int32)n + (4 << 4)); + } + } +#ifndef COMMON + return onevalue(fixnum_of_int(0)); /* aerror("length");??? */ +#else +/* + * Common Lisp expects length to find the length of vectors + * as well as lists. + */ + else if (!is_vector(a)) return aerror1("length", a); + else + { Header h = vechdr(a); + int32 n = length_of_header(h) - 4; + if (type_of_header(h) == TYPE_ARRAY) + { Lisp_Object dims = elt(a, 1); + Lisp_Object fillp = elt(a, 5); + if (consp(dims) && !consp(qcdr(dims))) dims = qcar(dims); + else return aerror1("length", a); /* Not one-dimensional */ + if (is_fixnum(fillp)) dims = fillp; + return onevalue(dims); + } + if (header_of_bitvector(h)) + { n = (n - 1)*8; +/* Dodgy constant on next line - critically dependent on tag codes used! */ + n += ((h & 0x380) >> 7) + 1; + } + else if (type_of_header(h) != TYPE_STRING) n = n >> 2; + return onevalue(fixnum_of_int(n)); + } +#endif +} + +#ifdef COMMON + +Lisp_Object MS_CDECL Lappend_n(Lisp_Object nil, int nargs, ...) +{ + va_list a; + int i; + Lisp_Object r; + if (nargs == 0) return onevalue(nil); + va_start(a, nargs); + push_args(a, nargs); +/* + * The actual args have been passed a C args - I can not afford to + * risk garbage collection until they have all been moved somewhere safe, + * and here that safe place is the Lisp stack. I have to delay checking for + * overflow on same until all args have been pushed. + */ + stackcheck0(nargs); + nil = C_nil; + r = nil; +/* + * rearrange order of items on the stack... + * The idea is that I will then reverse-copy the args in the order a1, + * a2 , ... to make a result list. But I want to pop the stack as soon as + * I can, so I need arg1 on the TOP of the stack. + */ + for (i = 0; 2*i+1