<> <> <> <> <> <> DIRECTORY AMBridge USING [TVForType], AMTypes USING [Class, Domain, Error, First, Ground, Index, IndexToDefaultInitialValue, IndexToName, IndexToType, Last, NComponents, NValues, Range, ReferentStatus, IsComputed, IsMachineDependent, IsOverlaid, IsPacked, TVToType, TypeClass, TypeToName, UnderType, UnderClass, Value, TV], 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]; PrintTypeImpl: CEDAR MONITOR IMPORTS AMBridge, AMTypes, BackStop, IO, Rope, SafeStorage, PrintTV EXPORTS PrintTV = BEGIN OPEN Rope, SafeStorage, AMTypes; UnderBoolean: Type _ LOOPHOLE[CODE[BOOL]]; PrintType: PUBLIC PROC [type: Type, put: IO.STREAM, depth: INT _ 4, width: INT _ 32, verbose: BOOL _ FALSE] = TRUSTED { tv: TV _ AMBridge.TVForType[type]; PrintTV.Print[tv, put, depth, width, verbose]; }; PrintTVForType: PROC [tv: TV, data: REF ANY, stream: IO.STREAM, depth: INT _ 4, width: INT _ 32, verbose: BOOL _ FALSE] RETURNS [useOld: BOOL _ FALSE] --PrintTV.TVPrintProc-- = { type: Type = TVToType[tv]; BasicPrintType[type, stream, depth, width, verbose]; }; BasicPrintType: PROC [type: Type, put: IO.STREAM, depth: INT _ 4, width: INT _ 32, verbose: BOOL _ FALSE] = { 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: 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; <

> 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], ": "]]; BasicPrintType[tagType, put, depth, width]; put.PutRope[" FROM "]; }; record, structure => {sep _ ": "; n _ AMTypes.NComponents[type]}; ENDCASE => {BasicPrintType[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 put.PutRope[Rope.Concat[name, sep]]; IF class = union THEN { <> put.PutRope["["]; PutInnards[subType, start]; put.PutRope["]"]; RETURN}; SELECT subClass FROM union => PutInnards[subType, i]; sequence => BasicPrintType[subType, put, depth, width]; ENDCASE => { defaultTV: TV _ NIL; BasicPrintType[subType, put, depth-1, width]; < LAST[CARDINAL]>> defaultTV _ IndexToDefaultInitialValue[type, i ! ANY => CONTINUE]; IF defaultTV # NIL THEN {put.PutRope[" _ "]; PrintTV.Print[defaultTV, put, depth, width, verbose]; }; }; }; msg: ROPE _ NIL; IF i > indexStart THEN put.PutRope[", "]; IF i > width AND i < n THEN {put.PutRope["..."]; EXIT}; msg _ BackStop.Call[subInner]; IF msg # NIL THEN put.PutRope[Rope.Cat["--{", msg, "}--"]]; 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 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 {put.PutRope[Rope.Cat[mod^, "."]]; EXIT}; REPEAT FINISHED => IF Rope.Equal[name, "LORA"] THEN { -- sorry Russ. BasicPrintType[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 = "]; BasicPrintType[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 "]; BasicPrintType[IndexToType[Range[type], 1], put, depth, width]; }; ref => { range: Type _ Range[type]; put.PutRope["REF "]; PutReadonly[type]; IF range # nullType THEN {BasicPrintType[range, put, depth, width]}; IF verbose THEN SELECT TypeClass[UnderType[range]] FROM record, structure => {put.PutRope["; \n"]; BasicPrintType[range, put, depth, width]; put.PutRope[": TYPE = "]; BasicPrintType[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; BasicPrintType[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]; BasicPrintType[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 => "??"; put.PutRope[prefix]; argsType _ Domain[type]; IF argsType # nullType THEN { put.PutChar[' ]; BasicPrintType[argsType, put, depth-1, width]}; SELECT class FROM procedure, signal => { rtnsType _ Range[type]; IF rtnsType # nullType THEN {put.PutRope[" RETURNS "]; BasicPrintType[rtnsType, put, depth-1, width]; }; }; 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 IF i > 1 THEN {put.PutChar[', ]; put.PutChar[' ]}; IF i > width THEN {put.PutRope["..."]; EXIT}; <> PrintTV.Print[Value[type, i], put]; ENDLOOP; put.PutRope["}"]; }; subrange => { ENABLE Error => IF reason = rangeFault THEN {put.PutRope["0..0)"]; CONTINUE}; <> IF verbose AND depth > 1 THEN BasicPrintType[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 "]; BasicPrintType[Domain[type], put, depth-1, width]; put.PutRope[" OF "]; BasicPrintType[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 "]; BasicPrintType[Domain[type], put, depth-1, width]; put.PutRope[" OF "]; BasicPrintType[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 ROPE _ LIST["INT", "REAL", "ROPE", "ATOM", "BOOL", "CHAR"]; PrintTV.RegisterClassPrintProc[class: type, proc: PrintTVForType]; 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 <> <> <> <<>>