<> <> <> <> <> <<>> <> DIRECTORY CD, CDBottomUp, CDCells, CDCommandOps, CDCommandOpsExtras2, CDDirectory, CDImports, CDOps, CDProperties, CDSequencer, IO, RefTab, Rope, TerminalIO; CDFeatureCheckImpl: CEDAR PROGRAM IMPORTS CD, CDBottomUp, CDCells, CDCommandOps, CDCommandOpsExtras2, CDDirectory, CDImports, CDOps, CDProperties, CDSequencer, RefTab, Rope, TerminalIO = BEGIN MsgProc: TYPE = PROC [ob: CD.Object] RETURNS [msg: Rope.ROPE_NIL]; State: TYPE = RefTab.Ref; FeatureTab: PROC [state: State] RETURNS [featureTab: RefTab.Ref] = INLINE { featureTab _ NARROW[state]; }; ReadOnlyCell: PROC [ob: CD.Object] RETURNS [readOnlyCell: CD.Object_NIL] = BEGIN readOnlyCell _ ob; WHILE ob#NIL AND ob.class.inDirectory AND ~CDCells.IsCell[ob] DO readOnlyCell _ CDDirectory.Expand[ob, NIL, NIL, FALSE].new; IF readOnlyCell=ob OR readOnlyCell=NIL THEN readOnlyCell _ CDDirectory.ExpandByDraw[ob]; ob _ readOnlyCell; ENDLOOP; END; CheckClass: PROC [ob: CD.Object] RETURNS [msg: Rope.ROPE_NIL] = <<--this is independent of particular design rules>> BEGIN WITH CDProperties.GetObjectProp[ob, $CDFeatureCheck] SELECT FROM mp: REF MsgProc => RETURN [mp[ob]]; r: Rope.ROPE => RETURN [r]; ENDCASE => WITH CDProperties.GetProp[ob.class, $CDFeatureCheck] SELECT FROM mp: REF MsgProc => RETURN [mp[ob]]; ENDCASE => RETURN [NIL] END; BadLayer: PROC [ob: CD.Object] RETURNS [msg: Rope.ROPE] = { msg _ Rope.Cat["layer ", CDOps.LayerName[ob.layer], " used in ", CDOps.ObjectInfo[ob]] }; CheckContainer: PROC [state: State, ob: CD.Object] RETURNS [msg: Rope.ROPE _ NIL] = BEGIN recurse: BOOL_FALSE; mustCheckLayer: BOOL_FALSE; layerFound: BOOL_FALSE; CheckRef: PROC [val: REF] = BEGIN IF val=NIL THEN { IF ~ob.class.inDirectory AND ~ob.class.symbolic THEN { IF recurse OR (val_RefTab.Fetch[FeatureTab[state], $CDFeatureCheckOthers].val)#NIL THEN msg _ Rope.Cat["class not enabled: ", CDOps.ObjectInfo[ob]] ELSE {recurse _ TRUE; CheckRef[val]} }; } ELSE WITH val SELECT FROM a: ATOM => { IF a=$T THEN layerFound _ TRUE ELSE IF a=CD.LayerKey[ob.layer] THEN layerFound _ TRUE ELSE mustCheckLayer _ TRUE }; lora: LIST OF REF ANY => FOR l: LIST OF REF ANY _ lora, l.rest WHILE (l#NIL AND msg=NIL) DO CheckRef[l.first]; ENDLOOP; loa: LIST OF ATOM => {layerKey: ATOM ~ CD.LayerKey[ob.layer]; FOR ll: LIST OF ATOM _ loa, ll.rest WHILE ll#NIL DO IF layerKey=ll.first OR ll.first=$T THEN {layerFound _ TRUE; EXIT}; ENDLOOP; mustCheckLayer _ TRUE; }; mp: REF MsgProc => msg _ mp[ob]; rp: REF CD.Rect => { sz: CD.Position _ CD.InterestSize[ob]; IF sz.xrp.x2 OR sz.y>rp.y2 THEN msg _ Rope.Cat[CDOps.ObjectInfo[ob], " too large"]; }; r: Rope.ROPE => IF ~Rope.IsEmpty[r] THEN msg _ Rope.Cat[CDOps.ObjectInfo[ob], " ", r]; ENDCASE => msg _ Rope.Cat["class forbidden: ", CDOps.ObjectInfo[ob]]; END; CheckRef[RefTab.Fetch[FeatureTab[state], ob.class.objectType].val]; IF Rope.IsEmpty[msg] AND mustCheckLayer AND ~layerFound THEN msg _ BadLayer[ob]; IF Rope.IsEmpty[msg] THEN msg _ CheckClass[ob]; IF Rope.IsEmpty[msg] THEN msg _ NIL; END; CheckTopChilds: PROC [state: State, ob: CD.Object] RETURNS [msg: Rope.ROPE _ NIL] = BEGIN cnt: INT _ 0; ob1: CD.Object _ ReadOnlyCell[ob]; IF ob1=NIL THEN msg _ "failed to expand" ELSE { cp: CD.CellPtr _ NARROW[ob1.specificRef]; FOR l: CD.InstanceList _ cp.contents, l.rest WHILE l#NIL DO IF ~l.first.ob.class.inDirectory THEN { msg1: Rope.ROPE _ CheckContainer[state, l.first.ob]; IF msg1#NIL THEN { cnt _ cnt+1; IF cnt<4 THEN msg _ Rope.Cat[msg, "\n | ", msg1] ELSE IF cnt=4 THEN msg _ Rope.Cat[msg, "\n |"] ELSE msg _ Rope.Cat[msg, "|"] }; } ENDLOOP; }; END; CheckOneLevel: PROC [state: State, ob: CD.Object] RETURNS [msg: Rope.ROPE _ NIL] = BEGIN msg _ CheckContainer[state, ob]; IF Rope.IsEmpty[msg] THEN msg _ CheckTopChilds[state, ob]; END; DoExt: CDBottomUp.DoProc = BEGIN msg: Rope.ROPE _ NIL; IF CDImports.IsImport[ob] THEN { ip: CDImports.ImportPtr _ NARROW[ob.specificRef]; IF ip.boundInstance#NIL THEN [] _ handle.DoRecurse[ip.boundInstance.ob] ELSE msg _ "not bound"; }; TerminalIO.WriteRopes["checking ", CDOps.ObjectInfo[ob]]; IF msg=NIL THEN msg _ CheckOneLevel[NARROW[handle.data], ob]; IF msg=NIL THEN TerminalIO.WriteRope[" ok\n"] ELSE { handle.cnt _ handle.cnt+1; TerminalIO.WriteRopes["\n ** ", msg, "\n"] }; val _ msg; IF handle.design#NIL THEN CDSequencer.CheckAborted[handle.design]; END; ReUseExt: CDBottomUp.ReUseProc = BEGIN TerminalIO.WriteRopes["previously checked ", CDOps.ObjectInfo[ob]]; WITH previousVal SELECT FROM r: Rope.ROPE => { handle.cnt _ handle.cnt+1; TerminalIO.WriteRopes["\n ** ", r, "\n"] }; ENDCASE => TerminalIO.WriteRope[" ok\n"]; IF handle.design#NIL THEN CDSequencer.CheckAborted[handle.design]; END; HierarchicalFeatureCheckComm: PROC [comm: CDSequencer.Command] = BEGIN HierarchicalFeatureCheck: PROC [featureChecker: CDBottomUp.Class, design: CD.Design, state: RefTab.Ref, ob: CD.Object] = BEGIN h: CDBottomUp.Handle _ CDBottomUp.StartRecurse[featureChecker, design, ob, state].handle; IF h.cnt=0 THEN TerminalIO.WriteRope["no errors found\n"] ELSE TerminalIO.WriteF1["error(s) found in %g object(s)\n", [integer[h.cnt]]] END; inst: CD.Instance _ CDCommandOps.TheInstance[comm, "Hierarchical feature checking"]; IF inst#NIL THEN { IF ~inst.ob.class.inDirectory THEN { TerminalIO.WriteRopes[" object not composed\n"]; RETURN }; WITH CDProperties.GetAtomProp[$CDFeatureCheck, $CDFeatureCheck] SELECT FROM rt: RefTab.Ref => { featureChecker: CDBottomUp.Class; key: REF _ rt.Fetch[$CDFeatureCheckKey].val; text: Rope.ROPE _ CDCommandOps.ToRope[rt.Fetch[$CDFeatureCheckName].val]; IF key=NIL THEN key_NEW[INT]; TerminalIO.WriteRopes["feature set used: [", text, "]\n"]; IF ISTYPE[key, ATOM] THEN TerminalIO.WriteRopes[" [ key = ", CDCommandOps.ToRope[key], " ]\n"]; featureChecker _ CDBottomUp.Register[DoExt, ReUseExt, key, $CDFeatureCheck ! CD.Error => GOTO oops]; HierarchicalFeatureCheck[featureChecker, comm.design, rt, inst.ob]; }; ENDCASE => TerminalIO.WriteRope[" no feature table is assigned\n"] } EXITS oops => TerminalIO.WriteRope[" failed to read parameters from atom\n"] END; CDCommandOpsExtras2.RegisterWithMenu[menu: $ProgramMenu, entry: "Feature checking", doc: "needs commandfile be previously set up", proc: HierarchicalFeatureCheckComm, key: $HFCheck]; END.