
    <<PSImpl.mesa>>
        <<Copyright © 1986 by Xerox Corporation.  All rights reserved.>>
        <<Doug Wyatt, October 29, 1986 6:51:09 pm PST>>

    DIRECTORY
        Atom USING [PropList],
        IO USING [STREAM],
        PS,
        RefTab USING [Ref],
        Rope USING [ROPE];

    PSImpl: PROGRAM
    ~ BEGIN OPEN PS;
<<Internal stuff>>
<<Registration>>
    Register: PROC [self: Root, name: LONG STRING, value: Any] ~ {
        key: Name ~ MakeName[self, name];
        Put[self.sysdict, key, value];
        };

    RegisterOp: PROC [rope: ROPE, op: Op] ~ {
        Register[rope, AnyFromOp[op]];
        };

    InitErrorNames: PROC [self: Root] ~ {
        dictfull _ NameFromRope["dictfull"];
        dictstackoverflow _ NameFromRope["dictstackoverflow"];
        dictstackunderflow _ NameFromRope["dictstackunderflow"];
        execstackoverflow _ NameFromRope["execstackoverflow"];
        handleerror _ NameFromRope["handleerror"];
        interrupt _ NameFromRope["interrupt"];
        invalidaccess _ NameFromRope["invalidaccess"];
        invalidexit _ NameFromRope["invalidexit"];
        invalidfileaccess _ NameFromRope["invalidfileaccess"];
        invalidfont _ NameFromRope["invalidfont"];
        invalidrestore _ NameFromRope["invalidrestore"];
        ioerror _ NameFromRope["ioerror"];
        limitcheck _ NameFromRope["limitcheck"];
        nocurrentpoint _ NameFromRope["nocurrentpoint"];
        rangecheck _ NameFromRope["rangecheck"];
        stackoverflow _ NameFromRope["stackoverflow"];
        stackunderflow _ NameFromRope["stackunderflow"];
        syntaxerror _ NameFromRope["syntaxerror"];
        timeout _ NameFromRope["timeout"];
        typecheck _ NameFromRope["typecheck"];
        undefined _ NameFromRope["undefined"];
        undefinedfilename _ NameFromRope["undefinedfilename"];
        undefinedresult _ NameFromRope["undefinedresult"];
        unmatchedmark _ NameFromRope["unmatchedmark"];
        unregistered _ NameFromRope["unregistered"];
        VMerror _ NameFromRope["VMerror"];
        };

    Initialize: PROC [self: Root] ~ {
        self.xfor _ MakeOp[self, Xfor];
        self.xrepeat _ MakeOp[self, Xrepeat];
        self.xloop _ MakeOp[self, Xloop];
        self.xforall _ MakeOp[self, Xforall];

        <<systemdict:>>
            Register["[", Pmark];
            Register["]", Pconstructarray];
            Register["aload", Paload];
            Register["anchorsearch", Panchorsearch];
            Register["and", Pand];
            Register["arc", Parc];
            Register["arcn", Parcn];
            Register["arcto", Parcto];
            Register["array", Parray];
            Register["ashow", Pashow];
            Register["astore", Pastore];
            Register["awidthshow", Pawidthshow];
            Register["begin", Pbegin];
            Register["bind", Pbind];
            Register["bitshift", Pbitshift];
            Register["bytesavailable", Pbytesavailable];
            Register["cachestatus", Pcachestatus];
            <<Register["cexec", Pcexec]; -- *>>
            Register["charpath", Pcharpath];
            Register["clear", Pclear];
            <<Register["clearinterrupt", Pclearinterrupt]; -- *>>
            Register["cleartomark", Pcleartomark];
            Register["clip", Pclip];
            Register["clippath", Pclippath];
            Register["closefile", Pclosefile];
            Register["closepath", Pclosepath];
            Register["concat", Pconcat];
            Register["concatmatrix", Pconcatmatrix];
            Register["copy", Pcopy];
            Register["copypage", Pcopypage];
            Register["count", Pcount];
            Register["countdictstack", Pcountdictstack];
            Register["countexecstack", Pcountexecstack];
            Register["counttomark", Pcounttomark];
            <<Register["currentcacheparams", Pcurrentcacheparams]; -- *>>
            Register["currentdash", Pcurrentdash];
            Register["currentdict", Pcurrentdict];
            Register["currentfile", Pcurrentfile];
            Register["currentflat", Pcurrentflat];
            Register["currentfont", Pcurrentfont];
            Register["currentgray", Pcurrentgray];
            Register["currenthsbcolor", Pcurrenthsbcolor];
            Register["currentlinecap", Pcurrentlinecap];
            Register["currentlinejoin", Pcurrentlinejoin];
            Register["currentlinewidth", Pcurrentlinewidth];
            Register["currentmatrix", Pcurrentmatrix];
            Register["currentmiterlimit", Pcurrentmiterlimit];
            <<Register["currentpacking", Pcurrentpacking]; -- *>>
            Register["currentpoint", Pcurrentpoint];
            Register["currentrgbcolor", Pcurrentrgbcolor];
            Register["currentscreen", Pcurrentscreen];
            Register["currenttransfer", Pcurrenttransfer];
            Register["curveto", Pcurveto];
            Register["cvi", Pcvi];
            Register["cvlit", Pcvlit];
            Register["cvn", Pcvn];
            Register["cvr", Pcvr];
            Register["cvrs", Pcvrs];
            Register["cvs", Pcvs];
            Register["cvx", Pcvx];
            <<Register["daytime", Pdaytime]; -- *>>
            Register["def", Pdef];
            Register["defaultmatrix", Pdefaultmatrix];
            Register["definefont", Pdefinefont];
            Register["dict", Pdict];
            Register["dictstack", Pdictstack];
            <<Register["disableinterrupt", Pdisableinterrupt]; -- *>>
            Register["div", Pdiv];
            Register["dtransform", Pdtransform];
            Register["dup", Pdup];
            Register["echo", Pecho];
            <<Register["eexec", Peexec]; -- *>>
            <<Register["enableinterrupt", Penableinterrupt]; -- *>>
            Register["end", Pend];
            Register["eoclip", Peoclip];
            Register["eofill", Peofill];
            Register["eq", Peq];
            Register["erasepage", Perasepage];
            Register["exch", Pexch];
            Register["exec", Pexec];
            Register["execstack", Pexecstack];
            Register["executeonly", Pexecuteonly];
            Register["exit", Pexit];
            Register["exp", Pexp];
            Register["file", Pfile];
            Register["fill", Pfill];
            Register["findfont", Pfindfont];
            Register["flattenpath", Pflattenpath];
            Register["floor", Pfloor];
            Register["flush", Pflush];
            Register["flushfile", Pflushfile];
            Register["for", Pfor];
            Register["forall", Pforall];
            Register["framedevice", Pframedevice];
            Register["ge", Pge];
            Register["get", Pget];
            Register["getinterval", Pgetinterval];
            Register["grestore", Pgrestore];
            Register["grestoreall", Pgrestoreall];
            Register["gsave", Pgsave];
            Register["gt", Pgt];
            Register["identmatrix", Pidentmatrix];
            Register["idiv", Pidiv];
            Register["idtransform", Pidtransform];
            Register["if", Pif];
            Register["ifelse", Pifelse];
            Register["image", Pimage];
            Register["imagemask", Pimagemask];
            Register["index", Pindex];
            Register["initclip", Pinitclip];
            Register["initgraphics", Pinitgraphics];
            Register["initmatrix", Pinitmatrix];
            <<Register["internaldict", Pinternaldict]; -- *>>
            Register["invermatrix", Pinvermatrix];
            Register["itransform", Pitransform];
            Register["known", Pknown];
            Register["kshow", Pkshow];
            Register["le", Ple];
            Register["length", Plength];
            Register["lineto", Plineto];
            Register["ln", Pln];
            Register["load", Pload];
            Register["log", Plog];
            Register["loop", Ploop];
            Register["lt", Plt];
            Register["makefont", Pmakefont];
            <<Register["makevm", Pmakevm]; -- *>>
            Register["mark", Pmark];
            Register["matrix", Pmatrix];
            Register["maxlength", Pmaxlength];
            Register["mod", Pmod];
            Register["moveto", Pmoveto];
            Register["mul", Pmul];
            Register["ne", Pne];
            Register["neg", Pneg];
            Register["newpath", Pnewpath];
            Register["noaccess", Pnoaccess];
            Register["not", Pnot];
            Register["nulldevice", Pnulldevice];
            Register["or", Por];
            <<Register["packedarray", Ppackedarray]; -- *>>
            Register["pathbbox", Ppathbbox];
            Register["pathforall", Ppathforall];
            Register["pop", Ppop];
            Register["print", Pprint];
            <<Register["psdevice", Ppsdevice]; -- *>>
            Register["put", Pput];
            Register["putinterval", Pputinterval];
            Register["quit", Pquit];
            Register["rand", Prand];
            Register["rcheck", Prcheck];
            Register["rcurveto", Prcurveto];
            Register["read", Pread];
            Register["readhexstring", Preadhexstring];
            Register["readline", Preadline];
            Register["readonly", Preadonly];
            Register["readstring", Preadstring];
            Register["repeat", Prepeat];
            Register["resetfile", Presetfile];
            Register["restore", Prestore];
            Register["reversepath", Preversepath];
            Register["rlineto", Prlineto];
            Register["rmoveto", Prmoveto];
            Register["roll", Proll];
            Register["rotate", Protate];
            Register["round", Pround];
            Register["rrand", Prrand];
            Register["run", Prun];
            Register["save", Psave];
            Register["scale", Pscale];
            Register["scalefont", Pscalefont];
            Register["search", Psearch];
            Register["setcachedevice", Psetcachedevice];
            Register["setcachelimit", Psetcachelimit];
            <<Register["setcacheparams", Psetcacheparams]; -- *>>
            Register["setcharwidth", Psetcharwidth];
            Register["setdash", Psetdash];
            Register["setflat", Psetflat];
            Register["setfont", Psetfont];
            Register["setgray", Psetgray];
            Register["sethsbcolor", Psethsbcolor];
            Register["setlinecap", Psetlinecap];
            Register["setlinejoin", Psetlinejoin];
            Register["setlinewidth", Psetlinewidth];
            Register["setmatrix", Psetmatrix];
            Register["setmiterlimit", Psetmiterlimit];
            <<Register["setpacking", Psetpacking]; -- *>>
            <<Register["setram", Psetram]; -- *>>
            Register["setrgbcolor", Psetrgbcolor];
            <<Register["setrom", Psetrom]; -- *>>
            Register["setscreen", Psetscreen];
            Register["settransfer", Psettransfer];
            Register["show", Pshow];
            Register["showpage", Pshowpage];
            Register["sin", Psin];
            Register["sqrt", Psqrt];
            Register["srand", Psrand];
            Register["status", Pstatus];
            Register["stop", Pstop];
            Register["stopped", Pstopped];
            Register["store", Pstore];
            Register["string", Pstring];
            Register["stringwidth", Pstringwidth];
            Register["stroke", Pstroke];
            Register["strokepath", Pstrokepath];
            Register["sub", Psub];
            Register["token", Ptoken];
            Register["transform", Ptransform];
            Register["translate", Ptranslate];
            Register["truncate", Ptruncate];
            Register["type", Ptype];
            Register["usertime", Pusertime];
            Register["vmstatus", Pvmstatus];
            Register["wcheck", Pwcheck];
            Register["where", Pwhere];
            Register["widthshow", Pwidthshow];
            Register["write", Pwrite];
            Register["writehexstring", Pwritehexstring];
            Register["writestring", Pwritestring];
            Register["xcheck", Pxcheck];
            Register["xor", Pxor];

            RegisterOb["null", null];
            RegisterOb["true", AnyFromBool[TRUE]];
            RegisterOb["false", AnyFromBool[FALSE]];

            RegisterOb["$error", Ob]; -- *
            RegisterOb[".error", Ob]; -- *
            RegisterOb["=", Ob];
            RegisterOb["==", Ob];
            RegisterOb["=print", Ob]; -- * {dup type /stringtype ne {<=string> cvs} if print}
            RegisterOb["=string", Ob]; -- * <128 string>
            RegisterOb["errordict", Ob];
            RegisterOb["FontDirectory", Ob];
            RegisterOb["handleerror", Ob];
            <<RegisterOb["initialized", Ob]; -- *>>
            <<RegisterOb["Run", Ob]; -- *>>
            RegisterOb["stack", Ob];
            RegisterOb["StandardEncoding", Ob];
            <<RegisterOb["statusdict", Ob]; -- *>>
            RegisterOb["systemdict", Ob];
            RegisterOb["userdict", Ob];
            RegisterOb["version", Ob];

        <<userdict:>>
            RegisterOb["$idleTimeDict"L, Ob];
            RegisterOb["legal"L, Ob];
            RegisterOb["execdict"L, Ob];
            RegisterOb["pstack"L, Ob];
            RegisterOb["$printerdict"L, Ob];
            RegisterOb["ReadIdleFonts"L, Ob];
            RegisterOb["b5"L, Ob];
            RegisterOb["a4small"L, Ob];
            RegisterOb["a4"L, Ob];
            RegisterOb["cleardictstack"L, Ob];
            RegisterOb["letter"L, Ob];
            RegisterOb["UseIdleTime"L, Ob];
            RegisterOb["executive"L, Ob];
            RegisterOb["lettersmall"L, Ob];
            RegisterOb["#copies"L, Ob];
            RegisterOb["note"L, Ob];
            RegisterOb["serverdict"L, Ob];
            RegisterOb["start"L, Ob];
            RegisterOb["prompt"L, Ob];
            RegisterOb["quit"L, Ob];
        <<>>
        };

