reduce-historical/r36/cslbase/read.c

/* 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 */