
    <<GPMImpl.mesa>>
        <<Copyright © 1985 by Xerox Corporation.  All rights reserved.>>
        <<Doug Wyatt, March 1, 1985 1:38:29 pm PST>>
        <<Russ Atkinson (RRA) October 24, 1985 6:40:49 pm PDT>>
        <<Michael Plass, October 30, 1985 9:19:33 am PST>>
    <<>>
    <<Strachey's General Purpose Macrogenerator>>
    <<as described in Computer Journal, Oct. 1965. pp. 225-241>>
    <<>>
    DIRECTORY
        FS USING [StreamOpen],
        GPM USING [BuiltIn, DEF, Entry, ErrorCode, gpmVAL, Handle, Index, maxIndex, Object, Stack, UPDATE],
        IO USING [Close, EndOfStream, GetChar, GetIndex, Put, PutChar, PutR, PutRope, STREAM],
        Rope USING [Concat, FromProc, ROPE];

    GPMImpl: CEDAR PROGRAM
        IMPORTS FS, IO, Rope
        EXPORTS GPM
        = { OPEN GPM;

        ROPE: TYPE = Rope.ROPE;
        STREAM: TYPE = IO.STREAM;

        <<for debugging>>
            outputloc: INT _ 0;
            inputloc: INT _ 0;

        Open: PUBLIC PROC [stream: STREAM] RETURNS [self: Handle] = {
            self _ NEW[Object];
            self.st _ NEW[Stack[10000]];
            self.output _ NEW[TEXT[100]];
            self.outputChar _ endOfInput;
            self.stream _ stream;
            self.s _ 21; self.e _ 12; self.q _ 1; self.a _ endOfInput;
            self.st[0] _ index[maxIndex];
            self.st[1] _ length[4];
            self.st[2] _ char['D];
            self.st[3] _ char['E];
            self.st[4] _ char['F];
            self.st[5] _ builtin[DEF];
            self.st[6] _ index[0];
            self.st[7] _ length[4];
            self.st[8] _ char['V];
            self.st[9] _ char['A];
            self.st[10] _ char['L];
            self.st[11] _ builtin[gpmVAL];
            self.st[12] _ index[6];
            self.st[13] _ length[7];
            self.st[14] _ char['U];
            self.st[15] _ char['P];
            self.st[16] _ char['D];
            self.st[17] _ char['A];
            self.st[18] _ char['T];
            self.st[19] _ char['E];
            self.st[20] _ builtin[UPDATE];
            outputloc _ 0;
            inputloc _ 0;
            };

        Close: PUBLIC PROC [self: Handle] = {
            IF self.stream # NIL THEN IO.Close[self.stream];
            self.stream _ NIL;
            self.output _ NIL;
            self.st _ NIL;
            };

        GetIndex: PUBLIC PROC [self: Handle] RETURNS [i: INT] = {
            RETURN [IO.GetIndex[self.stream]];
            };

        DumpToStream: PUBLIC PROC [output: STREAM, input: Handle] = {
            DO IO.PutChar[output,GetChar[input ! Error => IF ec = EndOfStream THEN EXIT]]; ENDLOOP;
            input.stream _ NIL;
            Close[input] 
            };

        Error: PUBLIC ERROR [ec: ErrorCode, errorMsg: ROPE] = CODE;
    <<>>
    <<Internal procs>>
        <<>>
        endOfInput: CHAR = 0C;
        Load: PROC [self: Handle] = {
            IF self.h=0
                THEN {
                    IF self.output.length = 0 AND self.outputChar = endOfInput THEN {
                        self.outputChar _ self.a; RETURN 
                        };
                    IF self.output.length = self.output.maxLength THEN {
                        new: REF TEXT _ NEW[TEXT[self.output.maxLength*2]];
                        new.length _ self.output.length;
                        FOR i:NAT IN [0..self.output.length) DO new[i] _ self.output[i]; ENDLOOP;
                        self.output _ new 
                        };
                    self.output[self.output.length] _ self.a;
                    self.output.length _ self.output.length+1 
                    }
                ELSE { self.st[self.s] _ char[self.a]; self.s _ self.s+1 };
            };

        NextCh: PROC [self: Handle] = {
            IF self.c=0
                THEN {
                    self.a _ IO.GetChar[self.stream ! IO.EndOfStream => { self.a _ endOfInput; CONTINUE }];
                    inputloc _ inputloc+1 
                    }
                ELSE { self.a _ ToChar[self.st[self.c]]; self.c _ self.c+1 };
            };

        Find: PROC [self: Handle, x: Index] = {
            <<x is index of name>>
            <<finds name in e chain and sets w to start of def>>
            ptr: Index _ self.e; -- start of definitions
            self.w _ x; -- index of name length
            DO    -- search for macro name definition
                match: BOOL _ TRUE;
                len: Index _ ToLength[self.st[self.w]];
                FOR r:Index IN [0..len) DO
                    IF self.st[self.w+r]#self.st[ptr+r+1] THEN { match _ FALSE; EXIT };
                    ENDLOOP;
                IF match THEN { self.w _ ptr+1+len; RETURN };
                ptr _ ToIndex[self.st[ptr]]; -- next entry
                IF ptr = maxIndex THEN EXIT; -- end of chain
                ENDLOOP;
            <<undefined>>
            Error[MacroError,Rope.Concat["Undefined name: ",Rope.Concat[Item[self,self.w],AtLoc[self]]]] 
            };

        Item: PROC [self: Handle, x: Index] RETURNS [rope: ROPE] = {
            <<return the item on the stack starting at st[x]>>
            <<if item is not complete, stop at st[s-1] and>>
            <<follow by "...(Incomplete)">>
            proc: SAFE PROC RETURNS [CHAR] = { k _ k+1; RETURN [ToChar[self.st[x+k]]] };
            k: Index _ 0;
            stklen: Index _ ToLength[self.st[x]];
            incomplete: BOOL _ stklen=0;
            len: Index _ IF incomplete THEN self.s-x-1 ELSE stklen-1;
            rope _ Rope.FromProc[len, proc];
            IF incomplete THEN rope _ Rope.Concat[rope,"...(Incomplete)"] 
            };

        AtLoc: PROC [self: Handle] RETURNS [rope: ROPE] = {
            RETURN [Rope.Concat[" at ", IO.PutR[[integer[IO.GetIndex[self.stream]-1]]]]] 
            };

        EndFn: PROC [self: Handle] = {
            <<remove call and arg list; copy back result if any>>
            y: Index;
            len: Index;
            IF self.f > self.p THEN { -- encountered terminator in bad place
                msg: ROPE;
                IF self.c=0 THEN ERROR; -- found terminator in input source
                msg _ Rope.Concat["Terminator in argument list for ",Item[self,self.f+2]];
                msg _ Rope.Concat[msg,". Probably due to a semicolon missing from the definition of "];
                msg _ Rope.Concat[msg,Item[self,self.p+2]];
                Error[MacroError,msg] 
                };
            <<first remove any defs in arg list from e chain>>
            <<and adjust defs in results so chain will be correct later>>
            y _ self.s;
            self.st[self.s] _ index[self.e];
            len _ ToLength[self.st[self.p-1]]; -- arg list stuff to be removed
            WHILE ToIndex[self.st[y]] >= self.p-1+len DO -- take care of defs in results
                next: Index _ ToIndex[self.st[y]];
                self.st[y] _ index[next-len];
                y _ next;
                ENDLOOP;
            self.w _ ToIndex[self.st[y]]; 
            WHILE self.w > self.p-1 DO self.w _ ToIndex[self.st[self.w]]; ENDLOOP;
                <<skip over defs in args>>
            self.st[y] _ index[self.w];
            self.e _ ToIndex[self.st[self.s]];
            IF self.h # 0 THEN
            IF self.h > self.p THEN self.h _ self.h-len
                ELSE self.st[self.h] _ length[ToLength[self.st[self.h]]-len];
            self.c _ ToIndex[self.st[self.p+1]];
            self.s _ self.s-len;
            y _ self.p-1; -- dest for results
            self.w _ self.p-1+len; -- source of results
            self.p _ ToIndex[self.st[self.p]];
            UNTIL y=self.s DO
                self.st[y] _ self.st[self.w];
                y _ y+1;
                self.w _ self.w+1;
                ENDLOOP 
            };

        GetChar: PUBLIC PROC [self: Handle] RETURNS [char: CHAR] = {
            DO
                <<main loop>>
                flag: BOOL _ FALSE;
                IF self.st = NIL THEN Error[EndOfStream, "Stream already closed"];
                IF self.outputChar # endOfInput THEN {
                    char _ self.outputChar;
                    self.outputChar _ endOfInput;
                    outputloc _ outputloc+1;
                    RETURN 
                    };
                IF self.output.length > self.outputPtr THEN {
                    char _ self.output[self.outputPtr];
                    IF (self.outputPtr _ self.outputPtr+1) = self.output.length THEN
                        self.output.length _ self.outputPtr _ 0;
                    outputloc _ outputloc+1;
                    RETURN 
                    };
                NextCh[self];
                SELECT self.a FROM
                    self.startQuote => { self.q _ self.q+1; flag _ TRUE };
                    self.singleQuote => { NextCh[self]; Load[self]; LOOP };
                    self.startCall => {
                        <<Fn; start new function call>>
                        self.st[self.s] _ index[self.h];
                        self.st[self.s+1] _ index[self.f];
                        self.st[self.s+2] _ index[0];
                        self.st[self.s+3] _ length[0];
                        self.h _ self.s+3;
                        self.f _ self.s+1;
                        self.s _ self.s+4;
                        LOOP 
                        };
                    self.sepArg => IF self.h=0 THEN NULL ELSE {
                        <<NextItem; collect next arg>>
                        self.st[self.h] _ length[self.s-self.h-ToLength[self.st[self.h]]];
                        self.st[self.s] _ length[0];
                        self.h _ self.s;
                        self.s _ self.s+1;
                        LOOP 
                        };
                    self.endCall => IF self.h=0 THEN NULL ELSE {
                        <<Apply;>>
                        oldstf1: Index _ ToIndex[self.st[self.f-1]];
                        oldstf: Index _ ToIndex[self.st[self.f]];
                        self.st[self.h] _ length[self.s-self.h];
                        self.st[self.s] _ mark;
                        self.st[self.f-1] _ length[self.s-self.f+2];
                        self.st[self.f] _ index[self.p];
                        self.st[self.f+1] _ index[self.c];
                        self.p _ self.f;
                        self.h _ oldstf1;
                        self.f _ oldstf;
                        self.s _ self.s+1;
                        IF self.h # 0 THEN -- increase count of extra stuff
                        self.st[self.h] _ length[ToLength[self.st[self.h]]+ToLength[self.st[self.p-1]]];
                        Find[self,self.p+2];
                        IF IsBuiltIn[self.st[self.w]] THEN {
                            SELECT ToBuiltIn[self.st[self.w]] FROM
                                DEF => {
                                    <<add self.a new definition>>
                                    IF self.h # 0 THEN self.st[self.h] _ length[ToLength[self.st[self.h]]-ToLength[self.st[self.p-1]]+6];
                                    self.st[self.p-1] _ length[6];
                                    self.st[self.p+5] _ index[self.e];
                                    self.e _ self.p+5 
                                    };
                                gpmVAL => {
                                    <<get value of name>>
                                    Find[self, self.p+6];
                                    UNTIL self.st[self.w+1]=mark DO
                                        self.a _ ToChar[self.st[self.w+1]];
                                        self.w _ self.w+1;
                                        Load[self];
                                        ENDLOOP 
                                    };
                                UPDATE => {
                                    <<change value of name>>
                                    y: Index;
                                    Find[self, self.p+9];
                                    y _ self.p+9+ToLength[self.st[self.p+9]];
                                    IF ToLength[self.st[y]] > ToLength[self.st[self.w]] THEN
                                    Error[MacroError,Rope.Concat["UPDATE arg too long for ",
                                        Rope.Concat[Item[self,self.p+9],AtLoc[self]]]];
                                    FOR r:NAT IN [1..ToLength[self.st[y]]] DO
                                        self.st[self.w+r] _ self.st[y+r];
                                        ENDLOOP 
                                    };
                                ENDCASE => ERROR;
                            EndFn[self];
                            LOOP 
                            };
                        self.c _ self.w+1;
                        LOOP 
                        };
                    self.numArg => IF self.p=0 THEN NULL ELSE {
                        <<LoadArg;>>
                        NextCh[self]; -- read arg number
                        self.w _ self.p+2;
                        IF self.a NOT IN ['0..'9] THEN
                        Error[MacroError,Rope.Concat["Bad arg number in definition of ",Item[self,self.p+2]]];
                        FOR r:NAT IN [0..self.a-'0) DO
                            self.w _ self.w+ToLength[self.st[self.w]];
                            IF self.st[self.w]=mark THEN EXIT; -- act like have null arg
                            ENDLOOP;
                        IF self.st[self.w]=mark THEN LOOP;
                        FOR r:NAT IN [1..ToLength[self.st[self.w]]) DO
                            self.a _ ToChar[self.st[self.w+r]]; Load[self]; ENDLOOP;
                        LOOP 
                        };
                    marker => { EndFn[self]; LOOP };
                    endOfInput =>
                        IF self.h # 0
                            THEN Error[MacroError,"End of input encountered inside macro call"]
                            ELSE Error[EndOfStream,"EndOfStream"];
                    ENDCASE;
                DO
                    <<subloop for copying literals>>
                    IF flag THEN flag _ FALSE ELSE { Load[self]; IF self.q = 1 THEN EXIT };
                    NextCh[self];
                    SELECT self.a FROM
                        self.startQuote => { self.q _ self.q+1; LOOP };
                        endOfInput =>
                            Error[MacroError,"End of input encountered inside macro quoted string"];
                        self.endQuote => NULL;
                        ENDCASE => LOOP;
                    self.q _ self.q-1;
                    IF self.q = 1 THEN EXIT;
                    ENDLOOP; 
                ENDLOOP 
            };

        ToIndex: PROC [e: Entry] RETURNS [i: Index] = INLINE { RETURN [LOOPHOLE[e]] };
        ToLength: PROC [e: Entry] RETURNS [i: Index] = INLINE { RETURN [LOOPHOLE[e]] };
        ToChar: PROC [e: Entry] RETURNS [char: CHAR] = INLINE { RETURN [LOOPHOLE[e]] };
        ToBuiltIn: PROC [e: Entry] RETURNS [name: BuiltIn] = INLINE { RETURN [LOOPHOLE[-e]] };
        index: PROC [i: Index] RETURNS [Entry] = INLINE { RETURN [[LOOPHOLE[i,INTEGER]]] };
        length: PROC [i: Index] RETURNS [Entry] = INLINE { RETURN [[LOOPHOLE[i,INTEGER]]] };
        char: PROC [c: CHAR] RETURNS [Entry] = INLINE { RETURN [[LOOPHOLE[c,INTEGER]]] };
        mark: Entry = char[marker];
        marker: CHAR = 377C;
        builtin: PROC [name: BuiltIn] RETURNS [Entry] = INLINE { RETURN [[-name]] };
        IsBuiltIn: PROC [e: Entry] RETURNS [BOOL] = INLINE { RETURN [e < 0] };

    <<debugging aids>>

        WriteStack: PROC [self: Handle] = {
            h: STREAM _ FS.StreamOpen[fileName: "GPMStack.Txt", accessOptions: $create];
            { ENABLE UNWIND => IO.Close[h];
                IF self.h = 0
                    THEN IO.PutRope[h, "h = 0\n"]
                    ELSE {
                        IO.PutRope[h, "\n\nIncomplete string on top of stack\n\n"];
                        FOR i: Index _ self.h + self.st[self.h] + 1--?--, i+1 UNTIL i >= self.s DO
                            WriteChar[i, self, h];
                            ENDLOOP 
                        };
                IF self.c = 0
                    THEN IO.PutRope[h, "\n\nc = 0\n\n"]
                    ELSE {
                        IO.PutRope[h, "\n\nString being scanned from stack\n\n"];
                        FOR i: Index _ self.c, i+1
                            UNTIL i >= self.s OR self.st[i] = mark DO
                            WriteChar[i, self, h];
                            ENDLOOP 
                        };
                IF self.p = 0
                    THEN IO.PutRope[h, "\n\np  = 0\n\n"]
                    ELSE {
                        last: Index _ self.s;
                        IO.PutRope[h, "\n\nCalls entered but not yet completed\n\n"];
                        FOR i: Index _ self.p, self.st[i] UNTIL i >= last OR i=0 DO
                            last _ i;
                            WriteItem[self, h, i+2];
                            ENDLOOP 
                        };
                IF self.f = 0
                    THEN IO.PutRope[h, "\n\nf  = 0\n\n"]
                    ELSE {
                        last: Index _ self.s;
                        IO.PutRope[h, "\n\nCalls started but not yet entered\n\n"];
                        FOR i: Index _ self.f, self.st[i] UNTIL i >= last OR i=0 DO
                            last _ i;
                            WriteItem[self, h, i+2];
                            ENDLOOP 
                        };
                IF self.e = 0
                    THEN IO.PutRope[h, "\n\ne  = 0\n\n"]
                    ELSE {
                        last: Index _ self.s;
                        IO.PutRope[h, "\n\nCurrent definitions\n\n"];
                        FOR i: Index _ self.e, self.st[i] UNTIL i >= last OR i=0 DO
                            last _ i;
                            WriteItem[self, h, i+1];
                            ENDLOOP 
                        };
                };
            IO.Close[h];
            };

        WriteChar: PROC [i: Index, self: Handle, h: STREAM] = {
            IO.Put[h, [character[LOOPHOLE [MIN[self.st[i],128], CHAR]]]];
            };

        WriteItem: PROC [self: Handle, h: STREAM, i: Index] = {
            len: INTEGER _ self.st[i];
            end: Index _ MIN[i+len, self.s];
            IO.PutChar[h, '\t];
            FOR j: Index IN [i+1..end) DO
                WriteChar[j, self, h];
                ENDLOOP;
            IO.PutChar[h, '\n];
            };

        }.