CDDirectoryImpl.mesa (part of ChipNDale)
Copyright © 1983, 1985 by Xerox Corporation. All rights reserved.
by Christian Jacobi, June 24, 1983 5:00 pm
last edited Christian Jacobi, February 5, 1986 10:12:09 am PST
DIRECTORY
CD,
CDInstances,
CDCallSpecific,
CDCells,
CDDefaultProcs,
CDDirectory,
CDEvents,
CDBasics,
CDOrient,
CDOps,
CDProperties,
CDRects,
CDValue,
Imager,
IO,
Rope,
SymTab,
TerminalIO;
CDDirectoryImpl:
CEDAR
MONITOR
IMPORTS CD, CDInstances, CDDefaultProcs, CDDirectory, CDCells, CDEvents, CDBasics, CDOps, CDOrient, CDProperties, CDRects, CDValue, IO, Imager, Rope, SymTab, TerminalIO
EXPORTS CDDirectory
SHARES CD, CDCells =
BEGIN
--all object which contain other objects are supposed to be in the directory;
--which is necessary for enumeration and for repositioning
DesignPtr: TYPE = LONG POINTER TO CD.DesignRec;
SetOwner:
PROC [ob:
CD.Object, design:
CD.Design] =
TRUSTED {
x: REF DesignPtr ← IF design=NIL THEN NIL ELSE NEW[DesignPtr←LOOPHOLE[design]];
CDProperties.PutPropOnObject[ob, ownerKey, x];
};
GetOwner:
PROC [ob:
CD.Object]
RETURNS [
CD.Design] =
TRUSTED {
WITH CDProperties.GetPropFromObject[ob, ownerKey]
SELECT
FROM
x: REF DesignPtr => RETURN [LOOPHOLE[x^]];
ENDCASE => RETURN [NIL]
};
EachEntryAction: TYPE = PROC [name: Rope.ROPE, ob: CD.Object] RETURNS [quit: BOOL];
Fetch:
PUBLIC
PROC [design:
CD.Design, name: Rope.
ROPE]
RETURNS [found: BOOL, object: CD.Object←NIL] =
--search for object in directory
BEGIN
x: SymTab.Val;
[found, x] ← SymTab.Fetch[design.cellDirectory, name];
IF found THEN object ← NARROW[x, CD.Object];
END;
Remove:
PUBLIC PROC [design:
CD.Design, name: Rope.
ROPE, expectObject:
CD.Object←
NIL]
RETURNS [done:
BOOL�LSE] =
--if expectObject#NIL removes name only, iff named object=expectObject
--if removed objects are still used, they are neither enumerated correctly anymore,
--nor repositioned if internal objects change
BEGIN
object: CD.Object ← Fetch[design, name].object;
IF object#
NIL
AND (expectObject=
NIL
OR object=expectObject)
THEN {
IF GetOwner[object]#design THEN ERROR CD.Error[callingError, "Removed ob not in design"];
done ← SymTab.Delete[design.cellDirectory, name];
IF done
THEN {
SetOwner[object, NIL];
IncludeEtAll[object, NIL, name]
};
};
END;
IncludeEtAll:
PROC[object:
CD.Object, design:
CD.Design, name: Rope.
ROPE] =
BEGIN
IF object.class.inDirectory
THEN {
includeEtAll: CDDirectory.IncludeEtAllProc = CDDirectory.ObToDirectoryProcs[object].includeEtAll;
IF includeEtAll#NIL THEN includeEtAll[object, design, name];
}
END;
SetName:
PROC[me:
CD.Object, r: Rope.
ROPE] =
INLINE {
IF me.class.inDirectory THEN CDDirectory.ObToDirectoryProcs[me].setName[me, r]
};
Include:
PUBLIC
PROC [design:
CD.Design, object:
CD.Object, alternateName: Rope.
ROPE←
NIL, fiddleName:
BOOL←
TRUE]
RETURNS [done:
BOOL] =
--it is an ERROR to include an object into several design's
--but it is ok to include an object twice in the same design
BEGIN
try: INT ← 0;
oldDesign: CD.Design ← GetOwner[object];
IF Rope.IsEmpty[alternateName]
THEN {
alternateName ← CDDirectory.Name[object];
IF Rope.IsEmpty[alternateName] THEN alternateName ← "-noname-";
};
IF oldDesign#
NIL
THEN {
IF oldDesign#design
THEN
ERROR CD.Error[callingError, "cant include object in two designs"]
ELSE {
--ignore whether name is right or wrong
IF ~fiddleName
AND ~Rope.Equal[alternateName, CDDirectory.Name[object]]
THEN
RETURN [done ← FALSE];
RETURN [done ← TRUE]
};
};
DO
IF SymTab.Insert[design.cellDirectory, alternateName, object]
THEN {
SetName[object, alternateName];
SetOwner[object, design];
IncludeEtAll[object, design, alternateName];
RETURN [done ← TRUE]
};
IF ~fiddleName THEN RETURN [done ← FALSE];
try ← try+1;
IF try<3 THEN alternateName ← FiddleName[alternateName, design]
ELSE {
try ← 0;
alternateName ← FiddleGlobal[alternateName];
}
ENDLOOP;
END;
globalCount:
INT ←
LOOPHOLE[nameKey,
INT]
MOD 99999 / 8;
--some value which might differ next time ChipNDale is started
FiddleGlobal:
PROC [name: Rope.
ROPE]
RETURNS [Rope.
ROPE] =
BEGIN
globalCount ← globalCount MOD 1000000B + 1;
RETURN [IO.PutFR["%g@%g@0", IO.rope[name], IO.int[globalCount]]];
END;
FiddleName:
PROC [name: Rope.
ROPE, design:
CD.Design]
RETURNS [Rope.
ROPE] =
BEGIN
modifier: INT ← CDValue.FetchInt[design, $CDxNextInt] MOD 10000000000B;
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]];
CDValue.StoreInt[design, $CDxNextInt, modifier+1];
RETURN [name];
END;
Rename:
PUBLIC
PROC [design:
CD.Design, object:
CD.Object,
newName: Rope.ROPE ← NIL, fiddleName: BOOL←FALSE] RETURNS [done: BOOL ← FALSE] =
BEGIN
oldName: Rope.ROPE = CDDirectory.Name[object];
removed: BOOL = Remove[design, oldName, object];
IF removed
THEN {
back: BOOL ← Include[design, object, newName, fiddleName];
IF back THEN RETURN [done ← TRUE];
back ← Include[design, object, oldName, TRUE];
IF NOT back THEN ERROR CD.Error[programmingError, "rename removed an object"]
}
END;
Enumerate:
PUBLIC
PROC [design:
CD.Design, action: EachEntryAction]
RETURNS [quit:
BOOL] =
--enumerates objects currently in directory in unspecified order
--objects inserted/deleted during enumeration may or may not be seen
--applies action to each object until action returns TRUE or no more objects
--returns quit: TRUE if some action returns TRUE
BEGIN
EachPairAction: SymTab.EachPairAction ~ {
quit ← action[name: key, ob: NARROW[val, CD.Object]]
};
quit ← SymTab.Pairs[design.cellDirectory, EachPairAction]
END;
InstallDirectoryProcs:
PUBLIC
PROC [type:
REF
CD.ObjectClass]
RETURNS [
REF CDDirectory.DirectoryProcs] =
BEGIN
dp: REF CDDirectory.DirectoryProcs ~ NEW[CDDirectory.DirectoryProcs];
IF type.directoryProcs#
NIL
OR type.inDirectory
THEN
ERROR CD.Error[ec: doubleRegistration, explanation: "object type includes already directory"];
type.directoryProcs ← dp;
type.inDirectory ← TRUE;
dp.enumerateChildObjects ← DefaultEnumerate;
dp.replaceDirectChilds ← DefaultReplaceDirectChilds;
dp.another ← DefaultAnother;
dp.name ← DefaultName;
dp.setName ← DefaultSetName;
RETURN [dp]
END;
DefaultAnother: CDDirectory.AnotherProc =
--crazy another proc which makes a copy of the object-definition
BEGIN
newOb: CD.Object = NEW[CD.ObjectRep←me^];
newOb.properties ← CDProperties.DangerousCopyProps[me.properties];
IF to#NIL THEN [] ← Include[to, newOb];
RETURN [newOb]
END;
DefaultReplaceDirectChilds: CDDirectory.ReplaceDChildsProc =
BEGIN
ERROR
END;
DefaultEnumerate:
PROC [me:
CD.Object, p: CDDirectory.EnumerateObjectsProc, x:
REF] =
BEGIN
END;
DefaultSetName:
PROC [me:
CD.Object, r: Rope.
ROPE] =
BEGIN
CDProperties.PutPropOnObject[onto: me, prop: nameKey, val: r]
END;
DefaultName:
PROC [me:
CD.Object]
RETURNS [Rope.
ROPE] =
BEGIN
WITH CDProperties.GetPropFromObject[from: me, prop: nameKey]
SELECT
FROM
r: Rope.ROPE => RETURN [r];
ENDCASE => RETURN ["-no name"]
END;
-- -- -- -- -- -- -- -- -- -- -- --
Another:
PUBLIC PROC [me:
CD.Object, from, to:
CD.Design]
RETURNS [
CD.Object]
=
--CAUTION: goes only one level deep; caller MUST go down the hierachy and
--replace children if from#to; name might change due to conflicts
BEGIN
IF me.class.inDirectory
THEN
RETURN [CDDirectory.ObToDirectoryProcs[me].another[me, from, to]]
ELSE RETURN [me]
END;
Expand:
PUBLIC
PROC [me:
CD.Object, from, to:
CD.Design]
RETURNS [new:
CD.Object ←
NIL] =
--May succeed or not, returns NIL if no success;
--returned object is of expand-simpler object class (half ordered); but
-- it will generate exactly the same mask.
--When "me" later changes, this has no influence on result;
--Each call delivers a new copy of result
--goes only one level deep; caller MUST go down the hierachy and
--replace children if from#to; name might change due to conflicts
BEGIN
IF me.class.inDirectory
THEN {
expand: CDDirectory.AnotherProc = CDDirectory.ObToDirectoryProcs[me].expand;
IF expand#NIL THEN new ← expand[me, from, to];
}
END;
ExpandHard:
PUBLIC
PROC [me:
CD.Object, from, to:
CD.Design]
RETURNS [
CD.Object] =
BEGIN
new: CD.Object ← Expand[me, from, to];
IF new=
NIL
THEN {
new ← ExpandByDraw[me, from, to];
};
RETURN [new]
END;
ExpandRec:
TYPE =
RECORD [
cell: CD.Object,
cellPtr: CD.CellPtr,
hasContext: BOOL ← FALSE
];
ExpandByDraw:
PUBLIC
PROC [me:
CD.Object, from, to:
CD.Design]
RETURNS [
CD.Object] =
--me should not propagate
BEGIN
dummyApPtr: CD.Instance = NEW[CD.InstanceRep];
expandRef: REF ExpandRec = NEW[ExpandRec];
expandPr: CD.DrawRef = CD.CreateDrawRef[from];
expandPr.interestClip ← CDBasics.universe;
expandPr.drawRect ← ExpandBareRect;
IF me.class.objectType#$Import
THEN expandPr.drawChild ← ExpandChild;
--Must flatten Imports: cant change design of sub childs
expandPr.drawContext ← ExpandContext;
expandPr.devicePrivate ← expandRef;
dummyApPtr^.ob ← me;
expandRef.cell ← CDCells.CreateEmptyCell[];
expandRef.cellPtr ← NARROW[expandRef.cell.specificRef];
me.class.drawMe[inst: dummyApPtr, pos: [0, 0], orient: 0, pr: expandPr];
IF expandRef.cellPtr.contents#
NIL
AND ~expandRef.hasContext
THEN {
name: Rope.ROPE ← CDDirectory.Name[me];
IF Rope.IsEmpty[name] THEN name ← CDOps.Info[me];
expandRef.cellPtr.name ← Rope.Concat["!", name];
expandRef.cellPtr.dIr ← CDInstances.BoundingRectI[expandRef.cellPtr.contents];
expandRef.cell.size ← me.size; --we dont reposition! size might have been bad and we want to get exactly the same size back
expandRef.cellPtr.ir ← CD.InterestRect[me];
expandRef.cellPtr.useDIr ← FALSE;
expandRef.cellPtr.origin ← CD.ClientOrigin[me];
IF to#NIL THEN [] ← Include[design: to, object: expandRef.cell, fiddleName: TRUE];
RETURN [expandRef.cell]
};
RETURN [NIL]
END;
ExpandBareRect:
PROC [r:
CD.Rect, l:
CD.Layer, pr:
CD.DrawRef] =
BEGIN
expandRef: REF ExpandRec = NARROW[pr.devicePrivate];
inst:
CD.Instance ←
NEW[
CD.InstanceRep←[
ob: CDRects.CreateBareRect[size: CDBasics.SizeOfRect[r], l: l],
location: CDBasics.BaseOfRect[r],
selected: FALSE
]];
expandRef.cellPtr.contents ← CONS[inst, expandRef.cellPtr.contents];
END;
ExpandChild:
PROC [inst:
CD.Instance, pos:
CD.Position, orient:
CD.Orientation, pr:
REF
CD.DrawInformation]
-- CD.DrawProc -- =
BEGIN
--make an instance
expandRef: REF ExpandRec = NARROW[pr.devicePrivate];
newInst:
CD.Instance =
NEW[
CD.InstanceRep←[
ob: inst.ob,
location: pos,
orientation: orient,
selected: FALSE,
properties: CDProperties.DangerousCopyProps[inst.properties]
]];
expandRef.cellPtr.contents ← CONS[newInst, expandRef.cellPtr.contents];
END;
ExpandContext:
PROC [pr:
CD.DrawRef, proc:
CD.DrawContextLayerProc, ob:
CD.Object, pos:
CD.Position, orient:
CD.Orientation, layer:
CD.Layer] =
BEGIN
IF ob=
NIL
THEN {
NARROW[pr.devicePrivate, REF ExpandRec].hasContext ← TRUE;
pr.stopFlag^ ← TRUE;
}
ELSE {
IF pr.contextFilter=NIL THEN pr.contextFilter←NEW[CD.ContextFilter←ALL[Imager.black]];
CDDefaultProcs.DrawContext[pr, proc, ob, pos, orient, layer];
};
END;
-- -- -- -- -- -- -- -- -- -- -- --
RepositionList: TYPE = LIST OF CD.Object;
changeEvent: CDEvents.EventRegistration ~ CDEvents.RegisterEventType[$AfterChange];
ReplaceObject:
PUBLIC
PROC [design:
CD.Design, old:
CD.Object, new:
CD.Object, off:
CD.Position ← [0, 0]] =
--all over in the design replace old by new
--may be delayed
BEGIN
repRef:
REF CDDirectory.ReplaceRec ←
NEW[CDDirectory.ReplaceRec←[
old: old,
oldSize: old.size,
newSize: new.size,
new: new,
off: off
]];
IF design=NIL THEN ERROR;
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.WriteRope["** Tries to replace pushed in cell; does not work\n"];
ENDLOOP;
ReplaceAllChilds[design, repRef]
END;
RepositionObject:
PUBLIC
PROC [design:
CD.Design, ob:
CD.Object, oldSize:
CD.Position, baseOff:
CD.Position ← [0, 0]] =
--all over in the design tries to reposition ob;
--may be delayed
BEGIN
repRef:
REF CDDirectory.ReplaceRec ←
NEW[CDDirectory.ReplaceRec←[
old: ob,
oldSize: oldSize,
newSize: ob.size,
new: ob,
off: baseOff
]];
[] ← CDEvents.ProcessEvent[
ev: repositionEvent,
design: design,
x: NEW[CDDirectory.ReplaceRec ← repRef^], --copy for safety
listenToDont: FALSE
];
IF design#NIL THEN ReplaceAllChilds[design, repRef]
END;
ReplaceAllChilds:
PROC [design:
CD.Design, repRef:
REF CDDirectory.ReplaceRec] =
--design#NIL
BEGIN
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
--impossible; call me to debug this
ERROR;
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[boundTo: design, key: repositioningListKey, value: NIL];
CDOps.DelayedRedraw[design];
END;
DoReplaceDirectChild:
PUBLIC CDDirectory.ReplaceDChildsProc =
BEGIN
IF me.class.inDirectory
THEN
changed ← CDDirectory.ObToDirectoryProcs[me].replaceDirectChilds[me, design, replace];
IF changed THEN PropagateChange[me, design];
END;
DoReplaceAllChilds:
PUBLIC
PROC [design:
CD.Design, repList: CDDirectory.ReplaceList] =
BEGIN
ReplaceForOne: CDDirectory.EachEntryAction =
-- PROC [name: Rope.ROPE, ob: CD.Object] RETURNS [quit: BOOL�LSE] --
BEGIN
[] ← DoReplaceDirectChild[me: ob, design: design, replace: repList];
END;
FOR list: CDDirectory.ReplaceList ← repList, list.rest
WHILE list#
NIL
DO
list.first.newSize ← list.first.new.size;
ENDLOOP;
[] ← CDDirectory.Enumerate[design, ReplaceForOne];
FOR plist:
LIST
OF
CD.PushRec ← design.actual, plist.rest
WHILE plist#
NIL
DO
inst: CD.Instance ← plist.first.mightReplace;
SetOwner[plist.first.dummyCell.ob, design]; --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 {
realPos:
CD.Position = CDOrient.MapPoint[
pointInCell: rep.off,
cellSize: rep.oldSize,
cellInstOrient: inst.orientation,
cellInstPos: inst.location
];
fakePos:
CD.Position = CDOrient.MapPoint[
pointInCell: [0, 0],
cellSize: rep.newSize,
cellInstOrient: inst.orientation,
cellInstPos: [0, 0]
];
inst.location ← CDBasics.SubPoints[realPos, fakePos];
}
ENDLOOP;
[] ← CDCells.ReplaceDirectChildForDummyCells[plist.first.dummyCell.ob, repList];
ENDLOOP;
END;
PropagateChange:
PUBLIC PROC [ob:
CD.Object, design:
CD.Design] =
-- processes an CDEvent $AfterChange
BEGIN
[] ← CDEvents.ProcessEvent[changeEvent, design, ob];
END;
repositionEventKey: ATOM = $reposition;
repositionEvent: CDEvents.EventRegistration = CDEvents.RegisterEventType[repositionEventKey];
repositioningListKey: ATOM = $RepositioningList;
ownerKey: ATOM = $OwnerDesign; --HACK XXX: property is also used by cdcellsimpl
nameKey: REF ATOM = NEW[ATOM ← $Name]; -- make it non accessible, non write on file
[] ← CDProperties.RegisterProperty[ownerKey];
CDProperties.InstallProcs[prop: ownerKey, new: CDProperties.PropertyProcsRec[exclusive: TRUE]];
CDProperties.InstallProcs[prop: nameKey, new: CDProperties.PropertyProcsRec[exclusive: TRUE]];
CDValue.EnregisterKey[repositioningListKey];
END.