reduce-historical/r36/cslbase/restart.c

/*  restart.c                       Copyright (C) 1989-1999 Codemist Ltd */

/*
 * Code needed to start off Lisp when no initial heap image is available,
 * or to re-instate links between heap and C-coded core if there IS a
 * heap loaded.  This code is run in a state that is in effect (in-package
 * "lisp").
 */

/* Signature: 2c97b73c 07-Mar-2000 */

#include <stdarg.h>
#include <string.h>
#include <ctype.h>
#include <float.h>

#include "machine.h"
#include "version.h"
#include "tags.h"
#include "cslerror.h"
#include "externs.h"
#include "read.h"
#include "stream.h"
#include "arith.h"
#include "entries.h"
#ifdef TIMEOUT
#include "timeout.h"
#endif

#ifdef ADDRESS_SIGN_UNKNOWN
int32 address_sign;
#endif

Lisp_Object C_nil;
Lisp_Object *stackbase;

Lisp_Object *nilsegment;
Lisp_Object *stacksegment;
int32 stack_segsize = 1;

char *exit_charvec = NULL;

#ifdef NILSEG_EXTERNS

unsigned32 byteflip;
Lisp_Object codefringe;
Lisp_Object volatile codelimit;
Lisp_Object * volatile stacklimit;
Lisp_Object fringe;
Lisp_Object volatile heaplimit;
Lisp_Object volatile vheaplimit;
Lisp_Object vfringe;
int32 nwork;
int32 exit_reason;
int32 exit_count;
unsigned32 gensym_ser, print_precision, miscflags;
int32 current_modulus, fastget_size, package_bits;
Lisp_Object lisp_true, lambda, funarg, unset_var, opt_key, rest_key;
Lisp_Object quote_symbol, function_symbol, comma_symbol, comma_at_symbol;
Lisp_Object cons_symbol, eval_symbol, work_symbol, evalhook, applyhook;
Lisp_Object macroexpand_hook, append_symbol, exit_tag;
Lisp_Object exit_value, catch_tags;
#ifdef COMMON
Lisp_Object keyword_package;
#endif
Lisp_Object current_package;
Lisp_Object startfn;
#ifdef COMMON
Lisp_Object all_packages, package_symbol, internal_symbol;
Lisp_Object external_symbol, inherited_symbol;
#endif
Lisp_Object gensym_base, string_char_sym, boffo;
#ifdef COMMON
Lisp_Object key_key, allow_other_keys, aux_key;
#endif
Lisp_Object err_table;
#ifdef COMMON
Lisp_Object format_symbol;
#endif
Lisp_Object progn_symbol;
#ifdef COMMON
Lisp_Object expand_def_symbol, allow_key_key, declare_symbol, special_symbol;
#endif
Lisp_Object lisp_work_stream, charvec, raise_symbol, lower_symbol, echo_symbol;
Lisp_Object codevec, litvec, supervisor, B_reg, savedef, comp_symbol;
Lisp_Object compiler_symbol, faslvec, tracedfn, lisp_terminal_io;
Lisp_Object lisp_standard_output, lisp_standard_input, lisp_error_output;
Lisp_Object lisp_trace_output, lisp_debug_io, lisp_query_io;
Lisp_Object prompt_thing, faslgensyms, prinl_symbol, emsg_star, redef_msg;
Lisp_Object expr_symbol, fexpr_symbol, macro_symbol;
Lisp_Object cl_symbols, active_stream, current_module;
Lisp_Object features_symbol, lisp_package, sys_hash_table;
Lisp_Object help_index, cfunarg, lex_words, get_counts, fastget_names;
Lisp_Object input_libraries, output_library, current_file, break_function;
Lisp_Object standard_output, standard_input, debug_io;
Lisp_Object error_output, query_io, terminal_io, trace_output, fasl_stream;
Lisp_Object native_code, native_symbol, traceprint_symbol, loadsource_symbol;
Lisp_Object hankaku_symbol;
Lisp_Object workbase[51];

#endif

Lisp_Object user_base_0, user_base_1, user_base_2, user_base_3, user_base_4;
Lisp_Object user_base_5, user_base_6, user_base_7, user_base_8, user_base_9;

Lisp_Object eq_hash_tables, equal_hash_tables;

/*
 * On an Intel 80x86 (because I am almost forced to) and on other machines
 * (much more cheerfully, and for choice!) I will arrange my memory as
 * a number of pages.  A general pool of these pages gets used
 * to satisfy requests for heap, vector heap and BPS space.  Running
 * under the Phar Lap 286 DOS extender in protected mode it seemed that
 * all segments returned by malloc() will have their top bit (when punned
 * as a long int) zero.  Thus even on an 80x86 I could make progress..
 * Ditto under the Zortech (Rational Systems) 80286 extender.  Win32
 * (Windows NT) seems OK too, but Win32s has given me pointers with
 * their top bit set... Ugh!  For the 80286 and small machines the pages
 * will be just 64 Kbytes - for larger machines I will make them a bit
 * bigger (typically 256 Kbytes).  See PAGE_BITS in machine.h.
 *
 * Since this code was first written it has become silly to even consider
 * computers with 16-bit segmented addressing! It is still convenient to
 * allocate memory in chunks, although that does set an upper limit to the
 * size of any individual object: this may hurt if a user wants a big vector
 * and it does constrain the range of big-numbers supported by the
 * artithmetic.
 */

void **pages,
     **heap_pages,
     **vheap_pages,
     **bps_pages,
     **native_pages;
#ifndef NO_COPYING_GC
void **new_heap_pages,
     **new_vheap_pages,
     **new_bps_pages,
     **new_native_pages;
#endif
int32 pages_count,
      heap_pages_count,
      vheap_pages_count,
      bps_pages_count,
      native_pages_count;
#ifndef NO_COPYING_GC
int32 new_heap_pages_count,
      new_vheap_pages_count,
      new_bps_pages_count,
      new_native_pages_count;
#endif

char program_name[64] = {0};

#ifndef COMMON
#ifdef CWIN
/*
 * Could be useful for other windowed systems.
 */
char **loadable_packages, **switches;
#endif
#endif

int native_code_tag;
int native_pages_changed;
int32 native_fringe;
int current_fp_rep;
static int old_fp_rep;
static CSLbool flip_needed;
static int old_page_bits;

/*
 * The next function is handed a page
 * of hard code that has just been loaded into memory and it must scan it
 * performing all relevant relocation. fringe give the offset within the
 * page that is the first byte not in use. The first 4 bytes of the page
 * are reserved for storing fringe from one run to the next. The exact
 * format of the rest must be sufficient to allow this code to scan
 * and correct the code, but thus far I have not defined it, and it will
 * anyway tend to need extension each time a new target architecture is
 * incorporated (to support the new and curious relocation modes tha the
 * new machine requires).
 */

static void relocate_native_code(unsigned char *p, int32 n)
{
/*
 * One helpful observation here. In pretty well all other parts of CSL
 * there is a possibility that an image file created on one computer will
 * be reloaded on another and so all the code is ultra-careful to avoid
 * sensitivity to byte order etc etc issues. But here the native code that
 * is being loaded MUST have been created using the conventions of the
 * current computer (otherwise I should not be loading it and I will be
 * in huge trouble when I try to execute code from it). So direct and
 * simple access to data is legitimate.
 */
    int32 k = 8;
    term_printf("Native code page type %d size %d to be relocated\n",
        native_code_tag, n);
    while (k <= n)
    {   unsigned char *block = p + k;
        int32 len = *(int32 *)block;
        term_printf("Block of %d bytes found\n", len);
        if (len == 0)
        {   term_printf("End of native page reached\n");
            break;
        }
        relocate_native_function(block);
        k += len;
    }
}

void relocate_native_function(unsigned char *bps)
{
/*
 * Each chunk of memory allocated by make-native will have its length (in
 * bytes) in its first 32-bit word. Next comes the offset of the
 * start of real code in the block. Just after that there will be a
 * hunk of relocation information. The code proper must not start until
 * after the relocation records. Relocation information is stored in the
 * following format as a sequence of bytes:
 *         0                 end of relocation information.
 *         1 to 170/xx       encode a value 0 to 169
 *         171 to 255/xx/yy  extra byte yy extends following offset xx, and
 *                           its top bit is used to extend opcode to range
 *                           0 to 169.
 * The opcode now in the range 0 to 169 is interpreted as
 *         169            no operation
 *         otherwise (0-12)*(0-12) as target*mode
 */
   unsigned char *r = bps + 4;
   unsigned char *next;
   int32 n;
   int code;
   n = *r++;          /* code start offset in LSB format */
   n |= (*r++) << 8;
   n |= (*r++) << 16;
   n |= (*r++) << 24;
   next = bps + n;
#define RELOC_END           0
    while ((code = *r++) != RELOC_END)
    {   int32 off = *r++;
        unsigned char *target;
/*
 * A native compiler will have to generate a sequence of bytes that adhere to
 * the contorted format used here.
 */
        if (code <= 170) code--;
        else
        {   int off1 = *r++;
            code = 2*(code-171) + (off1 >> 7);
            off = off | ((off1 & 0x7f) << 8);
        }
        next += off;   /* address where next relocation is to be applied */
#define RELOC_NOP           169
/*
 * One might like to note that with a long offset the NOP opcode turns into
 * an opcode byte 0xff. And if it then has the longest possible offset one]
 * gets the 3-byte sequence 0xff/0xff/0xff.
 */
        if (code == RELOC_NOP) continue;

#define RELOC_0_ARGS        0
#define RELOC_1_ARGS        1
#define RELOC_2_ARGS        2
#define RELOC_3_ARGS        3
#define RELOC_DIRECT_ENTRY  4
#define RELOC_VAR           5
#define RELOC_SELF_1        6
#define RELOC_SELF_2        7
        switch (code % 13)
        {
    default:
            term_printf("Illegal relocation byte %.2x\n", code);
            my_exit(EXIT_FAILURE);
    case RELOC_SELF_1:
/*
 * base of current native code block with an 8-bit offset.
 */
            target = bps + *r++;
            break;
    case RELOC_SELF_2:
/*
 * base of current native code block with 15 or 23-bit offset. The first byte
 * is the low 8-bits of the offset. The next is the next 7 bits, with its
 * 0x80 bit selecting whether a third byte is needed (which it will hardly
 * ever be).
 */
            off = *r++;
            off = off + (*r++ << 8);
            if (off & 0x8000) off = (off & 0x7fff) + (*r++ << 15);
            target = bps + off;
            break;
    case RELOC_0_ARGS:
/*
 * The next few relocation modes provide access to the C entrypoints
 * associated with a medium number of Lisp functions. The tables and
 * offsets used are documented in file "eval4.c" and are as used with the
 * byte-code compiler.
 */
            target = (unsigned char *)zero_arg_functions[*r++];
            break;
    case RELOC_1_ARGS:
            target = (unsigned char *)one_arg_functions[*r++];
            break;
    case RELOC_2_ARGS:
            target = (unsigned char *)two_arg_functions[*r++];
            break;
    case RELOC_3_ARGS:
            target = (unsigned char *)three_arg_functions[*r++];
            break;
    case RELOC_DIRECT_ENTRY:
/*
 * There are some entrypoints into the CSL kernel that are not
 * called using the usual Lisp conventions but are at a lower-level.
 * A selection of these are visible via the table "useful_functions"
 * in file fns3.c. This table can be extended if a native-mode compiler
 * needs access to any other speciality.
 */
            target = (unsigned char *)useful_functions[*r++];
            break;
    case RELOC_VAR:
/*
 * The function address_f_var (in fns3.c) returns the address of a Lisp
 * internal variable. See there for the numeric encoding used and what can
 * be accessed.
 */
            target = (unsigned char *)address_of_var(*r++);
            break;
        }

#define RELMODE_ABSOLUTE     0
#define RELMODE_RELATIVE     1
#define RELMODE_REL_PLUS_4   2
#define RELMODE_REL_MINUS_2  3
#define RELMODE_REL_MINUS_4  4
#define RELMODE_REL_OFFSET   5
#define RELMODE_SPARE1       6
#define RELMODE_SPARE2       7

        switch (code/13)
        {
    default:
            term_printf("Illegal relocation byte %.2x\n", code);
            my_exit(EXIT_FAILURE);
    case RELMODE_ABSOLUTE:
/*
 * relocate by pointing a 32-bit value directly at the absolute address
 * of the target.
 */
            *(int32 *)next = (int32)target;
            break;
    case RELMODE_RELATIVE:
/*
 * relocate by setting a 32-bit value of the offset from its own first
 * byte to the target.
 */
            *(int32 *)next = (int32)target - (int32)next;
            break;
    case RELMODE_REL_PLUS_4:
/*
 * relocate by setting a 32-bit value of the offset from the start of the
 * word after it.
 */
            *(int32 *)next = (int32)target - ((int32)next + 4);
            break;
    case RELMODE_REL_MINUS_2:
/*
 * relocate by setting a 32-bit value of the offset from the address 2 bytes
 * before its start. This may be used on machines where the relative address
 * is computed based on the start of the instruction rather than the start of
 * the field within the instruction that contains the offset.
 */
            *(int32 *)next = (int32)target - ((int32)next - 2);
            break;
    case RELMODE_REL_MINUS_4:
/*
 * relocate by setting a 32-bit value of the offset from the address 4 bytes
 * before its start. This may be used on machines where the relative address
 * is computed based on the start of the instruction rather than the start of
 * the field within the instruction that contains the offset.
 */
            *(int32 *)next = (int32)target - ((int32)next - 4);
            break;
    case RELMODE_REL_OFFSET:
/*
 * relocate by setting a 32-bit value of the offset from some place
 * offset using an 8-bit signed value from the start of the address. The
 * offset represents the number of bytes after the start of the address
 * that is to be used in the calculation. Note that the special values
 * -4, -2, 0 and 4 need never be used here because there are special
 * relocation modes for those common cases.
 */
            code = *r++;
            if (code & 0x80) code |= ~0xff; /* Sign extend */
            *(int32 *)next = (int32)target - ((int32)next + code);
            break;
        }
    } 
}

static int32 fread_count;
static unsigned char *fread_ptr;

#ifdef SIXTEEN_BIT
#define FREAD_BUFFER_SIZE 0x4000    /* 16 Kbytes of buffer */
#else
#define FREAD_BUFFER_SIZE 0xc000    /* 48 Kbytes of buffer */
#endif

static unsigned char *pair_c, *char_stack;
static unsigned short int *pair_prev;

static void Cfread(char *p, int32 n)
{
/*
 * The decompression process does not need hashed access to see if
 * character-pairs have been seen before, but it can need a stack to
 * unwind codes that have very lengthy expansions.
 */
    int c1, k;
    unsigned int prev, c, next_code;
    int32 count = fread_count;
    unsigned char *ptr = fread_ptr;
    if (n < compression_worth_while)
    {
#ifdef MAYBE_AVOID_A_DATA_COPY_OPERATION
        if (n > count)
        {   memcpy(p, ptr, (size_t)count);
            p += count;
            n -= count;
        }
        while (n >= FREAD_BUFFER_SIZE)
        {   count = Iread((unsigned char *)p, FREAD_BUFFER_SIZE);
            p += count;
            n -= count;
        }
/*
 * Here I believe that I am in the clear using the (Lisp) stack as
 * a buffer area. This is because Cfread is only used to read heap images,
 * and when such an image is being loaded the contents of the old one
 * (including the stack) are not too relevant.
 */
        ptr = (unsigned char *)stack;
        count = Iread(ptr, FREAD_BUFFER_SIZE);
#endif
        while (n > count)
        {   memcpy(p, ptr, (size_t)count);
            p += count;
            n -= count;
            ptr = (unsigned char *)stack;
            count = Iread(ptr, FREAD_BUFFER_SIZE);
        }
        if (n != 0)
        {   memcpy(p, ptr, (size_t)n);
            ptr += n;
            count -= n;
        }
        fread_count = count;
        fread_ptr = ptr;
        return;
    }

    next_code = 256;

    if (count == 0)
    {   ptr = (unsigned char *)stack;
        count = Iread(ptr, FREAD_BUFFER_SIZE);
    }
    c = *ptr++;
    count--;

    if (count == 0)
    {   ptr = (unsigned char *)stack;
        count = Iread(ptr, FREAD_BUFFER_SIZE);
    }
    c = (c << 8) | *ptr++;
    count--;

    prev = c >> 4;
    *p++ = (char)prev;    /* The first character is not compressed */
    n--;

    while (n > 0)
    {   if (count == 0)
        {   ptr = (unsigned char *)stack;
            count = Iread(ptr, FREAD_BUFFER_SIZE);
        }
        c = ((c & 0xf) << 8) | *ptr++;
        count--;
/*
 * Decode the next 12 bit character
 */
        c1 = c;
        k = 1;
        while (c1 >= 256)
        {   char_stack[k++] = pair_c[c1];
            if (pair_prev[c1] > CODESIZE || k >= CODESIZE)
            {   term_printf("Bad decoded char %x -> %x, k=%d\n", c1, pair_prev[c1], k);
                my_exit(EXIT_FAILURE);
            }
            c1 = pair_prev[c1];
        }
/*
 * Write the decoded stuff into the output array.
 */
        n -= k;
        *p++ = (char)c1;
        while (k != 1)
        {   *p++ = char_stack[--k];
        }
/*
 * ... then build up the decoding tables ready for next time.  Of course
 * the table building in this decoder MUST exactly match the behaviour of
 * the compression code above.
 */
        if (next_code >= CODESIZE) next_code = 256;
        else
        {   pair_prev[next_code] = (unsigned short int)prev;
            pair_c[next_code] = c1;
            next_code++;
        }
        prev = c;

        if (n <= 0) break;

/*
 * read the next 12 bit character.
 */
        if (count == 0)
        {   ptr = (unsigned char *)stack;
            count = Iread(ptr, FREAD_BUFFER_SIZE);
        }
        c = *ptr++;
        count--;
        if (count == 0)
        {   ptr = (unsigned char *)stack;
            count = Iread(ptr, FREAD_BUFFER_SIZE);
        }
        c = (c << 8) | *ptr++;
        count--;
/*
 * Decode it...
 */
        c1 = c >> 4;
        k = 1;
        while (c1 >= 256)
        {   char_stack[k++] = pair_c[c1];
            if (pair_prev[c1] > CODESIZE || k >= CODESIZE)
            {   term_printf("Bad decoded char %x -> %x, k=%d\n", c1, pair_prev[c1], k);
                my_exit(EXIT_FAILURE);
            }
            c1 = pair_prev[c1];
        }
/*
 * Write the decoded stuff into the output array.
 */
        n -= k;
        *p++ = (char)c1;
        while (k != 1)
        {   *p++ = char_stack[--k];
        }
/*
 * ... then build up the decoding tables ready for next time.  Of course
 * the table building in this decoder MUST exactly match the behaviour of
 * the compression code above.
 */
        if (next_code >= CODESIZE) next_code = 256;
        else
        {   pair_prev[next_code] = (unsigned short int)prev;
            pair_c[next_code] = c1;
            next_code++;
        }
        prev = c >> 4;
    }
    fread_count = count;
    fread_ptr = ptr;
}

#define flip_bytes(a) (flip_needed ? flip_bytes_fn(a) : (a))

static unsigned32 flip_bytes_fn(unsigned32 x)
{
    unsigned32 b0, b1, b2, b3;
    b0 = (x >> 24) & 0xffU;
    b1 = (x >> 8) & 0xff00U;
    b2 = (x << 8) & 0xff0000U;
    b3 = (x << 24) & 0xff000000U;
    return b0 | b1 | b2 | b3;
}

#define flip_halfwords(a) (flip_needed ? flip_halfwords_fn(a) : (a))

static unsigned32 flip_halfwords_fn(unsigned32 x)
{
    unsigned32 b0, b1, b2, b3;
    b0 = (x >> 8) & 0xffU;
    b1 = (x << 8) & 0xff00U;
    b2 = (x >> 8) & 0xff0000U;
    b3 = (x << 8) & 0xff000000U;
    return b0 | b1 | b2 | b3;
}

void convert_fp_rep(void *p, int old_rep, int new_rep, int type)
{
    unsigned32 *f = (unsigned32 *)p;
    if (old_rep == new_rep) return;
/*
 * type == 0 for sfloat, 1 for single float, 2 for double and 3 for extended.
 * in CSL mode only case 2 can arise.
 */
/*
 * At present conversions involving IBM370 or VAX representations are not
 * supported, i.e. only IEEE floating point units are allowed for.
 * Extended mode is not implemented yet... i.e. I only really expect
 * to be using (64-bit) double precision floating point values.
 */
    if (type >= 2 && ((old_rep ^ new_rep) & FP_WORD_ORDER))
    {   unsigned32 w = f[0];
        f[0] = f[1];
        f[1] = w;
    }
    if ((old_rep ^ new_rep) & FP_BYTE_ORDER)
    {   f[0] = flip_bytes_fn(f[0]);
        if (type >= 2) f[1] = flip_bytes_fn(f[1]);
    }
    if ((old_rep|new_rep) & (FP_VAXREP|FP_IBMREP))
    {   term_printf(
        "\n+++ This cross-floating representation conversion not supported\n");
/*
 * I have not implemented conversions that involve VAX or s/370 representations
 */
        my_exit(EXIT_FAILURE);
    }
    return;
}

static void adjust(Lisp_Object *cp)
/*
 * If p is a pointer to an object that has moved, adjust it.
 */
{
    Lisp_Object nil = C_nil, p = flip_bytes(*cp);
    if  (p == SPID_NIL) *cp = nil;
    else if (is_cons(p))
    {   int32 h = (int32)heap_pages[(p>>PAGE_BITS) & PAGE_MASK];
        *cp = (Lisp_Object)((char *)doubleword_align_up(h) +
                            (p & OFFSET_MASK));
    }
    else if (is_immed_or_cons(p))
    {
#ifdef COMMON
        if (is_sfloat(p))
        {   int32 w = flip_bytes(p);    /* delicate here!! */
            convert_fp_rep((void *)&w, old_fp_rep, current_fp_rep, 0);
            *cp = w;
        }
#endif
        *cp = p;   /* Immediate data here */
    }
    else
    {   int32 h = (int32)vheap_pages[(p>>PAGE_BITS) & PAGE_MASK];
        *cp = (Lisp_Object)((char *)doubleword_align_up(h) +
                            (p & OFFSET_MASK));
    }
}

