<> <> <> <> 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_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.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_FALSE] -- >> 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.