<> <> <> DIRECTORY CD, CDCallSpecific, CDDirectory, CDInline, CDOrient, CDProperties, CDValue, IO, Rope, SymTab, TerminalIO; CDDirectoryImpl: CEDAR MONITOR IMPORTS CD, CDDirectory, CDInline, CDOrient, CDProperties, CDValue, IO, Rope, SymTab, TerminalIO EXPORTS CDDirectory SHARES CD = BEGIN <<--all object which contain other objects are supposed to be in the directory;>> <<--which is necessary for enumeration and for repositioning>> EachEntryAction: TYPE = PROC [name: Rope.ROPE, ob: CD.ObPtr] RETURNS [quit: BOOL]; Fetch: PUBLIC PROC [design: CD.Design, name: Rope.ROPE] RETURNS [found: BOOL, object: CD.ObPtr_NIL] = <<--search for object in directory>> BEGIN x: SymTab.Val; [found, x] _ SymTab.Fetch[design.cellDirectory, name]; IF found THEN object _ NARROW[x, CD.ObPtr]; END; <<>> Remove: PUBLIC PROC [design: CD.Design, name: Rope.ROPE, expectObject: CD.ObPtr_NIL] RETURNS [done: BOOL_FALSE] = <<--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.ObPtr; found: BOOL; [found, object] _ Fetch[design, name]; IF found THEN { IF expectObject=NIL OR object=expectObject THEN { IF CDProperties.GetPropFromObject[from: object, prop: ownerKey]#design THEN ERROR CD.Error[callingError, "Removed object not in design"]; done _ SymTab.Delete[design.cellDirectory, name]; IF done THEN CDProperties.PutPropOnObject[onto: object, prop: ownerKey, val: NIL]; } } END; SetName: PROC[me: CD.ObPtr, r: Rope.ROPE] ~ INLINE { IF me.p.hasChildren THEN CDDirectory.ObToDirectoryProcs[me].setName[me, r] }; Include: PUBLIC PROC [design: CD.Design, object: CD.ObPtr, alternateName: Rope.ROPE_NIL, fiddleName: BOOL_TRUE] RETURNS [done: BOOL] = <<--it is an ERROR to include an object into several design's>> BEGIN name: Rope.ROPE _ CDDirectory.Name[object]; IF CDProperties.GetPropFromObject[from: object, prop: ownerKey]#NIL THEN ERROR CD.Error[callingError, "Included object already in a design"]; IF alternateName#NIL THEN name _ alternateName; IF name=NIL THEN name _ "-noname-"; DO IF SymTab.Insert[design.cellDirectory, name, object] THEN { SetName[object, name]; CDProperties.PutPropOnObject[onto: object, prop: ownerKey, val: design]; done _ TRUE; RETURN }; IF object = Fetch[design, name].object THEN { TerminalIO.WriteRope["object included twice in directory; debugging chipndale might be appropriate\n"]; }; IF NOT fiddleName THEN { done _ FALSE; RETURN }; name _ Rope.Concat[name, IO.PutFR[format: "@%g", v1: IO.int[LOOPHOLE[object, INT]/4 MOD 991]]] ENDLOOP; END; Rename: PUBLIC PROC [design: CD.Design, object: CD.ObPtr, newName: Rope.ROPE _ NIL] 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, FALSE]; 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.ObPtr]] }; quit _ SymTab.Pairs[design.cellDirectory, EachPairAction] END; InstallDirectoryProcs: PUBLIC PROC [type: REF CD.ObjectProcs] RETURNS [REF CDDirectory.DirectoryProcs] = BEGIN dp: REF CDDirectory.DirectoryProcs ~ NEW[CDDirectory.DirectoryProcs]; IF type.directoryProcs#NIL OR type.hasChildren THEN ERROR CD.Error[ec: doubleRegistration, explanation: "object type includes already directory"]; type.directoryProcs _ dp; type.hasChildren _ TRUE; dp.adjustItself _ DefaultAdjustItself; dp.repositionElements _ DefaultRepositionElements; dp.computeBounds _ DefaultComputeBounds; dp.enumerateChildObjects _ DefaultEnumerate; dp.key _ DefaultKey; dp.name _ DefaultName; dp.setName _ DefaultSetName; dp.setKey _ DefaultSetKey; RETURN [dp] END; DefaultAdjustItself: CDDirectory.AdjustItselfProc -- PROC [objToReposition: CD.ObPtr, newBound: CD.DesignRect] -- = BEGIN END; DefaultRepositionElements: CDDirectory.RepositionElementsProc -- PROC [me: CD.ObPtr, objToReposition: CD.ObPtr, oldSize: CD.DesignPosition, newBound: CD.DesignRect, design: CD.Design] -- = BEGIN END; DefaultComputeBounds: PROC [ob: CD.ObPtr] RETURNS [CD.DesignRect] = <<--returns bounds in coordinate system of ob itself>> BEGIN RETURN [CDInline.RectAt[[0,0], ob.size]] END; DefaultEnumerate: PROC [me: CD.ObPtr, p: CDDirectory.EnumerateObjectsProc, x: REF] = BEGIN END; DefaultSetName: PROC [me: CD.ObPtr, r: Rope.ROPE] = BEGIN CDProperties.PutPropOnObject[onto: me, prop: nameKey, val: r] END; DefaultSetKey: PROC [me: CD.ObPtr, r: Rope.ROPE] = BEGIN END; DefaultName: PROC [me: CD.ObPtr] RETURNS [Rope.ROPE] = BEGIN WITH CDProperties.GetPropFromObject[from: me, prop: nameKey] SELECT FROM r: Rope.ROPE => RETURN [r]; ENDCASE => RETURN [" no name"] END; DefaultKey: PROC [me: CD.ObPtr] RETURNS [Rope.ROPE] = BEGIN RETURN [NIL] END; -- -- -- -- -- -- -- -- -- -- -- -- ComputedBounds: PROC [ob: CD.ObPtr] RETURNS [CD.DesignRect] = INLINE <<--returns bounds in coordinate system of ob itself >> BEGIN RETURN [ IF ob.p.hasChildren THEN CDDirectory.ObToDirectoryProcs[ob].computeBounds[ob] ELSE DefaultComputeBounds[ob] ] END; <<>> RepositionList: TYPE = LIST OF CD.ObPtr; RepositionAnObject: PUBLIC PROC [design: CD.Design, objToReposition: CD.ObPtr] = <<--objToReposition.size must be old, not yet repositioned size;>> <<--(the actual reposition process may bepostboned until an started --reposition is finished; the started reposition should not be interferred --with objToReposition changing size.)>> <<--the size will be recomputed and corrected before return>> BEGIN IF CDProperties.GetPropFromObject[from: objToReposition, prop: ownerKey]#design THEN ERROR CD.Error[callingError, "object not in design"]; IF design=NIL THEN RepositionObjectOnDesign[NIL, objToReposition] ELSE { x: REF _ CDValue.Fetch[boundTo: design, key: $RepositioningList, propagation: design]; ref: REF RepositionList; IF x#NIL THEN { -- we are inside reposition process, remember object ref _ NARROW[x]; FOR l: RepositionList _ ref^, l.rest DO IF l.first=objToReposition THEN EXIT; IF l.rest=NIL THEN {l.rest _ LIST[objToReposition]; EXIT} ENDLOOP; RETURN }; <<-- we are not inside reposition process, start one>> ref _ NEW[RepositionList_LIST[objToReposition]]; CDValue.Store[boundTo: design, key: $RepositioningList, value: ref]; WHILE ref^#NIL DO RepositionObjectOnDesign[design, ref^.first]; ref^ _ ref^.rest ENDLOOP; CDValue.Store[boundTo: design, key: $RepositioningList, value: NIL]; }; END; RepositionObjectOnDesign: PROC [design: CD.Design, objToReposition: CD.ObPtr] = <<--this procedure called from RepositionAnObject only>> <<--objToReposition must have old, uncorrected size>> BEGIN oldSize: CD.DesignPosition = objToReposition.size; newBound: CD.DesignRect _ ComputedBounds[objToReposition]; AdjustItself: PROC [objToReposition: CD.ObPtr, newBound: CD.DesignRect] = INLINE <<--newBound is expected to be in coordinate system of objToReposition itself>> BEGIN IF objToReposition.p.hasChildren THEN { objToReposition.size _ CDInline.SizeOfRect[newBound]; CDDirectory.ObToDirectoryProcs[objToReposition].adjustItself[objToReposition, newBound]; }; END; EachEntryReposition: SymTab.EachPairAction --[key: Key, val: Val] RETURNS [quit: BOOLEAN] -- = <<--uses global "parameters": oldSize, newBound, objToReposition, design>> BEGIN ob: CD.ObPtr = NARROW[val]; quit _ FALSE; IF ob#objToReposition THEN -- this one is already in progress! IF ob.p.hasChildren THEN CDDirectory.ObToDirectoryProcs[ob].repositionElements[ob, objToReposition, oldSize, newBound, design] END; RepositionAllOthers: PROC [] = INLINE <<--relative globals used: oldSize, newBound, objToReposition, design>> BEGIN <<--reposition all of the actual design>> FOR l: LIST OF CD.PushRec _ design.actual, l.rest WHILE l#NIL DO RepositionApplicationList[l.first.specific.contents]; RepositionApplication[l.first.mightReplace] ENDLOOP; <<--reposition all cells>> <<--which may cause a Reposition of the some other cells recursively>> <<--the recursion stops iff the data structures do not contain recursive cells>> IF SymTab.Pairs[design.cellDirectory, EachEntryReposition] THEN ERROR; END; RepositionApplicationList: PROC [list: CD.ApplicationList] = INLINE <<--repositions all applications which call objToReposition>> <<--oldSize: size of the original rePositionList.first >> <<--objToReposition object needing reposition>> <<--newBound: bound of new objToReposition in coords of old rePositionList.first>> <<--(oldSize, newBound used by dynamic inner proc)>> <<--objToReposition.size is NOT used>> BEGIN FOR w: CD.ApplicationList _ list, w.rest WHILE w#NIL DO --IF w.first.ob=objToReposition THEN-- RepositionApplication[w.first]; ENDLOOP; END; RepositionApplication: PROC [aptr: CD.ApplicationPtr] = <<--repositions an application if it calls objToReposition>> <<--oldSize: size of the original objToReposition >> <<--objToReposition object needing reposition>> <<--newBound: bound of new objToReposition in coords of old objToReposition>> INLINE BEGIN IF aptr#NIL AND aptr.ob=objToReposition THEN BEGIN aptr.location _ CDOrient.MapPosition[ itemInCell: newBound, cellSize: oldSize, cellInstOrient: aptr.orientation, cellInstPos: aptr.location]; END END; <<-- RepositionObjectOnDesign>> IF CDInline.RectAt[[0, 0], oldSize] # newBound THEN { IF design#NIL THEN RepositionAllOthers[]; AdjustItself[objToReposition, newBound]; }; END; ownerKey: ATOM ~ $Owner; --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]]; END.