static void adjust_consheap(void)
{
    nil_as_base
    int32 page_number;
    for (page_number = 0; page_number < heap_pages_count; page_number++)
    {   void *page = heap_pages[page_number];
        char *low = (char *)doubleword_align_up((int32)page);
        char *start = low + CSL_PAGE_SIZE;
        int32 len = flip_bytes(qcar(low));
        char *fr;
        qcar(low) = len;
        fr = low + len;
        fringe = (Lisp_Object)fr;
        heaplimit = (Lisp_Object)(low + SPARE);
        while (fr < start)
        {   adjust((Lisp_Object *)fr);
            fr += sizeof(Lisp_Object);
        }
    }
}

entry_point entries_table[] =
{
/*
 * All values that can go in the function cells of symbols to stand for
 * special interpreter activity are kept here. In most cases where there
 * is an entrypoint there is a corresponding one that behaves just the
 * same except that it has tracing enabled.
 */
    {0,                                          "xillegal"},
    {(void *)undefined1,                         "1undefined1"},
    {(void *)undefined2,                         "2undefined2"},
    {(void *)undefinedn,                         "nundefinedn"},
    {(void *)autoload1,                          "1autoload1"},
    {(void *)autoload2,                          "2autoload2"},
    {(void *)autoloadn,                          "nautoloadn"},
    {(void *)interpreted1,                       "1interpreted1"},
    {(void *)traceinterpreted1,                  "1traceinterpreted1"},
    {(void *)double_interpreted1,                "1double_interpreted1"},
    {(void *)interpreted2,                       "2interpreted2"},
    {(void *)traceinterpreted2,                  "2traceinterpreted2"},
    {(void *)double_interpreted2,                "2double_interpreted2"},
    {(void *)interpretedn,                       "ninterpretedn"},
    {(void *)traceinterpretedn,                  "ntraceinterpretedn"},
    {(void *)double_interpretedn,                "ndouble_interpretedn"},
    {(void *)funarged1,                          "1funarged1"},
    {(void *)tracefunarged1,                     "1tracefunarged1"},
    {(void *)double_funarged1,                   "1double_funarged1"},
    {(void *)funarged2,                          "2funarged2"},
    {(void *)tracefunarged2,                     "2tracefunarged2"},
    {(void *)double_funarged2,                   "2double_funarged2"},
    {(void *)funargedn,                          "nfunargedn"},
    {(void *)tracefunargedn,                     "ntracefunargedn"},
    {(void *)double_funargedn,                   "ndouble_funargedn"},
    {(void *)bytecoded0,                         "nbytecoded0"},
    {(void *)tracebytecoded0,                    "ntracebytecoded0"},
    {(void *)double_bytecoded0,                  "ndouble_bytecoded0"},
    {(void *)bytecoded1,                         "1bytecoded1"},
    {(void *)tracebytecoded1,                    "1tracebytecoded1"},
    {(void *)double_bytecoded1,                  "1double_bytecoded1"},
    {(void *)bytecoded2,                         "2bytecoded2"},
    {(void *)tracebytecoded2,                    "2tracebytecoded2"},
    {(void *)double_bytecoded2,                  "2double_bytecoded2"},
    {(void *)bytecoded3,                         "nbytecoded3"},
    {(void *)tracebytecoded3,                    "ntracebytecoded3"},
    {(void *)double_bytecoded3,                  "ndouble_bytecoded3"},
    {(void *)bytecodedn,                         "nbytecodedn"},
    {(void *)tracebytecodedn,                    "ntracebytecodedn"},
    {(void *)double_bytecodedn,                  "ndouble_bytecodedn"},
    {(void *)byteopt1,                           "1byteopt1"},
    {(void *)tracebyteopt1,                      "1tracebyteopt1"},
    {(void *)double_byteopt1,                    "1double_byteopt1"},
    {(void *)byteopt2,                           "2byteopt2"},
    {(void *)tracebyteopt2,                      "2tracebyteopt2"},
    {(void *)double_byteopt2,                    "2double_byteopt2"},
    {(void *)byteoptn,                           "nbyteoptn"},
    {(void *)tracebyteoptn,                      "ntracebyteoptn"},
    {(void *)double_byteoptn,                    "ndouble_byteoptn"},
    {(void *)hardopt1,                           "1hardopt1"},
    {(void *)tracehardopt1,                      "1tracehardopt1"},
    {(void *)double_hardopt1,                    "1double_hardopt1"},
    {(void *)hardopt2,                           "2hardopt2"},
    {(void *)tracehardopt2,                      "2tracehardopt2"},
    {(void *)double_hardopt2,                    "2double_hardopt2"},
    {(void *)hardoptn,                           "nhardoptn"},
    {(void *)tracehardoptn,                      "ntracehardoptn"},
    {(void *)double_hardoptn,                    "ndouble_hardoptn"},
    {(void *)byteoptrest1,                       "1byteoptrest1"},
    {(void *)tracebyteoptrest1,                  "1tracebyteoptrest1"},
    {(void *)double_byteoptrest1,                "1double_byteoptrest1"},
    {(void *)byteoptrest2,                       "2byteoptrest2"},
    {(void *)tracebyteoptrest2,                  "2tracebyteoptrest2"},
    {(void *)double_byteoptrest2,                "2double_byteoptrest2"},
    {(void *)byteoptrestn,                       "nbyteoptrestn"},
    {(void *)tracebyteoptrestn,                  "ntracebyteoptrestn"},
    {(void *)double_byteoptrestn,                "ndouble_byteoptrestn"},
    {(void *)hardoptrest1,                       "1hardoptrest1"},
    {(void *)tracehardoptrest1,                  "1tracehardoptrest1"},
    {(void *)double_hardoptrest1,                "1double_hardoptrest1"},
    {(void *)hardoptrest2,                       "2hardoptrest2"},
    {(void *)tracehardoptrest2,                  "2tracehardoptrest2"},
    {(void *)double_hardoptrest2,                "2double_hardoptrest2"},
    {(void *)hardoptrestn,                       "nhardoptrestn"},
    {(void *)tracehardoptrestn,                  "ntracehardoptrestn"},
    {(void *)double_hardoptrestn,                "ndouble_hardoptrestn"},
    {(void *)too_many_1,                         "2too_many_1"},
    {(void *)wrong_no_1,                         "nwrong_no_1"},
    {(void *)too_few_2,                          "1too_few_2"},
    {(void *)wrong_no_2,                         "nwrong_no_2"},
    {(void *)wrong_no_0a,                        "1wrong_no_0a"},
    {(void *)wrong_no_0b,                        "2wrong_no_0b"},
    {(void *)wrong_no_3a,                        "1wrong_no_3a"},
    {(void *)wrong_no_3b,                        "2wrong_no_3b"},
    {(void *)wrong_no_na,                        "1wrong_no_na"},
    {(void *)wrong_no_nb,                        "2wrong_no_nb"},
/*
 * As a matter of convenience I will put stream-handling functions here
 * too -- they are not kept in symbol headers but in stream control
 * blocks, but they too need careful treatment across preserve/restart.
 */
    {(void *)char_from_illegal,                  "Xchar_from_illegal"},
    {(void *)char_to_illegal,                    "Xchar_to_illegal"},
    {(void *)read_action_illegal,                "Xread_action_illegal"},
    {(void *)write_action_illegal,               "Xwrite_action_illegal"},
    {(void *)char_from_terminal,                 "Xchar_from_terminal"},
    {(void *)char_to_terminal,                   "Xchar_to_terminal"},
    {(void *)read_action_terminal,               "Xread_action_terminal"},
    {(void *)write_action_terminal,              "Xwrite_action_terminal"},
    {(void *)char_from_file,                     "Xchar_from_file"},
    {(void *)char_to_file,                       "Xchar_to_file"},
    {(void *)read_action_file,                   "Xread_action_file"},
    {(void *)read_action_output_file,            "Xread_action_output_file"},
    {(void *)write_action_file,                  "Xwrite_action_file"},
    {(void *)binary_outchar,                     "Xbinary_outchar"},
    {(void *)char_from_list,                     "Xchar_from_list"},
    {(void *)char_to_list,                       "Xchar_to_list"},
    {(void *)code_to_list,                       "Xcode_to_list"},
    {(void *)read_action_list,                   "Xread_action_list"},
    {(void *)write_action_list,                  "Xwrite_action_list"},
    {(void *)count_character,                    "Xcount_character"},
    {(void *)char_to_pipeout,                    "Xchar_to_pipeout"},
    {(void *)write_action_pipe,                  "Xwrite_action_pipe"},
    {(void *)char_from_synonym,                  "Xchar_from_synonym"},
    {(void *)char_to_synonym,                    "Xchar_to_synonym"},
    {(void *)read_action_synonym,                "Xread_action_synonym"},
    {(void *)write_action_synonym,               "Xwrite_action_synonym"},
    {(void *)char_from_concatenated,             "Xchar_from_concatenated"},
    {(void *)char_to_broadcast,                  "Xchar_to_broadcast"},
    {(void *)read_action_concatenated,           "Xread_action_concatenated"},
    {(void *)write_action_broadcast,             "Xwrite_action_broadcast"},
    {(void *)char_from_echo,                     "Xchar_from_echo"},
/*
 * The batch here relate to function re-work that discards unwanted
 * extra arguments.
 */
    {(void *)f0_as_0,                            "n0->0"},
    {(void *)f1_as_0,                            "11->0"},
    {(void *)f2_as_0,                            "22->0"},
    {(void *)f3_as_0,                            "n3->0"},
    {(void *)f1_as_1,                            "11->1"},
    {(void *)f2_as_1,                            "22->1"},
    {(void *)f3_as_1,                            "n3->1"},
    {(void *)f2_as_2,                            "22->2"},
    {(void *)f3_as_2,                            "n3->2"},
    {(void *)f3_as_3,                            "n3->3"},
#ifdef CJAVA
    {(void *)java0,                              "njava0"},
    {(void *)java1,                              "1java1"},
    {(void *)java2,                              "2java2"},
    {(void *)java3,                              "njava3"},
    {(void *)javan,                              "njavan"},
#endif
    {NULL,                                       "Xdummy"}
};

static void adjust_vecheap(void)
{
    nil_as_base
    int32 page_number, i;
    for (page_number = 0; page_number < vheap_pages_count; page_number++)
    {   void *page = vheap_pages[page_number];
        char *low = (char *)doubleword_align_up((int32)page);
        int32 len = flip_bytes(qcar(low));
        char *fr;
        qcar(low) = len;
        fr = low + len;
        vfringe = (Lisp_Object)fr;
        vheaplimit = (Lisp_Object)(low + (CSL_PAGE_SIZE - 8));
        low += 8;
        while (low < fr)
        {   Header h = flip_bytes(*(Header *)low);
            *(Header *)low = h;
            if (is_symbol_header(h))
            {   Lisp_Object ss = (Lisp_Object)(low + TAG_SYMBOL);
                adjust(&qvalue(ss));
                adjust(&qenv(ss));
                adjust(&qpname(ss));
                adjust(&qplist(ss));
                adjust(&qfastgets(ss));
#ifdef COMMON
                adjust(&qpackage(ss));
#endif
/*
 * The mess here is because when CSL is re-loaded the position of all
 * C-coded entrypoints will very probably have changed since the
 * previous run - the set of entrypoints tested for here has to be
 * a complete list, except for ones established via "restart.c".  Note
 * that setup establishes entrypoints later on, so I can afford to leave
 * junk in the function cells of things that will be initialised then.
 * Thus if a "real" function pointer left over from last time happens
 * to look like one of the small integers used here to stand for special
 * built-in cases the false-hit I get here is not important.
 */
                i = flip_bytes(ifn1(ss));
/*
 * Another delicacy - somebody intent on cleaning up this code may spot the
 * cast from a function pointer to an integer here, and decide it would be
 * neater to make entries_table[] contain a union type that could hide the
 * conversion. But that MIGHT not be good enough if sizeof(void *)==8 and
 * sizeof(int32)==4, but it has been arranged that all pointers used have
 * their 32 most significant bits all zero..... And this odd case can be
 * persuaded to apply on a DEC Alpha!  The cast as written here really does
 * change data representation, but with luck does not lose any vital
 * information.
 */
                if (0 < i && i < entry_table_size)
                {   if (*entries_table[i].s != '1')
                    {   term_printf("?fn1 cell %d %s\n", i, entries_table[i].s);
                    }
                    ifn1(ss) = (int32)entries_table[i].p;
                }
                else ifn1(ss) = (int32)undefined1;
                i = flip_bytes(ifn2(ss));
                if (0 < i && i < entry_table_size)
                {   if (*entries_table[i].s != '2')
                    {   term_printf("?fn2 cell %d %s\n", i, entries_table[i].s);
                    }
                    ifn2(ss) = (int32)entries_table[i].p;
                }
                else ifn2(ss) = (int32)undefined2;
                i = flip_bytes(ifnn(ss));
                if (0 < i && i < entry_table_size)
                {   if (*entries_table[i].s != 'n')
                    {   term_printf("?fnn cell %d %s\n", i, entries_table[i].s);
                    }
                    ifnn(ss) = (int32)entries_table[i].p;
                }
                else ifnn(ss) = (int32)undefinedn;
                qcount(ss) = flip_bytes(qcount(ss));
                low += symhdr_length;
                continue;
            }
            else switch (type_of_header(h))
            {
#ifdef COMMON
        case TYPE_RATNUM:
        case TYPE_COMPLEX_NUM:
                adjust((Lisp_Object *)(low+4));
                adjust((Lisp_Object *)(low+8));
                break;
#endif
        case TYPE_HASH:
        case TYPE_SIMPLE_VEC:
        case TYPE_ARRAY:
        case TYPE_STRUCTURE:
                for (i=4; i<doubleword_align_up(length_of_header(h)); i+=4)
                    adjust((Lisp_Object *)(low+i));
                break;
        case TYPE_MIXED1:
        case TYPE_MIXED2:
        case TYPE_MIXED3:
        case TYPE_STREAM:
                for (i=4; i<16; i+=4) adjust((Lisp_Object *)(low+i));
                for (; i<doubleword_align_up(length_of_header(h)); i+=4)
                    *(Lisp_Object *)(low+i) =
                        flip_bytes(*(Lisp_Object *)(low+i));
                if (type_of_header(h) == TYPE_STREAM)
                {   Lisp_Object ss = (Lisp_Object)(low + TAG_VECTOR);
                    i = elt(ss, 4);
                    if (0 < i && i < entry_table_size)
                    {   if (*entries_table[i].s != 'X')
                            term_printf("Stream fn %d %s\n", i, entries_table[i].s);
                        elt(ss, 4) = (int32)entries_table[i].p;
                    }
                    else elt(ss, 4) = (int32)char_to_illegal;
                    i = elt(ss, 5);
                    if (0 < i && i < entry_table_size)
                    {   if (*entries_table[i].s != 'X')
                            term_printf("Stream fn %d %s\n", i, entries_table[i].s);
                        elt(ss, 5) = (int32)entries_table[i].p;
                    }
                    else elt(ss, 5) = (int32)write_action_illegal;
                    i = elt(ss, 8);
                    if (0 < i && i < entry_table_size)
                    {   if (*entries_table[i].s != 'X')
                            term_printf("Stream fn %d %s\n", i, entries_table[i].s);
                        elt(ss, 8) = (int32)entries_table[i].p;
                    }
                    else elt(ss, 8) = (int32)char_from_illegal;
                    i = elt(ss, 9);
                    if (0 < i && i < entry_table_size)
                    {   if (*entries_table[i].s != 'X')
                            term_printf("Stream fn %d %s\n", i, entries_table[i].s);
                        elt(ss, 9) = (int32)entries_table[i].p;
                    }
                    else elt(ss, 9) = (int32)read_action_illegal;
                }
                break;
        case TYPE_BIGNUM:
        case TYPE_VEC32:
                for (i=4; i<doubleword_align_up(length_of_header(h)); i+=4)
                    *(Lisp_Object *)(low+i) =
                        flip_bytes(*(Lisp_Object *)(low+i));
                break;
        case TYPE_VEC16:
                for (i=4; i<doubleword_align_up(length_of_header(h)); i+=4)
                    *(Lisp_Object *)(low+i) =
                        flip_halfwords(*(Lisp_Object *)(low+i));
                break;
        case TYPE_DOUBLE_FLOAT:
/*
 * note that this conversion is triggered by the vector header, not by
 * the pointer to the object, so punning associated with the pnames of
 * un-printed gensyms will not cause any confusion.
 */
                convert_fp_rep((void *)(low + 8L),
                               old_fp_rep, current_fp_rep, 2);
                break;
#ifdef COMMON
        case TYPE_SINGLE_FLOAT:
                convert_fp_rep((void *)(low + 4L),
                               old_fp_rep, current_fp_rep, 1);
                break;
        case TYPE_LONG_FLOAT:
/* Beware - if long floats move up to 3-word values the +8 here will change */
                convert_fp_rep((void *)(low + 8L),
                               old_fp_rep, current_fp_rep, 3);
                break;
#endif
        case TYPE_FLOAT32:
                for (i=4; i<doubleword_align_up(length_of_header(h)); i+=4)
                    convert_fp_rep((void *)(low+i),
                                   old_fp_rep, current_fp_rep, 1);
                break;
        case TYPE_FLOAT64:
                for (i=8; i<doubleword_align_up(length_of_header(h)); i+=8)
                    convert_fp_rep((void *)(low+i),
                                   old_fp_rep, current_fp_rep, 2);
                break;
        default:
                break;
            }
            low += doubleword_align_up(length_of_header(h));
        }
    }
}

static void adjust_bpsheap(void)
/*
 * This is needed so that (e.g.) headers in the code here get byte-flipped
 * if necessary.  Also to set codefringe.
 */
{
    nil_as_base
    int32 page_number;
#ifdef ENVIRONMENT_VECTORS_IN_BPS_HEAP
    int32 i;
#endif
    codelimit = codefringe = 0;
    for (page_number = 0; page_number < bps_pages_count; page_number++)
    {   void *page = bps_pages[page_number];
        char *low = (char *)doubleword_align_up((int32)page);
        int32 len = flip_bytes(qcar(low));
        char *fr;
        qcar(low) = len;
        fr = low + len;
        codefringe = (Lisp_Object)fr;
        codelimit = (Lisp_Object)(low + 8);
        while (fr < low + CSL_PAGE_SIZE)
        {   Header h = flip_bytes(*(Header *)fr);
            *(Header *)fr = h;
#ifdef ENVIRONMENT_VECTORS_IN_BPS_HEAP
            switch (type_of_header(h))
            {
        case TYPE_SIMPLE_VEC:   /* This option not used at present */
                for (i=4; i<doubleword_align_up(length_of_header(h)); i+=4)
                    adjust((Lisp_Object *)(fr+i));
                break;
        default:
                break;
            }
#endif
            fr += doubleword_align_up(length_of_header(h));
        }
    }
}

void adjust_all(void)
{
    int32 i;
    Lisp_Object nil = C_nil;
    qheader(nil)  = TAG_ODDS+TYPE_SYMBOL+SYM_SPECIAL_VAR;
#ifdef COMMON
    qheader(nil) |= SYM_EXTERN_IN_HOME;
#endif
    qvalue(nil)   = nil;
    qenv(nil)     = nil;
    ifn1(nil)     = (int32)undefined1;
    ifn2(nil)     = (int32)undefined2;
    ifnn(nil)     = (int32)undefinedn;
    adjust(&(qpname(nil)));     /* not a gensym */
    adjust(&(qplist(nil)));
    adjust(&(qfastgets(nil)));
#ifdef COMMON
    adjust(&(qpackage(nil)));
#endif

    copy_into_nilseg(NO);
    for (i = first_nil_offset; i<last_nil_offset; i++)
        adjust(&(((Lisp_Object *)nil)[i]));
    copy_out_of_nilseg(NO);

    adjust_consheap();
    adjust_vecheap();
    adjust_bpsheap();
}

static void *allocate_page(void)
{
    if (pages_count == 0) fatal_error(err_no_store);
    return pages[--pages_count];
}

#ifdef MEMORY_TRACE
int32 memory_base, memory_size, memory_count, memory_records = 0;
unsigned char *memory_map = NULL;
static int32 memory_lowest = 0x7fffffff, memory_highest = -1;
FILE *memory_file = NULL;

void memory_comment(int n)
{
    if (memory_map != NULL)
    {   putc(0xc0 + (n & 0x3f), memory_file);
        putc(0, memory_file);
        putc(0, memory_file);
    }
}

int kk = 0;

static void identify_one(void *p, int32 size, int type)
{
    int32 i, j;
    int32 base = (int32)p;
    int32 a = 0, b = 0;
    int32 da = 1, db = 1;
    int32 click = size/0x400;
    switch (type)
    {
case 0:  b = click; break;
case 1:  db = -1;   break;
case 2:  b = click; da = db = 2; break;
case 3:  da = 2; db = -2; break;
case 4:  db = 0; break;
case 5:  da = -1; db = 0; break;
default: b = click; da = db = 0; break;
    }
    if (size > 256)
    {   da *= (size/256);
        db *= (size/256);
    }
    memory_count |= 0x3ff;
    cmemory_reference(base);
    memory_comment(kk ? 3 : 5);
    kk = !kk;
    for (i=0; i<32; i++)
    {   int x;
        memory_count |= 0x3ff;
        cmemory_reference(base);
        for (j=0; j<0x400; j++)
        {   x = a + j*(size/8);
            while (x > size) x -= size;
            while (x < 0) x += size;
            cmemory_reference(base+x);
            x = b + j*(size/8);
            while (x > size) x -= size;
            while (x < 0) x += size;
            cmemory_reference(base+x);
        }
        a += da;
        b += db;
    }
}

static void identify_page(void *p[], int32 n, int type)
{
    while (n != 0)
    {   void *w = p[--n];
        if (w != NULL) identify_one(w, CSL_PAGE_SIZE, type);
    }
}

void identify_page_types()
{
    identify_page(pages,            pages_count,            0);
    identify_page(heap_pages,       heap_pages_count,       1);
    identify_page(vheap_pages,      vheap_pages_count,      2);
    identify_page(bps_pages,        bps_pages_count,        3);
    identify_page(native_pages,     native_pages_count,     4);
    identify_one((void *)stacksegment, CSL_PAGE_SIZE,       5);
    identify_one((void *)nilsegment, NIL_SEGMENT_SIZE,      6);
}

long int car_counter;
unsigned long int car_low, car_high;

Cons_Cell *memory_reference(int32 p)
{
    if (p & 0x3)
    {   term_printf("Access to mis-aligned address %.8x\n", p);
        ensure_screen();
        abort();
    }
    return (Cons_Cell *)cmemory_reference(p);
}

