DIRECTORY
AMTypes USING [TV, Type, nullType, Class],
AMBridge USING [TVForReadOnlyReferent, TVForROPE, TVForATOM],
IO USING [PutChar],
IOUtils USING [RegisterPrintRefAny, PrintRefAnyProc],
PrintTV USING [TVPrintProc, RefPrintProc, Print],
Rope USING [ROPE],
SafeStorage
USING [GetCanonicalType, GetReferentType];
PrintProcImpl:
CEDAR
MONITOR
-- protects printproc registries
IMPORTS AMBridge, IO, IOUtils, SafeStorage, PrintTV
EXPORTS PrintTV
= BEGIN OPEN AMTypes, PrintTV, SafeStorage;
tvPrintProcsEnabled: BOOL ← TRUE;
classPrintProcsEnabled: BOOL ← TRUE;
refPrintProcsEnabled:
BOOL ←
TRUE;
tvPrintProcList: TVPrintProcList ←
NIL;
TVPrintProcList: TYPE = LIST OF TVPrintProcListRecord;
TVPrintProcListRecord: TYPE = RECORD [type: Type, proc: TVPrintProc, data: REF];
classPrintProcList: ClassPrintProcList ←
NIL;
ClassPrintProcList: TYPE = LIST OF ClassPrintProcListRecord;
ClassPrintProcListRecord: TYPE = RECORD [class: Class, proc: TVPrintProc, data: REF];
refPrintProcList: RefPrintProcList ←
NIL;
RefPrintProcList: TYPE = LIST OF RefPrintProcListRecord;
RefPrintProcListRecord: TYPE = RECORD [type: Type, proc: RefPrintProc, data: REF];
RegisterTVPrintProc:
PUBLIC
ENTRY
PROC [type: Type, proc: TVPrintProc, data:
REF ←
NIL] = {
ENABLE UNWIND => NULL;
prev, new: TVPrintProcList ← NIL;
type ← GetCanonicalType[type];
FOR x: TVPrintProcList ← tvPrintProcList, x.rest
UNTIL x =
NIL
DO
IF
LOOPHOLE[x.first.type,
CARDINAL] =
LOOPHOLE[type,
CARDINAL]
THEN {
IF proc =
NIL
THEN {
-- splice it out
IF prev = NIL THEN tvPrintProcList ← x.rest ELSE prev.rest ← x.rest;
}
ELSE {--change bindings--x.first.proc ← proc; x.first.data ← data};
RETURN;
}
ELSE
IF
LOOPHOLE[x.first.type,
CARDINAL] >
LOOPHOLE[type,
CARDINAL]
THEN EXIT;
prev ← x;
ENDLOOP;
splice it in
new ← LIST[[type: type, proc: proc, data: data]];
IF prev =
NIL
THEN {
new.rest ← tvPrintProcList;
tvPrintProcList ← new}
ELSE {
new.rest ← prev.rest;
prev.rest ← new};
};
RegisterClassPrintProc:
PUBLIC
ENTRY
PROC [class: Class, proc: TVPrintProc, data:
REF ←
NIL] = {
ENABLE UNWIND => NULL;
prev, new: ClassPrintProcList ← NIL;
FOR x: ClassPrintProcList ← classPrintProcList, x.rest
UNTIL x =
NIL
DO
IF x.first.class = class
THEN {
IF proc =
NIL
THEN {
-- splice it out
IF prev = NIL THEN classPrintProcList ← x.rest ELSE prev.rest ← x.rest;
}
ELSE {--change bindings--x.first.proc ← proc; x.first.data ← data};
RETURN;
}
ELSE
IF
LOOPHOLE[x.first.class,
CARDINAL] >
LOOPHOLE[class,
CARDINAL]
THEN EXIT;
prev ← x;
ENDLOOP;
splice it in
new ← LIST[[class: class, proc: proc, data: data]];
IF prev =
NIL
THEN {
new.rest ← classPrintProcList;
classPrintProcList ← new}
ELSE {
new.rest ← prev.rest;
prev.rest ← new};
};
RegisterRefPrintProc:
PUBLIC
ENTRY
PROC [referentType: Type, proc: RefPrintProc, data:
REF ←
NIL] = {
ENABLE UNWIND => NULL;
prev, new: RefPrintProcList ← NIL;
type: Type ← GetCanonicalType[referentType];
FOR x: RefPrintProcList ← refPrintProcList, x.rest
UNTIL x =
NIL
DO
IF
LOOPHOLE[x.first.type,
CARDINAL] =
LOOPHOLE[type,
CARDINAL]
THEN {
IF proc =
NIL
THEN {
-- splice it out
IF prev = NIL THEN refPrintProcList ← x.rest ELSE prev.rest ← x.rest;
}
ELSE {--change bindings--x.first.proc ← proc; x.first.data ← data};
RETURN;
}
ELSE
IF
LOOPHOLE[x.first.type,
CARDINAL] >
LOOPHOLE[type,
CARDINAL]
THEN EXIT;
prev ← x;
ENDLOOP;
splice it in
new ← LIST[[type: type, proc: proc, data: data]];
IF prev =
NIL
THEN {
new.rest ← refPrintProcList;
refPrintProcList ← new}
ELSE {
new.rest ← prev.rest;
prev.rest ← new};
};
DisableTVPrintProcs:
PUBLIC
ENTRY
PROC
RETURNS [wasEnabled:
BOOL] = {
ENABLE UNWIND => NULL;
wasEnabled ← tvPrintProcsEnabled;
tvPrintProcsEnabled ← FALSE;
};
DisableClassPrintProcs:
PUBLIC
ENTRY
PROC
RETURNS [wasEnabled:
BOOL] = {
ENABLE UNWIND => NULL;
wasEnabled ← classPrintProcsEnabled;
classPrintProcsEnabled ← FALSE;
};
DisableRefPrintProc:
PUBLIC
ENTRY
PROC
RETURNS [wasEnabled:
BOOL] = {
ENABLE UNWIND => NULL;
wasEnabled ← refPrintProcsEnabled;
refPrintProcsEnabled ← FALSE;
};
EnableTVPrintProcs:
PUBLIC
ENTRY
PROC
RETURNS [wasEnabled:
BOOL] = {
ENABLE UNWIND => NULL;
wasEnabled ← classPrintProcsEnabled;
classPrintProcsEnabled ← TRUE;
};
EnableClassPrintProcs:
PUBLIC
ENTRY
PROC
RETURNS [wasEnabled:
BOOL] = {
ENABLE UNWIND => NULL;
wasEnabled ← tvPrintProcsEnabled;
tvPrintProcsEnabled ← TRUE;
};
EnableRefPrintProc:
PUBLIC
ENTRY
PROC
RETURNS [wasEnabled:
BOOL] = {
ENABLE UNWIND => NULL;
wasEnabled ← refPrintProcsEnabled;
refPrintProcsEnabled ← TRUE;
};
GetTVPrintProc:
PUBLIC
ENTRY
PROC [type: Type]
RETURNS [proc: TVPrintProc, data:
REF] = {
ENABLE UNWIND => NULL;
proc # NIL => print proc provided
x: TVPrintProcList;
IF NOT tvPrintProcsEnabled THEN RETURN [NIL, NIL];
type ← GetCanonicalType[type];
FOR x ← tvPrintProcList, x.rest
UNTIL x =
NIL
DO
IF x.first.type = type THEN RETURN [x.first.proc, x.first.data];
IF LOOPHOLE[x.first.type, CARDINAL] > LOOPHOLE[type, CARDINAL] THEN EXIT;
ENDLOOP;
RETURN [NIL, NIL];
};
GetClassPrintProc:
PUBLIC
ENTRY
PROC [class: Class]
RETURNS [proc: TVPrintProc, data:
REF] = {
ENABLE UNWIND => NULL;
proc # NIL => print proc provided
x: ClassPrintProcList;
IF NOT classPrintProcsEnabled THEN RETURN [NIL, NIL];
FOR x ← classPrintProcList, x.rest
UNTIL x =
NIL
DO
IF x.first.class = class THEN RETURN [x.first.proc, x.first.data];
IF LOOPHOLE[x.first.class, CARDINAL] > LOOPHOLE[class, CARDINAL] THEN EXIT;
ENDLOOP;
RETURN [NIL, NIL];
};
GetRefPrintProc:
PUBLIC
ENTRY
PROC [type: Type]
RETURNS [proc: RefPrintProc, data:
REF] = {
ENABLE UNWIND => NULL;
proc # NIL => print proc provided
x: RefPrintProcList;
IF NOT refPrintProcsEnabled THEN RETURN [NIL, NIL];
type ← GetCanonicalType[type];
FOR x ← refPrintProcList, x.rest
UNTIL x =
NIL
DO
IF x.first.type = type THEN RETURN [x.first.proc, x.first.data];
IF LOOPHOLE[x.first.type, CARDINAL] > LOOPHOLE[type, CARDINAL] THEN EXIT;
ENDLOOP;
RETURN [NIL, NIL];
};
NextTVPrintProc:
PUBLIC
ENTRY
PROC [after: Type ← nullType]
RETURNS [type: Type, proc: TVPrintProc, data:
REF] = {
provides a stateless enumerator for print procs
ENABLE UNWIND => NULL;
FOR x: TVPrintProcList ← tvPrintProcList, x.rest
UNTIL x =
NIL
DO
IF after = nullType
OR
LOOPHOLE[x.first.type,
CARDINAL] >
LOOPHOLE[after,
CARDINAL]
THEN RETURN [x.first.type, x.first.proc, x.first.data];
ENDLOOP;
RETURN [after, NIL, NIL];
};
NextClassPrintProc:
PUBLIC
ENTRY
PROC [after: Class ← nil]
RETURNS [class: Class, proc: TVPrintProc, data:
REF] = {
provides a stateless enumerator for print procs
ENABLE UNWIND => NULL;
FOR x: ClassPrintProcList ← classPrintProcList, x.rest
UNTIL x =
NIL
DO
IF after = nil
OR
LOOPHOLE[x.first.class,
CARDINAL] >
LOOPHOLE[after,
CARDINAL]
THEN RETURN [x.first.class, x.first.proc, x.first.data];
ENDLOOP;
RETURN [after, NIL, NIL];
};
NextRefPrintProc:
PUBLIC
ENTRY
PROC [after: Type ← nullType]
RETURNS [type: Type, proc: RefPrintProc, data:
REF] = {
provides a stateless enumerator for print procs
ENABLE UNWIND => NULL;
FOR x: RefPrintProcList ← refPrintProcList, x.rest
UNTIL x =
NIL
DO
IF after = nullType
OR
LOOPHOLE[x.first.type,
CARDINAL] >
LOOPHOLE[after,
CARDINAL]
THEN RETURN [x.first.type, x.first.proc, x.first.data];
ENDLOOP;
RETURN [after, NIL, NIL];
};
PrintRefAny: IOUtils.PrintRefAnyProc = {
PROC [stream: STREAM, refAny: REF READONLY ANY, depth: INT, width: INT, verbose: BOOL]
proc: RefPrintProc;
data: REF;
TRUSTED {
[proc: proc, data: data] ← GetRefPrintProc[GetReferentType[LOOPHOLE[refAny, REF]]];
};
IF proc =
NIL
OR proc[refAny, data, stream, depth, width, verbose].useOld
THEN {
tv: AMTypes.TV;
ra: REF ANY;
TRUSTED {
ra ←
LOOPHOLE[refAny];
so ROPE and ATOM arms will work (around compiler bug?)
WITH ra
SELECT
FROM
rope: Rope.ROPE => tv ← AMBridge.TVForROPE[rope];
atom: ATOM => tv ← AMBridge.TVForATOM[atom];
ENDCASE => {
IF ra # NIL THEN stream.PutChar['^];
tv ← AMBridge.TVForReadOnlyReferent[ref: refAny]}};
PrintTV.Print[tv: tv, put: stream, depth: depth, width: width, verbose: verbose];
};
};
START HERE
IOUtils.RegisterPrintRefAny[PrintRefAny];
END.