<<Primitive operators>>
<<Dictionary operators>>
    Munch: PROC [n: Basics.LongNumber] RETURNS [CARDINAL] ~ INLINE {
        RETURN [Basics.BITXOR[n.hi, n.lo]];
        };

    Hash: PROC [x: Any] RETURNS [CARDINAL] ~ {
        WITH x: x SELECT FROM
            integer => RETURN [Munch[[li[x.int]]]];
            real => RETURN [Munch[[real[x.real]]]];
            boolean => RETURN [ORD[n.bool]];
            array => RETURN [Munch[[lp[x.finger]]]];
            string => RETURN [HashString[x]];
            name => RETURN [x.id];
            dictionary => RETURN [Munch[[lp[x.finger]]]];
            operator => RETURN [LOOPHOLE[x.op]];
            file => RETURN [x.id];
            ENDCASE => RETURN [42];
        };

    InlineHash: PROC [x: Any] RETURNS [CARDINAL] ~ {
        RETURN [WITH x: x SELECT FROM name => x.id, ENDCASE => Hash[x]];
        };

    Key: PROC [x: Any] RETURNS [Any] ~ {
        WITH x: x SELECT FROM
            null => ERROR Error[typecheck];
            string => RETURN [NameFromString[x]];
            ENDCASE => RETURN [x];
        };

    InlineKey: PROC [x: Any] RETURNS [Any] ~ INLINE {
        RETURN [WITH x: x SELECT FROM name => x, ENDCASE => Key[x]];
        };

    Lookup: PROC [d: DictPointer, key: Any] RETURNS [found: BOOL, tuple: TuplePointer] ~ {
        loc: DictIndex _ InlineHash[key] MOD d.maxLength;
        THROUGH [0..d.maxLength) DO
            tuple _ @d[loc];
            IF tuple.key.type=null THEN RETURN [FALSE, tuple];
            IF Eq[key, tuple.key] THEN RETURN [TRUE, tuple];
            loc _ IF loc<d.maxLength THEN loc+1 ELSE 0;
            ENDLOOP;
        RETURN [FALSE, NIL];
        };

    Put: PROC [dict: Dict, key: Any, value: Any] ~ {
        d: DictPointer ~ DictAccess[dict, unlimited];
        found: BOOL; tuple: TuplePointer;
        [found, tuple] _ Lookup[d, key _ InlineKey[key]];
        IF found THEN tuple.value _ value
        ELSE IF d.length>=d.maxLength THEN ERROR Error[dictfull]
        ELSE { tuple^ _ [key: key, value: value]; d.length _ d.length+1 };
        };

    TryToGet: PROC [dict: Dict, key: Any] RETURNS [found: BOOL, value: Any] ~ {
        };

    Get: PROC [dict: Dict, key: Any] RETURNS [value: Any] ~ {
        };

    Store: PROC [self: Root, key: Any, value: Any] ~ {
        };

    TryToLoad: PROC [self: Root, key: Any] RETURNS [found: BOOL, value: Any] ~ {
        };

    Load: PROC [self: Root, key: Any] RETURNS [value: Any] ~ {
        };

    Known: PROC [dict: Dict, key: Any] RETURNS [BOOL] ~ {
        };

    Where: PROC [self: Root, key: Any] RETURNS [found: BOOL, dict: Dict] ~ {
        };


    Pdict: PROC [self: Root] ~ {
        int: INT ~ PopInt[self.ostack];
        IF int IN DictIndex THEN Push[self.ostack, NewDict[self, int]]
        ELSE ERROR Error[rangecheck];
        };

    Pmaxlength: PROC [self: Root] ~ {
        dict: Dict ~ PopDict[self.ostack];
        PushInt[self.ostack, DictAccess[dict, readOnly].maxLength];
        };

    Pbegin: PROC [self: Root] ~ {
        dict: Dict ~ PopDict[self.ostack];
        Push[self.dstack, dict];
        };

    Pend: PROC [self: Root] ~ {
        IF self.dstack.count>2 THEN [] _ Pop[self.dstack]
        ELSE ERROR Error[dictstackunderflow];
        };

    Pdef: PROC [self: Root] ~ {
        value: Any ~ Pop[self.ostack];
        key: Any ~ Pop[self.ostack];
        dict: Dict ~ CurrentDict[self];
        Put[dict, key, value];
        };

    Pload: PROC [self: Root] ~ {
        key: Any ~ Pop[self.ostack];
        value: Any ~ Load[self, key];
        Push[self.ostack, value];
        };

    Pstore: PROC [self: Root] ~ {
        value: Any ~ Pop[self.ostack];
        key: Any ~ Pop[self.ostack];
        Store[self, key, value];
        };

    Pknown: PROC [self: Root] ~ {
        key: Any ~ Pop[self.ostack];
        dict: Dict ~ PopDict[self.ostack];
        PushBool[self.ostack, Known[dict, key]];
        };

    Pwhere: PROC [self: Root] ~ {

        };

    Pcurrentdict: PROC [self: Root] ~ {
        Push[self.ostack, CurrentDict[self]];
        };

    Pcountdictstack: PROC [self: Root] ~ {
        PushInt[self.ostack, self.dstack.count];
        };

    Pdictstack: PROC [self: Root] ~ {
        array: Array _ PopArray[self.ostack];
        count: ArrayIndex ~ self.dstack.count;
        IF array.length<count THEN ERROR Error[rangecheck];
        array.length _ count;
        AStore[self.dstack, array];
        self.dstack.count _ count;
        Push[self.ostack, array];
        };

