CDDirectoryImpl.mesa (part of ChipNDale)
Copyright © 1983, 1984, 1985, 1986, 1987 by Xerox Corporation. All rights reserved.
Created by Christian Jacobi, June 24, 1983 5:00 pm
Last edited by: Christian Jacobi, April 10, 1987 6:38:49 pm PDT
DIRECTORY
CD,
CDCacheBase,
CDCells,
CDCellsBackdoor,
CDDefaultProcs,
CDDirectory,
CDEvents,
CDBasics,
CDOps,
CDProperties,
CDRects,
CDValue,
IO,
Properties,
Random,
RefTab,
Rope,
SymTab,
TerminalIO;
CDDirectoryImpl:
CEDAR
MONITOR
IMPORTS CD, CDDirectory, CDCells, CDCellsBackdoor, CDDefaultProcs, CDEvents, CDBasics, CDOps, CDProperties, CDRects, CDValue, IO, Properties, Random, RefTab, Rope, SymTab, TerminalIO
EXPORTS CDDirectory, CDCacheBase
SHARES CD, CDRects =
BEGIN
Directory updates:
Always include name in SymTab first then include object in RefTab.
Remove in opposite order.
SetOwner:
PUBLIC
PROC [design:
CD.Design, object:
CD.Object, check:
BOOL←
TRUE] = {
x: REF ← (IF design=NIL THEN NIL ELSE design.cdDirectoryPriv2);
IF check
THEN
SELECT CDProperties.GetObjectProp[object, ownerKey]
FROM
x => RETURN;
NIL => {};
ENDCASE => ERROR CD.Error[directoryInvariant, "object in different design"];
IF object.immutable AND design#NIL THEN ERROR CD.Error[calling, "don't set ownership of immutable object"];
CDProperties.PutObjectProp[object, ownerKey, x];
};
IsOwner:
PUBLIC PROC [design:
CD.Design, object:
CD.Object]
RETURNS [
BOOL] = {
x: REF ~ (IF design=NIL THEN NIL ELSE design.cdDirectoryPriv2);
SELECT CDProperties.GetObjectProp[object, ownerKey]
FROM
x => RETURN [TRUE];
ENDCASE => RETURN [FALSE];
};
CompatibleOwner:
PUBLIC PROC [design:
CD.Design, object:
CD.Object]
RETURNS [
BOOL] = {
x: REF ~ (IF design=NIL THEN NIL ELSE design.cdDirectoryPriv2);
SELECT CDProperties.GetObjectProp[object, ownerKey]
FROM
x => RETURN [TRUE];
NIL => RETURN [TRUE];
ENDCASE => RETURN [FALSE];
};
EachEntryAction: TYPE = PROC [name: Rope.ROPE, ob: CD.Object] RETURNS [quit: BOOL←FALSE];
Fetch:
PUBLIC
PROC [design:
CD.Design, name: Rope.
ROPE]
RETURNS [object:
CD.Object←
NIL] = {
WITH SymTab.Fetch[design.cdDirectory1, name].val
SELECT
FROM
ob: CD.Object => RETURN [ob]
ENDCASE => RETURN [NIL];
};
Remove:
PUBLIC
PROC [design:
CD.Design, name: Rope.
ROPE, expectObject:
CD.Object←
NIL]
RETURNS [ob:
CD.Object] = {
ob ← MyRemove[design, name, expectObject].removed;
IF ob#
NIL
THEN {
[] ← DirectoryOp[ob, design, name, remove];
We dont SetOwner[NIL, object]; This makes interactive operations safer,
at cost of inter-design copy; But inter-design copy is already difficult anyway.
};
};
Fiddle:
PUBLIC
PROC [design:
CD.Design, name: Rope.
ROPE]
RETURNS [ob:
CD.Object] = {
ob ← MyRemove[design, name].removed;
IF ob#
NIL
THEN {
newName: Rope.ROPE ← IncludeFiddled[design, ob, name];
[] ← DirectoryOp[ob, design, newName, rename];
};
};
IncludeFiddled:
PROC [design:
CD.Design, ob:
CD.Object, name: Rope.
ROPE]
RETURNS [newName: Rope.
ROPE] = {
--ob must not be already included with any name
--always ! succeeds including object
try: INT ← 0;
DO
IF (try ← try+1) < 3
THEN {name ← FiddleName[name, design]}
ELSE {try ← 0; name ← FiddleGlobal[name]};
IF SymTab.Insert[design.cdDirectory1, name, ob]
THEN {
[] ← RefTab.Store[design.cdDirectory2, ob, name];
RETURN [name];
}
ENDLOOP;
};
Status:
TYPE = {done, ok, failed};
--done: done on this call
--ok: its not really done, but that name is at least not occupying a slot in the
-- name-space anymore
--failed: place in name space is still occupied
MyRemove:
PROC [design:
CD.Design, name: Rope.
ROPE, expectObject:
CD.Object←
NIL]
RETURNS [status: Status�iled, removed:
CD.Object←
NIL] = {
object: CD.Object ← Fetch[design, name].object;
IF object=NIL THEN RETURN [ok, NIL];
IF (object=expectObject
OR expectObject=
NIL)
THEN {
IF ~CompatibleOwner[design, object]
THEN
ERROR CD.Error[directoryInvariant, "Removed object in different design"];
IF RefTab.Delete[design.cdDirectory2, object] THEN removed ← object;
IF SymTab.Delete[design.cdDirectory1, name] THEN removed ← object;
IF removed#NIL THEN status ← done
};
};
DirectoryOp:
PROC[me:
CD.Object, design:
CD.Design, name: Rope.
ROPE, function: CDDirectory.DirectoryFunction] = {
IF me.class.composed
THEN {
dop: CDDirectory.DirectoryProc = CDDirectory.ObToDirectoryProcs[me].directoryOp;
IF dop#NIL THEN dop[me, design, name, function];
}
};
IsIncluded:
PUBLIC
PROC [design:
CD.Design, object:
CD.Object]
RETURNS [
BOOL] = {
name: Rope.ROPE ← CDDirectory.Name[object, design];
RETURN [name#NIL]
};
Include:
PUBLIC
PROC [design:
CD.Design, object:
CD.Object, name: Rope.
ROPE, fiddle:
BOOL←
TRUE]
RETURNS [done:
BOOL←
FALSE] = {
--we tolerate include of an object twice in the same design
oldName: Rope.ROPE ← NIL;
try: INT ← 0;
IF Rope.IsEmpty[name] THEN name ← "-noname-";
IF ~object.immutable AND object.class.composed THEN SetOwner[design, object, TRUE];
IF (oldName ← CDDirectory.Name[object, design])#
NIL
THEN {
IF Rope.Equal[oldName, name] THEN RETURN [TRUE];
RETURN [FALSE];
};
IF SymTab.Insert[design.cdDirectory1, name, object]
THEN {
[] ← RefTab.Store[design.cdDirectory2, object, name];
DirectoryOp[object, design, name, include];
RETURN [TRUE]
};
IF fiddle
THEN {
name ← IncludeFiddled[design, object, name];
DirectoryOp[object, design, name, include];
RETURN [TRUE]
};
RETURN [FALSE]
};
FiddleGlobal:
PROC [name: Rope.
ROPE]
RETURNS [Rope.
ROPE] = {
RETURN [IO.PutFR["%g@%g@0", IO.rope[name], IO.int[Random.ChooseInt[max: LAST[NAT]]]]];
};
NextFiddleKey:
PROC [design:
CD.Design]
RETURNS [key:
INT] = {
WITH CDProperties.GetDesignProp[design, $FiddleKey]
SELECT
FROM
i: REF INT => {key ← i^; i^ ← i^ MOD 1000000B + 1};
ENDCASE => {key ← 0; CDProperties.PutDesignProp[design, $FiddleKey, NEW[INT𡤁]]};
};
FiddleName:
PROC [name: Rope.
ROPE, design:
CD.Design]
RETURNS [Rope.
ROPE] = {
modifier: INT ← NextFiddleKey[design];
leng: INT ← name.Length[];
WHILE leng>0
DO
leng ← leng-1;
IF name.Fetch[leng]='@
THEN {
name ← name.Substr[0, leng]; EXIT
}
ENDLOOP;
name ← IO.PutFR["%g@%g", IO.rope[name], IO.int[modifier]];
RETURN [name];
};
Rename:
PUBLIC
PROC [design:
CD.Design, object:
CD.Object, newName: Rope.
ROPE ←
NIL, fiddle:
BOOL ←
TRUE, fiddleFirst:
BOOL ←
FALSE, removeFirst:
BOOL ←
FALSE]
RETURNS [done:
BOOL, conflict:
CD.Object] = {
oldName: Rope.ROPE = CDDirectory.Name[object, design];
status: Status;
IF ~CompatibleOwner[design, object] THEN ERROR CD.Error[directoryInvariant];
status ← MyRemove[design, oldName, object].status;
IF status=failed THEN RETURN [FALSE, CDDirectory.Fetch[design, newName]];
IF SymTab.Insert[design.cdDirectory1, newName, object]
THEN {
[] ← RefTab.Store[design.cdDirectory2, object, newName];
DirectoryOp[object, design, newName, (IF status = done THEN rename ELSE include)];
RETURN [TRUE, NIL]
};
conflict ← CDDirectory.Fetch[design, newName];
IF fiddle
THEN {
newName ← IncludeFiddled[design, object, newName];
DirectoryOp[object, design, newName, (IF status = done THEN rename ELSE include)];
RETURN [TRUE, conflict]
}
ELSE {
--NOT fiddle
IF conflict#
NIL
THEN {
IF conflict=object THEN RETURN [TRUE, NIL];
IF fiddleFirst THEN conflict ← Fiddle[design, newName]
ELSE IF removeFirst THEN conflict ← Remove[design, newName]
};
IF SymTab.Insert[design.cdDirectory1, newName, object]
THEN {
[] ← RefTab.Store[design.cdDirectory2, object, newName];
DirectoryOp[object, design, newName, (IF status = done THEN rename ELSE include)];
RETURN [TRUE, conflict]
};
IF status=done
THEN {
[] ← IncludeFiddled[design, object, oldName];
RETURN [done: FALSE, conflict: conflict]
};
ERROR CD.Error[programming, "rename removed an object"]
}
};
Enumerate:
PUBLIC
PROC [design:
CD.Design, action: EachEntryAction]
RETURNS [quit:
BOOL] = {
EachPairAction: SymTab.EachPairAction ~ {
quit ← action[name: NARROW[key], ob: NARROW[val, CD.Object]]
};
quit ← SymTab.Pairs[design.cdDirectory1, EachPairAction]
};
DirSize:
PUBLIC
PROC [design:
CD.Design]
RETURNS [
INT] = {
RETURN [SymTab.GetSize[design.cdDirectory1]]
};
InstallDirectoryProcs:
PUBLIC
PROC [type:
CD.ObjectClass, dp: CDDirectory.DirectoryProcs]
RETURNS [
REF CDDirectory.DirectoryProcs] = {
dpr: REF CDDirectory.DirectoryProcs ~ NEW[CDDirectory.DirectoryProcs𡤍p];
IF type.directoryProcs#
NIL
OR type.composed
THEN
ERROR CD.Error[ec: doubleRegistration, explanation: "type already composed"];
type.directoryProcs ← dpr;
type.composed ← TRUE;
IF dpr.enumerateChildObjects=
NIL
THEN
dpr.enumerateChildObjects ← DefaultEnumerateChildObjects;
IF dpr.replaceDirectChilds=NIL THEN dpr.replaceDirectChilds ← DefaultReplaceDirectChilds;
IF dpr.another=NIL THEN dpr.another ← DefaultAnother;
IF dpr.expand=NIL THEN dpr.expand ← DefaultExpand;
IF dpr.directoryOp=NIL THEN dpr.directoryOp ← DefaultDirectoryOp;
RETURN [dpr]
};
DefaultAnother: CDDirectory.AnotherProc = {
--crazy another proc which makes a copy of the object-definition
new ← NEW[CD.ObjectRep←me^]; --this would not be ok for most object classes
new.properties ← CDProperties.DCopyProps[me.properties];
childAccessible ← (IF into#NIL AND into=fromOrNil THEN ~me.class.xDesign ELSE FALSE);
};
DefaultExpand: CDDirectory.ExpandProc = {
new ← Expand1ByDraw[me, LeaveNextLevel];
topAccessible ← TRUE;
childAccessible ← (into=fromOrNil OR into#NIL);
};
DefaultReplaceDirectChilds: CDDirectory.ReplaceDChildsProc = {
ERROR CD.Error[missingRegistration, "Don't default this procedure"];
};
DefaultEnumerateChildObjects: CDDirectory.EnumerateChildObjectsProc = {
--Use drawproc to find children.
--Sorry this is not too fast; But not providing a default proc would bare the risk of some
--people making classes with EnumerateChildObjectsProc's not returning any objects.
--
IF me.class.composed
AND ~me.class.xDesign
THEN {
exp: CD.Object;
exp ← Expand1ByDraw[me, LeaveNextLevel, NIL];
quit ← CDDirectory.EnumerateChildObjects[exp, proc, data];
RETURN
};
--
--The real implementation crashes when a nested procedure is passed in and assigned
--
IF me.class.composed
AND ~me.class.xDesign
THEN {
xPr:
CD.DrawRef =
CD.CreateDrawRef[[
drawRect: CDDefaultProcs.IgnoreRect,
drawChild: EnumerateByDrawing,
drawOutLine: CDDefaultProcs.IgnoreRect,
selections: FALSE,
symbolics: FALSE,
devicePrivate: NEW[EnumRec←[data, proc]]
]];
CD.DrawOb[xPr, me ! QuitEnumerating => GOTO quit];
};
RETURN [FALSE];
EXITS quit => RETURN [TRUE]
};
EnumRec:
TYPE =
RECORD [data:
REF, proc: CDDirectory.EachObjectProc];
--used by DefaultEnumerateChildObjects
QuitEnumerating:
ERROR =
CODE;
--used by DefaultEnumerateChildObjects
EnumerateByDrawing:
CD.DrawProc = {
--used by DefaultEnumerateChildObjects
IF ob.class.composed
THEN {
er: REF EnumRec ← NARROW[pr.devicePrivate];
IF er.proc[ob, er.data].quit THEN ERROR QuitEnumerating;
}
};
DefaultDirectoryOp:
PROC [me:
CD.Object, design:
CD.Design, name: Rope.
ROPE, function: CDDirectory.DirectoryFunction] = {
};
-- -- -- -- -- -- -- -- -- -- --
Name:
PUBLIC
PROC [object:
CD.Object, design:
CD.Design]
RETURNS [Rope.
ROPE] = {
WITH RefTab.Fetch[design.cdDirectory2, object].val
SELECT
FROM
r: Rope.ROPE => RETURN [r]
ENDCASE => RETURN [NIL];
};
EnumerateDesign:
PUBLIC PROC [design:
CD.Design, proc: CDDirectory.EachObjectProc, data:
REF←
NIL, dir:
BOOL←
TRUE, top:
BOOL←
TRUE, recurse:
BOOL←
TRUE, dummy:
BOOL←
FALSE, visited: RefTab.Ref←
NIL]
RETURNS [quit:
BOOL←
FALSE] = {
--enumerates only the mutable children
Handle:
PROC [ob:
CD.Object]
RETURNS [quit:
BOOL←
FALSE] =
INLINE {
IF RefTab.Insert[visited, ob, $x]
THEN {
IF recurse THEN quit ← CDDirectory.EnumerateChildObjects[ob, CheckNRecurse];
IF ~quit THEN quit ← proc[ob, data];
}
};
CheckNRecurse: CDDirectory.EachObjectProc = {
IF me.class.composed THEN RETURN [Handle[me]];
};
EachDirEntry: SymTab.EachPairAction = {
ob: CD.Object ← NARROW[val, CD.Object];
IF ob.class.composed THEN RETURN [Handle[ob]];
};
IF visited=NIL THEN visited ← RefTab.Create[MAX[CDDirectory.DirSize[design], 28]+17];
IF dir
THEN
quit ← SymTab.Pairs[design.cdDirectory1, EachDirEntry];
IF top
THEN
FOR l:
LIST
OF
CD.PushRec ← design.actual, l.rest
WHILE (l#
NIL
AND ~quit)
DO
IF l.first.mightReplace#NIL THEN quit ← CheckNRecurse[l.first.mightReplace.ob];
IF ~quit
THEN
quit ←
IF dummy
THEN CheckNRecurse[l.first.dummyCell.ob]
ELSE CDDirectory.EnumerateChildObjects[l.first.dummyCell.ob, CheckNRecurse]
ENDLOOP;
};
EnumerateObject:
PUBLIC PROC [ob:
CD.Object, proc: CDDirectory.EachObjectProc, data:
REF←
NIL, recurse:
BOOL←
TRUE, visited: RefTab.Ref←
NIL]
RETURNS [quit:
BOOL←
FALSE] = {
--enumerates only the mutable children
Handle:
PROC [ob:
CD.Object]
RETURNS [quit:
BOOL←
FALSE] =
INLINE {
IF RefTab.Insert[visited, ob, $x]
THEN {
IF recurse THEN quit ← CDDirectory.EnumerateChildObjects[ob, CheckNRecurse];
IF ~quit THEN quit ← proc[ob, data];
}
};
CheckNRecurse: CDDirectory.EachObjectProc = {
IF me.class.composed THEN RETURN [Handle[me]];
};
IF visited=NIL THEN visited ← RefTab.Create[];
IF ob.class.composed THEN RETURN [Handle[ob]];
};
-- -- -- -- -- -- -- -- -- -- --
Another1:
PUBLIC
PROC [me:
CD.Object, fromOrNil:
CD.Design←
NIL, into:
CD.Design←
NIL, friendly:
BOOL←
FALSE]
RETURNS [new:
CD.Object, childAccessible:
BOOL] = {
IF ~me.class.composed THEN RETURN [me, TRUE]
ELSE {
another: CDDirectory.AnotherProc ← CDDirectory.ObToDirectoryProcs[me].another;
IF another=NIL THEN ERROR CD.Error[missingRegistration];
[new, childAccessible] ← another[me, fromOrNil, into, friendly];
IF childAccessible THEN SetOwner[into, new];
};
};
Expand1:
PUBLIC
PROC [me:
CD.Object, fromOrNil:
CD.Design←
NIL, into:
CD.Design←
NIL, friendly:
BOOL←
FALSE]
RETURNS [new:
CD.Object, topAccessible:
BOOL, childAccessible:
BOOL] = {
IF ~me.class.composed THEN RETURN [NIL, FALSE, FALSE]
ELSE {
expand: CDDirectory.ExpandProc = CDDirectory.ObToDirectoryProcs[me].expand;
IF expand=NIL THEN ERROR CD.Error[missingRegistration];
[new, topAccessible, childAccessible] ← expand[me, fromOrNil, into, friendly];
IF topAccessible AND childAccessible THEN SetOwner[into, new];
};
};
AnotherRecursed:
PUBLIC
PROC [me:
CD.Object, into:
CD.Design←
NIL, fromOrNil:
CD.Design←
NIL, cx: RefTab.Ref←
NIL, getFromCache: CDDirectory.GetFromCacheProc←
NIL, putInCache: CDDirectory.PutInCacheProc←
NIL, data:
REF←
NIL]
RETURNS [new:
CD.Object←
NIL] = {
ca: BOOL ← TRUE;
IF cx=NIL THEN cx ← RefTab.Create[]
ELSE
WITH RefTab.Fetch[cx, me].val
SELECT
FROM
ob: CD.Object => RETURN [ob];
ENDCASE => NULL;
IF getFromCache#
NIL
THEN {
new ← getFromCache[me, data];
IF new#NIL THEN {[] ← RefTab.Store[cx, me, new]; RETURN};
};
[new, ca] ← Another1[me, fromOrNil, into, TRUE];
IF new#
NIL
AND ~ca
THEN {
IF ~FixChildren[new, into, fromOrNil, cx, getFromCache, putInCache, data].ok THEN RETURN [NIL]
};
IF new#
NIL
THEN {
[] ← RefTab.Store[cx, me, new];
IF putInCache#NIL THEN putInCache[me, new, data];
}
};
ExpandRecursed:
PUBLIC
PROC [me:
CD.Object, into:
CD.Design←
NIL, fromOrNil:
CD.Design←
NIL, cx: RefTab.Ref←
NIL, getFromCache: CDDirectory.GetFromCacheProc←
NIL, putInCache: CDDirectory.PutInCacheProc←
NIL, data:
REF←
NIL]
RETURNS [new:
CD.Object] = {
ta, ca: BOOL;
[new, ta, ca] ← Expand1[me, fromOrNil, into, TRUE];
IF new#
NIL
THEN {
IF cx=NIL THEN cx ← RefTab.Create[];
IF ~ta
THEN {
[new, ca] ← Another1[new, fromOrNil, into];
IF new=NIL THEN RETURN;
};
IF ~ca
THEN {
IF ~FixChildren[new, into, fromOrNil, cx, getFromCache, putInCache, data].ok THEN RETURN [NIL]
};
};
};
FixChildren:
PUBLIC
PROC [me:
CD.Object, into:
CD.Design, fromOrNil:
CD.Design←
NIL, cx: RefTab.Ref←
NIL, getFromCache: CDDirectory.GetFromCacheProc←
NIL, putInCache: CDDirectory.PutInCacheProc←
NIL, data:
REF←
NIL]
RETURNS [ok:
BOOL←
TRUE] = {
replaceList: CDDirectory.ReplaceList ← NIL;
localTab: RefTab.Ref ← RefTab.Create[];
--contains all elements of replaceList; one level only!
PerChild: CDDirectory.EachObjectProc = {
IF ~me.immutable
AND me.class.composed
THEN {
newChild: CD.Object ← NIL;
IF ~RefTab.Insert[localTab, me, $handled] THEN RETURN; -- eliminate duplicates
WITH RefTab.Fetch[cx, me].val
SELECT
FROM
cob: CD.Object => newChild ← cob;
ENDCASE => {
localOk, ca: BOOL ← TRUE;
IF IsOwner[into, me] THEN newChild ← me
ELSE IF getFromCache#NIL THEN newChild ← getFromCache[me, data];
IF newChild=
NIL
THEN {
[newChild, ca] ← Another1[me: me, fromOrNil: fromOrNil, into: into, friendly: TRUE];
IF newChild=NIL THEN {ok ← localOk ← FALSE; newChild ← me; ca ← FALSE}
ELSE
IF ~ca
AND newChild#me
THEN {
IF newChild.immutable THEN ERROR CD.Error[classBehaviour];
IF ~FixChildren[me: newChild, into: into, fromOrNil: fromOrNil, cx: cx, getFromCache: getFromCache, putInCache: putInCache, data: data].ok THEN ok ← localOk ← FALSE
};
IF localOk AND putInCache#NIL THEN putInCache[me, newChild, data]
};
IF localOk THEN [] ← RefTab.Insert[cx, me, newChild];
};
IF me#newChild
AND newChild#
NIL
THEN
replaceList ← CONS[NEW[CDDirectory.ReplaceRec←[old: me, new: newChild]], replaceList];
}
};
IF cx=NIL THEN cx ← RefTab.Create[];
[] ← CDDirectory.EnumerateChildObjects[me: me, proc: PerChild, data: data];
IF replaceList#
NIL
THEN {
IF me.immutable THEN ERROR CD.Error[classBehaviour, "immutable objects must not have inaccessible children"];
[] ← CDDirectory.ReplaceDirectChild[me: me, design: into, replace: replaceList, propagate: FALSE];
};
IF ok
THEN {
SetOwner[into, me];
[] ← RefTab.Insert[cx, me, me];
}
};
ExpandRec:
TYPE =
RECORD [
cell: CD.Object,
cellPtr: CD.CellSpecific,
ep: CDDirectory.ExpandDecisionProc,
data: REF
];
drawAll: REF CD.ContextFilter = NEW[CD.ContextFilter←ALL[TRUE]];
Expand1ByDraw:
PUBLIC
PROC [ob:
CD.Object, ep: CDDirectory.ExpandDecisionProc←
NIL, data:
REF←
NIL]
RETURNS [
CD.Object] = {
cell: CD.Object = CDCells.CreateEmptyCell[];
expandRef:
REF ExpandRec =
NEW[ExpandRec←[
cell: cell, cellPtr: NARROW[cell.specific],
ep: ep, data: data
]];
expandPr:
CD.DrawRef =
CD.CreateDrawRef[[
design: NIL,
drawRect: ExpandByDrawBareRect,
drawChild: ExpandByDrawChild,
drawOutLine: CDDefaultProcs.IgnoreRect,
selections: FALSE,
devicePrivate: expandRef,
contextFilter: drawAll
]];
ob.class.drawMe[pr: expandPr, ob: ob];
CDCells.SetInterestRect[NIL, cell, CD.InterestRect[ob], doit];
RETURN [cell]
};
LeaveRectangles:
PUBLIC CDDirectory.ExpandDecisionProc = {
IF ob.class.composed THEN RETURN [recurse];
IF ob.class.symbolic THEN RETURN [suppress];
IF ob.class=CDRects.bareRectClass THEN RETURN [leave];
RETURN [recurse];
};
LeaveNextLevel:
PUBLIC CDDirectory.ExpandDecisionProc = {
RETURN [leave];
};
LeaveDontFlatten:
PUBLIC CDDirectory.ExpandDecisionProc = {
IF ~ob.class.composed THEN RETURN [leave];
IF CDProperties.GetObjectProp[ob, $DontFlatten]#NIL THEN RETURN [leave];
IF CDProperties.GetListProp[readOnlyInstProps, $DontFlatten]#NIL THEN RETURN [leave];
RETURN [recurse];
};
ExpandByDrawBareRect:
PROC [pr:
CD.DrawRef, r:
CD.Rect, l:
CD.Layer] = {
expandRef: REF ExpandRec = NARROW[pr.devicePrivate];
inst:
CD.Instance ←
NEW[
CD.InstanceRep←[
ob: CDRects.CreateBareRect[size: CDBasics.SizeOfRect[r], l: l],
trans: [CDBasics.BaseOfRect[r], original]
]];
expandRef.cellPtr.contents ← CONS[inst, expandRef.cellPtr.contents];
};
ExpandByDrawChild: CD.DrawProc = {
expandRef: REF ExpandRec = NARROW[pr.devicePrivate];
SELECT expandRef.ep[ob, trans, readOnlyInstProps, expandRef.data]
FROM
suppress => NULL;
leave => expandRef.cellPtr.contents ←
CONS[
NEW[CD.InstanceRep←[ob: ob, trans: trans, properties: CDProperties.DCopyProps[readOnlyInstProps]]],
expandRef.cellPtr.contents
];
recurse => ob.class.drawMe[pr, ob, trans, readOnlyInstProps];
ENDCASE => ERROR CD.Error[programming];
};
-- -- -- -- -- -- -- -- -- -- --
RepositionList: TYPE = LIST OF CD.Object;
changeEvent: CDEvents.EventRegistration ~ CDEvents.RegisterEventType[$AfterChange];
ReplaceObject:
PUBLIC
PROC [design:
CD.Design, old:
CD.Object, new:
CD.Object, trans:
CD.Transformation] = {
--all over in the design replace old by new
--may be delayed
repRef: REF CDDirectory.ReplaceRec ← NEW[CDDirectory.ReplaceRec←[old: old, new: new, trans: trans]];
IF design=NIL THEN ERROR CD.Error[calling];
FOR plist:
LIST
OF
CD.PushRec ← design.actual, plist.rest
WHILE plist#
NIL
DO
IF plist.first.mightReplace#
NIL
AND plist.first.mightReplace.ob=old
THEN
TerminalIO.PutRope["** Tries to replace pushed in cell; does not work\n"];
ENDLOOP;
ReplaceAllChilds[design, repRef]
};
PropagateResize:
PUBLIC
PROC [design:
CD.Design, ob:
CD.Object] = {
--all over in the design tries to reposition ob;
--may be delayed
repRef: REF CDDirectory.ReplaceRec ← NEW[CDDirectory.ReplaceRec←[old: ob, new: ob]];
IF ob.immutable THEN ERROR CD.Error[objectMutability];
[] ← CDEvents.ProcessEvent[
eventRegistration: resizeEvent,
design: design,
x: NEW[CDDirectory.ReplaceRec ← repRef^], --copy for safety
listenToDont: FALSE
];
IF design#NIL THEN ReplaceAllChilds[design, repRef]
};
ReplaceAllChilds:
PROC [design:
CD.Design, repRef:
REF CDDirectory.ReplaceRec] = {
--catches recursive calls and transformes them into sequential calls...
--the list of what to do is found using CDValue on the design
ENABLE
UNWIND => {
CDValue.Store[design, repositioningListKey, NIL];
TerminalIO.PutRope["****repositioning or replace failed [maybe, partly]\n"];
};
ref:
REF CDDirectory.ReplaceList ←
NARROW[
CDValue.Fetch[boundTo: design, key: repositioningListKey, propagation: design]
];
IF ref#
NIL
THEN {
-- we are inside replace process, remember object
IF ref^=NIL THEN ref^ ← LIST[repRef]
ELSE {
FOR l: CDDirectory.ReplaceList ← ref^, l.rest
DO
IF l.first.old=repRef.old THEN ERROR CD.Error[programming, "impossible! call Christian"];
IF l.rest=NIL THEN {l.rest ← LIST[repRef]; EXIT}
ENDLOOP;
};
RETURN
};
-- we are not inside reposition process, start one
ref ← NEW[CDDirectory.ReplaceList←LIST[repRef]];
CDValue.Store[boundTo: design, key: repositioningListKey, value: ref];
WHILE ref^#
NIL
DO
repList: CDDirectory.ReplaceList ← ref^;
ref^ ← NIL;
DoReplaceAllChilds[design, repList];
ENDLOOP;
CDValue.Store[design, repositioningListKey, NIL];
CDOps.Redraw[design];
};
ReplaceDirectChild:
PUBLIC
PROC [me:
CD.Object, design:
CD.Design, replace: CDDirectory.ReplaceList, propagate:
BOOL←
TRUE]
RETURNS [changed:
BOOL←
FALSE] = {
IF me.class.composed
AND replace#
NIL
THEN {
IF me.immutable THEN ERROR CD.Error[objectMutability];
changed ← CDDirectory.ObToDirectoryProcs[me].replaceDirectChilds[me, design, replace];
IF changed AND propagate THEN PropagateChange[me, design];
}
};
DoReplaceAllChilds:
PROC [design:
CD.Design, repList: CDDirectory.ReplaceList] = {
ReplaceForOne: CDDirectory.EachObjectProc = {
IF ~me.immutable THEN [] ← ReplaceDirectChild[me: me, design: design, replace: repList];
};
[] ← CDDirectory.EnumerateDesign[design, ReplaceForOne];
FOR plist:
LIST
OF
CD.PushRec ← design.actual, plist.rest
WHILE plist#
NIL
DO
inst: CD.Instance ← plist.first.mightReplace;
SetOwner[design, plist.first.dummyCell.ob, TRUE]; --HACK XXX XXX
FOR rlist: CDDirectory.ReplaceList ← repList, rlist.rest
WHILE rlist#
NIL
DO
rep: REF CDDirectory.ReplaceRec = rlist.first;
IF inst#
NIL
AND inst.ob=rep.old
THEN {
inst.trans ← CDBasics.ComposeTransform[itemInCell: inst.trans, cellInWorld: rep.trans];
}
ENDLOOP;
[] ← CDCellsBackdoor.ReplaceDirectChildForCell[plist.first.dummyCell.ob, design, repList];
ENDLOOP;
};
RemovePropsEvent: CDEvents.EventProc = {
ob: CD.Object = NARROW[x];
Rem: Properties.EachProp = {
p: CDProperties.PropertyProcs ~ CDProperties.FetchProcs[key];
IF p#NIL AND p.autoRem THEN CDProperties.PutObjectProp[ob, key, NIL];
};
IF ob#NIL THEN [] ← Properties.Enumerate[ob.properties, Rem]
};
PropagateChange:
PUBLIC
PROC [ob:
CD.Object, design:
CD.Design] = {
-- processes an CDEvent $AfterChange
IF ob.immutable THEN ERROR CD.Error[objectMutability];
[] ← CDEvents.ProcessEvent[changeEvent, design, ob];
};
--CDCacheBase
CurrentKey:
PUBLIC
PROC [ob:
CD.Object]
RETURNS [key:
REF] = {
RETURN [CDProperties.GetObjectProp[ob, modificationKeyProp]]
};
Match:
PUBLIC
PROC [ok: CDCacheBase.ObjectAndKey]
RETURNS [
BOOL] = {
RETURN [CDProperties.GetObjectProp[ok.ob, modificationKeyProp]=ok.key]
};
modificationKeyProp: PUBLIC REF = NEW[ATOM←$ModificationKey];
nextModification: CARD ← 0;
ObjectHasChanged: CDEvents.EventProc = {
WITH x
SELECT
FROM
ob:
CD.Object =>
IF ob.class.composed
THEN
CDProperties.PutObjectProp[ob, modificationKeyProp, NEW[CARD←(nextModification←nextModification+1)]];
ENDCASE => NULL;
};
resizeEventKey: ATOM = $resize;
resizeEvent: CDEvents.EventRegistration = CDEvents.RegisterEventType[resizeEventKey];
repositioningListKey: REF ATOM = NEW[ATOM←$RepositioningList];
ownerKey: ATOM = $OwnerDesign; --HACK XXX: property is also used by cdcellsimpl
[] ← CDProperties.RegisterProperty[ownerKey];
[] ← CDProperties.RegisterProperty[modificationKeyProp];
CDProperties.InstallProcs[prop: ownerKey, procs: CDProperties.PropertyProcsRec[exclusive: TRUE]];
CDProperties.InstallProcs[prop: modificationKeyProp, procs: CDProperties.PropertyProcsRec[exclusive: TRUE, internalWrite: CDProperties.DontPWrite, makeCopy: CDProperties.CopyVal]];
CDValue.RegisterKey[repositioningListKey];
CDEvents.RegisterEventProc[event: changeEvent, proc: RemovePropsEvent];
CDEvents.RegisterEventProc[event: changeEvent, proc: ObjectHasChanged];
END.