<<>>
    <<SchemeIOImpl.mesa>>
        <<Copyright Ó 1988, 1989, 1991 by Xerox Corporation.  All rights reserved.>>
        <<Last changed by Pavel on July 18, 1989 8:22:44 pm PDT>>
        <<Michael Plass, December 2, 1991 10:30 am PST>>
        <<>>
    DIRECTORY
        Ascii USING [CR, FF, Letter, LF, Lower, SP, TAB],
        Atom USING [GetPName, MakeAtomFromRefText],
        Basics USING [CompareCard],
        BigCardinals USING [BigAdd, BigCARD, BigCompare, BigDivMod, BigFromBinaryRope, BigFromCard, BigFromSmall, BigMultiply, BigOdd, 
        BigPowerOfTen, BigToBinaryRope, BigToDecimalRope, BigZero, FirstOneBit, MultiplyByDigit, Zero],
        CardTab USING [Create, Fetch, Ref, Store],
        IO USING [Backup, CharsAvail, Close, EndOf, EndOfStream, GetChar, GetIndex, GetInfo, GetLineRope, GetRefAny, PeekChar, PutChar, 
        PutF, PutF1, PutFR1, PutRope, Reset, RIS, RopeFromROS, ROS, STREAM],
        List USING [CompareProc, Length, Sort],
        Real USING [Fix, FScale, Round],
        RefTab USING [Create, Fetch, Insert, Ref],
        RefText USING [Append, InlineAppendChar, ObtainScratch, ReleaseScratch, TrustTextRopeAsText],
        Rope USING [Fetch, FindBackward, Flatten, FromChar, FromRefText, Length, Map, ROPE, Size, Substr, Text],
        SafeStorage USING [GetReferentType, Type],
        Scheme USING [Any, Apply, Arith, Bignum, Car, Cdr, Char, Compile, Complain, Complex, Cons, DefinePrimitive, endOfFile, Environment, 
        Eval, Expand, false, Fixnum, Flonum, GetUserEnvironment, IsProcedure, KCheck, LookupVariableValue, MakeChar, MakeFixnum, 
        MakePolar, MakeReal, MakeRectangular, Marker, Negative, Number, NumberRep, Pair, Primitive, PrimitiveSyntax, 
        primitiveSyntaxForPrimitiveSyntaxRep, PrimitiveSyntaxRep, PrintProc, Procedure, ProperList, Ratnum, Record, RegisterInit, 
        RopeFromString, RopeFromSymbol, SimpleVector, SimpleVectorRep, String, StringFromRope, Symbol, symbolForPrimitiveSyntaxRep, 
        SymbolFromRope, Syntax, TheChar, TheString, True, true, undefined, unspecified, Vector, VectorFromList, VectorRef],
        SchemeEvents USING [Dequeue, Enqueue, EnqueueStream, FlushAvailableWhitespace, InputQueue, MakeInputQueue, Reset],
        SchemePrivate USING [ByteCodes, ByteCodesRep, ByteCodeTemplate, ByteCodeTemplateRep, ProcedureFromByteCodeTemplate, 
        TidbitProcedure],
        SchemeSys USING [CheckForAbort, DoWithIOErrorCatch, DoWithPorts, FindFileToLoad, GetFileCreateDateForStream, GetFileNameForStream, 
        GetPort, GetRope, IsFileStream, OpenFile, SetPort],
        SymTab USING [Create, Fetch, Ref, Store];

    SchemeIOImpl: CEDAR PROGRAM
    IMPORTS Ascii, Atom, Basics, BigCardinals, CardTab, IO, List, Real, RefTab, RefText, Rope, SafeStorage, Scheme, SchemeEvents, 
    SchemePrivate, SchemeSys, SymTab
    EXPORTS Scheme
    ~ BEGIN OPEN Scheme, SchemePrivate;

        ROPE: TYPE ~ Rope.ROPE;
        Port: TYPE ~ IO.STREAM;

        PrimitiveProc: TYPE ~ PROC [self: Primitive, a, b, c: Any, rest: ProperList] RETURNS [result: Any Ź NIL];