char *cmemory_reference(int32 p)
{
    int32 a = p - memory_base;
#ifdef CHECK_ONLY
    return (char *)p;
#endif
    if (memory_map != NULL && a >= 0 && a < memory_size)
    {   int bit;
        a = a >> 2;                          /* Get a word address */
        a = a >> 2;                          /* reduce to 4-word resolution */
        if (memory_count >= car_counter &&
            (unsigned long int)a >= car_low &&
            (unsigned long int)a <= car_high)
        {   Lisp_Object nil = C_nil;
            if (exception_pending()) nil = (Lisp_Object)((int32)nil ^ 1);
            interrupt_pending = 1;
#ifdef SOFTWARE_TICKS
            countdown = 0;
#else
            deal_with_tick();  /* pretend tick arrived here and now */
#endif
            miscflags |= HEADLINE_FLAG | MESSAGES_FLAG;
            car_counter = 0x7fffffff; /* Do not interrupt again */
        }
        bit = 1 << (a & 7);
        a = a >> 3;
        if (a < memory_lowest) memory_lowest = a;
        if (a > memory_highest) memory_highest = a;
        memory_map[a] |= bit;
        if ((++memory_count & 0x3ff) == 0)   /* Every 1024 references... */
        {   unsigned char *pp;
            int c;
            int32 run = 0, i;
/*
 * I use a run-length encoded representation for the file that I write out.
 * Each scan-line is stored as a collection of bytes each of which indicates
 * the number of '0' items before the next '1' in the bit-vector. The encoding
 * of individual lengths is as follows:
 *     0 - 127          1 byte
 *     128 - 16K        First byte has 0x80 plus 6 bits of data (+ 1 more)
 *     16K - 4M         First byte has 0xc0 plus 6 bits of data (+ 2 more)
 *     The byte pair (0x8n, 0x00) stands for n times 4M as a a prefix to
 *     one of the above. This gives up to 2^28 as the max span.
 *     The byte pair (0x80, 0x00) can be used to terminate a line.
 *     Codes (0xcn, 0x00, 0x00) give 64 special codes that can be used
 *     to interveave comments and annotations within the stream.
 */
            pp = memory_map + memory_lowest;
            run = 8*memory_lowest;
            for (i=memory_lowest; i<=memory_highest; i++)
            {   c = *pp++;
                if (c != 0)
                {   bit = 1;
                    while ((c & bit) == 0) run++, bit = bit << 1;
                    if (run >= 0x400000)
                    {   putc(0x80 + ((run >> 22) & 0x3f), memory_file);
                        putc(0x00, memory_file);
                        run &= 0x3fffff;
                    }
                    if (run < 0x80) putc(run, memory_file);
                    else if (run < 0x4000)
                    {   putc(0x80 + (run & 0x3f), memory_file);
                        putc((run >> 6) & 0xff, memory_file);
                    }
                    else
                    {   putc(0xc0 + (run & 0x3f), memory_file);
                        putc((run >> 6) & 0xff, memory_file);
                        putc((run >> 14) & 0xff, memory_file);
                    }
                    c &= ~bit;
                    run = 0;
                    bit = bit << 1;
                    while (c != 0)
                    {   while ((c & bit) == 0) run++, bit = bit << 1;
                        putc(run, memory_file);
                        c &= ~bit;
                        run = 0;
                        bit = bit << 1;
                    }
                    while (bit != 0x100) run++, bit = bit << 1;
                }
                else run += 8;
            }
            putc(0x80, memory_file);
            putc(0x00, memory_file);
            memory_lowest = 0x7fffffff;
            memory_highest = -1;
            memset(memory_map, 0, memory_size/32+8);
            memory_records++;
        }
    }
    return (char *)p;
}

#endif

static char *global_handle;

void *my_malloc(size_t n)
{
#ifdef NO_WORRY_ABOUT_MEMORY_PROBLEMS
    return malloc(n);
#else
#define EXPLICIT_FREE_AT_END_OF_RUN  1
    char *r = (char *)malloc(n+32);
    int *p = (int *)doubleword_align_up(r);
    if (r == NULL) return NULL;
    inject_randomness((int)r);
    p[0] = (int)r;                /* base address for free() */
    p[1] = n;
    p[2] = 0x12345678;            /* Marker word for security */
    p[3] = 0x3456789a;
    r = (char *)&p[4];
    *(int *)(r+n)   = 0x87654321;
    *(int *)(r+n+4) = 0xcba98765;
    return (void *)r;
#endif
}

#ifndef HOLD_BACK_MEMORY
static char *big_chunk_start, *big_chunk_end;
#endif

#ifdef EXPLICIT_FREE_AT_END_OF_RUN

static void my_free(void *r)
{
#ifdef NO_WORRY_ABOUT_MEMORY_PROBLEMS
#ifndef HOLD_BACK_MEMORY
    char *rr = (char *)r;
/*
 * I will not free it if the pointer is strictly inside the single big
 * chunk that I grabbed at the start of the run.
 */
    if (rr > big_chunk_start && rr <= big_chunk_end) return;
#endif
    free(r);
#else
    int *p, *q, n;
#ifndef HOLD_BACK_MEMORY
    char *rr = (char *)r;
/*
 * I will not free it if the pointer is strictly inside the single big
 * chunk that I grabbed at the start of the run.
 */
    if (rr > big_chunk_start && rr <= big_chunk_end) return;
#endif
    p = (int *)((char *)r - 16);
    n = p[1];
    if (p[2] != 0x12345678 ||
        p[3] != 0x3456789a)
    {   term_printf("Corruption at start of memory block %.8x: %.8x %.8x\n",
            (int)r, p[2], p[3]);
        ensure_screen();
        my_exit(0);
    }
    q = (int *)((char *)r + n);
    if (q[0] != 0x87654321 ||
        q[1] != 0xcba98765)
    {   term_printf("Corruption at end of memory block %.8x: %.8x %.8x\n",
            (int)r, q[0], q[1]);
        ensure_screen();
        my_exit(0);
    }
    free((void *)p[0]);
#endif
}

#endif

static void *my_malloc_1(size_t n)
/*
 * This is a pretty silly function - it gobbles up 24Kbytes of
 * stack and then just calls malloc - it stuffs a pointer to the
 * stack-chunk into a static variable so that compilers can not
 * detect (I hope!) that the array remains unused.  The purpose of this
 * is to make malloc fail if it is about to encroach on space that
 * should be used for stack.  This is relevant on small systems where
 * stack and heap grow towards one another and where one space has been
 * grabbed by malloc it is unavailable for stack (even if it is FREEd).
 * The number 24000 is pretty arbitrary - but if I have 24Kbytes of stack
 * I will be able to do at least something.
 * Also this code verifies that the memory addresses returned have the
 * correct most significant bit. I allocate just a bit more memory than
 * is really needed to leave a one-word (or so) guard-band between
 * allocated blocks. This is necessary on some releases of an SGI C
 * compiler (library) where blocks of memory that are word but not
 * doubleword aligned can be returned.
 */
{
    char gobble_stack[24000];
    char *r;
    int32 pun, pun1;
    global_handle = gobble_stack;
    r = (char *)my_malloc(n+8);
    pun = (int32)r;
    pun1 = (int32)(r + n);
/*
 * I will moan if the block of memory allocated spans zero.
 * Note that if this does happen then something very funny is happening
 * about 0 cast to a pointer (i.e. a NULL pointer) since NULL is supposed
 * not to be valid as an address (?) but appears to be within the address
 * range of the block of store just allocated.
 */
    if ((pun ^ pun1) < 0) fatal_error(err_mem_spans_zero);
/*
 * Now if I get a block with the "wrong" top bit I will just return NULL
 * to suggest that no more memory was available - CSL can then proceed
 * or fail as it sees fit.
 */
#ifdef ADDRESS_SIGN_UNKNOWN
/*
 * For dynamic address sign I should not test the address sign on the
 * first call - instead I just remember what it was.  On subsequent calls
 * I will check it.
  */
    if (nilsegment != NULL)
    {   if ((pun + address_sign) < 0) return NULL;
                                      /* fatal_error(err_top_bit); */
    }
    else address_sign = pun & 0x80000000;
#else
#ifdef ADDRESSES_HAVE_TOP_BIT_SET
    if (pun > 0) return NULL; /* fatal_error(err_top_bit); */
#else
    if (pun < 0) return NULL; /* fatal_error(err_top_bit); */
#endif
#endif
    return (void *)r;
}

static void *my_malloc_2(size_t n)
/*
 * Rather like my_malloc_1(), but does NOT check the sign bit of the
 * returned pointer. Provided as a place to put hooks to check memory
 * allocation problems.
 */
{
    char gobble_stack[24000];
    char *r;
    global_handle = gobble_stack;
    r = (char *)my_malloc(n+8);
    return (void *)r;
}

static void init_heap_segments(double store_size)
/*
 * This function just makes nil and the pool of page-frames available
 */
{
    char *memfile = "memory.use"; /* For memory statistics etc */
    pages = (void **)my_malloc_2(MAX_PAGES*sizeof(void *));
    heap_pages = (void **)my_malloc_2(MAX_PAGES*sizeof(void *));
    vheap_pages = (void **)my_malloc_2(MAX_PAGES*sizeof(void *));
    bps_pages = (void **)my_malloc_2(MAX_BPS_PAGES*sizeof(void *));
    native_pages = (void **)my_malloc_2(MAX_NATIVE_PAGES*sizeof(void *));
#ifndef NO_COPYING_GC
    new_heap_pages = (void **)my_malloc_2(MAX_PAGES*sizeof(void *));
    new_vheap_pages = (void **)my_malloc_2(MAX_PAGES*sizeof(void *));
    new_bps_pages = (void **)my_malloc_2(MAX_BPS_PAGES*sizeof(void *));
    new_native_pages = (void **)my_malloc_2(MAX_NATIVE_PAGES*sizeof(void *));
#endif
    pair_c = (unsigned char *)my_malloc_2(CODESIZE);
/*
 * The next line is utterly unsatisfactory at present
 */
    char_stack = (unsigned char *)my_malloc_2(CSL_PAGE_SIZE /*CODESIZE*/);
    pair_prev = (unsigned short int *)
                    my_malloc_2(CODESIZE*sizeof(unsigned short int));
    if (pages == NULL ||
#ifndef NO_COPYING_GC
        new_heap_pages == NULL ||
        new_vheap_pages == NULL ||
        new_bps_pages == NULL ||
        new_native_pages == NULL ||
#endif
        heap_pages == NULL ||
        vheap_pages == NULL ||
        bps_pages == NULL ||
        native_pages == NULL ||
        pair_c == NULL ||
        char_stack == NULL ||
        pair_prev == NULL) fatal_error(err_no_store);

    {
#ifdef COMMON
        int32 free_space = 8000000; /* Try 8 Mbyte as a default heap size */
#else
        int32 free_space = 8000000; /* Try 8 Mbyte as a default heap size */
#endif
        int32 request = (int32)store_size;
        if (request != 0) free_space = 1024*request;
        free_space = free_space/(CSL_PAGE_SIZE+4);
        if (free_space > MAX_PAGES) free_space = MAX_PAGES;
        pages_count = heap_pages_count = vheap_pages_count =
                      bps_pages_count = native_pages_count = 0;
        native_fringe = 0;
/*
 * I grab memory using a function called my_malloc_1(), which verifies that
 * all addresses used in the heap have the same top bit.  The very first time
 * it is called nilsegment will be NULL - that time it does less checking.
 */
        nilsegment = NULL;

#ifdef HOLD_BACK_MEMORY
/*
 * Try to grab a bit extra since I will then hand it back.  This version
 * of the code MUST be used on machines where size_t (the argument to
 * malloc) denotes a 16-bit value.
 */
        free_space += HOLD_BACK_MEMORY;
/*
 * I should wait until later to grab space, I suspect...  I.e. not pre-allocate
 * pages for the heap now at the start of the run but wait until the garbage
 * collector tells me that enlarging the CSL heap would be a good idea.
 * What I do at present is to allocate a reasonable amount of memory here,
 * and on small machines I will leave it at that.  On large machines
 * I will allocate more space (maybe) during garbage collection.  I use
 * the HOLD_BACK_MEMORY and (init_flags & INIT_EXPANDABLE) to control things
 * in a finer way.
 */
        nilsegment = (Lisp_Object *)my_malloc_1(NIL_SEGMENT_SIZE);
#ifdef COMMON
/*
 * NB here that NIL is tagged as a CONS not as a symbol. That means that
 * qheader(nil) is BEFORE the place that might normally have been the start
 * of the segment, so I add 8 to preserve alignment but to leave room for
 * the header. I have made NIL_SEGMENT_SIZE large enough by a useful margin
 * (in externs.h) so I should not run off th eend of it.
 */
        C_nil = doubleword_align_up(nilsegment) + TAG_CONS + 8;
#else
        C_nil = doubleword_align_up(nilsegment) + TAG_SYMBOL;
#endif
        while (pages_count < free_space)
        {
/*
 * I get 8 bytes more than seems necessary because I will need to
 * align my page frames up to a doubleword boundary, and that can
 * potentially waste 7 bytes.
 */
            void *page = (void *)my_malloc_1((size_t)(CSL_PAGE_SIZE+8));
            if (page == NULL) break;
            pages[pages_count++] = page;
        }
/*
 * Now release some memory for the operating system to play with.  This
 * is a bit crude, in that it can "waste" precious space on small
 * machines, but on at least the Acorn Archimedes (RISCOS) and the
 * Macintosh (system 7) it appears to be VITAL.
 */
        {   int32 i;
            for (i=0; i<HOLD_BACK_MEMORY; i++)
                if (pages_count != 0) my_free(pages[--pages_count]);
        }
#else /* HOLD_BACK_MEMORY */
#ifdef DEBUG
        if (sizeof(size_t) < 4 && PAGE_BITS > 16)
        {   fprintf(stderr,
                   "This machine needs configuration with HOLD_BACK_MEMORY\n");
            fprintf(stderr,
                   "and PAGE_BITS <= 16.  Change machine.h and recompile\n");
            my_exit(1);
        }
#endif
        {   size_t n = (size_t)(NIL_SEGMENT_SIZE+free_space*(CSL_PAGE_SIZE+8));
/*
 * I try to get the whole of the initial hunk of memory that I need in
 * one gulp since that (maybe) gives me the best chance to obtain all
 * the memory in just one half of my address space.
 */
            char *pool = (char *)my_malloc_1(n);
/*
 * I get 8 bytes more than seems necessary because I will need to
 * align my page frames up to a doubleword boundary, and that can
 * potentially waste 7 bytes.
 */
            if (pool != NULL)
            {   big_chunk_start = (char *)pool;
                big_chunk_end = big_chunk_start + (n-1);
#ifdef __mips__
/*
 * Some versions of the C compiler on 64-bit SGI machines leave
 * big_chunk_start and _end both zero despite the above. The effect is
 * unimportant until the end of a run of CSL, when the test at the start
 * of my_free misbehaves and a report is generated about memory "corruption".
 * With LUCK the extra reference to the variables via the call to the
 * dummy function will cause the compiler to behave in a more conservative
 * manner and get things correct. The problem has not been seen on
 * 32-bit SGI systems, but the extra dummy function call is not very
 * expensive so can be tolerated in such cases.
 *                                                          ACN: August 1996
 */
                dummy_function_call("64-bit SGI machines",
                                    big_chunk_start, big_chunk_end);
#endif
#ifdef MEMORY_TRACE
                memory_base = (int32)pool;
                memory_size = n;
                memory_count = 0;
                memory_map = (unsigned char *)malloc(n/32 + 16);
                if (memory_map != 0)
                {   memset(memory_map, 0, n/32+8);
                    memory_file = fopen(memfile, "wb");
                    if (memory_file == NULL)
                    {   free(memory_map);
                        memory_map = 0;
                    }
                    else
                    {   n = n/32 + 8;
                        putc(0, memory_file);
                        putc(0, memory_file);
                        putc(0, memory_file); /* 3 bytes to overwrite later on */
                        putc(n, memory_file);
                        putc(n>>8, memory_file);
                        putc(n>>16, memory_file);
                        memory_comment(2);  /* startup code */
                        init_flags &= ~INIT_EXPANDABLE;
                    }
                }
#endif
                nilsegment = (Lisp_Object *)pool;
                pool = pool + NIL_SEGMENT_SIZE;
#ifdef COMMON
/* NB here that NIL is tagged as a CONS not as a symbol */
                C_nil = doubleword_align_up(nilsegment) + TAG_CONS + 8;
#else
                C_nil = doubleword_align_up(nilsegment) + TAG_SYMBOL;
#endif
/*
 * If at the end of the run I am going to free some space I had better not
 * free these pages. When I free the nilsegment they all get discarded at
 * once.
 */
                while (pages_count < free_space)
                {   void *page = (void *)&pool[pages_count*(CSL_PAGE_SIZE+8)];
                    pages[pages_count++] = page;
                }
            }
        }
#endif
    }

    if (nilsegment != NULL && pages_count > 0)
    {   if (stack_segsize != 1)
        {   stacksegment =
                (Lisp_Object *)my_malloc(stack_segsize*CSL_PAGE_SIZE + 8);
            if (stacksegment == NULL) fatal_error(err_no_store);
        }
        stacksegment = (Lisp_Object *)pages[--pages_count];
    }
    else fatal_error(err_no_store);
    MD5_Update((unsigned char *)memfile, 8);
/*
 * The stack does not need to be doubleword aligned, but it does need
 * to be word aligned (otherwise certain back-pointers in the garbage
 * collector give trouble), so I fix it up here.  Note that stacksegment
 * remains pointing at the original base so that I can free() it later.
 */
    stackbase = (Lisp_Object *)doubleword_align_up((int32)stacksegment);
}

#ifdef EXPLICIT_FREE_AT_END_OF_RUN
/*
 * In general I will let CSL exit without bothering to free up all the
 * memory that it allocated - that job can be left (to the extent that
 * it is needed at all) to the run-time system.  But if for some reason
 * you really mind about such things here is some code to do it for you...
 */

static void abandon(void *p[], int32 n)
{
    while (n != 0)
    {   void *w = p[--n];
/*
 * The test here that avoids calling free on a NULL pointer is
 * certainly not needed with an ANSI compliant library - but
 * rumour has it that many Unix libraries are unkind in this
 * respect, and the test is pretty cheap...
 */
        if (w != NULL) my_free(w);
    }
}

#endif

void drop_heap_segments(void)
{
#ifdef MEMORY_TRACE
    identify_page_types();
#endif
#ifdef EXPLICIT_FREE_AT_END_OF_RUN
    abandon(pages,           pages_count);
    abandon(heap_pages,      heap_pages_count);
    abandon(vheap_pages,     vheap_pages_count);
    abandon(bps_pages,       bps_pages_count);
    abandon(native_pages,    native_pages_count);
    my_free(stacksegment);
    my_free(nilsegment);
#endif
#ifdef MEMORY_TRACE
    fseek(memory_file, 0L, SEEK_SET);
    putc(memory_records & 0xff, memory_file);
    putc((memory_records>>8) & 0xff, memory_file);
    putc((memory_records>>16) & 0xff, memory_file);
    fclose(memory_file);
    memory_file = NULL;
    memory_map = NULL;
#endif
}

static char *find_checksum(char *name, int32 len, const setup_type *p)
{
    char *n;
    while (p->name != NULL) p++;
    n = (char *)p->one;
    if (strlen(n) == len && memcmp(name, n, len) == 0)
        return (char *)p->two;
    else return NULL;
}

static Lisp_Object MS_CDECL Lcheck_c_code(Lisp_Object nil, int nargs, ...)
{
    Lisp_Object name, lc1, lc2, lc3;
    int32 c1=-1, c2=-1, c3=-1;
    long int x1=-2, x2=-2, x3=-2;
    int32 len;
    va_list a;
    char *p;
    char *sname;
    argcheck(nargs, 4, "check-c-code");
    va_start(a, nargs);
    name = va_arg(a, Lisp_Object);
    lc1 = va_arg(a, Lisp_Object);
    lc2 = va_arg(a, Lisp_Object);
    lc3 = va_arg(a, Lisp_Object);
    va_end(a);
    if (!is_vector(name) ||
        type_of_header(vechdr(name)) != TYPE_STRING ||
        !is_fixnum(lc1) ||
        !is_fixnum(lc2) ||
        !is_fixnum(lc3)) return aerror1("check-c-code", name);
    c1 = int_of_fixnum(lc1);
    c2 = int_of_fixnum(lc2);
    c3 = int_of_fixnum(lc3);
    sname = &celt(name, 0);
    len = length_of_header(vechdr(name)) - 4;
/*
 *  trace_printf("+++ Checking %.*s  %d %d %d\n",
 *               (int)len, sname, c1, c2, c3); 
 */
                   p = find_checksum(sname, len, u01_setup);
    if (p == NULL) p = find_checksum(sname, len, u02_setup);
    if (p == NULL) p = find_checksum(sname, len, u03_setup);
    if (p == NULL) p = find_checksum(sname, len, u04_setup);
    if (p == NULL) p = find_checksum(sname, len, u05_setup);
    if (p == NULL) p = find_checksum(sname, len, u06_setup);
    if (p == NULL) p = find_checksum(sname, len, u07_setup);
    if (p == NULL) p = find_checksum(sname, len, u08_setup);
    if (p == NULL) p = find_checksum(sname, len, u09_setup);
    if (p == NULL) p = find_checksum(sname, len, u10_setup);
    if (p == NULL) p = find_checksum(sname, len, u11_setup);
    if (p == NULL) p = find_checksum(sname, len, u12_setup);
    if (p == NULL) return aerror1("check-c-code", name);
    if (sscanf(p, "%ld %ld %ld", &x1, &x2, &x3) != 3)
        return aerror("check-c-code");
    if (c1 == x1 && c2 == x2 && c3 == x3) return onevalue(nil);
    err_printf("\n+++++ C code and environment files not compatible\n");
    err_printf("please check, re-compile and try again\n");
    return aerror("check-c-code");
}

