[_CDMiwok_01_]<cedarcommon2.0>PrintTypeString>PrintTypeStringImpl.mesa!6

PrintTypeStringImpl.Mesa

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.