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[]; nameToMethod: SymTab.Ref _ SymTab.Create[]; methodToName: Methods; ooTable: ClassTable _ CreateClassTable[]; 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]; 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 }; objectCaches: LIST OF RefTab.Ref _ NIL; CreateObjectCache: PUBLIC PROC RETURNS [objectCache: ObjectCache] = { objectCache _ RefTab.Create[]; objectCaches _ CONS [objectCache, objectCaches]; }; FlushObjectCaches: PUBLIC PROC [object: Object] = { FOR caches: LIST OF RefTab.Ref _ objectCaches, caches.rest WHILE caches#NIL DO [] _ RefTab.Delete[caches.first, object]; ENDLOOP; }; Reverse: PUBLIC PROC [objects: Objects] RETURNS [Objects] = { RETURN [List.Reverse[objects]]; }; Add: PUBLIC PROC [objects: Objects, candidate: Object] RETURNS [Objects] ={ RETURN [IF Member[objects, candidate] THEN objects ELSE CONS [candidate, objects]]; }; Delete: PUBLIC PROC [objects: Objects, candidate: Object] RETURNS [Objects] ={ RETURN [IF Member[objects, candidate] THEN List.Remove[candidate, objects] ELSE objects]; }; Member: PUBLIC PROC [objects: Objects, candidate: Object] RETURNS [BOOL] = { RETURN [List.Memb[candidate, objects]]; }; Length: PUBLIC PROC [objects: Objects] RETURNS [INT] = {RETURN [List.Length[objects]]}; Sort: PUBLIC PROC [objects: Objects, compare: CompareProc] RETURNS [Objects] = { Compare: List.CompareProc = {RETURN [compare[ref1, ref2]]}; RETURN [List.Sort[objects, Compare]]; }; AlwaysTrue: PUBLIC PROC [Object] RETURNS [BOOL] = {RETURN [TRUE]}; AlwaysFalse: PUBLIC PROC [Object] RETURNS [BOOL] = {RETURN [FALSE]}; CreateClassTable: PUBLIC PROC RETURNS [table: ClassTable] = { table _ NEW [ClassTableRec]; }; StoreInClassTable: PUBLIC PROC [table: ClassTable, class: Class, value: REF] = { table[class] _ value; }; FetchFromClassTable: PUBLIC PROC [table: ClassTable, class: Class] RETURNS [value: REF _ NIL] = { value _ table[class]; }; nameMethodName: ROPE _ "Name"; methodToName _ NEW [MethodsRec[1]]; methodToName[nameMethod] _ nameMethodName; [] _ SymTab.Store[nameToMethod, nameMethodName, NEW [Method _ nameMethod]]; overlayClass _ RegisterClass[name: "Overlay", type: CODE [OverlayRec]]; iconClass _ RegisterClass[name: "Icon", type: CODE [IconRec]]; annotationClass _ RegisterClass[name: "Annotation", type: CODE [AnnotationRec]]; hashMethod _ RegisterMethod["Hash"]; PutClassMethod[annotationClass, hashMethod, NEW [HashProc _ HashAnnotation]]; equalMethod _ RegisterMethod["Equal"]; PutClassMethod[annotationClass, equalMethod, NEW [EqualProc _ EqualAnnotation]]; describeMethod _ RegisterMethod["Describe"]; PutClassMethod[overlayClass, describeMethod, NEW [DescribeProc _ DescribeOverlay]]; PutClassMethod[iconClass, describeMethod, NEW [DescribeProc _ DescribeIcon]]; PutClassMethod[annotationClass, describeMethod, NEW [DescribeProc _ DescribeAnnotation]]; END. สPipalImpl.mesa Copyright ำ 1988 by Xerox Corporation. All rights reserved. Louis Monier January 15, 1988 8:46:10 pm PST Bertrand Serlet May 19, 1988 6:14:38 pm PDT Barth, January 28, 1988 4:20:51 pm PST Errors Classes and Methods The table of name -> REF class The table of name -> REF method The table of method -> name The table of class -> methods If a sequence of methods is NIL, the type has not been registered; otherwise, it has at least the nameMethod. global; used for allocating new methods; nameMethod is always defined Trying to register the same class under two different names previous registration with same name (same type or not): legal Objects Overlay records calls to create overlay for list of length<256. records calls to create overlay for list of length>=256. Index i corresponds to count for length/256. Icon Annotation Hash Equal Describe Utilities Object Caches Operations on objects Objects Predicates Class Tables Initialization ส– "cedar" style˜codešœ™Kšœ<™™>Kšœ1œ ˜@—KšŸF˜FKšœ%œ˜:Kšœ œ˜&Kšœ+˜+Kšœ˜Kšœ˜K˜—š žœœœœœœ˜KKšœœœ˜šžœœœ˜9Kšœœ˜$KšœœœŸ˜;Kšœ œœœ˜AKšœ˜K˜—Kšœœ˜ Kšœœ˜ Kšœ1˜1šœœŸ<˜MKšœ œœ ˜#Kšœ3œ ˜Bšœœ˜9Kšœœ&˜?Kšœ œœœ˜*Kšœ˜—Kšœœ˜K˜—KšœŸ6˜KKšœ&œ˜=Kšœ$˜$Kšœ˜šœœ˜9Kšœœ&˜?Kšœ œœ3˜FKšœ˜—Kšœ˜K˜K˜—š ž œœœœœ˜>Kšœœ'˜@Kš œ œœœœŸ˜:Jšœœ˜$Jšœ˜J˜—š ž œœœœœ˜AKšœœœœ˜'Jšœœ˜%Jšœ˜J˜—šžœœœ&œ˜IKšœœ'˜@KšœœœŸ˜:Kš œ œœœŸ˜3Jš œœœAœœ˜”Jšœ˜Jšœ˜K™—š žœœœ œœœ˜XKšœœ'˜@KšœœœŸ˜:Kš œ œœœŸ˜3Jšœ˜Jšœ˜——™šž œœœœ˜DKšœœœœ˜Kšœ,˜,Jšœ˜J˜—š ž œœœ"œœœ˜XJšœ3˜3Jšœ˜——™šœœ˜K˜—šœœ œ˜+K˜—Kš œ œœ œœœ˜4šœ œ œ ˜*Kšœ7™7—šœ œ œ ˜,Kšœ8™8K™,K˜—šžœ˜!Kšœœ ˜#Jšœ˜Jšœ˜Kšœ œœœ˜1šœœœ˜$Kšœ1˜1Kšœ˜ —K˜K˜—šž œœœœ˜MKšœœ˜šœ ˜ Kšœ%˜)Kšœ1˜5—Kšœœœ˜Kšœ œ˜!Jš œœœ œ7œ˜[K˜K˜—šžœœœœ ˜>Jšœœ˜šœ œ˜Jšœœ œ˜EJšœ˜Jšœ˜—Jšœœ œœœœœ˜\K˜K˜—š ž œœœœœ˜QKšœœ ˜"š œœ œœ˜/Jšœ œ˜&Jšœ˜—K˜K˜——™šœ œ˜K˜—šž œ˜Kšœ œ ˜Jšœ˜Jšœ,˜.Kšœ5˜5Kšœ4˜4K˜K˜—šž œœœ'œ˜VKšœœ8˜BK˜K˜——™ šœœ˜K˜—šœ  œ˜#K˜—šžœ˜Kšœœ ˜)Kšœ2œœ˜UK˜K˜—šžœ˜Kšœœ ˜+Kšœœ ˜+Kšœ(œ%œ.Ÿ-˜ฎK˜K˜—šžœ˜$Kšœœ ˜)Jšœ˜šœœ˜!Jšœ œœœ˜9J˜—Jšœ'œœ˜_Kšœ7˜7K˜K˜—š žœœœœ œœ˜iKšœ œ:˜JK˜K˜——šœ™šœ œ˜K˜—šžœœ ˜Kšœœ$˜-Kš œœœœœœ œ˜WK˜K˜—šžœœ ˜$Kšœ&˜&K˜K˜—šž œ œœœ˜>Kšœ+˜+K˜——šœ™šœ œ˜K˜—šžœœ˜Kšœœœœ˜&Kšœ+œœœ˜AKšœœœœ˜3š˜Kšœœ&˜/Kš œœœœœ˜ Kšœœœ!˜;Kšœ˜—K˜——šœ™šœœ˜K˜—šžœœ˜!Kšœ œœœ˜1Kš œœœœAŸ˜tKš œœœœœ˜Pšœœ˜˜Jšœ˜Jšœœ˜7šœ œ˜Jšœ4˜4Jšœ˜Jšœ˜—J˜—˜šžœ˜#Jšœ˜Jš œœ œœ œ ˜MKšœœ˜ K˜—Jšœ˜Jšœ˜Kšœ#˜#K˜—˜šžœ˜#Kšœœ˜ Jšœ˜Kšœœ˜ K˜—Jšœ˜Jšœ˜Kšœ#˜#K˜—šœ˜ Kšœœ(˜1šœœ˜ Kšœœœ2œ˜R—Jšœ˜Kšœ.˜0Jšœ˜——K˜K˜—šžœœœœ œ œœœœ˜rKš œœœœœ˜Kšœ)˜)Kšœœ˜K˜K˜—šž œœœœœ œœœ˜IKš œœœœœ˜"Kš œœœœœ˜Kšœ:œ˜PK˜šœ$˜$K˜—šœ,œ˜MK˜—šœ&˜&K˜—šœ-œ ˜PK˜—šœ,˜,K˜—Kšœ-œ#˜SKšœ*œ ˜MKšœ0œ&˜Y™K™——K˜Kšœ˜K˜—…—.เBฦ