static setup_type const restart_setup[] =
/*
 * things that are in modules that do not define enough Lisp entrypoints
 * to be worth giving separate entry-tables.
 */
{
    {"check-c-code",            wrong_no_na, wrong_no_nb, Lcheck_c_code},
    {"define-in-module",        Ldefine_in_module, too_many_1, wrong_no_1},
    {"modulep",                 Lmodule_exists, too_many_1, wrong_no_1},
    {"start-module",            Lstart_module, too_many_1, wrong_no_1},
    {"write-module",            Lwrite_module, too_many_1, wrong_no_1},
    {"copy-module",             Lcopy_module, too_many_1, wrong_no_1},
    {"delete-module",           Ldelete_module, too_many_1, wrong_no_1},
    {"load-module",             Lload_module, too_many_1, wrong_no_1},
    {"list-modules",            wrong_no_na, wrong_no_nb, Llist_modules},
    {"writable-libraryp",       Lwritable_libraryp, too_many_1, wrong_no_1},
    {"library-members",         Llibrary_members, too_many_1, Llibrary_members0},
    {"startup-banner",          Lbanner, too_many_1, wrong_no_1},
#ifdef HELP_SYSTEM
    {"write-help-module",       too_few_2, Lwrite_help_module, wrong_no_2},
    {"help",                    Lhelp, Lhelp_2, Lhelp_n},
    {"?",                       Lhelp, too_many_1, wrong_no_1},
#endif
    {"set-help-file",           too_few_2, Lset_help_file, wrong_no_2},
    {"mapstore",                Lmapstore, too_many_1, Lmapstore0},
    {"verbos",                  Lverbos, too_many_1, wrong_no_1},
#ifdef COMMON
    {"errorset",                Lerrorset1, Lerrorset2, Lerrorsetn},
    {"gc",                      Lgc, too_many_1, Lgc0},
#else
    {"errorset",                Lerrorset1, Lerrorset2, Lerrorsetn},
    {"reclaim",                 Lgc, too_many_1, Lgc0},
#endif
    {NULL,                          0, 0, 0}
};


static void create_symbols(setup_type const s[], CSLbool restartp)
{
    int i;
    for (i=0; s[i].name != NULL; i++)
        make_symbol(s[i].name, restartp, s[i].one, s[i].two, s[i].n);
}

static int32 defined_symbols;

static void count_symbols(setup_type const s[])
{
    int i;
    for (i=0; s[i].name != NULL; i++) defined_symbols++;
}

static void set_up_variables(CSLbool restartp);

static void warm_setup()
{
/*
 * Here I need to read in the bulk of the checkpoint file.
 */
    Lisp_Object nil = C_nil;
    int32 i;
    Cfread((char *)&heap_pages_count, sizeof(heap_pages_count));
    Cfread((char *)&vheap_pages_count, sizeof(vheap_pages_count));
    Cfread((char *)&bps_pages_count, sizeof(bps_pages_count));

    heap_pages_count = flip_bytes(heap_pages_count);
    vheap_pages_count = flip_bytes(vheap_pages_count);
    bps_pages_count = flip_bytes(bps_pages_count);

/*
 * Here I want to arrange to have at least one free page after re-loading
 * an image.  If malloc can give me enough I grab it here. Note that I do
 * not yet know how many pages will be needed for hard code, which is a
 * bit of a nuisance!
 */
    i = heap_pages_count+vheap_pages_count+
        bps_pages_count+1 - pages_count;
#ifdef MEMORY_TRACE
    if (i > 0) fatal_error(err_no_store);
#else
    while (i-- > 0)
    {   void *page = my_malloc_1((size_t)(CSL_PAGE_SIZE + 8));
        if (page == NULL) fatal_error(err_no_store);
        else pages[pages_count++] = page;
    }
#endif
    {   char dummy[16];
        Cfread(dummy, 8);
    }
#ifdef MEMORY_TRACE
    memory_comment(6);  /* vector heap */
#endif
    for (i=0; i<vheap_pages_count; i++)
    {   int32 p;
        vheap_pages[i] = allocate_page();
        p = doubleword_align_up((int32)vheap_pages[i]);
        Cfread((char *)p, CSL_PAGE_SIZE);
    }

    {   char dummy[16];
        Cfread(dummy, 8);
    }
#ifdef MEMORY_TRACE
    memory_comment(5);  /* cons heap */
#endif
    for (i=0; i<heap_pages_count; i++)
    {   int32 p;
        heap_pages[i] = allocate_page();
        p = doubleword_align_up((int32)heap_pages[i]);
        Cfread((char *)p, CSL_PAGE_SIZE);
    }

    {   char dummy[16];
        Cfread(dummy, 8);
    }
#ifdef MEMORY_TRACE
    memory_comment(14);  /* BPS heap */
#endif
    for (i=0; i<bps_pages_count; i++)
    {   int32 p;
        bps_pages[i] = allocate_page();
        p = doubleword_align_up((int32)bps_pages[i]);
        Cfread((char *)p, CSL_PAGE_SIZE);
    }

    {   char endmsg[32];
        Cfread(endmsg, 24);  /* the termination record */
/*
 * Although I check here I will not make the system crash if I see an
 * error - at least until I have tested things and found this test
 * properly reliable.
 */
#ifdef COMMON
        if (strncmp(endmsg, "\n\nEnd of CCL dump file\n\n", 24) != 0)
#else
        if (strncmp(endmsg, "\n\nEnd of CSL dump file\n\n", 24) != 0)
#endif
        {   term_printf("\n+++ Bad end record |%s|\n", endmsg);
        }
    }
/*
 * There is a delicacy here - Cfread uses Iread to read chunks of
 * data from the real input file, but it never goes beyond the recorded
 * end of file mark.  This buffering ensures that at this stage any
 * pending part-word of data will have been read - this because the
 * read buffer used is a multiple of 4 bytes long.  This point matters
 * with regard to checksum validation on these files.
 */
    crypt_active = -1;  /* Have read all of the initial image file */
    IcloseInput(YES);
#ifdef MEMORY_TRACE
    memory_comment(9);  /* adjusting */
#endif
    inject_randomness((int)clock());
    adjust_all();

#ifdef MEMORY_TRACE
    memory_comment(12);  /* remainder of setup */
#endif
    eq_hash_tables = eq_hash_table_list;
    equal_hash_tables = equal_hash_table_list;
    eq_hash_table_list = equal_hash_table_list = nil;
    {   Lisp_Object qq;
        for (qq = eq_hash_tables; qq!=nil; qq=qcdr(qq))
            rehash_this_table(qcar(qq));
        for (qq = equal_hash_tables; qq!=nil; qq=qcdr(qq))
            rehash_this_table(qcar(qq));
    }

    gensym_ser = flip_bytes(gensym_ser);
    print_precision = flip_bytes(print_precision);
    miscflags = flip_bytes(miscflags);
    current_modulus = flip_bytes(current_modulus);
    fastget_size = flip_bytes(fastget_size);
    package_bits = flip_bytes(package_bits);
    set_up_functions(1);
    set_up_variables(1);
/*
 * Now I have closed the main heap image, but if there is any hard machine
 * code available for this architecture I should load it. When I do this
 * the main heap has been loaded and relocated and all the entrypoints
 * in it that relate to kernel code have been inserted.
 */
    if (native_code_tag != 0) /* Not worth trying if none available */
    {   if (!IopenRoot(NULL, -native_code_tag))
        {   int32 nn = Igetc() & 0xff;
            nn = nn + ((Igetc() & 0xff) << 8);
            native_pages_count = nn;
            for (i=0; i<native_pages_count; i++)
            {   int32 p;
/*
 * Because I did not know earlier how many pages would be needed here I
 * may not have overall enough. So I expand my heap (if possible)
 * when things start to look tight here.
 */
                if (pages_count <= 1)
                {   void *page = my_malloc_1((size_t)(CSL_PAGE_SIZE + 8));
                    if (page == NULL) fatal_error(err_no_store);
                    else pages[pages_count++] = page;
                }
                native_pages[i] = allocate_page();
                p = (int32)native_pages[i];
                p = doubleword_align_up(p);
                fread_count = 0;
                Cfread((char *)p, CSL_PAGE_SIZE);
                native_fringe = *(int32 *)p;
                relocate_native_code((unsigned char *)p, native_fringe);
            }
            IcloseInput(YES);
        }
    }
/*
 * Finally with a warm start I must instate the definitions of all functions
 * that may have been compiled into hard code on this platform. Functions that
 * may be hard-coded on SOME platform may also be in a mess and will have
 * a byte-coded definition put back in place at this point. Observe that this
 * happens AFTER the system has otherwise been loaded and relocated.
 */
    {   Lisp_Object f_list = native_code, byte_code_def;
        do_not_kill_native_code = 1;
        while (f_list != nil)
        {   Lisp_Object w, fn, defs;
            int32 nargs;
            int instated_something = 0;
            byte_code_def = nil;
            w = qcar(f_list);
            f_list = qcdr(f_list);
            fn = qcar(w); w = qcdr(w);
            nargs = int_of_fixnum(qcar(w));
            defs = qcdr(w);
            while (defs != nil)
            {   int32 n, tag, type, page, off;
                void *e;
                w = qcar(defs);
                defs = qcdr(defs);
                n = int_of_fixnum(qcar(w));
                w = qcdr(w);
                tag = (n >> 20) & 0xff;
                type = (n >> 18) & 0x3;
                page = n & 0x3ffff;
                if (tag == 0)
                {   byte_code_def = qcdr(w);
                    continue;
                }
                if (tag != native_code_tag) continue; /* Not for me today */
                instated_something = 1;
                off = int_of_fixnum(qcar(w));
                w = qcdr(w);
/*
 * Now fn should be a symbol, the function to be defined. w is the thing to go
 * into its environment cell. page and off define a location in the hard
 * code space and type tells me which of the 3 function cells to put that in.
 *
 * I will not (yet) mess around with the removal of C definition
 * flags and all the other delicacies. Note that this means attempts to
 * redefine built-in functions with user-provided native code varients
 * may cause all sorts of muddle! Please do not try it, but when you
 * do (!) tell me and I will attempt to work out what ought to happen.
 * Maybe it will all be OK provided that a consistent byte-code definition
 * is in place before any native code gets generated.
 */
                page = (int32)native_pages[page];
                page = doubleword_align_up(page);
                e = (void *)((char *)page + off);
                switch (type)
                {
/*
 * Warning - I just support nargs being a simple integer here, with no
 * fancy encoding for variable numbers of args or &rest args etc. I think
 * that for native code all such cases need to be dealt with via non-zero
 * type code so that the 3 individual function cells get filled in one
 * by 1.
 */
            case 0: switch (nargs)
                    {
                case 0: set_fns(fn, wrong_no_0a, wrong_no_0b, (n_args *)e);
                        break;
                case 1: set_fns(fn, (one_args *)e, too_many_1, wrong_no_1);
                        break;
                case 2: set_fns(fn, too_few_2, (two_args *)e, wrong_no_2);
                        break;
                case 3: set_fns(fn, wrong_no_3a, wrong_no_3b, (n_args *)e);
                        break;
                default:set_fns(fn, wrong_no_na, wrong_no_nb, (n_args *)e);
                        break;
                    }
                    break;
/*
 * A non-zero type field allows me to fill in just one of the function cells.
 * Note that I ought to arrange to get ALL of them filled in somehow, either
 * by using type=0 or by using all three of type = 1,2,3.
 */
            case 1: ifn1(fn) = (int32)e;
                    break;
            case 2: ifn2(fn) = (int32)e;
                    break;
            case 3: ifnn(fn) = (int32)e;
                    break;
                }
                qenv(fn) = w;
            }
            if (!instated_something && byte_code_def != nil)
            {   w = cons(fixnum_of_int(nargs), byte_code_def);
/*
 * You can look at this bit of code and moan, saying "What happens if
 * the call to CONS causes a garbage collection?". Well I have this policy
 * that garbage collection attempts during startup should be thought of
 * as fatal, and that the user should give enough memory to make it possible
 * to get at least started. I hope that I do not generate much litter here
 * and in other places within the startup code. Not thinking about GC
 * safety leaves the code neater and easier to work with.
 */
                Lsymbol_set_definition(nil, fn, w);
            }
        }
        do_not_kill_native_code = 0;
    }
    inject_randomness((int)clock());
}

static void cold_setup()
{
    Lisp_Object nil = C_nil;
    void *p;
    p = vheap_pages[vheap_pages_count++] = allocate_page();
    vfringe = (Lisp_Object)(8 + (char *)doubleword_align_up((int32)p));
    vheaplimit = (Lisp_Object)((char *)vfringe + (CSL_PAGE_SIZE - 16));

    p = heap_pages[heap_pages_count++] = allocate_page();
    heaplimit = doubleword_align_up((int32)p);
    fringe = (Lisp_Object)((char *)heaplimit + CSL_PAGE_SIZE);
    heaplimit = (Lisp_Object)((char *)heaplimit + SPARE);

    codelimit = codefringe = 0; /* no BPS to start with */

    miscflags = 3;
    qplist(nil) = nil;
    qfastgets(nil) = nil;
    qenv(nil) = nil;        /* points to self in undefined case */
    ifn1(nil) = (int32)undefined1;
    ifn2(nil) = (int32)undefined2;
    ifnn(nil) = (int32)undefinedn;
    qheader(nil) = TAG_ODDS+TYPE_SYMBOL+SYM_SPECIAL_VAR;
    qvalue(nil) = nil;
#ifdef COMMON
    qpname(nil) = make_string("NIL");
#else
    qpname(nil) = make_string("nil");
#endif
    qcount(nil) = 0;
    exit_tag = exit_value = nil;
    exit_reason = UNWIND_NULL;
    eq_hash_tables = equal_hash_tables = nil;

    current_package = nil;
    qvalue(nil) = getvector_init(sizeof(Package), nil);
#ifdef COMMON
    qpackage(nil) = qvalue(nil);    /* For sake of restart code */
    all_packages = ncons(qvalue(nil));
#endif

    packhdr_(CP) = TYPE_STRUCTURE + (packhdr_(CP) & ~header_mask);
#ifdef COMMON
    packname_(CP) = make_string("LISP");
#endif
/*
 * The size chosen here is only an initial size - the hash table in a package
 * can grow later on if needbe - but I ought to ensure that the initial
 * size is big enough for the built-in symbols that Lisp creates in
 * this restart code.  The size must be a power of 2.
 */
#define INIT_OBVECI_SIZE      4096
    packint_(CP) = getvector_init(INIT_OBVECI_SIZE+4, fixnum_of_int(0));
    packvint_(CP) = fixnum_of_int(1);
    packflags_(CP) = fixnum_of_int(++package_bits);
#ifdef COMMON
/*
 * Common Lisp also has "external" symbols to allow for...
 */
#define INIT_OBVECX_SIZE      4096
    packnint_(CP) = fixnum_of_int(0);
    packext_(CP) = getvector_init(INIT_OBVECX_SIZE+4, fixnum_of_int(0));
    packvext_(CP) = fixnum_of_int(1);
    packnext_(CP) = fixnum_of_int(1); /* Allow for nil */
    {   int i = (int)(hash_lisp_string(qpname(nil)) &
                      (INIT_OBVECX_SIZE/4 - 1));
        elt(packext_(CP), i) = nil;
    }
#else
    packnint_(CP) = fixnum_of_int(1); /* Allow for nil */
    {   int i = (int)(hash_lisp_string(qpname(nil)) &
                      (INIT_OBVECI_SIZE/4 - 1));
        elt(packint_(CP), i) = nil;
    }
#endif
    gensym_ser = 0;
    print_precision = 15;
    current_modulus = 1;
    fastget_size = 32;
    package_bits = 0;
    unset_var = nil;
/*
 * there had better not be a need for garbage collection here...
 * ... or elsewhere in setup, since the world is not yet put together.
 * Ditto interrupts.
 */
#define boffo_size 256
    boffo = getvector(TAG_VECTOR, TYPE_STRING, boffo_size+4);
    memset((void *)((char *)boffo + (4 - TAG_VECTOR)), '@', boffo_size);
#ifndef COMMON
    if (current_package == nil)
    {   current_package      = make_undefined_symbol("*package*");
        qheader(current_package) |= SYM_SPECIAL_VAR;
        lisp_package = qvalue(current_package) = qvalue(nil);
        qvalue(nil) = nil;
    }
#else
/*
 * The next line has hidden depths.  When it is obeyed during cold start
 * the C variable current_package has the value nil, hence make_symbol
 * looks in the value cell of nil to find the package to intern wrt. Once
 * this has been done I can put nil back how it ought to have been!
 */
    current_package          = make_undefined_symbol("*package*");
    qheader(current_package)|= SYM_SPECIAL_VAR;
    lisp_package = qvalue(current_package)  = qpackage(nil);
    qvalue(nil)              = nil;          /* Whew! */
#endif

    B_reg = nil;                             /* safe for GC */
    unset_var                = make_undefined_symbol("~indefinite-value~");
    qheader(unset_var)      |= SYM_SPECIAL_VAR;
    qvalue(unset_var)        = unset_var;
    Lunintern(nil, unset_var);
/*
 * Now in some minor sense the world is in a self-consistent state
 */
    lisp_true           = make_undefined_symbol("t");
    qheader(lisp_true) |= SYM_SPECIAL_VAR;
    qvalue(lisp_true)   = lisp_true;
    savedef             = make_undefined_symbol("*savedef");
    comma_symbol        = make_undefined_symbol("~comma");
    comma_at_symbol     = make_undefined_symbol("~comma-at");
    lambda              = make_undefined_symbol("lambda");
    funarg              = make_undefined_symbol("funarg");
    cfunarg             = make_undefined_symbol("cfunarg");
    opt_key             = make_undefined_symbol("&optional");
    rest_key            = make_undefined_symbol("&rest");
#ifdef COMMON
    key_key             = make_undefined_symbol("&key");
    allow_other_keys    = make_undefined_symbol("&allow-other-keys");
    aux_key             = make_undefined_symbol("&aux");
#endif
    work_symbol         = make_undefined_symbol("~magic-internal-symbol~");
    Lunintern(nil, work_symbol);
#ifndef COMMON
    packid_(CP)         = make_undefined_symbol("package");
#else
    package_symbol      = make_undefined_symbol("package");
    packid_(CP)         = package_symbol;
#endif

    macroexpand_hook    = make_undefined_symbol("*macroexpand-hook*");
    qheader(macroexpand_hook) |= SYM_SPECIAL_VAR;
    evalhook            = make_undefined_symbol("*evalhook*");
    qheader(evalhook)  |= SYM_SPECIAL_VAR;
    qvalue(evalhook)    = nil;
    applyhook           = make_undefined_symbol("*applyhook*");
    qheader(applyhook) |= SYM_SPECIAL_VAR;
    qvalue(applyhook)   = nil;
#ifdef COMMON
    keyword_package     = make_undefined_symbol("*keyword-package*");
    qheader(keyword_package) |= SYM_SPECIAL_VAR;
    qvalue(keyword_package) = make_package(make_string("KEYWORD"));
    err_table           = make_undefined_symbol("*ERROR-MESSAGE*");
#else
    err_table           = make_undefined_symbol("*error-messages*");
#endif
    qheader(err_table) |= SYM_SPECIAL_VAR;
    qvalue(err_table)   = nil;
#ifdef COMMON
#define make_keyword(name) \
        Lintern_2(nil, make_string(name), qvalue(keyword_package))
    internal_symbol     = make_keyword("INTERNAL");
    external_symbol     = make_keyword("EXTERNAL");
    inherited_symbol    = make_keyword("INHERITED");
    allow_key_key       = make_keyword("ALLOW-OTHER-KEYS");
#else
#define make_keyword(name) make_undefined_symbol(name)
#endif
    gensym_base         = make_string("G");
#ifdef COMMON
    special_symbol      = make_undefined_symbol("special");
    expand_def_symbol   = make_undefined_symbol("expand-definer");
    format_symbol       = make_undefined_symbol("format");
    string_char_sym     = make_undefined_symbol("string-char");
    cl_symbols          = make_undefined_symbol("*cl-symbols*");
/*
 * cl_symbols has to be at least a vector or else I can not
 * read in the Lisp file that sets its proper value...
 */
    qvalue(cl_symbols)  = getvector_init(8<<2, nil);
    features_symbol     = make_undefined_symbol("*features*");
    qheader(cl_symbols)      |= SYM_SPECIAL_VAR;
    qheader(features_symbol) |= SYM_SPECIAL_VAR;
    {   Lisp_Object w;
#define make_constant(name, value)       \
        w = make_undefined_symbol(name); \
        qheader(w) |= SYM_SPECIAL_VAR;   \
        qvalue(w) = value;
        make_constant("most-positive-fixnum", fixnum_of_int(0x07ffffff));
        make_constant("most-negative-fixnum", fixnum_of_int(0xf8000000));
/* #undef  TYPE_LONG_FLOAT                   */
/* #define TYPE_LONG_FLOAT TYPE_DOUBLE_FLOAT */
        make_constant("pi",
            make_boxfloat(3.141592653589793238, TYPE_LONG_FLOAT));
    }
#endif
    append_symbol       = make_undefined_symbol("append");
    raise_symbol        = make_undefined_symbol("*raise");
    lower_symbol        = make_undefined_symbol("*lower");
    echo_symbol         = make_undefined_symbol("*echo");
/*
 * I think that having a built-in symbol called *hankaku even if Kanji support
 * is not otherwise present is not too severe a problem, and making the
 * symbol present always will help keep image files re-usable from one
 * version of CSL to another.
 */
    hankaku_symbol      = make_undefined_symbol("*hankaku");
    comp_symbol         = make_undefined_symbol("*comp");
    compiler_symbol     = make_undefined_symbol("compile");
    native_symbol       = make_undefined_symbol("native-compile");
    traceprint_symbol   = make_undefined_symbol("trace-print");
    loadsource_symbol   = make_symbol("load-source", 0, Lload_source, too_many_1, wrong_no_1);
    prinl_symbol        = make_symbol("prinl", 0, Lprin, too_many_1, wrong_no_1);
    emsg_star           = make_undefined_symbol("emsg*");
    redef_msg           = make_undefined_symbol("*redefmsg");
    expr_symbol         = make_undefined_symbol("expr");
    fexpr_symbol        = make_undefined_symbol("fexpr");
    macro_symbol        = make_undefined_symbol("macro");
    break_function      = make_undefined_symbol("*break-loop*");
    qheader(raise_symbol) |= SYM_SPECIAL_VAR;
    qheader(lower_symbol) |= SYM_SPECIAL_VAR;
    qheader(echo_symbol)  |= SYM_SPECIAL_VAR;
    qheader(hankaku_symbol) |= SYM_SPECIAL_VAR;
    qheader(comp_symbol)  |= SYM_SPECIAL_VAR;
    qheader(emsg_star)    |= SYM_SPECIAL_VAR;
    qheader(redef_msg)    |= SYM_SPECIAL_VAR;
    qheader(break_function)    |= SYM_SPECIAL_VAR;
    qvalue(break_function)      = nil;
    qheader(loadsource_symbol) |= SYM_SPECIAL_VAR;
    qvalue(loadsource_symbol)   = nil;
    {   Lisp_Object common = make_undefined_symbol("common-lisp-mode");
        qheader(common)   |= SYM_SPECIAL_VAR;
#ifdef COMMON
        qvalue(common)        = lisp_true;
        qvalue(raise_symbol)  = lisp_true;
        qvalue(lower_symbol)  = nil;
#else
        qvalue(common)        = nil;
        qvalue(raise_symbol)  = nil;
        qvalue(lower_symbol)  = lisp_true;
#endif
    }
    qvalue(echo_symbol)    = nil;
    qvalue(hankaku_symbol) = nil;
    qvalue(comp_symbol)    = nil;
    qvalue(emsg_star)      = nil;
    qvalue(redef_msg)      = lisp_true;

    sys_hash_table = Lmkhash(nil, 3, fixnum_of_int(5), fixnum_of_int(2), nil);
    get_counts = Lmkhash(nil, 3, fixnum_of_int(5), fixnum_of_int(0), nil);
/*
 * I make the vector that can hold the names used for "fast" get tags big
 * enough for the largest possible number.
 */
    fastget_names = getvector_init((MAX_FASTGET_SIZE+2)<<2, SPID_NOPROP);
/*
 * The next bit is a horrid fudge, used in read.c (function orderp) to
 * support REDUCE. It ensures that the flag 'noncom is subject to an
 * optimisation for flag/flagp that allows it to be tested for using a
 * simple bit-test.  This MUST use entry zero (coded as 1 here!).
 * Also I insist that 'lose be the second fastget thing!
 */
    {   Lisp_Object nc = make_undefined_symbol("noncom");
        qheader(nc) |= (1L << SYM_FASTGET_SHIFT);
        elt(fastget_names, 0) = nc;
        nc = make_undefined_symbol("lose");
        qheader(nc) |= (2L << SYM_FASTGET_SHIFT);
        elt(fastget_names, 1) = nc;
    }
/*
 * I create the stream objects just once at cold-start time, but every time I
 * restart I will fill in their components in the standard way again.
 */
    lisp_work_stream = make_stream_handle();
    lisp_terminal_io = make_stream_handle();
    lisp_standard_output = make_stream_handle();
    lisp_standard_input = make_stream_handle();
    lisp_error_output = make_stream_handle();
    lisp_trace_output = make_stream_handle();
    lisp_debug_io = make_stream_handle();
    lisp_query_io = make_stream_handle();
    inject_randomness((int)clock());
    set_up_functions(0);
    set_up_variables(0);
}

