<> <> <> DIRECTORY AMTypes USING [Class, Domain, Error, First, Ground, Index, IndexToDefaultInitialValue, IndexToName, IndexToType, Last, NComponents, NValues, Range, ReferentStatus, IsComputed, IsMachineDependent, IsOverlaid, IsOrdered, IsPacked, TypeClass, TypeToName, UnderType, UnderClass, Value], PrintTV USING [Mother, Print, PutClosure, PutProc], Rope USING [Fetch, Map, ROPE, Equal, Length, IsEmpty], RTBasic USING [nullType, TV, Type], RTTypesBasic USING [EquivalentTypes] ; PrintTypeImpl: CEDAR MONITOR IMPORTS AMTypes, Rope, RTTypesBasic, PrintTV EXPORTS PrintTV = BEGIN OPEN PrintTV, Rope, RTBasic, AMTypes; UnderBoolean: Type _ LOOPHOLE[CODE[BOOL]]; PrintType: PUBLIC PROC [type: Type, put: PutClosure, depth: INT _ 4, width: INT _ 32, verbose: BOOL _ FALSE] = { putproc: PutProc = put.proc; putdata: REF = put.data; PutChar: PROC [c: CHAR] = { putproc[putdata, c] }; PutCharB: PROC [c: CHAR] RETURNS [BOOL] = { PutChar[c]; RETURN [FALSE] }; PutRope: PROC [r: ROPE] = { [] _ Rope.Map[base: r, action: PutCharB] }; PutMD: PROC [t: Type] = { IF IsMachineDependent[t] THEN PutRope["MACHINE DEPENDENT "]; }; PutPacked: PROC [t: Type] = { IF IsPacked[t] THEN PutRope["PACKED "]; }; PutReadonly: PROC [t: Type] = { IF ReferentStatus[t] = readOnly THEN PutRope["READONLY "]; }; PutComputed: PROC [t: Type] = { IF IsComputed[t] THEN PutRope["COMPUTED "]; }; PutOverlaid: PROC [t: Type] = { IF IsOverlaid[t] THEN PutRope["OVERLAID "]; }; PutOrdered: PROC [t: Type] = { IF IsOrdered[t] THEN PutRope["ORDERED "]; }; PutRopes: PROC [r1,r2,r3,r4,r5,r6: ROPE _ NIL] = { [] _ Rope.Map[base: r1, action: PutCharB]; [] _ Rope.Map[base: r2, action: PutCharB]; [] _ Rope.Map[base: r3, action: PutCharB]; [] _ Rope.Map[base: r4, action: PutCharB]; [] _ Rope.Map[base: r5, action: PutCharB]; [] _ Rope.Map[base: r6, action: PutCharB]; }; PutInnards: PROC [type: Type, start: INT _ 1] = { n: INT _ 0; class: Class _ TypeClass[type]; indexStart: NAT _ start; sep: ROPE _ NIL; SELECT class FROM union => { NCases: PROC [type: Type] RETURNS [n: INT] = { <> 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; <

> PutRope["SELECT "]; tagType _ AMTypes.Domain[type]; n _ NCases[type]; IF IsOverlaid[type] THEN PutOverlaid[type] ELSE PutRopes[AMTypes.IndexToName[type, 0], ": "]; PrintType[tagType, put, depth, width]; PutRopes[" 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; subInner: PROC = { name: ROPE _ IndexToName[type, i]; subType _ IndexToType[type, i]; subClass _ TypeClass[subType]; IF NOT name.IsEmpty[] THEN PutRopes[name, sep]; IF class = union THEN {-- the subType must be a record or structure <> PutRope["["]; PutInnards[subType, start]; PutRope["]"]; RETURN}; SELECT subClass FROM union => PutInnards[subType, i]; sequence => PrintType[subType, put, depth, width]; ENDCASE => {defaultTV: TV _ NIL; PrintType[subType, put, depth-1, width]; < LAST[CARDINAL]>> defaultTV _ IndexToDefaultInitialValue[type, i ! ANY => CONTINUE]; IF defaultTV # NIL THEN {PutRope[" _ "]; PrintTV.Print[defaultTV, put, depth, width, verbose]; }; }; }; msg: ROPE _ NIL; IF i > indexStart THEN PutRope[", "]; IF i > width AND i < n THEN {PutRope["..."]; EXIT}; msg _ Mother[subInner]; IF msg # NIL THEN PutRopes["--{", msg, "}--"]; ENDLOOP; IF class = union THEN PutRope[" ENDCASE"]; }; class: Class _ nil; innerPut: PROC = { IF depth <= 0 THEN {PutRope["..."]; RETURN}; class _ TypeClass[type]; SELECT class FROM definition => {mod: REF ROPE _ NEW[ROPE _ NIL]; 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 {PutRopes[mod^, "."]; EXIT}; REPEAT FINISHED => IF Rope.Equal[name, "LORA"] THEN { -- sorry Russ. PrintType[UnderType[type], put, depth, width, verbose]; RETURN; }; ENDLOOP; 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 => {PutRope[": TYPE = "]; PrintType[UnderType[type], put, depth, width, verbose]; }; ENDLOOP; }; cardinal => PutRope["CARDINAL"]; longCardinal => PutRope["LONG CARDINAL"]; integer => PutRope["INTEGER"]; longInteger => PutRope["INT"]; real => PutRope["REAL"]; character => PutRope["CHAR"]; atom => PutRope["ATOM"]; rope => PutRope["ROPE"]; list => {PutRope["LIST OF "]; PrintType[IndexToType[Range[type], 1], put, depth, width]; }; ref => {range: Type _ Range[type]; PutRope["REF "]; PutReadonly[type]; IF range # nullType -- AND TypeClass[range] # any -- THEN {PrintType[range, put, depth, width]}; IF verbose THEN SELECT TypeClass[UnderType[range]] FROM record, structure => {PutRope["; \n"]; PrintType[range, put, depth, width]; PutRope[": TYPE = "]; PrintType[UnderType[range], put, depth, width]}; ENDCASE; }; pointer, longPointer, basePointer, relativePointer => {range: Type _ Range[type]; SELECT class FROM longPointer => PutRope["LONG "]; relativePointer => PutRope["RELATIVE "]; basePointer => PutRope["LONG BASE "]; ENDCASE; SELECT TRUE FROM range = nullType OR TypeClass[range] = unspecified => PutRope["POINTER"]; RTTypesBasic.EquivalentTypes[range, CODE[StringBody]] => PutRope["STRING"]; ENDCASE => {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 PutRope["LONG "]; PutRope["DESCRIPTOR"]; range _ Range[type]; IF range # nullType AND TypeClass[range] # unspecified THEN {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 => "??"; PutRope[prefix]; argsType _ Domain[type]; IF argsType # nullType THEN {PutChar[' ]; PrintType[argsType, put, depth-1, width]}; SELECT class FROM procedure, signal => {rtnsType _ Range[type]; IF rtnsType # nullType THEN {PutRope[" RETURNS "]; PrintType[rtnsType, put, depth-1, width]; }; }; ENDCASE; }; enumerated => {n: INT _ 0; md: BOOL _ IsMachineDependent[type]; IF type = UnderBoolean THEN {PutRope["BOOL"]; RETURN}; PutMD[type]; PutRope["{"]; FOR i: INT IN [1..NValues[type]] DO IF i > 1 THEN {PutChar[', ]; PutChar[' ]}; IF i > width THEN {PutRope["..."]; EXIT}; <> {elem: TV _ Value[type, i]; PrintTV.Print[elem, put]; }; ENDLOOP; PutRope["}"]; }; subrange => {ENABLE Error => IF reason = rangeFault THEN {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]; PutChar['[]; PrintTV.Print[First[type], put, depth, width]; PutRope[".."]; PrintTV.Print[Last[type], put, depth, width]; PutChar[']]; }; union => {PutRope["UNION??"]; }; sequence => {PutComputed[type]; PutPacked[type]; PutRope["SEQUENCE "]; PrintType[Domain[type], put, depth-1, width]; PutRope[" OF "]; PrintType[Range[type], put, depth-1, width]; }; record, structure => {IF class = record THEN PutRope["RECORD"]; IF depth < 2 THEN {PutRope["[...]"]; RETURN}; PutChar['[]; PutInnards[type]; PutChar[']]; }; array => {PutPacked[type]; PutRope["ARRAY "]; PrintType[Domain[type], put, depth-1, width]; PutRope[" OF "]; PrintType[Range[type], put, depth-1, width]; }; countedZone => PutRope["ZONE"]; uncountedZone => PutRope["UNCOUNTED ZONE"]; nil => PutRope["nullType"]; unspecified => PutRope["UNSPECIFIED"]; process => PutRope["PROCESS"]; type => PutRope["TYPE"]; opaque => PutRope["OPAQUE"]; any => PutRope["ANY"]; globalFrame => PutRope["GF??"]; localFrame => PutRope["LF??"]; ENDCASE => PutRope["??"]; }; msg: ROPE _ Mother[innerPut]; IF msg # NIL THEN PutRopes["--{", msg, "}--"]; }; everybodyKnowsThese: LIST OF ROPE _ LIST["INT", "REAL", "ROPE", "ATOM", "BOOL", "CHAR"]; 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. December 30, 1982 11:39 am added everybodyKnowsThese check so that things like 3.2? didnt print out is of type REAL: TYPE = REAL