<<Scanning>>
    CharInfo: TYPE ~ RECORD [
        newline: BOOL _ FALSE,
        whitespace: BOOL _ FALSE,
        special: BOOL _ FALSE,
        decimal: BOOL _ FALSE,
        hex: BOOL _ FALSE,
        digit: [0..15] _ 0
        ];
    CharInfoArray: TYPE ~ ARRAY CHAR OF CharInfo;
    charInfo: REF CharInfoArray ~ InitCharInfo[];
    InitCharClass: PROC RETURNS [c: REF CharInfoArray] ~ {
        info _ NEW [CharInfoArray _ ALL[[]]];

        info[Ascii.LF].newline _ TRUE;
        info[Ascii.CR].newline _ TRUE;

        info[Ascii.SP].whitespace _ TRUE;
        info[Ascii.TAB].whitespace _ TRUE;
        info[Ascii.LF].whitespace _ TRUE;
        info[Ascii.CR].whitespace _ TRUE;

        info['(].special _ TRUE;
        info[')].special _ TRUE;
        info['<].special _ TRUE;
        info['>].special _ TRUE;
        info['{].special _ TRUE;
        info['}].special _ TRUE;
        info['/].special _ TRUE;
        info['%].special _ TRUE;

        FOR c: CHAR IN ['0..'9] DO
            info[c].decimal _ TRUE;
            info[c].hex _ TRUE;
            info[c].digit _ (c-'0);
            ENDLOOP;

        FOR c: CHAR IN ['A..'F] DO
            info[c].hex _ TRUE;
            info[c].digit _ 10+(c-'A);
            ENDLOOP;

        FOR c: CHAR IN ['a..'f] DO
            info[c].hex _ TRUE;
            info[c].digit _ 10+(c-'a);
            ENDLOOP;

        };

    StringToken: PROC [self: Root, string: String, access: Access _ readOnly] 
    RETURNS [found: BOOL, token: Any, post: String] ~ {
        pointer: StringBase ~ StringAccess[string, access];
        state: ScanState _ null;
        pnest: INT _ 0; -- nesting depth of parens
        end: BOOL _ FALSE;
        i: StringIndex _ string.start;
        stop: StringIndex ~ string.start+string.length;
        WHILE i<stop DO
            char: CHAR ~ pointer[i];
            SELECT charClass[char] FROM
                whitespace, newline => i _ i+1;
                ENDCASE => EXIT;
            REPEAT FINISHED => {
                post _ string; post.start _ i; post.length _ 0;
                RETURN [found: FALSE, token: null, post: post];
                };
            ENDLOOP;
        FOR i: StringIndex IN [0..string.length) DO
            char: CHAR ~ pointer[i];
            info: CharInfo ~ charInfo[char];
            { 
            SELECT state FROM
                null => {
                    IF char.whitespace THEN { GOTO Skip };
                    IF char.decimal THEN { state _ int; GOTO NameChar };
                    SELECT char FROM
                        '( => { state _ string; stringNest _ 0; GOTO StringBegin }; -- begin string
                        ') => { GOTO SyntaxError }; -- syntax error
                        '< => { state _ hex1 }; -- begin string
                        '> => { GOTO SyntaxError }; -- syntax error
                        '{ => { procNest _ procNest+1 };
                        '} => { procNest _ procNest-1 };
                        '/ => { state _ name; literal _ TRUE }; -- single character names
                        '[, '] => { state _ name; EXIT }; -- single character names
                        '% => { state _ comment }; -- begin comment
                        '+ => { state _ plus }; -- might begin number or name
                        '- => { state _ minus }; -- might begin number or name
                        '. => { state _ dot }; -- might begin real or name
                        IN['0..'9] => { state _ int }; -- begin integer
                        ENDCASE => { state _ name }; -- begin name

                    };

                SELECT char FROM
                    Ascii.SP, Ascii.TAB, Ascii.CR, Ascii.LF => NULL;
                    '( => { state _ string; stringNest _ 0; GOTO StringBegin }; -- begin string
                    ') => { GOTO SyntaxError }; -- syntax error
                    '< => { state _ hex1 }; -- begin string
                    '> => { GOTO SyntaxError }; -- syntax error
                    '{ => { procNest _ procNest+1 };
                    '} => { procNest _ procNest-1 };
                    '/ => { state _ name; literal _ TRUE }; -- single character names
                    '[, '] => { state _ name; EXIT }; -- single character names
                    '% => { state _ comment }; -- begin comment
                    '+ => { state _ plus }; -- might begin number or name
                    '- => { state _ minus }; -- might begin number or name
                    '. => { state _ dot }; -- might begin real or name
                    IN['0..'9] => { state _ int }; -- begin integer
                    ENDCASE => { state _ name }; -- begin name
                string => SELECT char FROM
                    '( => { stringNest _ stringNest+1; GOTO StringChar };
                    ') => { stringNest _ stringNest-1;
                        IF stringNest>0 THEN GOTO StringChar ELSE GOTO StringEnd };
                    '\\ => { state _ esc0; GOTO Skip };
                    ENDCASE => GOTO StringChar;
                esc0 => SELECT char FROM
                    Ascii.LF => { state _ string; GOTO Skip };
                    'n => { state _ string; code _ ORD[Ascii.LF]; GOTO StringCode };
                    'r => { state _ string; code _ ORD[Ascii.CR]; GOTO StringCode };
                    't => { state _ string; code _ ORD[Ascii.TAB]; GOTO StringCode };
                    'b => { state _ string; code _ ORD[Ascii.BS]; GOTO StringCode };
                    'f => { state _ string; code _ ORD[Ascii.FF]; GOTO StringCode };
                    IN['0..'9] => { state _ esc1; code _ (char-'0); GOTO Skip };
                    ENDCASE => { state _ string; GOTO StringChar };
                esc1 => SELECT char FROM
                    IN['0..'9] => { state _ esc2; code _ code*8+(char-'0); GOTO Skip };
                    ENDCASE => { state _ string; GOTO StringCodeAndChar };
                esc2 => SELECT char FROM
                    IN['0..'9] => { state _ string; code _ code*8+(char-'0); GOTO StringCode };
                    ENDCASE => { state _ string; GOTO StringCodeAndChar };
                hex0 => {
                    IF info.hex THEN { state _ hex1; code _ info.digit*16; GOTO Skip }
                    ELSE GOTO SyntaxError;
                    };
                hex1 => {
                    IF info.hex THEN { state _ hex0; code _ code+info.digit; GOTO StringCode }
                    ELSE GOTO SyntaxError;
                    };
                name => GOTO TestForEnd; -- test for end of name
                plus => SELECT char FROM
                    IN['0..'9] => { state _ int }; -- first integer digit
                    '. => { state _ dot }; -- might start a real
                    ENDCASE => GOTO TestForEnd; -- make it a name
                minus => SELECT char FROM
                    IN['0..'9] => { state _ int }; -- first integer digit
                    '. => { state _ dot }; -- might start a real
                    ENDCASE => { state _ name }; -- make it a name
                dot => SELECT char FROM
                    IN['0..'9] => { state _ frac }; -- first fraction digit
                    ENDCASE => { state _ name }; -- no digits after dot
                int => SELECT char FROM
                    IN['0..'9] => { }; -- extend integer
                    '. => { state _ frac }; -- fraction coming
                    'E, 'e => { state _ exp1 }; -- exponent coming
                    ENDCASE => { state _ name }; -- integer ends here
                frac => SELECT char FROM
                    IN['0..'9] => { }; -- extend fraction
                    'E, 'e => { state _ exp1 }; -- exponent coming
                    ENDCASE => GOTO TestForEnd; -- real with fraction ends here
                exp1 => SELECT char FROM
                    '+, '- => { state _ exp2 }; -- exponent sign
                    IN['0..'9] => { state _ exp3 }; -- first exponent digit
                    ENDCASE => GOTO TestForEnd; -- make it a name
                exp2 => SELECT char FROM
                    IN['0..'9] => { state _ exp3 }; -- first exponent digit
                    ENDCASE => GOTO TestForEnd; -- make it a name
                exp3 => SELECT char FROM
                    IN['0..'9] => { }; -- extend exponent
                    ENDCASE => GOTO TestForEnd; -- real with exponent ends here
                comment => SELECT char FROM
                    '\n => { token.type _ comment; EXIT }; -- end of comment
                    ENDCASE => { }; -- skip
                ENDCASE => ERROR; -- unknown state
                EXITS
                ExtendString =>
                    IF end THEN { token.truncated _ TRUE; token.type _ string; EXIT };
                TestForEnd =>
                    IF class[char]=nil THEN state _ name -- if it doesn't end here, make it a name
                    ELSE {
                        token.type _ SELECT state FROM
                            int, oct => int, frac, exp3 => real, ENDCASE => name;
                        IF NOT end THEN [] _ reader.Backwards[]; -- put the last character back
                        EXIT;
                        };
                };
                ENDLOOP;
        token.len _ reader.GetIndex[]-token.start;
        RETURN[token];
        };


<<String operators>>
    Ptoken: PROC [self: Root] ~ {

        };

<<Polymorphic operators>>
    Pforall: PROC [self: Root] ~ {
        proc: Proc ~ PopProc[self.ostack];
        x: Any ~ Pop[self.ostack];
        WITH x: x SELECT FROM
            array => {
                PushMark[self.estack];
                Push[self.estack, proc];
                Push[self.estack, x];
                Push[self.estack, self.xarrayforall];
                };
            string => {
                PushMark[self.estack];
                Push[self.estack, proc];
                Push[self.estack, x];
                Push[self.estack, self.xstringforall];
                };
            dictionary => {
                DictCopy[to, from];
                };
            ENDCASE => ERROR Error[typecheck];
        };

    Xarrayforall: PROC [self: Root] ~ {
        array: Array ~ PopArray[self.estack];
        proc: Proc ~ TopProc[self.estack];
        IF array.length=0 THEN {
            [--proc--] _ PopProc[self.estack];
            PopMark[self.estack];
            }
        ELSE {
            pointer: ArrayBase ~ ArrayAccess[array, readOnly];
            element: Any ~ pointer[array.start];
            post: Array _ array;
            post.start _ array.start+1;
            post.length _ array.length-1;
            Push[self.estack, post];
            Push[self.estack, self.xarrayforall];
            Push[self.estack, proc];
            Push[self.ostack, element];
            };
        };

    Xstringforall: PROC [self: Root] ~ {
        string: Array ~ PopString[self.estack];
        proc: Any ~ Top[self.estack];
        IF string.length=0 THEN {
            [--proc--] _ Pop[self.estack];
            PopMark[self.estack];
            }
        ELSE {
            pointer: StringBase ~ StringAccess[string, readOnly];
            element: CHAR ~ pointer[string.start];
            post: String _ string;
            post.start _ string.start+1;
            post.length _ string.length-1;
            Push[self.estack, post];
            Push[self.estack, self.xstringforall];
            Push[self.estack, proc];
            PushInt[self.ostack, ORD[element]];
            };
        };


<<Relational, boolean, and bitwise operators>>
    ArrayEq: PROC [a1, a2: Array] RETURNS [BOOL] ~ {
        pointer1: ArrayBase ~ ArrayAccess[a1, readOnly];
        pointer2: ArrayBase ~ ArrayAccess[a2, readOnly];
        RETURN [pointer1=pointer2 AND a1.start=a2.start AND a1.length=a2.length];
        };

    StringCompare: PROC [s1, s2: String] RETURNS [Basics.Comparison] ~ {
        pointer1: StringBase ~ StringAccess[s1, readOnly];
        pointer2: StringBase ~ StringAccess[s2, readOnly];
        FOR i: NAT IN [0..MIN[s1.length, s2.length]) DO
            c1: CHAR ~ pointer1[s1.start+i];
            c2: CHAR ~ pointer2[s2.start+i];
            IF c1#c2 THEN RETURN [IF c1<c2 THEN less ELSE greater];
            ENDLOOP
        IF s1.length=s2.length THEN RETURN [equal]
        ELSE RETURN [IF s1.length<s2.length THEN less ELSE greater];
        };

    StringEq: PROC [s1, s2: String] RETURNS [BOOL] ~ {
        pointer1: StringBase ~ StringAccess[s1, readOnly];
        pointer2: StringBase ~ StringAccess[s2, readOnly];
        IF s1.length#s2.length THEN RETURN [FALSE];
        FOR i: NAT IN [0..s1.length) DO
            c1: CHAR ~ pointer1[s1.start+i];
            c2: CHAR ~ pointer2[s2.start+i];
            IF c1#c2 THEN RETURN [FALSE];
            ENDLOOP
        RETURN [TRUE];
        };

    Eq: PROC [x1, x2: Any] RETURNS [eq: BOOL _ FALSE] ~ {
        WITH x1: x1 SELECT FROM
            null => WITH x2: x2 SELECT FROM
                null => RETURN [TRUE];
                ENDCASE;
            integer => WITH x2: x2 SELECT FROM
                integer => RETURN [x1.int=x2.int];
                real => RETURN [x1.int=x2.real];
                ENDCASE;
            real => WITH x2: x2 SELECT FROM
                integer => RETURN [x1.real=x2.int];
                real => RETURN [x1.real=x2.real];
                ENDCASE;
            boolean => WITH x2: x2 SELECT FROM
                boolean => RETURN [x1.bool=x2.bool];
                ENDCASE;
            array => WITH x2: x2 SELECT FROM
                array => RETURN [ArrayEq[x1, x2]];
                ENDCASE;
            string => WITH x2: x2 SELECT FROM
                string => RETURN [StringEq[x1, x2]];
                name => RETURN [StringEq[x1, StringFromName[x2]]];
                ENDCASE;
            name => WITH x2: x2 SELECT FROM
                string => RETURN [StringEq[StringFromName[x1], x2]];
                name => RETURN [x1.id=x2.id];
                ENDCASE;
            dictionary => WITH x2: x2 SELECT FROM
                dictionary => RETURN [x1.finger=x2.finger];
                ENDCASE;
            operator => WITH x2: x2 SELECT FROM
                operator => RETURN [x1.op=x2.op];
                ENDCASE;
            file => WITH x2: x2 SELECT FROM
                file => RETURN [x1.id=x2.id];
                ENDCASE;
            mark => WITH x2: x2 SELECT FROM
                mark => RETURN [TRUE];
                ENDCASE;
            ENDCASE;
        RETURN [FALSE];
        };

    InlineEq: PROC [x1, x2: Any] RETURNS [BOOL] ~ INLINE {
        WITH x1: x1 SELECT FROM
            name => WITH x2: x2 SELECT FROM
                name => RETURN[x1.id=x2.id];
                ENDCASE;
            ENDCASE;
        RETURN[Eq[x1, x2]];
        };

    Ge: PROC [x1, x2: Any] RETURNS [BOOL] ~ {
        WITH x1: x1 SELECT FROM
            integer => WITH x2: x2 SELECT FROM
                integer => RETURN [x1.int>=x2.int];
                real => RETURN [x1.int>=x2.real];
                ENDCASE => ERROR Error[typecheck];
            real => WITH x2: x2 SELECT FROM
                integer => RETURN [x1.int>=x2.real];
                real => RETURN [x1.int>=x2.real];
                ENDCASE => ERROR Error[typecheck];
            string => WITH x2: x2 SELECT FROM
                string => RETURN [StringCompare[x1, x2]#less];
                ENDCASE => ERROR Error[typecheck];
            ENDCASE => ERROR Error[typecheck];
        };

    Gt: PROC [x1, x2: Any] RETURNS [BOOL] ~ {
        WITH x1: x1 SELECT FROM
            integer => WITH x2: x2 SELECT FROM
                integer => RETURN [x1.int>x2.int];
                real => RETURN [x1.int>x2.real];
                ENDCASE => ERROR Error[typecheck];
            real => WITH x2: x2 SELECT FROM
                integer => RETURN [x1.int>x2.real];
                real => RETURN [x1.int>x2.real];
                ENDCASE => ERROR Error[typecheck];
            string => WITH x2: x2 SELECT FROM
                string => RETURN [StringCompare[x1, x2]=greater];
                ENDCASE => ERROR Error[typecheck];
            ENDCASE => ERROR Error[typecheck];
        };

    Ne: PROC [x1, x2: Any] RETURNS [BOOL] ~ INLINE { RETURN [NOT Eq[x1, x2]] };

    Lt: PROC [x1, x2: Any] RETURNS [BOOL] ~ INLINE { RETURN [NOT Ge[x1, x2]] };

    Le: PROC [x1, x2: Any] RETURNS [BOOL] ~ INLINE { RETURN [NOT Gt[x1, x2]] };


    Peq: PROC [self: Root] ~ {
        x2: Any ~ Pop[self.ostack];
        x1: Any ~ Pop[self.ostack];
        PushBool[self.ostack, Eq[x1, x2]];
        };

    Pne: PROC [self: Root] ~ {
        x2: Any ~ Pop[self.ostack];
        x1: Any ~ Pop[self.ostack];
        PushBool[self.ostack, Ne[x1, x2]];
        };

    Pge: PROC [self: Root] ~ {
        x2: Any ~ Pop[self.ostack];
        x1: Any ~ Pop[self.ostack];
        PushBool[self.ostack, Ge[x1, x2]];
        };

    Pgt: PROC [self: Root] ~ {
        x2: Any ~ Pop[self.ostack];
        x1: Any ~ Pop[self.ostack];
        PushBool[self.ostack, Gt[x1, x2]];
        };

    Ple: PROC [self: Root] ~ {
        x2: Any ~ Pop[self.ostack];
        x1: Any ~ Pop[self.ostack];
        PushBool[self.ostack, Le[x1, x2]];
        };

    Plt: PROC [self: Root] ~ {
        x2: Any ~ Pop[self.ostack];
        x1: Any ~ Pop[self.ostack];
        PushBool[self.ostack, Lt[x1, x2]];
        };

    Pand: PROC [self: Root] ~ {
        x2: Any ~ Pop[self.ostack];
        x1: Any ~ Pop[self.ostack];
        WITH x1: x1 SELECT FROM
            integer => WITH x2: x2 SELECT FROM
                integer => PushInt[self.ostack, Basics.DoubleAnd[[li[x1.int]], [li[x2.int]]].li];
                ENDCASE => ERROR Error[typecheck];
            boolean => WITH x2: x2 SELECT FROM
                boolean => PushBool[self.ostack, x1.bool AND x2.bool];
                ENDCASE => ERROR Error[typecheck];
            ENDCASE => ERROR Error[typecheck];
        };

    Pnot: PROC [self: Root] ~ {
        x1: Any ~ Pop[self.ostack];
        WITH x1: x1 SELECT FROM
            integer => PushInt[self.ostack, Basics.DoubleNot[[li[x1.int]]].li];
            boolean => PushBool[self.ostack, NOT x1.bool];
            ENDCASE => ERROR Error[typecheck];
        };

    Por: PROC [self: Root] ~ {
        x2: Any ~ Pop[self.ostack];
        x1: Any ~ Pop[self.ostack];
        WITH x1: x1 SELECT FROM
            integer => WITH x2: x2 SELECT FROM
                integer => PushInt[self.ostack, Basics.DoubleOr[[li[x1.int]], [li[x2.int]]].li];
                ENDCASE => ERROR Error[typecheck];
            boolean => WITH x2: x2 SELECT FROM
                boolean => PushBool[self.ostack, x1.bool OR x2.bool];
                ENDCASE => ERROR Error[typecheck];
            ENDCASE => ERROR Error[typecheck];
        };

    Pxor: PROC [self: Root] ~ {
        x2: Any ~ Pop[self.ostack];
        x1: Any ~ Pop[self.ostack];
        WITH x1: x1 SELECT FROM
            integer => WITH x2: x2 SELECT FROM
                integer => PushInt[self.ostack, Basics.DoubleXor[[li[x1.int]], [li[x2.int]]].li];
                ENDCASE => ERROR Error[typecheck];
            boolean => WITH x2: x2 SELECT FROM
                boolean => PushBool[self.ostack, x1.bool#x2.bool];
                ENDCASE => ERROR Error[typecheck];
            ENDCASE => ERROR Error[typecheck];
        };

    Pbitshift: PROC [self: Root] ~ {
        shift: INT ~ PopInt[self.ostack];
        int1: INT ~ PopInt[self.ostack];
        PushInt[self.ostack, IF shift IN(-32..32) THEN Basics.DoubleShift[[li[int1]], shift].li ELSE 0];
        };

<<File operators>>
    Pfile: PROC [self: Root] ~ {
        };

    Pclosefile: PROC [self: Root] ~ {
        };

    Pread: PROC [self: Root] ~ {
        };

    Pwrite: PROC [self: Root] ~ {
        };

    Preadhexstring: PROC [self: Root] ~ {
        };

    Pwritehexstring: PROC [self: Root] ~ {
        };

    Preadstring: PROC [self: Root] ~ {
        };

    Pwritestring: PROC [self: Root] ~ {
        };

    Preadline: PROC [self: Root] ~ {
        };

    Pbytesavailable: PROC [self: Root] ~ {
        };

    Pflush: PROC [self: Root] ~ {
        };

    Pflushfile: PROC [self: Root] ~ {
        };

    Presetfile: PROC [self: Root] ~ {
        };

    Pstatus: PROC [self: Root] ~ {
        };

    Prun: PROC [self: Root] ~ {
        };

    Pcurrentfile: PROC [self: Root] ~ {
        };

    Pprint: PROC [self: Root] ~ {
        };

    Pecho: PROC [self: Root] ~ {
        };

<<Virtual memory operators>>
    Psave: PROC [self: Root] ~ {
        };

    Prestore: PROC [self: Root] ~ {
        };

    Pvmstatus: PROC [self: Root] ~ {
        };

<<Miscellaneous operators>>
    Pbind: PROC [self: Root] ~ {
        };

    Pusertime: PROC [self: Root] ~ {
        };

<<Path construction operators>>
    Pnewpath: PROC [self: Root] ~ {
        };

    Pcurrentpoint: PROC [self: Root] ~ {
        };

    Pmoveto: PROC [self: Root] ~ {
        };

    Prmoveto: PROC [self: Root] ~ {
        };

    Plineto: PROC [self: Root] ~ {
        };

    Prlineto: PROC [self: Root] ~ {
        };

    Parc: PROC [self: Root] ~ {
        };

    Parcn: PROC [self: Root] ~ {
        };

    Parcto: PROC [self: Root] ~ {
        };

    Pcurveto: PROC [self: Root] ~ {
        };

    Prcurveto: PROC [self: Root] ~ {
        };

    Pclosepath: PROC [self: Root] ~ {
        };

    Pflattenpath: PROC [self: Root] ~ {
        };

    Preversepath: PROC [self: Root] ~ {
        };

    Pstrokepath: PROC [self: Root] ~ {
        };

    Pcharpath: PROC [self: Root] ~ {
        };

    Pclippath: PROC [self: Root] ~ {
        };

    Ppathbbox: PROC [self: Root] ~ {
        };

    Ppathforall: PROC [self: Root] ~ {
        };

    Pinitclip: PROC [self: Root] ~ {
        };

    Pclip: PROC [self: Root] ~ {
        };

    Peoclip: PROC [self: Root] ~ {
        };

<<Painting operators>>
    Perasepage: PROC [self: Root] ~ {
        };

    Pfill: PROC [self: Root] ~ {
        };

    Peofill: PROC [self: Root] ~ {
        };

    Pstroke: PROC [self: Root] ~ {
        };

    Pimage: PROC [self: Root] ~ {
        };

    Pimagemask: PROC [self: Root] ~ {
        };

<<Device setup and output operators>>
    Pshowpage: PROC [self: Root] ~ {
        };

    Pcopypage: PROC [self: Root] ~ {
        };

    Pbanddevice: PROC [self: Root] ~ {
        };

    Pframedevice: PROC [self: Root] ~ {
        };

    Pnulldevice: PROC [self: Root] ~ {
        };

    Prenderbands: PROC [self: Root] ~ {
        };

<<Character and font operators>>
    Pdefinefont: PROC [self: Root] ~ {
        };

    Pfindfont: PROC [self: Root] ~ {
        };

    Pscalefont: PROC [self: Root] ~ {
        };

    Pmakefont: PROC [self: Root] ~ {
        };

    Psetfont: PROC [self: Root] ~ {
        };

    Pcurrentfont: PROC [self: Root] ~ {
        };

    Pshow: PROC [self: Root] ~ {
        };

    Pashow: PROC [self: Root] ~ {
        };

    Pwidthshow: PROC [self: Root] ~ {
        };

    Pawidthshow: PROC [self: Root] ~ {
        };

    Pkshow: PROC [self: Root] ~ {
        };

    Pstringwidth: PROC [self: Root] ~ {
        };

<<Font cache operators>>
    Pcachestatus: PROC [self: Root] ~ {
        };

    Psetcachedevice: PROC [self: Root] ~ {
        };

    Psetcharwidth: PROC [self: Root] ~ {
        };

    Psetcachelimit: PROC [self: Root] ~ {
        };


    END.