void set_up_functions(CSLbool restartp)
{
/*
 * All symbols that have a pointer to C code in their function cell must
 * be set up whether we are in a warm OR a cold start state, because the
 * actual addresses associated with C entrypoints will vary from version
 * to version of the binary of the system.
 */
    int i;
    nil_as_base
#ifdef COMMON
/*
 * In Common Lisp mode it could be that the user had something other than the
 * LISP package active when the image was saved. But I want all the symbols
 * that I create or restore here to be in the LISP (or sometimes keyword)
 * package. So I temporarily reset the package here...
 */
    Lisp_Object saved_package = CP;
    CP = find_package("LISP", 4);
#endif
    function_symbol          = make_symbol("function", restartp, function_fn, bad_special2, bad_specialn);
    qheader(function_symbol)|= SYM_SPECIAL_FORM;
    quote_symbol             = make_symbol("quote", restartp, quote_fn, bad_special2, bad_specialn);
    qheader(quote_symbol)   |= SYM_SPECIAL_FORM;
    progn_symbol             = make_symbol("progn", restartp, progn_fn, bad_special2, bad_specialn);
    qheader(progn_symbol)   |= SYM_SPECIAL_FORM;
#ifdef COMMON
    declare_symbol           = make_symbol("declare", restartp, declare_fn, bad_special2, bad_specialn);
    qheader(declare_symbol) |= SYM_SPECIAL_FORM;
#endif
    cons_symbol              = make_symbol("cons", restartp, too_few_2, Lcons, wrong_no_2);
    eval_symbol              = make_symbol("eval", restartp, Leval, too_many_1, wrong_no_1);
    loadsource_symbol        = make_symbol("load-source", restartp, Lload_source, too_many_1, wrong_no_1);
/*
 * The main bunch of symbols can be handed using a table that
 * gives names and values.
 */
    for (i=0; eval2_setup[i].name != NULL; i++)
        qheader(make_symbol(eval2_setup[i].name,
                            restartp,
                            eval2_setup[i].one,
                            eval2_setup[i].two,
                            eval2_setup[i].n)) |= SYM_SPECIAL_FORM;
    for (i=0; eval3_setup[i].name != NULL; i++)
        qheader(make_symbol(eval3_setup[i].name,
                            restartp,
                            eval3_setup[i].one,
                            eval3_setup[i].two,
                            eval3_setup[i].n)) |= SYM_SPECIAL_FORM;

    create_symbols(arith06_setup, restartp);
    create_symbols(arith08_setup, restartp);
    create_symbols(arith10_setup, restartp);
    create_symbols(arith12_setup, restartp);
    create_symbols(char_setup, restartp);
    create_symbols(eval1_setup, restartp);
    create_symbols(funcs1_setup, restartp);
    create_symbols(funcs2_setup, restartp);
    create_symbols(funcs3_setup, restartp);
    create_symbols(print_setup, restartp);
    create_symbols(read_setup, restartp);
    create_symbols(restart_setup, restartp);
/*
    create_symbols(mpi_setup, restartp);
 */
/*
 * Although almost everything is mappeed into upper case in a Common Lisp
 * world I will preserve the case of symbols defined un u01 to u12.
 */
    create_symbols(u01_setup, restartp | 2);
    create_symbols(u02_setup, restartp | 2);
    create_symbols(u03_setup, restartp | 2);
    create_symbols(u04_setup, restartp | 2);
    create_symbols(u05_setup, restartp | 2);
    create_symbols(u06_setup, restartp | 2);
    create_symbols(u07_setup, restartp | 2);
    create_symbols(u08_setup, restartp | 2);
    create_symbols(u09_setup, restartp | 2);
    create_symbols(u10_setup, restartp | 2);
    create_symbols(u11_setup, restartp | 2);
    create_symbols(u12_setup, restartp | 2);

#ifdef NAG
    create_symbols(asp_setup, restartp);
    create_symbols(nag_setup, restartp);
    create_symbols(socket_setup, restartp);
    create_symbols(xdr_setup, restartp);
    create_symbols(grep_setup, restartp);
    create_symbols(axfns_setup, restartp);
    create_symbols(gr_setup, restartp);
#endif

#ifdef MEMORY_TRACE
    memory_comment(13);  /* tail end of setup */
#endif

#ifdef COMMON
    CP = saved_package;
#endif
}

static int MS_CDECL alpha0(const void *a, const void *b)
{
    return strcmp(*(const char **)a, *(const char **)b);
}

static int MS_CDECL alpha1(const void *a, const void *b)
{
    return strcmp(1+*(const char **)a, 1+*(const char **)b);
}

static void set_up_variables(CSLbool restartp)
{
    Lisp_Object nil = C_nil;
    int i;
#ifdef COMMON
    Lisp_Object saved_package = CP;
    CP = find_package("LISP", 4);
#endif
    qvalue(macroexpand_hook) = make_symbol("funcall", restartp, Lfuncall1, Lfuncall2, Lfuncalln);
    input_libraries = make_undefined_symbol("input-libraries");
    qheader(input_libraries)  |= SYM_SPECIAL_FORM;
    qvalue(input_libraries) = nil;
    for (i=number_of_fasl_paths-1; i>=0; i--)
        qvalue(input_libraries) = cons(SPID_LIBRARY + (((int32)i)<<20),
                                       qvalue(input_libraries));
    output_library = make_undefined_symbol("output-library");
    qheader(output_library)   |= SYM_SPECIAL_FORM;
    qvalue(output_library)  = output_directory < 0 ? nil :
                              SPID_LIBRARY + (((int32)output_directory)<<20);
/*
 * The Lisp variable lispsystem* gets set here. (in COMMON mode it is
 * the variable *features*)
 * Its value is a list.
 *       csl                      says I am a CSL Lisp
 *       (executable . "string")  name of current executable (if available)
 *       pipes                    do I support open-pipe?
 *       (version . "string")     eg "2.11"
 *       (name . "string")        eg "MSDOS/386"
 *       (opsys . id)             unix/msdos/riscos/win32/finder/riscos/...
 *       id                       unix/msdos etc again...
 *       win32s                   qualifier when (opsys . win32) is set
 *       win95                    ditto
 *       help                     help mechanism provided within Lisp
 *       (native . number)        native code tag
 *       (c-code . number)        u01.c through u12.c define n functions
 *
 * In COMMON mode the tags on the *features* list are generally in the
 * keyword package. Otherwise they are just regular symbols. This makes it
 * slightly hard to use code that tests this list in a generic environment!
 */
    {
#ifdef COMMON
        Lisp_Object n = features_symbol;
        Lisp_Object w;
        char opsys[32];
        char *p1 = opsys, *p2 = OPSYS;
        while ((*p1++ = toupper(*p2++)) != 0);
        *p1 = 0;
        w = cons(make_keyword(opsys), nil);
#else
        Lisp_Object n = make_undefined_symbol("lispsystem*");
        Lisp_Object w = cons(make_keyword(OPSYS), nil), w1;
        qheader(n) |= SYM_SPECIAL_VAR;
#endif
        defined_symbols = 0;
        count_symbols(u01_setup); count_symbols(u02_setup);
        count_symbols(u03_setup); count_symbols(u04_setup);
        count_symbols(u05_setup); count_symbols(u06_setup);
        count_symbols(u07_setup); count_symbols(u08_setup);
        count_symbols(u09_setup); count_symbols(u10_setup);
        count_symbols(u11_setup); count_symbols(u12_setup);
#ifdef COMMON
/*
 * A gratuitous misery here is the need to make COMMON words
 * upper case.
 */
        w = acons(make_keyword("OPSYS"),
                  make_undefined_symbol(OPSYS), w);
        w = acons(make_keyword("NATIVE"),
                  fixnum_of_int(native_code_tag), w);
        w = acons(make_keyword("C-CODE"),
                  fixnum_of_int(defined_symbols), w);
#ifdef WINDOWS_NT
        if (win32s==1) w = cons(make_keyword("WIN32S"), w);
        else if (win32s==2) w = cons(make_keyword("WIN95"), w);
#endif
#ifdef PIPES
#ifdef PIPES_SOMETIMES
        if (pipes_today)
#endif
            w = cons(make_keyword("PIPES"), w);
#endif
#ifdef HELP_SYSTEM
        w = cons(make_keyword("HELP"), w);
#endif
        w = cons(make_keyword("RECORD_GET"), w);
        if (program_name[0] != 0)
            w = acons(make_keyword("EXECUTABLE"),
                      make_string(program_name), w);
        w = acons(make_keyword("NAME"), make_string(IMPNAME), w);
        w = acons(make_keyword("VERSION"), make_string(VERSION), w);
        w = cons(make_keyword("CCL"), w);
        w = cons(make_keyword("COMMON-LISP"), w);
#else   /* !COMMON */
        w = acons(make_keyword("opsys"),
                  make_undefined_symbol(OPSYS), w);
        w = acons(make_keyword("native"),
                  fixnum_of_int(native_code_tag), w);
        w = acons(make_keyword("c-code"),
                  fixnum_of_int(defined_symbols), w);
#ifdef WINDOWS_NT
        if (win32s==1) w = cons(make_keyword("win32s"), w);
        else if (win32s==2) w = cons(make_keyword("win95"), w);
#endif
#ifdef PIPES
#ifdef PIPES_SOMETIMES
        if (pipes_today)
#endif
            w = cons(make_keyword("pipes"), w);
#endif
#ifdef HELP_SYSTEM
        w = cons(make_keyword("help"), w);
#endif
#ifdef RECORD_GET
        w = cons(make_keyword("record_get"), w);
#endif
        if (program_name[0] != 0)
            w = acons(make_keyword("executable"),
                      make_string(program_name), w);
        w = acons(make_keyword("name"), make_string(IMPNAME), w);
        w = acons(make_keyword("version"), make_string(VERSION), w);
        w = cons(make_keyword("csl"), w);
/*
 * Ha Ha a trick here - if a symbol ADDSQ is defined I view this image
 * as being one for REDUCE and push that information onto lispsystem*,
 * and I also reset the "about box" information (if using cwin).
 */
        w1 = make_undefined_symbol("addsq");
        if (qfn1(w1) != undefined1)
        {   w = cons(make_keyword("reduce"), w);
/*
 * I then inspect VERSION!* to try to see whether I have 3.6 or 3.7
 */
            w1 = qvalue(make_undefined_symbol("version*"));
            if (is_vector(w1) && 
                type_of_header(vechdr(w1)) == TYPE_STRING)
            {
#ifdef CWIN
                int n = length_of_header(vechdr(w1))-4;
                sprintf(about_box_title, "About %.*s",
                   (n > 31-strlen("About ") ? 31-strlen("About ") : n),
                   &celt(w1, 0));
                sprintf(about_box_description, "%.*s",
                   (n > 31 ? 31 : n),
                   &celt(w1, 0));
/*
 * 3.6 did not have copyright1!* etc info, so take it specially here.
 */
                if (memcmp(&celt(w1, 0), "REDUCE 3.6", 10) == 0)
                {   strcpy(about_box_rights_1, "Copyright RAND 1995");
                    strcpy(about_box_rights_2, "Copyright Codemist 1996");
                }
                else
                {   w1 = qvalue(make_undefined_symbol("copyright1*"));
                    if (is_vector(w1) && 
                        type_of_header(vechdr(w1)) == TYPE_STRING)
                    {   n = length_of_header(vechdr(w1))-4;
                        sprintf(about_box_rights_1, "%.*s",
                            n > 31 ? 31 : n, &celt(w1, 0));
                    }
                    else strcpy(about_box_rights_1, "Copyright A C Hearn/RAND");
                    w1 = qvalue(make_undefined_symbol("copyright2*"));
                    if (is_vector(w1) && 
                        type_of_header(vechdr(w1)) == TYPE_STRING)
                    {   n = length_of_header(vechdr(w1))-4;
                        sprintf(about_box_rights_2, "%.*s",
                            n > 31 ? 31 : n, &celt(w1, 0));
                    }
                    else strcpy(about_box_rights_2, "Copyright Codemist Ltd");
                }
#endif
            }
            else
            {
#ifdef CWIN
                strcpy(about_box_title, "About REDUCE");
                strcpy(about_box_description, "REDUCE");
                strcpy(about_box_rights_1, "Copyright A C Hearn/RAND");
                strcpy(about_box_rights_2, "Copyright Codemist Ltd");
#endif
            }
        }
#endif
        qheader(n) |= SYM_SPECIAL_VAR;
        qvalue(n) = w;
    }
#ifdef COMMON
/*
 * Floating point characteristics are taken from <float.h> where it is
 * supposed that the C compiler involved has got the values correct.
 * I do this every time the system is loaded rather than just when an
 * image is cold-created. This is because an image file may have been created
 * on a system differing from the one on which it is used. Mayve in fact
 * IEEE arithmetic is ALMOST universal and I am being too cautious here?
 */
    {   Lisp_Object w;
        make_constant("short-float-epsilon",
                      make_sfloat(16.0*FLT_EPSILON));
        make_constant("single-float-epsilon",
                      make_boxfloat(FLT_EPSILON, TYPE_SINGLE_FLOAT));
        make_constant("double-float-epsilon",
                      make_boxfloat(DBL_EPSILON, TYPE_DOUBLE_FLOAT));
/* For now "long" = "double" */
        make_constant("long-float-epsilon",
                      make_boxfloat(DBL_EPSILON, TYPE_LONG_FLOAT));
/*
 * I assume that I have a radix 2 representation, and float-negative-epsilon
 * is just half float-epsilon. Correct me if I am wrong...
 */
        make_constant("short-float-negative-epsilon",
                      make_sfloat(16.0*FLT_EPSILON/2.0));
        make_constant("single-float-negative-epsilon",
                      make_boxfloat(FLT_EPSILON/2.0, TYPE_SINGLE_FLOAT));
        make_constant("double-float-negative-epsilon",
                      make_boxfloat(DBL_EPSILON/2.0, TYPE_DOUBLE_FLOAT));
/* For now "long" = "double" */
        make_constant("long-float-negative-epsilon",
                      make_boxfloat(DBL_EPSILON/2.0, TYPE_LONG_FLOAT));
/*
 * I hope that the C header file gets extremal values correct. Note that
 * because make_sfloat() truncates (rather than rounding) it should give
 * correct values for most-positive-short-float etc
 */
        make_constant("most-positive-short-float",
                      make_sfloat(FLT_MAX));
        make_constant("most-positive-single-float",
                      make_boxfloat(FLT_MAX, TYPE_SINGLE_FLOAT));
        make_constant("most-positive-double-float",
                      make_boxfloat(DBL_MAX, TYPE_DOUBLE_FLOAT));
        make_constant("most-positive-long-float",
                      make_boxfloat(DBL_MAX, TYPE_LONG_FLOAT));
/*
 * Here I assume that the floating point representation is sign-and-magnitude
 * and hence symmetric about zero.
 */
        make_constant("most-negative-short-float",
                      make_sfloat(-FLT_MAX));
        make_constant("most-negative-single-float",
                      make_boxfloat(-FLT_MAX, TYPE_SINGLE_FLOAT));
        make_constant("most-negative-double-float",
                      make_boxfloat(-DBL_MAX, TYPE_DOUBLE_FLOAT));
        make_constant("most-negative-long-float",
                      make_boxfloat(-DBL_MAX, TYPE_LONG_FLOAT));
/*
 * The "least-xxx" set of values did not consider the case of denormalised
 * numbers too carefully in ClTl-1, so in ClTl-2 there are elaborations. I
 * believe that a proper C header file <float.h> will make the macros that
 * I use here refer to NORMALISED values, so the numeric results I use
 * here will not be quite proper (ie there are smaller floats that are
 * un-normalised). But I will ignore that worry just for now.
 */
        make_constant("least-positive-short-float",
                      make_sfloat(FLT_MIN));
        make_constant("least-positive-single-float",
                      make_boxfloat(FLT_MIN, TYPE_SINGLE_FLOAT));
        make_constant("least-positive-double-float",
                      make_boxfloat(DBL_MIN, TYPE_DOUBLE_FLOAT));
        make_constant("least-positive-long-float",
                      make_boxfloat(DBL_MIN, TYPE_LONG_FLOAT));
        make_constant("least-negative-short-float",
                      make_sfloat(-FLT_MIN));
        make_constant("least-negative-single-float",
                      make_boxfloat(-FLT_MIN, TYPE_SINGLE_FLOAT));
        make_constant("least-negative-double-float",
                      make_boxfloat(-DBL_MIN, TYPE_DOUBLE_FLOAT));
        make_constant("least-negative-long-float",
                      make_boxfloat(-DBL_MIN, TYPE_LONG_FLOAT));
/*
 * The bunch here are intended to be NORMALISED numbers, while the unqualified
 * ones above may not be.
 */
        make_constant("least-positive-normalized-short-float",
                      make_sfloat(FLT_MIN));
        make_constant("least-positive-normalized-single-float",
                      make_boxfloat(FLT_MIN, TYPE_SINGLE_FLOAT));
        make_constant("least-positive-normalized-double-float",
                      make_boxfloat(DBL_MIN, TYPE_DOUBLE_FLOAT));
        make_constant("least-positive-normalized-long-float",
                      make_boxfloat(DBL_MIN, TYPE_LONG_FLOAT));
        make_constant("least-negative-normalized-short-float",
                      make_sfloat(-FLT_MIN));
        make_constant("least-negative-normalized-single-float",
                      make_boxfloat(-FLT_MIN, TYPE_SINGLE_FLOAT));
        make_constant("least-negative-normalized-double-float",
                      make_boxfloat(-DBL_MIN, TYPE_DOUBLE_FLOAT));
        make_constant("least-negative-normalized-long-float",
                      make_boxfloat(-DBL_MIN, TYPE_LONG_FLOAT));
#ifdef UNIX_TIMES
/* /*
 * ACN believes that the following is misguided, since the time-reading
 * function (defined in fns1.c) that CCL provides always returns its answer
 * in milliseconds. This the 1000 below is NOT as arbitrary as all that, it
 * represents the unit that CCL (across all platforms) returns time
 * measurements in. The UNIX_TIMES macro is set on Unix systems to
 * influence whether the times() function or clock() is used to read
 * time, where in the former case Unix makes it possible to separate
 * user and system time.
 */
        /* UNIX_TIMES is set in machine.h and will usually be HZ. */
        make_constant("internal-time-units-per-second",
            fixnum_of_int(UNIX_TIMES));
#else
        make_constant("internal-time-units-per-second",
            fixnum_of_int(1000)); /* Arbitrary figure */
#endif
    }
#endif
#ifdef MEMORY_TRACE
    memory_comment(3);  /* creating symbols */
#endif
    charvec = getvector_init(257<<2, nil);
    faslvec = nil;
    faslgensyms = nil;

    qheader(terminal_io = make_undefined_symbol("*terminal-io*"))
        |= SYM_SPECIAL_VAR;
    qheader(standard_input = make_undefined_symbol("*standard-input*"))
        |= SYM_SPECIAL_VAR;
    qheader(standard_output = make_undefined_symbol("*standard-output*"))
        |= SYM_SPECIAL_VAR;
    qheader(error_output = make_undefined_symbol("*error-output*"))
        |= SYM_SPECIAL_VAR;
    qheader(trace_output = make_undefined_symbol("*trace-output*"))
        |= SYM_SPECIAL_VAR;
    qheader(debug_io = make_undefined_symbol("*debug-io*"))
        |= SYM_SPECIAL_VAR;
    qheader(query_io = make_undefined_symbol("*query-io*"))
        |= SYM_SPECIAL_VAR;

    stream_type(lisp_work_stream) = make_undefined_symbol("work-stream");

    {   Lisp_Object f = lisp_terminal_io;
        stream_type(f) = make_undefined_symbol("terminal-stream");
        set_stream_read_fn(f, char_from_terminal);
        set_stream_read_other(f, read_action_terminal);
        set_stream_write_fn(f, char_to_terminal);
        set_stream_write_other(f, write_action_terminal);
        qvalue(terminal_io) = f;

        f = lisp_standard_input;
        stream_type(f) = make_undefined_symbol("synonym-stream");
#ifdef COMMON
/*
 * If I do not have COMMON defined I will take a slight short cut here and
 * make reading from *standard-input* read directly from the terminal. For
 * full Common Lisp compatibility I think *standard-input* is required to
 * be a synonym stream that will dynamically look at the value of the variable
 * *terminal-io* every time it does anything. Ugh, since people who assign to
 * or re-bind *terminal-io* seem to me to be asking for terrible trouble!
 */
        set_stream_read_fn(f, char_from_synonym);
#else
        set_stream_read_fn(f, char_from_terminal);
#endif
        set_stream_read_other(f, read_action_synonym);
        stream_read_data(f) = terminal_io;
        qvalue(standard_input) = f;

        f = lisp_standard_output;
        stream_type(f) = make_undefined_symbol("synonym-stream");
#ifdef COMMON
        set_stream_write_fn(f, char_to_synonym);
#else
        set_stream_write_fn(f, char_to_terminal);
#endif
        set_stream_write_other(f, write_action_synonym);
        stream_write_data(f) = terminal_io;
        qvalue(standard_output) = f;

        f = lisp_error_output;
        stream_type(f) = make_undefined_symbol("synonym-stream");
#ifdef COMMON
        set_stream_write_fn(f, char_to_synonym);
#else
        set_stream_write_fn(f, char_to_terminal);
#endif
        set_stream_write_other(f, write_action_synonym);
        stream_write_data(f) = terminal_io;
        qvalue(error_output) = f;

        f = lisp_trace_output;
        stream_type(f) = make_undefined_symbol("synonym-stream");
#ifdef COMMON
        set_stream_write_fn(f, char_to_synonym);
#else
        set_stream_write_fn(f, char_to_terminal);
#endif
        set_stream_write_other(f, write_action_synonym);
        stream_write_data(f) = terminal_io;
        qvalue(trace_output) = f;

        f = lisp_debug_io;
        stream_type(f) = make_undefined_symbol("synonym-stream");
#ifdef COMMON
        set_stream_read_fn(f, char_from_synonym);
#else
        set_stream_read_fn(f, char_from_terminal);
#endif
        set_stream_read_other(f, read_action_synonym);
        stream_read_data(f) = terminal_io;
#ifdef COMMON
        set_stream_write_fn(f, char_to_synonym);
#else
        set_stream_write_fn(f, char_to_terminal);
#endif
        set_stream_write_other(f, write_action_synonym);
        stream_write_data(f) = terminal_io;
        qvalue(debug_io) = f;

        f = lisp_query_io;
        stream_type(f) = make_undefined_symbol("synonym-stream");
#ifdef COMMON
        set_stream_read_fn(f, char_from_synonym);
#else
        set_stream_read_fn(f, char_from_terminal);
#endif
        set_stream_read_other(f, read_action_synonym);
        stream_read_data(f) = terminal_io;
#ifdef COMMON
        set_stream_write_fn(f, char_to_synonym);
#else
        set_stream_write_fn(f, char_to_terminal);
#endif
        set_stream_write_other(f, write_action_synonym);
        stream_write_data(f) = terminal_io;
        qvalue(query_io) = f;
    }

/*
 * I can not handle boffo overflow very well here, but I do really hope that
 * symbols spelt out on the command line will always be fairly short.
 */
    for (i=0; i<number_of_symbols_to_define; i++)
    {   CSLbool undef = undefine_this_one[i];
        char *s = symbols_to_define[i];
        if (undef)
        {   Lisp_Object n = make_undefined_symbol(s);
            qvalue(n) = unset_var;
        }
        else
        {   char buffer[256];
            char *p = buffer;
            int c;
            Lisp_Object n, v;
            while ((c = *s++) != 0 && c != '=') *p++ = c;
            *p = 0;
            n = make_undefined_symbol(buffer);
            push(n);
            if (c == 0) v = lisp_true;
            else
            {
/*
 * I have been having a big difficulty here, caused by the inconsistent and
 * awkward behaviours of various shells and "make" utilities. In a tidy
 * and simple world I might like a command-line option -Dxx=yyy to allow
 * arbitrary text for yyy terminating it at the next whitespace. Then yyy
 * could be processed by the Lisp reader so that numbers, symbols, strings
 * etc could be specified. However I find that things I often want to
 * use involve characters such as "\" and ":" (as components of file-names
 * on some machines), and sometimes "make" treats these as terminators, or
 * wants to do something magic with "\".  If I put things within quote marks
 * then sometimes the quotes get passed through to Lisp and sometimes not.
 * This is all a BIG misery in a multi-platform situation!  As a fresh
 * attempt to inject sanity I will always convert yyy to a Lisp string. If
 * it is specified with leading and trailing '"' marks I will strip them. Thus
 * both -Dxxx=yyy and -Dxxx="yyy" will leave the variable xxx set to the
 * string "yyy". Then as a Lisp user I can parse the string if I need to
 * interpret it as something else.
 */
#ifndef PASS_PREDEFINES_THROUGH_READER
                if (*s == '"')   /* Convert "yyy" to just yyy */
                {   p = ++s;
                    while (*p != 0) p++;
                    if (*--p == '"') *p = 0;
                }
#endif
                v = make_string(s);
#ifdef PASS_PREDEFINES_THROUGH_READER
                v = Lexplodec(nil, v);
                v = Lcompress(nil, v);
/*
 * The above will first make the value in -Dname=value into a string,
 * then explode it into a list, and compress back - the effect is as if the
 * original value had been passed through the regular Lisp READ function,
 * so symbols, numbers and even s-expressions can be parsed.  If the
 * parsing fails I (silently) treat the value as just NIL.
 */
#endif
                nil = C_nil;
                if (exception_pending()) v = flip_exception();
            }
            pop(n);
            qheader(n) |= SYM_SPECIAL_VAR;
            qvalue(n) = v;
        }
    }
#ifndef COMMON
#ifdef CWIN
/*
 * Now if I have the CWIN windowed system (I might want this info elsewhere
 * too if another windowed implementation of CSL can use it) I look in the
 * Lisp variables
 *    loadable-packages!*
 *    switches!*
 * (both expected to be lists of symbols) and copy info into a couple of
 * C vectors, whence it can go to the window manager and be used to create
 * suitable menus.
 */
    {   Lisp_Object w1 = qvalue(make_undefined_symbol("loadable-packages*"));
        Lisp_Object w2;
        int n;
        char *v;
        n = 0;
        for (w2=w1; consp(w2); w2=qcdr(w2)) n++; /* How many? */
        loadable_packages = (char **)malloc((n+1)*sizeof(char *));
        if (loadable_packages != NULL)
        {   n = 0;
            for (w2=w1; consp(w2); w2=qcdr(w2))
            {   Lisp_Object w3 = qcar(w2);
                int n1;
                if (is_symbol(w3)) w3 = qpname(w3);
                if (!is_vector(w3) ||
                    type_of_header(vechdr(w3)) != TYPE_STRING) break;
                n1 = length_of_header(vechdr(w3))-4;
                v = (char *)malloc(n1+1);
                if (v == NULL) break;
                memcpy(v, &celt(w3, 0), n1);
                v[n1] = 0;
                loadable_packages[n++] = v;
            }
            qsort(loadable_packages, n, sizeof(char *), alpha0);
            loadable_packages[n] = NULL;
        }
        w1 = qvalue(make_undefined_symbol("switches*"));
        n = 0;
        for (w2=w1; consp(w2); w2=qcdr(w2)) n++; /* How many? */
        switches = (char **)malloc((n+1)*sizeof(char *));
        if (switches != NULL)
        {   n = 0;
            for (w2=w1; consp(w2); w2=qcdr(w2))
            {   Lisp_Object w3 = qcar(w2), w4;
                char sname[64];
                int n1;
                if (is_symbol(w3)) w3 = qpname(w3);
                if (!is_vector(w3) ||
                    type_of_header(vechdr(w3)) != TYPE_STRING) break;
                n1 = length_of_header(vechdr(w3))-4;
                if (n1 > 60) break;
                sprintf(sname, "*%.*s", n1, &celt(w3, 0));
                w4 = make_undefined_symbol(sname);
                v = (char *)malloc(n1+2);
                if (v == NULL) break;
/*
 * The first character records the current state of the switch.
 */
                if (qvalue(w4) == nil) v[0] = 'n';
                else v[0] = 'y';
                memcpy(v+1, &celt(w3, 0), n1);
                v[n1+1] = 0;
                switches[n++] = v;
            }
            qsort(switches, n, sizeof(char *), alpha1);
            switches[n] = NULL;
        }
    }

#endif
#endif
#ifdef COMMON
    CP = saved_package;
#endif
}

