<<>>
    <<PrintTypeStringImpl.Mesa>>
        <<Copyright Ó 1990 by Xerox Corporation.  All rights reserved.>>
        <<Last tweaked by Mike Spreitzer on June 28, 1991 8:10 am PDT>>

    DIRECTORY Card2Tab, Commander, CommandTool, IO, MobDefs, PFSNames, PrintTypeString, Rope, RuntimeError, StructuredStreams, SymTab, 
    TypeStrings, UnparserBuffer, VersionMap2, VersionMap2Binding;

    PrintTypeStringImpl: CEDAR PROGRAM
        IMPORTS Card2Tab, Commander, CommandTool, IO, PFSNames, Rope, RuntimeError, StructuredStreams, SymTab, UnparserBuffer, VersionMap2, 
        VersionMap2Binding
        EXPORTS PrintTypeString
        =

    BEGIN OPEN PrintTypeString, SS:StructuredStreams, TS:TypeStrings, UB:UnparserBuffer, VM2:VersionMap2;

    Defs: TYPE ~ REF DefsPrivate;
    DefsPrivate: TYPE ~ ARRAY CHAR OF INT;

    Malformed: PUBLIC ERROR [i: INT, why: ROPE] ~ CODE;

    vsToName: Card2Tab.Ref ~ Card2Tab.Create[];

    ToRope: PUBLIC PROC [ts: ROPE] RETURNS [ROPE] ~ {
        buff: IO.STREAM ~ IO.ROS[];
        ToStream[buff, ts];
        RETURN IO.RopeFromROS[buff]};

    ToStream: PUBLIC PROC [to: IO.STREAM, ts: ROPE] ~ {
        defs: Defs = NEW [DefsPrivate _ ALL[INT.FIRST]];
        Work: PROC ~ {
            after: INT _ PrintType[to, defs, ts, 0];
            IF after # ts.Length[] THEN Malformed[after, "didn't consume whole string"];
            FOR name: CHAR IN CHAR DO
                IF defs[name] # INT.FIRST THEN {
                    to.PutRope[";"];
                    SS.Bp[to, united, 0, " "];
                    to.PutF["T%g: TYPE = ", [cardinal[name.ORD]] ];
                    [] _ PrintType[to, defs, ts, defs[name]];
                    }
                ENDLOOP;
            RETURN};
        PrintObj[to, Work];
        RETURN};

    GetChar: PROC [ts: ROPE, i: INT] RETURNS [c: CHAR]
        ~ {c _ ts.InlineFetch[i !RuntimeError.BoundsFault, RuntimeError.ArithmeticFault => Malformed[i, "ran off end"]]};

    PrintObj: PROC [to: IO.STREAM, Obj: PROC] ~ {
        SS.Begin[to];
        Obj[!UNWIND => SS.End[to]];
        SS.End[to]};

    PrintType: PROC [to: IO.STREAM, defs: Defs, ts: ROPE, i: INT] RETURNS [INT] ~ {
        byte: NAT ~ GetChar[ts, i].ORD;
        code: TS.Code _ definition;
        SELECT byte FROM
            <TS.Code.FIRST.ORD => Malformed[i, "too-small code"];
            300B => {to.PutRope["SX-Val"]; RETURN [i.SUCC]};
            >TS.Code.LAST.ORD => Malformed[i, "too-large code"];
            ENDCASE => code _ VAL[byte];
        SELECT code FROM
            definition => {name: CHAR ~ GetChar[ts, i.SUCC];
                IF defs[name] # INT.FIRST THEN Malformed[i, "double def"];
                defs[name] _ i+2;
                to.PutF["T%g", [cardinal[name.ORD]] ];
                RETURN PrintType[IO.noWhereStream, defs, ts, i+2]};
            name => {name: CHAR ~ GetChar[ts, i.SUCC];
                IF defs[name] = INT.FIRST THEN Malformed[i, "undefined name"];
                to.PutF["T%g", [cardinal[name.ORD]] ];
                RETURN [i+2]};
            boolean => {to.PutRope["BOOL"]; RETURN [i.SUCC]};
            enumerated => {j: INT _ i+2; first: BOOL _ TRUE;
                PrintEnum: PROC ~ {
                    to.PutRope["{"];
                    UNTIL GetChar[ts, j].ORD = TS.Code.rightParen.ORD DO
                        name: ROPE; j2, j3: INT; rep: CARD;
                        [name, j2] _ GetName[ts, j];
                        [rep, j3] _ GetCard[ts, j2];
                        IF first THEN first _ FALSE ELSE {to.PutChar[',]; SS.Bp[to, lookLeft, 3, " "]};
                        to.PutF["%g(%g)", [rope[name]], [cardinal[rep]] ];
                        j _ j3; ENDLOOP;
                    to.PutRope["}"]};
                IF GetChar[ts, i.SUCC].ORD # TS.Code.leftParen.ORD THEN Malformed[i, "enumerated not followed by leftParen"];
                PrintObj[to, PrintEnum];
                RETURN [j.SUCC]};
            paint => RETURN PrintPaint[to, ts, i.SUCC, FALSE];
            text => {to.PutRope["TEXT"]; RETURN [i.SUCC]};
            stringBody => {to.PutRope["StringBody"]; RETURN [i.SUCC]};
            leftParen => {
                PrintRecord: PROC ~ {first: BOOL _ TRUE;
                    i _ i.SUCC;
                    UNTIL GetChar[ts, i].ORD = TS.Code.rightParen.ORD DO
                        IF first THEN first _ FALSE ELSE {to.PutChar[',]; SS.Bp[to, united, 0, " "]};
                        i _ PrintField[to, defs, ts, i];
                        ENDLOOP;
                    to.PutRope["]"]};
                to.PutRope["["];
                PrintObj[to, PrintRecord];
                RETURN [i.SUCC]};
            union => RETURN PrintPaint[to, ts, i.SUCC, FALSE];
            packed => RETURN PrintUnary[to, defs, ts, i.SUCC, "PACKED"];
            array => RETURN PrintBinary[to, defs, ts, i.SUCC, "ARRAY ", "OF ", FALSE];
            sequence => {i2, i3: INT _ 0;
                SeqObj: PROC ~ {
                    to.PutRope["SEQUENCE "];
                    i2 _ PrintField[to, defs, ts, i.SUCC];
                    SS.Bp[to, united, 2, " "];
                    to.PutRope["OF "];
                    i3 _ PrintType[to, defs, ts, i2]};
                PrintObj[to, SeqObj];
                RETURN [i3]};
            subrange => {i2, i3, i4: INT _ 0; first, last: CARD;
                SubObj: PROC ~ {
                    SubSubObj: PROC ~ {
                        to.PutF["[LOOPHOLE[%xH]", [cardinal[first]] ];
                        SS.Bp[to, width, 1, ""];
                        to.PutF["..LOOPHOLE[%xH]]", [cardinal[last]] ];
                        RETURN};
                    i2 _ PrintType[to, defs, ts, i.SUCC];
                    [first, i3] _ GetCard[ts, i2];
                    [last, i4] _ GetCard[ts, i3];
                    SS.Bp[to, united, 1, ""];
                    PrintObj[to, SubSubObj];
                    RETURN};
                PrintObj[to, SubObj];
                RETURN [i4]};
            atomRec => {to.PutRope["AtomRec"]; RETURN [i.SUCC]};
            opaque => RETURN PrintPaint[to, ts, i.SUCC, TRUE];
            mds => RETURN PrintUnary[to, defs, ts, i.SUCC, "MDS"];
            countedZone => {to.PutRope["CountedZone"]; RETURN [i.SUCC]};
            uncountedZone => {to.PutRope["UncountedZone"]; RETURN [i.SUCC]};
            ordered => RETURN PrintUnary[to, defs, ts, i.SUCC, "ORDERED"];
            readOnly => RETURN PrintUnary[to, defs, ts, i.SUCC, "READONLY"];
            list => RETURN PrintUnary[to, defs, ts, i.SUCC, "LIST OF"];
            relativeRef => RETURN PrintBinary[to, defs, ts, i.SUCC, NIL, "RELATIVE"];
            refAny => {to.PutRope["REFANY"]; RETURN [i.SUCC]};
            ref => RETURN PrintUnary[to, defs, ts, i.SUCC, "REF"];
            var => RETURN PrintUnary[to, defs, ts, i.SUCC, "VAR"];
            pointer => RETURN PrintUnary[to, defs, ts, i.SUCC, "POINTER TO"];
            longPointer => RETURN PrintUnary[to, defs, ts, i.SUCC, "LONG POINTER TO"];
            descriptor => RETURN PrintUnary[to, defs, ts, i.SUCC, "DESCRIPTOR FOR"];
            longDescriptor => RETURN PrintUnary[to, defs, ts, i.SUCC, "LONG DESCRIPTOR FOR"];
            procedure => RETURN PrintTransfer[to, defs, ts, i.SUCC, "UNSAFE PROC "];
            safeProc => RETURN PrintTransfer[to, defs, ts, i.SUCC, "SAFE PROC "];
            safe => RETURN PrintUnary[to, defs, ts, i.SUCC, "SAFE"];
            port => RETURN PrintTransfer[to, defs, ts, i.SUCC, "PORT "];
            program => RETURN PrintTransfer[to, defs, ts, i.SUCC, "PROGRAM "];
            signal => RETURN PrintTransfer[to, defs, ts, i.SUCC, "SIGNAL "];
            error => RETURN PrintTransfer[to, defs, ts, i.SUCC, "ERROR "];
            process => RETURN PrintUnary[to, defs, ts, i.SUCC, "PROCESS RETURNS"];
            cardinal => {to.PutRope["CARDINAL"]; RETURN [i.SUCC]};
            integer => {to.PutRope["INTEGER"]; RETURN [i.SUCC]};
            character => {to.PutRope["CHAR"]; RETURN [i.SUCC]};
            longInteger => {to.PutRope["INT"]; RETURN [i.SUCC]};
            longCardinal => {to.PutRope["CARD"]; RETURN [i.SUCC]};
            real => {to.PutRope["REAL"]; RETURN [i.SUCC]};
            type => {to.PutRope["TYPE"]; RETURN [i.SUCC]};
            any => {to.PutRope["ANY"]; RETURN [i.SUCC]};
            unspecified => {to.PutRope["UNSPECIFIED"]; RETURN [i.SUCC]};
            longUnspecified => {to.PutRope["LONG UNSPECIFIED"]; RETURN [i.SUCC]};
            dcard => {to.PutRope["DCARD"]; RETURN [i.SUCC]};
            dint => {to.PutRope["DINT"]; RETURN [i.SUCC]};
            dreal => {to.PutRope["DREAL"]; RETURN [i.SUCC]};
            globalFrame, localFrame => Malformed[i, "got a frame"];
            ENDCASE => Malformed[i, "unrecognized code"]};

    PrintTransfer: PROC [to: IO.STREAM, defs: Defs, ts: ROPE, i: INT, head: ROPE] RETURNS [INT]
        ~ {RETURN PrintBinary[to, defs, ts, i, head, "RETURNS"]};

    PrintUnary: PROC [to: IO.STREAM, defs: Defs, ts: ROPE, i: INT, head: ROPE] RETURNS [INT] ~ {
        i2: INT _ 0;
        Objer: PROC ~ {
            to.PutRope[head];
            SS.Bp[to, united, 2, " "];
            i2 _ PrintType[to, defs, ts, i];
            RETURN};
        PrintObj[to, Objer];
        RETURN [i2]};

    PrintBinary: PROC [to: IO.STREAM, defs: Defs, ts: ROPE, i: INT, head, mid: ROPE, b2: BOOL _ TRUE] RETURNS [INT] ~ {
        i2, i3: INT _ 0;
        Objer: PROC ~ {
            to.PutRope[head];
            i2 _ PrintType[to, defs, ts, i];
            SS.Bp[to, united, 1, " "];
            to.PutRope[mid];
            IF b2 THEN SS.Bp[to, united, 2, " "];
            i3 _ PrintType[to, defs, ts, i2];
            RETURN};
        PrintObj[to, Objer];
        RETURN [i3]};

    PrintField: PROC [to: IO.STREAM, defs: Defs, ts: ROPE, i: INT] RETURNS [INT] ~ {
        name: ROPE;
        i2, i3: INT _ 0;
        FieldObj: PROC ~ {
            to.PutRope[name];
            to.PutRope[":"];
            SS.Bp[to, united, 2, " "];
            i3 _ PrintType[to, defs, ts, i2];
            RETURN};
        [name, i2] _ GetName[ts, i];
        PrintObj[to, FieldObj];
        RETURN [i3]};

    PrintPaint: PROC [to: IO.STREAM, ts: ROPE, i: INT, isOpaque: BOOL] RETURNS [INT] ~ {
        vs: MobDefs.VersionStamp;
        i2, i3, i4: INT;
        IF isOpaque THEN {mod, name: ROPE;
            [name, i2] _ GetName[ts, i];
            [vs[0], i3] _ GetCard[ts, i2];
            [vs[1], i4] _ GetCard[ts, i3];
            mod _ DescribeModule[vs];
            to.PutF["%g.%g", [rope[mod]], [rope[name]] ];
            RETURN [i4]}
        ELSE {mod: ROPE; ctx: CARD;
            [vs[0], i2] _ GetCard[ts, i];
            [vs[1], i3] _ GetCard[ts, i2];
            mod _ DescribeModule[vs];
            [ctx, i4] _ GetCard[ts, i3];
            to.PutF["%g:ctx%x", [rope[mod]], [cardinal[ctx]] ];
            RETURN [i4]}};

    DescribeModule: PROC [vs: MobDefs.VersionStamp] RETURNS [ROPE] ~ {
        ans: ROPE;
        Update: PROC [found: BOOL, val: REF ANY] RETURNS [op: Card2Tab.UpdateOperation, new: REF ANY] ~ {
            IF found THEN {
                ans _ NARROW[val];
                RETURN [none, NIL]}
            ELSE {
                ints: VM2.Map ~ VersionMap2Binding.GetMap["Intermediate"];
                syms: SymTab.Ref ~ SymTab.Create[case: FALSE];
                PerMatch: PROC [vt: VM2.VersionTuple] RETURNS [BOOL] ~ {
                    lc: PFSNames.Component ~ vt.name.ShortName[];
                    snr: ROPE ~ lc.ComponentRope[--no version part wanted or expected--];
                    dp: INT ~ snr.Index[s2: "."];
                    base: ROPE ~ snr.Substr[len: dp];
                    [] _ syms.Insert[ans _ base, $T];
                    RETURN [syms.GetSize[] > 1]};
                [] _ ints.ScanMatches[PerMatch, FALSE, [stamp: vs]];
                SELECT syms.GetSize[] FROM
                    1 => ans _ ans;
                    ENDCASE => ans _ IO.PutFR["%08x%08x", [cardinal[vs[0]]], [cardinal[vs[1]]] ];
                RETURN [store, ans]};
            };
        vsToName.Update[vs, Update];
        RETURN [ans]};

    GetName: PROC [ts: ROPE, i: INT] RETURNS [name: ROPE, j: INT] ~ {
        len: INT ~ GetChar[ts, i].ORD;
        GenChar: PROC RETURNS [CHAR] ~ {j _ j.SUCC; RETURN [GetChar[ts, j]]};
        IF len=0 THEN RETURN ["null name", i.SUCC];
        IF len >= 200B THEN Malformed[i, "implausible name"];
        j _ i;
        name _ Rope.FromProc[len, GenChar];
        j _ j.SUCC;
        IF name.Fetch[0].ORD = len-1 THEN name _ name.Substr[start: 1];
        RETURN};

    b8: CARD = 256;

    GetCard: PROC [ts: ROPE, i: INT] RETURNS [card: CARD, j: INT] ~ {
        encodeMod: NAT = 64;
        c1: NAT ~ GetChar[ts, i].ORD;
        SELECT c1 FROM
            < encodeMod*1 => RETURN [c1, i+1];
            < encodeMod*2 => RETURN [256*(c1-encodeMod*1) + GetChar[ts, i+1].ORD, i+2];
            < encodeMod*3 => RETURN [65536*(c1-encodeMod*2) + b8*GetChar[ts, i+1].ORD + GetChar[ts, i+2].ORD, i+3];
            > encodeMod*3 => RETURN [CARD.LAST-(c1-encodeMod*3-1), i+1];
            ENDCASE => RETURN [GetChar[ts, i+4].ORD + b8 * (
                GetChar[ts, i+3].ORD + b8 * (
                GetChar[ts, i+2].ORD + b8 * (
                GetChar[ts, i+1].ORD))), i+5]};

    Cmd: PROC [cmd: Commander.Handle] RETURNS [result: REF ANY _ NIL, msg: ROPE _ NIL] --Commander.CommandProc-- ~ {
        buff: UB.Handle ~ UB.NewInittedHandle[[margin: 60, output: [stream[cmd.out]] ]];
        sout: IO.STREAM ~ SS.Create[buff];
        argv: CommandTool.ArgumentVector;
        argv _ CommandTool.Parse[cmd !CommandTool.Failed => {msg _ errorMsg; GOTO Failed}];
        FOR i: NAT IN (0 .. argv.argc) DO
            ts: ROPE ~ argv[i];
            sout.PutF["\"%q\" <->", [rope[ts]] ];
            SS.Bp[sout, width, 0, " "];
            ToStream[sout, ts !Malformed => {
                cmd.err.PutF["!Malformed (%g) at %g", [rope[why]], [integer[i]] ];
                CONTINUE}];
            sout.PutRope[".\n"];
            ENDLOOP;
        RETURN
        EXITS Failed => result _ $Failure};

    Flush: Commander.CommandProc ~ {vsToName.Erase[]; RETURN};

    Commander.Register["FlushTypeStringModuleCache", Flush];
    Commander.Register["PrintTypeString", Cmd];

    END.