<> <> <> <> DIRECTORY CD, CDPrivate, CDDefaultProcs, CDEvents, CDBasics, Imager, RefTab, Rope, SafeStorage; CDImpl: CEDAR MONITOR IMPORTS CDDefaultProcs, CDEvents, RefTab, SafeStorage EXPORTS CD, CDPrivate SHARES CDPrivate = BEGIN Error: PUBLIC ERROR[ec: CD.ErrorCode _ programmingError, explanation: Rope.ROPE _ NIL] = CODE; permanent: ZONE = SafeStorage.GetPermanentZone[]; <<--assume everithing gets correct even if all references are lost, >> <<--don't care about memory area, hint only>> layers: PUBLIC REF ARRAY CD.Layer OF CDPrivate.LayerRef = permanent.NEW[ARRAY CD.Layer OF CDPrivate.LayerRef]; registerTechEvent: CDEvents.EventRegistration = CDEvents.RegisterEventType[$RegisterTechnology]; technologyRegistration: RefTab.Ref = RefTab.Create[]; -- contains technologies TechnologyPrivate: TYPE = REF TechnologyPrivateRep; TechnologyPrivateRep: PUBLIC TYPE = RECORD [ objectRegisterTab: RefTab.Ref, -- contains object types layerKeyTab: RefTab.Ref -- contains Layers ]; nilTechnologyPrivate: TechnologyPrivate = NEW[TechnologyPrivateRep _ [ objectRegisterTab: RefTab.Create[], --for technology dependant objects it contains NIL layerKeyTab: RefTab.Create[] ]]; RegisterObjectClass: PUBLIC PROC [objectType: ATOM, technology: CD.Technology_NIL] RETURNS [REF CD.ObjectClass] = <<--also initializes procedures with default values >> BEGIN done: BOOL; class: REF CD.ObjectClass = permanent.NEW[CD.ObjectClass]; class.technology _ technology; class.objectType _ objectType; class.further _ RefTab.Create[]; class.drawMe _ CDDefaultProcs.DrawMe; class.quickDrawMe _ CDDefaultProcs.QuickDrawMe; class.showMeSelected _ CDDefaultProcs.ShowMeSelected; class.hitInside _ CDDefaultProcs.HitInside; class.interestRect _ CDDefaultProcs.InterestRect; class.oldInsideRect _ DefaultOldInsideRect; class.inDirectory _ FALSE; class.wireTyped _ FALSE; class.describe _ CDDefaultProcs.Describe; class.describeInst _ CDDefaultProcs.DescribeInstance; class.origin _ CDDefaultProcs.Origin; IF technology=NIL THEN done _ RefTab.Insert[nilTechnologyPrivate.objectRegisterTab, objectType, class] ELSE { techPriv: TechnologyPrivate = technology.technologyPrivate; objectRegisterTab: RefTab.Ref = techPriv.objectRegisterTab; globFound: BOOL; x: REF; [globFound, x] _ RefTab.Fetch[nilTechnologyPrivate.objectRegisterTab, objectType]; <<--still check if it might be global>> IF globFound AND x#NIL THEN done _ FALSE ELSE { [] _ RefTab.Insert[nilTechnologyPrivate.objectRegisterTab, objectType, NIL]; <<--global register it used per technology>> done _ RefTab.Insert[objectRegisterTab, objectType, class]; -- technology register } }; IF NOT done THEN RETURN [NIL]; RETURN [class] END; FetchObjectClass: PUBLIC PROC [objectType: REF, technology: CD.Technology_NIL] RETURNS [REF CD.ObjectClass] = BEGIN x: REF; class: REF CD.ObjectClass _ NIL; found: BOOL _ FALSE; IF technology#NIL THEN { -- search in technology table techPriv: TechnologyPrivate = technology.technologyPrivate; [found, x] _ RefTab.Fetch[techPriv.objectRegisterTab, objectType]; }; IF NOT found THEN { -- search in global table [found, x] _ RefTab.Fetch[nilTechnologyPrivate.objectRegisterTab, objectType]; <<--may find it but have NIL value: then is technologydependant>> }; IF found THEN class _ NARROW[x]; RETURN [class] END; DefaultOldInsideRect: PROC [ob: CD.Object] RETURNS [CD.Rect] = BEGIN RETURN [ob.class.interestRect[ob]] END; lastLayer: CD.Layer _ 3; InitiateLayer: PROC [lev: CD.Layer, technology: CD.Technology_NIL, uniqueKey: ATOM] = BEGIN techPriv: TechnologyPrivate; layers[lev].technology _ technology; layers[lev].uniqueKey _ uniqueKey; IF technology=NIL THEN techPriv _ nilTechnologyPrivate ELSE { techPriv _ technology.technologyPrivate; technology.usedLayers _ CONS[lev, technology.usedLayers] }; [] _ RefTab.Insert[techPriv.layerKeyTab, uniqueKey, layers[lev]]; END; ConvertLayer: PUBLIC ENTRY PROC [technology: CD.Technology, uniqueKey: ATOM, into: CD.Layer] = <<--Helps conversion when layers are renamed>> BEGIN ENABLE UNWIND => NULL; techPriv: TechnologyPrivate; IF uniqueKey=NIL OR uniqueKey=$NIL THEN RETURN WITH ERROR Error[callingError, "bad uniqueKey"]; -- avoid problems with NIL as ATOM; any IO routine might use $NIL instead IF technology=NIL THEN techPriv _ nilTechnologyPrivate ELSE techPriv _ technology.technologyPrivate; [] _ RefTab.Insert[techPriv.layerKeyTab, uniqueKey, layers[into]]; END; NewLayer: PUBLIC ENTRY PROC [technology: CD.Technology_NIL, uniqueKey: ATOM] RETURNS [CD.Layer] = BEGIN ENABLE UNWIND => NULL; IF uniqueKey=NIL OR uniqueKey=$NIL THEN RETURN WITH ERROR Error[callingError, "bad uniqueKey"]; -- avoid problems with NIL as ATOM; any IO routine might use $NIL instead IF lastLayer>=CD.layerNum-1 THEN RETURN WITH ERROR Error[noResource, "too many layers have been requested; (probably too many different technologies are used)"]; lastLayer _ lastLayer+1; InitiateLayer[lastLayer, technology, uniqueKey]; RETURN [lastLayer] END; FetchLayer: PUBLIC PROC [t: CD.Technology, uniqueKey: ATOM] RETURNS [CD.Layer] = BEGIN found: BOOL_FALSE; l: CD.Layer _ CD.highLightError; x: REF; IF t#NIL THEN { techPriv: TechnologyPrivate = t.technologyPrivate; [found: found, val: x] _ RefTab.Fetch[techPriv.layerKeyTab, uniqueKey]; }; IF ~found THEN { [found: found, val: x] _ RefTab.Fetch[nilTechnologyPrivate.layerKeyTab, uniqueKey]; }; IF found THEN l _ NARROW[x, CDPrivate.LayerRef].number; RETURN [l] END; LayerTechnology: PUBLIC PROC [l: CD.Layer] RETURNS [CD.Technology] = BEGIN RETURN [layers[l].technology]; END; LayerKey: PUBLIC PROC [l: CD.Layer] RETURNS [ATOM] = BEGIN RETURN [layers[l].uniqueKey]; END; CreateDrawRef: PUBLIC PROC [design: CD.Design, deviceContext: Imager.Context] RETURNS [CD.DrawRef] = BEGIN class: CD.DrawRef = NEW[CD.DrawInformation]; class.interestClip _ CDBasics.universe; class.minimalSize _ 0; class.scaleHint _ 0.0; class.drawRect _ CDDefaultProcs.DrawRect; class.drawComment _ CDDefaultProcs.DrawComment; class.drawChild _ CDDefaultProcs.DrawChild; class.drawOutLine _ CDDefaultProcs.DrawOutLine; class.stopFlag _ NEW[BOOL _ FALSE]; class.drawContext _ CDDefaultProcs.DrawContext; class.deviceContext _ deviceContext; class.devicePrivate _ NIL; class.design _ design; class.setGround _ CDDefaultProcs.SetGround; RETURN [class] END; RegisterTechnology: PUBLIC PROC [key: ATOM, name: Rope.ROPE] RETURNS [CD.Technology] = <<--Returns NIL if key is already in use>> <<--This must be the only way to create data of type TechnologyRep>> <<--not ENTRY since RefTab.Insert does necessary monitoring and CDEvents.ProcessEvent>> <<--is dangerous>> BEGIN t: CD.Technology = permanent.NEW[CD.TechnologyRep]; IF ~RefTab.Insert[technologyRegistration, key, t] THEN { Error[doubleRegistration, "technology exist already"]; }; t.key _ key; t.name _ name; t.usedLayers _ NIL; t.technologyPrivate _ permanent.NEW[TechnologyPrivateRep _ [RefTab.Create[], RefTab.Create[]]]; [] _ CDEvents.ProcessEvent[ev: registerTechEvent, design: NIL, x: t]; RETURN[t] END; FetchTechnology: PUBLIC PROC [key: ATOM] RETURNS [CD.Technology] = <<--Returns NIL if key is not registered>> BEGIN x: REF; found: BOOL; tech: CD.Technology _ NIL; [found: found, val: x] _ RefTab.Fetch[technologyRegistration, key]; IF found THEN tech _ NARROW[x]; RETURN[tech] END; EnumerateTechnologies: PUBLIC PROC [proc: CD.TechnologyEnumerator] RETURNS [quit: BOOL] = BEGIN Action: RefTab.EachPairAction = { quit _ proc[NARROW[val]] }; quit _ RefTab.Pairs[technologyRegistration, Action]; END; IF registerTechEvent=NIL THEN ERROR; FOR l: CD.Layer IN CD.Layer DO layers[l] _ permanent.NEW[CDPrivate.LayerRec]; layers[l].number _ l; layers[l].globalUniqueKey _ layers[l]; ENDLOOP; InitiateLayer[CD.combined, NIL, $combined]; InitiateLayer[CD.highLightShade, NIL, $highLightShade]; InitiateLayer[CD.highLightError, NIL, $highLightError]; InitiateLayer[CD.backGround, NIL, $backGround]; END.