unsigned char registration_data[REGISTRATION_SIZE];
CSLbool MD5_busy;
unsigned char unpredictable[256];
static int n_unpredictable = 0;
static CSLbool unpredictable_pending = 0;

void inject_randomness(int n)
{
    unpredictable[n_unpredictable++] ^= (n % 255);
    if (n_unpredictable >= 256)
    {   n_unpredictable = 0;
        unpredictable_pending = YES;
    }
    if (unpredictable_pending & !MD5_busy)
    {   MD5_Init();
        MD5_Update(unpredictable, sizeof(unpredictable));
        MD5_Final(unpredictable);
        unpredictable_pending = NO;
    }
}

/*
 * For some of what follows I think I need to show that I have considered
 * the issue of export regulations.
 *
 * What I have here is MD5 (and when and if I feel keen SHA-1). I observe
 * that MD5, SHA-1 and DSA are made available as part of Sun's Java
 * Development Kit in the version that can be downloade freely from their
 * servers. They have a separate Java Cryptography Extension within which
 * they keep things that are subject to USA export regulations. I take this
 * as encouragement to believe that these three algorithms are not subject
 * to USA export limits. I believe such limits to be supersets (ie more
 * restrictive) than ones that apply in the UK and so feel happy about
 * including the implementations that I do here. Specifically, although I
 * have extracts from the SSL code which as a whole might give trouble if
 * importen to the USA and the re-exported I only have the message digest
 * bits that should not be so encumbered. I am aware that MD5 is now
 * considered weakish with SHA-1 the improved replacement, but will take the
 * view that I was not aiming for real security on anything anyway!
 */

/*
 *  MD5 message digest code, adapted from Eric Young's version,
 *  for which the copyright and disclaimer notices follow. Observe that
 *  this code can be adapted and re-used subject to these terms being
 *  retained.
 */


/* crypto/md/md5.c and support files */
/* Copyright (C) 1995-1997 Eric Young (eay@mincom.oz.au)
 * All rights reserved.
 *
 * This package is an SSL implementation written
 * by Eric Young (eay@mincom.oz.au).
 * The implementation was written so as to conform with Netscapes SSL.
 * 
 * This library is free for commercial and non-commercial use as long as
 * the following conditions are aheared to.  The following conditions
 * apply to all code found in this distribution, be it the RC4, RSA,
 * lhash, DES, etc., code; not just the SSL code.  The SSL documentation
 * included with this distribution is covered by the same copyright terms
 * except that the holder is Tim Hudson (tjh@mincom.oz.au).
 * 
 * Copyright remains Eric Young's, and as such any Copyright notices in
 * the code are not to be removed.
 * If this package is used in a product, Eric Young should be given attribution
 * as the author of the parts of the library used.
 * This can be in the form of a textual message at program startup or
 * in documentation (online or textual) provided with the package.
 * 
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 * 1. Redistributions of source code must retain the copyright
 *    notice, this list of conditions and the following disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in the
 *    documentation and/or other materials provided with the distribution.
 * 3. All advertising materials mentioning features or use of this software
 *    must display the following acknowledgement:
 *    "This product includes cryptographic software written by
 *     Eric Young (eay@mincom.oz.au)"
 *    The word 'cryptographic' can be left out if the rouines from the library
 *    being used are not cryptographic related :-).
 * 4. If you include any Windows specific code (or a derivative thereof) from 
 *    the apps directory (application code) you must include an acknowledgement:
 *    "This product includes software written by Tim Hudson (tjh@mincom.oz.au)"
 * 
 * THIS SOFTWARE IS PROVIDED BY ERIC YOUNG ``AS IS'' AND
 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
 * SUCH DAMAGE.
 * 
 * The licence and distribution terms for any publically available version or
 * derivative of this code cannot be changed.  i.e. this code cannot simply be
 * copied and put under another distribution licence
 * [including the GNU Public Licence.]
 */

/*
 * End of Eric Young's copyright and disclaimer notice.
 *
 * The changes made by A C Norman remove some optimisation to leave shorter
 * code (I will not be using this in speed-critical applications) and
 * adjusting the style and layout to agree with other Codemist utilities.
 */

#define MD5_CBLOCK         64
#define MD5_LBLOCK         16

static unsigned32 MD5_A, MD5_B, MD5_C, MD5_D;
static unsigned32 MD5_Nl;
static int MD5_num;
static unsigned32 MD5_data[MD5_CBLOCK];

#define F(x,y,z)        ((((y) ^ (z)) & (x)) ^ (z))
#define G(x,y,z)        ((((x) ^ (y)) & (z)) ^ (y))
#define H(x,y,z)        ((x) ^ (y) ^ (z))
#define I(x,y,z)        (((x) | (~(z))) ^ (y))

#define ROTATE(a,n)     (((a)<<(n))|((a)>>(32-(n))))


#define R0(a,b,c,d,k,s,t) {          \
        a+=((k)+(t)+F((b),(c),(d))); \
        a=ROTATE(a,s);               \
        a+=b; }

#define R1(a,b,c,d,k,s,t) {          \
        a+=((k)+(t)+G((b),(c),(d))); \
        a=ROTATE(a,s);               \
        a+=b; }

#define R2(a,b,c,d,k,s,t) {          \
        a+=((k)+(t)+H((b),(c),(d))); \
        a=ROTATE(a,s);               \
        a+=b; }

#define R3(a,b,c,d,k,s,t) {          \
        a+=((k)+(t)+I((b),(c),(d))); \
        a=ROTATE(a,s);               \
        a+=b; }


/*
 * Implemented from RFC1321 The MD5 Message-Digest Algorithm
 */

void MD5_Init()
{
    MD5_busy = YES;
    MD5_A = 0x67452301;
    MD5_B = 0xefcdab89;
    MD5_C = 0x98badcfe;
    MD5_D = 0x10325476;
    MD5_Nl = 0;
    MD5_num = 0;
}

static unsigned char byte_order_test[4] = {1, 0, 0, 0};

static void md5_block()
{
    unsigned32 A=MD5_A, B=MD5_B, C=MD5_C, D=MD5_D;
    int i;
/*
 * Here I re-write the buffer so that it now behaves as if it is
 * an array of 32-bit words in native computer representation. On
 * many machines the code here will have no effect at all apart from
 * consuming a little time. I do a little test first to see if
 * it is really needed.
 */
    unsigned32 *p = MD5_data;
    unsigned char *q = (unsigned char *)p;
    if (((unsigned32 *)byte_order_test)[0] != 1)
    {   for (i=0; i<MD5_LBLOCK; i++)
        {   unsigned32 w = *q++;
            w |= *q++ << 8;
            w |= *q++ << 16;
            w |= *q++ << 24;
            *p++ = w;
        }
    }
    p = MD5_data;
    /* Round 0 */
    R0(A,B,C,D,p[ 0], 7,0xd76aa478); R0(D,A,B,C,p[ 1],12,0xe8c7b756);
    R0(C,D,A,B,p[ 2],17,0x242070db); R0(B,C,D,A,p[ 3],22,0xc1bdceee);
    R0(A,B,C,D,p[ 4], 7,0xf57c0faf); R0(D,A,B,C,p[ 5],12,0x4787c62a);
    R0(C,D,A,B,p[ 6],17,0xa8304613); R0(B,C,D,A,p[ 7],22,0xfd469501);
    R0(A,B,C,D,p[ 8], 7,0x698098d8); R0(D,A,B,C,p[ 9],12,0x8b44f7af);
    R0(C,D,A,B,p[10],17,0xffff5bb1); R0(B,C,D,A,p[11],22,0x895cd7be);
    R0(A,B,C,D,p[12], 7,0x6b901122); R0(D,A,B,C,p[13],12,0xfd987193);
    R0(C,D,A,B,p[14],17,0xa679438e); R0(B,C,D,A,p[15],22,0x49b40821);
    /* Round 1 */
    R1(A,B,C,D,p[ 1], 5,0xf61e2562); R1(D,A,B,C,p[ 6], 9,0xc040b340);
    R1(C,D,A,B,p[11],14,0x265e5a51); R1(B,C,D,A,p[ 0],20,0xe9b6c7aa);
    R1(A,B,C,D,p[ 5], 5,0xd62f105d); R1(D,A,B,C,p[10], 9,0x02441453);
    R1(C,D,A,B,p[15],14,0xd8a1e681); R1(B,C,D,A,p[ 4],20,0xe7d3fbc8);
    R1(A,B,C,D,p[ 9], 5,0x21e1cde6); R1(D,A,B,C,p[14], 9,0xc33707d6);
    R1(C,D,A,B,p[ 3],14,0xf4d50d87); R1(B,C,D,A,p[ 8],20,0x455a14ed);
    R1(A,B,C,D,p[13], 5,0xa9e3e905); R1(D,A,B,C,p[ 2], 9,0xfcefa3f8);
    R1(C,D,A,B,p[ 7],14,0x676f02d9); R1(B,C,D,A,p[12],20,0x8d2a4c8a);
    /* Round 2 */
    R2(A,B,C,D,p[ 5], 4,0xfffa3942); R2(D,A,B,C,p[ 8],11,0x8771f681);
    R2(C,D,A,B,p[11],16,0x6d9d6122); R2(B,C,D,A,p[14],23,0xfde5380c);
    R2(A,B,C,D,p[ 1], 4,0xa4beea44); R2(D,A,B,C,p[ 4],11,0x4bdecfa9);
    R2(C,D,A,B,p[ 7],16,0xf6bb4b60); R2(B,C,D,A,p[10],23,0xbebfbc70);
    R2(A,B,C,D,p[13], 4,0x289b7ec6); R2(D,A,B,C,p[ 0],11,0xeaa127fa);
    R2(C,D,A,B,p[ 3],16,0xd4ef3085); R2(B,C,D,A,p[ 6],23,0x04881d05);
    R2(A,B,C,D,p[ 9], 4,0xd9d4d039); R2(D,A,B,C,p[12],11,0xe6db99e5);
    R2(C,D,A,B,p[15],16,0x1fa27cf8); R2(B,C,D,A,p[ 2],23,0xc4ac5665);
    /* Round 3 */
    R3(A,B,C,D,p[ 0], 6,0xf4292244); R3(D,A,B,C,p[ 7],10,0x432aff97);
    R3(C,D,A,B,p[14],15,0xab9423a7); R3(B,C,D,A,p[ 5],21,0xfc93a039);
    R3(A,B,C,D,p[12], 6,0x655b59c3); R3(D,A,B,C,p[ 3],10,0x8f0ccc92);
    R3(C,D,A,B,p[10],15,0xffeff47d); R3(B,C,D,A,p[ 1],21,0x85845dd1);
    R3(A,B,C,D,p[ 8], 6,0x6fa87e4f); R3(D,A,B,C,p[15],10,0xfe2ce6e0);
    R3(C,D,A,B,p[ 6],15,0xa3014314); R3(B,C,D,A,p[13],21,0x4e0811a1);
    R3(A,B,C,D,p[ 4], 6,0xf7537e82); R3(D,A,B,C,p[11],10,0xbd3af235);
    R3(C,D,A,B,p[ 2],15,0x2ad7d2bb); R3(B,C,D,A,p[ 9],21,0xeb86d391);

    MD5_A += A;
    MD5_B += B;
    MD5_C += C;
    MD5_D += D;
}

void MD5_Update(unsigned char *data, int len)
{
    unsigned char *p = (unsigned char *)MD5_data;
/*
 * The full MD5 procedure allows for encoding strings of up to
 * around 2^64 bits. I will restrict myself to 2^32 so I can just ignore
 * the high word of the bit-count.
 */
    MD5_Nl += len<<3;   /* Counts in BITS not BYTES here */
    while (len != 0)
    {   p[MD5_num++] = *data++;
        len--;
        if (MD5_num == MD5_CBLOCK)
        {   md5_block();
            MD5_num = 0;
        }
    }
}

void MD5_Final(unsigned char *md)
{
    unsigned32 l = MD5_Nl;
    unsigned char *p = (unsigned char *)MD5_data;
    
    p[MD5_num++] = 0x80;
    if (MD5_num >= MD5_CBLOCK-8)
    {   while (MD5_num < MD5_CBLOCK) p[MD5_num++] = 0;
        md5_block();
        MD5_num = 0;
    }
    while (MD5_num < MD5_CBLOCK-8) p[MD5_num++] = 0;
    p[MD5_num++] = l;
    p[MD5_num++] = l>>8;
    p[MD5_num++] = l>>16;
    p[MD5_num++] = l>>24;
    p[MD5_num++] = 0;
    p[MD5_num++] = 0;
    p[MD5_num++] = 0;
    p[MD5_num++] = 0;
    md5_block();
    p = md;
    l = MD5_A; *p++ = l; *p++ = l>>8; *p++ = l>>16; *p++ = l>>24;
    l = MD5_B; *p++ = l; *p++ = l>>8; *p++ = l>>16; *p++ = l>>24;
    l = MD5_C; *p++ = l; *p++ = l>>8; *p++ = l>>16; *p++ = l>>24;
    l = MD5_D; *p++ = l; *p++ = l>>8; *p++ = l>>16; *p++ = l>>24;
    MD5_busy = NO;
}

unsigned char *MD5(unsigned char *d, int n, unsigned char *md)
{
    if (n < 0) n = strlen((char *)d);
    MD5_Init();
    MD5_Update(d, n);
    MD5_Final(md);
    return md;
}

#ifdef STAND_ALONE_TESTING_OF_MD5_CODE

int main(int argc, char *argv[])
{
    int i;
    unsigned char mm[16];
    MD5("", 0, mm);
    for (i=0; i<16; i++) printf("%.2x", mm[i] & 0xff);
    printf("\n");
    MD5("a", 1, mm);
    for (i=0; i<16; i++) printf("%.2x", mm[i] & 0xff);
    printf("\n");
    MD5("abc", 3, mm);
    for (i=0; i<16; i++) printf("%.2x", mm[i] & 0xff);
    printf("\n");
    MD5("message digest", -1, mm);
    for (i=0; i<16; i++) printf("%.2x", mm[i] & 0xff);
    printf("\n");
    MD5("abcdefghijklmnopqrstuvwxyz", -1, mm);
    for (i=0; i<16; i++) printf("%.2x", mm[i] & 0xff);
    printf("\n");
    MD5("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789", -1, mm);
    for (i=0; i<16; i++) printf("%.2x", mm[i] & 0xff);
    printf("\n");
    MD5("12345678901234567890123456789012345678901234567890123456789012345678901234567890", -1, mm);
    for (i=0; i<16; i++) printf("%.2x", mm[i] & 0xff);
    printf("\n");
    return 0;
}

