PrettyTypePrinter.mesa
Copyright © 1985 by Xerox Corporation. All rights reserved.
Russ Atkinson, February 12, 1985 2:08:53 pm PST
Warren Teitelman, January 6, 1983 7:22 pm
Paul Rovner, July 13, 1983 5:39 pm
Spreitzer, September 20, 1985 10:20:45 am PDT
Mike Spreitzer July 30, 1986 7:53:05 pm PDT
DIRECTORY
AMTypes USING [Class, Domain, Error, First, Ground, Index, IndexToDefaultInitialValue, IndexToName, IndexToType, Last, NComponents, NValues, Range, ReferentStatus, IsComputed, IsMachineDependent, IsOverlaid, IsPacked, TypeClass, TypeToName, UnderType, UnderClass, Value, TV, TVToType],
BackStop USING [Call],
IO USING [STREAM, PutRope, PutChar],
PrintTV USING [Print, RegisterClassPrintProc],
Rope USING [Fetch, ROPE, Equal, Length, IsEmpty, Cat, Concat],
SafeStorage USING [nullType, Type, EquivalentTypes],
StructuredStreams USING [Begin, End, Bp]
;
PrettyTypePrinter: CEDAR MONITOR
IMPORTS AMTypes, BackStop, IO, PrintTV, Rope, SafeStorage, StructuredStreams
= BEGIN OPEN Rope, SafeStorage, AMTypes, StructuredStreams;
MakePiece: PROC [put: IO.STREAM, Write: PROC, united: BOOLFALSE] = {
Bp[put, IF united THEN united ELSE lookLeft, indent];
Begin[put];
Write[ !UNWIND => End[put] ];
End[put];
};
indent: INTEGER ← 3;
UnderBoolean: Type ← LOOPHOLE[CODE[BOOL]];
PrettyPrintType: PROC [tv: TV, data: REF ANY, stream: IO.STREAM, depth: INT ← 4, width: INT ← 32, verbose: BOOLFALSE] RETURNS [useOld: BOOLFALSE] --PrintTV.TVPrintProc-- = {
type: Type = TVToType[tv];
PrintType[type, stream, depth, width, verbose];
};
PrintType: PROC [type: Type, put: IO.STREAM, depth: INT ← 4, width: INT ← 32, verbose: BOOLFALSE] = {
PutReadonly: PROC [t: Type] = {
IF ReferentStatus[t] = readOnly THEN put.PutRope["READONLY "];
};
PutInnards: PROC [type: Type, start: INT ← 1] = {
n: INT ← 0;
class: Class ← TypeClass[type];
indexStart: NAT ← start;
sep: ROPENIL;
SELECT class FROM
union => {
NCases: PROC [type: Type] RETURNS [n: INT] = {
this procedure returns the number of cases for a variant record. we need this proc because the number of cases is sometimes less than the number of values for the domain type. ERROR AMTypes.Error[typeFault] is raised when the type is not right
SELECT AMTypes.UnderClass[type] FROM
record, structure => {
last: INT ← AMTypes.NComponents[type];
lastType: Type ← nullType;
IF last = 0 THEN GO TO noCases;
lastType ← AMTypes.IndexToType[type, last];
IF AMTypes.UnderClass[lastType] # union THEN GO TO noCases;
type ← lastType;
};
union => {};
ENDCASE => GO TO noCases;
n ← AMTypes.NValues[AMTypes.Domain[type]];
WHILE n > 0 DO
[] ← AMTypes.IndexToType[type, n ! AMTypes.Error =>
IF reason = badIndex THEN {n ← n - 1; LOOP}
];
RETURN;
ENDLOOP;
EXITS
noCases => ERROR AMTypes.Error[typeFault, NIL, type];
};
tagType: Type ← nullType;
sep ← " => ";
indexStart ← 1;
output the SELECT stuff
put.PutRope["SELECT "];
tagType ← AMTypes.Domain[type];
n ← NCases[type];
IF IsOverlaid[type]
THEN put.PutRope["OVERLAID "]
ELSE put.PutRope[Rope.Concat[AMTypes.IndexToName[type, 0], ": "]];
PrintType[tagType, put, depth, width];
put.PutRope[" FROM "];
};
record, structure => {sep ← ": "; n ← AMTypes.NComponents[type]};
ENDCASE => {PrintType[type, put, depth, width]; RETURN};
FOR i: INT IN [indexStart..n] DO
subType: Type ← nullType;
subClass: Class ← nil;
WriteSepAndType: PROC = {put.PutRope[sep]; WriteType[]};
WriteType: PROC = {
IF class = union
THEN {
the subType must be a record or structure which describes the bound variant type (so be careful where you start)
put.PutRope["["];
PutInnards[subType, start];
put.PutRope["]"];
}
ELSE SELECT subClass FROM
union => PutInnards[subType, i];
sequence => PrintType[subType, put, depth, width];
ENDCASE => PrintType[subType, put, depth-1, width];
};
WriteInitialization: PROC = {
IF class # union THEN SELECT subClass FROM
union => NULL;
sequence => NULL;
ENDCASE => {
defaultTV: TVNIL;
be prepared: rttypes bug when NValues[...] > LAST[CARDINAL]
defaultTV ← IndexToDefaultInitialValue[type, i ! ANY => CONTINUE];
IF defaultTV # NIL THEN {
put.PutRope[" ← "];
PrintTV.Print[defaultTV, put, depth, width, verbose];
};
};
};
subInner: PROC = {
name: ROPE = IndexToName[type, i];
named: BOOL = NOT name.IsEmpty[];
subType ← IndexToType[type, i];
subClass ← TypeClass[subType];
IF named THEN {
put.PutRope[name];
MakePiece[put, WriteSepAndType, TRUE];
MakePiece[put, WriteInitialization, TRUE];
}
ELSE {
WriteType[];
MakePiece[put, WriteInitialization];
};
};
WriteField: PROC = {
msg: ROPENIL;
msg ← BackStop.Call[subInner];
IF msg # NIL THEN put.PutRope[Rope.Cat["--{", msg, "}--"]];
};
IF i > indexStart THEN put.PutRope[", "];
IF i > width AND i < n THEN {put.PutRope["..."]; EXIT};
MakePiece[put, WriteField];
ENDLOOP;
IF class = union THEN put.PutRope[" ENDCASE"];
};
class: Class ← nil;
innerPut: PROC = {
IF depth <= 0 THEN {put.PutRope["..."]; RETURN};
class ← TypeClass[type];
SELECT class FROM
definition => {
mod: REF ROPENEW[ROPENIL];
name: ROPE ← TypeToName[type, mod];
length: INT = mod^.Length[];
IF length # 0 THEN -- put out module name unless type name is all caps.
FOR i: INT IN [0..Rope.Length[name]) DO
IF Rope.Fetch[name, i] NOT IN ['A..'Z] THEN {put.PutRope[Rope.Cat[mod^, "."]]; EXIT};
REPEAT
FINISHED => IF Rope.Equal[name, "LORA"] THEN { -- sorry Russ.
PrintType[UnderType[type], put, depth, width, verbose];
RETURN;
};
ENDLOOP;
put.PutRope[name];
IF NOT name.IsEmpty[] AND verbose THEN
FOR l: LIST OF ROPE ← everybodyKnowsThese, l.rest UNTIL l = NIL DO
IF Rope.Equal[l.first, name] THEN EXIT;
REPEAT
FINISHED =>
{put.PutRope[": TYPE = "];
PrintType[UnderType[type], put, depth, width, verbose];
};
ENDLOOP;
};
cardinal => put.PutRope["CARDINAL"];
longCardinal => put.PutRope["LONG CARDINAL"];
integer => put.PutRope["INTEGER"];
longInteger => put.PutRope["INT"];
real => put.PutRope["REAL"];
character => put.PutRope["CHAR"];
atom => put.PutRope["ATOM"];
rope => put.PutRope["ROPE"];
list => {
put.PutRope["LIST OF "];
PrintType[IndexToType[Range[type], 1], put, depth, width];
};
ref => {
range: Type ← Range[type];
put.PutRope["REF "];
PutReadonly[type];
IF range # nullType THEN {PrintType[range, put, depth, width]};
IF verbose THEN
SELECT TypeClass[UnderType[range]] FROM
record, structure =>
{put.PutRope["; \n"];
PrintType[range, put, depth, width];
put.PutRope[": TYPE = "];
PrintType[UnderType[range], put, depth, width]};
ENDCASE;
};
pointer, longPointer, basePointer, relativePointer => {
range: Type ← Range[type];
SELECT class FROM
longPointer => put.PutRope["LONG "];
relativePointer => put.PutRope["RELATIVE "];
basePointer => put.PutRope["LONG BASE "];
ENDCASE;
SELECT TRUE FROM
range = nullType OR TypeClass[range] = unspecified => put.PutRope["POINTER"];
EquivalentTypes[range, CODE[StringBody]] => put.PutRope["STRING"];
ENDCASE =>
{put.PutRope["POINTER TO "];
SELECT class FROM
longPointer, pointer => PutReadonly[type];
ENDCASE;
PrintType[range, put, depth, width]};
};
descriptor, longDescriptor => {
range: Type ← nullType;
IF class = longPointer THEN put.PutRope["LONG "];
put.PutRope["DESCRIPTOR"];
range ← Range[type];
IF range # nullType AND TypeClass[range] # unspecified THEN
{put.PutRope[" TO "];
PutReadonly[type];
PrintType[range, put, depth, width]};
};
procedure, signal, error, program, port => {
argsType, rtnsType: Type ← nullType;
prefix: ROPE
SELECT class FROM
procedure => "PROC", signal => "SIGNAL", error => "ERROR",
program => "PROGRAM" , port => "PORT", ENDCASE => "??";
WriteArg: PROC = {
PrintType[argsType, put, depth-1, width]
};
WriteRtn: PROC = {
put.PutRope["RETURNS "];
PrintType[rtnsType, put, depth-1, width];
};
put.PutRope[prefix];
argsType ← Domain[type];
IF argsType # nullType THEN {
put.PutChar[' ];
MakePiece[put, WriteArg];
};
SELECT class FROM
procedure, signal => {
rtnsType ← Range[type];
IF rtnsType # nullType THEN {
put.PutChar[' ];
MakePiece[put, WriteRtn];
};
};
ENDCASE;
};
enumerated => {
n: INT ← 0;
md: BOOL ← IsMachineDependent[type];
IF type = UnderBoolean THEN {put.PutRope["BOOL"]; RETURN};
IF IsMachineDependent[type] THEN put.PutRope["MACHINE DEPENDENT "];
put.PutRope["{"];
FOR i: INT IN [1..NValues[type]] DO
WriteElt: PROC = {
PrintTV.Print[Value[type, i], put];
};
IF i > 1 THEN {put.PutChar[', ]; put.PutChar[' ]};
IF i > width THEN {put.PutRope["..."]; EXIT};
now fetch and print the element (if possible)
MakePiece[put, WriteElt];
ENDLOOP;
put.PutRope["}"];
};
subrange => {
ENABLE Error => IF reason = rangeFault THEN {put.PutRope["0..0)"]; CONTINUE};
empty subrange causes First to raise a RangeFault.
IF verbose AND depth > 1 THEN PrintType[Ground[type], put, depth-1, width];
put.PutChar['[];
PrintTV.Print[First[type], put, depth, width];
put.PutRope[".."];
PrintTV.Print[Last[type], put, depth, width];
put.PutChar[']];
};
union =>
put.PutRope["UNION??"];
sequence => {
IF IsComputed[type] THEN put.PutRope["COMPUTED "];
IF IsPacked[type] THEN put.PutRope["PACKED "];
put.PutRope["SEQUENCE "];
PrintType[Domain[type], put, depth-1, width];
put.PutRope[" OF "];
PrintType[Range[type], put, depth-1, width];
};
record, structure => {
IF class = record THEN put.PutRope["RECORD"];
IF depth < 2 THEN {put.PutRope["[...]"]; RETURN};
put.PutChar['[];
PutInnards[type];
put.PutChar[']];
};
array => {
IF IsPacked[type] THEN put.PutRope["PACKED "];
put.PutRope["ARRAY "];
PrintType[Domain[type], put, depth-1, width];
put.PutRope[" OF "];
PrintType[Range[type], put, depth-1, width];
};
countedZone => put.PutRope["ZONE"];
uncountedZone => put.PutRope["UNCOUNTED ZONE"];
nil => put.PutRope["nullType"];
unspecified => put.PutRope["UNSPECIFIED"];
process => put.PutRope["PROCESS"];
type => put.PutRope["TYPE"];
opaque => put.PutRope["OPAQUE"];
any => put.PutRope["ANY"];
globalFrame => put.PutRope["GF??"];
localFrame => put.PutRope["LF??"];
ENDCASE => put.PutRope["??"];
};
msg: ROPE ← BackStop.Call[innerPut];
IF msg # NIL THEN
put.PutRope[Rope.Cat["--{", msg, "}--"]];
};
everybodyKnowsThese: LIST OF ROPELIST["INT", "REAL", "ROPE", "ATOM", "BOOL", "CHAR"];
Setup: PROC =
BEGIN
PrintTV.RegisterClassPrintProc[class: type, proc: PrettyPrintType];
END;
Setdown: PROC =
BEGIN
PrintTV.RegisterClassPrintProc[class: type, proc: NIL];
END;
Setup[];
END.
September 1, 1982 10:57 am fixed bug in PrintType so that LONG STRING would print correctly.
September 14, 1982 2:15 pm added 3.4 operations for IsPacked, IsMachineDependent, etc.
August 16, 1985 11:35:04 am PDT added everybodyKnowsThese check so that things like 3.2? didnt print out is of type REAL: TYPE = REAL
Spreitzer, August 16, 1985 11:27:22 am PDT
Moved from PrintTV>PrintTypeImpl.Mesa!2 of February 12, 1985 2:08:54 pm PST to PrettyPrint>PrettyTypePrinter. Added StructuredStreams bracketing in PutInner and listing of enumeration values.
changes to: DIRECTORY, PrintTypeImpl, PrintType, PutReadonly (local of PrintType), PutInnards (local of PrintType), innerPut (local of PrintType)