Artifact 69a1068da9f6cc35c235c20a71c0b358db01ff01c7047749bdd69f170ceae99b:


// Jlisp
//
// Standard Lisp system coded in Java. Actually this goes
// way beyond the Standard Lisp Report and includes a large fraction
// of that which is present in the CSL Lisp system.
//
// The purpose of this implementation is to support
// REDUCE. Early versions of jlisp were amazingly slow but
// performance is gradually improving!

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//


import java.io.*;
import java.math.*;
import java.util.*;
import java.util.zip.*;
import java.text.*;

public class Jlisp
{

// Within this file I will often reference lispIO and lispErr
// directly. Elsewhere they should ONLY be accessed via the Lisp
// variables that point towards them. The direct access here is in
// cases where the Lisp world may not have been fully set up.
static LispStream lispIO, lispErr;
static boolean interactivep = false;
static boolean debugFlag = false;
static boolean headline = true;
static boolean backtrace = true;
static LispObject errorCode;
static int verbosFlag = 1;

static void print(String s)
{
    ((LispStream)(lit[Lit.std_output].car/*value*/)).print(s);
}

static void println(String s)
{
    ((LispStream)(lit[Lit.std_output].car/*value*/)).println(s);
}

static void println()
{
    ((LispStream)(lit[Lit.std_output].car/*value*/)).println();
}

static void errprint(String s)
{
    ((LispStream)(lit[Lit.err_output].car/*value*/)).print(s);
}

static void errprintln(String s)
{
    ((LispStream)(lit[Lit.err_output].car/*value*/)).println(s);
}

static void errprintln()
{
    ((LispStream)(lit[Lit.err_output].car/*value*/)).println();
}

static void traceprint(String s)
{
    ((LispStream)(lit[Lit.tr_output].car/*value*/)).print(s);
}

static void traceprintln(String s)
{
    ((LispStream)(lit[Lit.tr_output].car/*value*/)).println(s);
}

static void traceprintln()
{
    ((LispStream)(lit[Lit.tr_output].car/*value*/)).println();
}

static LispObject error(String s) throws LispException
{
    if (headline)
    {   errprintln();
        errprintln("++++ " + s);
    }
    throw new LispException(s);
}

static LispObject error(String s, LispObject a) throws LispException
{
    if (headline)
    {   errprintln();
        errprint("++++ " + s + ": ");
        a.errPrint();
        errprintln();
    }
    throw new LispException(s);
}


// The main parts of this file relate to system startup options

static PDS [] images = new PDS[10];
static int outputImagePos;
static int imageCount;

static String [] imageFile = new String[10];

public static void main(String [] args)
{
    startup(args,
            new InputStreamReader(System.in),
            new PrintWriter(System.out),
            true);
}

static Reader in;
static PrintWriter out;

static boolean standAlone;

static Vector openOutputFiles = null;

static boolean restarting = false;
static String  restartModule = null;
static String  restartFn = null;
static String  restartArg = null;

static boolean finishingUp = false;

public static void startup(String [] args, 
                           Reader Xin, PrintWriter Xout,
                           boolean standAloneFlag)
{
    in = Xin;
    out = Xout;
    lispIO = null;
    standAlone = standAloneFlag;
    Thread t = null;
    if (standAlone)
    {   final int screenRefreshInterval = 2500;
        t = new FlushOutputThread();
        t.start();
    }
// I am pretty keen that all output files should be closed (and in the
// process they should be flushed) so that data is never lost. So I keep
// a record (in this Vector) of ones that are liable to need closing, and
// then in a "finally" clause I zoom through cleaning up.
    openOutputFiles = new Vector(10, 5);
    try
    {   startup1(args);
    }
    finally
    {
        lispIO = null;
        finishingUp = true;
        t.interrupt();     // so it can exit
        int i;
// In general I close in the opposite order from that in which I opened files.
// The code here is such that if closing one file happened to have a side
// effect of closing another along the way that would not be a calamity.
        while ((i=openOutputFiles.size()) != 0)
        {   ((LispStream)openOutputFiles.get(i-1)).close();
        }
    }
// If I was run as an application not an applet (via any route!) I am
// permitted to exit.
    if (!CWin.isApplet) System.exit(0);
}

static void startup1(String [] args)
{
    long startTime = System.currentTimeMillis();
    String [] inputFile = new String [10];
    int inputCount = 0;
    imageCount = 0;
    outputImagePos = -1;
    boolean coldStart = false;
    String mainOutput = null;
    String logFile = null;
    boolean verbose = false;
    boolean copyrightRequest = false;
    String [] errs = new String [10];
    int errCount = 0;
    String [] defineSymbol = new String [10];
    int defineCount = 0;
    String [] undefineSymbol = new String [10];
    int undefineCount = 0;
    boolean noRestart = false;
    boolean batchSwitch = false;

// The options that I accept here are intended to match (as far as I can
// reasonably make them) the ones used with the "CSL" Lisp implementation.
// I scan the command line to decode them. Note that until this has
// been completed I can not do proper Lisp output because I will not have
// seen redirection requests.
    int i;
    for (i=0; i<args.length; i++)
    {   String arg = args[i];
        String arg1;
        if (arg.length() >= 2 && arg.charAt(0) == '-')
        {   char key = Character.toLowerCase(arg.charAt(1));
            switch (key)
            {
        case '-': // redirect all output
                break;
        case 'b': // flips batchp() result
                batchSwitch = true;
                continue;
        case 'c': // display copyright notice
                copyrightRequest = true;
                continue;
        case 'd': // define symbol
                break;
        case 'e': // "experiment" control
                continue;
        case 'f': // serve on a socket
                break;
        case 'g': // enhance debugging
                debugFlag = true;
                continue;
        case 'i': // specify (input) image or library
                break;
        case 'k': // indicate amount of memory to use
                break;
        case 'l': // transcript of output to a log file
                break;
        case 'm': // (memory trace control)
                continue;
        case 'n': // ignore restart function in image
                noRestart = true;
                continue;
        case 'o': // output image
                break;
        case 'p': // profile option
                continue;
        case 'q': // quiet mode
                verbose = false;
                continue;
        case 'r': // initial random seed
                break;
        case 's': // view machine code from any compilation
                continue;
        case 't': // inspect time-stamp on a module
                continue;
        case 'u': // undefined symbol
                break;
        case 'v': // verbose mode
                verbose = true;
                continue;
        case 'w': // run in windowed mode
                continue;
        case 'x': // less trapping of possibly internal errors
                continue;
        case 'y': // ignore restart-function in saved image
                continue;
        case 'z': // cold start mode
                coldStart = true;
                continue;
        default:
                if (errCount < errs.length)
                    errs[errCount++] =
                        "Invalid option \"" + arg + "\"";
                continue;
            }
// In many cases an option takes an argument. I permit either -Ixx or -I xx
// and separate off xxx here.
            if (arg.length() > 2) arg1 = arg.substring(2);
            else if (i+1<args.length) arg1 = args[++i];
            else
            {   if (errCount < errs.length)
                    errs[errCount++] =
                        "Option \"" + arg +
                        "\" invalid as final option";
                continue;
            }
// Now arg is the initial key and arg1 is the follow-up.
            switch (key)
            {
        case '-': // redirect all output
                mainOutput = arg1;
                break;
        case 'd': // define a symbol
                if (defineCount < defineSymbol.length)
                    defineSymbol[defineCount++] = arg1;
                break;
        case 'f': // serve on a socket
                break;
        case 'i': // specify (input) image or library
                if (imageCount < imageFile.length)
                    imageFile[imageCount++] = arg1;
                break;
        case 'k': // indicate amount of memory to use
                break;
        case 'l': // transcript of output to a log file
                logFile = arg1;
                break;
        case 'o': // output image
// If the user specifies an output image then I will make it available
// as an input image too, in the place in the search-list that it
// appears on the command-line: eg
//    -i file1.img -o file2.img -i file3.img
// will scan in order file1/file2/file3 when loading files, and will
// write to file2.
                if (imageCount < imageFile.length)
                {   outputImagePos = imageCount;
                    imageFile[imageCount++] = arg1;
                }
                break;
        case 'r': // initial random seed
                break;
        case 'u': // undefined symbol
                if (undefineCount < undefineSymbol.length)
                    undefineSymbol[undefineCount++] = arg1;
                break;
            }
        }
        else inputFile[inputCount++] = arg;
    }
// Now I have finished decoding the command line. The first parts I
// process are those relating to the intended destination for
// output.

    Writer transcript = null;
// The directive "-l file" arranges that a copy of all output goes to
// the named file (if it can be opened) in addition to the usual
// destination (which may have been adjusted using "-- file").
    if (logFile != null)
    {   try
        {   transcript = new BufferedWriter(
                new FileWriter(LispStream.nameConvert(logFile)));
        }
        catch (IOException e)
        {   transcript = null;
            if (errCount < errs.length)
                errs[errCount++] =
                    "File \"" + logFile +
                    "\" unavailable as a log file";
        }
    }

// If the user had specified "-- file" then the main output is to that
// file. Otherwise the main output is to the initial "standard" stream.
// If the file named after "--" can not be opened for writing then the
// directive is ignored and output again goes to the "standard" place.

    if (mainOutput == null)
    {   if (transcript == null) lispIO = new LispOutputStream();
        else lispIO = new DoubleWriter(transcript);
    }
    else
    {   try
        {   if (transcript == null) lispIO = new LispOutputStream(mainOutput);
        else lispIO = new DoubleWriter(mainOutput, transcript);
        }
        catch (IOException e)
        {    errs[errCount++] =
                 "File \"" + mainOutput + "\" could not be written to";
            if (transcript == null) lispIO = new LispOutputStream();
            else lispIO = new DoubleWriter(transcript);
        }
    }
    if (transcript != null)
        lispIO.println("Transcript sent to file " + logFile);
    lispErr = lispIO; // lispErr sent to spool file if lispIO is...
// now I have Java variables that refer to the output streams I need
// to establish.

// Now I am in a position to display any errors relating to
// command line options.
    for (i=0; i<errCount; i++)
        lispErr.println(errs[i]);

    LispSmallInteger.preAllocate();  // some small integers treated specially

// For use while I am re-loading images and also to assist the
// custom Lisp bytecoded stuff I build a table of all the functions
// that I have built into this Lisp.
//
    builtinFunctions = new HashMap();
    builtinSpecials  = new HashMap();
    for (i=0; i<fns1.builtins.length; i++)
    {   ((LispFunction)fns1.builtins[i][1]).name =
            (String)fns1.builtins[i][0];
        builtinFunctions.put(fns1.builtins[i][0], fns1.builtins[i][1]);
    }
    for (i=0; i<fns2.builtins.length; i++)
    {   ((LispFunction)fns2.builtins[i][1]).name =
            (String)fns2.builtins[i][0];
        builtinFunctions.put(fns2.builtins[i][0], fns2.builtins[i][1]);
    }
    for (i=0; i<fns3.builtins.length; i++)
    {   ((LispFunction)fns3.builtins[i][1]).name =
            (String)fns3.builtins[i][0];
        builtinFunctions.put(fns3.builtins[i][0], fns3.builtins[i][1]);
    }
    for (i=0; i<fns4.builtins.length; i++)
    {   ((LispFunction)fns4.builtins[i][1]).name =
            (String)fns4.builtins[i][0];
        builtinFunctions.put(fns4.builtins[i][0], fns4.builtins[i][1]);
    }
    for (i=0; i<specfn.specials.length; i++)
    {   ((SpecialFunction)specfn.specials[i][1]).name =
            (String)specfn.specials[i][0];
        builtinSpecials.put(specfn.specials[i][0], specfn.specials[i][1]);
    }
    Bytecode.setupBuiltins();

// I open all the image files that the user had mentioned...
    if (imageCount == 0)
    {   if (verbose)
            lispErr.println(
                "Image file defaulting to in-store data");
        imageFile[0] = "-";
        imageCount = 1;
    }
    for (i=0; i<imageCount; i++)
    {   images[i] = null;
        try
        {   if (imageFile[0].equals("-"))
            {
// I get the ClassLoader for LispStream as a randomish convenient
// class that is part of my code. Then I can access my image as
// a resource, searching for it wherever I loaded my classes from.
// This may well be the .jar file I am using...
                ClassLoader cl = lispIO.getClass().getClassLoader();
                InputStream is = cl.getResourceAsStream("default.img");
                if (is != null) images[i] = new PDS(is);
            }
            else images[i] = new PDS(imageFile[i], i==outputImagePos);
        }
        catch (IOException e)
        {
        }
    }

// The next stage is either to create an initial Lisp heap or to
// re-load one that had been saved from a previous session. Things are
// made MUCH more complicated here because a running Lisp can (under program
// control) get itself restarted either in cold or warm-start mode.

    boolean loaded;

    for (;;)  // loop here is for the oddly named RESTART-CSL function
    {
        loaded = false;
// The next section is a sort of admission of confusion. When I restart the
// whole of the old word ought to get discarded: Java garbage collection
// ought to reap it. However that seems not to happen anything like as well
// as I intended, with BAD effects on total storage use in restarted systems
// (most of the old as well as most of the new heap remains!). This could
// well be MY fault with some valid Lisp root not being restored, but
// right now I can not find it and it COULD also be a consequence of
// a conservative GC strategy in the Java world. Anyway to reduce the pain as
// much as possible I will destroy a lot of connectivity in the old heap
// now so that even if bits of it are still referred to that will only lead
// to a small memory loss not a huge one.
        if (restarting)
        {   for (i=0; i<chars.length; i++)  chars[i] = null;
            for (i=0; i<oblist.length; i++)
            {   nil = oblist[i];
                // Do a radical clean-up of all existing symbols
                if (nil != null)
                {   nil.car/*value*/ = null;
                    nil.cdr/*plist*/ = null;
                    nil.fn = null;
                    nil.special = null;
                }
                oblist[i] = null;
            }
            oblistCount = 0;
            ((LispHash)lit[Lit.hashtab]).hash.clear();
            for (i=0; i<lit.length; i++)    lit[i] = null;
            for (i=0; i<spine.length; i++)  spine[i] = null;
            lispIO.tidyup(null);
            lispErr.tidyup(null);
            nil = null;
            lispTrue = null;
            modulus = 1;
            bigModulus = BigInteger.valueOf(modulus);
            Specfn.progData = null;
            Specfn.progEvent = Specfn.NONE;
            errorCode = null;
        }
        if (!coldStart)
        {   GZIPInputStream image = null;
            PDSInputStream ii = null;
// I will re-load from the first checkpoint file in the list that has
// a HeapImage stored in it.
            for (i=0; i<imageCount; i++)
            {   try
                {   ii = new PDSInputStream(images[i], "HeapImage");
                }
                catch (IOException e)
                {
                }
                if (ii != null) break;
            }
            try
            {   if (ii == null)
                    throw new IOException("No valid checkpoint file found");
                image = new GZIPInputStream(
                    new BufferedInputStream(ii, 32768));
                Symbol.symbolCount =
                Cons.consCount =
                LispString.stringCount = 0;
                restore(image);
                loaded = true;
            }
            catch (Exception e)
            {   lispErr.println("Failed to load image \"" +
                                       imageFile[0] + "<HeapImage>\"");
// The next two lines are for debugging at least
                lispErr.println(e.getMessage());
                e.printStackTrace(new PrintWriter(new WriterToLisp(lispErr)));
                loaded = false;
            }
            finally
            {   if (image != null)
                {   try
                    {   image.close();
                    }
                    catch (IOException e)
                    {   lispErr.println("Failed to load image");
                        loaded = false;
                    }
                }
            }
            if (restarting && !loaded)
            {   lispIO.println("+++ No image file when restarting");
                return;
            }
        }

// If no image file was available I will fall back to a cold start. This is
// probably not what is wanted in the long run but will be useful while
// testing.
        if (!loaded)
        {   initSymbols();
            DateFormat df = DateFormat.getInstance();
            df.setTimeZone(TimeZone.getDefault());
            lit[Lit.birthday] = new LispString(df.format(new Date()));
        }
        else
        {   // System.out.println("Bodge here...");
            initfns(fns4.builtins);
        }
        lispIO.tidyup(nil);
        lispErr.tidyup(nil);

// Having set up an image I optionally display a banner.
        if (verbose)
        {   lispIO.println("Jlisp 0.93a ... " +
               ((LispString)lit[Lit.birthday]).string);
            if (loaded)
            {   lispIO.println("Sym    = " + Symbol.symbolCount);
                lispIO.println("Cons   = " + Cons.consCount);
                lispIO.println("String = " + LispString.stringCount);
            }
            if (copyrightRequest)
            {
                lispIO.println("Copyright \u00a9 (C) Codemist Ltd, 1998-2000");
            }
        }

// If the user specifed -Dxxx, -Dxxx=yyy or -Uxxx on the command
// line I process that here. I will perform all the "undefine"
// operations before any of the "define" ones, but otherwise
// proceed left to right
        for (i=0; i<undefineCount; i++)
        {   Symbol s = Symbol.intern(undefineSymbol[i]);
            s.car/*value*/ = lit[Lit.undefined];
            s = null;
        }
        for (i=0; i<defineCount; i++)
        {   String name = defineSymbol[i];
            LispObject value;
            int eqPos = name.indexOf('=');
// Just -Dname without an "=" sets the name to T
            if (eqPos == -1) value = lispTrue;
            else
            {   String v = name.substring(eqPos+1);
                name = name.substring(0, eqPos);
                int lv = v.length();
// If the value specified was enclosed in double quotes I strip those
// off. Thus -Dname=xxx and -Dname="xxx" both set name to a string "xxx".
// Note that -Dname= will set name to the empty string "" which is non-nil
// so is OK for "true".
                if (lv != 0 &&
                    v.charAt(0) == '\"' &&
                    v.charAt(lv-1) == '\"')
                    v = v.substring(1, lv-1);
                value = new LispString(v);
            }
            Symbol s = Symbol.intern(name);
            s.car/*value*/ = value;
            s = null;
            value = null;
        }

        for (i=0; i<128; i++) // To speed up readch()
        {   chars[i] = Symbol.intern(String.valueOf((char)i));
        }

// If no input files had been specified I will read from the standard
// input - often the keyboard. Otherwise I will process each file that
// is given. This seems a bulky bit of code because of Java's
// insistence on exception processing. I do not work too hard on that!
        if (inputCount == 0)
        {   interactivep = !batchSwitch;
            if (!restarting)
                lispIO.setReader("<stdin>", in, standAlone, true);
            standardStreams();
            try
            {   readEvalPrintLoop(noRestart);
                throw new ProgEvent(ProgEvent.STOP, nil, "EOF");
            }
            catch (ProgEvent e)
            {   switch (e.type)
                {
            case ProgEvent.STOP:
                    restarting = false;
                    break;
            case ProgEvent.PRESERVE:
                    Cons w = (Cons)e.details;
                    preserve(w.car, w.cdr);
                    restarting = false;
                    break;
            case ProgEvent.RESTART:
                    println();
                    println("Restart Lisp...");
// the RESTART event has (details/extra) as Lisp items carried
// with it. 
//    If details=nil it asks for a cold start
//    If details=t   it asks for a normal start using the default
//                   restart-action from the image
//    if details=f   it does a warm restart but then calls function f
//                   (this is any atomic f not nil or t)
//    if details=(m f) it does a warm start, then loads module m and
//                   finally calls function f
// In the two latter cases (ie details other than nil/t) if extra is provided
// it is passed on as an argument to the user-specified restart function f.
//
// This elaborate behaviour is as grew up piecemeal in CSL and it is expected
// that this function is only used when setting up scripts to rebuild major
// bits of software so MAYBE the fact that it is a bit obscure is not too
// much of a problem.
                    restartFn = null;
                    restartModule = null;
                    restartArg = null;
                    if (e.details == nil) coldStart = true;
                    else try
                    {   coldStart = false;
                        if (e.details != lispTrue)
                        {   if (e.details.atom)
                            {   restartFn = Fns.explodeToString(e.details);
                            }
                            else
                            {   restartModule =
                                    Fns.explodeToString(e.details.car);
                                LispObject w1 = e.details.cdr;
                                if (!w1.atom) w1 = w1.car;
                                restartFn = Fns.explodeToString(w1);
                            }
                            if (e.extras != null)
                                restartArg = Fns.explodeToString(e.extras);
                        }
                    }
                    catch (Exception e1)
                    {   System.out.println("Unexpected exception " + e1);
                    }
// @@@ next line for debugging
print("restart mode " + restartFn + " " + restartModule + " " + restartArg);
                    restarting = true;
                    continue;
            default:
                    errprintln();
                    errprintln("Stopping because of " + e.message);
                    restarting = false;
                    break;
                }
            }
            if (restarting) continue;
            else break;
        }
        else
        {   interactivep = batchSwitch;
            if (restarting) inputCount = 1;
            for (i=0; i<inputCount; i++)
            {   try
                {   if (!restarting)
                        lispIO.setReader(
                            inputFile[i],
                            new BufferedReader(
                                new FileReader(inputFile[i])),
                            false, true);
                    standardStreams();
                    try
                    {   readEvalPrintLoop(noRestart);
                    }
                    catch (ProgEvent e)
                    {   switch (e.type)
                        {
                    case ProgEvent.STOP:
                            restarting = false;
                            i = inputCount;
                            break;
                    case ProgEvent.PRESERVE:
                            Cons w = (Cons)e.details;
                            preserve(w.car, w.cdr);
                            i = inputCount;
                            restarting = false;
                            break;
                    case ProgEvent.RESTART:
                            println();
                            println("Restart Lisp...");
                            restartFn = null;
                            restartModule = null;
                            restartArg = null;
                            if (e.details == nil) coldStart = true;
                            else try
                            {   coldStart = false;
                                if (e.details != lispTrue)
                                {   if (e.details.atom)
                                    {   restartFn = Fns.explodeToString(e.details);
                                    }
                                    else
                                    {   restartModule =
                                            Fns.explodeToString(e.details.car);
                                        LispObject w1 = e.details.cdr;
                                        if (!w1.atom) w1 = w1.car;
                                        restartFn = Fns.explodeToString(w1);
                                    }
                                    if (e.extras != null)
                                        restartArg = Fns.explodeToString(e.extras);
                                }
                            }
                            catch (Exception e1)
                            {   System.out.println("Unexpected exception " + e);
                            }
// @@@
println("restart mode " + restartFn + " " + restartModule + " " + restartArg);
                            i = inputCount;
                            restarting = true;
                            break;
                    default:
                            errprintln();
                            errprintln(
                                "Stopping because of " + e.message);
                            i = inputCount;
                            restarting = false;
                            break;
                        }
                    }
                    finally
                    {   if (!restarting) lispIO.reader.close();
                    }
                }
                catch (IOException e)
                {   errprintln("Failed to read from \"" +
                                       inputFile[i] + "\"");
                }
            }
        }
        if (restarting) continue;
        else break; // loop to do with RESTART-CSL calls
    }
    if (verbose)
    {   long endTime = System.currentTimeMillis();
        long elapsed = endTime - startTime;
        long secs = elapsed / 1000;
        long millis = elapsed % 1000;
        long tenths = millis / 100;
        long hunds = (millis % 100) / 10;
        lispIO.println("End of Lisp run after " +
            secs + "." + tenths + hunds + " seconds");
    }

    lispIO.close();

}

static void standardStreams()
{
    lit[Lit.std_output].car/*value*/  = lispIO;
    lit[Lit.tr_output].car/*value*/   = lispIO;
    lit[Lit.err_output].car/*value*/  = lispErr;
    lit[Lit.std_input].car/*value*/   = lispIO;
    lit[Lit.terminal_io].car/*value*/ = lispIO;
    lit[Lit.debug_io].car/*value*/    = lispIO;
    lit[Lit.query_io].car/*value*/    = lispIO;
}


static void preserve(LispObject arg1, LispObject arg2)
{
    PDS imagePDS = images[outputImagePos];
    if (imagePDS == null)
    {   errprintln("no output image file available");
        return;
    }
    LispObject save1 = lit[Lit.restart];
    LispObject save2 = lit[Lit.banner];
    lit[Lit.restart] = arg1;
    lit[Lit.banner] = arg2;

    LispObject oldBirthday = lit[Lit.birthday];
// I want the new image file to have a fresh date
    DateFormat df = DateFormat.getInstance();
    df.setTimeZone(TimeZone.getDefault());
    lit[Lit.birthday] =
        new LispString(df.format(new Date()));

    GZIPOutputStream dump = null;
    try
    {   dump = new GZIPOutputStream(
                   new BufferedOutputStream(
                       new PDSOutputStream(imagePDS, "HeapImage"),
                       32768));
        preserve(dump);
        println();
        println("Image written");
    }
    catch (IOException e)
    {   errprintln("IO error on dump file: " + e.getMessage());
    }
    finally
    {   if (dump != null)
        try
        {   dump.close();
        }
        catch (IOException e)
        {
        }
        lit[Lit.birthday] = oldBirthday;
        lit[Lit.restart] = save1;
        lit[Lit.banner] = save2;
    }
}

// At one stage the code that follows was in a separate class. That was done
// so that I could serialize the instance of the class concerned to capture
// the entire useful state of Lisp. Now I use my own serialization code
// it is nicer to have enerything in one top-level class

public static Symbol nil, lispTrue;
static LispObject [] lit = new LispObject[Lit.names.length];

static int modulus = 1;
static BigInteger bigModulus = BigInteger.ONE;
static int printprec = 15;

static Fns1 fns1 = new Fns1();
static Fns2 fns2 = new Fns2();
static Fns3 fns3 = new Fns3();
static Fns4 fns4 = new Fns4();
static Specfn specfn = new Specfn();

// I choose my initial oblist size so that REDUCE can run without need
// for re-hashing at all often. The size must also be a prime, and 9001
// seems to fit the bill.
static int oblistSize = 9001;
static int oblistCount = 0;
static Symbol [] oblist = new Symbol[oblistSize];
static LispVector obvector = new LispVector((LispObject [])oblist);

static Symbol [] chars  = new Symbol[128];  // to speed up READCH
static LispObject [] spine = new LispObject[17]; // for PRESERVE


static int inputType;

static OutputStream odump;
static InputStream  idump;

static HashSet objects;
static HashMap repeatedObjects;
static int sharedIndex;
static Stack stack;
static boolean specialNil, descendSymbols;

static void scanObject(LispObject a)
{
    if (a == null) return;
    stack.push(a);
    try              // keep going until the stack empties.
    {   for (;;)
        {   LispObject w = (LispObject)stack.pop();
            w.scan();
        }
    }
    catch (EmptyStackException e)
    {
    }
}

static void writeObject(LispObject a) throws IOException
{
    if (a == null)
    {   odump.write(LispObject.X_NULL);
        return;
    }
    stack.push(a);
    try              // keep going until the stack empties.
    {   for (;;)
        {   LispObject w = (LispObject)stack.pop();
            if (w == null) odump.write(LispObject.X_NULL);
            else w.dump();
        }
    }
    catch (EmptyStackException e)
    {
    }
}

static void preserve(OutputStream dump) throws IOException
{
    int i;
    odump = dump;
    descendSymbols = true;
    LispNumber g1 = LispInteger.valueOf(Fns.gensymCounter);
    LispNumber g2 = LispInteger.valueOf(modulus);
    LispNumber g3 = LispInteger.valueOf(printprec);
    LispString gp = null;
    if (Fns.prompt != null) gp = new LispString(Fns.prompt);
    try
    {   objects = new HashSet();
        repeatedObjects = new HashMap();
        stack = new Stack();
        sharedIndex = 0;
// First scan to detect shared sub-structures
        scanObject(nil);
        scanObject(lispTrue);
        for (i=0; i<Lit.names.length; i++)
            scanObject(lit[i]);
        for (i=0; i<oblistSize; i++)
        {   scanObject(oblist[i]);
        }
        scanObject(gp);
        scanObject(g1);
        scanObject(g2);
        scanObject(g3);

// Now write it out. The code here MUST process the same set of things as
// that above. But before I write out the main heap I will dump
// some special header info...
        int n = repeatedObjects.size();
        odump.write(n>>16);
        odump.write(n>>8);
        odump.write(n);
// See comments where the banner is loaded and displayed to the effect that
// I might want to store this information elsewhere...
        byte [] rep = null;
        if (lit[Lit.banner] instanceof LispString)
        {   rep = ((LispString)lit[Lit.banner]).string.getBytes("UTF8");
            n = rep.length;
        }
        else n = 0;
        odump.write(n>>16);
        odump.write(n>>8);
        odump.write(n);
        for (i=0; i<n; i++) odump.write(rep[i]);

// OK - now for the bulk of the heap
        specialNil = false; // extra careful while writing NIL itself!
        writeObject(nil);
        specialNil = true;
        writeObject(lispTrue);
        for (i=0; i<Lit.names.length; i++)
            writeObject(lit[i]);
        for (i=0; i<oblistSize; i++)
        {   Symbol s = oblist[i];
            if (s!=null)
            {   writeObject(s);
            }
        }
        odump.write(LispObject.X_ENDHASH); // marks end of oblist data
        if (Fns.prompt == null) odump.write(0);
        else
        {   odump.write(1);
            writeObject(new LispString(Fns.prompt));
        }
        writeObject(g1);
        writeObject(g2);
        writeObject(g3);

    }
    finally
    {   objects = null;
        repeatedObjects = null;
        stack = null;
    }

}

static void dumpTree(LispObject a, OutputStream dump) throws IOException
{
    int i;
    odump = dump;
    descendSymbols = false;
    try
    {   objects = new HashSet();
        repeatedObjects = new HashMap();
        stack = new Stack();
        sharedIndex = 0;
        scanObject(a);
        i = repeatedObjects.size();
        odump.write(i>>16);
        odump.write(i>>8);
        odump.write(i);
        writeObject(a);
    }
    finally
    {   objects = null;
        repeatedObjects = null;
        stack = null;
    }

}

static final int S_VECTOR     =  0;      // + number of items to come

static final int S_START      = -1;
static final int S_CDR        = -2;
static final int S_HASHKEY    = -3;
static final int S_HASHVAL    = -4;
static final int S_SYMVAL     = -5;
static final int S_SYMPLIST   = -6;
static final int S_SYMFN      = -7;
static final int S_SYMSPECIAL = -8;
static final int S_AUTONAME   = -9;
static final int S_AUTODATA   = -10;
static final int S_INTERP_BODY= -11;
static final int S_MACRO_BODY = -12;
static final int S_CALLAS_BODY= -13;

static final int S_CADR       = -100;  // +0 to +15 offsets from this used

static int istacklimit;
static int [] istack;
static int sharedSize;
static LispObject [] shared;
static HashMap builtinFunctions, builtinSpecials;


static void preRestore() throws IOException
{
    sharedIndex = 0;
    sharedSize = idump.read();
    sharedSize = (sharedSize<<8) + idump.read();
    sharedSize = (sharedSize<<8) + idump.read();
    shared = new LispObject[sharedSize];
    istacklimit = 500;
    istack = new int[istacklimit];
    stack = new Stack();
    stack.push(new Cons()); // to make "peek()" valid even when empty
}

static void postRestore()
{
    istack = null;
    stack = null;
    shared = null;
}


static void restore(InputStream dump) throws IOException
{
    idump = dump;
    preRestore();
    descendSymbols = true;
// First I will read and display the banner...
// I would like to be able to update JUST this banner in a heap image. To
// support that I will (sometime!) change my heap format to put the
// banner as an initial chunk of bytes in the PDS outside the compressed
// data that represents the main heap image. One natural place to put it
// will be as part of the directory entry for the initial image, and another
// would be at the very start of the whole image file.
    int n, i;
    n = idump.read();
    n = (n<<8) + idump.read();
    n = (n<<8) + idump.read();
    if (n != 0)
    {   byte [] b = new byte[n];
        for (i=0; i<n; i++) b[i] = (byte)idump.read();
        lispIO.println(new String(b, "UTF8"));
        lispIO.flush();
    }

    nil = (Symbol)readObject();

    lispTrue = (Symbol)readObject();

    for (i=0; i<Lit.names.length; i++)
    {   lit[i] = readObject();
    }

    for (i=0; i<oblistSize; i++) oblist[i] = null;
    oblistCount = 0;
    Symbol s;
// When restoring a heap image my oblist handling can be fairly
// simple: I should NEVER get any attempt to insert an item that is already
// there and when I start I start with an empty table so there are no deleted
// items to worry about.
    while ((s = (Symbol)readObject()) != null)
    {
        String name = s.pname;
//if (name.length() > 1) System.out.println("restore symbol <" + name + "> length " + name.length());
        int inc = name.hashCode();
//System.out.println("raw hash = " + Integer.toHexString(inc));
// I want my hash addresses and the increment to be positive...
// and Java tells me what the hash algorithm for strings is. What I do here
// ensures that strings that differ only in their final character get placed
// some multiple of 169 apart (is not quite adjacant).
        int hash = ((169*inc) & 0x7fffffff) % oblistSize;
        inc = 1 + ((inc & 0x7fffffff) % (oblistSize-1)); // never zero
//System.out.println("first probe = " + hash + " " + inc);
        while (oblist[hash] != null)
        {   if (oblist[hash].pname.equals(name))
                System.out.println("Two symbols called <" + name + "> " +
                   Integer.toHexString((int)name.charAt(0)));
            hash += inc;
            if (hash >= oblistSize) hash -= oblistSize;
//System.out.println("next probe = " + hash);
        }
//System.out.println("Put <" + name + "> at " + hash + " " + inc);
        oblist[hash] = s;
        oblistCount++;
// I will permit the hash table loading to reach 0.75, but then I take action
        if (4*oblistCount > 3*oblistSize) reHashOblist();
    }
//System.out.println("termination of oblist found : " + oblistCount);

    LispObject w;

    if (idump.read() == 0) Fns.prompt = null;
    else
    {   w = readObject();
        Fns.prompt = ((LispString)w).string;
    }

    w = readObject();
    try { Fns.gensymCounter = w.intValue(); }
    catch (Exception ee) { Fns.gensymCounter = 0; }

    w = readObject();
    try { modulus = w.intValue(); }
    catch (Exception ee) { modulus = 1; }
    bigModulus = BigInteger.valueOf(modulus);

    w = readObject();
    try { printprec = w.intValue(); }
    catch (Exception ee) { printprec = 14; }


    postRestore();
}

static boolean isPrime(int n)
{
// the input must be odd and fairly large here... so the case of even
// numbers is not important, as is the status of the number 1.
    for (int f=3; f*f<=n; f+=2)
    {   if (n%f == 0) return false;
    }
    return true;
}

static void reHashOblist()
{
System.out.println("ReHashing");
    int n = ((3*oblistSize)/2) | 1;
    while (!isPrime(n)) n += 2;
    Symbol [] v = new Symbol[n];
    for (int i=0; i<n; i++) v[i] = null;
    for (int i=0; i<oblistSize; i++)
    {   Symbol s = oblist[i];
        if (s == null) continue;
        int inc = s.pname.hashCode();
        int hash = ((169*inc) & 0x7fffffff) % n;
        inc = 1 + ((inc & 0x7fffffff) % (n-1)); // never zero
        while (v[hash] != null)
        {   if (v[hash].pname.equals(s.pname))
                System.out.println("Two symbols called <" + s.pname + "> " +
                    Integer.toHexString((int)s.pname.charAt(0)));
            hash += inc;
            if (hash >= n) hash -= n;
        }
//System.out.println("Relocate <" + s.pname + "> at " + hash + " " + inc);
        v[hash] = s;
    }
    oblist = v;
    oblistSize = n;
    obvector.vec = v;
}

static LispObject readObject() throws IOException
{
// Reloading an image uses an explicit stack to manage the recusion that
// it needs. It controls this stack using a finite-state control. The states
// are identified here as constants S_xxx.

    int state = S_START;
    int sp = 0;

    LispObject w = null;
    boolean setLabel = false;
    int i;

    for (;;)
    {   if (sp >= istacklimit-2)  // grow integer stack if needbe.
        {   int [] newistack = new int[2*istacklimit];
            for (i=0; i<istacklimit; i++) newistack[i] = istack[i];
            istack = newistack;
            istacklimit = 2*istacklimit;
        }
// At the start of the loop here I will read another object. I "continue"
// if the object can not be completed all at once, having adjusted my
// state and the stack suitably.
        int opcode = idump.read();
        if (opcode == -1) throw new IOException("End of file");
        int operand = 0;
        if (opcode < LispObject.X_BREAK1)
        {   operand = opcode & 0x3f;
            opcode &= ~0x3f;
        }
        else if (opcode < LispObject.X_BREAK2)
        {   operand = opcode & 0x0f;
            opcode &= ~0x0f;
        }
        else if (opcode < LispObject.X_BREAK3)
        {
// The first class of opcodes have a selector in their bottom two bits,
// and that indicates whether they are followed by 1, 2, 3 or 4 bytes
// of operand.
            switch (opcode & 3)
            {
        case 0: operand = idump.read();
                break;
        case 1: operand = idump.read();
                operand = (operand << 8) | idump.read();
                break;
        case 2: operand = idump.read();
                operand = (operand << 8) | idump.read();
                operand = (operand << 8) | idump.read();
                break;
        case 3: operand = idump.read();
                operand = (operand << 8) | idump.read();
                operand = (operand << 8) | idump.read();
                operand = (operand << 8) | idump.read();
                break;
            }
            opcode &= ~3;
        }
// Other cases do not have an (explicit) operand.
        switch (opcode)
        {
    case LispObject.X_REFn:
            if (operand >= 48) operand = sharedIndex - (operand + 1 - 48);
    case LispObject.X_REF:       // refer to an item that has already been read
            w = shared[operand];
            break;
    case LispObject.X_REFBACK:
            w = shared[sharedIndex - operand];
            break;
    case LispObject.X_RECENT:
            Fasl.recentn++;
            w = Fasl.recent[idump.read()];
	    if (setLabel)
	    {   shared[sharedIndex++] = w;
	        setLabel = false;
	    }
	    break;
    case LispObject.X_RECENT1:
            Fasl.recentn++;
            w = Fasl.recent[idump.read()+256];
	    if (setLabel)
	    {   shared[sharedIndex++] = w;
	        setLabel = false;
	    }
	    break;
    case LispObject.X_OBLIST:
            w = obvector;
            break;
    case LispObject.X_INT:       // a LispInteger
    case LispObject.X_INTn:
            {   byte [] data = new byte[operand];
                for (i=0; i<operand; i++) data[i] = (byte)idump.read();
                w = LispInteger.valueOf(new BigInteger(data));
            }
            break;
    case LispObject.X_FIXNUM:
// Slighly curious encoding of signed numbers so that the variable-length
// packing in the image file works well.
            if ((operand & 1) == 0) operand = (operand >>> 1);
            else if (operand == 1) operand = 0x80000000;
            else operand = -(operand >>> 1);
            w = LispInteger.valueOf(operand);
            break;
    case LispObject.X_STR:
    case LispObject.X_STRn:
            {   byte [] data = new byte[operand];
                for (i=0; i<operand; i++) data[i] = (byte)idump.read();
                w = new LispString(new String(data, "UTF8"));
                LispString.stringCount++;
            }
            break;
    case LispObject.X_GENSYM:
    case LispObject.X_GENSYMn:
            {   byte [] data = new byte[operand];
                for (i=0; i<operand; i++) data[i] = (byte)idump.read();
                Symbol ws = new Gensym(new String(data, "UTF8"));
                Symbol.symbolCount++;
                if (setLabel)
                {   shared[sharedIndex++] = ws;
                    setLabel = false;
                }
                if (!descendSymbols)
                {   ws.car/*value*/ = lit[Lit.undefined];
                    ws.cdr/*plist*/ = nil;
                    ws.fn = new Undefined(ws.pname);
                    ws.special = null;
                    w = ws;
                    break;
                }
                stack.push(ws);
                istack[sp++] = state;
                state = S_SYMFN;
                continue;
            }
    case LispObject.X_SYM:
            opcode = LispObject.X_SYMn; // drop through
    case LispObject.X_SYMn:
    case LispObject.X_UNDEF:
    case LispObject.X_UNDEFn:
            {   byte [] data = new byte[operand];
                for (i=0; i<operand; i++) data[i] = (byte)idump.read();
                if (descendSymbols)
                {   Symbol ws = new Symbol();
                    Symbol.symbolCount++;
                    ws.pname = new String(data, "UTF8");
                    stack.push(ws);
                    istack[sp++] = state;
                    if (opcode == LispObject.X_SYMn) state = S_SYMFN;
                    else
                    {   ws.fn = new Undefined(ws.pname);
                        state = S_SYMSPECIAL;
                    }
                    if (setLabel)
                    {   shared[sharedIndex++] = ws;
                        setLabel = false;
                    }
                    continue;
                }
                else
                {   w = Symbol.intern(new String(data, "UTF8"));
		    Fasl.recent[Fasl.recentp++ & 0x1ff] = w;
                    break;
                }
            }
    case LispObject.X_VEC:
            w = new LispVector(operand);
            if (setLabel)
            {   shared[sharedIndex++] = w;
                setLabel = false;
            }
            if (operand == 0) break;  // vector with 0 elements
            stack.push(w);
            istack[sp++] = state;
            state = S_VECTOR + operand;
            continue;
    case LispObject.X_HASH:
            w = new LispHash(new HashMap(), 0);
            stack.push(w);
            istack[sp++] = state;
            state = S_HASHKEY;
            if (setLabel)
            {   shared[sharedIndex++] = w;
                setLabel = false;
            }
            continue;
    case LispObject.X_HASH2:
            w = new LispHash(new LispEqualHash(), 2);
            stack.push(w);
            istack[sp++] = state;
            state = S_HASHKEY;
            if (setLabel)
            {   shared[sharedIndex++] = w;
                setLabel = false;
            }
            continue;
    case LispObject.X_ENDHASH:
            w = null;          // marker for end of hash table entries
            break;
    case LispObject.X_UNDEF1:
            {   byte [] data = new byte[operand];
                for (i=0; i<operand; i++) data[i] = (byte)idump.read();
                w = new Undefined(new String(data, "UTF8"));
            }
            break;
    case LispObject.X_MACRO:
            {   Macro wm = new Macro();
                if (setLabel)
                {   shared[sharedIndex++] = wm;
                    setLabel = false;
                }
                stack.push(wm);
                istack[sp++] = state;
                state = S_MACRO_BODY;
            }
            continue;
    case LispObject.X_AUTOLOAD:
            {   AutoLoad wa = new AutoLoad(null, null);
                if (setLabel)
                {   shared[sharedIndex++] = wa;
                    setLabel = false;
                }
                stack.push(wa);
                istack[sp++] = state;
                state = S_AUTONAME;
                continue;
            }
    case LispObject.X_INTERP:
            {   Interpreted wi = new Interpreted();
                if (setLabel)
                {   shared[sharedIndex++] = wi;
                    setLabel = false;
                }
                stack.push(wi);
                istack[sp++] = state;
                state = S_INTERP_BODY;
                continue;
            }
    case LispObject.X_CALLAS:
            {   CallAs wi = new CallAs(idump.read());
                if (setLabel)
                {   shared[sharedIndex++] = wi;
                    setLabel = false;
                }
                stack.push(wi);
                istack[sp++] = state;
                state = S_CALLAS_BODY;
                continue;
            }
    case LispObject.X_BPS:
            {   byte [] data;
                int nargs = 0;
                int n1 = idump.read(), n2=0, n3=0;
                if ((n1 & 0x80) != 0)
                {   n1 &= 0x7f;
                    n2 = idump.read();
                    if ((n2 & 0x80) != 0)
                    {   n2 &= 0x7f;
                        n3 = idump.read();
                    }
                }
                nargs = n1 + (n2<<7) + (n3<<14);
                if (operand == 0) data = null;
                else
                {   data = new byte[operand];
                    for (i=0; i<operand; i++) data[i] = (byte)idump.read();
                }
                FnWithEnv ws;
                if (nargs > 0xff) ws = new ByteOpt(nargs);
                else 
                {   ws = new Bytecode();
                    ws.nargs = nargs;
                }
                ws.bytecodes = data;
// the X_BPS format is curious in that it should ALWAYS be followed
// by an X_VEC. So I look for that here. I think I should also note that
// I have a fragment of design here that is not fully worked through.
// My Bytecoded is a sub-class of FnWithEnv - a general class for functions
// that want a vector of LispObjects kept with them. But at present
// Bytecode is the only sub-class that exists and the only one that this
// rea-loading code can ever re-create.  So I expect to have to do more
// work when or if I add more, for instance for code that has been reduced
// to real Jaba bytecodes rather than my Jlisp-specific ones.
                opcode = idump.read();
                if (opcode < LispObject.X_VEC || opcode > LispObject.X_VEC+3)
                    throw new IOException("Corrupted image file");
                switch (opcode & 3)
                {
            case 0: operand = idump.read();
                    break;
            case 1: operand = idump.read();
                    operand = (operand << 8) | idump.read();
                    break;
            case 2: operand = idump.read();
                    operand = (operand << 8) | idump.read();
                    operand = (operand << 8) | idump.read();
                    break;
            case 3: operand = idump.read();
                    operand = (operand << 8) | idump.read();
                    operand = (operand << 8) | idump.read();
                    operand = (operand << 8) | idump.read();
                    break;
                }
		ws.env = new LispObject [operand];
                if (operand == 0)
                {   w = ws;
                    break;
                }
                stack.push(ws);
                istack[sp++] = state;
                state = S_VECTOR + operand;
                continue;
            }
    case LispObject.X_LIST:
            w = nil;
            if (operand == 0) break;
            for (i=0; i<operand; i++)
                w = new Cons(nil, w);
            Cons.consCount += operand;
            if (setLabel)
            {   shared[sharedIndex++] = w;
                setLabel = false;
            }
            stack.push(w);
            istack[sp++] = state;
            state = S_CADR+operand;
            continue;
    case LispObject.X_LISTX:
            w = new Cons(nil, nil);
            {   LispObject w1 = w;
                for (i=0; i<operand; i++)
                    w = new Cons(nil, w);
                Cons.consCount += operand+1;
                if (setLabel)
                {   shared[sharedIndex++] = w;
                    setLabel = false;
                }
                stack.push(w);
                istack[sp++] = state;
                state = S_CADR+operand+1;
                stack.push(w1);
// I will fill in the very tail and then drop back to
// the case used with X_LIST
                istack[sp++] = state;
                state = S_CDR;
                continue;
            }
    case LispObject.X_NULL:
            w = null;
            break;
    case LispObject.X_DOUBLE:
            {   long v = idump.read();
                for (i=0; i<7; i++)
                    v = (v << 8) | idump.read();
                w = new LispFloat(Double.longBitsToDouble(v));
            }
            break;
    case LispObject.X_SPID:
            w = new Spid(idump.read());
            break;
    case LispObject.X_DEFINMOD:
// This case is ONLY expected to be present in FASL modules, and it is a
// prefix indicating what to do with some subsequent stuff.
            {   int n0=idump.read(), n1=0, n2=0;
                if ((n0 & 0x80) != 0)
                {   n0 &= 0x7f;
                    n1 = idump.read();
                    if ((n1 & 0x80) != 0)
                    {   n1 &= 0x7f;
                        n2 = idump.read();
                    }
                }
                n0 = n0 + (n1 << 7) + (n2 << 14);
// That has read in a 22-bit number. Actually only 18 bits are really needed
// in the CSL byte-compiler model so I have some spare capacity. I offset
// values by 1 so I can represent "-1" too.
                w = new Spid(Spid.DEFINMOD, n0-1);
            }
            break;
    case LispObject.X_STREAM:
            w = Jlisp.nil;       // new LispStream();
            break;
    case LispObject.X_FNAME:
            operand = idump.read();
            {   byte [] data = new byte[operand];
                for (i=0; i<operand; i++) data[i] = (byte)idump.read();
                String s = new String(data, "UTF8");
                w = (LispObject)builtinFunctions.get(s);
                if (w == null)
                    Jlisp.lispErr.println(s + " not found");
            }
            break;
    case LispObject.X_SPECFN:
            operand = idump.read();
            {   byte [] data = new byte[operand];
                for (i=0; i<operand; i++) data[i] = (byte)idump.read();
                String s = new String(data, "UTF8");
                w = (LispObject)builtinSpecials.get(s);
                if (w == null)
                    Jlisp.lispErr.println(s + " not found");
            }
            break;
    case LispObject.X_STORE:
            setLabel = true;
            continue;
    default:
            throw new IOException("Bad byte in image file");
        }
// For objects that were read all in one gulp I arrive here and must
// impose sharing.
        if (setLabel)
        {   shared[sharedIndex++] = w;
            setLabel = false;
        }
// Now I have read in an object (it is in w) so I need to consider what to
// do with it! It may be that processing this object will complete another
// whose actions had been stacked, so I have a loop here which unwinds
// the stack. If I "break" that will take me back to where the next item
// gets read.
        for (;;)
        {   LispObject y = (LispObject)stack.peek();
            if (state > S_VECTOR)
            {   if (y instanceof LispVector)
                    ((LispVector)y).vec[--state - S_VECTOR] = w;
                else if (y instanceof FnWithEnv)
                    ((FnWithEnv)y).env[--state - S_VECTOR] = w;
                else throw new IOException("Corrupt image file");
                if (state == S_VECTOR) // now completed?
                {   if (y instanceof LispVector)
                    {   stack.pop();
                        w = y;
                        state = istack[--sp];
                        continue;
                    }
                    else if (y instanceof FnWithEnv)
                    {   stack.pop();
                        w = y;
                        state = istack[--sp];
                        continue;
                    }
                }
                else break;
            }
            else switch (state)
            {
        case S_START:
                return w;
        case S_CADR+16:
                y = y.cdr;
        case S_CADR+15:
                y = y.cdr;
        case S_CADR+14:
                y = y.cdr;
        case S_CADR+13:
                y = y.cdr;
        case S_CADR+12:
                y = y.cdr;
        case S_CADR+11:
                y = y.cdr;
        case S_CADR+10:
                y = y.cdr;
        case S_CADR+9:
                y = y.cdr;
        case S_CADR+8:
                y = y.cdr;
        case S_CADR+7:
                y = y.cdr;
        case S_CADR+6:
                y = y.cdr;
        case S_CADR+5:
                y = y.cdr;
        case S_CADR+4:
                y = y.cdr;
        case S_CADR+3:
                y = y.cdr;
        case S_CADR+2:
                y = y.cdr;
                y.car = w;
                state--;
                break;
        case S_CADR+1:
                y.car = w;
                w = (LispObject)stack.pop();
                state = istack[--sp];
                continue;
        case S_CDR:
                {   Cons wc = (Cons)stack.pop();
                    wc.cdr = w;
                    state = istack[--sp];  // will be S_CADR+nn
                }
                break;
        case S_HASHKEY:
                if (w == null)  // hash table now complete
                {   w = (LispObject)stack.pop();
                    state = istack[--sp];
                    continue;
                }
                stack.push(w);
                state = S_HASHVAL;
                break;
        case S_HASHVAL:
                {   LispObject k = (LispObject)stack.pop();
                    LispHash h = (LispHash)stack.peek();
                    h.hash.put(k, w);
                }
                state = S_HASHKEY;
                break;
        case S_SYMFN:
                {   Symbol ws = (Symbol)stack.peek();
                    ws.fn = (LispFunction)w;
                    state = S_SYMSPECIAL;
                    break;
                }
        case S_SYMSPECIAL:
                {   Symbol ws = (Symbol)stack.peek();
                    ws.special = (SpecialFunction)w;
                    state = S_SYMPLIST;
                    break;
                }
        case S_SYMPLIST:
                {   Symbol ws = (Symbol)stack.peek();
                    ws.cdr/*plist*/ = (LispObject)w;
                    state = S_SYMVAL;
                    break;
                }
        case S_SYMVAL:
                {   Symbol ws = (Symbol)stack.pop();
                    ws.car/*value*/ = (LispObject)w;
                    w = ws;
                    state = istack[--sp];
                    continue;
                }
        case S_AUTONAME:
                {   AutoLoad wa = (AutoLoad)stack.peek();
                    wa.name = (Symbol)w;
                    state = S_AUTODATA;
                    break;
                }
        case S_AUTODATA:
                {   AutoLoad wa = (AutoLoad)stack.pop();
                    wa.data = w;
                    w = wa;
                    state = istack[--sp];
                    continue;
                }
        case S_INTERP_BODY:
                {   Interpreted wa = (Interpreted)stack.pop();
                    wa.body = w;
                    w = wa;
                    state = istack[--sp];
                    continue;
                }
        case S_MACRO_BODY:
                {   Macro wa = (Macro)stack.pop();
                    wa.body = w;
                    w = wa;
                    state = istack[--sp];
                    continue;
                }
        case S_CALLAS_BODY:
                {   CallAs wa = (CallAs)stack.pop();
                    wa.body = w;
                    w = wa;
                    state = istack[--sp];
                    continue;
                }
        default:
                lispIO.println("Unknown state");
                throw new IOException("Malformed image file (bad state)");
            }
            break;    // so "break" in the switch corresponds to
                      // requesting a SHIFT, while "continue" is a REDUCE.
        }
    }
}


// read a single parenthesised expression.
// Supports  'xx as a short-hand for (quote xx)
// which is what most Lisps do.

// Formal syntax:
//    read => SYMBOL | NUMBER | STRING
//         => ' read
//         => ` read
//         => , read
//         => ,@ read
//         => ( tail
//    tail => )
//         => . read )
//         => read readtail

static LispStream readIn;

static LispObject read() throws Exception
{
    LispObject r;
    r = lit[Lit.std_input].car/*value*/;
    if (r instanceof LispStream) readIn = (LispStream)r;
    else throw new EOFException();
    if (!readIn.inputValid)
    {   inputType = readIn.nextToken();
        readIn.inputValid = true;
    }
    switch (inputType)
    {
case LispStream.TT_EOF:
        throw new EOFException();
case LispStream.TT_WORD:
        readIn.inputValid = false;
        return readIn.value;
        //case LispStream.TT_NUMBER:
        //readIn.inputValid = false;
        //return readIn.value;
        //case '\"':  // String
        //r = new LispString(readIn.sval);
        //readIn.inputValid = false;
        //return r;
case '\'':
        readIn.inputValid = false;
        r = read();
        return new Cons(lit[Lit.quote], new Cons(r, nil));
case '`':
        readIn.inputValid = false;
        r = read();
        return expandBackquote(r);
case ',':
        readIn.inputValid = false;
        r = read();
        return new Cons(lit[Lit.comma], new Cons(r, nil));
case 0x10000:  // ",@"
        readIn.inputValid = false;
        r = read();
        return new Cons(lit[Lit.commaAt], new Cons(r, nil));
case '(':
        readIn.inputValid = false;
        return readTail();
case ')':
case '.':
        readIn.inputValid = false;
        return nil;
default:
        if (inputType < 128) r = chars[inputType];
        else r = Symbol.intern(String.valueOf((char)inputType));
        readIn.inputValid = false;
        return r;
    }
}

static LispObject readTail() throws Exception
{
    LispObject r;
    if (!readIn.inputValid)
    {   inputType = readIn.nextToken();
        readIn.inputValid = true;
    }
    switch (inputType)
    {
case '.':
        readIn.inputValid = false;
        r = read();
        if (!readIn.inputValid)
        {   inputType = readIn.nextToken();
            readIn.inputValid = true;
        }
        if (inputType == ')') readIn.inputValid = false;
        return r;
case LispStream.TT_EOF:
        throw new EOFException();
case ')':
        readIn.inputValid = false;
        return nil;
default:r = read();
        return new Cons(r, readTail());
    }
}

static LispObject expandBackquote(LispObject a)
{
    if (a == nil) return a;
    else if (a.atom)
        return new Cons(lit[Lit.quote], new Cons(a, nil));
    LispObject aa = a;
    if (aa.car == lit[Lit.comma]) return aa.cdr.car;
    if (!aa.car.atom)
    {   LispObject aaa = aa.car;
        if (aaa.car == lit[Lit.commaAt])
        {   LispObject v = aaa.cdr.car;
            LispObject t = expandBackquote(aa.cdr);
            return new Cons(lit[Lit.append],
                new Cons(v, new Cons(t, nil)));
        }
    }
    return new Cons(lit[Lit.cons],
        new Cons(expandBackquote(aa.car),
            new Cons(expandBackquote(aa.cdr), nil)));
}

// set up fixed definitions

static void initfns(Object [][] builtins)
{
    for (int i=0; i<builtins.length; i++)
    {   Object [] s = builtins[i];
        String name = (String)s[0];
        LispFunction fn = (LispFunction)s[1];
        fn.name = name;
        Symbol.intern(name, fn, null);
    }

}

static void initSymbols()
{
//System.out.println("Beginning cold start: " + oblistCount);
    Fns.prompt = null;
    Fns.gensymCounter = 1;

// set up nil first since it is needed by Symbol.intern
    nil = Symbol.intern("nil");
    nil.cdr/*plist*/ = nil;
    nil.car/*value*/ = nil;
    nil.car = nil.cdr = nil;

// next set up "undefined" and "t" which both have themselves as value
    lit[Lit.undefined]       = Symbol.intern("*undefined-value*");
    ((Symbol)lit[Lit.undefined]).car/*value*/ = lit[Lit.undefined];
    lispTrue                 = Symbol.intern("t");
    lispTrue.car/*value*/           = lispTrue;

// Now the remaining literals. It does not matter that undefined gets
// looked up again here, since the version already created will be found.
    for (int i=0; i<Lit.names.length; i++)
    {   lit[i] = Symbol.intern(Lit.names[i]);
    }

// The object list has a funny treatment to make it agree with CSL
    lit[Lit.starpackage].car/*value*/ =
        new LispVector(new LispObject [] {nil, obvector});

    ((Symbol)lit[Lit.raise]).car/*value*/ = nil;
    ((Symbol)lit[Lit.lower]).car/*value*/ = lispTrue;
    ((Symbol)lit[Lit.redefmsg]).car/*value*/ = lispTrue;

// The things put in lispsystem* must include various ones relied upon
// by the REDUCE (3.7) build scripts!
    ((Symbol)lit[Lit.lispsystem]).car/*value*/ =
        new Cons(new Cons(Symbol.intern("c-code"), LispInteger.valueOf(0)),
        new Cons(new Cons(Symbol.intern("name"),   new LispString("java")),
        new Cons(Symbol.intern("csl"),  // a lie, in some sense!
        new Cons(Symbol.intern("jlisp"),
        nil))));

    Fns.fluid(nil);
    Fns.fluid(lispTrue);
    Fns.fluid(lit[Lit.lispsystem]);
    Fns.fluid(lit[Lit.raise]);
    Fns.fluid(lit[Lit.lower]);
    Fns.fluid(lit[Lit.starcomp]);
    Fns.fluid(lit[Lit.commonLisp]);
    Fns.fluid(lit[Lit.redefmsg]);

    initfns(fns1.builtins);
    initfns(fns2.builtins);
    initfns(fns3.builtins);
    initfns(fns4.builtins);
    // initfns(fns5.builtins);
    // initfns(fns6.builtins);

    {   Object [][] specials = specfn.specials;
        for (int i=0; i<specials.length; i++)
        {   Object [] s = specials[i];
            String name = (String)s[0];
            SpecialFunction fn = (SpecialFunction)s[1];
            fn.name = name;
            Symbol.intern(name, null, fn);
        }
    }

    lit[Lit.restart] = nil;
    lit[Lit.hashtab] = new LispHash(new LispEqualHash(), 2);
    lit[Lit.banner]  = new LispString("Jlisp");

    modulus = 1;
    bigModulus = BigInteger.valueOf(modulus);
//System.out.println("After cold start: " + oblistCount);
}

static void readEvalPrintLoop(boolean noRestart) throws ProgEvent
{
// If the user had set a restart-function when an image was preserved
// then I will run that now unless the command-line had gone "-n" (for
// "ignore restart function". That option is only intended for allowing
// experts to recover when an image is a bit mangled!
    LispObject r = lit[Lit.restart];
    LispObject a = null;
//@
println("restart mode in read eval print loop " + restartFn + " " +
        restartModule + " " + restartArg);
    if (restarting && restartFn != null)
    {   r = Symbol.intern(restartFn);
        if (restartArg != null)
        {   LispObject save = lit[Lit.std_input].car/*value*/;
            try
            {   lit[Lit.std_input].car/*value*/ =
                    new LispStringReader(restartArg);
                a = read();
                ((LispStream)lit[Lit.std_input].car/*value*/).close();
            }
            catch (Exception e)
            {   a = null;
                System.out.println("Unexpected exception " + e);
            }
            finally
            {   lit[Lit.std_input].car/*value*/ = save;
            }
        }
        if (restartModule != null)
        {   try
            {   Fasl.loadModule(new LispString(restartModule));
            }
            catch (Exception ex)
            {   System.out.println("Unexpected exception " + ex);
            }
        }
        restartFn = null;
        restartArg = null;
        restartModule = null;
    }
    if (noRestart ||
        (r instanceof Symbol &&
         ((Symbol)r).fn instanceof Undefined) ||
        (r instanceof Undefined) ||
        (!r.atom && r.car != lit[Lit.lambda]) ||
        !(r instanceof Symbol || r instanceof Cons ||
          r instanceof LispFunction))
    {}    // cases when the restart object looks wrong
    else
    {   try
        {   if (a == null)
            {   if (r instanceof Symbol)
                    ((Symbol)r).fn.op0();
                else if (r instanceof LispFunction)
                    ((LispFunction)r).op0();
                else Fns.apply0(r);
            }
            else
            {   if (r instanceof Symbol)
                    ((Symbol)r).fn.op1(a);
                else if (r instanceof LispFunction)
                    ((LispFunction)r).op1(a);
                else Fns.apply1(r, a);
            }
        }
        catch (ProgEvent e)
        {   throw e;
        }
        catch (Exception e)
        {   // ignore all other exceptions
            System.err.println("Stopping because of error: " +
                               e.getMessage());
        }
        return;
    }
// Otherwise I will run a simple READ-EVAL-PRINT loop
    for (;;)
    {   try
        {   r = read();
        }
        catch (EOFException e)
        {
            break;
        }
        catch (Exception e)
        {   errprintln(
                "Error while reading: " + e.getMessage());
            e.printStackTrace(new PrintWriter(new WriterToLisp(
                ((LispStream)Jlisp.lit[Lit.err_output].car/*value*/))));
            break;
        }
        try
        {   LispObject v = r.eval();
            if (Specfn.progEvent != Specfn.NONE)
            {   Specfn.progEvent = Specfn.NONE;
                error("GO or RETURN out of context");
            }
            println();
            print("Value: ");
            v.print(LispObject.printEscape);
            println();
        }
        catch (Exception e)
        {   if (e instanceof LispException)
            {
                if (e instanceof ProgEvent)
                {   ProgEvent ep = (ProgEvent)e;
                    switch (ep.type)
                    {
                case ProgEvent.STOP:
                case ProgEvent.PRESERVE:
                case ProgEvent.RESTART:
                        throw ep;
                default:
                        break;
                    }
                }
                LispException e1 = (LispException)e;
                errprintln();
                errprint("+++++ Error: " + e1.message);
                if (e1.details != null)
                {   errprint(": ");
                    e1.details.errPrint();
                }
                errprintln();
            }
            else
            {   errprintln();
                errprintln("+++++ Error: " +
                                             e.getMessage());
            }
            e.printStackTrace(new PrintWriter(new WriterToLisp(
                ((LispStream)Jlisp.lit[Lit.err_output].car/*value*/))));
        }
    }
    return;
}


}

class FlushOutputThread extends Thread
{
    public void run()
    {
        for (;;)
        {   try
            {   sleep(2500);
            }
            catch (InterruptedException e)
            {}
            if (Jlisp.finishingUp) return;
// The only stream that I flush regularly is the main output one, since
// others should be directed to files (not the screen).
            if (Jlisp.lispIO != null) Jlisp.lispIO.flush();
// Well maybe I will flush the one that is currently selected if that
// is different...
            LispObject a = Jlisp.lit[Lit.std_output];
            if (a != null &&
                a instanceof Symbol) a = a.car/*value*/;
            if (a != null &&
                a != Jlisp.lispIO &&
                a instanceof LispStream)
            {   ((LispStream)a).flush();
            }
        }
    }
}

// End of Jlisp.java



REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]