#endif

/*
 * This is the end of the Eric Young code - what follows is Codemist
 * original code again.
 *
 *
 *
 * The next bit is for an experiment in controlling access to image files
 * etc.  It is solely intended for use in implementing this access control
 * and is not made available as something that a CSL/Reduce user can access
 * directly. It favours high speed above other things, and much of its
 * security in use will be based on nobody having a real incentive to
 * poke at it since CSL-based images will not be expected to be of
 * sufficient value to justify the effort.
 */



int crypt_active;
unsigned char *crypt_buffer;
int crypt_count;

/*
 * The following code was generated by running the program "gencry.c",
 * within which you can find the comments that explain what is going on. The
 * macro TIME_TEST could be defined to make this file more of a self-
 * contained test of its performance, but to do that you probably need
 * to look at the raw output from gencry.c.
 *
 * word length = 32
 * shift register length = 65
 * tap at position 18
 * shuffle-buffer size = 4096
 */

#ifdef TIME_TEST

#include <stdio.h>
#include <time.h>

#define N       10000000   /* parameters for time test */
#define NSTARTS 4000
#define NTINY   50000000
#define KEY     "Arthurs's sample key"

typedef unsigned int unsigned32;

#endif /* TIME_TEST */

static unsigned32 lf[65], mix[4096];

#define R(x) ((x) >> 20)
#define S(x) ((x) >> 18)
#define T(x) ((x) << 13)

/*
 * static unsigned char byte_order_test[] =
 * {1, 0, 0, 0, 0, 0, 0, 0};
 */

#define CRYPT_BLOCK_SIZE 128

void crypt_get_block(unsigned char block[CRYPT_BLOCK_SIZE])
{
    unsigned32 *b = (unsigned32 *)block;
    int n;
    lf[0] -= lf[18];     lf[1] ^= lf[19];
    lf[2] -= lf[20];     lf[3] += lf[21];
    lf[4] += lf[22];     lf[5] -= lf[23];
    lf[6] ^= lf[24];     lf[7] -= lf[25];
    lf[8] += lf[26];     lf[9] ^= lf[27];
    lf[10] -= lf[28];    lf[11] -= lf[29];
    lf[12] += lf[30];    lf[13] += lf[31];
    lf[14] -= lf[32];    lf[15] ^= lf[33];
    lf[16] -= lf[34];    lf[17] += lf[35];
    lf[18] += lf[36];    lf[19] += lf[37];
    lf[20] -= lf[38];    lf[21] -= lf[39];
    lf[22] ^= lf[40];    lf[23] += lf[41];
    lf[24] -= lf[42];    lf[25] -= lf[43];
    lf[26] += lf[44];    lf[27] += lf[45];
    lf[28] -= lf[46];    lf[29] ^= lf[47];
    lf[30] -= lf[48];    lf[31] += lf[49];
    lf[32] -= lf[50];    lf[33] ^= lf[51];
    lf[34] -= lf[52];    lf[35] ^= lf[53];
    lf[36] += lf[54];    lf[37] += lf[55];
    lf[38] ^= lf[56];    lf[39] ^= lf[57];
    lf[40] += lf[58];    lf[41] -= lf[59];
    lf[42] ^= lf[60];    lf[43] += lf[61];
    lf[44] += lf[62];    lf[45] ^= lf[63];
    lf[46] ^= lf[64];    lf[47] -= lf[0];
    lf[48] ^= lf[1];     lf[49] ^= lf[2];
    lf[50] ^= lf[3];     lf[51] ^= lf[4];
    lf[52] ^= lf[5];     lf[53] ^= lf[6];
    lf[54] += lf[7];     lf[55] -= lf[8];
    lf[56] -= lf[9];     lf[57] ^= lf[10];
    lf[58] -= lf[11];    lf[59] -= lf[12];
    lf[60] ^= lf[13];    lf[61] += lf[14];
    lf[62] ^= lf[15];    lf[63] -= lf[16];
    lf[64] -= lf[17];
    n = R(lf[0]); b[0] = mix[n]; mix[n] = (lf[54] + S(lf[29])) ^ T(lf[5]);
    n = R(lf[1]); b[1] = mix[n]; mix[n] = ~(lf[39] + S(lf[47])) + T(lf[15]);
    n = R(lf[2]); b[2] = mix[n]; mix[n] = (lf[25] + S(lf[14])) + T(lf[38]);
    n = R(lf[4]); b[3] = mix[n]; mix[n] = ~(lf[48] - S(lf[40])) ^ T(lf[10]);
    n = R(lf[5]); b[4] = mix[n]; mix[n] = (lf[44] - S(lf[55])) - T(lf[49]);
    n = R(lf[6]); b[5] = mix[n]; mix[n] = ~(lf[9] ^ S(lf[37])) + T(lf[50]);
    n = R(lf[8]); b[6] = mix[n]; mix[n] = (lf[64] ^ S(lf[51])) + T(lf[8]);
    n = R(lf[9]); b[7] = mix[n]; mix[n] = ~(lf[11] - S(lf[35])) - T(lf[21]);
    n = R(lf[10]); b[8] = mix[n]; mix[n] = (lf[20] ^ S(lf[21])) ^ T(lf[3]);
    n = R(lf[12]); b[9] = mix[n]; mix[n] = ~(lf[6] ^ S(lf[31])) - T(lf[61]);
    n = R(lf[13]); b[10] = mix[n]; mix[n] = (lf[3] - S(lf[16])) ^ T(lf[16]);
    n = R(lf[14]); b[11] = mix[n]; mix[n] = ~(lf[17] - S(lf[53])) - T(lf[2]);
    n = R(lf[16]); b[12] = mix[n]; mix[n] = (lf[27] + S(lf[42])) - T(lf[33]);
    n = R(lf[17]); b[13] = mix[n]; mix[n] = ~(lf[28] + S(lf[63])) - T(lf[46]);
    n = R(lf[18]); b[14] = mix[n]; mix[n] = (lf[10] - S(lf[46])) + T(lf[35]);
    n = R(lf[20]); b[15] = mix[n]; mix[n] = ~(lf[53] - S(lf[10])) - T(lf[27]);
    n = R(lf[21]); b[16] = mix[n]; mix[n] = (lf[4] + S(lf[18])) - T(lf[7]);
    n = R(lf[22]); b[17] = mix[n]; mix[n] = ~(lf[43] + S(lf[64])) ^ T(lf[45]);
    n = R(lf[24]); b[18] = mix[n]; mix[n] = (lf[14] + S(lf[26])) + T(lf[44]);
    n = R(lf[25]); b[19] = mix[n]; mix[n] = ~(lf[23] ^ S(lf[38])) + T(lf[58]);
    n = R(lf[26]); b[20] = mix[n]; mix[n] = (lf[47] + S(lf[59])) ^ T(lf[47]);
    n = R(lf[28]); b[21] = mix[n]; mix[n] = ~(lf[63] - S(lf[36])) - T(lf[57]);
    n = R(lf[29]); b[22] = mix[n]; mix[n] = (lf[56] + S(lf[4])) + T(lf[19]);
    n = R(lf[30]); b[23] = mix[n]; mix[n] = ~(lf[42] - S(lf[52])) - T(lf[56]);
    n = R(lf[32]); b[24] = mix[n]; mix[n] = (lf[37] + S(lf[3])) - T(lf[63]);
    n = R(lf[33]); b[25] = mix[n]; mix[n] = ~(lf[32] + S(lf[1])) - T(lf[12]);
    n = R(lf[34]); b[26] = mix[n]; mix[n] = (lf[62] - S(lf[39])) - T(lf[31]);
    n = R(lf[36]); b[27] = mix[n]; mix[n] = ~(lf[2] ^ S(lf[44])) ^ T(lf[18]);
    n = R(lf[37]); b[28] = mix[n]; mix[n] = (lf[24] ^ S(lf[50])) ^ T(lf[55]);
    n = R(lf[38]); b[29] = mix[n]; mix[n] = ~(lf[22] + S(lf[27])) - T(lf[32]);
    n = R(lf[40]); b[30] = mix[n]; mix[n] = (lf[51] + S(lf[33])) + T(lf[0]);
    n = R(lf[41]); b[31] = mix[n]; mix[n] = ~(lf[52] ^ S(lf[19])) - T(lf[26]);
    n = R(lf[42]); mix[n] = (lf[5] ^ S(lf[41])) + T(lf[28]);
    n = R(lf[44]); mix[n] = ~(lf[30] ^ S(lf[15])) - T(lf[30]);
    n = R(lf[45]); mix[n] = (lf[45] + S(lf[24])) ^ T(lf[51]);
    n = R(lf[46]); mix[n] = ~(lf[13] + S(lf[49])) - T(lf[11]);
    n = R(lf[48]); mix[n] = (lf[16] + S(lf[11])) - T(lf[39]);
    n = R(lf[49]); mix[n] = ~(lf[57] - S(lf[43])) - T(lf[60]);
    n = R(lf[50]); mix[n] = (lf[49] + S(lf[48])) ^ T(lf[25]);
    n = R(lf[52]); mix[n] = ~(lf[34] - S(lf[22])) ^ T(lf[23]);
    n = R(lf[53]); mix[n] = (lf[18] + S(lf[6])) + T(lf[1]);
    n = R(lf[54]); mix[n] = ~(lf[29] + S(lf[61])) - T(lf[64]);
    n = R(lf[56]); mix[n] = (lf[59] ^ S(lf[45])) - T(lf[41]);
    n = R(lf[57]); mix[n] = ~(lf[36] - S(lf[32])) + T(lf[37]);
    n = R(lf[58]); mix[n] = (lf[40] + S(lf[60])) + T(lf[14]);
    n = R(lf[60]); mix[n] = ~(lf[1] + S(lf[56])) ^ T(lf[36]);
    n = R(lf[61]); mix[n] = (lf[8] ^ S(lf[5])) ^ T(lf[17]);
    n = R(lf[62]); mix[n] = ~(lf[31] ^ S(lf[17])) ^ T(lf[52]);
/* The test this way around favours Intel etc byte order */
    if (((unsigned int *)byte_order_test)[0] != 1)
    {   int i;
        for (i=0; i<32; i++)
        {   unsigned32 w = b[i];
            unsigned32 b0, b1, b2, b3;
            b0 = (w >> 24) & 0xffU;
            b1 = (w >> 8) & 0xff00U;
            b2 = (w << 8) & 0xff0000U;
            b3 = (w << 24) & 0xff000000U;
            b[i] = b0 | b1 | b2 | b3;
        }
    }
    return;
}

void crypt_init(char *key)
{
    char *pk = key;
    unsigned char junk[CRYPT_BLOCK_SIZE];
    int i, j;
    unsigned32 w = 0;
    for (i=0; i<260; i++)
    {   int k = *pk++;
        if (k == 0) pk = key;  /* Cycle key (inc. terminating 0) */
        w = (w << 8) | (k & 0xff);
        if ((i % 4) == 3) lf[i/4] = w;
    }
    for (i=0; i<4096; i++) mix[i] = 0;
    for (i=0; i<8; i++)
    {   for (j=0; j<65; j++)
            lf[j] = (lf[j] << 10) | (lf[j] >> 22);
        lf[0] |= 1;
        for (j=0; j<64; j++)
            crypt_get_block(junk);
    }
    for (i=0; i<4096;)
    {   int j;
        crypt_get_block(junk);
        for (j=0; j<32; j++)
        {   unsigned32 r = junk[4*j];
            r = (r << 8) | junk[4*j+1];
            r = (r << 8) | junk[4*j+2];
            r = (r << 8) | junk[4*j+3];
            if (r == 0) continue;
            mix[i++] ^= junk[j];
            if (i == 4096) break;
        }
    }
    for (i=0; i<192; i++)
        crypt_get_block(junk);
    return;
}

#ifdef TIME_TEST
/*
 * The main program here does not do anything of real interest. It
 * runs both the key-setup and the main loop lots of times and reports
 * how long it all takes.
 *
 * Here is some sample output from a Pentium-II 400Mhz system
 *
 * [02faf080] 7.60 nanoseconds to do tiny loop
 * 1.25 milliseconds to startup
 * rate = 104.86 megabytes per second
 * 79 a7 e1 52 2e 84 09 ce d0 3d 45 b2 52 2d b6 c7
 * 9b ee 57 25 68 58 b7 44 42 51 1c c7 de 69 0f 89
 * 98 6c cd 45 e0 a1 d4 04 a3 be 3d 5f 93 64 c9 d9
 * b9 47 28 59 d0 99 5a 35 56 fd 89 e6 48 4f a4 88
 * 7e dd 31 76 2b 8e 96 fa d0 6f d7 30 9c 3c 01 97
 * 8a 54 93 c0 02 1d 26 df 31 2b 7b 92 56 51 fa 47
 * 92 13 39 47 45 d2 b5 33 2b f6 cc 62 ec 73 00 40
 * 66 ab 37 f5 1d 21 3a a9 b8 da 35 ac 04 f1 3b 53
 *
 */

int main(int argc, char *argv[])
{
    clock_t c0, c1;
    unsigned char r[CRYPT_BLOCK_SIZE];
    int i, j = 0;
    double rate;
    c0 = clock();
    for (i=0; i<(NTINY+1); i++) j ^= i;
    c1 = clock();
    printf("[%.8x] %.2f nanoseconds to do tiny loop\n", j,
       1.0e9*(double)(c1-c0)/((double)CLOCKS_PER_SEC*(double)(NTINY+1)));
    c0 = clock();
    for (i=0; i<NSTARTS; i++) crypt_init(KEY);
    c1 = clock();
    printf("%.2f milliseconds to startup\n",
       1000.0*(double)(c1-c0)/((double)CLOCKS_PER_SEC*(double)NSTARTS));
    c0 = clock();
    for (i=0; i<N; i++) crypt_get_block(r);
    c1 = clock();
    rate = (double)N*(double)CRYPT_BLOCK_SIZE*(double)CLOCKS_PER_SEC/
           ((double)(c1-c0)*1.0e6);
    printf("rate = %.2f megabytes per second\n", rate);
    for (i=0; i<128; i++)
    {   printf("%.2x ", r[i]);
        if ((i % 16) == 15) printf("\n");
    }
    return 0;
}

#endif /* TIME_TEST */

#undef R
#undef S
#undef T

/* End of generated code... */

static void get_checksum(const setup_type *p)
{
    while (p->name!=NULL) p++;
    if (p->one != NULL && p->two != NULL)
    {   unsigned char *w = (unsigned char *)p->two;
        MD5_Update(w, strlen((char *)w));
    }
}

void get_user_files_checksum(unsigned char *b)
{
    MD5_Init();
    get_checksum(u01_setup);
    get_checksum(u02_setup);
    get_checksum(u03_setup);
    get_checksum(u04_setup);
    get_checksum(u05_setup);
    get_checksum(u06_setup);
    get_checksum(u07_setup);
    get_checksum(u08_setup);
    get_checksum(u09_setup);
    get_checksum(u10_setup);
    get_checksum(u11_setup);
    get_checksum(u12_setup);
    MD5_Final(b);
}

char *crypt_keys[CRYPT_KEYS];

void setup(int restartp, double store_size)
{
    int i;
    Lisp_Object nil;
#ifdef TIME_TEST_CRYPTO
/* *********** Now I will time my encryption stuff... ************* */
    clock_t t0 = clock(), t1;
#define TRIALS 2000
    for (i=0; i<TRIALS; i++) crypt_init("Arthur\'s secret key");
    t1 = clock();
    term_printf("Time for crypt_init = %.2g milliseconds\n",
        1.0e3*((double)(t1-t0))/(double)CLOCKS_PER_SEC/(double)TRIALS);
#define TRIALS1 1000000
    {   unsigned char buffer[CRYPT_BLOCK];
        t0 = clock();
        for (i=0; i<TRIALS1; i++) crypt_get_block(buffer);
        t1 = clock();
    }
    {   double Mbytes = (double)TRIALS1*(double)CRYPT_BLOCK/1000000.0;
        double seconds = (double)(t1-t0)/(double)CLOCKS_PER_SEC;
        term_printf("Time to do 1 Mbyte = %.2g seconds\n", seconds/Mbytes);
        term_printf("Ie %.4g Mbytes per sec\n", Mbytes/seconds);
    }
/* **************** end of temp gunk ***************** */
#endif
    crypt_active = -1;

#ifdef DEBUG
/*
 * Just a sanity check so that if I add entries in this table but to
 * not change the recorded size I will be warned.
 */
    if ((entry_table_size+1)*sizeof(entry_point) != sizeof(entries_table))
    {   term_printf("entry_table_size badly set up in externs.h\n");
        my_exit(EXIT_FAILURE);
    }
    if (sizeof(int32) != 4 ||
        sizeof(unsigned32) != 4 ||
#ifdef SIXTY_FOUR_BIT
        sizeof(int64) != 8 ||
        sizeof(unsigned64) != 8 ||
#endif
#ifndef ILP64
        sizeof(int16) != 2 ||
        sizeof(unsigned16) != 2 ||
#endif
        sizeof(int8) != 1 ||
        sizeof(unsigned8) != 1)
    {   term_printf("Some datatype size is wrongly set up in tags.h\n");
        my_exit(EXIT_FAILURE);
    }
#endif

    if (restartp & 2) init_heap_segments(store_size);
    restartp &= 1;
    nil = C_nil;
#ifdef TIDY_UP_MEMORY_AT_START
/*
 * The following should not be needed, feature on big machines could be
 * expensive.  The code is left in case it helps with repeatability in
 * the face of accesses to uninitialised locations (ie BUGS)
 */
    for (i=0; i<pages_count; i++)
        memset(pages[i], 0, (size_t)CSL_PAGE_SIZE+8);
    memset(stacksegment, 0, (size_t)stack_segsize*CSL_PAGE_SIZE+8);
    memset(nilsegment, 0, (size_t)NIL_SEGMENT_SIZE);
#endif
    stack = stackbase;
    exit_tag = exit_value = nil;
    exit_reason = UNWIND_NULL;

    if (restartp & 1)
    {   char junkbuf[120];
        char filename[LONGEST_LEGAL_FILENAME];
        if (IopenRoot(filename, 0))
        {   term_printf("\n+++ Image file \"%s\" can not be read\n",
                    filename);
            my_exit(EXIT_FAILURE);
        }
/*
 * I read input via a buffer of size FREAD_BUFFER_SIZE, which I pre-fill
 * at this stage before I even try to read anything
 */
        fread_ptr = (unsigned char *)stack;
        fread_count = Iread(fread_ptr, FREAD_BUFFER_SIZE);
/*
 * I can adjust here (automatically) for whatever compression threshold
 * had been active when the image file was created.
 */
        compression_worth_while = 128;
        crypt_active = -1;
        Cfread(junkbuf, 112);
        {   int fg = junkbuf[111];
            while (fg != 0) compression_worth_while <<= 1, fg--;
            fg = junkbuf[110];
            while (fg != 0) crypt_active++, fg--;
            if (crypt_active >= 0 &&
                crypt_active < CRYPT_KEYS &&
                crypt_keys[crypt_active] != NULL)
            {   crypt_init(crypt_keys[crypt_active]);
                if ((crypt_buffer = 
                       (unsigned char *)malloc(CRYPT_BLOCK))
                     == NULL) crypt_active = -1; /* And will then fail */
                crypt_count = 0;
            }
        }
        if (init_flags & INIT_VERBOSE)
        {   term_printf("Created: %.25s\n", &junkbuf[64]);
            /* Time dump was taken */
        }
        {   unsigned char chk[16];
            get_user_files_checksum(chk);
            for (i=0; i<16; i++)
            {   if (chk[i] != (junkbuf[90+i] & 0xff))
                {   term_printf(
                        "\n+++ Image file belongs with a different version\n");
                    term_printf(
                        "    of the executable file (incompatible code\n");
                    term_printf(
                        "    has been optimised into C and incorporated)\n");
                    term_printf(
                        "    Unable to use this image file, so stopping\n");
                    my_exit(EXIT_FAILURE);
                }
            }
        }
/*
 * To make things more responsive for the user I will display a
 * banner rather early (before reading the bulk of the image file).
 * The banner that I will display is one provided to be by PRESERVE.
 */
        {   Ihandle save;
            char b[64];
            int i;
            Icontext(&save);
#define BANNER_CODE (-1002)
            if (IopenRoot(filename, BANNER_CODE)) b[0] = 0;
            else
            {   for (i=0; i<64; i++) b[i] = Igetc();
                IcloseInput(NO);
            }
            Irestore_context(save);
/*
 * A banner set via startup-banner takes precedence over one from preserve.
 */
            if (b[0] != 0)
            {   term_printf("%s\n", b);
                ensure_screen();
            }
            else if (junkbuf[0] != 0)
            {   term_printf("%s\n", junkbuf);
                ensure_screen();
            }
        }
#ifdef PREVIOUS_ATTEMPT_AT_AUTHENTICATION
        {   char username[48];
            unsigned char sig[16];
            unsigned32 hash;
            int c1;
            unsigned char *s = &registration_data[4];
            MD5_Update(s, 48);
            MD5_Final(sig);
            if (memcmp(sig, &s[48], 16) != 0)
            {   term_printf("************************************\n");
                term_printf("* Registration data seems corrupt  *\n");
                term_printf("* Please check with your supplier. *\n");
                term_printf("************************************\n");
/*
 * If I were really feeling confident - or possibly mean - I would
 * just exit from the system here declaring that my consistency check
 * had failed and that hence there was a presumption that somebody had
 * tried to patch or otherwise bodge my registration-name code. At least for
 * a few weeks I will not go that far, and I will expect that the annoying
 * message above will do quite enough. The real security that I can enforce
 * is pretty low anyway, and so overall I believe that the policy adopted
 * here is probably adequate.
 */
            }
            else
            {   hash = *s++;
                hash |= *s++<<8;
                hash |= *s++<<16;
                hash |= *s++<<24;
                for (c1=0;c1<44;c1++)
                {   hash = 69069*hash + 314159;
                    username[c1] = *s++ ^ (hash >> 16);
                }
                while (c1 > 0 && username[--c1] == ' ') username[c1] = 0;
                term_printf("Registered to: %s\n", username);
            }
        }
#endif /* AUTHORIZATION */
/*
 * From here on if crypt_active is >= 0 I will be decoding an encrypted
 * image file.
 */
        Cfread(junkbuf, 8);
        Cfread((char *)nil, sizeof(Lisp_Object)*last_nil_offset);
        copy_out_of_nilseg(YES);
#ifndef COMMON
        qheader(nil) = TAG_ODDS+TYPE_SYMBOL+SYM_SPECIAL_VAR;/* BEFORE nil... */
#endif
        if ((byteflip & 0xffff0000U) == 0x56780000U)
        {   flip_needed = NO;
            old_fp_rep = (int)(byteflip & FP_MASK);
            old_page_bits = (int)((byteflip >> 8) & 0x1f);
        }
        else if ((byteflip & 0x0000ffffU) == 0x00007856U)
        {   flip_needed = YES;
            old_fp_rep = (int)(flip_bytes_fn(byteflip) & FP_MASK);
            old_page_bits = (int)((flip_bytes_fn(byteflip) >> 8) & 0x1f);
        }
        else
        {   term_printf("\n+++ The checkpoint file is corrupt\n");
/*
 * Note: I use different numbers to check byte-ordering on segmented feature
 * non-segmented systems, since the heap image formats are not compatible.
 * A result will be that use of the wrong sort of image will lead to a
 * "checkpoint file corrupt" message rather than a more serious shambles.
 */
            my_exit(EXIT_FAILURE);
        }
        if (old_page_bits == 0) old_page_bits = 16; /* Old default value */
/*
 * I could in fact recover in the case that old_page_bits < PAGE_BITS, since
 * I could just map the old small pages into the new big ones with a little
 * padding where needed.  I will not do that JUST yet.  In general it will
 * not be possible to load an image with large pages into a CSL that only
 * has small ones - eg there might be some vector that just would not fit
 * in the small page size.  Even discounting that worry rearranging the
 * heap to allow for the discontinuities at the smaller page granularity would
 * be pretty painful.  Again in the limit something very much akin to the
 * normal garbage collector could probably do it if it ever became really
 * necessary.
 */
        if (old_page_bits != PAGE_BITS)
        {   term_printf("\n+++ The checkpoint file was made on a machine\n");
            term_printf("where CSL had been configured with a different page\n");
            term_printf("size. It is not usable with this version.\n");
            my_exit(EXIT_FAILURE);
        }
        /* The saved value of NIL is not needed in this case */
    }
    else
    {
        for (i=first_nil_offset; i<last_nil_offset; i++)
             ((Lisp_Object *)nil)[i] = nil;
        copy_out_of_nilseg(NO);
    }

    stacklimit = &stack[stack_segsize*CSL_PAGE_SIZE/4-200]; 
                 /* allow some slop at end */
    byteflip = 0x56780000 |
               ((int32)current_fp_rep & ~FP_WORD_ORDER) |
               (((int32)PAGE_BITS) << 8);
    native_pages_changed = 0;
    if (restartp) warm_setup();
    else cold_setup();


    if (init_flags & INIT_QUIET) Lverbos(nil, fixnum_of_int(1));
    if (init_flags & INIT_VERBOSE) Lverbos(nil, fixnum_of_int(3));
#ifndef HOLD_BACK_MEMORY
/*
 * Here I grab more memory (if I am allowed to) until the proportion of the
 * heap active at the end of garbage collection is less than 1/2.  If the
 * attempt to grab more memory fails I clear the bit in init_flags that
 * allows me to try to expand, so I will not waste time again.  If
 * HOLD_BACK_MEMORY was asserted (for machines where grabbing all seemingly
 * available memory may cause a crash) I do not try this operation.  The
 * aim of keeping the heap less than half full is an heuristic and could be
 * adjusted on the basis of experience with this code.
 */
    if (init_flags & INIT_EXPANDABLE)
    {   int32 more = heap_pages_count + vheap_pages_count +
                     bps_pages_count + native_pages_count;
        more = 3 *more - pages_count;
        while (more-- > 0)
        {   void *page = (void *)my_malloc_1((size_t)(CSL_PAGE_SIZE + 8));
/*
 * CF the code in gc.c -- I can still use my_malloc_1 here, which makes this
 * code just a tiny bit safer.
 */
            int32 pun = (int32)page;
            int32 pun1 = (int32)((char *)page + CSL_PAGE_SIZE + 8);
            if ((pun ^ pun1) < 0) page = NULL;
#ifdef ADDRESS_SIGN_UNKNOWN
            if ((pun + address_sign) < 0) page = NULL;
#else
#ifdef ADDRESSES_HAVE_TOP_BIT_SET
            if (pun > 0) page = NULL;
#else
            if (pun < 0) page = NULL;
#endif
#endif
            if (page == NULL)
            {   init_flags &= ~INIT_EXPANDABLE;
                break;
            }
            else pages[pages_count++] = page;
        }
    }
#endif
    {
      int32 w = 0;
#ifndef NO_COPYING_GC
/*
 * I will make the first garbage collection a copying one if the heap is
 * at most 25% full, or a sliding one if it is more full than that.
 */
      w = heap_pages_count + vheap_pages_count +
          bps_pages_count + native_pages_count;
      gc_method = (pages_count > 3*w);
#endif
/*
 * The total store allocated is that used plus that free, including the
 * page set aside for the Lisp stack.
 */
        if (init_flags & INIT_VERBOSE)
            term_printf("Memory allocation: %ld bytes\n",
                                         (long)CSL_PAGE_SIZE*(pages_count+w+1));
    }
#ifdef MEMORY_TRACE
    memory_comment(15);
#endif
    return;
}

