/* fns2.c Copyright (C) 1989-2002 Codemist Ltd */ /* * Basic functions part 2. */ /* * This code may be used and modified, and redistributed in binary * or source form, subject to the "CCL Public License", which should * accompany it. This license is a variant on the BSD license, and thus * permits use of code derived from this in either open and commercial * projects: but it does require that updates to this code be made * available back to the originators of the package. * Before merging other code in with this or linking this code * with other packages or libraries please check that the license terms * of the other material are compatible with those of this. */ /* Signature: 3fc8c70b 10-Oct-2002 */ #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, intxx 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 (;;) { intxx alloc_size = (intxx)doubleword_align_up(size); char *cf = (char *)codefringe, *cl = (char *)codelimit; unsignedxx free = cf - cl; char *r; if (alloc_size > (intxx)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; /* * codelimit is always 8 bytes above the base of the code-page. The * address I need to return for a code-vector points (in a packed way) * to the first byte of actual byte data, ie CELL bytes above the start * of the data-structure. Oh joy! */ return TAG_BPS + (((int32)((r + CELL) - (cl - 8)) & (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+CELL); errexit(); return onevalue(n); } Lisp_Object get_native_code_vector(intxx 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 (;;) { intxx alloc_size = (intxx)doubleword_align_up(size); intxx cf = native_fringe; intxx 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 = (intxx)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. */ car32(free+native_fringe) = alloc_size; car32(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)) { if (symbol_protect_flag) { if (warn_about_protected_symbols) { trace_printf("+++ WARNING: protected function "); prin_to_trace(a); trace_printf(" not redefined\n"); } return; } else { if (warn_about_protected_symbols) { trace_printf("+++ WARNING: protected function "); prin_to_trace(a); trace_printf(" *has* been redefined\n"); } Lsymbol_protect(C_nil, a, C_nil); } } ifn1(a) = (intxx)f1; ifn2(a) = (intxx)f2; ifnn(a) = (intxx)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, t_p, arginfo; intxx address, page, bps; #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 = (intxx)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; w2 = nil; 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) == (size_t)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 Lisp_Object traced1_function(Lisp_Object env, Lisp_Object a) { Lisp_Object name, nil = C_nil; Lisp_Object r = nil; /* * Worry about errors & garbage collection in following calls to print fns * This MUST be fixed sometime fairly soon... but then it could only bite * people using the trace facility, and their code is already dead! */ freshline_trace(); loop_print_trace(tracedfn); push(tracedfn); trace_printf(" called (1 arg)\narg1: "); loop_print_trace(a); trace_printf("\n"); r = (*displaced1)(env, a); pop(name); errexit(); push(r); freshline_trace(); loop_print_trace(name); trace_printf(" = "); loop_print_trace(r); trace_printf("\n"); pop(r); return onevalue(r); } static Lisp_Object traced2_function(Lisp_Object env, Lisp_Object a, Lisp_Object b) { Lisp_Object name, nil = C_nil; Lisp_Object r = nil; freshline_trace(); loop_print_trace(tracedfn); push(tracedfn); trace_printf(" called (2 args)\narg1:"); loop_print_trace(a); trace_printf("\narg2: "); loop_print_trace(b); trace_printf("\n"); r = (*displaced2)(env, a, b); pop(name); errexit(); push(r); freshline_trace(); loop_print_trace(name); trace_printf(" = "); loop_print_trace(r); trace_printf("\n"); pop(r); return onevalue(r); } static Lisp_Object MS_CDECL tracedn_function(Lisp_Object env, int nargs, ...) { Lisp_Object name, nil = C_nil; Lisp_Object r = nil; int i; va_list a; push(tracedfn); va_start(a, nargs); push_args(a, nargs); freshline_trace(); loop_print_trace(tracedfn); trace_printf(" called (%d args)\n", nargs); for (i=1; i<=nargs; i++) { trace_printf("arg%d: ", i); loop_print_trace(stack[i-nargs]); trace_printf("\n"); } if (nargs <= 15) switch (nargs) { default: /* * Calls with 1 or 2 args can never arise, since those cases have been * split off for separate treatment. */ popv(nargs+1); return aerror("system error in trace mechanism"); case 0: r = (*displacedn)(env, 0); break; case 3: r = (*displacedn)(env, 3, stack[-2], stack[-1], stack[0]); break; case 4: r = (*displacedn)(env, 4, stack[-3], stack[-2], stack[-1], stack[0]); break; case 5: r = (*displacedn)(env, 5, stack[-4], stack[-3], stack[-2], stack[-1], stack[0]); break; case 6: r = (*displacedn)(env, 6, stack[-5], stack[-4], stack[-3], stack[-2], stack[-1], stack[0]); break; case 7: r = (*displacedn)(env, 7, stack[-6], stack[-5], stack[-4], stack[-3], stack[-2], stack[-1], stack[0]); break; case 8: r = (*displacedn)(env, 8, stack[-7], stack[-6], stack[-5], stack[-4], stack[-3], stack[-2], stack[-1], stack[0]); break; case 9: r = (*displacedn)(env, 9, stack[-8], stack[-7], stack[-6], stack[-5], stack[-4], stack[-3], stack[-2], stack[-1], stack[0]); break; case 10: r = (*displacedn)(env, 10, stack[-9], stack[-8], stack[-7], stack[-6], stack[-5], stack[-4], stack[-3], stack[-2], stack[-1], stack[0]); break; case 11: r = (*displacedn)(env, 11, stack[-10], stack[-9], stack[-8], stack[-7], stack[-6], stack[-5], stack[-4], stack[-3], stack[-2], stack[-1], stack[0]); break; case 12: r = (*displacedn)(env, 12, stack[-11], stack[-10], stack[-9], stack[-8], stack[-7], stack[-6], stack[-5], stack[-4], stack[-3], stack[-2], stack[-1], stack[0]); break; case 13: r = (*displacedn)(env, 13, stack[-12], stack[-11], stack[-10], stack[-9], stack[-8], stack[-7], stack[-6], stack[-5], stack[-4], stack[-3], stack[-2], stack[-1], stack[0]); break; case 14: r = (*displacedn)(env, 14, stack[-13], stack[-12], stack[-11], stack[-10], stack[-9], stack[-8], stack[-7], stack[-6], stack[-5], stack[-4], stack[-3], stack[-2], stack[-1], stack[0]); break; case 15: r = (*displacedn)(env, 15, stack[-14], stack[-13], stack[-12], stack[-11], stack[-10], stack[-9], stack[-8], stack[-7], stack[-6], stack[-5], stack[-4], stack[-3], stack[-2], stack[-1], stack[0]); break; } else { trace_printf("Too many arguments to trace a function\n"); /* * Because the above is a horrid mess I will only support traced * calls with at most 15 args (more than I expect most people to * try). And this only applies to thigs that are NOT bytecoded - * I can trace bytecoded things with more args I believe, so users are not * utterly lost I hope. */ return aerror("traced function with > 15 args: not supported"); } popv(nargs); pop(name); errexit(); push(r); freshline_trace(); loop_print_trace(name); trace_printf(" = "); loop_print_trace(r); trace_printf("\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 CSL_IGNORE(nil); CSL_IGNORE(a); 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) = (intxx)tracebytecoded0, done = 1; if (f1 == bytecoded1) ifn1(s) = (intxx)tracebytecoded1, done = 1; if (f2 == bytecoded2) ifn2(s) = (intxx)tracebytecoded2, done = 1; if (fn == bytecoded3) ifnn(s) = (intxx)tracebytecoded3, done = 1; if (fn == bytecodedn) ifnn(s) = (intxx)tracebytecodedn, done = 1; if (f1 == byteopt1) ifn1(s) = (intxx)tracebyteopt1, done = 1; if (f2 == byteopt2) ifn2(s) = (intxx)tracebyteopt2, done = 1; if (fn == byteoptn) ifnn(s) = (intxx)tracebyteoptn, done = 1; if (f1 == hardopt1) ifn1(s) = (intxx)tracehardopt1, done = 1; if (f2 == hardopt2) ifn2(s) = (intxx)tracehardopt2, done = 1; if (fn == hardoptn) ifnn(s) = (intxx)tracehardoptn, done = 1; if (f1 == byteoptrest1) ifn1(s) = (intxx)tracebyteoptrest1, done = 1; if (f2 == byteoptrest2) ifn2(s) = (intxx)tracebyteoptrest2, done = 1; if (fn == byteoptrestn) ifnn(s) = (intxx)tracebyteoptrestn, done = 1; if (f1 == hardoptrest1) ifn1(s) = (intxx)tracehardoptrest1, done = 1; if (f2 == hardoptrest2) ifn2(s) = (intxx)tracehardoptrest2, done = 1; if (fn == hardoptrestn) ifnn(s) = (intxx)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) = (intxx)bytecoded1; if (f2 == tracebytecoded2) ifn2(s) = (intxx)bytecoded2; if (fn == tracebytecoded0) ifnn(s) = (intxx)bytecoded0; if (fn == tracebytecoded3) ifnn(s) = (intxx)bytecoded3; if (fn == tracebytecodedn) ifnn(s) = (intxx)bytecodedn; if (f1 == tracebyteopt1) ifn1(s) = (intxx)byteopt1; if (f2 == tracebyteopt2) ifn2(s) = (intxx)byteopt2; if (fn == tracebyteoptn) ifnn(s) = (intxx)byteoptn; if (f1 == tracebyteoptrest1) ifn1(s) = (intxx)byteoptrest1; if (f2 == tracebyteoptrest2) ifn2(s) = (intxx)byteoptrest2; if (fn == tracebyteoptrestn) ifnn(s) = (intxx)byteoptrestn; if (f1 == tracehardopt1) ifn1(s) = (intxx)hardopt1; if (f2 == tracehardopt2) ifn2(s) = (intxx)hardopt2; if (fn == tracehardoptn) ifnn(s) = (intxx)hardoptn; if (f1 == tracehardoptrest1) ifn1(s) = (intxx)hardoptrest1; if (f2 == tracehardoptrest2) ifn2(s) = (intxx)hardoptrest2; if (fn == tracehardoptrestn) ifnn(s) = (intxx)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) = (intxx)double_bytecoded0, done = 1; if (f1 == bytecoded1) ifn1(s) = (intxx)double_bytecoded1, done = 1; if (f2 == bytecoded2) ifn2(s) = (intxx)double_bytecoded2, done = 1; if (fn == bytecoded3) ifnn(s) = (intxx)double_bytecoded3, done = 1; if (fn == bytecodedn) ifnn(s) = (intxx)double_bytecodedn, done = 1; if (f1 == byteopt1) ifn1(s) = (intxx)double_byteopt1, done = 1; if (f2 == byteopt2) ifn2(s) = (intxx)double_byteopt2, done = 1; if (fn == byteoptn) ifnn(s) = (intxx)double_byteoptn, done = 1; if (f1 == hardopt1) ifn1(s) = (intxx)double_hardopt1, done = 1; if (f2 == hardopt2) ifn2(s) = (intxx)double_hardopt2, done = 1; if (fn == hardoptn) ifnn(s) = (intxx)double_hardoptn, done = 1; if (f1 == byteoptrest1) ifn1(s) = (intxx)double_byteoptrest1, done = 1; if (f2 == byteoptrest2) ifn2(s) = (intxx)double_byteoptrest2, done = 1; if (fn == byteoptrestn) ifnn(s) = (intxx)double_byteoptrestn, done = 1; if (f1 == hardoptrest1) ifn1(s) = (intxx)double_hardoptrest1, done = 1; if (f2 == hardoptrest2) ifn2(s) = (intxx)double_hardoptrest2, done = 1; if (fn == hardoptrestn) ifnn(s) = (intxx)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) = (intxx)bytecoded1; else if (f2 == double_bytecoded2) ifn2(s) = (intxx)bytecoded2; else if (fn == double_bytecoded0) ifnn(s) = (intxx)bytecoded0; else if (fn == double_bytecoded3) ifnn(s) = (intxx)bytecoded3; else if (fn == double_bytecodedn) ifnn(s) = (intxx)bytecodedn; else if (f1 == double_byteopt1) ifn1(s) = (intxx)byteopt1; else if (f2 == double_byteopt2) ifn2(s) = (intxx)byteopt2; else if (fn == double_byteoptn) ifnn(s) = (intxx)byteoptn; else if (f1 == double_byteoptrest1) ifn1(s) = (intxx)byteoptrest1; else if (f2 == double_byteoptrest2) ifn2(s) = (intxx)byteoptrest2; else if (fn == double_byteoptrestn) ifnn(s) = (intxx)byteoptrestn; else if (f1 == double_hardopt1) ifn1(s) = (intxx)hardopt1; else if (f2 == double_hardopt2) ifn2(s) = (intxx)hardopt2; else if (fn == double_hardoptn) ifnn(s) = (intxx)hardoptn; else if (f1 == double_hardoptrest1) ifn1(s) = (intxx)hardoptrest1; else if (f2 == double_hardoptrest2) ifn2(s) = (intxx)hardoptrest2; else if (fn == double_hardoptrestn) ifnn(s) = (intxx)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) { unsignedxx len; Lisp_Object nil = C_nil; char genname[64]; len = length_of_header(vechdr(name)) - CELL; if (len > 60) len = 60; /* Unpublished truncation of the string */ sprintf(genname, "%.*s%lu", (int)len, (char *)name + (CELL - 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; push(a); b1 = b = Lexploden(nil, b); pop(a); 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++] = (char)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 + (CELL - TAG_NUMBERS)); q = *(Lisp_Object *)(b + (CELL - TAG_NUMBERS)); if (!eql(p, q)) return NO; p = *(Lisp_Object *)(a + (2*CELL - TAG_NUMBERS)); q = *(Lisp_Object *)(b + (2*CELL - 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; #ifdef COMMON if (type_of_header(h) == TYPE_SINGLE_FLOAT) return (single_float_val(a) == single_float_val(b)); 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. */ return (double_float_val(a) == double_float_val(b)); } else /* ratio, complex or bignum */ { Header h = numhdr(a); if (h != numhdr(b)) return NO; if (type_of_header(h) == TYPE_BIGNUM) { intxx hh = (intxx)length_of_header(h) - TAG_NUMBERS; while (hh > (intxx)(CELL - TAG_NUMBERS)) { hh -= 4; if (*(unsigned32 *)((char *)a + hh) != *(unsigned32 *)((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); intxx offa = 0, offb = 0; int ta = type_of_header(ha), tb = type_of_header(hb); intxx 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) { intxx hh = (intxx)length_of_header(h) - TAG_NUMBERS; while (hh > (intxx)(CELL - TAG_NUMBERS)) { hh -= 4; if (*(unsigned32 *)((char *)ca + hh) != *(unsigned32 *)((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; #ifdef COMMON if (type_of_header(h) == TYPE_SINGLE_FLOAT) { if (single_float_val(ca) != single_float_val(cb)) return NO; else break; } else #endif { if (double_float_val(ca) != double_float_val(cb)) return NO; 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; /* * OK - now a and b both have the same type and neither are immediate data * conses or symbols. That leaves vectors (including strings) and boxed * numbers. */ else switch (ta) { case TAG_NUMBERS: { Header h = numhdr(a); if (h != numhdr(b)) return NO; if (type_of_header(h) == TYPE_BIGNUM) { intxx hh = (intxx)length_of_header(h) - TAG_NUMBERS; while (hh > (intxx)(CELL - TAG_NUMBERS)) { hh -= 4; if (*(unsigned32 *)((char *)a + hh) != *(unsigned32 *)((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; #ifdef COMMON if (type_of_header(h) == TYPE_SINGLE_FLOAT) { if (single_float_val(a) != single_float_val(b)) return NO; 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. */ { if (double_float_val(a) != double_float_val(b)) return NO; 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 = 169*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 (intxx)(CELL - TAG_NUMBERS)) { hh -= 4; if (*(unsigned32 *)((char *)ca + hh) != *(unsigned32 *)((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; #ifdef COMMON if (type_of_header(h) == TYPE_SINGLE_FLOAT) { if (single_float_val(ca) != single_float_val(cb)) return NO; else break; } else #endif { if (double_float_val(ca) != double_float_val(cb)) return NO; 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) { intxx hh = (intxx)length_of_header(h) - TAG_NUMBERS; while (hh > (intxx)(CELL - TAG_NUMBERS)) { hh -= 4; if (*(unsigned32 *)((char *)a + hh) != *(unsigned32 *)((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; #ifdef COMMON if (type_of_header(h) == TYPE_SINGLE_FLOAT) { if (single_float_val(a) != single_float_val(b)) return NO; 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. */ { if (double_float_val(a) != double_float_val(b)) return NO; 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 (*((unsigned32 *)((char *)a + l - TAG_VECTOR)) != *((unsigned32 *)((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 -= CELL) != 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) { intxx hh = (intxx)length_of_header(h) - TAG_NUMBERS; while (hh > (intxx)(CELL - TAG_NUMBERS)) { hh -= 4; if (*(unsigned32 *)((char *)ca + hh) != *(unsigned32 *)((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; #ifdef COMMON if (type_of_header(h) == TYPE_SINGLE_FLOAT) { if (single_float_val(ca) != single_float_val(cb)) return NO; else break; } else #endif { if (double_float_val(ca) != double_float_val(cb)) return NO; 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; /* What is left is vectors, strings and boxed numbers */ else switch (ta) { case TAG_NUMBERS: { Header h = numhdr(a); if (h != numhdr(b)) return NO; if (type_of_header(h) == TYPE_BIGNUM) { intxx hh = (intxx)length_of_header(h) - TAG_NUMBERS; while (hh > (intxx)(CELL - TAG_NUMBERS)) { hh -= 4; if (*(unsigned32 *)((char *)a + hh) != *(unsigned32 *)((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; #ifdef COMMON if (type_of_header(h) == TYPE_SINGLE_FLOAT) { if (single_float_val(a) != single_float_val(b)) return NO; 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. */ { if (double_float_val(a) != double_float_val(b)) return NO; 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); } Lisp_Object Lnreverse2(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { CSL_IGNORE(nil); 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; CSL_IGNORE(nil); 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; CSL_IGNORE(nil); 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) - CELL; 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/CELL; 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