<<I/O Primitives>>
    ThePort: PUBLIC PROC [any: Any] RETURNS [Port] ~ {
        WITH any SELECT FROM
            p: Port => RETURN [p];
            ENDCASE => Complain[any, "not a port"];
        };

    printWidth: INT Ź 250;
    printDepth: INT Ź 10;

    PortPrim: PrimitiveProc ~ {
        Inner: PROC ~ {
            SELECT self.data FROM
                $currentIn => { result Ź SchemeSys.GetPort[undefined, TRUE] };
                $currentOut => { result Ź SchemeSys.GetPort[undefined, FALSE] };
                $close => { IO.Close[ThePort[a]] };
                $inputPred => {
                    WITH a SELECT FROM
                        p: Port => IF IO.GetInfo[p].variety#output THEN result Ź true
                        ENDCASE => result Ź false
                    };
                $outputPred => {
                    WITH a SELECT FROM
                        p: Port => IF IO.GetInfo[p].variety#input THEN result Ź true
                        ENDCASE => result Ź false
                    };
                $openIn => {
                    result Ź SchemeSys.OpenFile[fileName: RopeFromString[TheString[a]], in: TRUE]
                    };
                $openOut => {
                    result Ź SchemeSys.OpenFile[fileName: RopeFromString[TheString[a]], in: FALSE]
                    };
                $openInString => {
                    result Ź IO.RIS[rope: RopeFromString[TheString[a]]]
                    };
                $openOutString => {
                    result Ź IO.ROS[]
                    };
                $getOutString => {
                    WITH a SELECT FROM
                        port: Port => {
                            result Ź StringFromRope[IO.RopeFromROS[port]];
                            [] Ź IO.ROS[port];
                            }
                        ENDCASE => Complain[a, "not a port"];
                    };
                $read => { result Ź Read[SchemeSys.GetPort[a, TRUE]] };
                $readChar => {
                    result Ź endOfFile;
                    result Ź MakeChar[IO.GetChar[SchemeSys.GetPort[a, TRUE] ! IO.EndOfStream => CONTINUE]];
                    };
                $unreadChar => {
                    IO.Backup[self: SchemeSys.GetPort[b, TRUE], char: TheChar[a]­];
                    };
                $charReadyPred => {
                    p: Port ~ SchemeSys.GetPort[a, TRUE];
                    result Ź IF IO.EndOf[p] OR IO.CharsAvail[p] # 0 THEN true ELSE false;
                    };
                $eofObjectPred => { result Ź IF a = endOfFile THEN true ELSE false };
                $write => { Print[a: a, stream: SchemeSys.GetPort[b, FALSE], depth: INT.LAST, width: INT.LAST] };
                $display => { Print[a: a, stream: SchemeSys.GetPort[b, FALSE], depth: -printDepth, width: printWidth] };
                $newline => { IO.PutChar[SchemeSys.GetPort[a, FALSE], '\n] };
                $writeChar => { IO.PutChar[SchemeSys.GetPort[b, FALSE], TheChar[a]­] };
                $binaryWrite => {
                    p: Port ~ SchemeSys.GetPort[b, FALSE];
                    IO.PutChar[p, '#];
                    IO.PutChar[p, '\001];
                    WriteBinary[a, p];
                    };
                $changeLooks => {
                    p: Port ~ SchemeSys.GetPort[b, FALSE];
                    IO.PutF1[p, "%l", [rope[RopeFromString[TheString[a]]]]];
                    };
                $setPrintProc => {
                    type: SafeStorage.Type ~ SafeStorage.GetReferentType[b];
                    card: CARD ~ CARDForType[type];
                    IF NOT IsProcedure[a] THEN Complain[a, "not a procedure"];
                    [] Ź typedPrintProcs.Store[card, NEW[PrintProc Ź SchemePrintProc]];
                    [] Ź printProcData.Store[card, a];
                    };
                $setCurrentInputPort => {
                    SchemeSys.SetPort[port: ThePort[a], in: TRUE];
                    };
                $setCurrentOutputPort => {
                    SchemeSys.SetPort[port: ThePort[a], in: FALSE];
                    };
                ENDCASE => ERROR;
            };
        result Ź unspecified;
        SchemeSys.DoWithIOErrorCatch[Inner];
        };

    NoteLoad: PROC [userEnv: Environment, loadeeName, fullFName, createDate: ROPE, definedSymbols: Any] ~ {
        noteTaker: Scheme.Any Ź NIL;
        noteTakerName: Symbol ~ SymbolFromRope["*load-note-taker*"];
        noteTaker Ź LookupVariableValue[noteTakerName, userEnv ! Complain => CONTINUE];
        IF noteTaker # NIL THEN {
            p: Pair Ź NIL;
            IF createDate # NIL THEN p Ź Cons[StringFromRope[createDate], p];
            p Ź Cons[StringFromRope[IF fullFName = NIL THEN loadeeName ELSE fullFName], p];
            [] Ź Apply[noteTaker, Cons[p, Cons[definedSymbols, NIL]] ! Complain => CONTINUE];
            };
        };

    LoadPrim: PrimitiveProc ~ {
        head: Pair ~ Cons[NIL, NIL];
        last: Pair Ź head;
        env: Environment ~ NARROW[self.data];
        loadeeName: ROPE ~ RopeFromString[TheString[a]];
        Inner: PROC [port: IO.STREAM, doExpand: BOOL] ~ {
            DoOne: PROC [exp: Any] ~ {
                WITH exp SELECT FROM
                    template: ByteCodeTemplate => {
                        proc: Procedure ~ ProcedureFromByteCodeTemplate[template, env];
                        last Ź last.cdr Ź Cons[Apply[proc, NIL], NIL];
                        RETURN;
                        };
                    pair: Pair => {
                        IF NOT doExpand THEN {
                            WITH pair.car SELECT FROM
                                syntax: PrimitiveSyntax => {
                                    IF syntax­ = begin THEN {
                                        FOR tail: Any Ź pair.cdr, Cdr[tail] UNTIL tail = NIL DO
                                            DoOne[Car[tail]];
                                            ENDLOOP;
                                        RETURN;
                                        };
                                    };
                                ENDCASE;
                            };
                        };
                    ENDCASE;
                {
                    form: Any ~ IF doExpand THEN Expand[exp, env] ELSE exp;
                    proc: Procedure ~ Compile[form, env];
                    last Ź last.cdr Ź Cons[Apply[proc, NIL], NIL];
                    };
                };
            FOR exp: Any Ź Read[port], Read[port] UNTIL exp = endOfFile DO
                DoOne[exp];
                ENDLOOP;
            NoteLoad[env, loadeeName, SchemeSys.GetFileNameForStream[port], SchemeSys.GetFileCreateDateForStream[port], head.cdr];
            };
        SchemeSys.FindFileToLoad[loadeeName, Inner];
        RETURN [head.cdr]
        };

    dot: Symbol ~ SymbolFromRope["."];
    rpar: Symbol ~ SymbolFromRope[")"];

    ReadRope: PUBLIC PROC [rope: ROPE, forceLower: BOOL] RETURNS [Any] ~ {
        RETURN [Read[IO.RIS[rope], forceLower]]
        };

    environmentRefSymbol: Symbol Ź SymbolFromRope["environment-ref"];

    ParseSymbolFromRope: PROC [rope: Rope.ROPE] RETURNS [Any] ~ {
        <<Handle environment-reference notation: look for colons in the given name and, if found, convert to calls on environment-ref.>>
        index: INT Ź rope.FindBackward[":"];
        IF index = -1 OR rope.Fetch[0] = ': OR index = rope.Length[]-1 THEN
            RETURN [SymbolFromRope[rope]]
        ELSE {
            package: Rope.ROPE Ź rope.Substr[0, index];
            name: Rope.ROPE Ź rope.Substr[index + 1];
            RETURN [
                Cons[environmentRefSymbol,
                    Cons[ParseSymbolFromRope[package], 
                        Cons[Cons[$quote, Cons[SymbolFromRope[name], NIL]],
                            NIL]]]];
            };
        };

    Read: PUBLIC PROC [stream: IO.STREAM, forceLower: BOOL Ź TRUE] RETURNS [readResult: Any Ź NIL] ~ {
        scratch: REF TEXT ~ RefText.ObtainScratch[100];
        ReadInternal: PROC [inList: BOOL Ź FALSE] RETURNS [Any] ~ {
            ch: CHAR Ź '\000;
            BEGIN
                ch Ź IO.GetChar[stream ! IO.EndOfStream => GO TO eof];
                DO -- loop for skipping comments
                    SELECT GetCharClass[ch] FROM
                        whitespace => NULL;
                        comment => { [] Ź IO.GetLineRope[stream] };
                        ENDCASE => EXIT;
                    ch Ź IO.GetChar[stream ! IO.EndOfStream => GO TO eof];
                    ENDLOOP;
                EXITS eof => RETURN [endOfFile]
                END;
            SELECT ch FROM
                '( => {
                    result: Any Ź NIL;
                    last: Pair Ź NIL;
                    DO
                        next: Any Ź ReadInternal[inList: TRUE];
                        SELECT next FROM
                            dot => {
                                afterDot: Any Ź ReadInternal[inList: FALSE];
                                close: Any Ź ReadInternal[inList: TRUE];
                                IF close # rpar OR last = NIL THEN
                                    Complain[result, "invalid dotted list"];
                                last.cdr Ź afterDot;
                                RETURN [result]
                                };
                            rpar => { RETURN [result] };
                            endOfFile => { Complain[result, "unexpected-end-of-file"] };
                            ENDCASE => {
                                new: Pair Ź Cons[next, NIL];
                                IF result = NIL THEN result Ź new ELSE last.cdr Ź new;
                                last Ź new;
                                };
                        ENDLOOP;
                    };
                ') => {
                    IF NOT inList THEN 
                        Complain[MakeChar[')], "unmatched right parenthesis"]
                    ELSE
                        RETURN [rpar];
                    };
                '\" => {
                    IO.Backup[self: stream, char: '\"];
                    RETURN [StringFromRope[NARROW[IO.GetRefAny[stream: stream]]]]
                    };
                '\' => {
                    quoted: Any Ź ReadInternal[inList: FALSE];
                    RETURN [Cons[$quote, Cons[quoted, NIL]]]
                    };
                '\140 -- backquote -- => {
                    quoted: Any Ź ReadInternal[inList: FALSE];
                    RETURN [Cons[$quasiquote, Cons[quoted, NIL]]]
                    };
                ', => {
                    q: Symbol Ź $unquote;
                    IF IO.PeekChar[stream] = '@ THEN {[] Ź IO.GetChar[stream]; q Ź SymbolFromRope["unquote-splicing"]};
                    RETURN [Cons[q, Cons[ReadInternal[inList: FALSE], NIL]]]
                    };
                '\000 => {
                    <<Must be Tioga formatting>>
                    RETURN [endOfFile]
                    };
                '# => {
                    SELECT IO.PeekChar[stream ! IO.EndOfStream => Complain[StringFromRope["#"], "unexpected end-of-file in middle of #-syntax"]] FROM
                        '\001 => {[] Ź IO.GetChar[stream]; RETURN [ReadBinary[stream]]};
                        'x, 'X, 'e, 'E, 'b, 'B, 'o, 'O, 'd, 'D, 'i, 'I, 's, 'S, 'l, 'L => {
                            token: REF TEXT ~ GetToken['#, stream, forceLower, inList, scratch];
                            RETURN [ParseNumber[CheckTEXT[token]]];
                            };
                        '( => {RETURN [VectorFromList[ReadInternal[inList: FALSE]]]};
                        '\" => {RETURN [ParseSymbolFromRope[NARROW[IO.GetRefAny[stream]]]]};
                        '\\ => {
                            s: CHAR ~ IO.GetChar[stream];
                            k: CHAR ~ IO.PeekChar[stream
                                ! IO.EndOfStream =>
                                    Complain[StringFromRope["#\\"],
                                    "unexpected end-of-file in middle of #\\ character-name syntax"]];
                            IF Ascii.Letter[k] THEN {
                                a: Any ~ Read[stream];
                                WITH a SELECT FROM
                                    symbol: Symbol => {
                                        rope: ROPE ~ RopeFromSymbol[symbol];
                                        found: BOOL;
                                        character: REF ANY;

                                        <<Handle single-character names specially; the SymTab is case-insensitive.>>
                                        IF Rope.Size[rope] = 1 THEN 
                                            RETURN [MakeChar[k]];
                                        [found, character] Ź SymTab.Fetch[x: charForName, key: rope];
                                        IF found THEN 
                                            RETURN [character];
                                        };
                                    ENDCASE => NULL;
                                Complain[a, "invalid character name"];
                                };
                            RETURN [MakeChar[IO.GetChar[stream]]]
                            };
                        '! => {
                            s: Any Ź NIL;
                            [] Ź IO.GetChar[stream];
                            s Ź ReadInternal[inList: FALSE];
                            FOR p: PrimitiveSyntaxRep IN PrimitiveSyntaxRep DO
                                IF symbolForPrimitiveSyntaxRep[p] = s THEN
                                    RETURN [primitiveSyntaxForPrimitiveSyntaxRep[p]]
                                ENDLOOP;
                            IF s = $unspecified THEN 
                                RETURN [unspecified];
                            Complain[s, "unknown primitive syntax marker"];
                            };
                        't, 'T => { [] Ź IO.GetChar[stream]; RETURN[true] };
                        'f, 'F => { [] Ź IO.GetChar[stream]; RETURN[false] };
                        ENDCASE => {
                            ch: CHAR ~ IO.GetChar[stream];
                            rope: Rope.ROPE ~ IO.PutFR1["#%g", [character[ch]]];
                            Complain[StringFromRope[rope], "unknown syntax"];
                            };
                    };
                ENDCASE => NULL;    -- It's a complex token, either a symbol or a number

            {
                token: REF TEXT Ź GetToken[ch, stream, forceLower, inList, scratch];
                initial: CharClass ~ GetCharClass[token[0]];
                hasColons: BOOL Ź FALSE;
                OKSym: PROC RETURNS [ok: BOOL] ~ INLINE {
                    <<Also sets hasColons>>
                    [ok: ok, colons: hasColons] Ź ValidAsSymbol[token];
                    };
                SELECT TRUE FROM
                    inList AND token.length = 1 AND (SELECT token[0] FROM '., ') => TRUE ENDCASE => FALSE) =>
                        RETURN [Atom.MakeAtomFromRefText[token]];
                    OKSym[] => {
                        RETURN [IF hasColons THEN ParseSymbolFromRope[Rope.FromRefText[token]] ELSE Atom.MakeAtomFromRefText[token]]
                        };
                    initial = numeric OR initial = dot OR initial = sign => {
                        RETURN [ParseNumber[CheckTEXT[token]]];
                        };
                    ENDCASE =>
                        Complain[StringFromRope[Rope.FromRefText[token]], "illegally-formed symbol"];
                };

            };
        readResult Ź ReadInternal[];
        RefText.ReleaseScratch[scratch];
        };

    paranoid: BOOL ~ FALSE;
    CheckTEXT: PROC [text: REF TEXT] RETURNS [REF READONLY TEXT] ~ INLINE {
        <<Optionally copy into a TEXT of the exact size, to cause bounds faults when garbage would be referenced.>>
        RETURN [IF paranoid THEN RefText.Append[to: NEW[TEXT[text.length]], from: text] ELSE text]
        };

    GetToken: PROC [ch: CHAR, stream: IO.STREAM, forceLower: BOOL, tossTrailingWhite: BOOL, scratch: REF TEXT] RETURNS [token: REF 
    TEXT] ~ {
        <<This expects the initial character of the token to be in ch, and it better not be a terminator, comment, or whitespace.>>
        <<IF tossTrailingWhite, may eat one whitespace character after the token.>>
        token Ź scratch;
        token.length Ź 0;
        DO
            SELECT GetCharClass[ch] FROM
                terminator, comment => { IO.Backup[stream, ch]; EXIT };
                whitespace => { IF NOT tossTrailingWhite THEN IO.Backup[stream, ch]; EXIT };
                ENDCASE => { token Ź RefText.InlineAppendChar[token, ch] };
            ch Ź IO.GetChar[stream ! IO.EndOfStream => EXIT];
            ENDLOOP;
        IF token.length = 0 THEN ERROR; -- a caller bug
        IF forceLower THEN {
            FOR i: NAT IN [0..token.length) DO
                token[i] Ź Ascii.Lower[token[i]];
                ENDLOOP;
            };
        };

    ParseNumber: PROC [text: REF READONLY TEXT] RETURNS [number: Any] ~ {
        ch: CHAR;
        culprit: Any Ź endOfFile;
        index: NAT Ź 0;
        len: NAT ~ text.length;
        {
            [number, index] Ź ParseReal[text, index];
            IF index < len THEN SELECT ch Ź text[index] FROM
                '+, '- => {
                    imagPart: Any;
                    [imagPart, index] Ź ParseReal[text, index];
                    number Ź MakeRectangular[number, imagPart];
                    IF index >= len THEN GO TO blewIt;
                    ch Ź text[(indexŹindex+1)-1];
                    IF Ascii.Lower[ch] # 'i THEN {
                        culprit Ź MakeChar[ch];
                        GO TO blewIt;
                        };
                    };
                '@ => {
                    angle: Any;
                    [angle, index] Ź ParseReal[text, index+1];
                    number Ź MakePolar[number, angle];
                    };
                ENDCASE => NULL;
            IF index < len THEN {
                culprit Ź MakeChar[text[index]];
                GO TO blewIt;
                };
            EXITS
                blewIt => Complain[culprit, "ill-formed number"];
            };
        };

    bigZero: BigCardinals.BigCARD ~ BigCardinals.BigFromSmall[0];
    bigOne: BigCardinals.BigCARD ~ BigCardinals.BigFromSmall[1];
    preferFloat: BOOL Ź TRUE;

    MultiplyByCARD: PROC [big: BigCardinals.BigCARD, small: CARD] RETURNS [BigCardinals.BigCARD] ~ {
        IF small = 0 OR BigCardinals.BigZero[big] THEN RETURN [bigZero];
        IF small <= CARD16.LAST THEN RETURN [BigCardinals.MultiplyByDigit[big, small]];
        RETURN [BigCardinals.BigMultiply[big, BigCardinals.BigFromCard[small]]];
        };

    ParseReal: PROC [text: REF READONLY TEXT, index: NAT] RETURNS [Any, NAT] ~ {
        len: NAT ~ text.length;
        negative: BOOL Ź FALSE;
        exact: {true, false, unspecified} Ź unspecified;
        precisionSpecified: BOOL Ź FALSE;
        radix: CARDINAL Ź 0;    -- unspecified
        exponent: INT Ź 0;
        exponentSign: INT Ź 1;
        state: {prefix, begin, numerator, dot, afterDot, denomBegin, denominator, suffixSign, suffixBegin, suffix} Ź prefix;
        ch: CHAR;
        <<|||     accumulators for numerator and denominator         |||>>
        smallLimit: CARD ~ CARD.LAST/16; -- if bigger than this, can't fit another digit
        Digits: TYPE ~ RECORD [small: CARD, bigScale: CARD, big: BigCardinals.BigCARD Ź BigCardinals.Zero]; -- represents 
        small+(bigScale*big)
        digitsZero: Digits ~ [small: 0, bigScale: 0, big: bigZero];
        digitsOne: Digits ~ [small: 1, bigScale: 0, big: bigZero];
        Which: TYPE ~ {num, denom};
        val: ARRAY Which OF Digits Ź [num: digitsZero, denom: digitsOne];
        Fold: PROC [w: Which] ~ {
            val[w].big Ź BigCardinals.BigAdd[
                MultiplyByCARD[val[w].big, val[w].bigScale],
                BigCardinals.BigFromCard[val[w].small]
                ];
            val[w].small Ź 0;
            val[w].bigScale Ź 1;
            };
        GetVal: PROC [w: Which] RETURNS [BigCardinals.BigCARD] ~ INLINE {
            Fold[w];
            RETURN [val[w].big]
            };
        AccumDigit: PROC [w: Which, digit: CARDINAL] ~ INLINE { -- uses radix
            IF val[w].small > smallLimit OR val[w].bigScale > smallLimit THEN Fold[w];
            val[w].small Ź val[w].small*radix+digit;
            IF val[w].bigScale#0 THEN val[w].bigScale Ź val[w].bigScale*radix;
            };


        {

            AccumNumDigit: PROC [ch: CHAR, digit: CARDINAL] ~ {
                IF digit >= radix THEN 
                    Complain[MakeChar[ch], IO.PutFR1["illegal digit in radix %g numbers", [integer[radix]]]]
                ELSE AccumDigit[num, digit]
                };

            AccumAfterDotDigit: PROC [ch: CHAR, digit: CARDINAL] ~ {
                AccumNumDigit[ch, digit];
                AccumDigit[denom, 0];
                };

            AccumDenomDigit: PROC [ch: CHAR, digit: CARDINAL] ~ {
                IF digit >= radix THEN 
                    Complain[MakeChar[ch], IO.PutFR1["illegal digit in radix %g numbers", [integer[radix]]]]
                ELSE AccumDigit[denom, digit]
                };

            SignFollows: PROC RETURNS [BOOL] ~ INLINE {
                RETURN [index<len AND GetCharClass[text[index]] = sign];
                };

            IF index < len THEN SELECT ch Ź text[index] FROM
                '+, '- => {
                    indexŹindex+1;
                    negative Ź (ch = '-);
                    };
                ENDCASE;

            WHILE index < len DO
                ch Ź Ascii.Lower[text[(indexŹindex+1)-1]];
                SELECT state FROM
                    prefix => {        -- <prefix R>
                        IF ch = '#
                            THEN {
                                SetRadix: PROC [r: INTEGER] ~ {
                                    IF radix = 0
                                        THEN radix Ź r
                                        ELSE Complain[StringFromRope[IO.PutFR1["#%g", [character[ch]]]], "extra radix specifier"];
                                    };
                                IF index>=len THEN Complain[StringFromRope[Rope.FromRefText[text]], "unexpected eof"];
                                SELECT ch Ź Ascii.Lower[text[(indexŹindex+1)-1]] FROM
                                    'i, 'e => 
                                        IF exact = unspecified
                                            THEN {exact Ź IF ch = 'i THEN false ELSE true}
                                            ELSE Complain[StringFromRope[IO.PutFR1["#%g", [character[ch]]]], "extra exactness specifier"];
                                    's, 'l =>
                                        IF NOT precisionSpecified
                                            THEN precisionSpecified Ź TRUE
                                            ELSE Complain[StringFromRope[IO.PutFR1["#%g", [character[ch]]]], "extra precision specifier"];
                                    'b =>
                                        SetRadix[2];
                                    'o =>
                                        SetRadix[8];
                                    'd =>
                                        SetRadix[10];
                                    'x =>
                                        SetRadix[16];
                                    ENDCASE => 
                                        Complain[StringFromRope[IO.PutFR1["#%g", [character[ch]]]], "illegal numeric prefix"];
                                }
                            ELSE {    -- The next character is not a #
                                state Ź begin;
                                IF radix = 0 THEN radix Ź 10;
                                index Ź index - 1;
                                };
                        };
                    begin => {        -- right after <prefix R>
                        SELECT ch FROM
                            '. => {
                                state Ź dot;
                                };
                            IN ['0..'9] => {
                                state Ź numerator;
                                AccumNumDigit[ch, ch - '0];
                                };
                            IN ['a..'f] => {
                                state Ź numerator;
                                AccumNumDigit[ch, ch - 'a + 10];
                                };
                            ENDCASE => 
                                GO TO blewIt;
                        };
                    numerator => {    -- seen at least one <digit R>
                        SELECT TRUE FROM
                            ch = '/ => {
                                val[denom] Ź digitsZero;
                                state Ź denomBegin
                                };
                            ch = '. => {
                                state Ź afterDot;
                                IF preferFloat AND exact = unspecified THEN exact Ź false;
                                };
                            ch = '# => {
                                AccumNumDigit['0, 0];    -- Treat '# as an inexact zero
                                IF exact = true THEN 
                                    Complain[MakeChar[ch], "an inexact digit appeared after an explicit #e exactness prefix"]
                                ELSE 
                                    exact Ź false;
                                };
                            ch IN ['0..'9] =>
                                AccumNumDigit[ch, ch - '0];
                            ch = 'e AND (radix # 16 OR SignFollows[]) =>
                                state Ź suffixSign;
                            ch IN ['a..'f] =>
                                AccumNumDigit[ch, ch - 'a + 10];
                            ENDCASE => 
                                GO TO backupAndStop;
                        };
                    dot => {        -- no digits before the radix point; one required now
                        SELECT ch FROM
                            IN ['0..'9] => 
                                AccumAfterDotDigit[ch, ch - '0];
                            IN ['a..'f] => 
                                AccumAfterDotDigit[ch, ch - 'a + 10];
                            ENDCASE => 
                                GO TO blewIt;
                        state Ź afterDot;
                        IF preferFloat AND exact = unspecified THEN exact Ź false;
                        };
                    afterDot => {    -- the radix point has appeared, we can stop at any time
                        SELECT TRUE FROM
                            ch = '# => {
                                IF exact = true THEN 
                                    Complain[MakeChar[ch], "an inexact digit appeared after an explicit #e exactness prefix"]
                                ELSE 
                                    exact Ź false;
                                };
                            ch IN ['0..'9] =>
                                AccumAfterDotDigit[ch, ch - '0];
                            ch = 'e AND (radix # 16 OR SignFollows[]) =>
                                state Ź suffixSign;
                            ch IN ['a..'f] =>
                                AccumAfterDotDigit[ch, ch - 'a + 10];
                            ENDCASE => 
                                GO TO backupAndStop;
                        };
                    denomBegin => {    -- just saw the /
                        SELECT ch FROM
                            IN ['0..'9] => 
                                AccumDenomDigit[ch, ch - '0];
                            IN ['a..'f] => 
                                AccumDenomDigit[ch, ch - 'a + 10];
                            ENDCASE => 
                                GO TO blewIt;
                        state Ź denominator;
                        };
                    denominator => {    -- seen at least one denominator digit
                        SELECT TRUE FROM
                            ch = '# => {
                                AccumDenomDigit['0, 0];    -- Treat '# as an inexact zero
                                IF exact = true THEN 
                                    Complain[MakeChar[ch], "an inexact digit appeared after an explicit #e exactness prefix"]
                                ELSE 
                                    exact Ź false;
                                };
                            ch IN ['0..'9] => 
                                AccumDenomDigit[ch, ch - '0];
                            ch = 'e AND (radix # 16 OR SignFollows[]) =>
                                state Ź suffixSign;
                            ch IN ['a..'f] => 
                                AccumDenomDigit[ch, ch - 'a + 10];
                            ENDCASE => 
                                GO TO backupAndStop;
                        };
                    suffixSign => {    -- just saw the 'e' for the exponent
                        <<IF preferFloat AND exact = unspecified THEN exact _ false;>>
                        SELECT ch FROM
                            '+ => 
                                NULL;
                            '- =>
                                exponentSign Ź -1;
                            ENDCASE =>
                                index Ź index-1;
                        state Ź suffixBegin;
                        };
                    suffixBegin => {    -- ready for the first digit of the exponent
                        SELECT ch FROM
                            IN ['0..'9] => {
                                exponent Ź ch - '0;
                                state Ź suffix;
                                };
                            ENDCASE => 
                                GO TO blewIt;
                        };
                    suffix => {        -- seen at least one exponent digit
                        SELECT ch FROM
                            IN ['0..'9] =>
                                exponent Ź exponent * 10 + ch - '0;
                            ENDCASE => 
                                GO TO backupAndStop;
                        };
                    ENDCASE => ERROR;    -- unknown state

                REPEAT
                    backupAndStop => { index Ź index-1 };
                ENDLOOP;

            SELECT state FROM
                numerator, afterDot, denominator, suffix => {
                    IF exact # false AND exponent=0 AND val[num].bigScale = 0 AND val[denom].bigScale = 0 AND val[denom].small = 1 AND val[num].small 
                    <= CARD[INT.LAST] THEN {
                        <<SPECIAL CASE - Small exact integer>>
                        RETURN [MakeFixnum[IF negative THEN -INT[val[num].small] ELSE INT[val[num].small]], index];
                        };
                    IF exact = false AND exponent=0 AND val[num].bigScale = 0 AND val[denom].bigScale = 0 AND val[num].small <= 1000000 AND 
                    val[denom].small <= 1000000 THEN {
                        <<SPECIAL CASE - Small inexact real; can generate flonum with only one roundoff>>
                        float: REAL Ź REAL[INT[val[num].small]]/REAL[INT[val[denom].small]];
                        IF negative THEN float Ź -float;
                        RETURN [NEW[NumberRep.flonum Ź [FALSE, flonum[float]]], index];
                        };
                    RETURN [
                        MakeReal[
                            negative: negative,
                            numerator: GetVal[num],
                            denominator: GetVal[denom],
                            exponent: exponent * exponentSign,
                            radix: radix,
                            exact: exact # false], index];
                    };
                ENDCASE =>
                    GO TO blewIt;

            EXITS
                blewIt => Complain[MakeChar[ch], "illegal numeric body"];
            };
        };

    ReadBinary: PUBLIC PROC [stream: IO.STREAM, symbolTable: SimpleVector Ź NIL, encodingID: BYTE Ź 0] RETURNS [Any] ~ {
        ReadCount: PROC RETURNS [c: CARD Ź 0] ~ {
            DO
                byte: BYTE ~ ORD[IO.GetChar[stream]];
                c Ź c*128 + byte MOD 128;
                IF byte < 128 THEN EXIT;
                ENDLOOP;
            };
        ReadList: PROC [length: CARD, dotted: BOOL Ź FALSE] RETURNS [Any] ~ {
            first: Pair Ź NIL;
            last: Pair Ź NIL;
            THROUGH [0..length) DO
                new: Pair ~ Cons[ReadBinary[stream, symbolTable], NIL];
                IF last = NIL THEN { first Ź last Ź new } ELSE { last Ź last.cdr Ź new };
                ENDLOOP;
            IF dotted THEN last.cdr Ź ReadBinary[stream, symbolTable];
            RETURN [first]
            };
        markerByte: BYTE ~ ORD[IO.GetChar[stream]];
        IF markerByte > ORD[Marker.LAST]
            THEN {Complain[MakeFixnum[IO.GetIndex[stream]], "malformed binary input at this byte index"]}
            ELSE {
                marker: Marker ~ VAL[markerByte];
                SELECT marker FROM
                    list0 => RETURN [NIL];
                    list1 => RETURN [ReadList[1]];
                    list2 => RETURN [ReadList[2]];
                    list3 => RETURN [ReadList[3]];
                    listN => RETURN [ReadList[ReadCount[]]];
                    dottedList => RETURN [ReadList[ReadCount[], TRUE]];
                    symbolTable => {
                        length: NAT ~ ReadCount[];
                        v: SimpleVector ~ NEW[SimpleVectorRep[length]];
                        FOR i: NAT IN [0..length) DO
                            len: INT ~ ReadCount[];
                            name: ROPE ~ SchemeSys.GetRope[self: stream, len: len, demand: TRUE];
                            v[i] Ź SymbolFromRope[name];
                            ENDLOOP;
                        RETURN [ReadBinary[stream, v]]
                        };
                    symbol => { RETURN [symbolTable[ReadCount[]]] };
                    quote => { RETURN [primitiveSyntaxForPrimitiveSyntaxRep[quote]] };
                    define => { RETURN [primitiveSyntaxForPrimitiveSyntaxRep[define]] };
                    setBang => { RETURN [primitiveSyntaxForPrimitiveSyntaxRep[setBang]] };
                    lambda => { RETURN [primitiveSyntaxForPrimitiveSyntaxRep[lambda]] };
                    begin => { RETURN [primitiveSyntaxForPrimitiveSyntaxRep[begin]] };
                    if => { RETURN [primitiveSyntaxForPrimitiveSyntaxRep[if]] };
                    true => { RETURN [true] };
                    false => { RETURN [false] };
                    char => { RETURN [MakeChar[IO.GetChar[stream]]] };
                    string => { RETURN [StringFromRope[SchemeSys.GetRope[stream, ReadCount[]]]] };
                    vector => {
                        length: NAT ~ ReadCount[];
                        v: SimpleVector ~ NEW[SimpleVectorRep[length]];
                        FOR i: NAT IN [0..length) DO
                            v[i] Ź ReadBinary[stream, symbolTable];
                            ENDLOOP;
                        RETURN [v];
                        };
                    zero => { RETURN [MakeFixnum[0]] };
                    one => { RETURN [MakeFixnum[1]] };
                    inexact => {
                        WITH ReadBinary[stream] SELECT FROM
                            num: Number => {num.exact Ź FALSE; RETURN [num]};
                            ENDCASE => Complain[MakeFixnum[IO.GetIndex[stream]], "malformed binary input at this byte index"];
                        };
                    negFixnum => { RETURN [MakeFixnum[-INT[ReadCount[]]]] };
                    fixnum => { RETURN [MakeFixnum[ReadCount[]]] };
                    negFlonum, flonum => {
                        significand: INT ~ ReadCount[];
                        exponent: INT ~ WITH ReadBinary[stream] SELECT FROM n: Fixnum => n­ ENDCASE => Complain[MakeFixnum[IO.GetIndex[stream]], "malformed 
                        binary input at this byte index"];
                        mag: REAL ~ Real.FScale[REAL[significand], exponent];
                        RETURN [NEW [NumberRep.flonum Ź [TRUE, flonum[IF marker=negFlonum THEN -mag ELSE mag]]]]
                        };
                    negBignum, bignum => {
                        RETURN [NEW [NumberRep.bignum Ź [TRUE, bignum[neg: marker=negBignum, magnitude: 
                        BigCardinals.BigFromBinaryRope[SchemeSys.GetRope[self: stream, len: ReadCount[], demand: TRUE]]]]]]
                        };
                    ratnum => {
                        numerator: Any ~ ReadBinary[stream];
                        denominator: Any ~ ReadBinary[stream];
                        RETURN [NEW [NumberRep.ratnum Ź [TRUE, ratnum[numerator: numerator, denominator: denominator]]]]
                        };
                    complex => {
                        x: Any ~ ReadBinary[stream];
                        y: Any ~ ReadBinary[stream];
                        RETURN [NEW [NumberRep.complex Ź [TRUE, complex[x: x, y: y]]]]
                        };
                    unspecified => { RETURN [unspecified] };
                    byteCodes => {
                        length: NAT ~ ReadCount[];
                        bc: ByteCodes ~ NEW[ByteCodesRep[length]];
                        FOR i: NAT IN [0..length) DO
                            bc[i] Ź ORD[IO.GetChar[stream]];
                            ENDLOOP;
                        RETURN [bc];
                        };
                    byteCodeTemplate => {
                        name: Any ~ ReadBinary[stream, symbolTable];
                        envNames: SimpleVector ~ NARROW[ReadBinary[stream, symbolTable]];
                        dotted: BOOL ~ True[ReadBinary[stream, symbolTable]];
                        minArgs: NAT ~ KCheck[ReadBinary[stream, symbolTable]];
                        maxArgs: NAT ~ KCheck[ReadBinary[stream, symbolTable]];
                        globalNames: ProperList ~ NARROW[ReadBinary[stream, symbolTable]];
                        literals: ProperList ~ NARROW[ReadBinary[stream, symbolTable]];
                        doc: Rope.ROPE ~ RopeFromString[TheString[ReadBinary[stream, symbolTable]]];
                        ext: Any ~ ReadBinary[stream, symbolTable];
                        RETURN [NEW[ByteCodeTemplateRep Ź [
                            name: name,
                            envNames: envNames,
                            dotted: dotted,
                            minArgs: minArgs,
                            maxArgs: maxArgs,
                            globalNames: globalNames,
                            literals: literals,
                            doc: doc,
                            ext: ext
                            ]]];
                        };
                    ENDCASE => ERROR;
                };
        };

    charForName: SymTab.Ref ~ SymTab.Create[case: FALSE];
    nameForChar: REF ARRAY CHAR OF ROPE ~ InitCharNames[];
    InitCharNames: PROC RETURNS [REF ARRAY CHAR OF ROPE] ~ {
        a: REF ARRAY CHAR OF ROPE Ź NEW[ARRAY CHAR OF ROPE];
        AddName: PROC [char: CHAR, name: ROPE] ~ {
            [] Ź SymTab.Store[x: charForName, key: name, val: MakeChar[char]];
            a[char] Ź name;
            };

        <<Names are added in increasing order of preference on output.  That is, the last name assigned to each character is the one to be 
        used on output.>>

        FOR c: CHAR IN CHAR DO
            AddName[c, Rope.Flatten[IO.PutFR1[format: "o%03b", value: [integer[ORD[c]]]]]];
            ENDLOOP;

        AddName['(, Rope.Flatten["OpenPar"]];
        AddName['(, Rope.Flatten["OpenParen"]];
        AddName['), Rope.Flatten["ClosePar"]];
        AddName['), Rope.Flatten["CloseParen"]];

        FOR c: CHAR IN (' ..'~] DO
            AddName[c, Rope.FromChar[c]];
            ENDLOOP;

        AddName['\r, Rope.Flatten["Return"]];
        AddName['\l, Rope.Flatten["LineFeed"]];
        AddName['\n, Rope.Flatten["Newline"]];
        AddName['\t, Rope.Flatten["Tab"]];
        AddName[' , Rope.Flatten["Space"]];
        AddName['\f, Rope.Flatten["FormFeed"]];

        RETURN [a]
        };

    PrintRopeLiteral: PROC [stream: IO.STREAM, rope: ROPE, width: INT] ~ {
        r: INT Ź IF width > INT.LAST/8 THEN INT.LAST ELSE width*8;
        Action: PROC [c: CHAR] RETURNS [quit: BOOL Ź FALSE] ~ {
            IF r = 0 THEN {
                IO.PutRope[stream, "..."];
                RETURN [TRUE]
                };
            IF c = '" OR c='\\ THEN
                IO.PutChar[stream, '\\];
            IF c IN [' .. '~] THEN
                IO.PutChar[stream, c]
            ELSE
                IO.PutF1[stream, "\\%03b", [cardinal[ORD[c]]]];
            r Ź r - 1;
            };
        IO.PutChar[stream, '"];
        [] Ź Rope.Map[base: rope, action: Action];
        IO.PutChar[stream, '"];
        };

    sigBits: REAL Ź 24.0; -- default number of significant bits for non-flonum inexact numbers

    PutInexactRatio: PROC [stream: IO.STREAM, numerator, denominator: BigCardinals.BigCARD, significantBits: REAL] ~ {
        numBits: INT ~ BigCardinals.FirstOneBit[numerator];
        denBits: INT ~ BigCardinals.FirstOneBit[denominator];
        exponent: INT ~ Real.Round[(numBits-denBits-significantBits)*0.301];
        sNum: BigCardinals.BigCARD ~ (
            IF exponent >= 0
                THEN numerator
                ELSE BigCardinals.BigMultiply[numerator, BigCardinals.BigPowerOfTen[-exponent]]);
        sDen: BigCardinals.BigCARD ~ (
            IF exponent <= 0
                THEN denominator
                ELSE BigCardinals.BigMultiply[denominator, BigCardinals.BigPowerOfTen[exponent]]);
        quo, rem: BigCardinals.BigCARD;
        [quo, rem] Ź BigCardinals.BigDivMod[sNum, sDen];
        SELECT BigCardinals.BigCompare[BigCardinals.BigAdd[rem, rem], sDen] FROM
            greater => { quo Ź BigCardinals.BigAdd[quo, bigOne] };
            equal => {
                <<break tie by rounding towards even.>>
                IF BigCardinals.BigOdd[quo] THEN quo Ź BigCardinals.BigAdd[quo, bigOne];
                };
            ENDCASE => NULL;
        IF BigCardinals.BigZero[quo]
            THEN IO.PutRope[stream, "0.0"]
            ELSE {
                digits: ROPE Ź BigCardinals.BigToDecimalRope[quo];
                nDigits: INT Ź Rope.Size[digits];
                exp: INT Ź exponent;
                WHILE nDigits > 2 AND Rope.Fetch[digits, nDigits-1] = '0 DO
                    digits Ź Rope.Substr[base: digits, start: 0, len: nDigits-1];
                    nDigits Ź nDigits-1;
                    exp Ź exp + 1;
                    ENDLOOP;
                IO.PutF[stream, "%g.%g", [character[Rope.Fetch[digits, 0]]], [rope[Rope.Substr[digits, 1]]]];
                IF exp+(nDigits-1) # 0 THEN {
                    IO.PutF1[stream, "e%g", [integer[exp+(nDigits-1)]]];
                    };
                };
        };

    typedPrintProcs: CardTab.Ref ~ CardTab.Create[];
    fallbackPrintProcs: LIST OF PrintProc Ź NIL;
    printProcData: CardTab.Ref ~ CardTab.Create[];

    CARDForType: PROC [type: SafeStorage.Type] RETURNS [CARD] ~ INLINE {
        RETURN [ORD[type]]
        };

    RegisterPrintProc: PUBLIC PROC [proc: PrintProc, type: SafeStorage.Type] ~ {
        [] Ź typedPrintProcs.Store[CARDForType[type], NEW[PrintProc Ź proc]];
        };

    RegisterFallbackPrintProc: PUBLIC PROC [proc: PrintProc] ~ {
        fallbackPrintProcs Ź CONS[proc, fallbackPrintProcs];
        };

    RegisterSimplePrintProc: PUBLIC PROC [typeName: Rope.ROPE, type: SafeStorage.Type] ~ {
        card: CARD ~ CARDForType[type];
        [] Ź typedPrintProcs.Store[card, NEW[PrintProc Ź SimplePrintProc]];
        [] Ź printProcData.Store[card, typeName];
        };

    SimplePrintProc: PrintProc ~ {
        type: SafeStorage.Type ~ SafeStorage.GetReferentType[value];
        name: Rope.ROPE ~ NARROW[printProcData.Fetch[CARDForType[type]].val];
        stream.PutF["#<%g @ %x>", [rope[name]], [cardinal[LOOPHOLE[value, CARD]]]];
        };

    SchemePrintProc: PrintProc ~ {
        type: SafeStorage.Type ~ SafeStorage.GetReferentType[value];
        proc: Any ~ printProcData.Fetch[CARDForType[type]].val;
        [] Ź Apply[proc, Cons[stream, Cons[value, Cons[IF display THEN true ELSE false, NIL]]]];
        };

    Print: PUBLIC PROC [a: Any, stream: IO.STREAM, depth: INT Ź INT.LAST, width: INT Ź INT.LAST] ~ {
        <<HACK: if depth < 0, does display instead of write>>
        display: BOOL Ź depth < 0;
        depth1: INT Ź IF depth < 0 THEN depth+1 ELSE IF depth > 0 THEN depth-1 ELSE depth;
        PrintList: PROC [pair: Pair] ~ {
            rest: Pair Ź NIL;
            rem: INT Ź width;
            FOR each: Pair Ź pair, rest UNTIL each = NIL DO
                IF rest # NIL THEN IO.PutRope[stream, " "];
                IF rem <= 0 THEN {IO.PutRope[stream, ". . ."]; EXIT};
                Print[a: each.car, stream: stream, depth: depth1, width: width];
                rem Ź rem - 1;
                WITH each.cdr SELECT FROM
                    p: Pair => rest Ź p;
                    ENDCASE => {
                        IF each.cdr # NIL THEN {
                            IO.PutRope[stream, " . "];
                            Print[a: each.cdr, stream: stream, depth: depth1, width: width];
                            };
                        rest Ź NIL;
                        };
                ENDLOOP;
            };
        WITH a SELECT FROM
            pair: Pair => {
                IF depth = 0 THEN {IO.PutRope[stream, "( . . . )"]; RETURN};
                IO.PutRope[stream, "("];
                PrintList[pair];
                IO.PutRope[stream, ")"];
                };
            num: Fixnum => IO.PutF1[stream, "%g", [integer[num­]]];
            num: Flonum => {
                IF num.exact
                    THEN { Print[a: Arith[plus, num, MakeFixnum[0]], stream: stream, depth: depth1, width: width] }
                    ELSE { IO.PutF1[stream, "%g", [real[num.real]]] };
                };
            num: Bignum => {
                IF num.neg THEN IO.PutChar[stream, '-];
                IF num.exact
                    THEN {
                        IO.PutRope[stream, BigCardinals.BigToDecimalRope[num.magnitude]];
                        }
                    ELSE { PutInexactRatio[stream, num.magnitude, bigOne, sigBits] };
                };
            num: Ratnum => {
                IF num.exact
                    THEN {
                        Print[num.numerator, stream, depth, width];
                        IO.PutChar[stream, '/];
                        Print[num.denominator, stream, depth, width];
                        }
                    ELSE {
                        numer: Bignum ~ NARROW[num.numerator];
                        denom: Bignum ~ NARROW[num.denominator];
                        IF numer.neg THEN IO.PutChar[stream, '-];
                        PutInexactRatio[stream, numer.magnitude, denom.magnitude, sigBits];
                        };
                };
            num: Complex => {
                Print[num.x, stream, depth, width];
                IF NOT Negative[num.y] THEN IO.PutChar[stream, '+];
                Print[num.y, stream, depth, width];
                IO.PutChar[stream, 'i];
                };
            b: REF BOOL => IO.PutRope[stream, IF b­ THEN "#t" ELSE "#f"];
            v: SimpleVector => {
                IF depth = 0 THEN {IO.PutRope[stream, "#( . . . )"]; RETURN};
                IO.PutRope[stream, "#("];
                FOR i: NAT IN [0..v.length) DO
                    IF i # 0 THEN IO.PutRope[stream, " "];
                    IF i >= width THEN { IO.PutRope[stream, ". . ."]; EXIT };
                    Print[a: v[i], stream: stream, depth: depth1, width: width];
                    ENDLOOP;
                IO.PutRope[stream, ")"];
                };
            v: Vector => {
                IF depth = 0 THEN {IO.PutRope[stream, "#( . . . )"]; RETURN};
                IO.PutRope[stream, "#("];
                FOR i: INT IN [0..v.length) DO
                    IF i # 0 THEN IO.PutRope[stream, " "];
                    IF i >= width THEN { IO.PutRope[stream, ". . ."]; EXIT };
                    Print[a: VectorRef[v, i], stream: stream, depth: depth1, width: width];
                    ENDLOOP;
                IO.PutRope[stream, ")"];
                };
            symbol: Symbol => {
                rope: Rope.Text ~ Atom.GetPName[symbol];
                IF ValidAsSymbol[RefText.TrustTextRopeAsText[rope]].ok
                    THEN IO.PutRope[stream, rope]
                    ELSE IO.PutF1[stream, "#\"%q\"", [rope[rope]]];
                };
            string: String => {
                IF depth < 0
                    THEN IO.PutRope[stream, RopeFromString[string]]
                    ELSE PrintRopeLiteral[stream, RopeFromString[string], width];
                };
            rope: ROPE => {
                IF depth < 0
                    THEN IO.PutRope[stream, rope]
                    ELSE PrintRopeLiteral[stream, rope, width];
                };
            char: Char => {
                IF depth < 0
                    THEN IO.PutChar[stream, char­]
                    ELSE IO.PutF1[stream, "#\\%g", [rope[nameForChar[char­]]]];
                };
            p: Primitive => {
                pRep: Pair Ź Cons[StringFromRope[p.doc], NIL];
                IF p.doc.Fetch[0] # '( THEN {
                    IF p.dotted THEN pRep Ź Cons[$rest, pRep] ELSE pRep Ź Cons[NIL, pRep];
                    IF p.minArgs # p.maxArgs THEN pRep.car Ź Cons[StringFromRope["]"], pRep.car];
                    FOR n: NAT DECREASING IN [0..p.maxArgs) DO
                        pRep.car Ź Cons[SymbolFromRope[Rope.FromChar['a+n]], pRep.car];
                        IF n = p.minArgs THEN pRep.car Ź Cons[StringFromRope["["], pRep.car];
                        ENDLOOP;
                    };
                IO.PutF1[stream, "#<primitive %g: ", [atom[p.symbol]]];
                depth1 Ź -2;
                PrintList[pRep];
                IO.PutRope[stream, ">"];
                };
            p: TidbitProcedure => {
                IO.PutRope[stream, "#<procedure "];
                Print[p.code.name, stream];
                IO.PutF1[stream, ": %g>", [rope[p.code.doc]]];
                };
            <<p: CompoundProcedure => {>>
                <<names: SimpleVector ~ p.parameterNames;>>
                <<pRep: Pair _ NIL;>>
                <<>>
                <<IF ISTYPE[Car[p.body], String] AND Cdr[p.body] # NIL THEN -- it's a doc string>>
                    <<pRep _ Cons[Car[p.body], NIL];>>
                <<IF pRep = NIL OR StringRef[NARROW[pRep.car], 0] # '( THEN {>>
                    <<IF p.dotted THEN>>
                        <<pRep _ Cons[names[names.length-1], pRep]>>
                    <<ELSE>>
                        <<pRep _ Cons[NIL, pRep];>>
                    <<FOR i: NAT DECREASING IN [0..names.length - (IF p.dotted THEN 1 ELSE 0)) DO>>
                        <<pRep.car _ Cons[names[i], pRep.car];>>
                        <<ENDLOOP;>>
                    <<};>>
                <<>>
                <<IO.PutRope[stream, "#<procedure"];>>
                <<IF depth # 0 THEN {>>
                    <<IO.PutRope[stream, " "];>>
                    <<depth1 _ -2;>>
                    <<PrintList[pRep]>>
                    <<};>>
                <<IO.PutRope[stream, ">"];>>
                <<};>>
            s: Syntax => {
                IO.PutRope[stream, "#<syntax "];
                IF depth # 0 THEN Print[a: s.expander, stream: stream, depth: depth1, width: width];
                IO.PutRope[stream, ">"];
                };
            p: PrimitiveSyntax => {
                IF NOT display THEN IO.PutRope[stream, "#!"];
                IO.PutRope[stream, RopeFromSymbol[symbolForPrimitiveSyntaxRep[p­]]];
                };
            env: Environment => {
                IO.PutRope[stream, "#<environment "];
                Print[a: IF env.names = NIL THEN env[1] ELSE env.names, stream: stream, depth: -ABS[depth1], width: width]; -- force display
                IO.PutRope[stream, ">"];
                };
            p: Port => {
                class: ATOM ~ IO.GetInfo[stream: p].class;
                IO.PutRope[stream, "#<"];
                IO.PutRope[stream, SELECT IO.GetInfo[stream: p].variety FROM input => "input", output => "output", inputOutput => "input-output" 
                ENDCASE => ERROR];
                IO.PutRope[stream, "-port "];
                IO.PutRope[stream, RopeFromSymbol[class]];
                IF SchemeSys.IsFileStream[stream] THEN {
                    IO.PutRope[stream, " "];
                    IO.PutRope[stream, SchemeSys.GetFileNameForStream[stream]];
                    };
                IO.PutRope[stream, ">"];
                };
            r: Record => {
                length: NAT ~ r.length;
                index: NAT Ź 0;
                proc: Any Ź NIL;
                WHILE index # length DO
                    WITH r[index] SELECT FROM
                        p: Pair => {  -- Magic cookie for record type: (print-proc . length)
                            proc Ź p.car;
                            index Ź KCheck[p.cdr, length];
                            };
                        ENDCASE =>  -- Oops! No magic cookie; record either bad or not yet together
                            GOTO bad;
                    ENDLOOP;
                [] Ź Apply[proc, Cons[stream, Cons[r, Cons[IF display THEN true ELSE false, NIL]]]];

                EXITS
                    bad => stream.PutF1["#<Record @ %x>", [cardinal[LOOPHOLE[r, CARD]]]];
                };
            ENDCASE => {
                SELECT a FROM
                    NIL => IO.PutRope[stream, "()"];
                    endOfFile => IO.PutRope[stream, "#<eof-object>"];
                    unspecified => IO.PutRope[stream, "#!unspecified"];
                    ENDCASE => {
                        type: SafeStorage.Type ~ SafeStorage.GetReferentType[a];
                        WITH typedPrintProcs.Fetch[CARDForType[type]].val SELECT FROM
                            proc: REF PrintProc =>
                                [] Ź proc­[stream, a, display];
                            ENDCASE => {
                                FOR tail: LIST OF PrintProc Ź fallbackPrintProcs, tail.rest UNTIL tail = NIL DO
                                    IF tail.first[stream, a, display] THEN RETURN;
                                    ENDLOOP;
                                IO.PutF1[stream, "%g", [refAny[a]]];
                                };
                        };
                };
        };

    AtomTableEntry: TYPE ~ REF AtomTableEntryRep;
    AtomTableEntryRep: TYPE ~ RECORD [symbol: Symbol, n: CARD];

    CompareAtomTableEntry: List.CompareProc = {
        <<[ref1: REF ANY, ref2: REF ANY] RETURNS [Basics.Comparison]>>
        a: AtomTableEntry ~ NARROW[ref1];
        b: AtomTableEntry ~ NARROW[ref2];
        RETURN [Basics.CompareCard[b.n, a.n]]
        };

    largestFlonumFraction: REAL Ź LargestFlonumFraction[];
    LargestFlonumFraction: PROC RETURNS [REAL] ~ INLINE {
        a: REAL Ź 0.5;
        FOR i: NAT IN [0..1000) DO
            b: REAL ~ a+a+0.5;
            IF b = REAL[Real.Fix[b]] THEN RETURN [a];
            a Ź b;
            ENDLOOP;
        ERROR; -- this doesn't act like floating point!
        };

    BinaryFlonum: TYPE ~ RECORD [neg: BOOL, significand: CARD, exponent: INT];

    BinaryFlonumFromREAL: PROC [real: REAL] RETURNS [b: BinaryFlonum Ź [FALSE, 0, 0]] ~ {
        IF real < 0 THEN {real Ź -real; b.neg Ź TRUE};
        WHILE real > largestFlonumFraction DO
            real Ź Real.FScale[real, -1];
            b.exponent Ź b.exponent + 1;
            ENDLOOP;
        UNTIL real = Real.Round[real] DO
            real Ź Real.FScale[real, 1];
            b.exponent Ź b.exponent - 1;
            ENDLOOP;
        b.significand Ź Real.Round[real];
        };

    WriteBinary: PUBLIC PROC [a: Any, stream: IO.STREAM, encodingID: BYTE Ź 0] ~ {
        list: LIST OF REF Ź NIL;
        tab: RefTab.Ref ~ RefTab.Create[];
        n: INT Ź 0;
        recursionLimit: NAT Ź 100; -- for protection against circular structures
        WriteMarker: PROC [marker: Marker] ~ { IO.PutChar[stream, VAL[ORD[marker]]] };
        WriteCount: PROC [i: CARD] ~ {
            c: ARRAY [0..5) OF BYTE Ź ALL[0];
            k: NAT Ź 0;
            DO
                c[k] Ź (i MOD 128) + 128;
                k Ź k + 1;
                i Ź i / 128;
                IF i = 0 THEN EXIT;
                ENDLOOP;
            c[0] Ź c[0]-128;
            UNTIL k = 0 DO
                k Ź k - 1;
                IO.PutChar[stream, VAL[c[k]]];
                ENDLOOP;
            };
        WriteNumber: PROC [any: Any] ~ {
            WITH any SELECT FROM
                num: Fixnum => {
                    WriteMarker[IF num­ < 0 THEN negFixnum ELSE fixnum];
                    WriteCount[ABS[num­]];
                    };
                num: Flonum => {
                    b: BinaryFlonum ~ BinaryFlonumFromREAL[num.real];
                    WriteMarker[IF num.real < 0 THEN negFlonum ELSE flonum];
                    WriteCount[b.significand];
                    WriteMarker[IF b.exponent < 0 THEN negFixnum ELSE fixnum];
                    WriteCount[ABS[b.exponent]];
                    };
                num: Bignum => {
                    rope: ROPE ~ BigCardinals.BigToBinaryRope[num.magnitude];
                    WriteMarker[IF num.neg THEN negBignum ELSE bignum];
                    WriteCount[Rope.Size[rope]];
                    IO.PutRope[stream, rope];
                    };
                num: Ratnum => {
                    WriteMarker[ratnum];
                    WriteNumber[num.numerator];
                    WriteNumber[num.denominator];
                    };
                num: Complex => {
                    WriteMarker[complex];
                    WriteNumber[num.x];
                    WriteNumber[num.y];
                    };
                ENDCASE => Complain[any, "not an externalizeable number"];
            };
        Pass1: PROC [a: Any] ~ {
            SchemeSys.CheckForAbort[];
            recursionLimit Ź recursionLimit - 1; -- for protection against circular structures
            DO
                WITH a SELECT FROM
                    pair: Pair => { Pass1[pair.car]; a Ź pair.cdr; LOOP };
                    symbol: Symbol => {
                        ate: AtomTableEntry ~ NARROW[RefTab.Fetch[x: tab, key: symbol].val];
                        IF ate = NIL
                            THEN {
                                list Ź CONS[NEW[AtomTableEntryRep Ź [symbol, 1]], list];
                                [] Ź RefTab.Insert[x: tab, key: symbol, val: list.first]
                                }
                            ELSE { ate.n Ź ate.n + 1 }
                        };
                    v: SimpleVector => {
                        FOR i: NAT IN [0..v.length) DO
                            Pass1[v[i]];
                            ENDLOOP;
                        };
                    v: Vector => {
                        FOR i: INT IN [0..v.length) DO
                            Pass1[v.ref[v, i]];
                            ENDLOOP;
                        };
                    bct: ByteCodeTemplate => {
                        Pass1[bct.name];
                        Pass1[bct.envNames];
                        Pass1[bct.globalNames];
                        Pass1[bct.literals];
                        };
                    ENDCASE => NULL;
                EXIT;
                ENDLOOP;
            recursionLimit Ź recursionLimit + 1;
            };
        Pass2: PROC [a: Any] ~ {
            SchemeSys.CheckForAbort[];
            WITH a SELECT FROM
                pair: Pair => {
                    length: INT Ź 0;
                    dotted: BOOL Ź FALSE;
                    FOR tail: Any Ź pair, Cdr[tail] DO
                        WITH tail SELECT FROM
                            p: Pair => { length Ź length + 1 };
                            ENDCASE => {dotted Ź tail#NIL; EXIT};
                        ENDLOOP;
                    IF dotted OR length > 3
                        THEN {
                            WriteMarker[IF dotted THEN dottedList ELSE listN];
                            WriteCount[length];
                            }
                        ELSE {
                            WriteMarker[SELECT length FROM 1 => list1, 2 => list2, 3 => list3 ENDCASE => ERROR];
                            };
                    FOR tail: Any Ź pair, Cdr[tail] DO
                        WITH tail SELECT FROM
                            p: Pair => {Pass2[p.car]};
                            ENDCASE => {IF dotted THEN Pass2[tail]; EXIT};
                        ENDLOOP;
                    };
                symbol: Symbol => {
                    ate: AtomTableEntry ~ NARROW[RefTab.Fetch[x: tab, key: symbol].val];
                    WriteMarker[symbol];
                    WriteCount[ate.n];
                    };
                primitiveSyntax: PrimitiveSyntax => {
                    WriteMarker[SELECT primitiveSyntax­ FROM
                        quote => quote, define => define, setBang => setBang, lambda => lambda, begin => begin, if => if
                        ENDCASE => ERROR];
                    };
                num: Fixnum => {
                    SELECT num­ FROM
                        0 => WriteMarker[zero];
                        1 => WriteMarker[one];
                        ENDCASE => WriteNumber[num]
                        };
                num: Number => {
                    IF NOT num.exact THEN WriteMarker[inexact];
                    WriteNumber[num];
                    };
                b: REF BOOL => { WriteMarker[IF b­ THEN true ELSE false] };
                v: SimpleVector => {
                    WriteMarker[vector];
                    WriteCount[v.length];
                    FOR i: NAT IN [0..v.length) DO
                        Pass2[v[i]];
                        ENDLOOP;
                    };
                v: Vector => {
                    WriteMarker[vector];
                    WriteCount[v.length];
                    FOR i: INT IN [0..v.length) DO
                        Pass2[v.ref[v, i]];
                        ENDLOOP;
                    };
                string: String => {
                    rope: ROPE ~ RopeFromString[string];
                    WriteMarker[string];
                    WriteCount[Rope.Size[rope]];
                    IO.PutRope[stream, rope];
                    };
                char: Char => {
                    WriteMarker[char];
                    IO.PutChar[stream, char­];
                    };
                bct: ByteCodeTemplate => {
                    WriteMarker[byteCodeTemplate];
                    Pass2[bct.name];
                    Pass2[bct.envNames];
                    Pass2[IF bct.dotted THEN true ELSE false];
                    Pass2[MakeFixnum[bct.minArgs]];
                    Pass2[MakeFixnum[bct.maxArgs]];
                    Pass2[bct.globalNames];
                    Pass2[bct.literals];
                    Pass2[StringFromRope[bct.doc]];
                    Pass2[bct.ext];
                    };
                bc: ByteCodes => {
                    WriteMarker[byteCodes];
                    WriteCount[bc.size];
                    FOR i: INT IN [0..bc.size) DO
                        IO.PutChar[stream, VAL[bc[i]]];
                        ENDLOOP;
                    };
                ENDCASE => {
                    SELECT a FROM
                        NIL => WriteMarker[list0];
                        unspecified => WriteMarker[unspecified];
                        ENDCASE => Complain[a, "cannot be externalized"];
                    };
            };
        Pass1[a];
        IF list # NIL THEN {
            list Ź List.Sort[list: list, compareProc: CompareAtomTableEntry];
            WriteMarker[symbolTable];
            WriteCount[List.Length[list]];
            FOR each: LIST OF REF Ź list, each.rest UNTIL each = NIL DO
                ate: AtomTableEntry ~ NARROW[each.first];
                text: Rope.Text ~ Atom.GetPName[ate.symbol];
                WriteCount[Rope.Size[text]];
                IO.PutRope[self: stream, r: text];
                ate.n Ź n;
                n Ź n + 1;
                ENDLOOP;
            };
        Pass2[a];
        };

    CharClass: TYPE ~ {lowercase, extendedAlpha, uppercase, numeric, dot, sign, terminator, whitespace, comment, other};
    charClassTable: REF ARRAY CHAR OF CharClass ~ NEW[ARRAY CHAR OF CharClass Ź InitCharClassTable[]];
    GetCharClass: PROC [char: CHAR] RETURNS [CharClass] ~ INLINE {
        RETURN [charClassTable­[char]]
        };
    InitCharClassTable: PROC RETURNS [a: ARRAY CHAR OF CharClass] ~ INLINE {
        FOR char: CHAR IN CHAR DO
            a[char] Ź (
                SELECT char FROM
                    Ascii.SP, Ascii.TAB, Ascii.CR, Ascii.LF, Ascii.FF => whitespace,
                    '(, '), '" => terminator,
                    IN ['a..'z] => lowercase,
                    IN ['A..'Z] => uppercase,
                    '; => comment,
                    '*, '/, '<, '=, '>, '!, '?, ':, '$, '%, '_, '&, '~, '^ => extendedAlpha,
                    IN ['0..'9] => numeric,
                    '+, '- => sign,
                    '. => dot,
                    '{, '} => extendedAlpha,    -- A Cedar Scheme extension
                    ENDCASE => other
                )
            ENDLOOP;
        };

    ValidAsSymbol: PROC [text: REF READONLY TEXT] RETURNS [ok: BOOL Ź TRUE, colons: BOOL Ź FALSE] ~ {
        notInitialDot: BOOL Ź TRUE;
        IF text.length = 0 THEN RETURN [FALSE];
        SELECT GetCharClass[text[0]] FROM
            lowercase, extendedAlpha => NULL;
            sign => ok Ź (text.length=1);
            dot => {ok Ź (text.length>1); notInitialDot Ź FALSE};
                <<A Cedar Scheme extension; allow symbols consisting solely of two or more dots>>
            ENDCASE => {ok Ź FALSE};
        FOR i: NAT IN (0..text.length) WHILE ok DO
            SELECT GetCharClass[text[i]] FROM
                extendedAlpha => { IF text[i] = ': THEN colons Ź TRUE; ok Ź notInitialDot };
                lowercase, numeric, sign => {ok Ź notInitialDot};
                dot => NULL;
                ENDCASE => {ok Ź FALSE};
            ENDLOOP;
        };
<<Read-Eval-Print Loop>>
    actionQueueName: Symbol ~ SymbolFromRope["*read-eval-print-action-queue*"];

    ReadEvalPrintLoop: PUBLIC PROC [in, out: IO.STREAM, userEnv: Environment] ~ {
        originalIn: IO.STREAM ~ in;
        nullInputStream: IO.STREAM ~ IO.RIS[""];
        env: Environment Ź userEnv;
        actionQueue: SchemeEvents.InputQueue Ź NIL;
        Reset: PROC ~ {
            IF actionQueue # NIL THEN {
                SchemeEvents.Reset[actionQueue];
                actionQueue Ź NIL;
                };
            IF in # originalIn THEN {
                in Ź originalIn;
                SchemeSys.SetPort[port: in, in: TRUE];
                };
            };
        Inner: PROC ~ {
            exp, x, val: Any;
            ReadExpWithErrorCatch: PROC ~ {
                ReadExp: PROC ~ {exp Ź Read[in]};
                SchemeSys.DoWithIOErrorCatch[proc: ReadExp
                    ! Complain => {
                        IO.PutF1[out, "%l ... Read error: ", [rope["i"]]];
                        Print[object, out];
                        IO.PutF[out, ", %g%l\n", [rope[msg]], [rope["Ib"]]];
                        IO.Reset[in];
                        REJECT;
                        }
                    ]
                };
            noteTaker: Scheme.Any Ź NIL;
            noteTakerName: Symbol ~ SymbolFromRope["*read-eval-print-note-taker*"];
            promptName: Symbol ~ SymbolFromRope["*read-eval-print-prompt*"];
            noval: REF TEXT Ź "noval";
            prompt: Any Ź true;
            promptRope: ROPE Ź NIL;
            DO
                WITH LookupVariableValue[actionQueueName, env ! Complain => {Reset[]; CONTINUE}] SELECT FROM
                    a: SchemeEvents.InputQueue => {
                        IF actionQueue # a AND actionQueue # NIL THEN Reset[];
                        actionQueue Ź a;
                        };
                    ENDCASE => Reset[];
                IF in # nullInputStream THEN {
                    prompt Ź LookupVariableValue[promptName, env ! Complain => CONTINUE];
                    SELECT prompt FROM
                        false => NULL;
                        true => {
                            IO.PutF1[out, "%l(", [rope["Ib"]]];
                            Print[env[1], out, -1];
                            IO.PutF1[out, ") %l", [rope["B"]]];
                            };
                        ENDCASE => {
                            IO.PutF1[out, "%l", [rope["Ib"]]];
                            Print[prompt, out, -1];
                            IO.PutF1[out, "%l", [rope["B"]]];
                            };
                    };
                IF actionQueue # NIL
                    THEN {
                        IF in # nullInputStream THEN {
                            [] Ź SchemeEvents.FlushAvailableWhitespace[in];
                            SchemeEvents.EnqueueStream[actionQueue, in];
                            in Ź nullInputStream;
                            SchemeSys.SetPort[port: in, in: TRUE];
                            };
                        exp Ź SchemeEvents.Dequeue[actionQueue];
                        WITH exp SELECT FROM
                            stream: IO.STREAM => {
                                in Ź stream;
                                SchemeSys.SetPort[port: in, in: TRUE];
                                ReadExpWithErrorCatch[ ! Complain => LOOP];
                                };
                            <<error: SchemeEvents.StreamErrorEvent => {>>
                                <<in _ error.stream;>>
                                <<IO.PutF1[out, "%l ... Read error: ", [rope["i"]]];>>
                                <<Print[error.object, out];>>
                                <<IO.PutF[out, ", %g%l\n", [rope[error.msg]], [rope["Ib"]]];>>
                                <<IO.Reset[in];>>
                                <<LOOP;>>
                                <<};>>
                            ENDCASE => {
                                IF IsProcedure[exp] THEN {
                                    [] Ź Apply[exp, NIL !
                                        ABORTED => {
                                            IO.PutF[out, "%l ... event thunk aborted %l\n", [rope["i"]], [rope["I"]]];
                                            CONTINUE;
                                            };
                                        Complain => { Reset[] };
                                        ];
                                    LOOP;
                                    };
                                };
                        }
                    ELSE { ReadExpWithErrorCatch[ ! Complain => LOOP ] };
                IF exp = endOfFile THEN EXIT;
                noteTaker Ź LookupVariableValue[noteTakerName, env ! Complain => CONTINUE];
                x Ź val Ź noval;
                x Ź Expand[exp, env ! ABORTED => CONTINUE];
                IF x # noval THEN {
                    val Ź Eval[x, env ! ABORTED => CONTINUE];
                    IF noteTaker # NIL THEN [] Ź Apply[noteTaker, Cons[exp, Cons[x, IF val = noval THEN NIL ELSE Cons[val, NIL]]] ! Complain => 
                    CONTINUE];
                    };
                IO.PutF1[out, "%l", [rope["i"]]];
                IF val = noval
                    THEN { Reset[]; IO.PutRope[out, " ... aborted"] }
                    ELSE Print[val, out, printDepth, printWidth];
                IO.PutF1[out, "%l", [rope["I"]]];
                IO.PutRope[out, "\n"];
                ENDLOOP;
            };
        SchemeSys.DoWithPorts[in: in, out: out, proc: Inner !
            UNWIND => Reset[];
            Quit => {
                Reset[];
                IO.Reset[in];        -- to flush the carriage-return after "(quit)"
                CONTINUE
                };
            GetUserEnvironment => RESUME[userEnv];
            ChangeREPEnvironment => {
                env Ź newEnv;
                RESUME;
                };
            ];
        };

    Quit: ERROR ~ CODE;

    ChangeREPEnvironment: SIGNAL[newEnv: Environment] ~ CODE;

    EnqueueAction: PROC [actionQueue: Any, a: Any] ~ {
        WITH actionQueue SELECT FROM
            actionQueue: SchemeEvents.InputQueue => { SchemeEvents.Enqueue[actionQueue, a] };
            ENDCASE => Complain[actionQueue, "not an event queue"];
        };

    REPPrim: PROC [self: Primitive, a, b, c: Any, rest: ProperList]                RETURNS [Any Ź unspecified] ~ {
        SELECT self.data FROM
            $quit => ERROR Quit;
            $setEnv =>
                WITH a SELECT FROM
                    e: Environment => ChangeREPEnvironment[e];
                    ENDCASE => Complain[a, "not an environment"];
            $enqueueAction => { EnqueueAction[a, b] };
            $makeActionQueue => {
                RETURN[SchemeEvents.MakeInputQueue[]];
                };
            ENDCASE => ERROR;
        };
<<Registration of Primitives>>
    RegisterEssentials: PROC [env: Environment] ~ {
        DefinePrimitive[name: "input-port?", nArgs: 1, dotted: FALSE, proc: PortPrim, env: env, data: $inputPred, doc: "test for input-port 
        type"];
        DefinePrimitive[name: "output-port?", nArgs: 1, dotted: FALSE, proc: PortPrim, env: env, data: $outputPred, doc: "test for 
        output-port type"];
        DefinePrimitive[name: "current-input-port", nArgs: 0, dotted: FALSE, proc: PortPrim, env: env, data: $currentIn, doc: "returns the 
        default input port"];
        DefinePrimitive[name: "current-output-port", nArgs: 0, dotted: FALSE, proc: PortPrim, env: env, data: $currentOut, doc: "returns 
        the default output port"];
        DefinePrimitive[name: "open-input-file", nArgs: 1, dotted: FALSE, proc: PortPrim, env: env, data: $openIn, doc: "open input file 
        named by the string a"];
        DefinePrimitive[name: "open-output-file", nArgs: 1, dotted: FALSE, proc: PortPrim, env: env, data: $openOut, doc: "open output file 
        named by the string a"];
        DefinePrimitive[name: "close-input-port", nArgs: 1, dotted: FALSE, proc: PortPrim, env: env, data: $close, doc: "close the port a"];
        DefinePrimitive[name: "close-output-port", nArgs: 1, dotted: FALSE, proc: PortPrim, env: env, data: $close, doc: "close the port 
        a"];
        DefinePrimitive[name: "read", nArgs: 1, optional: 1, dotted: FALSE, proc: PortPrim, env: env, data: $read, doc: "read an object"];
        DefinePrimitive[name: "read-char", nArgs: 1, optional: 1, dotted: FALSE, proc: PortPrim, env: env, data: $readChar, doc: "read a 
        character"];
        DefinePrimitive[name: "char-ready?", nArgs: 1, optional: 1, dotted: FALSE, proc: PortPrim, env: env, data: $charReadyPred, doc: 
        "check for available characters"];
        DefinePrimitive[name: "eof-object?", nArgs: 1, dotted: FALSE, proc: PortPrim, env: env, data: $eofObjectPred, doc: "test for 
        end-of-file object"];
        DefinePrimitive[name: "write", nArgs: 2, optional: 1, dotted: FALSE, proc: PortPrim, env: env, data: $write, doc: "write an object 
        in unambiguous form"];
        DefinePrimitive[name: "display", nArgs: 2, optional: 1, dotted: FALSE, proc: PortPrim, env: env, data: $display, doc: "display an 
        object in unclutterd form"];
        DefinePrimitive[name: "newline", nArgs: 1, optional: 1, dotted: FALSE, proc: PortPrim, env: env, data: $newline, doc: "begin a new 
        line"];
        DefinePrimitive[name: "write-char", nArgs: 2, optional: 1, dotted: FALSE, proc: PortPrim, env: env, data: $writeChar, doc: "write a 
        character"];
        DefinePrimitive[name: "load", nArgs: 1, dotted: FALSE, proc: LoadPrim, env: env, data: env, doc: "load a Scheme file"];
        };

    RegisterExtensions: PROC [env: Environment] ~ {
        DefinePrimitive[name: "register-print-proc", nArgs: 2, dotted: FALSE, proc: PortPrim, env: env, data: $setPrintProc, doc: "(proc 
        value) Register PROC as the printer for values of the same type as VALUE"];
        DefinePrimitive[name: "open-input-string", nArgs: 1, dotted: FALSE, proc: PortPrim, env: env, data: $openInString, doc: "create an 
        input port on the string a"];
        DefinePrimitive[name: "open-output-string", nArgs: 0, dotted: FALSE, proc: PortPrim, env: env, data: $openOutString, doc: "create 
        an output port for get-output-string"];
        DefinePrimitive[name: "get-output-string", nArgs: 1, dotted: FALSE, proc: PortPrim, env: env, data: $getOutString, doc: "get the 
        string contents of a port created with open-output-string"];
        DefinePrimitive[name: "unread-char", nArgs: 2, optional: 1, dotted: FALSE, proc: PortPrim, env: env, data: $unreadChar, doc: "put 
        back a lookahead character"];
        DefinePrimitive[name: "binary-write", nArgs: 2, optional: 1, dotted: FALSE, proc: PortPrim, env: env, data: $binaryWrite, doc: 
        "write a binary item"];
        DefinePrimitive[name: "change-looks", nArgs: 2, optional: 1, dotted: FALSE, proc: PortPrim, env: env, data: $changeLooks, doc: 
        "Change the current looks on the port b using the string a"];
        DefinePrimitive[name: "quit", nArgs: 0, dotted: FALSE, proc: REPPrim, data: $quit, doc: "Terminate the read-eval-print loop", env: 
        env];
        DefinePrimitive[name: "set-rep-environment!", nArgs: 1, dotted: FALSE, proc: REPPrim, data: $setEnv, doc: "(env) Change the 
        environment used by the read-eval-print loop to env", env: env];
        DefinePrimitive[name: "enqueue-action!", nArgs: 2, dotted: FALSE, proc: REPPrim, data: $enqueueAction, doc: "(action-queue action) 
        Enqueue an action (thunk or expression) e.g.  (enqueue-action! *read-eval-print-action-queue* action)", env: env];
        DefinePrimitive[name: "make-read-eval-print-action-queue", nArgs: 0, dotted: FALSE, proc: REPPrim, data: $makeActionQueue, doc: "() 
        Make a new action queue, e.g. (define *read-eval-print-action-queue* (make-read-eval-print-action-queue))", env: env];
        DefinePrimitive[name: "%set-current-input-port!", nArgs: 1, dotted: FALSE, proc: PortPrim, data: $setCurrentInputPort, doc: "(port) 
        Change the current default input port (don't use directly; use with-input-from-file instead)", env: env];
        DefinePrimitive[name: "%set-current-output-port!", nArgs: 1, dotted: FALSE, proc: PortPrim, data: $setCurrentOutputPort, doc: 
        "(port) Change the current default output port (don't use directly; use with-output-to-file instead)", env: env];
        };
<<Initalization>>
    RegisterInit[RegisterEssentials];
    RegisterInit[RegisterExtensions];

    END.