<> <> <> <> DIRECTORY CD, CDCells, CDCleanUp, CDDirectory, CDOps, CDProperties, CDSequencer, CDSimpleOps, CDValue, CedarProcess, Process, Rope, RuntimeError USING [UNCAUGHT], TerminalIO; CDCleanUpImpl: CEDAR MONITOR IMPORTS CDDirectory, CDCells, CDOps, CDSequencer, CDSimpleOps, CDProperties, CDValue, CedarProcess, Process, Rope, RuntimeError, TerminalIO EXPORTS CDCleanUp SHARES CD, CDDirectory = BEGIN EnumeratePossibleRoots: PROC [design: CD.Design, proc: CDDirectory.EnumerateObjectsProc, x: REF_NIL, inclDir: BOOL_TRUE] = { EachEntry: CDDirectory.EachEntryAction = {proc[ob, x]}; FOR pushed: LIST OF CD.PushRec _ design.actual, pushed.rest WHILE pushed#NIL DO FOR list: CD.InstanceList _ pushed.first.specific.contents, list.rest WHILE list#NIL DO proc[list.first.ob, x]; ENDLOOP; ENDLOOP; IF inclDir THEN [] _ CDDirectory.Enumerate[design, EachEntry]; }; ReplaceFunnys: PROC [design: CD.Design, rootOb: CD.Object, key: REF] = { <<--Replaces all object with funny classes in place,>> <<--hopes that this is allowed... but it does not know funny classes and their restrictions>> <<--IF rootOb#NIL only rootOb and its descendants are handled>> <<--Of course, there shouldn't be any funny classes...>> <<--key: a property key which will be used freely... NIL is ok>> realKey: REF ~ IF key=NIL THEN NEW[INT] ELSE key; DirtyExpand: PROC [ob: CD.Object] = { WHILE ob.class.internalWrite=NIL DO <<--real dirty, but it never happens because internalWrite is never NIL, except... >> new: CD.Object; tm, cm: CDDirectory.DMode; own: REF; [new, tm, cm] _ CDDirectory.Expand[ob]; --we ignore modes; class is fishy own _ CDProperties.GetObjectProp[ob, $OwnerDesign]; IF new=NIL THEN { TerminalIO.PutF["**** %g is fishy\n", [rope[CDDirectory.Name[ob]]]]; EXIT; }; CDProperties.AppendProps[looser: new.properties, winner: ob.properties, putOnto: new]; TerminalIO.PutF["* %g has been modified in all designs\n", [rope[CDDirectory.Name[ob]]]]; ob^ _ new^; --real dirty-- CDProperties.PutObjectProp[ob, $OwnerDesign, own]; CDCells.SetSimplificationTreshhold[ob, 50]; ENDLOOP; }; DoIt: CDDirectory.EnumerateObjectsProc = { <<--uses globals: realKey>> IF me.class.inDirectory AND CDProperties.GetObjectProp[me, realKey]#x THEN { CDProperties.PutProp[me, realKey, x]; DirtyExpand[me]; CDDirectory.EnumerateChildObjects[me, DoIt, x]; }; }; IF rootOb#NIL THEN DoIt[rootOb, NEW[INT]] ELSE EnumeratePossibleRoots[design, DoIt, NEW[INT]]; IF key=NIL THEN RemoveProperties[design, realKey]; }; <<>> PreTag: PROC [design: CD.Design, rootOb: CD.Object, tag: REF, key: REF] = { <<--figures out whether objects have funny classes and should be replaced >> <<--or whether objects should be replaced because they are in different designs:>> <<--such objects will be taken, expanded or copied, included in the directory and put >> <<--onto the tag property>> DoIt: CDDirectory.EnumerateObjectsProc = { <<--uses globals: design, tag, key>> IF me.class.inDirectory AND CDProperties.GetObjectProp[me, key]#x THEN { tm, cm: CDDirectory.DMode; --cm is actually ignored; we go down hierarchy anyway useOb, new: CD.Object; UseNewAndTmToFinish: PROC [includeIfNecessary: BOOL] RETURNS [failed: BOOL _ FALSE] = { <<--uses new, tm, useOb, me and tag>> IF new=NIL OR new.class.internalWrite=NIL THEN { new _ CDDirectory.ExpandByDraw[me: useOb]; tm _ ready; --cell }; IF tm=immutable AND new#NIL THEN { [new, tm, cm] _ CDDirectory.Another[me: new, into: design, friendly: TRUE]; IF new=NIL OR tm=immutable OR new.class.internalWrite=NIL THEN { new _ CDDirectory.ExpandByDraw[me: useOb]; tm _ ready; }; }; IF new=NIL THEN { TerminalIO.PutF["**** %g (%g) is fishy\n", [rope[CDDirectory.Name[me]]], [rope[CDOps.ObjectRope[me]]]]; RETURN [failed_TRUE] }; IF tm=ready AND includeIfNecessary THEN <<--includeIfNecessary: we dont trust objects returning tm=ready if>> <<--they had funny classes>> [] _ CDDirectory.Include[design, new, CDDirectory.Name[me]]; <<--cm: childs are copied or included when going down the main recursion>> useOb _ new; CDProperties.PutProp[me, tag, useOb]; }; CDProperties.PutProp[me, key, x]; --don't visit me a second time new _ useOb _ me; <<--fix funny classes>> IF useOb.class.internalWrite=NIL THEN {--it never happens, except... WHILE new#NIL AND new.class.internalWrite=NIL DO [new, tm, cm] _ CDDirectory.Expand[me: new, into: design, friendly: TRUE]; ENDLOOP; IF UseNewAndTmToFinish[FALSE].failed THEN RETURN; }; <<--fix funny designs>> IF CDProperties.GetObjectProp[useOb, $OwnerDesign]=NIL THEN { <<--not yet included into any design>> [] _ CDDirectory.Include[design, useOb, CDDirectory.Name[me]]; } ELSE IF CDDirectory.Fetch[design, CDDirectory.Name[useOb]].object#useOb THEN { <<--included into a wrong design>> [new, tm, cm] _ CDDirectory.Another[me: useOb, into: design, friendly: TRUE]; IF UseNewAndTmToFinish[TRUE].failed THEN RETURN; }; <<--go down hierarchy>> CDDirectory.EnumerateChildObjects[useOb, DoIt, x]; }; }; IF rootOb#NIL THEN DoIt[rootOb, NEW[INT]] ELSE EnumeratePossibleRoots[design, DoIt, NEW[INT]]; }; ReplaceTaggedOneLevel: PROC [design: CD.Design, ob: CD.Object, tag: REF] = { ForCells: PROC [cell: CD.Object, tag: REF] = INLINE { EachInst: CDCells.InstEnumerator = { WITH CDProperties.GetObjectProp[inst.ob, tag] SELECT FROM ob: CD.Object => inst.ob _ ob; ENDCASE => NULL; }; [] _ CDCells.EnumerateInstances[cell, EachInst]; }; --ForCells ForNonCells: PROC [design: CD.Design, ob: CD.Object, tag: REF] = { replaces: CDDirectory.ReplaceList _ NIL; FindReplaces: CDDirectory.EnumerateObjectsProc = { WITH CDProperties.GetObjectProp[me, tag] SELECT FROM new: CD.Object => { FOR l: CDDirectory.ReplaceList _ replaces, l.rest WHILE l#NIL DO IF l.first.old=me THEN RETURN; ENDLOOP; replaces _ CONS[NEW[CDDirectory.ReplaceRec _ [old: me, new: new]], replaces]; }; ENDCASE => NULL; }; --FindReplaces <<>> <<--ForNonCells>> CDDirectory.EnumerateChildObjects[ob, FindReplaces, NIL]; IF replaces#NIL THEN [] _ CDDirectory.ObToDirectoryProcs[ob].replaceDirectChilds[ob, design, replaces]; }; --ForNonCells <<--ReplaceTaggedOneLevel>> IF CDCells.IsCell[ob] THEN ForCells[ob, tag] ELSE ForNonCells[design, ob, tag]; }; --ReplaceTaggedOneLevel ReplaceTagged: PUBLIC PROC [design: CD.Design, replaceBy: REF, rename: BOOL _ TRUE, key: REF] = { myVal: REF ~ NEW[INT]; realKey: REF ~ IF key=NIL THEN NEW[INT] ELSE key; DoChilds: CDDirectory.EnumerateObjectsProc = { <<--globals: design, realKey>> <<--x: visit key >> IF me.class.inDirectory AND CDProperties.GetObjectProp[me, realKey]#x THEN { CDProperties.PutProp[me, realKey, x]; ReplaceTaggedOneLevel[design, me, replaceBy]; CDDirectory.EnumerateChildObjects[me, DoChilds, x]; }; }; --DoChilds EachEntry: CDDirectory.EachEntryAction = { WITH CDProperties.GetObjectProp[ob, replaceBy] SELECT FROM new: CD.Object => { removed: BOOL _ CDDirectory.Remove[design, name, ob]; IF ~removed THEN { DoChilds[ob, myVal]; TerminalIO.PutRopes["** problem with replacing ", name, "\n"]; }; IF new.class.inDirectory THEN { [] _ CDDirectory.Include[design, new]; IF rename THEN [] _ CDDirectory.Rename[design, new, name]; }; ob _ new; }; ENDCASE => NULL; DoChilds[ob, myVal]; }; --EachEntry <<--ReplaceTagged>> FOR pushed: LIST OF CD.PushRec _ design.actual, pushed.rest WHILE pushed#NIL DO FOR list: CD.InstanceList _ pushed.first.specific.contents, list.rest WHILE list#NIL DO WITH CDProperties.GetObjectProp[list.first.ob, replaceBy] SELECT FROM ob: CD.Object => { list.first.ob _ ob; DoChilds[ob, myVal]; } ENDCASE => NULL; ENDLOOP; ENDLOOP; [] _ CDDirectory.Enumerate[design, EachEntry]; IF key=NIL THEN RemoveProperties[design, realKey]; }; --ReplaceTagged <<>> FixDirectory: PROC [design: CD.Design] = { EachEntry: CDDirectory.EachEntryAction = { IF ob.class.inDirectory AND ~Rope.Equal[name, CDDirectory.Name[ob]] THEN { TerminalIO.PutF["** name conflict %g <--> %g\n", [rope[CDDirectory.Name[ob]]], [rope[name]]]; <<--not that easy... [ob's could be in directory twice and worse]>> <> }; }; [] _ CDDirectory.Enumerate[design, EachEntry]; }; CleanUp: PUBLIC PROC [design: CD.Design, rootOb: CD.Object] = { myKey: REF ATOM ~ NEW[ATOM_$UsedForCleanup]; replaceBy: REF ATOM ~ NEW[ATOM_$UsedForCleanup]; CDSimpleOps.FlushDeletedCache[design]; IF rootOb=NIL THEN FixDirectory[design]; PreTag[design, rootOb, replaceBy, myKey]; ReplaceTagged[design, replaceBy, TRUE, myKey]; RemoveProperties[design, myKey]; RemoveProperties[design, replaceBy]; myKey^ _ $MayBeRemoved; replaceBy^ _ $MayBeRemoved; }; <<--==== property removing =====>> RemoveRecord: TYPE = RECORD [ --monitored; used to remember what properties to forget running: BOOL _ FALSE, --a forget loop process is running right now forgetNext: LIST OF REF ANY _ NIL --use next time in forget loop ]; DepositAndStart: ENTRY PROC [design: CD.Design, rr: REF RemoveRecord, key: REF] = { <<--deposit property key in forget queue; starts forget loop process if necessary >> IF rr#NIL THEN { rr.forgetNext _ CONS[key, rr.forgetNext]; IF ~rr.running THEN { rr.running _ TRUE; TRUSTED {Process.Detach[FORK RemoveLoop[design, rr]]} }; }; }; FetchAndStop: ENTRY PROC [rr: REF RemoveRecord] RETURNS [forgetNow: LIST OF REF ANY _ NIL] = { <<--fetch and remove property keys from the forget queue >> <<--if queue is empty: mark forget loop process as NOT running >> IF rr#NIL THEN { forgetNow _ rr.forgetNext; rr.forgetNext _ NIL; IF forgetNow=NIL THEN rr.running _ FALSE; } }; RemoveLoop: PROC [design: CD.Design, rr: REF RemoveRecord] = { <<--loops and forgets properties, as long as there are some>> forgetNow: LIST OF REF ANY; RemoveInner: PROC [design: CD.Design] = { RemoveAll: PROC [ob: CD.Object] = { FOR l: LIST OF REF ANY _ forgetNow, l.rest WHILE l#NIL DO CDProperties.PutObjectProp[onto: ob, prop: l.first, val: NIL]; Process.Yield[]; ENDLOOP; }; RPEachChildren: CDDirectory.EnumerateObjectsProc = { RemoveAll[me]; }; RPEachDirectoryEntry: CDDirectory.EachEntryAction = { RemoveAll[ob]; IF ob.class.inDirectory THEN CDDirectory.EnumerateChildObjects[me: ob, p: RPEachChildren]; }; [] _ CDDirectory.Enumerate[design: design, action: RPEachDirectoryEntry]; }; CedarProcess.SetPriority[CedarProcess.Priority[background]]; DO forgetNow _ FetchAndStop[rr]; IF forgetNow=NIL THEN EXIT; RemoveInner[design ! RuntimeError.UNCAUGHT => CONTINUE]; ENDLOOP; }; RemoveProperties: PUBLIC PROC [design: CD.Design, key: REF] = { GetRemoveRecord: PROC [d: CD.Design] RETURNS [rr: REF RemoveRecord] = { WITH CDValue.Fetch[d, $CDCleanUpPrivate, design] SELECT FROM r: REF RemoveRecord => RETURN [r]; ENDCASE => NULL; [] _ CDValue.StoreConditional[d, $CDCleanUpPrivate, NEW[RemoveRecord]]; rr _ GetRemoveRecord[d]; }; rr: REF RemoveRecord ~ GetRemoveRecord[design]; DepositAndStart[design, rr, key]; }; <<>> <<--============================>> CleanupCommand: PROC [comm: CDSequencer.Command] = { n: INT; TerminalIO.PutRope["cleanup directory\n"]; n _ CDDirectory.DirSize[comm.design]; CleanUp[comm.design, NIL]; IF n = CDDirectory.DirSize[comm.design] THEN TerminalIO.PutF["design was ok; has %g entries in directory\n", [integer[n]]] ELSE TerminalIO.PutF["design was not ok; previously had %g; now has %g entries in directory\n", [integer[n]], [integer[CDDirectory.DirSize[comm.design]]] ]; }; CDSequencer.ImplementCommand[key: $CheckDir, proc: CleanupCommand, queue: doQueue]; END.