Artifact 7e8e87381a6a5b6499467cc8af6b6c74580b597a7893f856a031d312d0726e76:
- Executable file
r36/cslbase/read.c
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 140326) [annotate] [blame] [check-ins using] [more...]
/* read.c Copyright (C) 1990-1996 Codemist Ltd */ /* * Reading and symbol-table support. */ /* Signature: 69447962 12-Mar-2000 */ #include <stdarg.h> #include <string.h> #include <ctype.h> #ifdef __WATCOMC__ #include <float.h> #endif #include "machine.h" #include "tags.h" #include "cslerror.h" #include "externs.h" #include "read.h" #include "stream.h" #include "arith.h" #include "entries.h" #ifdef COMMON #include "clsyms.h" #endif #ifdef TIMEOUT #include "timeout.h" #endif #ifdef SOCKETS #include "sockhdr.h" #endif #define CTRL_C 3 #define CTRL_D 4 #ifdef Kanji #define ISalpha(a) iswalpha(a) #define ISdigit(a) iswdigit(a) #define ISspace(a) iswspace(a) #define TOupper(a) towupper(a) #define TOlower(a) towlower(a) int first_char(Lisp_Object ch) { /* ch is a symbol. Get the first character of its name. */ int n; ch = qpname(ch); n = celt(ch, 0); if (is2byte(n) && length_of_header(vechdr(ch)) != CELL) n = (n << 8) + ucelt(ch, 1); return n; } #else /* Kanji */ #define ISalpha(a) isalpha(a) #define ISdigit(a) isdigit(a) #define ISspace(a) isspace(a) #define TOupper(a) toupper(a) #define TOlower(a) tolower(a) #define first_char(ch) ucelt(qpname(ch), 0) #endif /* Kanji */ /* * Basic version of Lisp reader. */ static int curchar = NOT_CHAR; FILE *non_terminal_input; static int boffop; #define boffo_char(i) ucelt(boffo, i) Lisp_Object make_string(char *b) /* * Given a C string, create a Lisp (simple-) string. */ { int32 n = strlen(b); Lisp_Object r = getvector(TAG_VECTOR, TYPE_STRING, CELL+n); char *s = (char *)r - TAG_VECTOR; int32 k = (n + 3) & ~(int32)7; Lisp_Object nil; errexit(); /* Here I go to some trouble to zero out the last doubleword of the vector */ #ifdef ADDRESS_64 if (k != 0) { *(int32 *)(s + k + 4) = 0; *(int32 *)(s + k) = 0; } #else *(int32 *)(s + k + 4) = 0; if (k != 0) *(int32 *)(s + k) = 0; #endif memcpy(s + CELL, b, (size_t)n); return r; } static Lisp_Object copy_string(Lisp_Object str, int32 n) /* * Given a Lisp string, plus its length, create a Lisp (simple-) string. */ { Lisp_Object nil, r; char *s; int32 k; push(str); r = getvector(TAG_VECTOR, TYPE_STRING, CELL+n); pop(str); s = (char *)r - TAG_VECTOR; k = (n + 3) & ~(int32)7; errexit(); /* Here I go to some trouble to zero out the last doubleword of the vector */ #ifdef ADDRESS_64 if (k != 0) { *(int32 *)(s + k + 4) = 0; *(int32 *)(s + k) = 0; } #else *(int32 *)(s + k + 4) = 0; if (k != 0) *(int32 *)(s + k) = 0; #endif memcpy(s + CELL, (char *)str + (CELL-TAG_VECTOR), (size_t)n); return r; } Lisp_Object MS_CDECL Lbatchp(Lisp_Object nil, int nargs, ...) { CSL_IGNORE(nil); argcheck(nargs, 0, "batchp"); #ifdef SOCKETS /* * If CSL is being run as a service (ie accessed via a socket) then I will * deem it to be in "interactive" mode. This leaves responsibility for stopping * after errors (if that is what is wanted) with the other end of the * communications link. */ if (socket_server != 0) return onevalue(nil); #endif /* * If the user had specified input files on the command line I will say that * we are in batch mode even if there is a terminal present somewhere. So * a run of the form * csl inputfile.lsp * is a "batch" run, while * csl < inputfile.lsp * will MAYBE also be noticed as batch, but do not count on it! */ if (non_terminal_input != NULL) return onevalue(batch_flag ? nil : lisp_true); /* * "sysxxx.c" now decides if we are in "batch processing" context, * in general by asking "isatty(fileno(stdin))" to see if stdin is * attached to an interactive terminal. Ideally this will say we are in * batch mode if the user has redirected input from a file, as in * csl < xxx.lsp * but catching such cases may be HARD with some operating systems. * With some operating systems we will NEVER report ourselves as "batch". */ return onevalue(Lispify_predicate(batch_flag ? !batchp : batchp())); } Lisp_Object Lgetenv(Lisp_Object nil, Lisp_Object a) { char parmname[LONGEST_LEGAL_FILENAME]; Header h; Lisp_Object r; int32 len; char *w; #ifdef COMMON if (complex_stringp(a)) { a = simplify_string(a); errexit(); } #endif if (symbolp(a)) { a = get_pname(a); errexit(); h = vechdr(a); } else if (!is_vector(a) || type_of_header(h = vechdr(a)) != TYPE_STRING) return aerror1("getenv", a); len = length_of_header(h) - CELL; memcpy(parmname, (char *)a + (CELL-TAG_VECTOR), (size_t)len); parmname[len] = 0; w = my_getenv(parmname); if (w == NULL) return onevalue(nil); /* not available */ r = make_string(w); errexit(); return onevalue(r); } Lisp_Object Lsystem(Lisp_Object nil, Lisp_Object a) { char parmname[LONGEST_LEGAL_FILENAME]; Header h; int32 len; int w; #ifdef SOCKETS /* * Security measure - remote client can not do "system" */ if (socket_server != 0) return onevalue(nil); #endif if (a == nil) /* enquire if command processor is available */ { w = my_system(NULL); return onevalue(Lispify_predicate(w != 0)); } #ifdef COMMON if (complex_stringp(a)) { a = simplify_string(a); errexit(); } #endif if (symbolp(a)) { a = get_pname(a); errexit();nil = C_nil; h = vechdr(a); } else if (!is_vector(a) || type_of_header(h = vechdr(a)) != TYPE_STRING) return aerror1("system", a); len = length_of_header(h) - CELL; memcpy(parmname, (char *)a + (CELL-TAG_VECTOR), (size_t)len); parmname[len] = 0; w = my_system(parmname); return onevalue(fixnum_of_int((int32)w)); } static unsigned32 hash_lisp_string_with_length(Lisp_Object s, int32 n) { /* * I start off the hash calculation with something that depends on the * length of the string n. */ unsigned32 hh = 0x01000000 + n; unsigned32 *b = (unsigned32 *)((char *)s + (CELL-TAG_VECTOR)); char *b1; while (n >= 8) /* Do as much as is possible word at a time */ { unsigned32 temp; /* * The next few lines take a 32-bit value with digits PQRS and for a value * with digits Q^R and P^Q^R^S. Note that this is invariant under the change * to SRQP, and thus even though I fetched a whole word and the order of bytes * in that word is hard to know the hash value will not depend on the byte * order involved. By that time I have done all this and thereby lost any * chance of ABCD and DCBA not clashing maybe a simple byte at a time hash * procedure would have been more sense? Some day I should take comparative * timings and measurements of hash-table conflicts. */ unsigned32 a = *b++; /* P Q R S */ a = a ^ (a << 8); /* P^Q Q^R R^S S */ a = a ^ (a >> 16); /* P^Q Q^R P^Q^R^S Q^R^S */ a = a << 8; /* Q^R P^Q^R^S Q^R^S 0 */ /* * And now compute a hash value using a CRC that has a period of * 0x7fffffff (i.e. maximum period in 31 bits). And at least if shift * operations are cheap on your computer it can be evaluated rapidly as well. */ temp = hh << 7; hh = ((hh >> 25) ^ (temp >> 1) ^ (temp >> 4) ^ (a >> 16)) & 0x7fffffff; n -= 4; } b1 = (char *)b; /* * Finish off the hash value byte-at-a-time. If I could be certain that * strings being hashed would always be zero-padded in their last word I * could avoid the need for this, but at present I can not. */ while (n > 4) { unsigned32 temp; temp = hh << 7; hh = ((hh >> 25) ^ (temp >> 1) ^ (temp >> 4) ^ (unsigned32)*b1++) & 0x7fffffff; n -= 1; } /* * At the end I multiply by 139 so that at least symbols that differ * by just having adjacent last letters will be better spread out. */ return ((139*hh) & 0x7fffffff); } unsigned32 hash_lisp_string(Lisp_Object s) /* * Argument is a (lisp) string. Return a 31 bit hash value. */ { return hash_lisp_string_with_length(s, length_of_header(vechdr(s))); } static int value_in_radix(int c, int radix) { if (ISdigit(c)) c = c - '0'; /* Assumes digit codes are consecutive */ /* * The next section tries hard not to depend on any particular character * code - this may slow it down a little bit but reading numbers that * have an explicit radix will not usually matter that much. */ else if (ISalpha(c)) { char *v = "abcdefghijklmnopqrstuvwxyz"; int n = 0; c = tolower(c); while (*v++ != c) if (++n >= 26) return -1; /* break on unrecognized letter */ c = n + 10; } else return -1; if (c < radix) return c; else return -1; } Lisp_Object intern(int len, CSLbool escaped) /* * This takes whatever is in the first len characters of * the Lisp string boffo, and maps it into a number, string * or symbol as relevant. */ { int i, numberp = escaped ? -1 : 0; #ifdef COMMON int fplength = 2, explicit_fp_format = 0; #endif Lisp_Object nil = C_nil; stackcheck0(0); for (i=0; i<len; i++) { int c = boffo_char(i); switch (numberp) { default: break; case 0: if (c == '+' | c == '-') { numberp = 1; continue; } /* drop through */ case 1: if (c == '.') { numberp = 6; continue; } if (ISdigit(c)) /* Really wants to inspect *read-base* */ { numberp = 2; continue; } numberp = -1; break; case 2: if (ISdigit(c)) continue; /* *read-base* */ switch (c) { #ifdef COMMON case '/': numberp = 3; continue; #endif case '.': numberp = 5; continue; case 'e': case 'E': /* * in CSL mode I will read all floating point numbers as if they had been * double-precision, so I disable recognition of s,f,d and l exponent * markers and force the length. In Common Lisp mode I have to look at the * value of *read-default-float-format* to see what to do. */ numberp = 9; continue; #ifdef COMMON case 's': case 'S': boffo_char(i) = 'e'; explicit_fp_format = 1; fplength = 0; numberp = 9; continue; case 'f': case 'F': boffo_char(i) = 'e'; explicit_fp_format = 1; fplength = 1; numberp = 9; continue; case 'd': case 'D': boffo_char(i) = 'e'; explicit_fp_format = 1; numberp = 9; continue; case 'l': case 'L': boffo_char(i) = 'e'; explicit_fp_format = 1; fplength = 3; numberp = 9; continue; #endif default: numberp = -1; break; } break; #ifdef COMMON case 3: case 4: if (ISdigit(c)) /* *read-base* */ { numberp = 4; continue; } numberp = -1; break; #endif case 5: case 8: if (ISdigit(c)) { numberp = 8; continue; } switch (c) { case 'e': case 'E': numberp = 9; continue; #ifdef COMMON case 's': case 'S': /* Clobbering the string is a DISASTER if it is not in fact numeric */ boffo_char(i) = 'e'; explicit_fp_format = 1; fplength = 0; numberp = 9; continue; case 'f': case 'F': boffo_char(i) = 'e'; explicit_fp_format = 1; fplength = 1; numberp = 9; continue; case 'd': case 'D': boffo_char(i) = 'e'; explicit_fp_format = 1; numberp = 9; continue; case 'l': case 'L': boffo_char(i) = 'e'; explicit_fp_format = 1; fplength = 3; numberp = 9; continue; #endif default: numberp = -1; break; } break; case 6: if (ISdigit(c)) { numberp = 8; continue; } numberp = -1; break; case 9: if (c == '+' || c == '-') { numberp = 10; continue; } /* Drop through */ case 10: case 11: if (ISdigit(c)) { numberp = 11; continue; } numberp = -1; break; } break; } /* Here the item has been scanned, and it is known if it is numeric! */ switch (numberp) { default: /* Not a number... look up in package system */ #ifdef COMMON if (!escaped && boffo_char(0) == ':') { int i = 0; for (i = 0; i<boffop; i++) boffo_char(i) = boffo_char(i+1); boffop--; return iintern(boffo, (int32)boffop, qvalue(keyword_package), 0); } #endif return iintern(boffo, (int32)boffop, CP, 0); case 5: /* Integer written as 12345. */ boffo_char(--boffop) = 0; /* ... trim off the trailing dot */ /* drop through */ case 2: /* * I speed up reading by working 7 digits at a time (using C integer * arithmetic to gobble them) and only resorting to Lisp generic * arithmetic to combine the chunks. */ if (boffo_char(0) == '+') { int i = 0; for (i = 0; i<boffop; i++) boffo_char(i) = boffo_char(i+1); boffop--; } { Lisp_Object v = fixnum_of_int(0); CSLbool sign = NO; int32 d = 0, d1 = 10; for (i=0; i<boffop; i++) { if (i==0 && boffo_char(i) == '-') sign = YES; else if (d1 == 10000000 || i == boffop-1) { d = 10*d + (int32)value_in_radix(boffo_char(i), 10); v = times2(v, fixnum_of_int(d1)); errexit(); v = plus2(v, fixnum_of_int(d)); d = 0; d1 = 10; errexit(); } else { d = 10*d + (int32)value_in_radix(boffo_char(i), 10); d1 = 10*d1; } } if (sign) v = negate(v); return v; } #ifdef COMMON case 4: { int p, q, g; Lisp_Object r; /* Beware bignum issue here... but take view that ratios are not used! */ boffo_char(boffop) = 0; /* p and q were made int not int32 to match up with the %d in scanf ... */ sscanf((char *)&boffo_char(0), "%d/%d", &p, &q); /* Limit myself to fixnums here */ g = (int)int_of_fixnum(gcd(fixnum_of_int((int32)p), fixnum_of_int((int32)q))); p /= g; q /= g; if (q < 0) { p = -p; q = -q; } r = getvector(TAG_NUMBERS, TYPE_RATNUM, sizeof(Rational_Number)); errexit(); numerator(r) = fixnum_of_int((int32)p); denominator(r) = fixnum_of_int((int32)q); return r; } #endif case 8: case 11: { double d; Lisp_Object r; #ifdef COMMON float f; if (!explicit_fp_format && is_symbol(read_float_format)) { Lisp_Object w = qvalue(read_float_format); if (w == short_float) fplength = 0; else if (w == single_float) fplength = 1; /* else if (w == double_float) fplength = 2; */ else if (w == long_float) fplength = 3; } #endif boffo_char(boffop) = 0; d = atof((char *)&boffo_char(0)); #ifdef COMMON switch (fplength) { case 0: { Float_union ff; ff.f = (float)d; return TAG_SFLOAT + (ff.i & ~(int32)0xf); } case 1: f = (float)d; r = getvector(TAG_BOXFLOAT, TYPE_SINGLE_FLOAT, sizeof(Single_Float)); errexit(); single_float_val(r) = f; return r; default: /* case 2: case 3: */ r = getvector(TAG_BOXFLOAT, TYPE_DOUBLE_FLOAT, sizeof(Double_Float)); errexit(); double_float_val(r) = d; return r; } #else /* * Only support double precision in CSL mode */ r = getvector(TAG_BOXFLOAT, TYPE_DOUBLE_FLOAT, sizeof(Double_Float)); errexit(); double_float_val(r) = d; return r; #endif } } } Lisp_Object make_undefined_symbol(char const *s) { return make_symbol(s, 0, undefined1, undefined2, undefinedn); } Lisp_Object make_symbol(char const *s, int restartp, one_args *f1, two_args *f2, n_args *fn) /* * Used from the startup code to create an interned symbol and (maybe) * put something in its function cell. */ { Lisp_Object v, nil = C_nil; int first_try = 1; /* * Here I blandly assume that boffo is long enough to hold the string * that I am about to copy into it. All is guaranteed well for * symbols predefined in Lisp in the normal way, but ones established * using command-line options like -Dname could cause trouble? */ #ifdef COMMON /* * For COMMON Lisp I will make all the built-in symbols upper case, unless * the "2" bit of restartp is set... */ char const *p1 = s; char *p2 = (char *)&boffo_char(0); int c; if ((restartp & 2) == 0) { while ((c = *p1++) != 0) { c = toupper(c); *p2++ = c; } *p2 = 0; } else #endif strcpy((char *)&boffo_char(0), s); start_again: v = iintern(boffo, (int32)strlen((char *)&boffo_char(0)), CP, 0); errexit(); /* * I instate the definition given if (a) the definition is a real * one (ie not for an undefined function) and if (b) either I am doing a cold * start or the name is still marked as having a definition in the form * of C code. */ if (f1 != undefined1) { if ((restartp & 1)==0 || (qheader(v) & SYM_C_DEF) != 0 || !first_try) { if (qenv(v) == v) qenv(v) = nil; /* only set env field to nil if it was otherwise not in use */ ifn1(v) = (int32)f1; ifn2(v) = (int32)f2; ifnn(v) = (int32)fn; qheader(v) |= SYM_C_DEF; } else { int l = strlen((char *)&boffo_char(0)); /* * Another piece of curious behaviour here, intend to make it easier to * survive when the CSL/CCL kernel is extended. If a function that the * (new) kernel would like to define as a C-coded thing is already in * the current image either as undefined or with some other (byte-coded) * definition, I map the name of the new function, and XYZ goes to ~XYZ etc * by prefixing a '~'. The image as loaded can then access the new C coded * function by this name, and possibly transfer it across to the normal * name it was originally expected to have. Since this is a symptom of * somebody having done either a curious over-riding redefinition of something * in the kernel or not having re-build to get new symbols properly available, * I print a message about it. Note also that I only rename once, so if there * were to be existing symbols with names that started with "~" that could * make my attempts here less than fully effective. */ if (init_flags & INIT_VERBOSE) term_printf( "+++ Built-in \"%s\" clashes with image file: => \"~%s\"\n", &boffo_char(0), &boffo_char(0)); while (l >= 0) boffo_char(l+1) = boffo_char(l), l--; boffo_char(0) = '~'; first_try = 0; goto start_again; } /* * All things that have been set up as copies of this symbol must be * initialised with the definition too. */ if ((restartp & 1) != 0) { #ifdef COMMON Lisp_Object v1 = get(v, work_symbol, nil); #else Lisp_Object v1 = get(v, work_symbol); #endif while (consp(v1)) { Lisp_Object w = qcar(v1); v1 = qcdr(v1); ifn1(w) = (int32)f1; ifn2(w) = (int32)f2; ifnn(w) = (int32)fn; qenv(w) = qenv(v); /* Copy across environment too */ qheader(w) |= SYM_C_DEF; } } } return v; } static CSLbool add_to_hash(Lisp_Object s, Lisp_Object vector, unsigned32 hash) /* * Adds an item into a hash table given that it is known that it is not * already there. */ { Header h = vechdr(vector); int32 size = (length_of_header(h) - CELL)/4; int32 i = (int32)(hash & (size - 1)); /* * I have arranged (elsewhere) that the hash table will be a power of two * in size, so I can avoid primary clustering by stepping on by any odd * number. Furthermore I can replace the (perhaps expensive) remaindering * operations by (perhaps cheap) bitwise AND ones when I reduce my hash value * to the right range to be an index into the table. */ int32 step = 1 | ((hash >> 10) & (size - 1)); int32 probes = 0; while (++probes <= size) { if (is_fixnum(elt(vector, i))) { elt(vector, i) = s; return YES; /* Success */ } i = i + step; if (i >= size) i -= size; } return NO; /* Table is totally full */ } static int32 number_of_chunks; static Lisp_Object rehash(Lisp_Object v, Lisp_Object chunks, int grow) { /* * If (grow) is +1 this enlarges the table. If -1 it shrinks it. In the * case that the table is to shrink I should guarantee that the next smaller * table size down will have enough space for the number of active items * present. grow=0 leaves the table size alone but still rehashes. */ int32 h = 16384, i; Lisp_Object new_obvec, nil; number_of_chunks = int_of_fixnum(chunks); /* * Now I decide how to format the new structure. To grow, If I had a single * vector at present I try to double its size. If that would give something * with over 40Kbytes I go to 48K, formatted as three chunks each of 16K. */ if (grow > 0) { if (number_of_chunks == 1) { h = length_of_header(vechdr(v)) - CELL; if (h > 20480) { h = 16384; number_of_chunks = 3; } else h = 2*h; } else number_of_chunks++; /* * NB the linear growth of the hash table from this point on gives * bad performance for very large symbol tables due to excessive need * for rehashing. */ } else if (grow < 0) { if (number_of_chunks == 1) { h = length_of_header(vechdr(v)) - CELL; /* * When shrinking, I will not permit the hash table to have room for * less than 8 entries. */ if (h > 64) h = h / 2; } else if (number_of_chunks <= 3) { h = 32768; number_of_chunks = 1; } else number_of_chunks--; } nil = C_nil; stackcheck1(0, v); push(v); try_again: if (number_of_chunks == 1) { new_obvec = getvector_init(h+CELL, fixnum_of_int(0)); errexitn(1); } else { new_obvec = nil; for (i=0; i<number_of_chunks; i++) { Lisp_Object w; push(new_obvec); w = getvector_init(h+CELL, fixnum_of_int(0)); errexitn(2); pop(new_obvec); new_obvec = cons(w, new_obvec); errexitn(1); } } v = stack[0]; while (v != nil) { Lisp_Object vv; if (is_vector(v)) { vv = v; v = nil; } else { vv = qcar(v); v = qcdr(v); } h = length_of_header(vechdr(vv)) - CELL; h = h >> 2; while (h != 0) { Lisp_Object s, p, n = new_obvec; unsigned32 hash; h--; s = elt(vv, h); if (is_fixnum(s)) continue; p = qpname(s); hash = hash_lisp_string(p); if (number_of_chunks != 1) { int32 i = (hash ^ (hash >> 16)) % number_of_chunks; while (i-- != 0) n = qcdr(n); n = qcar(n); } if (!add_to_hash(s, n, hash)) { number_of_chunks++; /* * In the grossly improbable case that clustering leads to one of the * sub-vectors overflowing I will go back and re-start the expansion * process but with yet more space available. This can ONLY happen * if I already had multiple sub-hash-tables. */ goto try_again; } } } popv(1); return new_obvec; } #ifdef COMMON static Lisp_Object add_to_externals(Lisp_Object s, Lisp_Object p, unsigned32 hash) { Lisp_Object n = packnext_(p); Lisp_Object v = packext_(p); Lisp_Object nil = C_nil; int32 used = int_of_fixnum(packvext_(p)); if (used == 1) used = length_of_header(vechdr(v)); else used = 16384*used; /* * n is (16*sym_count+1) * used = 4*spaces+4 * The effect is that I trigger a re-hash if the table reaches 70% * loading. For small vectors when I re-hash I will double the * table size, for large ones I will add another 16Kbytes (i.e. 4K * table entries). The effect will be that small packages will often * be fairly lightly loaded (down to 35% just after an expansion) while * very large ones will be kept close to the 70% mark. If I start off * all tables with size that is a power of 2 that state will persist. */ try_again: if (5L*(int32)n >= 14L*used) { stackcheck3(0, s, p, v); push2(s, p); v = rehash(v, packvext_(p), 1); pop2(p, s); errexit(); packext_(p) = v; packvext_(p) = fixnum_of_int(number_of_chunks); } packnext_(p) = n + (1<<4); /* increment as a Lisp fixnum */ { int32 nv = int_of_fixnum(packvext_(p)); if (nv == 1) add_to_hash(s, v, hash); else { nv = (hash ^ (hash >> 16)) % nv; /* * There is a systematic nasty problem here that I maybe ought to deal with * some time. Large packages are represented as a collection of smaller * hash tables, and part of the hash value of a symbol decides which of these * sub-tables any particular string will be placed in. I enlarge the whole * system when the set of tables (treated as a whole) is 70% full. But * clustering COULD potentially lead to one of the sub-tables becoming * totally full before then, and that would give a loop here if I was not * careful. To avoid the possibility I make add_to_hash() report any * trouble and if I have difficulty I go back and re-enlarge the tables. * This is not guaranteed safe, but I will be VERY unlucky if it ever bites * me! */ while (nv-- != 0) v = qcdr(v); if (!add_to_hash(s, qcar(v), hash)) { n = used = 0; goto try_again; } } } return nil; } #endif static Lisp_Object add_to_internals(Lisp_Object s, Lisp_Object p, unsigned32 hash) { Lisp_Object n = packnint_(p); Lisp_Object v = packint_(p); Lisp_Object nil = C_nil; int32 used = int_of_fixnum(packvint_(p)); if (used == 1) used = length_of_header(vechdr(v)); else used = 16384*used; try_again: if (5L*(int32)n >= 14L*used) { stackcheck3(0, s, p, v); push2(s, p); v = rehash(v, packvint_(p), 1); pop2(p, s); errexit(); packint_(p) = v; packvint_(p) = fixnum_of_int(number_of_chunks); } packnint_(p) = (Lisp_Object)((int32)n + (1<<4)); /* increment as a Lisp fixnum */ { int32 nv = int_of_fixnum(packvint_(p)); if (nv == 1) add_to_hash(s, v, hash); else { nv = (hash ^ (hash >> 16)) % nv; while (nv-- != 0) v = qcdr(v); if (!add_to_hash(s, qcar(v), hash)) { n = used = 0; goto try_again; } } } return nil; } #ifdef __mips__ #ifdef __GCC__ /* * Bad news - with the version of gcc installed on the mips-based * DecStations in Cambridge as of February 1992 the memcmp() function * is plain broken. Here is a replacement. */ static int my_memcmp(const void *a, const void *b, size_t n) { const unsigned char *ac = a, *bc = b; if ((((int)ac | (int)bc) & 3) == 0) { while (n >= 4 && *(int *)ac == *(int *)bc) ac += 4, bc += 4, n -= 4; } while (n-- > 0) { unsigned char c1,c2; /* unsigned cmp seems more intuitive */ if ((c1 = *ac++) != (c2 = *bc++)) return c1 - c2; } return 0; } #define memcmp(a, b, n) my_memcmp(a, b, n) #endif #endif static CSLbool rehash_pending = NO; static Lisp_Object lookup(Lisp_Object str, int32 strsize, Lisp_Object v, Lisp_Object nv, int32 hash) /* * Searches a hash table for a symbol with name matching the given string, * and NOTE that the string passed down here is to be treated as having * just strsize characters in it. Return Lisp number 0 if not found. * Sets rehash_pending if the number of probes used to find the item is * at least half the size of the table. This case might arise in the following * way: * insert items into the table until it is just under 70% full. * remob (eg via EXPORT) items until the table is just over 25% full. * note that so far there will have been no need to rehash * insert more items, but select them so that thir hash values are all * different from the ones used before. You should be able to end up * with 70% of the table full of valid symbols and 30% left as the value * fixnum_of_int(1) which represents a place where a deleted symbol used * to be. There is now NO really empty space. * Now looking up symbols must keep searching past tombstones, and hence * here it will be necessary to scan the entire table before it is * possible to assert that a symbol is not present. Inserting new symbols * does not suffer in this way - only lookup. To help with this horror I set * rehash_pending if the lookup uses a number of probes > 75% of the table * size. This should only arise in degenerate cases! */ { Header h; int32 size; int32 i = int_of_fixnum(nv), step, n; if (i != 1) { i = (hash ^ (hash >> 16)) % i; /* Segmented - find correct segment */ while (i-- != 0) v = qcdr(v); v = qcar(v); } h = vechdr(v); size = (length_of_header(h) - CELL)/4; i = (int32)(hash & (size - 1)); step = 1 | ((hash >> 10) & (size - 1)); /* * I count the probes that I make here and if there are as many as the size * of the hash table then I allow the lookup to report that the symbol is not * present. But at least I do not get stuck in a loop. */ for (n=0; n<size; n++) { Lisp_Object w = elt(v, i); Lisp_Object pn; if (w == fixnum_of_int(0)) { if (4*n > 3*size) rehash_pending = YES; return w; /* Not found */ } if (w != fixnum_of_int(1)) { pn = qpname(w); /* v comes out of a package so has a proper pname */ if (memcmp((char *)str + (CELL-TAG_VECTOR), (char *)pn + (CELL-TAG_VECTOR), (size_t)strsize) == 0 && (int32)length_of_header(vechdr(pn)) - CELL == strsize) { if (4*n > 3*size) rehash_pending = YES; return w; } } i = i + step; if (i >= size) i -= size; } rehash_pending = YES; return fixnum_of_int(0); } static int ordersymbol(Lisp_Object v1, Lisp_Object v2) /* * Compare two symbols to see if they are in alphabetic order. * Returns 0 is the symbols have the same name, otherwise * the comparison is a lexical one on their names, with -ve if * v1 comes alphabetically before v2. Deals with gensyms, and in so * doing has to allocate names for them, which seems a great misery * since it means that this procedure can provoke garbage collection.. * * Note that the ordering here is based on the bit-patterns that * represent the names, so Kanji (etc) symbols may not come out in * an order that is especially useful. */ { Lisp_Object pn1 = qpname(v1), pn2 = qpname(v2); int c; int32 l1, l2; #ifndef COMMON if (qheader(v1) & SYM_UNPRINTED_GENSYM) { Lisp_Object nil; push(v2); pn1 = get_pname(v1); pop(v2); nil = C_nil; if (exception_pending()) return 0; pn2 = qpname(v2); } if (qheader(v2) & SYM_UNPRINTED_GENSYM) { Lisp_Object nil; push(pn1); pn2 = get_pname(v2); pop(pn1); nil = C_nil; if (exception_pending()) return 0; } #endif l1 = length_of_header(vechdr(pn1)) - CELL; l2 = length_of_header(vechdr(pn2)) - CELL; c = memcmp((char *)pn1 + (CELL-TAG_VECTOR), (char *)pn2 + (CELL-TAG_VECTOR), (size_t)(l1 < l2 ? l1 : l2)); if (c == 0) c = (int)(l1 - l2); return c; } /* * This has been coded so that it provides the behavious that Reduce expects * of ordp(). This is the REDUCE 3.6/3.7 version - it will need re-work * if REDUCE is altered. Note the curious situation that symbols are * alphabetically ordered, EXCEPT that "nil" comes before everything else! * (NB for 3.6 this is as provided in a patch file rather than the original * release. The places with *** represent updates since 3.6 and the initial * version of 3.6) * * symbolic procedure ordp(u,v); * if null u then null v * else if null v then t * else if vectorp u then if vectorp v then ordpv(u,v) else atom v * else if atom u * then if atom v * then if numberp u then numberp v and not (u<v) * else if idp v then orderp(u,v) * else numberp v * else nil * else if atom v then t * else if car u=car v then %%% ordp(cdr u,cdr v) *** ordpl(cdr u, cdr v) *** 8 Feb 1999 *** %% flagp(car u,'noncom) or ordpl(cdr u,cdr v) *** * else if flagp(car u,'noncom) * then if flagp(car v,'noncom) then ordp(car u,car v) else t * else if flagp(car v,'noncom) then nil * else ordp(car u,car v); * *** symbolic procedure ordpl(u,v) *** if atom u then ordp(u,v) *** else if atom v then t *** else if car u=car v then ordpl(cdr u,cdr v) *** else ordp(car u, car v); * */ static int orderp(Lisp_Object u, Lisp_Object v); static int ordpv(Lisp_Object u, Lisp_Object v) { Header hu = vechdr(u), hv = vechdr(v); int32 lu = length_of_header(hu), lv = length_of_header(hv), n = 4; if (type_of_header(hu) != type_of_header(hv)) return (type_of_header(hu) < type_of_header(hv) ? -1 : 1); if (vector_holds_binary(hu)) { while (n < lu && n < lv) { unsigned int eu = *(unsigned char *)(u - TAG_VECTOR + n), ev = *(unsigned char *)(v - TAG_VECTOR + n); if (eu != ev) return (eu < ev ? -1 : 1); n += 1; } return (lu == lv ? 0 : lu < lv ? -1 : 1); } /* * At present it is an ERROR to include mixed vectors in structures passed * to ordering functions, and if it is done the system may crash. Note that * stream objects count as mixed for these purposes. I will get around to * fixing things sometime... */ else { while (n < lu && n < lv) { Lisp_Object eu = *(Lisp_Object *)(u - TAG_VECTOR + n), ev = *(Lisp_Object *)(v - TAG_VECTOR + n), nil = C_nil; int w; push2(u, v); #ifdef SOFTWARE_TICKS if (--countdown < 0) deal_with_tick(); #endif if (stack >= (Lisp_Object *)stacklimit) { push(ev); eu = reclaim(eu, "stack", GC_STACK, 0); pop(ev); nil = C_nil; /* stackcheck expanded by hand here to return an int, not nil, in bad case */ if (exception_pending()) { popv(2); return 0; } } w = orderp(eu, ev); pop2(v, u); nil = C_nil; if (exception_pending()) return 0; if (w != 0) return w; n += 4; } return (lu == lv ? 0 : lu < lv ? -1 : 1); } } static int ordpl(Lisp_Object u, Lisp_Object v) { for (;;) { int w = orderp(qcar(u), qcar(v)); if (w != 0) return w; u = qcdr(u); v = qcdr(v); if (!is_cons(u)) return orderp(u, v); if (!is_cons(v)) return -1; } } #define flagged_noncom(v) \ ((fv = qfastgets(v)) != nil && elt(fv, 0) != SPID_NOPROP) static int orderp(Lisp_Object u, Lisp_Object v) { Lisp_Object nil = C_nil; for (;;) { if (u == nil) return v == nil ? 0 : 1; else if (v == nil) return -1; /* Special cases of NIL done */ else if (u == v) return 0; /* useful optimisation? */ /* * I migrate the vectorp test inside where I have tested for atoms, since * I expect vectors to be a somewhat uncommon case */ else if (!is_cons(u)) { if (!is_cons(v)) { if (is_vector(u)) { if (is_vector(v)) return ordpv(u, v); else return -1; } else if (is_number(u)) { if (is_number(v)) return lessp2(u, v) ? 1 : eql(u, v) ? 0 : -1; else return 1; } else if (is_number(v)) return -1; else if (is_symbol(u)) { if (is_symbol(v)) return ordersymbol(u, v); else return 1; } else if (is_symbol(v)) return -1; /* * Now the objects are not symbols, vectors or numbers. That maybe * leaves character objects. I compare representations to give a * rather arbitrary ordering. Note that any comparisons that get * down here are yielding non portable results. */ else return (u == v) ? 0 : (u < v) ? 1 : -1; } else return 1; } else if (!is_cons(v)) return -1; else { Lisp_Object cu = qcar(u), cv = qcar(v); Lisp_Object fv; /* used by flagged_noncom */ int w; push2(u, v); /* stackcheck2(2, cu, cv); */ #ifdef SOFTWARE_TICKS if (--countdown < 0) deal_with_tick(); #endif if (stack >= (Lisp_Object *)stacklimit) { push(cv); cu = reclaim(cu, "stack", GC_STACK, 0); pop(cv); nil = C_nil; /* stackcheck expanded by hand here to return an int, not nil, in bad case */ if (exception_pending()) { popv(2); return 0; } } w = orderp(cu, cv); pop2(v, u); nil = C_nil; if (exception_pending()) return 0; if (w != 0) { cu = qcar(u); if (is_symbol(cu) && flagged_noncom(cu)) { cv = qcar(v); if (is_symbol(cv) && flagged_noncom(cv)) return w; else return -1; } else { cv = qcar(v); if (is_symbol(cv) && flagged_noncom(cv)) return 1; else return w; } } /* * here car u = car v */ u = qcdr(u); v = qcdr(v); if (!is_cons(u)) continue; if (!is_cons(v)) return -1; /* * The function I can ordpl here has the atom tests lifted out from * its top... */ return ordpl(u, v); } } } Lisp_Object Lorderp(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { int w; w = orderp(a, b); errexit(); return onevalue(Lispify_predicate(w <= 0)); } static unsigned32 removed_hash; static CSLbool remob(Lisp_Object sym, Lisp_Object v, Lisp_Object nv) /* * Searches a hash table for a symbol with name matching the given string, * and remove it. */ { Lisp_Object str = qpname(sym); Header h; unsigned32 hash; int32 i = int_of_fixnum(nv), size, step, n; if (qheader(sym) & SYM_ANY_GENSYM) return NO; /* gensym case is easy! */ #ifdef COMMON /* If not in any package it has no home & is not available */ qheader(sym) &= ~SYM_EXTERN_IN_HOME & ~(0xffffffff<<SYM_IN_PKG_SHIFT); #endif removed_hash = hash = hash_lisp_string(str); /* * The search procedure used here MUST match that coded in lookup(). */ if (i != 1) { i = (hash ^ (hash >> 16)) % i; while (i-- != 0) v = qcdr(v); v = qcar(v); } h = vechdr(v); size = (length_of_header(h) - CELL)/4; i = (int32)(hash & (size - 1)); step = 1 | ((hash >> 10) & (size - 1)); for (n=0; n<size; n++) { Lisp_Object w = elt(v, i); if (w == fixnum_of_int(0)) return NO; /* Not found */ if (w == sym) { elt(v, i) = fixnum_of_int(1); /* * I will shrink the hash table if it becomes less than 25% full, * but not in this bit of code... because I want this internal * remob() function to avoid any possible failure or garbage collection * so I can call it from C code without any formality. Thus I should do * any tidying up afterwards. */ return YES; } i = i + step; if (i >= size) i -= size; } return NO; } #ifdef COMMON static Lisp_Object Lmake_symbol(Lisp_Object nil, Lisp_Object str) /* * Lisp function (make-symbol ..) creates an uninterned symbol. */ { Lisp_Object s; stackcheck1(0, str); /* * Common Lisp wants a STRING passed here, but as a matter of generosity and * for the benefit of some of my system code I support symbols too. */ if (symbolp(str)) { str = get_pname(str); errexit(); } else if (!is_vector(str)) return aerror1("make-symbol", str); else if (complex_stringp(str)) { str = simplify_string(str); errexit(); } else if (type_of_header(vechdr(str)) != TYPE_STRING) return aerror1("make-symbol", str); push(str); s = getvector(TAG_SYMBOL, TYPE_SYMBOL, symhdr_length); errexitn(1); pop(str); qheader(s) = TAG_ODDS+TYPE_SYMBOL; qvalue(s) = unset_var; qpname(s) = str; qplist(s) = nil; qfastgets(s) = nil; qpackage(s) = nil; qenv(s) = s; ifn1(s) = (int32)undefined1; ifn2(s) = (int32)undefined2; ifnn(s) = (int32)undefinedn; qcount(s) = 0; /* set counts to zero to be tidy */ return onevalue(s); } #endif Lisp_Object MS_CDECL Lgensym(Lisp_Object nil, int nargs, ...) /* * Lisp function (gensym) creates an uninterned symbol with odd name. */ { Lisp_Object id; #ifdef COMMON Lisp_Object pn; char genname[64]; #endif argcheck(nargs, 0, "gensym"); stackcheck0(0); nil = C_nil; #ifdef COMMON sprintf(genname, "G%lu", (long unsigned)gensym_ser++); pn = make_string(genname); errexit(); push(pn); #endif id = getvector(TAG_SYMBOL, TYPE_SYMBOL, symhdr_length); #ifdef COMMON pop(pn); #endif errexit(); #ifdef COMMON qheader(id) = TAG_ODDS+TYPE_SYMBOL+SYM_ANY_GENSYM; qpname(id) = pn; #else qheader(id) = TAG_ODDS+TYPE_SYMBOL+SYM_UNPRINTED_GENSYM+SYM_ANY_GENSYM; qpname(id) = gensym_base; #endif qvalue(id) = unset_var; qplist(id) = nil; qfastgets(id) = nil; #ifdef COMMON qpackage(id) = nil; /* Marks it as a uninterned */ #endif qenv(id) = id; ifn1(id) = (int32)undefined1; ifn2(id) = (int32)undefined2; ifnn(id) = (int32)undefinedn; qcount(id) = 0; /* to be tidy */ return onevalue(id); } Lisp_Object Lgensym1(Lisp_Object nil, Lisp_Object a) /* * Lisp function (gensym1 base) creates an uninterned symbol with odd name. * The case (gensym <number>) is DEPRECATED by the Common Lisp standards * committee and so I will not implement it at least for now. */ { Lisp_Object id, genbase; #ifdef COMMON unsigned32 len; char genname[64]; if (complex_stringp(a)) { a = simplify_string(a); errexit(); } #endif if (is_vector(a) && type_of_header(vechdr(a)) == TYPE_STRING) genbase = a; else if (symbolp(a)) genbase = qpname(a); /* copy gensym base */ else return aerror1("gensym1", a); push(genbase); stackcheck0(0); #ifdef COMMON len = length_of_header(vechdr(genbase)) - CELL; if (len > 60) len = 60; /* Unpublished truncation of the string */ sprintf(genname, "%.*s%lu", (int)len, (char *)genbase + (CELL-TAG_VECTOR), (long unsigned)gensym_ser++); stack[0] = make_string(genname); errexitn(1); #endif id = getvector(TAG_SYMBOL, TYPE_SYMBOL, symhdr_length); errexitn(1); pop(genbase); #ifdef COMMON qheader(id) = TAG_ODDS+TYPE_SYMBOL+SYM_ANY_GENSYM; #else qheader(id) = TAG_ODDS+TYPE_SYMBOL+SYM_UNPRINTED_GENSYM+SYM_ANY_GENSYM; #endif qvalue(id) = unset_var; qpname(id) = genbase; qplist(id) = nil; qfastgets(id) = nil; #ifdef COMMON qpackage(id) = nil; /* Marks it as a uninterned */ #endif qenv(id) = id; ifn1(id) = (int32)undefined1; ifn2(id) = (int32)undefined2; ifnn(id) = (int32)undefinedn; qcount(id) = 0; /* to be tidy */ return onevalue(id); } Lisp_Object Lgensym2(Lisp_Object nil, Lisp_Object a) /* * Lisp function (gensym2 base) whose name is exactly that given by the * argument. This might be UNHELPFUL if one tried to print the value * concerned, but seems to be what the Common Lisp syntax #:ggg expects * to achieve! */ { Lisp_Object id, genbase; unsigned32 len; #ifdef COMMON if (complex_stringp(a)) { a = simplify_string(a); errexit(); } #endif if (is_vector(a) && type_of_header(vechdr(a)) == TYPE_STRING) genbase = a; else if (symbolp(a)) genbase = qpname(a); else return aerror1("gensym2", a); push(genbase); stackcheck0(0); len = length_of_header(vechdr(genbase)) - CELL; stack[0] = copy_string(genbase, len); errexitn(1); id = getvector(TAG_SYMBOL, TYPE_SYMBOL, symhdr_length); errexitn(1); pop(genbase); qheader(id) = TAG_ODDS+TYPE_SYMBOL+SYM_ANY_GENSYM; qvalue(id) = unset_var; qpname(id) = genbase; qplist(id) = nil; qfastgets(id) = nil; #ifdef COMMON qpackage(id) = nil; /* Marks it as a uninterned */ #endif qenv(id) = id; ifn1(id) = (int32)undefined1; ifn2(id) = (int32)undefined2; ifnn(id) = (int32)undefinedn; qcount(id) = 0; /* to be tidy */ return onevalue(id); } static Lisp_Object Lgensymp(Lisp_Object nil, Lisp_Object a) { if (is_symbol(a) && (qheader(a) & SYM_CODEPTR) == 0 && (qheader(a) & SYM_ANY_GENSYM) != 0) return onevalue(lisp_true); else return onevalue(nil); } Lisp_Object iintern(Lisp_Object str, int32 h, Lisp_Object p, int str_is_ok) /* * Look up the first h chars of the string str with respect to the package p. * The last arg is a boolean that allows me to decide if (when a new symbol * has to be created) the string must be copied. If h differs from the * real number of characters in arg1 then a copy MUST be made. * If non-zero, the last arg is 1 for intern, 2 for extern, 3 * for find-symbol and 4 for "find-external-symbol" as in reader syntax p:x. * NB in CSL mode only one value is returned. */ { Lisp_Object r, nil = C_nil; unsigned32 hash; stackcheck2(0, str, p); hash = hash_lisp_string_with_length(str, h+CELL); /* find-external-symbol will not look at the internals */ if (str_is_ok != 4) { r = lookup(str, h, packint_(p), packvint_(p), hash); /* * rehash_pending is intended to deal with horrible cases that involve * lots of remobs. But in the worst possible scenario one could have * a symbol table where all symbols clashed on hashing, and then by * restricting further use to just the last few symbols entered it would be * possible for all lookup operations to take a number of probes that * was almost 70% of the table size. In such cases rehashing (without * expanding the table size at the same time) would leave the table * unaltered and would not mend things. To avoid such repeated fruitless * rehashing I only set rehash_pending if the number of probes was over * 75% of the table size, and this should be impossible if there are no * tombstones present. */ if (rehash_pending) { Lisp_Object v = packint_(p); push2(p, r); v = rehash(v, packvint_(p), 0); pop2(r, p); errexit(); packint_(p) = v; packvint_(p) = fixnum_of_int(number_of_chunks); rehash_pending = NO; } nil = C_nil; if (r != fixnum_of_int(0)) { #ifdef COMMON mv_2 = internal_symbol; #endif return nvalues(r, 2); } } #ifdef COMMON r = lookup(str, h, packext_(p), packvext_(p), hash); if (rehash_pending) { Lisp_Object v = packext_(p); push2(p, r); v = rehash(v, packvext_(p), 0); pop2(r, p); errexit(); packext_(p) = v; packvext_(p) = fixnum_of_int(number_of_chunks); rehash_pending = NO; } if (r != fixnum_of_int(0)) { mv_2 = external_symbol; return nvalues(r, 2); } if (str_is_ok == 4) { #ifdef COMMON mv_2 = nil; #endif return nvalues(nil, 2); } for (r = packuses_(p); r!=nil; r=qcdr(r)) { Lisp_Object w = qcar(r); w = lookup(str, h, packext_(w), packvext_(w), hash); if (rehash_pending) { Lisp_Object v = packext_(p); push2(p, r); v = rehash(v, packvext_(p), 0); pop2(r, p); errexit(); packext_(p) = v; packvext_(p) = fixnum_of_int(number_of_chunks); rehash_pending = NO; } if (w != fixnum_of_int(0)) { mv_2 = inherited_symbol; return nvalues(w, 2); } } #endif if (str_is_ok == 3) { #ifdef COMMON mv_2 = nil; #endif return nvalues(nil, 2); } { Lisp_Object s; push2(str, p); s = (Lisp_Object)getvector(TAG_SYMBOL, TYPE_SYMBOL, symhdr_length); pop(p); errexit(); qheader(s) = TAG_ODDS+TYPE_SYMBOL; #ifdef COMMON if (p == qvalue(keyword_package) && keyword_package != nil) { qvalue(s) = (Lisp_Object)s; qheader(s) |= SYM_SPECIAL_VAR; } else #endif qvalue(s) = unset_var; qpname(s) = qpname(nil); /* At this stage the pname is a dummy */ qplist(s) = nil; qfastgets(s) = nil; #ifdef COMMON qpackage(s) = p; #endif qenv(s) = (Lisp_Object)s; ifn1(s) = (int32)undefined1; ifn2(s) = (int32)undefined2; ifnn(s) = (int32)undefinedn; qcount(s) = 0; push(s); #ifdef COMMON if ((p == qvalue(keyword_package) && keyword_package != nil) || str_is_ok == 2) { add_to_externals(s, p, hash); errexitn(2); qheader(s) |= SYM_EXTERN_IN_HOME; } else #endif add_to_internals(s, p, hash); pop(s); pop(str); errexit(); /* Now the symbol-head is safe enough that I can let the GC look at it */ if (str_is_ok != 0) qpname(s) = str; else { Lisp_Object pn; push(s); pn = copy_string(str, h); pop(s); qpname(s) = pn; } errexit(); #ifdef COMMON mv_2 = nil; #endif return nvalues((Lisp_Object)s, 2); } } #ifdef COMMON static Lisp_Object Lfind_package(Lisp_Object nil, Lisp_Object name); Lisp_Object Lintern_2(Lisp_Object nil, Lisp_Object str, Lisp_Object pp) #else Lisp_Object Lintern(Lisp_Object nil, Lisp_Object str) #endif /* * Lisp entrypoint for (intern ..) */ { Header h; Lisp_Object p; #ifdef COMMON push(str); p = Lfind_package(nil, pp); pop(str); errexit(); #else p = CP; #endif #ifdef COMMON if (complex_stringp(str)) { push(p); str = simplify_string(str); pop(p); errexit(); } #endif /* * For COMMON it is perhaps undue generosity to permit a symbol here * rather than just a string. However it will make life a bit easier for * me in porting existing code. Note that the Common Lisp book says quite * explicitly that symbols are NOT allowed here. */ if (symbolp(str)) { str = get_pname(str); errexit(); } if (!is_vector(str) || type_of_header(h = vechdr(str)) != TYPE_STRING) return aerror1("intern (not a string)", str); return iintern(str, length_of_header(h) - CELL, p, 1); } #ifdef COMMON Lisp_Object Lintern(Lisp_Object nil, Lisp_Object a) { return Lintern_2(nil, a, CP); } static Lisp_Object Lfind_symbol(Lisp_Object nil, Lisp_Object str, Lisp_Object pp) { Header h; Lisp_Object p; push(str); p = Lfind_package(nil, pp); pop(str); errexit(); if (symbolp(str)) { push(p); str = get_pname(str); pop(p); errexit(); } if (complex_stringp(str)) { push(p); str = simplify_string(str); pop(p); errexit(); } if (!is_vector(str) || type_of_header(h = vechdr(str)) != TYPE_STRING) { return aerror1("find-symbol (not a string)", str); } return iintern(str, length_of_header(h) - CELL, p, 3); } Lisp_Object Lfind_symbol_1(Lisp_Object nil, Lisp_Object str) { return Lfind_symbol(nil, str, CP); } static Lisp_Object Lextern(Lisp_Object nil, Lisp_Object sym, Lisp_Object package) /* * If sym is internal in given package make it external - the inside parts * of the export function. Note that the second argument must be a real * package object, not a package name. Higher level code must have done * a find-package as necessary. */ { if (!is_symbol(sym)) return onevalue(nil); if (remob(sym, packint_(package), packvint_(package))) { Lisp_Object n = packnint_(package); Lisp_Object v = packint_(package); int32 used = int_of_fixnum(packvint_(package)); if (used == 1) used = length_of_header(vechdr(v)); else used = 16384*used; /* * I will shrink a hash table if a sequence of remob-style operations, * which will especially include the case where a symbol ceases to be * internal to a package so that it can be external, leaves the table * less than 25% full. Note that normal growth is supposed to leave these * tables between 35 and 70% full, so the activity here will not be * triggered frivolously. However note the following oddity: if a package * is of minimum size (8 entries in the hash table) then rehashing will not * cause it to shrink (but it will rehash and hence tidy it up). Hence * every remob on such a table will cause it to be re-hashed. */ if ((int32)n < used) { stackcheck3(0, sym, package, v); push2(sym, package); v = rehash(v, packvint_(package), -1); pop2(package, sym); errexit(); packint_(package) = v; packvint_(package) = fixnum_of_int(number_of_chunks); } packnint_(package) -= (1<<4); /* decrement as fixnum */ /* * removed_hash was left set up by remob, and it is known that the symbol * was not already external, since it had been internal. */ if (qpackage(sym) == package) qheader(sym) |= SYM_EXTERN_IN_HOME; add_to_externals(sym, package, removed_hash); errexit(); return onevalue(lisp_true); } return onevalue(nil);/* no action if it was not internal in this package */ } static Lisp_Object Lextern_1(Lisp_Object nil, Lisp_Object str) { return Lextern(nil, str, CP); } static Lisp_Object Limport(Lisp_Object nil, Lisp_Object sym, Lisp_Object package) /* * The internal part of the IMPORT and SHADOWING-IMPORT functions. * makes sym internal in package. The symbol MUST NOT be present there * before this function is called. The second argument must be a real * package object, not just the name of one. */ { unsigned32 hash; Lisp_Object pn; if (!is_symbol(sym)) return onevalue(nil); push2(sym, package); pn = get_pname(sym); errexitn(2); hash = hash_lisp_string(pn); add_to_internals(stack[-1], stack[0], hash); pop2(package, sym); errexit(); if (qpackage(sym) == nil) qpackage(sym) = package; return onevalue(nil); } static Lisp_Object Limport_1(Lisp_Object nil, Lisp_Object str) { return Limport(nil, str, CP); } #endif Lisp_Object ndelete(Lisp_Object a, Lisp_Object l) /* * Probably useful in various places throughout the system... */ { #ifdef COMMON Lisp_Object nil = C_nil; #endif if (!consp(l)) return l; if (a == qcar(l)) return qcdr(l); { Lisp_Object z1 = l, z2 = qcdr(l); while (consp(z2)) { if (a == qcar(z2)) { qcdr(z1) = qcdr(z2); return l; } else { z1 = z2; z2 = qcdr(z2); } } } return l; } Lisp_Object Lunintern_2(Lisp_Object nil, Lisp_Object sym, Lisp_Object pp) { Lisp_Object package; #ifdef COMMON push(sym); package = Lfind_package(nil, pp); pop(sym); errexit(); #else package = pp; #endif if (!is_symbol(sym)) return onevalue(nil); #ifdef COMMON if (qpackage(sym) == package) qpackage(sym) = nil; packshade_(package) = ndelete(sym, packshade_(package)); #endif if ((qheader(sym) & SYM_C_DEF) != 0) return aerror1("remob on function with kernel definition", sym); if (remob(sym, packint_(package), packvint_(package))) { Lisp_Object n = packnint_(package); Lisp_Object v = packint_(package); int32 used = int_of_fixnum(packvint_(package)); if (used == 1) used = length_of_header(vechdr(v)); else used = 16384*used; if ((int32)n < used) { stackcheck2(0, package, v); push(package); v = rehash(v, packvint_(package), -1); pop(package); errexit(); packint_(package) = v; packvint_(package) = fixnum_of_int(number_of_chunks); } packnint_(package) -= (1<<4); /* decrement as fixnum */ return onevalue(lisp_true); } #ifdef COMMON if (remob(sym, packext_(package), packvext_(package))) { Lisp_Object n = packnext_(package); Lisp_Object v = packext_(package); int32 used = int_of_fixnum(packvext_(package)); if (used == 1) used = length_of_header(vechdr(v)); else used = 16384*used; if ((int32)n < used) { stackcheck2(0, package, v); push(package); v = rehash(v, packvext_(package), -1); pop(package); errexit(); packext_(package) = v; packvext_(package) = fixnum_of_int(number_of_chunks); } packnext_(package) -= (1<<4); /* decrement as fixnum */ return onevalue(lisp_true); } #endif return onevalue(nil); } Lisp_Object Lunintern(Lisp_Object nil, Lisp_Object str) { return Lunintern_2(nil, str, CP); } #ifdef COMMON static Lisp_Object Lkeywordp(Lisp_Object nil, Lisp_Object a) { if (!symbolp(a)) return onevalue(nil); return onevalue(Lispify_predicate(qpackage(a) == qvalue(keyword_package))); } #endif /* * If I have a window system then getting characters from the keyboard * is deemed a system-dependent activity. On non-windowed systems I still * do rather more than just getchar(), although under typical Unix what I * do here may count as over-kill. */ int tty_count; #define TTYBUF_SIZE 256 #ifdef Kanji static kchar_t tty_buffer[TTYBUF_SIZE]; static kchar_t *tty_pointer; #else /* * Note: I should never have an END_OF_FILE in the buffere here: if I see * this condition I pack in the character CTRL-D instead. */ static char tty_buffer[TTYBUF_SIZE]; static char *tty_pointer; #endif static CSLbool int_nest = NO; #ifndef CWIN static int prevchar = '\n'; #endif int terminal_pushed = NOT_CHAR; int char_from_terminal(Lisp_Object dummy) /* * "What ..." you might ask, "is the meaning of this mess?". Well the answer * is that when input is directly from the terminal I buffer up to 256 * characters in a private buffer, and I discount the time spent filling this * buffer. On some miserable systems this will succeed in ensuring that the * time reported at the end of a run reflects time that CSL spends computing * and not time it spends waiting for the user to type something at it. Note * that it is only stdin input that I intercept in this way, so the full cost * of getting characters from disc files will be accounted. I also (rather * improperly) map EOF onto a code (4) which will fit in a byte-sized buffer. * I fill by buffer up as far as a newline or a vertical tab (or end of file), * and hope that that will not seriously hurt any interactions with CSL. * After all the operating system may well line-buffer input anyway, so that * it can deal with the delete key on your keyboard for you. * * Furthermore here is where I display prompt strings to the user - * in a way that Standard Lisp does not define, but PSL implements and * some REDUCE programmers have come to expect... (in some cases I will * let lower level code deal with prompts). * * If the user provokes an interrupt (^C, or ESC or whatever) while I am * in here I will try to return promptly with an empty buffer and * some indication of an exception. */ { /* * I have a hook here for cases where I want to call CSL from other C * code. In that case the variable used here points at a function that * reads a single character. When I use this option I will NOT generate * prompts. */ int c; Lisp_Object nil = C_nil; CSL_IGNORE(dummy); if (terminal_pushed != NOT_CHAR) { c = terminal_pushed; terminal_pushed = NOT_CHAR; return c; } if (procedural_input != NULL) c = (*procedural_input)(); else if (non_terminal_input != NULL) { #ifdef Kanji c = getwc(non_terminal_input); #else c = getc(non_terminal_input); #endif } else { if (tty_count == 0) { /* * Time spent waiting for keyboard input is not counted against the user. */ push_clock(); #ifdef CWIN /* Under CWIN I will arrange prompts at a lower level. */ #else if (prevchar == '\n') { escaped_printing = 0; if (prompt_thing != nil) { push(active_stream); active_stream = qvalue(terminal_io); if (!is_stream(active_stream)) active_stream = lisp_terminal_io; internal_prin(prompt_thing, NO); nil = C_nil; if (exception_pending()) flip_exception(); pop(active_stream); } } ensure_screen(); if (exception_pending()) return EOF; #endif #ifdef WINDOW_SYSTEM if (use_wimp) { tty_count = wimpget(tty_buffer); if (exception_pending()) return EOF; if (interrupt_pending) { interrupt_pending = 0; if (miscflags & HEADLINE_FLAG) err_printf("+++ Interrupted\n"); exit_reason = (miscflags & MESSAGES_FLAG) ? UNWIND_ERROR : UNWIND_UNWIND; exit_value = exit_tag = nil; exit_count = 0; flip_exception(); } } else #endif for (;;) /* The while loop is so I can restart after ^C */ { /* * The setjmp here can not mask any bindings of fluid variables... */ errorset_msg = NULL; #ifdef __cplusplus try #else if (!setjmp(sigint_buf)) #endif { while (tty_count<TTYBUF_SIZE && !interrupt_pending) { int c; sigint_must_longjmp = YES; #ifdef Kanji c = getwc(stdin); #else c = getchar(); #endif sigint_must_longjmp = NO; if (c == EOF) { clearerr(stdin); /* Believed to be what is wanted */ c = CTRL_D; /* Use ASCII ^D as EOF marker */ } tty_buffer[tty_count++] = c; if (c == '\n' || c == '\v' || c == CTRL_D) break; } if (interrupt_pending) { push_clock(); /* * Time spent in the interrupt handler here will not be counted as CPU * time used. */ interrupt_pending = NO; if (int_nest) { err_printf("\n+++ Nested interrupt ignored\n"); tty_count = 0; break; } else { int_nest = YES; interrupted(nil); int_nest = NO; } pop_clock(); tty_count = 0; nil = C_nil; if (!exception_pending()) continue; } break; } #ifdef __cplusplus catch (int *) #else else #endif { if (errorset_msg != NULL) { term_printf("\n%s detected\n", errorset_msg); errorset_msg = NULL; } sigint_must_longjmp = NO; interrupt_pending = YES; tty_count = 0; } } pop_clock(); tty_pointer = tty_buffer; } if (tty_count == 0) c = '\n'; /* ^C odd case */ else { tty_count--; c = *tty_pointer++; #ifndef Kanji c &= 0xff; #endif } } inject_randomness(c); if (c == EOF || c == CTRL_D) return EOF; if (qvalue(echo_symbol) != nil) { Lisp_Object stream = qvalue(standard_output); if (!is_stream(stream)) stream = qvalue(terminal_io); if (!is_stream(stream)) stream = lisp_terminal_io; putc_stream(c, stream); if (exception_pending()) flip_exception(); } else if (spool_file != NULL) putc(c, spool_file); return c; } Lisp_Object Lrds(Lisp_Object nil, Lisp_Object a) { Lisp_Object old = qvalue(standard_input); if (a == nil) a = qvalue(terminal_io); if (a == old) return onevalue(old); else if (!is_stream(a)) return aerror1("rds", a); else if (stream_read_fn(a) == char_from_illegal) return aerror("rds"); /* closed stream or output stream */ qvalue(standard_input) = a; return onevalue(old); } Lisp_Object Lrtell_1(Lisp_Object nil, Lisp_Object stream) { int32 n; if (!is_stream(stream)) return onevalue(nil); n = other_read_action(READ_TELL, stream); if (n == -1) return onevalue(nil); else return onevalue(fixnum_of_int(n)); } Lisp_Object MS_CDECL Lrtell(Lisp_Object nil, int nargs, ...) /* * RTELL returns an integer that indicates the position of the current * input stream (as selected by RDS). If the position is not available * (as would be the case for an interactive stream) then NIL is returned. * Otherwise the result is an integer suitable for use with rseek. In the * case that the file was opened in binary mode the number returned is a * direct indication of the position in the file and arithmetic will * behave predictably - for text streams the value returned should be * thought of as an abstract position-tag. */ { argcheck(nargs, 0, "rtell"); return Lrtell_1(nil, qvalue(standard_input)); } Lisp_Object Lrseekend(Lisp_Object nil, Lisp_Object stream) { if (!is_stream(stream)) stream = qvalue(terminal_io); if (!is_stream(stream)) stream = lisp_terminal_io; other_read_action(READ_FLUSH, stream); if (other_read_action(READ_END, stream) != 0) return onevalue(nil); else return onevalue(lisp_true); } Lisp_Object Lrseek_2(Lisp_Object nil, Lisp_Object stream, Lisp_Object a) { int32 n; if (!is_stream(stream)) stream = qvalue(terminal_io); if (!is_stream(stream)) stream = lisp_terminal_io; if (is_fixnum(a)) n = (int32)int_of_fixnum(a); else return aerror("rseek"); other_read_action(READ_FLUSH, stream); if (other_read_action(n | 0x80000000, stream) != 0) return onevalue(nil); else return onevalue(lisp_true); } Lisp_Object Lrseek(Lisp_Object nil, Lisp_Object a) /* * If the current input stream supports random access this re-positions * it to a place indicated by the argument a. If the file was opened in * binary mode then a can be an integer indicating how far down the file * to set the position. For text files arguments to RSEEK should only be * values returned by previous calls to RTELL. RSEEK returns nil if it * failed (and if it noticed that fact) or T if it succeeded. */ { return Lrseek_2(nil, qvalue(standard_input), a); } /* * The getc_stream() method must NEVER be able to cause garbage collection, * since I code the reader here on the assumption that file control blocks * do not move while individual characters are read. */ /* * While I am in the middle of reading a whole expression the variable * curchar will hold the most recent character (or NOT_CHAR if there is none), * but between expressions I will push that back into the stream header. */ static void skip_whitespace(Lisp_Object stream) { Lisp_Object nil; for (;;) { switch (curchar) { case NOT_CHAR: case 0: case '\v': case '\f': case ' ': case '\t': case '\n': case '\r': case CTRL_C: curchar = getc_stream(stream); errexitv(); continue; #ifndef COMMON case '%': #else case ';': #endif while (curchar != '\n' && curchar != EOF && curchar != CTRL_D) { curchar = getc_stream(stream); errexitv(); } continue; default: return; } } } static Lisp_Object read_s(Lisp_Object stream); #ifdef COMMON static Lisp_Object read_hash(Lisp_Object stream); #endif static Lisp_Object read_list(Lisp_Object stream) /* * There is no code here to do anything about general read-macros, * and it will be awkward to fit it in here because of the reliance * that the Common Lisp readmacro scheme puts on the ability to return * no values at all using (values). I implement ' and ; and ` since * they seem very useful, but only simple cases of #. * I require that when this function is called I have already done * a skip_whitespace(), and as a result curchar will not be NOT_CHAR. */ { Lisp_Object l, w, nil = C_nil; stackcheck0(0); if (curchar == ')') { curchar = NOT_CHAR; return C_nil; } push(stream); #ifdef COMMON if (curchar == '#') { l = read_hash(stream); if (l == SPID_NOINPUT) { pop(stream); return read_list(stream); } } else #endif l = read_s(stream); errexitn(1); l = ncons(l); errexitn(1); push(l); /* this will be the final result */ for (;;) { skip_whitespace(stack[-1]); switch (curchar) { #ifndef COMMON case ']': #endif case ')': curchar = NOT_CHAR; pop2(l, stream); return l; case EOF: case CTRL_D: pop2(l, stream); return l; /* This code treats '.' as a special lexical marker, while the */ /* full version of the reader has to be more subtle. */ case '.': curchar = NOT_CHAR; push(l); w = read_s(stack[-2]); pop(l); errexitn(2); qcdr(l) = w; skip_whitespace(stack[-1]); if (curchar == ')') curchar = NOT_CHAR; /* else error("missing rpar or bad dot"); */ pop2(l, stream); return l; #ifdef COMMON case '#': push(l); w = read_hash(stack[-2]); errexitn(3); if (w == SPID_NOINPUT) { pop(l); continue; } w = ncons(w); errexitn(3); pop(l); qcdr(l) = w; l = w; continue; #endif default: push(l); w = read_s(stack[-2]); errexitn(3); w = ncons(w); errexitn(3); pop(l); qcdr(l) = w; l = w; continue; } } } static Lisp_Object list_to_vector(Lisp_Object l) { int32 len = 0; Lisp_Object p = l, nil = C_nil; while (consp(p)) len++, p = qcdr(p); push(l); p = getvector_init(CELL*(len+1), nil); pop(l); errexit(); len = 0; while (consp(l)) { elt(p, len) = qcar(l); len++; l = qcdr(l); } return p; } #ifdef COMMON static CSLbool evalfeature(Lisp_Object u) { Lisp_Object w, nil = C_nil; if (consp(u)) { Lisp_Object fn = qcar(u); u = qcdr(u); if (!consp(u)) return NO; if (fn == not_symbol) return !evalfeature(qcar(u)); else if (fn == and_symbol) { while (consp(u)) { if (!evalfeature(qcar(u))) return NO; nil = C_nil; if (exception_pending()) return NO; u = qcdr(u); } return YES; } else if (fn == or_symbol) { while (consp(u)) { if (evalfeature(qcar(u))) return YES; nil = C_nil; if (exception_pending()) return NO; u = qcdr(u); } return NO; } else return NO; } w = qvalue(features_symbol); while (consp(w)) { if (u == qcar(w)) return YES; w = qcdr(w); } return NO; } static Lisp_Object read_hash(Lisp_Object stream) { /* * A small subset of the # escaped read-macros will be supported here. * curchar must already be set to the character that follows the '#' */ int32 v, w = -1; int radix; Lisp_Object nil = C_nil; Lisp_Object p; curchar = getc_stream(stream); errexit(); if (ISdigit(curchar)) { w = 0; do { w = 10*w + curchar - '0'; curchar = getc_stream(stream); errexit(); } while (ISdigit(curchar)); } switch (curchar) { default: /* error("Unknown # escape"); */ return pack_char(0, 0, '#'); #ifdef COMMON case '#': curchar = NOT_CHAR; p = reader_workspace; while (p != nil) { Lisp_Object k = qcar(p); if (fixnum_of_int(w) == qcar(k)) return qcdr(k); p = qcdr(p); } return aerror1("Label not found with #n# syntax", fixnum_of_int(w)); case '=': curchar = NOT_CHAR; push(stream); /* * Hmmm - is it necessary for #nn# to refer back to the label here from * within the value about to be read? */ p = read_s(stream); pop(stream); errexit(); push(p); p = acons(fixnum_of_int(w), p, reader_workspace); errexitn(1); reader_workspace = p; pop(p); return p; #endif case ':': /* #:XXX reads in a gensym... */ curchar = NOT_CHAR; { Lisp_Object base = read_s(stream), al; /* The XXX bit unadorned */ errexit(); /* * This keeps an association list of gensyms present in this call to READ. * Note that if you use #.(read) [or other clever things] you may get * muddled about contexts. Note that this is sometimes helpful with * Standard Lisp but that for Common Lisp the more general #= and ## * mechanism should be used and this behaviour here would count as * WRONG. */ al = reader_workspace; while (al != nil) { Lisp_Object k = qcar(al); if (base == qcar(k)) return qcdr(k); al = qcdr(al); } push(base); /* * Beware that #:ggg has just ggg as its name, with no numeric suffix. */ al = Lgensym2(nil, base); pop(base); errexit(); al = acons(base, al, reader_workspace); errexit(); reader_workspace = al; return qcdr(qcar(al)); } case '(': /* Simple vector */ curchar = getc_stream(stream); errexit(); skip_whitespace(stream); errexit(); { Lisp_Object l = read_list(stream); errexit(); return list_to_vector(l); } case '\'': curchar = NOT_CHAR; p = read_s(stream); errexit(); return list2(function_symbol, p); case '\\': /* * The character just after "#\" is read without any case folding */ curchar = getc_stream(stream); errexit(); w = curchar; #ifdef COMMON /* * The word after "#\" is always spelt in regular ASCII so Kanji support * doe snot cut in here. */ if (isalpha(w)) { char buffer[32]; int bp = 0, w0 = w; while (isalpha(w) && bp < 30) { buffer[bp++] = toupper(w); /* Force word to upper case */ curchar = getc_stream(stream); errexit(); w = curchar; } if (bp == 1) #ifdef Kanji return pack_char(0, 0, w0 & 0xffff); #else return pack_char(0, 0, w0 & 0xff); #endif buffer[bp] = 0; p = make_string(buffer); errexit(); p = Lintern_2(nil, p, qvalue(keyword_package)); errexit(); p = get(p, named_character, nil); errexit(); return p; } #endif curchar = NOT_CHAR; errexit(); #ifdef Kanji return pack_char(0, 0, w & 0xffff); #else return pack_char(0, 0, w & 0xff); #endif case '.': curchar = NOT_CHAR; p = read_s(stream); errexit(); /* * The next is in case the expression evaluated involves reading from * this or another stream. */ if (curchar != NOT_CHAR) { other_read_action(curchar, stream); curchar = NOT_CHAR; } p = eval(p, nil); errexit(); return onevalue(p); case '+': case '-': v = (curchar == '-'); curchar = NOT_CHAR; /* * In March 1988 X3J13 voted that feature names read here should be in * the keyword package unless explicily otherwise qualified, but (I guess) * the AND, OR and NOT operators applying to them are NOT in the keyword * package. Thus I can not just rebind *package* here in any simple way. * Oh dear - I hope nobody relies on what those kind experts decided! * Meanwhile REMEMBER to go #+ :whatever please. */ push(stream); p = read_s(stream); errexitn(1); w = evalfeature(p); pop(stream); errexit(); if (w == v) { read_s(stream); errexit(); } /* * The following flag-value shows that read_hash() has not actually read * anything - but it may have skipped over some unwanted stuff. */ return onevalue(SPID_NOINPUT); case 'r': case 'R': radix = (w>=2 && w<=36) ? (int)w : 10; break; case 'b': case 'B': radix = 2; break; case 'o': case 'O': radix = 8; break; case 'x': case 'X': radix = 16; break; } /* Here I have a number specified in some unusual radix */ w = fixnum_of_int(0); curchar = getc_stream(stream); errexit(); while ((v = value_in_radix(curchar, radix)) >= 0) { w = times2(w, fixnum_of_int((int32)radix)); errexit(); w = plus2(w, fixnum_of_int(v)); errexit(); curchar = getc_stream(stream); errexit(); } return w; } #endif /* COMMON */ CSLbool is_constituent(int c) { if (c == EOF) return NO; if (c & ESCAPED_CHAR) return YES; /* escaped */ switch (c) { /* The following characters terminate symbols */ case ' ': case '\n': case '\t': case '\v': case '\f': case 0: case '(': case ')': case '\'': case ';': case '"': case '`': case ',': case CTRL_D: /* character 4 is EOF in ASCII */ #ifndef COMMON case '+': case '-': case '*': case '/': case '~': case '\\': case '@': case '#': case '$': case '%': case '^': case '&': case '=': case '{': case '}': case '[': case ']': case ':': case '<': case '>': case '?': case '!': case '|': /* * case '_': In OLD Standard Lisp underscore was a break character - * these days it is classified rather oddly, in that it does not terminate * a symbol but behaves specially if it starts one. * What about '.', which may need to be treated specially? */ case '.': #endif return NO; default: return YES; } } static Lisp_Object backquote_expander(Lisp_Object a) /* * ClTl (edition 2) seems to suggest that nested backquotes are a disgusting * morass - this code does not worry about the fine details! */ { Lisp_Object w1, f, nil = C_nil; if (a == nil) return a; if (!consp(a)) return list2(quote_symbol, a); stackcheck1(0, a); nil = C_nil; f = qcar(a); if (f == comma_symbol) return qcar(qcdr(a)); if (consp(f) && qcar(f) == comma_at_symbol) { w1 = qcar(qcdr(f)); push(w1); a = backquote_expander(qcdr(a)); errexit(); pop(w1); w1 = list2(w1, a); errexit(); return cons(append_symbol, w1); } /* * There is noticable scope for further optimisation here, with the * introduction of uses of list, list* as well as just cons and append. * It is also probably useful to worry about ,. as well as ,@ but for * now I defer that until the full version of the reader is installed. */ push(a); f = backquote_expander(f); pop(a); errexit(); push(f); a = backquote_expander(qcdr(a)); pop(f); errexit(); a = list2(f, a); errexit(); return cons(cons_symbol, a); } static CSLbool read_failure; static void packbyte(int c) { Lisp_Object nil = C_nil; int32 boffo_size = length_of_header(vechdr(boffo)); /* * I expand boffo (maybe) several characters earlier than you might * consider necessary. Some of that is to be extra certain about having * space in it when I pack a multi-byte (eg Kanji) character. */ if (boffop >= (int)boffo_size - 12) { Lisp_Object new_boffo = getvector(TAG_VECTOR, TYPE_STRING, 2*boffo_size); nil = C_nil; if (exception_pending()) { flip_exception(); /* * What should I do if I fail to expand boffo - for present I silently * truncate the object I am reading. But I set a flag that will be checked * on the way out of read/compress, so the user will know. */ read_failure = YES; return; } memcpy((void *)((char *)new_boffo + (CELL-TAG_VECTOR)), &boffo_char(0), boffop); boffo = new_boffo; } #ifdef Kanji if (iswchar(c)) boffo_char(boffop++) = c >> 8; #endif boffo_char(boffop) = c; boffop++; } #ifdef COMMON static char package_name[32]; #endif static Lisp_Object read_s(Lisp_Object stream) { Lisp_Object w, nil = C_nil; for (;;) { skip_whitespace(stream); errexit(); switch (curchar) { case EOF: case CTRL_D: return CHAR_EOF; case '(': curchar = NOT_CHAR; skip_whitespace(stream); errexit(); return read_list(stream); #ifndef COMMON case '[': curchar = NOT_CHAR; skip_whitespace(stream); errexit(); w = read_list(stream); errexit(); return list_to_vector(w); case ']': #endif case ')': curchar = NOT_CHAR; continue; /* Ignore spurious rpar */ case '\'': curchar = NOT_CHAR; w = read_s(stream); errexit(); return list2(quote_symbol, w); case '`': curchar = NOT_CHAR; w = read_s(stream); errexit(); return backquote_expander(w); case ',': curchar = getc_stream(stream); errexit(); if (curchar == '@') { curchar = NOT_CHAR; w = read_s(stream); errexit(); return list2(comma_at_symbol, w); } else { w = read_s(stream); errexit(); return list2(comma_symbol, w); } /* * Neither Standard nor Common Lisp make stray dots very welcome. In Common * Lisp multiple adjacent dots are supposed to be an error. Here I just ignore * stray dots, and hope that nobody is silly enough to have them in their code. */ case '.': /* error("Bad dot"); */ curchar = NOT_CHAR; continue; /* Ignore spurious dot */ #ifdef COMMON case '#': push(stream); w = read_hash(stream); pop(stream); if (w != SPID_NOINPUT) return w; else return read_s(stream); #endif case '"': boffop = 0; { for (;;) /* Used to cope with "abc""def" */ { curchar = getc_stream(stream); errexit(); #ifdef COMMON if (curchar == ESCAPE_CHAR) { curchar = getc_stream(stream); errexit(); if (curchar!=EOF) curchar |= ESCAPED_CHAR; } #endif if (curchar == EOF || curchar == CTRL_D) return CHAR_EOF; while (curchar != '"' && curchar != EOF && curchar != CTRL_D) { push(stream); packbyte(curchar); pop(stream); curchar = getc_stream(stream); errexit(); #ifdef COMMON if (curchar == ESCAPE_CHAR) { curchar = getc_stream(stream); errexit(); if (curchar!=EOF) curchar |= ESCAPED_CHAR; } #endif } #ifndef COMMON curchar = getc_stream(stream); errexit(); if (curchar == '"') { push(stream); packbyte(curchar); pop(stream); continue; /* Handle "abc""def" for Standard Lisp */ } #else curchar = NOT_CHAR; #endif return copy_string(boffo, boffop); } } #ifndef COMMON case '+': case '-': case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': /* * I treat numbers specially here since I want to allow '.' within * numbers, but NOT within symbols. Common Lisp views '.' as a * constituent character and so does not need quite so much effort * just here. */ { boffop = 0; if (curchar == '+' || curchar == '-') { push(stream); packbyte(curchar); pop(stream); curchar = getc_stream(stream); errexit(); /* + or - not followed by a digit will be read as a symbol */ if (!ISdigit(curchar)) return intern(boffop, NO); } while (ISdigit(curchar)) { push(stream); packbyte(curchar); pop(stream); curchar = getc_stream(stream); errexit(); } /* accept possible decimal point */ if (curchar == '.') { push(stream); packbyte(curchar); pop(stream); curchar = getc_stream(stream); errexit(); while (ISdigit(curchar)) { push(stream); packbyte(curchar); pop(stream); curchar = getc_stream(stream); errexit(); } } /* accept possible exponent */ if (curchar == 'e' || curchar == 'E') { push(stream); packbyte('e'); pop(stream); curchar = getc_stream(stream); errexit(); if (curchar == '+' || curchar == '-') { push(stream); packbyte(curchar); pop(stream); curchar = getc_stream(stream); errexit(); } while (ISdigit(curchar)) { push(stream); packbyte(curchar); pop(stream); curchar = getc_stream(stream); errexit(); } } return intern(boffop, NO); } case '_': /* This seems to have to be a funny case for REDUCE */ boffop = 0; push(stream); packbyte(curchar); pop(stream); curchar = getc_stream(stream); errexit(); return intern(boffop, NO); #endif default: { CSLbool escaped = NO; #ifdef COMMON CSLbool within_vbars = NO; int colon = -1, double_colon = -1, i; #endif boffop = 0; #ifdef COMMON while (curchar == '|') { nil = C_nil; stackcheck0(0); curchar = getc_stream(stream); errexit(); within_vbars = !within_vbars; /* * A funny thought arises here - maybe the characters ||123 are a potential * number, since there are no characters inside the vertical bars to show * otherwise! Hence I need to set escaped only when I find a genuine character * within the vertical-bar protected region. Hence this coded as a while * loop not a simple IF statement. Another horrid issue is that the input * "|| " (where there are two initial vertical bars and then a terminating * character) ought to parse as an identifier with an empty name. Thus * if I read ahead here and find whitespace etc I need to exit here. */ if (!within_vbars && !is_constituent(curchar)) return intern(0, YES); } #endif if (curchar == ESCAPE_CHAR) { nil = C_nil; stackcheck0(0); curchar = getc_stream(stream); errexit(); /* However, any character escaped with '\' means we do not have a number */ escaped = YES; } else #ifdef COMMON if (!within_vbars) { if (curchar == ':') colon = boffop, escaped = YES; #else { #endif if (curchar != EOF) { if (qvalue(lower_symbol) != nil) curchar = TOlower(curchar); else if (qvalue(raise_symbol) != nil) curchar = TOupper(curchar); #ifdef Kanji if (qvalue(hankaku_symbol) != nil) is (iszenkaku(curchar)) curchar = tohankaku(curchar); #endif } } /* * Here is the main loop that reads an identifier. Observe the extra * complication that Common Lisp generates with the need to support * package markers and '|' style escapes... */ do { push(stream); packbyte(curchar); pop(stream); curchar = getc_stream(stream); errexit(); #ifdef COMMON if (within_vbars) escaped = YES; while (curchar == '|') { nil = C_nil; stackcheck0(0); curchar = getc_stream(stream); errexit(); within_vbars = !within_vbars; } #endif if (curchar == EOF) break; else if (curchar == ESCAPE_CHAR) { nil = C_nil; stackcheck0(0); curchar = getc_stream(stream); errexit(); curchar |= ESCAPED_CHAR; escaped = YES; } #ifdef COMMON else if (!within_vbars) { if (curchar == ':') { if (colon >= 0) double_colon = boffop; else colon = boffop, escaped = YES; } #endif else if (qvalue(lower_symbol) != nil) curchar = TOlower(curchar); else if (qvalue(raise_symbol) != nil) curchar = TOupper(curchar); #ifdef Kanji if (qvalue(hankaku_symbol) != nil) is (iszenkaku(curchar)) curchar = tohankaku(curchar); #endif #ifdef COMMON } } while (within_vbars || is_constituent(curchar)); #else } while (is_constituent(curchar)); #endif #ifdef COMMON /* * If there are no colons present, or if there are two but they * are not consecutive, or of there are three or more, or if the last * character of the symbol was a colon, I will just look it up in * the current package. */ if (colon < 0 || colon+1==boffop) return intern(boffop, escaped); if ((double_colon >= 0 && double_colon != colon+1) || double_colon+1==boffop) return intern(boffop, escaped); /* * If the first character was a colon I use the keyword package. */ memset(package_name, 0, sizeof(package_name)); strncpy(package_name, &celt(boffo, 0), (size_t)colon); package_name[sizeof(package_name)-1] = 0; /* term_printf("Package lookup <%.*s>\n", (int)colon, &celt(boffo, 0)); */ if (colon == 0) w = qvalue(keyword_package); else w = find_package(&celt(boffo, 0), colon); /* * Here I rely on find_package never raising an exception and never giving * a possible entry into a break loop (etc), since I need boffo[] intact * after the call. */ if (w == nil) { err_printf( "+++ Package %s not found: using current package\n", package_name); /* * Similarly I assume, unreasonably, that boffo can not be disturbed by * printing this warning message. */ w = CP; /* default behaviour: unknown package */ } if (double_colon >= 0) colon = double_colon; i = 0; colon++; while (colon < boffop) boffo_char(i++) = boffo_char(colon++); boffop = i; /* term_printf("Name within package <%.*s>\n", (int)boffop, &celt(boffo, 0)); */ if (double_colon < 0 && w != qvalue(keyword_package)) { /* In the case ppp:sss it MUST be external in ppp */ Lisp_Object wx; push(w); wx = iintern(boffo, (int32)boffop, w, 4); pop(w); errexit(); if (mv_2 == nil) { err_printf("+++ Symbol %.*s not external in %s\n", (int)boffop, &celt(boffo, 0), package_name); err_printf("+++ Treating as internal symbol...\n"); } else return wx; } /* * Curiously I will always take keywords (as in :kkk) through the path * that corresponds to looking up an internal symbol, ie ::kkk, since that * way I allow the reader to create a new symbol. If I handled the keyword * case in the usual external symbol way it would demand that the keyword * already existed (since in all other packages nothing is external unless * it already exists and has been exported). */ return iintern(boffo, (int32)boffop, w, 0); #else return intern(boffop, escaped); #endif } } } } int char_from_synonym(Lisp_Object stream) { stream = qvalue(stream_read_data(stream)); if (!is_stream(stream)) return aerror1("bad synonym stream", stream); return getc_stream(stream); } int char_from_concatenated(Lisp_Object stream) { Lisp_Object l = stream_read_data(stream), s1; Lisp_Object nil = C_nil; int c; while (consp(l)) { s1 = qcar(l); if (!is_symbol(s1)) { l = qcdr(l); stream_read_data(stream) = l; continue; } s1 = qvalue(s1); if (!is_stream(s1)) { l = qcdr(l); stream_read_data(stream) = l; continue; } push2(l, stream); c = getc_stream(s1); pop2(stream, l); errexit(); if (c == EOF) { l = qcdr(l); stream_read_data(stream) = l; continue; } } return EOF; } int char_from_echo(Lisp_Object stream) { int c; Lisp_Object stream1 = qvalue(stream_read_data(stream)); if (!is_stream(stream1)) return aerror1("bad synonym stream", stream1); c = getc_stream(stream1); char_to_synonym(c, stream); return c; } int char_from_file(Lisp_Object stream) { Lisp_Object nil = C_nil; int ch = stream_pushed_char(stream); if (ch == NOT_CHAR) { #ifdef Kanji ch = getwc(stream_file(stream)); #else ch = getc(stream_file(stream)); #endif if (ch == EOF /* || ch == CTRL_D */ ) return EOF; if (qvalue(echo_symbol) != nil) { Lisp_Object stream1 = qvalue(standard_output); if (!is_stream(stream1)) stream1 = qvalue(terminal_io); if (!is_stream(stream1)) stream1 = lisp_terminal_io; putc_stream(ch, stream1); if (exception_pending()) flip_exception(); } } else stream_pushed_char(stream) = NOT_CHAR; return ch; } int32 read_action_illegal(int32 op, Lisp_Object f) { CSL_IGNORE(f); if (op != READ_CLOSE && op != READ_IS_CONSOLE) aerror1("Illegal operation on stream", cons_no_gc(fixnum_of_int(op), stream_type(f))); return 0; } int32 read_action_file(int32 op, Lisp_Object f) { if (op < -1) return fseek(stream_file(f), op & 0x7fffffff, SEEK_SET); else if (op <= 0xffff) return (stream_pushed_char(f) = op); else switch (op) { case READ_CLOSE: if (stream_file(f) == NULL) op = 0; else op = fclose(stream_file(f)); set_stream_read_fn(f, char_from_illegal); set_stream_read_other(f, read_action_illegal); set_stream_file(f, NULL); return op; case READ_FLUSH: stream_pushed_char(f) = NOT_CHAR; return 0; case READ_TELL: if ((op = stream_pushed_char(f)) != NOT_CHAR) { ungetc(op, stream_file(f)); stream_pushed_char(f) = NOT_CHAR; } return (int32)ftell(stream_file(f)); case READ_END: return fseek(stream_file(f), 0L, SEEK_END); case READ_IS_CONSOLE: return 0; default: return 0; } } int32 read_action_output_file(int32 op, Lisp_Object f) { if (op < -1) return fseek(stream_file(f), op & 0x7fffffff, SEEK_SET); else if (op <= 0xffff) return 0; else switch (op) { case READ_TELL: op = ftell(stream_file(f)); return op; case READ_END: return fseek(stream_file(f), 0L, SEEK_END); default: return 0; } } int32 read_action_terminal(int32 op, Lisp_Object f) { CSL_IGNORE(f); if (op < -1) return 1; else if (op <= 0xffff) return (terminal_pushed = op); else switch (op) { case READ_CLOSE: return 0; case READ_FLUSH: terminal_pushed = NOT_CHAR; tty_count = 0; return 0; case READ_TELL: return -1; case READ_IS_CONSOLE: return 1; default: return 0; } } int32 read_action_synonym(int32 c, Lisp_Object f) { int32 r; Lisp_Object f1; f1 = qvalue(stream_read_data(f)); if (!is_stream(f1)) return aerror1("bad synonym stream", f1); r = other_read_action(c, f1); if (c == READ_CLOSE) { set_stream_read_fn(f, char_from_illegal); set_stream_read_other(f, read_action_illegal); set_stream_file(f, NULL); } return r; } int32 read_action_concatenated(int32 c, Lisp_Object f) { int32 r = 0, r1; Lisp_Object l, f1; #ifdef COMMON Lisp_Object nil = C_nil; #endif l = stream_read_data(f); while (consp(l)) { f1 = qcar(l); l = qcdr(l); if (!is_symbol(f1)) continue; f1 = qvalue(f1); if (!is_stream(f1)) continue; push2(l, f); r1 = other_read_action(c, f1); pop2(f, l); if (r == 0) r = r1; } if (c == READ_CLOSE) { set_stream_read_fn(f, char_from_illegal); set_stream_read_other(f, read_action_illegal); set_stream_file(f, NULL); } return r; } int32 read_action_list(int32 op, Lisp_Object f) { if (op < -1) return 1; else if (op <= 0xffff) return (stream_pushed_char(f) = op); else switch (op) { case READ_CLOSE: set_stream_read_fn(f, char_from_illegal); set_stream_read_other(f, read_action_illegal); set_stream_file(f, NULL); stream_read_data(f) = C_nil; return 0; case READ_FLUSH: stream_pushed_char(f) = NOT_CHAR; return 0; case READ_TELL: return -1; case READ_IS_CONSOLE: return 0; default: return 0; } } int32 read_action_vector(int32 op, Lisp_Object f) { if (op < -1) return 1; else if (op <= 0xffff) return (stream_pushed_char(f) = op); else switch (op) { case READ_CLOSE: set_stream_read_fn(f, char_from_illegal); set_stream_read_other(f, read_action_illegal); set_stream_file(f, NULL); stream_read_data(f) = C_nil; return 0; case READ_FLUSH: stream_pushed_char(f) = NOT_CHAR; return 0; case READ_TELL: return -1; case READ_IS_CONSOLE: return 0; default: return 0; } } static int most_recent_read_point = 0; Lisp_Object MS_CDECL Lread(Lisp_Object nil, int nargs, ...) /* * The full version of read_s() has to support extra optional args * that deal with error and eof returns... and a recursive-p arg! */ { Lisp_Object w, stream = qvalue(standard_input); int cursave = curchar; argcheck(nargs, 0, "read"); #ifdef COMMON push(reader_workspace); reader_workspace = nil; #endif read_failure = NO; if (!is_stream(stream)) stream = qvalue(terminal_io); if (!is_stream(stream)) stream = lisp_terminal_io; curchar = NOT_CHAR; most_recent_read_point = other_read_action(READ_TELL, stream); push(stream); w = read_s(stream); pop(stream); if (curchar != NOT_CHAR) other_read_action(curchar, stream); curchar = cursave; current_file = stream_type(stream); #ifdef COMMON nil = C_nil; if (exception_pending()) { flip_exception(); pop(reader_workspace); flip_exception(); return nil; } pop(reader_workspace); #else errexit(); #endif if (read_failure) return aerror("read"); return onevalue(w); } static Lisp_Object MS_CDECL Lwhere_was_that(Lisp_Object nil, int nargs, ...) { Lisp_Object w; argcheck(nargs, 0, "where-was-that"); #ifdef COMMON w = list3(current_file, fixnum_of_int(most_recent_read_point), packname_(CP)); #else w = list2(current_file, fixnum_of_int(most_recent_read_point)); #endif errexit(); return onevalue(w); } #ifdef COMMON Lisp_Object Lread_1(Lisp_Object nil, Lisp_Object stream) { int cursave = curchar; Lisp_Object w; Lisp_Object save = Lrds(nil, stream); errexit(); push2(reader_workspace, save); reader_workspace = nil; read_failure = NO; stream = qvalue(standard_input); if (!is_stream(stream)) stream = qvalue(terminal_io); if (!is_stream(stream)) stream = lisp_terminal_io; curchar = NOT_CHAR; w = read_s(stream); if (curchar != NOT_CHAR) other_read_action(curchar, stream); curchar = cursave; nil = C_nil; if (exception_pending()) { flip_exception(); pop2(save, reader_workspace); Lrds(nil, save); errexit(); flip_exception(); return nil; } pop2(save, reader_workspace); push(w); Lrds(nil, save); pop(w); errexit(); if (read_failure) return aerror("read"); return onevalue(w); } #endif /* * compress is not a Common Lisp function, but it is another on those * things that I want within my implementation for internal purposes as * well as for real use. */ int char_from_list(Lisp_Object f) { #ifdef COMMON Lisp_Object nil = C_nil; #else nil_as_base #endif Lisp_Object ch = stream_pushed_char(f); if (ch == NOT_CHAR) { if (!consp(stream_read_data(f))) ch = EOF; else { ch = qcar(stream_read_data(f)); stream_read_data(f) = qcdr(stream_read_data(f)); } /* * here I tend towards generosity - a symbol stands for the first character * of its name, and character objects and numbers (representing internal * codes) are also permitted. Incomplete gensyms are OK here - I just * use the first character of the base of the name. */ if (is_symbol(ch)) ch = first_char(ch); else if (is_char(ch)) ch = (char)code_of_char(ch); else if (is_fixnum(ch)) ch = (char)int_of_fixnum(ch); else ch = EOF; /* Bad item in the list */ } else stream_pushed_char(f) = NOT_CHAR; return ch; } int char_from_vector(Lisp_Object f) { #ifdef COMMON Lisp_Object nil = C_nil; #else nil_as_base #endif Lisp_Object ch = stream_pushed_char(f); if (ch == NOT_CHAR) { char *v = (char *)stream_file(f); if (v == NULL) ch = EOF; else { ch = *v++; if (ch == 0) ch = EOF; else set_stream_file(f, (FILE *)v); } } else stream_pushed_char(f) = NOT_CHAR; return ch; } Lisp_Object read_from_vector(char *v) { int savecur = curchar; Lisp_Object nil = C_nil, r; stream_read_data(lisp_work_stream) = nil; set_stream_read_fn(lisp_work_stream, char_from_vector); set_stream_read_other(lisp_work_stream, read_action_vector); stream_pushed_char(lisp_work_stream) = NOT_CHAR; set_stream_file(lisp_work_stream, (FILE *)v); read_failure = NO; curchar = NOT_CHAR; r = read_s(lisp_work_stream); errexit(); curchar = savecur; if (read_failure) return aerror("read-from-vector"); return onevalue(r); } Lisp_Object Lcompress(Lisp_Object env, Lisp_Object stream) { int savecur = curchar; Lisp_Object nil = C_nil; stream_read_data(lisp_work_stream) = stream; set_stream_read_fn(lisp_work_stream, char_from_list); set_stream_read_other(lisp_work_stream, read_action_list); stream_pushed_char(lisp_work_stream) = NOT_CHAR; read_failure = NO; curchar = NOT_CHAR; env = read_s(lisp_work_stream); errexit(); stream_read_data(lisp_work_stream) = C_nil; curchar = savecur; if (read_failure) return aerror("compress"); return onevalue(env); } Lisp_Object Llist_to_string(Lisp_Object nil, Lisp_Object stream) { int n = 0, k; Lisp_Object str; char *s; stream_read_data(lisp_work_stream) = stream; set_stream_read_fn(lisp_work_stream, char_from_list); set_stream_read_other(lisp_work_stream, read_action_list); stream_pushed_char(lisp_work_stream) = NOT_CHAR; while (consp(stream)) n++, stream = qcdr(stream); str = getvector(TAG_VECTOR, TYPE_STRING, CELL+n); errexit(); s = (char *)str - TAG_VECTOR; k = (n + 3) & ~7; /* Here I zero out the last doubleword of the new string */ *(int32 *)(s + k + 4) = 0; if (k != 0) *(int32 *)(s + k) = 0; s = s + 4; for (k=0; k<n; k++) *s++ = char_from_list(lisp_work_stream); return onevalue(str); } Lisp_Object Llist_to_symbol(Lisp_Object nil, Lisp_Object stream) { stream = Llist_to_string(nil, stream); errexit(); #ifdef COMMON stream = Lintern_2(nil, stream, CP); errexit(); return onevalue(stream); /* NB intern would have returned 2 values */ #else return Lintern(nil, stream); #endif } void read_eval_print(int noisy) { Lisp_Object nil = C_nil, *save = stack; #ifndef __cplusplus jmp_buf this_level, *saved_buffer = errorset_buffer; #endif push2(codevec, litvec); for (;;) /* Loop for each s-expression found */ { Lisp_Object u; #ifdef COMMON int32 nvals, i; #endif miscflags |= (HEADLINE_FLAG | MESSAGES_FLAG); errorset_msg = NULL; #ifdef __cplusplus try #else if (!setjmp(this_level)) #endif { #ifndef __cplusplus errorset_buffer = &this_level; #endif u = Lread(nil, 0); } #ifdef __cplusplus catch (char *) #else else #endif { if (errorset_msg != NULL) { term_printf("\n%s detected\n", errorset_msg); errorset_msg = NULL; } unwind_stack(save, NO); stack = save; signal(SIGFPE, low_level_signal_handler); #ifdef __WATCOMC__ _control87(_EM_OVERFLOW | _EM_INVALID | _EM_DENORMAL | _EM_ZERODIVIDE | _EM_INEXACT | _EM_UNDERFLOW, _MCW_EM); #endif if (segvtrap) signal(SIGSEGV, low_level_signal_handler); #ifdef SIGBUS if (segvtrap) signal(SIGBUS, low_level_signal_handler); #endif #ifdef SIGILL if (segvtrap) signal(SIGILL, low_level_signal_handler); #endif err_printf("\n... read failed\n"); continue; } nil = C_nil; if (exception_pending()) { flip_exception(); /* * Maybe (stop) or (preserve) was called from a read-macro? Otherwise * errors reading are ignored and the system tries to read the next * expression for evaluation. Note that this behaviour means that * perhaps unreasonably or unexpectedly, THROW will not be propagated * back past a read_eval_print loop. */ if (exit_reason == UNWIND_RESTART) { #ifndef __cplusplus errorset_buffer = saved_buffer; #endif pop2(litvec, codevec); flip_exception(); return; } err_printf("\n... read failed\n"); continue; } /* * This will stop at end of file. That could EITHER be a real proper * end of file, or the user having #\eof in the input file. These are NOT * equivalent, in that #\eof is read once and then further stuff from the * stream can be read, while a real EOF (eg typing ^D at the terminal in * some cases) ends the stream once and for all. */ if (u == CHAR_EOF) { #ifndef __cplusplus errorset_buffer = saved_buffer; #endif pop2(litvec, codevec); return; } if (qvalue(standard_input) == lisp_terminal_io && spool_file != NULL) putc('\n', spool_file); miscflags |= (HEADLINE_FLAG | MESSAGES_FLAG); errorset_msg = NULL; #ifdef __cplusplus try #else if (!setjmp(this_level)) #endif { u = eval(u, nil); nil = C_nil; if (exception_pending()) { flip_exception(); /* safe again! */ if (exit_reason == UNWIND_RESTART) { #ifndef __cplusplus errorset_buffer = saved_buffer; #endif pop2(litvec, codevec); flip_exception(); return; } err_printf("\n... continuing after error\n"); if (spool_file != NULL) fflush(spool_file); continue; } if (noisy) { #ifndef COMMON print(u); /* Always exactly one value */ stdout_printf("\n"); nil = C_nil; if (exception_pending()) flip_exception(); #else nvals = exit_count; /* * These days I have to push mv_2 because print can call find-symbol to * decide if it needs to display a package qualifier, and in that case * it alters mv_2 on the way... But at present it should never change * any higher multiple value. I guess if it were interrupted then a break * loop (if one existed) could corrupt almost anything, but I will * ignore that worry. */ if (nvals > 0) { push(mv_2); print(u); pop(u); } nil = C_nil; if (exception_pending()) flip_exception(); mv_2 = u; miscflags |= (HEADLINE_FLAG | MESSAGES_FLAG); for (i=2; i<=nvals; i++) { print((&mv_2)[i-2]); nil = C_nil; if (exception_pending()) { flip_exception(); break; } } stdout_printf("\n"); #endif } } #ifdef __cplusplus catch (char *) #else else #endif { if (errorset_msg != NULL) { term_printf("\n%s detected\n", errorset_msg); errorset_msg = NULL; } unwind_stack(save, NO); stack = save; signal(SIGFPE, low_level_signal_handler); #ifdef __WATCOMC__ _control87(_EM_OVERFLOW | _EM_INVALID | _EM_DENORMAL | _EM_ZERODIVIDE | _EM_INEXACT | _EM_UNDERFLOW, _MCW_EM); #endif if (segvtrap) signal(SIGSEGV, low_level_signal_handler); #ifdef SIGBUS if (segvtrap) signal(SIGBUS, low_level_signal_handler); #endif #ifdef SIGILL if (segvtrap) signal(SIGILL, low_level_signal_handler); #endif err_printf("\n... continuing after error\n"); if (spool_file != NULL) fflush(spool_file); continue; } } } /* * RDF is wanted as it is in Standard Lisp. In Common Lisp the corresponding * function is LOAD. LOAD takes keyword arguments, which are decoded * elsewhere, leaving the code here which takes a variable number of * args, but all with definite simple interpretations. */ Lisp_Object Lrdf4(Lisp_Object nil, Lisp_Object file, Lisp_Object noisyp, Lisp_Object verbosep, Lisp_Object nofilep) { Lisp_Object r = nil; int noisy = (noisyp != nil), #ifdef COMMON nofile = (nofilep != nil), #endif verbose = (verbosep != nil); #ifndef COMMON CSL_IGNORE(nofilep); #endif /* * (rdf nil)/(load nil) obeys Lisp commands from the current input */ push3(nil, nil, file); /* * I have a somewhat comical chunk of code here. If the file-name passed * across ends in a suffix that is one of ".o", ".fsl" or ".fasl" then * instead of reading a textual source file the way one might have * expected I will subvert things and perform LOAD-MODULE instead. */ if (file != nil) { Header h; char *filestring; char tail[8]; int32 i, len; #ifdef COMMON if (complex_stringp(file)) { file = simplify_string(file); errexitn(3); } #endif if (symbolp(file)) { file = get_pname(file); errexitn(3); h = vechdr(file); } else if (!is_vector(file) || type_of_header(h = vechdr(file)) != TYPE_STRING) return aerror1("load", file); len = length_of_header(h) - CELL; filestring = (char *)file + CELL-TAG_VECTOR; for (i=0; i<6; i++) { if (len == 0) { tail[i] = 0; break; } else tail[i] = tolower(filestring[--len]); } if (strncmp(tail, "lsf.", 4) == 0 || strncmp(tail, "lasf.", 5) == 0 || strncmp(tail, "o.", 2) == 0) { stack[0] = file; if (verbose) { #ifdef COMMON trace_printf("\n;; Loading module "); #else trace_printf("\nReading module "); #endif loop_print_trace(file); trace_printf("\n"); } Lload_module(nil, stack[0]); errexitn(3); if (verbose) { #ifdef COMMON trace_printf("\n;; Loaded module "); #else trace_printf("\nRead module "); #endif loop_print_trace(stack[0]); trace_printf("\n"); } popv(3); #ifdef COMMON return onevalue(lisp_true); #else return onevalue(nil); #endif } stack[-1] = r = Lopen(nil, file, fixnum_of_int(1+64)); errexitn(3); #ifdef COMMON /* * The test here is necessary since in Common Lisp mode an attempt to OPEN a * file that can not be accessed returns NIL rather than raising an * exception. */ if (r == nil) { pop(file); popv(2); if (nofile) return error(1, err_open_failed, file); else return onevalue(nil); } #endif stack[-2] = r = Lrds(nil, r); errexitn(3); if (verbose) { file = stack[0]; #ifdef COMMON trace_printf("\n;; Loading "); loop_print_trace(file); trace_printf("\n"); #else trace_printf("\nReading "); loop_print_trace(file); trace_printf("\n"); #endif } errexitn(3); } read_eval_print(noisy); nil = C_nil; if (exception_pending()) { flip_exception(); if (exit_reason == UNWIND_ERROR) { #ifdef COMMON trace_printf("\n;; Loaded "); #else trace_printf("\nFinished reading "); #endif loop_print_trace(stack[0]); trace_printf(" (bad)\n"); } if (stack[0] != nil) { Lclose(nil, stack[-1]); nil = C_nil; if (exception_pending()) flip_exception(); Lrds(nil, stack[-2]); errexitn(3); } flip_exception(); popv(3); return nil; } #ifdef COMMON trace_printf("\n;; Loaded "); #else trace_printf("\nRead "); #endif loop_print_trace(stack[0]); trace_printf("\n"); if (stack[0] != nil) { Lclose(nil, stack[-1]); nil = C_nil; if (exception_pending()) flip_exception(); Lrds(nil, stack[-2]); errexitn(3); } popv(3); #ifdef COMMON return onevalue(lisp_true); #else return onevalue(nil); #endif } Lisp_Object Lrdf1(Lisp_Object nil, Lisp_Object file) { return Lrdf4(nil, file, lisp_true, lisp_true, lisp_true); } Lisp_Object Lrdf2(Lisp_Object nil, Lisp_Object file, Lisp_Object noisy) { return Lrdf4(nil, file, noisy, lisp_true, lisp_true); } Lisp_Object MS_CDECL Lrdfn(Lisp_Object nil, int nargs, ...) { va_list a; Lisp_Object file, noisy, verbose, nofile = lisp_true; if (nargs < 3 || nargs > 4) return aerror("load"); va_start(a, nargs); file = va_arg(a, Lisp_Object); noisy = va_arg(a, Lisp_Object); verbose = va_arg(a, Lisp_Object); if (nargs > 3) nofile = va_arg(a, Lisp_Object); va_end(a); return Lrdf4(nil, file, noisy, verbose, nofile); } #ifdef COMMON #define spool_name "dribble" #else #define spool_name "spool" #endif Lisp_Object Lspool(Lisp_Object nil, Lisp_Object file) { char filename[LONGEST_LEGAL_FILENAME]; Header h; int32 len; #ifdef SOCKETS /* * Security measure - remote client can not do "spool" */ if (socket_server != 0) return onevalue(nil); #endif if (spool_file != NULL) { #ifdef COMMON fprintf(spool_file, "\nFinished dribbling to %s.\n", spool_file_name); #else fprintf(spool_file, "\n+++ End of transcript +++\n"); #endif fclose(spool_file); spool_file = NULL; } if (file == nil) return onevalue(lisp_true); #ifdef COMMON if (complex_stringp(file)) { file = simplify_string(file); errexit(); } #endif if (symbolp(file)) { file = get_pname(file); errexit(); h = vechdr(file); } if (!is_vector(file) || type_of_header(h = vechdr(file)) != TYPE_STRING) return aerror1(spool_name, file); len = length_of_header(h) - CELL; spool_file = open_file(filename, (char *)file + (CELL-TAG_VECTOR), (size_t)len, "w", NULL); if (spool_file != NULL) { time_t t0 = time(NULL); strncpy(spool_file_name, filename, 32); spool_file_name[31] = 0; #ifdef COMMON fprintf(spool_file, "Starts dribbling to %s (%.24s)\n", spool_file_name, ctime(&t0)); #else fprintf(spool_file, "+++ Transcript to %s started at %.24s +++\n", spool_file_name, ctime(&t0)); #endif return onevalue(lisp_true); } return onevalue(nil); } static Lisp_Object MS_CDECL Lspool0(Lisp_Object nil, int nargs, ...) { argcheck(nargs, 0, spool_name); return Lspool(nil, nil); } #ifdef COMMON #define STARTING_SIZE_X 32 #define STARTING_SIZE_I 32 Lisp_Object make_package(Lisp_Object name) /* * ... assuming that there is not already one with this name. Packages * can grow as extra symbols are inserted into them, so I can reasonably * start off with a very small package. */ { Lisp_Object nil = C_nil; Lisp_Object p = getvector_init(sizeof(Package), nil), w; errexit(); packhdr_(p) = TYPE_STRUCTURE + (packhdr_(p) & ~header_mask); packid_(p) = package_symbol; packname_(p) = name; packext_(p) = getvector_init(STARTING_SIZE_X+CELL, fixnum_of_int(0)); errexit(); packint_(p) = getvector_init(STARTING_SIZE_I+CELL, fixnum_of_int(0)); errexit(); packflags_(p) = fixnum_of_int(++package_bits); packvext_(p) = fixnum_of_int(1); packvint_(p) = fixnum_of_int(1); packnext_(p) = fixnum_of_int(0); packnint_(p) = fixnum_of_int(0); w = cons(p, all_packages); errexit(); all_packages = w; return onevalue(p); } static Lisp_Object want_a_string(Lisp_Object name) { #ifdef COMMON Lisp_Object nil = C_nil; if (complex_stringp(name)) return simplify_string(name); #else nil_as_base #endif if (symbolp(name)) return get_pname(name); else if (is_vector(name) && type_of_header(vechdr(name)) == TYPE_STRING) return name; else return aerror1("name or string needed", name); } static Lisp_Object Lfind_package(Lisp_Object nil, Lisp_Object name) /* * This should be given a string as an argument. If it is given a * symbol it takes its pname as the string to be used. It scans the list * of all packages and returns the first that it finds where the name * or a nickname matches the string passed in. */ { Lisp_Object w; Header h; int32 len; CSL_IGNORE(nil); if (is_vector(name)) { h = vechdr(name); if (type_of_header(h) == TYPE_STRUCTURE && packid_(name) == package_symbol) return onevalue(name); } name = want_a_string(name); errexit(); h = vechdr(name); len = length_of_header(h) - CELL; for (w = all_packages; w!=nil; w=qcdr(w)) { Lisp_Object nn, n = packname_(qcar(w)); if (is_vector(n) && vechdr(n) == h && memcmp((char *)name + (CELL-TAG_VECTOR), (char *)n + (CELL-TAG_VECTOR), (size_t)len) == 0) return onevalue(qcar(w)); for (nn = packnick_(qcar(w)); nn!=nil; nn=qcdr(nn)) { n = qcar(nn); if (!is_vector(n) || vechdr(n) != h) continue; if (memcmp((char *)name + (CELL-TAG_VECTOR), (char *)n + (CELL-TAG_VECTOR), (size_t)len) == 0) return onevalue(qcar(w)); } } return onevalue(nil); } Lisp_Object find_package(char *name, int len) /* * This is like Lfind_package but takes a C string as its arg. Note that * this can not cause garbage collection or return an error, so is safe to * call from the middle of other things... */ { Lisp_Object w, nil = C_nil; for (w = all_packages; w!=nil; w=qcdr(w)) { Lisp_Object nn, n = packname_(qcar(w)); if (is_vector(n) && length_of_header(vechdr(n))==(unsigned32)(len+CELL) && memcmp(name, (char *)n + (CELL-TAG_VECTOR), (size_t)len) == 0) return qcar(w); for (nn = packnick_(qcar(w)); nn!=nil; nn=qcdr(nn)) { n = qcar(nn); if (!is_vector(n) || length_of_header(vechdr(n)) != (unsigned32)(len+CELL)) continue; if (memcmp(name, (char *)n + (CELL-TAG_VECTOR), (size_t)len) == 0) return qcar(w); } } return nil; } static Lisp_Object Luse_package(Lisp_Object nil, Lisp_Object uses, Lisp_Object pkg) { CSL_IGNORE(nil); push(uses); pkg = Lfind_package(nil, pkg); pop(uses); errexit(); if (pkg == nil) return onevalue(nil); if (consp(uses)) { while (consp(uses)) { push2(uses, pkg); Luse_package(nil, qcar(uses), pkg); errexitn(2); pop2(pkg, uses); uses = qcdr(uses); } } else { Lisp_Object w, w1; push(pkg); uses = Lfind_package(nil, uses); pop(pkg); errexit(); if (uses == nil || uses == pkg) return onevalue(nil); push2(pkg, uses); /* * Around here I am supposed to do a large-scale check to ensure that there * are no unexpected name conflicts between the packages that are being * worked linked. */ w = cons(uses, packuses_(pkg)); errexitn(2); uses = stack[0]; pkg = stack[-1]; push(w); w1 = cons(pkg, packused_(uses)); errexitn(3); pop3(w, uses, pkg); packuses_(pkg) = w; packused_(uses) = w1; } return onevalue(lisp_true); } static Lisp_Object MS_CDECL Lmake_package(Lisp_Object nil, int nargs, ...) { Lisp_Object name, nicknames = nil, uses = nil, w = nil, k; CSLbool has_use = NO; va_list a; int i; if (nargs == 0) return aerror("make-package"); /* * First I scan the arguments - there may be a lot of them - looking for * any relevant keyword parameters */ va_start(a, nargs); push_args(a, nargs); name = stack[1-nargs]; if ((nargs & 1) == 0) { popv(1); nargs--; } for (i=1; i<nargs; i+=2) { pop2(k, w); if (w == nicknames_symbol) nicknames = k; else if (w == use_symbol) has_use = YES, uses = k; } popv(1); /* * I provide a default value for the ":use" argument */ if (!has_use) { push2(name, nicknames); uses = make_string("LISP"); errexitn(2); uses = ncons(uses); errexitn(2); pop2(nicknames, name); } push2(uses, nicknames); /* * Now I need to ensure that the name I had for the package is * a string... */ name = want_a_string(name); errexitn(2); push(name); w = Lfind_package(nil, name); pop(name); errexitn(2); /* * It is SUPPOSED to be a continuable error if the package already exists. * For the present I will just display a message and keep going. */ if (w != nil) { popv(2); err_printf("\n+++++ package already exists: "); prin_to_error(name); err_printf("\n"); return onevalue(w); } /* * The package does not exist yet - so I will make one... */ name = make_package(name); errexitn(2); /* * ensure that NICKNAMES is a list of strings... */ uses = nil; while (consp(stack[0])) { w = stack[0]; push(uses); w = want_a_string(qcar(w)); errexitn(3); pop(uses); uses = cons(w, uses); errexitn(2); stack[0] = qcdr(stack[0]); } nicknames = nil; while (uses != nil) { w = uses; uses = qcdr(w); qcdr(w) = nicknames; nicknames = w; } popv(1); packnick_(name) = nicknames; uses = stack[0]; stack[0] = name; Luse_package(nil, uses, name); errexitn(1); pop(name); return onevalue(name); } static Lisp_Object Lmake_package_2(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { return Lmake_package(nil, 2, a, b); } static Lisp_Object Lmake_package_1(Lisp_Object nil, Lisp_Object a) { return Lmake_package(nil, 1, a); } static Lisp_Object MS_CDECL Llist_all_packages(Lisp_Object nil, int nargs, ...) { CSL_IGNORE(nargs); CSL_IGNORE(nil); return onevalue(all_packages); } #endif Lisp_Object MS_CDECL Ltyi(Lisp_Object nil, int nargs, ...) { int ch; argcheck(nargs, 0, "tyi"); if (curchar == NOT_CHAR) { Lisp_Object stream = qvalue(standard_input); if (!is_stream(stream)) stream = qvalue(terminal_io); if (!is_stream(stream)) stream = lisp_terminal_io; ch = getc_stream(stream); errexit(); } else { ch = curchar; curchar = NOT_CHAR; } if (ch == EOF || ch == CTRL_D) return onevalue(CHAR_EOF); #ifdef Kanji return onevalue(pack_char(0, 0, ch & 0xffff)); #else return onevalue(pack_char(0, 0, ch & 0xff)); #endif } Lisp_Object Lreadch1(Lisp_Object nil, Lisp_Object stream) { Lisp_Object w; int ch; if (!is_stream(stream)) stream = qvalue(terminal_io); if (!is_stream(stream)) stream = lisp_terminal_io; ch = getc_stream(stream); errexit(); if (ch == EOF || ch == CTRL_D) w = CHAR_EOF; else { if (qvalue(lower_symbol) != nil) ch = TOlower(ch); else if (qvalue(raise_symbol) != nil) ch = TOupper(ch); #ifdef Kanji if (qvalue(hankaku_symbol) != nil) is (iszenkaku(curchar)) curchar = tohankaku(curchar); if (iswchar(ch)) { boffo_char(0) = ch >> 8; boffo_char(1) = ch; w = iintern(boffo, 2, lisp_package, 1); errexit(); } else { w = elt(charvec, ch & 0xff); if (w == nil) { boffo_char(0) = ch; /* NB I always want to intern in the LISP package here */ w = iintern(boffo, 1, lisp_package, 0); errexit(); elt(charvec, ch & 0xff) = w; } } #else w = elt(charvec, ch & 0xff); if (w == nil) { boffo_char(0) = ch; /* NB I always want to intern in the LISP package here */ w = iintern(boffo, 1, lisp_package, 0); errexit(); elt(charvec, ch & 0xff) = w; } #endif } return onevalue(w); } Lisp_Object MS_CDECL Lreadch(Lisp_Object nil, int nargs, ...) { argcheck(nargs, 0, "readch"); return Lreadch1(nil, qvalue(standard_input)); } Lisp_Object Lpeekch2(Lisp_Object nil, Lisp_Object type, Lisp_Object stream) { Lisp_Object w; int ch; if (!is_stream(stream)) stream = qvalue(terminal_io); if (!is_stream(stream)) stream = lisp_terminal_io; if (type != nil) { do { ch = getc_stream(stream); errexit(); } while (ISspace(ch)); } else { ch = getc_stream(stream); errexit(); } other_read_action(ch, stream); errexit(); if (ch == EOF || ch == CTRL_D) w = CHAR_EOF; else { if (qvalue(lower_symbol) != nil) ch = TOlower(ch); else if (qvalue(raise_symbol) != nil) ch = TOupper(ch); #ifdef Kanji if (qvalue(hankaku_symbol) != nil) is (iszenkaku(curchar)) curchar = tohankaku(curchar); if (iswchar(curchar)) { boffo_char(0) = curchar >> 8; boffo_char(1) = curchar; w = iintern(boffo, 2, lisp_package, 0); errexit(); } else { w = elt(charvec, ch & 0xff); if (w == nil) { boffo_char(0) = ch; /* NB I always want to intern in the LISP package here */ w = iintern(boffo, 1, lisp_package, 0); errexit(); elt(charvec, ch & 0xff) = w; } } #else w = elt(charvec, ch & 0xff); if (w == nil) { boffo_char(0) = ch; /* NB I always want to intern in the LISP package here */ w = iintern(boffo, 1, lisp_package, 0); errexit(); elt(charvec, ch & 0xff) = w; } #endif } return onevalue(w); } Lisp_Object Lpeekch1(Lisp_Object nil, Lisp_Object type) { return Lpeekch2(nil, type, qvalue(standard_input)); } Lisp_Object MS_CDECL Lpeekch(Lisp_Object nil, int nargs, ...) { argcheck(nargs, 0, "peekch"); return Lpeekch2(nil, nil, qvalue(standard_input)); } Lisp_Object Lunreadch2(Lisp_Object nil, Lisp_Object a, Lisp_Object stream) { int ch; CSL_IGNORE(nil); if (!is_stream(stream)) stream = qvalue(terminal_io); if (!is_stream(stream)) stream = lisp_terminal_io; if (a == CHAR_EOF) ch = EOF; else { if (is_symbol(a)) a = pack_char(0, 0, first_char(a)); ch = (char)code_of_char(a); } other_read_action(ch, stream); return onevalue(a); } Lisp_Object Lunreadch(Lisp_Object nil, Lisp_Object a) { return Lunreadch2(nil, a, qvalue(standard_input)); } Lisp_Object Lreadline1(Lisp_Object nil, Lisp_Object stream) { Lisp_Object w; int ch, n = 0, k; char *s; if (!is_stream(stream)) stream = qvalue(terminal_io); if (!is_stream(stream)) stream = lisp_terminal_io; boffop = 0; while ((ch = getc_stream(stream)) != EOF && ch != '\n') { errexit(); packbyte(ch); n++; } errexit(); if (ch == EOF && n == 0) w = CHAR_EOF; else { w = getvector(TAG_VECTOR, TYPE_STRING, CELL+n); errexit(); s = (char *)w - TAG_VECTOR; k = (n + 3) & ~7; *(int32 *)(s + k + 4) = 0; if (k != 0) *(int32 *)(s + k) = 0; s = s + 4; memcpy(s, &boffo_char(0), n); } #ifdef COMMON mv_2 = Lispify_predicate(ch == EOF); #endif return nvalues(w, 2); } Lisp_Object MS_CDECL Lreadline(Lisp_Object nil, int nargs, ...) { argcheck(nargs, 0, "readline"); return Lreadline1(nil, qvalue(standard_input)); } setup_type const read_setup[] = { {"batchp", wrong_no_na, wrong_no_nb, Lbatchp}, {"rseek", Lrseek, Lrseek_2, wrong_no_1}, #ifdef COMMON {"rseekend", Lrseekend, too_many_1, wrong_no_1}, #endif {"rtell", Lrtell_1, wrong_no_nb, Lrtell}, {"gensym1", Lgensym1, too_many_1, wrong_no_1}, {"gensym2", Lgensym2, too_many_1, wrong_no_1}, {"gensymp", Lgensymp, too_many_1, wrong_no_1}, {"getenv", Lgetenv, too_many_1, wrong_no_1}, {"orderp", too_few_2, Lorderp, wrong_no_2}, {"rdf", Lrdf1, Lrdf2, Lrdfn}, {"rds", Lrds, too_many_1, wrong_no_1}, {"peekch", Lpeekch1, Lpeekch2, Lpeekch}, {"readch", Lreadch1, wrong_no_nb, Lreadch}, {"unreadch", Lunreadch, Lunreadch2, wrong_no_1}, {"readline", Lreadline1, wrong_no_nb, Lreadline}, {"setpchar", Lsetpchar, too_many_1, wrong_no_1}, {"spool", Lspool, too_many_1, Lspool0}, {"system", Lsystem, too_many_1, wrong_no_1}, {"~tyi", wrong_no_na, wrong_no_nb, Ltyi}, {"list-to-string", Llist_to_string, too_many_1, wrong_no_1}, {"list-to-symbol", Llist_to_symbol, too_many_1, wrong_no_1}, {"where-was-that", wrong_no_na, wrong_no_nb, Lwhere_was_that}, #ifdef COMMON {"compress1", Lcompress, too_many_1, wrong_no_1}, {"dribble", Lspool, too_many_1, Lspool0}, {"read", Lread_1, wrong_no_nb, Lread}, {"intern", Lintern, Lintern_2, wrong_no_1}, {"gensym", Lgensym1, wrong_no_nb, Lgensym}, {"extern", Lextern_1, Lextern, wrong_no_1}, {"import*", Limport_1, Limport, wrong_no_1}, {"find-symbol", Lfind_symbol_1, Lfind_symbol, wrong_no_1}, {"keywordp", Lkeywordp, too_many_1, wrong_no_1}, {"find-package", Lfind_package, too_many_1, wrong_no_1}, {"make-package", Lmake_package_1, Lmake_package_2, Lmake_package}, {"use-package*", too_few_2, Luse_package, wrong_no_2}, {"list-all-packages", wrong_no_na, wrong_no_nb, Llist_all_packages}, {"make-symbol", Lmake_symbol, too_many_1, wrong_no_1}, {"unintern", Lunintern, Lunintern_2, wrong_no_1}, #else {"compress", Lcompress, too_many_1, wrong_no_1}, {"read", wrong_no_na, wrong_no_nb, Lread}, {"intern", Lintern, too_many_1, wrong_no_1}, {"gensym", Lgensym1, wrong_no_nb, Lgensym}, {"ordp", too_few_2, Lorderp, wrong_no_2}, {"remob", Lunintern, too_many_1, wrong_no_1}, #endif {NULL, 0, 0, 0} }; /* end of read.c */