void copy_into_nilseg(int fg)
{
    int i;
    Lisp_Object nil = C_nil;

#ifdef NILSEG_EXTERNS
    if (fg)     /* move non list bases too */
    {   ((unsigned32 *)nil)[12]                 = byteflip;
        ((Lisp_Object *)nil)[13]                = codefringe;
        ((Lisp_Object volatile *)nil)[14]       = codelimit;
/*
 * The messing around here is to ensure that on 64-bit architectures
 * stacklimit is kept properly aligned.
 */
#ifdef COMMON
        *(Lisp_Object * volatile *)&((Lisp_Object *)nil)[16] = stacklimit;
#else
        *(Lisp_Object * volatile *)&((Lisp_Object *)nil)[15] = stacklimit;
#endif
        ((Lisp_Object *)nil)[18]                = fringe;
        ((Lisp_Object volatile *)nil)[19]       = heaplimit;
        ((Lisp_Object volatile *)nil)[20]       = vheaplimit;
        ((Lisp_Object *)nil)[21]                = vfringe;
        ((unsigned32 *)nil)[22]                 = miscflags;

        ((int32 *)nil)[24]                      = nwork;
        ((int32 *)nil)[25]                      = exit_reason;
        ((int32 *)nil)[26]                      = exit_count;
        ((unsigned32 *)nil)[27]                 = gensym_ser;
        ((unsigned32 *)nil)[28]                 = print_precision;
        ((int32 *)nil)[29]                      = current_modulus;
        ((int32 *)nil)[30]                      = fastget_size;
        ((int32 *)nil)[31]                      = package_bits;
    }
/*
 * Entries 50 and 51 are used for chains of hash tables, and so get
 * very special individual treatment.
 */
    ((Lisp_Object *)nil)[52]     = current_package;
    ((Lisp_Object *)nil)[53]     = B_reg;
    ((Lisp_Object *)nil)[54]     = codevec;
    ((Lisp_Object *)nil)[55]     = litvec;
    ((Lisp_Object *)nil)[56]     = exit_tag;
    ((Lisp_Object *)nil)[57]     = exit_value;
    ((Lisp_Object *)nil)[58]     = catch_tags;
    ((Lisp_Object *)nil)[59]     = lisp_package;
    ((Lisp_Object *)nil)[60]     = boffo;
    ((Lisp_Object *)nil)[61]     = charvec;
    ((Lisp_Object *)nil)[62]     = sys_hash_table;
    ((Lisp_Object *)nil)[63]     = help_index;
    ((Lisp_Object *)nil)[64]     = gensym_base;
    ((Lisp_Object *)nil)[65]     = err_table;
    ((Lisp_Object *)nil)[66]     = supervisor;
    ((Lisp_Object *)nil)[67]     = startfn;
    ((Lisp_Object *)nil)[68]     = faslvec;
    ((Lisp_Object *)nil)[69]     = tracedfn;
    ((Lisp_Object *)nil)[70]     = prompt_thing;
    ((Lisp_Object *)nil)[71]     = faslgensyms;
    ((Lisp_Object *)nil)[72]     = cl_symbols;
    ((Lisp_Object *)nil)[73]     = active_stream;
    ((Lisp_Object *)nil)[74]     = current_module;

    ((Lisp_Object *)nil)[90]     = append_symbol;
    ((Lisp_Object *)nil)[91]     = applyhook;
    ((Lisp_Object *)nil)[92]     = cfunarg;
    ((Lisp_Object *)nil)[93]     = comma_at_symbol;
    ((Lisp_Object *)nil)[94]     = comma_symbol;
    ((Lisp_Object *)nil)[95]     = compiler_symbol;
    ((Lisp_Object *)nil)[96]     = comp_symbol;
    ((Lisp_Object *)nil)[97]     = cons_symbol;
    ((Lisp_Object *)nil)[98]     = echo_symbol;
    ((Lisp_Object *)nil)[99]     = emsg_star;
    ((Lisp_Object *)nil)[100]    = evalhook;
    ((Lisp_Object *)nil)[101]    = eval_symbol;
    ((Lisp_Object *)nil)[102]    = expr_symbol;
    ((Lisp_Object *)nil)[103]    = features_symbol;
    ((Lisp_Object *)nil)[104]    = fexpr_symbol;
    ((Lisp_Object *)nil)[105]    = funarg;
    ((Lisp_Object *)nil)[106]    = function_symbol;
    ((Lisp_Object *)nil)[107]    = lambda;
    ((Lisp_Object *)nil)[108]    = lisp_true;
    ((Lisp_Object *)nil)[109]    = lower_symbol;
    ((Lisp_Object *)nil)[110]    = macroexpand_hook;
    ((Lisp_Object *)nil)[111]    = macro_symbol;
    ((Lisp_Object *)nil)[112]    = opt_key;
    ((Lisp_Object *)nil)[113]    = prinl_symbol;
    ((Lisp_Object *)nil)[114]    = progn_symbol;
    ((Lisp_Object *)nil)[115]    = quote_symbol;
    ((Lisp_Object *)nil)[116]    = raise_symbol;
    ((Lisp_Object *)nil)[117]    = redef_msg;
    ((Lisp_Object *)nil)[118]    = rest_key;
    ((Lisp_Object *)nil)[119]    = savedef;
    ((Lisp_Object *)nil)[120]    = string_char_sym;
    ((Lisp_Object *)nil)[121]    = unset_var;
    ((Lisp_Object *)nil)[122]    = work_symbol;
    ((Lisp_Object *)nil)[123]    = lex_words;
    ((Lisp_Object *)nil)[124]    = get_counts;
    ((Lisp_Object *)nil)[125]    = fastget_names;
    ((Lisp_Object *)nil)[126]    = input_libraries;
    ((Lisp_Object *)nil)[127]    = output_library;
    ((Lisp_Object *)nil)[128]    = current_file;
    ((Lisp_Object *)nil)[129]    = break_function;

    ((Lisp_Object *)nil)[130]    = lisp_work_stream;
    ((Lisp_Object *)nil)[131]    = lisp_standard_output;
    ((Lisp_Object *)nil)[132]    = lisp_standard_input;
    ((Lisp_Object *)nil)[133]    = lisp_debug_io;
    ((Lisp_Object *)nil)[134]    = lisp_error_output;
    ((Lisp_Object *)nil)[135]    = lisp_query_io;
    ((Lisp_Object *)nil)[136]    = lisp_terminal_io;
    ((Lisp_Object *)nil)[137]    = lisp_trace_output;
    ((Lisp_Object *)nil)[138]    = standard_output;
    ((Lisp_Object *)nil)[139]    = standard_input;
    ((Lisp_Object *)nil)[140]    = debug_io;
    ((Lisp_Object *)nil)[141]    = error_output;
    ((Lisp_Object *)nil)[142]    = query_io;
    ((Lisp_Object *)nil)[143]    = terminal_io;
    ((Lisp_Object *)nil)[144]    = trace_output;
    ((Lisp_Object *)nil)[145]    = fasl_stream;
    ((Lisp_Object *)nil)[146]    = native_code;
    ((Lisp_Object *)nil)[147]    = native_symbol;
    ((Lisp_Object *)nil)[148]    = traceprint_symbol;
    ((Lisp_Object *)nil)[149]    = loadsource_symbol;
    ((Lisp_Object *)nil)[150]    = hankaku_symbol;

#ifdef COMMON
    ((Lisp_Object *)nil)[170]    = keyword_package;
    ((Lisp_Object *)nil)[171]    = all_packages;
    ((Lisp_Object *)nil)[172]    = package_symbol;
    ((Lisp_Object *)nil)[173]    = internal_symbol;
    ((Lisp_Object *)nil)[174]    = external_symbol;
    ((Lisp_Object *)nil)[175]    = inherited_symbol;
    ((Lisp_Object *)nil)[176]    = key_key;
    ((Lisp_Object *)nil)[177]    = allow_other_keys;
    ((Lisp_Object *)nil)[178]    = aux_key;
    ((Lisp_Object *)nil)[179]    = format_symbol;
    ((Lisp_Object *)nil)[180]    = expand_def_symbol;
    ((Lisp_Object *)nil)[181]    = allow_key_key;
    ((Lisp_Object *)nil)[182]    = declare_symbol;
    ((Lisp_Object *)nil)[183]    = special_symbol;
#endif

    for (i=0; i<=50; i++)
        ((Lisp_Object *)nil)[work_0_offset+i]   = workbase[i];
#endif /* NILSEG_EXTERNS */
    ((Lisp_Object *)nil)[190]    = user_base_0;
    ((Lisp_Object *)nil)[191]    = user_base_1;
    ((Lisp_Object *)nil)[192]    = user_base_2;
    ((Lisp_Object *)nil)[193]    = user_base_3;
    ((Lisp_Object *)nil)[194]    = user_base_4;
    ((Lisp_Object *)nil)[195]    = user_base_5;
    ((Lisp_Object *)nil)[196]    = user_base_6;
    ((Lisp_Object *)nil)[197]    = user_base_7;
    ((Lisp_Object *)nil)[198]    = user_base_8;
    ((Lisp_Object *)nil)[199]    = user_base_9;

}

void copy_out_of_nilseg(int fg)
{
    int i;
    Lisp_Object nil = C_nil;

#ifdef NILSEG_EXTERNS
    if (fg)
    {
        byteflip         = ((unsigned32 *)nil)[12];
        codefringe       = ((Lisp_Object *)nil)[13];
        codelimit        = ((Lisp_Object volatile *)nil)[14];
#ifdef COMMON
        stacklimit       = *(Lisp_Object *volatile *)&((Lisp_Object *)nil)[16];
#else
        stacklimit       = *(Lisp_Object *volatile *)&((Lisp_Object *)nil)[15];
#endif
        fringe           = ((Lisp_Object *)nil)[18];
        heaplimit        = ((Lisp_Object volatile *)nil)[19];
        vheaplimit       = ((Lisp_Object volatile *)nil)[20];
        vfringe          = ((Lisp_Object *)nil)[21];
        miscflags        = ((unsigned32 *)nil)[22];

        nwork            = ((int32 *)nil)[24];
        exit_reason      = ((int32 *)nil)[25];
        exit_count       = ((int32 *)nil)[26];
        gensym_ser       = ((unsigned32 *)nil)[27];
        print_precision  = ((unsigned32 *)nil)[28];
        current_modulus  = ((int32 *)nil)[29];
        fastget_size     = ((int32 *)nil)[30];
        package_bits     = ((int32 *)nil)[31];
    }

    current_package       = ((Lisp_Object *)nil)[52];
    B_reg                 = ((Lisp_Object *)nil)[53];
    codevec               = ((Lisp_Object *)nil)[54];
    litvec                = ((Lisp_Object *)nil)[55];
    exit_tag              = ((Lisp_Object *)nil)[56];
    exit_value            = ((Lisp_Object *)nil)[57];
    catch_tags            = ((Lisp_Object *)nil)[58];
    lisp_package          = ((Lisp_Object *)nil)[59];
    boffo                 = ((Lisp_Object *)nil)[60];
    charvec               = ((Lisp_Object *)nil)[61];
    sys_hash_table        = ((Lisp_Object *)nil)[62];
    help_index            = ((Lisp_Object *)nil)[63];
    gensym_base           = ((Lisp_Object *)nil)[64];
    err_table             = ((Lisp_Object *)nil)[65];
    supervisor            = ((Lisp_Object *)nil)[66];
    startfn               = ((Lisp_Object *)nil)[67];
    faslvec               = ((Lisp_Object *)nil)[68];
    tracedfn              = ((Lisp_Object *)nil)[69];
    prompt_thing          = ((Lisp_Object *)nil)[70];
    faslgensyms           = ((Lisp_Object *)nil)[71];
    cl_symbols            = ((Lisp_Object *)nil)[72];
    active_stream         = ((Lisp_Object *)nil)[73];
    current_module        = ((Lisp_Object *)nil)[74];

    append_symbol         = ((Lisp_Object *)nil)[90];
    applyhook             = ((Lisp_Object *)nil)[91];
    cfunarg               = ((Lisp_Object *)nil)[92];
    comma_at_symbol       = ((Lisp_Object *)nil)[93];
    comma_symbol          = ((Lisp_Object *)nil)[94];
    compiler_symbol       = ((Lisp_Object *)nil)[95];
    comp_symbol           = ((Lisp_Object *)nil)[96];
    cons_symbol           = ((Lisp_Object *)nil)[97];
    echo_symbol           = ((Lisp_Object *)nil)[98];
    emsg_star             = ((Lisp_Object *)nil)[99];
    evalhook              = ((Lisp_Object *)nil)[100];
    eval_symbol           = ((Lisp_Object *)nil)[101];
    expr_symbol           = ((Lisp_Object *)nil)[102];
    features_symbol       = ((Lisp_Object *)nil)[103];
    fexpr_symbol          = ((Lisp_Object *)nil)[104];
    funarg                = ((Lisp_Object *)nil)[105];
    function_symbol       = ((Lisp_Object *)nil)[106];
    lambda                = ((Lisp_Object *)nil)[107];
    lisp_true             = ((Lisp_Object *)nil)[108];
    lower_symbol          = ((Lisp_Object *)nil)[109];
    macroexpand_hook      = ((Lisp_Object *)nil)[110];
    macro_symbol          = ((Lisp_Object *)nil)[111];
    opt_key               = ((Lisp_Object *)nil)[112];
    prinl_symbol          = ((Lisp_Object *)nil)[113];
    progn_symbol          = ((Lisp_Object *)nil)[114];
    quote_symbol          = ((Lisp_Object *)nil)[115];
    raise_symbol          = ((Lisp_Object *)nil)[116];
    redef_msg             = ((Lisp_Object *)nil)[117];
    rest_key              = ((Lisp_Object *)nil)[118];
    savedef               = ((Lisp_Object *)nil)[119];
    string_char_sym       = ((Lisp_Object *)nil)[120];
    unset_var             = ((Lisp_Object *)nil)[121];
    work_symbol           = ((Lisp_Object *)nil)[122];
    lex_words             = ((Lisp_Object *)nil)[123];
    get_counts            = ((Lisp_Object *)nil)[124];
    fastget_names         = ((Lisp_Object *)nil)[125];
    input_libraries       = ((Lisp_Object *)nil)[126];
    output_library        = ((Lisp_Object *)nil)[127];
    current_file          = ((Lisp_Object *)nil)[128];
    break_function        = ((Lisp_Object *)nil)[129];

    lisp_work_stream      = ((Lisp_Object *)nil)[130];
    lisp_standard_output  = ((Lisp_Object *)nil)[131];
    lisp_standard_input   = ((Lisp_Object *)nil)[132];
    lisp_debug_io         = ((Lisp_Object *)nil)[133];
    lisp_error_output     = ((Lisp_Object *)nil)[134];
    lisp_query_io         = ((Lisp_Object *)nil)[135];
    lisp_terminal_io      = ((Lisp_Object *)nil)[136];
    lisp_trace_output     = ((Lisp_Object *)nil)[137];
    standard_output       = ((Lisp_Object *)nil)[138];
    standard_input        = ((Lisp_Object *)nil)[139];
    debug_io              = ((Lisp_Object *)nil)[140];
    error_output          = ((Lisp_Object *)nil)[141];
    query_io              = ((Lisp_Object *)nil)[142];
    terminal_io           = ((Lisp_Object *)nil)[143];
    trace_output          = ((Lisp_Object *)nil)[144];
    fasl_stream           = ((Lisp_Object *)nil)[145];
    native_code           = ((Lisp_Object *)nil)[146];
    native_symbol         = ((Lisp_Object *)nil)[147];
    traceprint_symbol     = ((Lisp_Object *)nil)[148];
    loadsource_symbol     = ((Lisp_Object *)nil)[149];
    hankaku_symbol        = ((Lisp_Object *)nil)[150];

#ifdef COMMON

    keyword_package       = ((Lisp_Object *)nil)[170];
    all_packages          = ((Lisp_Object *)nil)[171];
    package_symbol        = ((Lisp_Object *)nil)[172];
    internal_symbol       = ((Lisp_Object *)nil)[173];
    external_symbol       = ((Lisp_Object *)nil)[174];
    inherited_symbol      = ((Lisp_Object *)nil)[175];
    key_key               = ((Lisp_Object *)nil)[176];
    allow_other_keys      = ((Lisp_Object *)nil)[177];
    aux_key               = ((Lisp_Object *)nil)[178];
    format_symbol         = ((Lisp_Object *)nil)[179];
    expand_def_symbol     = ((Lisp_Object *)nil)[180];
    allow_key_key         = ((Lisp_Object *)nil)[181];
    declare_symbol        = ((Lisp_Object *)nil)[182];
    special_symbol        = ((Lisp_Object *)nil)[183];

#endif

    for (i = 0; i<=50; i++)
        workbase[i]  = ((Lisp_Object *)nil)[work_0_offset+i];
#endif /* NILSEG_EXTERNS */

    user_base_0           = ((Lisp_Object *)nil)[190];
    user_base_1           = ((Lisp_Object *)nil)[191];
    user_base_2           = ((Lisp_Object *)nil)[192];
    user_base_3           = ((Lisp_Object *)nil)[193];
    user_base_4           = ((Lisp_Object *)nil)[194];
    user_base_5           = ((Lisp_Object *)nil)[195];
    user_base_6           = ((Lisp_Object *)nil)[196];
    user_base_7           = ((Lisp_Object *)nil)[197];
    user_base_8           = ((Lisp_Object *)nil)[198];
    user_base_9           = ((Lisp_Object *)nil)[199];
}


/* end of restart.c */