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
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;
Errors
Error: PUBLIC SIGNAL [reason: ATOM ← $Client, message: ROPE ← NIL, data: REF ANY ← NIL] = CODE;
Classes and Methods
Methods: TYPE = REF MethodsRec;
MethodsRec: TYPE = RECORD [SEQUENCE nbMethods: NAT OF REF];
nameToClass: SymTab.Ref ← SymTab.Create[];
The table of name -> REF class
nameToMethod: SymTab.Ref ← SymTab.Create[];
The table of name -> REF method
methodToName: Methods;
The table of method -> name
ooTable: ClassTable ← CreateClassTable[];
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.
nbMethods: NAT ← 1;
global; used for allocating new methods; nameMethod is always defined
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;
Trying to register the same class under two different names
};
[found, ref] ← SymTab.Fetch[nameToClass, name];
IF found THEN
previous registration with same name (same type or not): legal
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];
};
Objects
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];
};
Overlay
overlayClass: PUBLIC Class;
void: PUBLIC Overlay = NEW [OverlayRec[0]];
StatArray: TYPE = ARRAY [0 .. 256) OF INT ← ALL [0];
stats256: REF StatArray ← NEW [StatArray];
records calls to create overlay for list of length<256.
stats65536: REF StatArray ← NEW [StatArray];
records calls to create overlay for list of length>=256.
Index i corresponds to count for length/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;
};
Icon
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]];
};
Annotation
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]];
};
Hash
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]];
};
Equal
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;
};
Describe
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
};
Utilities
Object Caches
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;
};
Operations on objects
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]];
};
Objects Predicates
AlwaysTrue: PUBLIC PROC [Object] RETURNS [BOOL] = {RETURN [TRUE]};
AlwaysFalse: PUBLIC PROC [Object] RETURNS [BOOL] = {RETURN [FALSE]};
Class Tables
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];
};
Initialization
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.