<> <> <> <> <> <<>> DIRECTORY Basics, Commander, IO, List, Pipal, ProcessProps, RefTab, Rope, RopeHash, SafeStorage, SymTab, TerminalIO; PipalImpl: CEDAR MONITOR IMPORTS IO, List, ProcessProps, RefTab, Rope, RopeHash, SafeStorage, SymTab, TerminalIO EXPORTS Pipal = BEGIN OPEN Pipal; <> Error: PUBLIC SIGNAL [reason: ATOM _ $Client, message: ROPE _ NIL, data: REF ANY _ NIL] = CODE; <> Methods: TYPE = REF MethodsRec; MethodsRec: TYPE = RECORD [SEQUENCE nbMethods: NAT OF REF]; nameToClass: SymTab.Ref _ SymTab.Create[]; < REF class>> nameToMethod: SymTab.Ref _ SymTab.Create[]; < REF method>> methodToName: Methods; < name>> ooTable: ClassTable _ CreateClassTable[]; < methods>> <> nbMethods: NAT _ 1; <> nameMethod: Method = 0; -- from class to name RegisterClass: PUBLIC ENTRY PROC [name: ROPE, type: SafeStorage.Type] RETURNS [class: Class] ~ { ENABLE UNWIND => NULL; found: BOOL; ref: REF; methods: Methods _ NARROW [FetchFromClassTable[ooTable, type]]; class _ type; IF methods#NIL THEN { -- type already used IF NOT Rope.Equal[NARROW [methods[nameMethod], ROPE], name] THEN ERROR; <> }; [found, ref] _ SymTab.Fetch[nameToClass, name]; IF found THEN <> TerminalIO.PutF["Re-registration of class %g\n", IO.rope[name]]; -- at this point, we can assume that the class has not been registered [] _ SymTab.Store[nameToClass, name, NEW [Class _ class]]; methods _ NEW [MethodsRec[nbMethods]]; StoreInClassTable[ooTable, class, methods]; methods[nameMethod] _ name; }; RegisterMethod: PUBLIC ENTRY PROC [name: ROPE] RETURNS [method: Method] ~ { ENABLE UNWIND => NULL; Extend: PROC [methods: Methods] RETURNS [new: Methods]~ { new _ NEW [MethodsRec[nbMethods+1]]; IF methods.nbMethods#nbMethods THEN ERROR; -- sanity check FOR i: Method IN [0 .. nbMethods) DO new[i] _ methods[i] ENDLOOP; methods _ new; }; found: BOOL; ref: REF; [found, ref] _ SymTab.Fetch[nameToMethod, name]; IF found THEN { -- Double registration under the same name: destroy old data method _ NARROW [ref, REF Method]^; TerminalIO.PutF["Re-registration of method %g.\n", IO.rope[name]]; FOR ii: SafeStorage.TypeIndex IN SafeStorage.TypeIndex DO methods: Methods _ NARROW [FetchFromClassTable[ooTable, [ii]]]; IF methods#NIL THEN methods[method] _ NIL; ENDLOOP; methodToName[method] _ NIL; }; method _ nbMethods; -- always allocate a new method (think of caches, ...) [] _ SymTab.Store[nameToMethod, name, NEW [Method _ method]]; methodToName _ Extend[methodToName]; methodToName[method] _ name; FOR ii: SafeStorage.TypeIndex IN SafeStorage.TypeIndex DO methods: Methods _ NARROW [FetchFromClassTable[ooTable, [ii]]]; IF methods#NIL THEN StoreInClassTable[ooTable, [ii], Extend[methods]]; ENDLOOP; nbMethods _ nbMethods+1; }; ClassName: PUBLIC PROC [class: Class] RETURNS [name: ROPE] ~ { methods: Methods _ NARROW [FetchFromClassTable[ooTable, class]]; IF methods=NIL THEN RETURN [NIL]; -- class not registered name _ NARROW [methods[nameMethod]]; }; MethodName: PUBLIC PROC [method: Method] RETURNS [name: ROPE] ~ { IF method>=nbMethods THEN RETURN [NIL]; name _ NARROW [methodToName[method]]; }; PutClassMethod: PUBLIC PROC [class: Class, method: Method, data: REF] ~ { methods: Methods _ NARROW [FetchFromClassTable[ooTable, class]]; IF method>=nbMethods THEN ERROR; -- method not registered IF methods=NIL THEN ERROR; -- class not registered IF methods[method]#NIL THEN TerminalIO.PutF["Re-registration of method %g for class %g.\n", IO.rope[MethodName[method]], IO.rope[ClassName[class]]]; methods[method] _ data; }; <<>> GetClassMethod: PUBLIC PROC [class: Class, method: Method] RETURNS [data: REF _ NIL] ~ { methods: Methods _ NARROW [FetchFromClassTable[ooTable, class]]; IF method>=nbMethods THEN ERROR; -- method not registered IF methods=NIL THEN ERROR; -- class not registered data _ methods[method]; }; <> ObjectClass: PUBLIC PROC [object: Object] RETURNS [class: Class] ~ { IF object=NIL THEN ERROR; class _ SafeStorage.GetReferentType[object]; }; ObjectMethod: PUBLIC PROC [object: Object, method: Method] RETURNS [data: REF _ NIL] ~ { data _ GetClassMethod[ObjectClass[object], method]; }; <> overlayClass: PUBLIC Class; void: PUBLIC Overlay = NEW [OverlayRec[0]]; StatArray: TYPE = ARRAY [0 .. 256) OF INT _ ALL [0]; stats256: REF StatArray _ NEW [StatArray]; <> stats65536: REF StatArray _ NEW [StatArray]; <=256.>> <> DescribeOverlay: DescribeProc = { overlay: Overlay _ NARROW [object]; PutIndent[out, indent, cr]; IO.PutF[out, "Overlay of: "]; IF level=1 THEN {IO.PutRope[out, "..."]; RETURN}; FOR i: NAT IN [0 .. overlay.size) DO Describe[out, overlay[i], indent+1, level-1, cr]; ENDLOOP; }; CreateOverlay: PUBLIC PROC [children: Objects] RETURNS [overlay: Overlay] ~ { size: NAT _ Length[children]; IF size<256 THEN stats256[size] _ stats256[size] + 1 ELSE stats65536[size/256] _ stats65536[size/256] + 1; IF size=0 THEN RETURN [void]; overlay _ NEW [OverlayRec[size]]; FOR i: NAT IN [0 .. size) DO overlay[i] _ children.first; children _ children.rest ENDLOOP; }; CreateOv: PUBLIC PROC [children: Objects] RETURNS [Object] ~ { nonVoid: Objects _ NIL; WHILE children#NIL DO IF children.first#void THEN nonVoid _ CONS [children.first, nonVoid]; children _ children.rest; ENDLOOP; RETURN [IF nonVoid#NIL AND nonVoid.rest=NIL THEN nonVoid.first ELSE CreateOverlay[nonVoid]]; }; ExpandOverlay: PUBLIC PROC [object: Object] RETURNS [children: Objects _ NIL] = { overlay: Overlay _ NARROW[object]; FOR i: NAT DECREASING IN [0 .. overlay.size) DO children _ CONS[overlay[i], children]; ENDLOOP; }; <> iconClass: PUBLIC Class; DescribeIcon: DescribeProc = { icon: Icon _ NARROW [object]; PutIndent[out, indent, cr]; IO.PutF[out, "Icon of (reference/referent):"]; Describe[out, icon.reference, indent+1, level-1, cr]; Describe[out, icon.referent, indent+1, level-1, cr]; }; CreateIcon: PUBLIC PROC [reference: Object, referent: Object] RETURNS [icon: Icon] = { icon _ NEW [IconRec _ [reference: reference, referent: referent]]; }; <> annotationClass: PUBLIC Class; nameProp: PUBLIC ATOM _ $PipalName; HashAnnotation: HashProc = { annotation: Annotation _ NARROW [object]; hash _ Hash[annotation.child] + RopeHash.FromRope[IO.PutR1[IO.atom[annotation.key]]]; }; EqualAnnotation: EqualProc = { annotation1: Annotation _ NARROW [object1]; annotation2: Annotation _ NARROW [object2]; equal _ annotation1.key=annotation2.key AND annotation1.value=annotation2.value AND Equal[annotation1.child, annotation2.child]; -- could be more fancy fore comparing values! }; DescribeAnnotation: DescribeProc = { annotation: Annotation _ NARROW [object]; PutIndent[out, indent, cr]; IF annotation.key=nameProp THEN { IO.Put1[out, IO.rope[NARROW [annotation.value]]]; RETURN; }; IO.PutF[out, "Annotation (%g: %g) of :", IO.atom[annotation.key], IO.refAny[annotation.value]]; Describe[out, annotation.child, indent+1, level-1, cr]; }; CreateAnnotation: PUBLIC PROC [child: Object, key: ATOM, value: REF] RETURNS [annotation: Annotation] = { annotation _ NEW [AnnotationRec _ [child: child, key: key, value: value]]; }; <> hashMethod: PUBLIC Method; Hash: PUBLIC HashProc = { data: REF _ ObjectMethod[object, hashMethod]; hash _ (IF data#NIL THEN (NARROW [data, REF HashProc]^) ELSE HashObjectClass) [object]; }; HashObjectClass: PUBLIC HashProc = { hash _ HashClass[ObjectClass[object]]; }; HashClass: PUBLIC PROC [class: Class] RETURNS [hash: CARD] = { hash _ RopeHash.FromRope[ClassName[class]]; }; <> equalMethod: PUBLIC Method; Equal: PUBLIC EqualProc = { IF object1=object2 THEN RETURN [TRUE]; IF ObjectClass[object1]#ObjectClass[object2] THEN RETURN [FALSE]; IF Hash[object1]#Hash[object2] THEN RETURN [FALSE]; BEGIN data: REF _ ObjectMethod[object1, equalMethod]; IF data=NIL THEN RETURN [FALSE]; RETURN [(NARROW [data, REF EqualProc]^)[object1, object2]]; END; }; <> describeMethod: PUBLIC Method; Describe: PUBLIC DescribeProc = { IF level=0 THEN {IO.PutRope[out, "..."]; RETURN}; IF out=NIL THEN out _ NARROW [ProcessProps.GetProp[$CommanderHandle], Commander.Handle].out; -- hack, hack, hack ... IF object=NIL THEN {PutIndent[out, indent, cr]; IO.PutRope[out, "NIL"]; RETURN}; WITH object SELECT FROM objects: Objects => { PutIndent[out, indent, cr]; IO.PutF[out, "List [%g] of:", IO.int[Length[objects]]]; WHILE objects#NIL DO Describe[out, objects.first, indent+1, level-1, cr]; objects _ objects.rest; ENDLOOP; }; table: SymTab.Ref => { EachItem: SymTab.EachPairAction ~ { PutIndent[out, indent, cr]; IO.PutF[out, "%l%g%l : ", IO.rope["b"], IO.rope[NARROW [key]], IO.rope["B"]]; Describe[out, val, 0, 1, FALSE]; }; PutIndent[out, indent, cr]; IO.PutF[out, "SymTab of:"]; [] _ SymTab.Pairs[table, EachItem]; }; table: RefTab.Ref => { EachItem: RefTab.EachPairAction ~ { Describe[out, key, 0, 1, FALSE]; IO.PutRope[out, " : "]; Describe[out, val, 0, 1, FALSE]; }; PutIndent[out, indent, cr]; IO.PutF[out, "RefTab of:"]; [] _ RefTab.Pairs[table, EachItem]; }; ENDCASE => { data: REF _ ObjectMethod[object, describeMethod]; IF data#NIL THEN {(NARROW [data, REF DescribeProc]^)[out, object, indent, level, cr]; RETURN}; PutIndent[out, indent, cr]; IO.PutRope[out, ClassName[ObjectClass[object]]]; }; }; DescribeToRope: PUBLIC PROC [object: Object, indent: NAT _ 0, level: NAT _ 1, cr: BOOL _ FALSE] RETURNS [ROPE] = { out: IO.STREAM = IO.ROS[]; Describe[out, object, indent, level, cr]; RETURN [IO.RopeFromROS[out]]; }; PutIndent: PUBLIC PROC [out: IO.STREAM, indent: NAT, cr: BOOL _ TRUE] = { IF cr THEN IO.PutChar[out, IO.CR]; FOR i: NAT IN [0 .. indent) DO IO.PutRope[out, " "] ENDLOOP }; <> <