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 {  -- previous registration with same name (same type or not): legal
oldClass: Class _ NARROW [ref, REF Class]^;
TerminalIO.PutF["Re-registration of class %g\n", IO.rope[name]];
FOR i: Method IN [ 0.. nbMethods) DO
PutClassMethod[oldClass, i, NIL];  -- any data attached to old registration is lost
ENDLOOP;
};
-- 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 0:39:05 am 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

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



สO–

"cedar" style˜
codeš
œ™Kš
œ<™<Kšœ)ฯk™,Kš
œ+™+Kšœ#™&K™—š
	˜	KšœœU˜j—K˜•StartOfExpansion[]šฯn	œœ
˜Kšœ
œM˜WKšœ˜Kšœ
œ˜—
head™Kšžœœ
œ
œœœœ
œœœ
˜_—™Kšœ	œœ˜Kš
œœœœœ
œ
œ˜;K˜š
œ*˜*Kšœœ™—š
œ+˜+Kšœœ™—š
œ˜Kš
œ™—š
œ)˜)K™KšœœN™m—šœœ˜Kš
œE™E—Kšœฯc˜.K˜šž
œœ
œ
œœœ˜`Kšœ
œœ
˜Kšœœ
˜Kšœœ
˜	Kšœœ&˜?Kš
œ
˜
šœ	œ
œŸ˜+šœ
œœœ	œ
œ
˜GKš
œ;™;—Kš
œ˜—Kš
œ/˜/šœœŸA˜RKšœœœ	˜+Kšœ1œ
˜@šœœ˜$KšœœŸ0˜SKšœ
˜—K˜—Kš
ŸF˜FKšœ%œ˜:Kšœ
œ˜&Kš
œ+˜+Kš
œ˜Kš
œ˜K˜—šžœœ
œ
œœœ˜KKšœ
œœ
˜šžœœœ˜9Kšœœ˜$Kšœœ
œŸ˜;Kšœœœœ
˜AKš
œ˜K˜—Kšœœ
˜Kšœœ
˜	Kš
œ1˜1šœœŸ<˜MKšœ	œœ
˜#Kšœ2œ
˜Ašœœ˜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˜K˜——™	™
šœœ
œœ
˜'J˜—šžœœ
œ
œ˜EJš
œ˜Jšœœ˜0J˜J˜—šžœœ
œ˜3šœ	œ
œ(œœ
˜NKš
œ)˜)Kšœ
˜—J˜J˜——™šžœœ
œœ˜=Kšœ˜K˜—šžœœ
œ'œ
˜KKš
œœœ	œ
œ˜SK˜—šžœœ
œ'œ
˜NKšœœœ!œ
˜YK˜—š
žœœ
œ'œœ˜LKšœ!˜'K˜—Jšžœœ
œœœœ˜Wšžœœ*œ˜PKšžœœ˜;Kšœ˜%K˜——™Kšž
œœ
œ
œœœœ˜BKšžœœ
œ
œœœœ˜D—™šžœœ
œ˜=Jšœœ˜J˜J˜—šžœœ*œ˜PJš
œ˜J˜J˜—š
žœœ#œ	œœ˜aJš
œ˜J˜———™Kšœœ
˜Kšœœ˜#Kš
œ*˜*Kšœ0œ˜KK™Kšœ4œ˜GKšœ.œ˜>Kšœ:œ˜PK˜š
œ$˜$K˜—šœ,œ˜MK˜—š
œ&˜&K˜—šœ-œ ˜PK˜—š
œ,˜,K˜—Kšœ-œ#˜SKšœ*œ ˜MKšœ0œ&˜Y™K™——K˜Kšœ
˜K˜—…—/ิCญ