<<>> <> <> <> <> <<>> DIRECTORY Atom, RefTab, UnsafePropList, Xl, XlCursor, XlUtils, XTk, XTkDB, XTkFastAccessPrivate, XTkFriends, XTkOps, XTkPrivate; XTkImpl: CEDAR MONITOR LOCKS widget USING widget: Widget IMPORTS RefTab, UnsafePropList, Xl, XlCursor, XlUtils, XTk, XTkDB, XTkFastAccessPrivate EXPORTS XTk, XTkFriends, XTkOps, XTkPrivate = BEGIN OPEN Xl, XTk, XTkFriends; detailsForSynchronous: PUBLIC Xl.Details Ź NEW[Xl.DetailsRec Ź [synchronous: TRUE, localErrors: inline]]; detailsForFlushNoErrors: PUBLIC Xl.Details Ź NEW[Xl.DetailsRec Ź [flush: now, errorMatch: NEW[Xl.MatchRep Ź [proc: IgnoreErrors, handles: NIL, tq: Xl.CreateTQ[]]]]]; detailsForFlushSoonNoErrors: PUBLIC Xl.Details Ź NEW[Xl.DetailsRec Ź [flush: soon, errorMatch: NEW[Xl.MatchRep Ź [proc: IgnoreErrors, handles: NIL, tq: Xl.CreateTQ[]]]]]; detailsForNoErrors: PUBLIC Xl.Details Ź NEW[Xl.DetailsRec Ź [errorMatch: NEW[Xl.MatchRep Ź [proc: IgnoreErrors, handles: NIL, tq: Xl.CreateTQ[]]]]]; debugErrCount: CARD Ź 0; IgnoreErrors: Xl.EventProcType = {debugErrCount Ź debugErrCount+1}; classTable: RefTab.Ref Ź RefTab.Create[]; aliasTable: RefTab.Ref Ź RefTab.Create[]; --key: "alias" val: "key" keyTable: RefTab.Ref Ź RefTab.Create[]; --key: "key" val: not importasnt XTkBadAlias: SIGNAL = CODE; <<--Resumable signal from debugger (while debugging application) >> <<--Resume means reuse is ok; abort means reuse is not ok>> AliasNotifierKey: PUBLIC PROC [key: REF, alias: REF Ź NIL] = { <<--not monitored because typically called in module initializations>> IF alias=NIL THEN alias Ź key; IF RefTab.Fetch[keyTable, alias].found THEN { IF alias#key THEN SIGNAL XTkBadAlias; --this aliases is somebody elses key }; IF ~RefTab.Insert[aliasTable, alias, key] THEN { <<--alias already defined>> IF RefTab.Fetch[aliasTable, alias].val#key THEN SIGNAL XTkBadAlias; --definition has changed }; [] Ź RefTab.Store[keyTable, key, key]; --keys can have many aliases }; <<>> AllNotifiers: TYPE = LIST OF NotifierHead; NotifierHead: TYPE = RECORD [key: REF, list: NotifierList]; NotifierList: TYPE = LIST OF NofierRec; NofierRec: TYPE = RECORD [proc: WidgetNotifyProc, registerData: REF Ź NIL]; CallNotifierList: PROC [list: NotifierList, widget: Widget, callData: REF Ź NIL, event: Event Ź NIL] = { FOR l: NotifierList Ź list, l.rest WHILE l#NIL DO l.first.proc[widget: widget, registerData: l.first.registerData, callData: callData, event: event]; ENDLOOP }; CallNotifiers: PUBLIC PROC [widget: Widget, key: REF, callData: REF Ź NIL, event: Event Ź NIL] = { FOR al: AllNotifiers Ź NARROW[widget.notifiers], al.rest WHILE al#NIL DO IF al.first.key=key THEN { CallNotifierList[al.first.list, widget, callData, event]; RETURN; }; ENDLOOP; }; RemoveNotifiers: PUBLIC PROC [widget: Widget, key: REF] = { [] Ź GetNRemoveNotifiers[widget, key]; }; GetNRemoveNotifiers: ENTRY PROC [widget: Widget, key: REF] RETURNS [notifiers: NotifierList Ź NIL] = { head: AllNotifiers Ź NARROW[widget.notifiers]; IF head#NIL THEN { IF head.first.key=key THEN { notifiers Ź head.first.list; widget.notifiers Ź head.rest; RETURN }; WHILE head.rest#NIL DO IF head.rest.first.key=key THEN { notifiers Ź head.rest.first.list; head.rest Ź head.rest.rest; RETURN }; head Ź head.rest ENDLOOP }; }; UnregisterFromSingleList: INTERNAL PROC [list: NotifierList, proc: WidgetNotifyProc, registerData: REF Ź NIL] RETURNS [NotifierList] = { WHILE list#NIL AND list.first.proc=proc AND list.first.registerData=registerData DO list _ list.rest ENDLOOP; IF list#NIL THEN { lag: NotifierList _ list; WHILE lag#NIL AND lag.rest#NIL DO IF lag.rest.first.proc=proc AND lag.rest.first.registerData=registerData THEN {lag.rest _ lag.rest.rest} ELSE {lag _ lag.rest}; ENDLOOP; }; RETURN [list] }; InternalRegisterNotifier: INTERNAL PROC [widget: Widget, real: REF, proc: WidgetNotifyProc, registerData: REF Ź NIL] = { head: AllNotifiers Ź NARROW[widget.notifiers]; this: AllNotifiers Ź NIL; FOR al: AllNotifiers Ź head, al.rest WHILE al#NIL DO IF al.first.key=real THEN {this Ź al; EXIT}; ENDLOOP; IF this=NIL THEN { this Ź CONS[NotifierHead[key: real, list: NIL], head]; widget.notifiers Ź this }; this.first.list Ź CONS[[proc, registerData], this.first.list] }; RegisterNotifier: PUBLIC PROC [widget: Widget, key: REF, procLX: WidgetNotifyProc, registerData: REF Ź NIL] = { EntryRegisterNotifier: ENTRY PROC [widget: Widget, real: REF, proc: WidgetNotifyProc, registerData: REF] = { InternalRegisterNotifier[widget, real, proc, registerData]; }; p: WidgetNotifyProc Ź procLX; --checks globality real: REF Ź RefTab.Fetch[aliasTable, key].val; IF real=NIL THEN real Ź key; EntryRegisterNotifier[widget, real, p, registerData]; }; UnRegisterNotifier: PUBLIC PROC [widget: Widget, key: REF, procLX: WidgetNotifyProc, registerData: REF Ź NIL] = { EntryUnRegisterNotifier: ENTRY PROC [widget: Widget, real: REF, proc: WidgetNotifyProc, registerData: REF] = { head: AllNotifiers Ź NARROW[widget.notifiers]; this: AllNotifiers Ź NIL; FOR al: AllNotifiers Ź head, al.rest WHILE al#NIL DO IF al.first.key=real THEN {this Ź al; EXIT}; ENDLOOP; IF this#NIL AND this.first.list#NIL THEN this.first.list _ UnregisterFromSingleList[this.first.list, proc, registerData]; }; p: WidgetNotifyProc Ź procLX; --checks globality real: REF Ź RefTab.Fetch[aliasTable, key].val; IF real=NIL THEN real Ź key; EntryUnRegisterNotifier[widget, real, p, registerData]; }; CallAndRegisterOnPostRealize: PUBLIC <> PROC [widget: Widget, proc: WidgetNotifyProc, registerData: REF Ź NIL] = { p: WidgetNotifyProc Ź proc; --checks globality MustCall: ENTRY PROC [widget: Widget, proc: WidgetNotifyProc, registerData: REF] RETURNS [mustCall: BOOL] = { mustCall Ź widget.state=realized; InternalRegisterNotifier[widget, postWindowCreationLRReal, p, registerData] }; IF widget.state>=dead THEN RETURN; IF MustCall[widget, proc, registerData] THEN p[widget, registerData]; }; NewNotifyKey: PROC [a: ATOM] RETURNS [key: REF ATOM] = { key Ź NEW[ATOMŹa]; AliasNotifierKey[key: key, alias: a]; }; preWindowCreationLRKey: PUBLIC ATOM Ź $preWindowCreation; preWindowCreationKey: PUBLIC ATOM Ź $preWindowCreation; postWindowCreationLRKey: PUBLIC ATOM Ź $postWindowCreation; postWindowCreationKey: PUBLIC ATOM Ź $postWindowCreation; postConfigureLRKey: PUBLIC ATOM Ź $postConfigure; postConfigureKey: PUBLIC ATOM Ź $postConfigure; postWindowDestructionLRKey: PUBLIC ATOM Ź $postWindowDestruction; postWindowDestructionKey: PUBLIC ATOM Ź $postWindowDestruction; <<>> preStopFastAccessKey: PUBLIC ATOM Ź $preStopFastAccess; postStopFastAccessLRKey: PUBLIC ATOM Ź $postStopFastAccess; postStopFastAccessKey: PUBLIC ATOM Ź $postStopFastAccess; bindScreenLRKey: PUBLIC ATOM Ź $bindScreen; bindScreenKey: PUBLIC ATOM Ź $bindScreen; forgetScreenLRKey: PUBLIC ATOM Ź $forgetScreen; forgetScreenKey: PUBLIC ATOM Ź $forgetScreen; postWidgetDestructionKey: PUBLIC ATOM Ź $postWidgetDestruction; preWindowCreationLRReal: REF ATOM Ź NewNotifyKey[preWindowCreationLRKey]; postWindowCreationLRReal: REF ATOM Ź NewNotifyKey[postWindowCreationLRKey]; postConfigureLRReal: REF ATOM Ź NewNotifyKey[postConfigureLRKey]; postWindowDestructionLRReal: REF ATOM Ź NewNotifyKey[postWindowDestructionLRKey]; preStopFastAccessReal: REF ATOM Ź NewNotifyKey[preStopFastAccessKey]; postStopFastAccessLRReal: REF ATOM Ź NewNotifyKey[postStopFastAccessLRKey]; forgetScreenLRReal: REF ATOM Ź NewNotifyKey[forgetScreenLRKey]; bindScreenLRReal: REF ATOM Ź NewNotifyKey[bindScreenLRKey]; postWidgetDestructionReal: REF ATOM Ź NewNotifyKey[postWidgetDestructionKey]; AddPermanentMatch: PUBLIC PROC [widget: Widget, matchRep: MatchRep, generate: SetOfEvent] = { EntryPart: ENTRY PROC [widget: Widget, matchRep: MatchRep, generate: SetOfEvent] RETURNS [realized: BOOL] = { widget.attributes.eventMask Ź Xl.ORSetOfEvents[widget.attributes.eventMask, generate]; widget.matchListX Ź CONS[matchRep, widget.matchListX]; realized Ź widget.state=realized AND widget.window#Xl.nullWindow AND widget.actualMapping=0 THEN {maySkip[x] Ź TRUE; proposed.pos.x Ź widget.s.geometry.pos.x}; IF widget.s.geometry.pos.y>=0 THEN {maySkip[y] Ź TRUE; proposed.pos.y Ź widget.s.geometry.pos.y}; IF widget.s.geometry.size.width>0 THEN {maySkip[w] Ź TRUE; proposed.size.width Ź widget.s.geometry.size.width}; IF widget.s.geometry.size.height>0 THEN {maySkip[h] Ź TRUE; proposed.size.height Ź widget.s.geometry.size.height}; IF widget.s.geometry.borderWidth>0 THEN {maySkip[b] Ź TRUE; proposed.borderWidth Ź widget.s.geometry.borderWidth}; IF maySkip=gAllTrue THEN RETURN [proposed]; }; IF widget.state>realized AND GetWidgetFlag[widget, preferredSizeFromDB] THEN { IF maySkip[x] AND maySkip[y] AND maySkip[b] THEN preferred.size Ź XTkDB.GetSizeFromDB[widget] ELSE preferred Ź XTkDB.GetGeometryFromDB[widget]; IF preferred.pos.x>=0 THEN {maySkip[x] Ź TRUE; proposed.pos.x Ź preferred.pos.x}; IF preferred.pos.y>=0 THEN {maySkip[y] Ź TRUE; proposed.pos.y Ź preferred.pos.y}; IF preferred.size.width>0 THEN {maySkip[w] Ź TRUE; proposed.size.width Ź preferred.size.width}; IF preferred.size.height>0 THEN {maySkip[h] Ź TRUE; proposed.size.height Ź preferred.size.height}; IF preferred.borderWidth>=0 THEN {maySkip[b] Ź TRUE; proposed.borderWidth Ź preferred.borderWidth}; IF maySkip=gAllTrue THEN RETURN [proposed]; }; preferred Ź widget.s.class.preferredSizeLR[widget, mode, proposed, maySkip]; }; PreStopFastAccess: PUBLIC TerminateProc = { <<<>>> Recurse: EachChild = {PreStopFastAccess[child, reason]}; IF widget.fastAccessAllowed=ok THEN { parent: Widget Ź widget.parent; widget.fastAccessAllowed Ź warned; CallNotifiers[widget, preStopFastAccessReal, IF reason=normal THEN $normal ELSE $error]; <<--sub to super order for no good reason>> FOR class: Class Ź widget.s.class, class.super WHILE class#NIL DO IF class.preStopFastAccess#NIL THEN class.preStopFastAccess[widget, reason]; ENDLOOP; ShallowInternalEnumerateChildren[widget, Recurse]; }; }; FullStopFastAccessRecurseLR: PROC [w: Widget, protectPaintTQ: PROC [TQ], reason: TerminationReason] = { <<<>>> <<<>>> <<<>>> Recurse: EachChild = { FullStopFastAccessRecurseLR[child, protectPaintTQ, reason] }; IF w.state>=warned THEN RETURN; IF w.fastAccessAllowed=ok THEN PreStopFastAccess[w, reason]; w.state Ź warned; <<--sub to super order for no good reason>> FOR class: Class Ź w.s.class, class.super WHILE class#NIL DO IF class.fullStopFastAccessLR#NIL THEN class.fullStopFastAccessLR[w, protectPaintTQ, reason]; ENDLOOP; ShallowInternalEnumerateChildren[w, Recurse]; FOR list: LIST OF TQ Ź GetNRemoveSyncsFastAccess[w], list.rest WHILE list#NIL DO protectPaintTQ[list.first]; ENDLOOP; }; synchFastAccessKey: REF INT ~ NEW[INT]; SynchronizeFastAccess: PUBLIC ENTRY PROC [widget: Widget, protectTQ: TQ] = TRUSTED { IF protectTQ#NIL THEN { WITH UnsafePropList.GetProp[@widget.props, synchFastAccessKey] SELECT FROM lst: LIST OF TQ => { <<--rarely used, not worth optimizing>> list: LIST OF TQ Ź CONS[protectTQ, lst]; [] Ź UnsafePropList.PutProp[LOOPHOLE[@widget.props], synchFastAccessKey, list]; } ENDCASE => { UnsafePropList.TrustedAddNewProp[LOOPHOLE[@widget.props], synchFastAccessKey, LIST[protectTQ]]; }; }; }; GetNRemoveSyncsFastAccess: ENTRY PROC [widget: Widget] RETURNS [LIST OF TQ Ź NIL] = TRUSTED { <<--Removes all registered TQ's for SynchronizeFastAccess and returns them. >> <<--Used on all widgets; optimizing worth while.>> old: REF ~ UnsafePropList.RemProp[LOOPHOLE[@widget.props], synchFastAccessKey]; WITH old SELECT FROM lst: LIST OF TQ => RETURN [lst]; ENDCASE => {} }; FullStopFastAccessLR: PUBLIC PROC [w: Widget, reason: TerminationReason] = { <<<>>> <<<>>> <<--collect tqs and wait a little for slow stoppers>> tqSet: XTkFastAccessPrivate.TQSet Ź NIL; MyQueueTQ: PROC [waitTQ: TQ] = { IF waitTQ#NIL AND waitTQ#w.rootTQ THEN tqSet Ź XTkFastAccessPrivate.Include[tqSet, waitTQ] }; IF w.state>=warned THEN RETURN; FullStopFastAccessRecurseLR[w, MyQueueTQ, reason]; IF tqSet#NIL THEN XTkFastAccessPrivate.Synchronize[tqSet]; CallNotifiers[w, postStopFastAccessLRReal, $normal]; }; DestroyWidgetLR: PUBLIC PROC [widget: Widget] = { DestroyChild: XTk.EachChild = { IF child.state> [] Ź UnsafePropList.PutProp[LOOPHOLE[@widget.props], key, value]; }; GetWidgetProp: PUBLIC PROC [widget: Widget, key: REF] RETURNS [REF] = TRUSTED { <> RETURN [UnsafePropList.GetProp[LOOPHOLE[@widget.props], key]] }; HasSubClass: PUBLIC PROC [widget: Widget, class: Class] RETURNS [BOOL Ź FALSE] = { FOR super: Class Ź widget.s.class.super, super.super WHILE super # NIL DO IF super=class THEN RETURN [TRUE]; ENDLOOP; }; HasSubClassKey: PUBLIC PROC [widget: Widget, classKey: ATOM] RETURNS [BOOL Ź FALSE] = { FOR super: Class Ź widget.s.class.super, super.super WHILE super # NIL DO IF super.key = classKey THEN RETURN [TRUE]; ENDLOOP; }; RootWidget: PUBLIC PROC [widget: Widget] RETURNS [Widget] = { WHILE widget.parent#NIL DO widget Ź widget.parent ENDLOOP; RETURN [widget]; }; BorderWidth: PUBLIC PROC [w: Widget] RETURNS [bw: INT] = { bw Ź w.s.geometry.borderWidth; IF bw<0 THEN { p: Widget ~ w.parent; IF p=NIL THEN bw Ź 0 ELSE bw Ź BorderWidth[p] }; }; CreateClass: PUBLIC PROC [basicMethods: BasicMethodsRec Ź []] RETURNS [class: ImplementorClass] = { CallSubCreateClass: PROC [superClass: Class, newClass: ImplementorClass] = { <<--recurse ancestor first-->> IF superClass.super#NIL THEN CallSubCreateClass[superClass.super, newClass]; <<--do the job for this level-->> IF superClass.createSubClass#NIL THEN superClass.createSubClass[superClass, newClass, newClass=superClass]; }; sup: Class Ź IF basicMethods.super=NIL THEN defaultSuper --used for default procedure values but not for chaining ELSE basicMethods.super; cDataIdx: NAT Ź sup.cDataIdx+sup.cDataNum; <<--inherit by copy>> IF basicMethods.configureLR = NIL THEN basicMethods.configureLR Ź sup.configureLR; IF basicMethods.actualCreateWindowLR = NIL THEN basicMethods.actualCreateWindowLR Ź sup.actualCreateWindowLR; IF basicMethods.pleaseResizeChild = NIL THEN basicMethods.pleaseResizeChild Ź sup.pleaseResizeChild; IF basicMethods.preferredSizeLR = NIL THEN basicMethods.preferredSizeLR Ź sup.preferredSizeLR; IF basicMethods.classNameHint = NIL THEN basicMethods.classNameHint Ź sup.classNameHint; IF basicMethods.className = NIL THEN basicMethods.className Ź sup.className; IF basicMethods.destroyWindowLR=NIL AND basicMethods.super=NIL THEN basicMethods.destroyWindowLR Ź SimpleDestroyWindowLR; <<--set up>> class Ź NEW[ClassRec[cDataIdx+basicMethods.cDataNum]]; class.flags Ź basicMethods.addFlags; class.key Ź basicMethods.key; class.classNameHint Ź basicMethods.classNameHint; class.super Ź basicMethods.super; --! no chaining to defaultSuper (sup) class.wDataIdx Ź sup.wDataIdx+sup.wDataNum; class.wDataNum Ź basicMethods.wDataNum; class.internalEnumerateChildren Ź basicMethods.internalEnumerateChildren; class.superWithIEC Ź IF sup.internalEnumerateChildren#NIL THEN sup ELSE sup.superWithIEC; class.configureLR Ź basicMethods.configureLR; class.actualCreateWindowLR Ź basicMethods.actualCreateWindowLR; class.destroyWindowLR Ź basicMethods.destroyWindowLR; class.removeChildLR Ź basicMethods.removeChildLR; class.preferredSizeLR Ź basicMethods.preferredSizeLR; class.initInstPart Ź basicMethods.initInstPart; class.preStopFastAccess Ź basicMethods.preStopFastAccess; class.fullStopFastAccessLR Ź basicMethods.fullStopFastAccessLR; class.bindScreenLX Ź basicMethods.bindScreenLX; class.forgetScreenLR Ź basicMethods.forgetScreenLR; class.destroyWidget Ź basicMethods.destroyWidget; class.className Ź basicMethods.className; class.pleaseResizeChild Ź basicMethods.pleaseResizeChild; class.createSubClass Ź basicMethods.createSubClass; class.cDataIdx Ź cDataIdx; class.cDataNum Ź basicMethods.cDataNum; class.eventMask Ź Xl.ORSetOfEvents[basicMethods.eventMask, sup.eventMask]; class.cursorKey Ź IF basicMethods.cursorKey=NIL THEN sup.cursorKey ELSE basicMethods.cursorKey; class.backgroundKey Ź IF basicMethods.backgroundKey=NIL THEN sup.backgroundKey ELSE basicMethods.backgroundKey; class.borderColorKey Ź IF basicMethods.borderColorKey=NIL THEN sup.borderColorKey ELSE basicMethods.borderColorKey; FOR i: INT IN [0..cDataIdx) DO class.cClassData[i] Ź sup.cClassData[i]; ENDLOOP; IF class.super#NIL THEN class.flags Ź OrClassFlags[class.flags, class.super.flags]; CallSubCreateClass[class, class]; [] Ź RefTab.Store[classTable, class.key, class]; }; OrClassFlags: PROC [cf1, cf2: ClassFlags] RETURNS [ClassFlags] = { RETURN [LOOPHOLE[Basics.BITOR[LOOPHOLE[cf1], LOOPHOLE[cf2]]]] }; FindClass: PUBLIC PROC [key: ATOM] RETURNS [Class] = { RETURN [NARROW[RefTab.Fetch[classTable, key].val]] }; SpecificsCount: PROC [class: Class] RETURNS [NAT] = INLINE { RETURN [class.wDataIdx + class.wDataNum] }; InitClassField: PUBLIC PROC [classField: Class, class: Class] RETURNS [Class] = { <<--initializes or restricts classField to superclasses of class>> IF classField=NIL THEN RETURN [class] ELSE { original: Class Ź classField; WHILE original # NIL AND original # class DO original Ź original.super ENDLOOP; IF original # class THEN { ERROR; --inconsistent class definition (sometimes caused by re-loading a super class) }; RETURN [classField] }; }; InheritedConfigureLRProc: PUBLIC PROC [superClass: Class] RETURNS [ConfigureProc] = { WHILE superClass.super#NIL AND superClass.configureLR=superClass.super.configureLR DO superClass Ź superClass.super ENDLOOP; RETURN [superClass.configureLR]; }; FindScreen: PROC [widget: Widget] RETURNS [Screen] = { <<--called before window is set up !>> <<<>>> <<--try to find using inheritance>> FOR w: Widget Ź widget, w.parent WHILE w#NIL DO IF w.screenDepth#NIL THEN RETURN [w.screenDepth.screen]; ENDLOOP; <<--try to find screen using visual>> IF widget.visual#nullVisual THEN { FOR i: NAT IN [0..ScreenDepthCount[widget.connection]) DO sd: ScreenDepth Ź NthScreenDepth[widget.connection, i]; FOR vl: LIST OF READONLY VisualType Ź sd.visuals, vl.rest WHILE vl#NIL DO IF widget.visual=vl.first.visual THEN RETURN [sd.screen]; ENDLOOP; ENDLOOP; }; <<--dont search for a screen supporting that depth... >> <<--a reasonable root should have something set up at least>> RETURN [DefaultScreen[widget.connection]]; }; InheritDepth: PROC [widget: Widget] = { IF widget.depth<=0 THEN { FOR w: Widget Ź widget.parent, w.parent WHILE w#NIL DO IF w.depth>0 THEN { widget.depth Ź w.depth; IF w.screenDepth#NIL AND w.screenDepth.depth=widget.depth THEN widget.screenDepth Ź w.screenDepth; RETURN }; ENDLOOP; } }; SetupScreenDepth: PUBLIC PROC [widget: Widget] = { IF widget.depth<=0 AND widget.screenDepth#NIL THEN { widget.depth Ź widget.screenDepth.depth; }; IF widget.depth<=0 THEN InheritDepth[widget]; IF widget.screenDepth=NIL THEN { screen: Screen Ź FindScreen[widget]; IF widget.depth>0 THEN { <<--check existence of required depth on screen >> FOR sdl: ScreenDepthL Ź screen.screenDepthL, sdl.rest WHILE sdl#NIL DO IF widget.depth=sdl.first.depth THEN {widget.screenDepth Ź sdl.first; RETURN}; ENDLOOP; <<--well; to bad if we guessed the first screen and it doesnt provide the depth...>> <<--but root widgets should be more clever and provide screenDepth>> ERROR; } ELSE { <<--try inheriting a screenDepth and use its depth >> FOR w: Widget Ź widget.parent, w.parent WHILE w#NIL DO IF w.screenDepth#NIL THEN { widget.screenDepth Ź w.screenDepth; widget.depth Ź widget.screenDepth.depth; RETURN }; ENDLOOP; <<--make a screenDepth up >> <<--try 1 bit per pixel first>> FOR sdl: ScreenDepthL Ź screen.screenDepthL, sdl.rest WHILE sdl#NIL DO IF sdl.first.depth=1 AND sdl.first.nVisualTypes>0 THEN { widget.screenDepth Ź sdl.first; widget.depth Ź widget.screenDepth.depth; RETURN }; ENDLOOP; <<--try rootDepth >> FOR sdl: ScreenDepthL Ź screen.screenDepthL, sdl.rest WHILE sdl#NIL DO IF sdl.first.depth=screen.rootDepth AND sdl.first.nVisualTypes>0 THEN { widget.screenDepth Ź sdl.first; widget.depth Ź widget.screenDepth.depth; RETURN }; ENDLOOP; <<--try any bit per pixel>> FOR sdl: ScreenDepthL Ź screen.screenDepthL, sdl.rest WHILE sdl#NIL DO IF sdl.first.nVisualTypes>0 THEN { widget.screenDepth Ź sdl.first; widget.depth Ź widget.screenDepth.depth; RETURN }; ENDLOOP; ERROR; }; }; }; FindVisual: PROC [widget: Widget] RETURNS [Visual Ź nullVisual] = { v: Xl.Visual Ź widget.visual; IF v=nullVisual THEN { <<--try inheriting from parent>> IF widget.parent#NIL AND widget.screenDepth=widget.parent.screenDepth THEN RETURN [widget.parent.visual]; --most frequent <<--if it can not be inherited it should be specified!>> <<--I'm to lazy to make one up, and wouldn't know which>> ERROR; } ELSE { <<--check whether supplied visual is legal>> FOR vtl: LIST OF READONLY VisualType Ź widget.screenDepth.visuals, vtl.rest WHILE vtl#NIL DO IF vtl.first.visual=v THEN RETURN [v]; ENDLOOP; ERROR; --visual not supported by screen for this depth }; }; IScreenBound: PROC [widget: Widget] RETURNS [BOOL] = INLINE { RETURN [widget.state<=screened]; }; ScreenBound: PUBLIC PROC [widget: Widget] RETURNS [BOOL] = { RETURN [IScreenBound[widget]]; }; BindScreenFromParent: PROC [widget: Widget] = { IF ~IScreenBound[widget] THEN { parent: Widget Ź widget.parent; --crash if parent doesn't exist or isn't IScreenBound is ok IF ~IScreenBound[parent] THEN ERROR; BindScreenLR[widget, parent.rootTQ, parent.screenDepth.screen, parent.screenDepth]; }; }; HardScreenFromParentLR: PROC [child: Widget] = { parent: Widget Ź child.parent; IF ~IScreenBound[parent] THEN ERROR; BindScreenLR[child, parent.rootTQ, parent.screenDepth.screen, parent.screenDepth]; }; <<>> AssignParentAndCheckScreenLR: PUBLIC PROC [child, parent: Widget] = { child.parent Ź parent; IF IScreenBound[parent] THEN HardScreenFromParentLR[child] }; <<>> BindScreenLR: PUBLIC PROC [widget: Widget, rootTQ: TQ, screen: Xl.Screen, screenDepth: Xl.ScreenDepth Ź NIL] = { Recurse: EachChild = {BindScreenLR[child, rootTQ, screen, screenDepth]}; IF widget.state>=dead THEN ERROR; IF ~IScreenBound[widget] THEN { IF screen=NIL THEN screen Ź screenDepth.screen; widget.state Ź screened; widget.connection Ź screen.connection; widget.rootTQ Ź rootTQ; <<--sub to super order to give subclass first chance to recognize not yet initialized values>> FOR class: Class Ź widget.s.class, class.super WHILE class#NIL DO IF class.bindScreenLX#NIL THEN class.bindScreenLX[widget, rootTQ, screen, screenDepth]; ENDLOOP; IF widget.screenDepth=NIL THEN widget.screenDepth Ź screenDepth; CallNotifiers[widget, bindScreenLRReal, NIL<>]; ShallowInternalEnumerateChildren[widget, Recurse]; }; }; ForgetScreenLR: PUBLIC PROC [widget: Widget] = { Recurse: EachChild = {ForgetScreenLR[child]}; IF IScreenBound[widget] THEN { reason: TerminationReason Ź errorConnection; IF widget.fastAccessAllowed> FOR class: Class Ź widget.s.class, class.super WHILE class#NIL DO IF class.forgetScreenLR#NIL THEN class.forgetScreenLR[widget, errorWindow]; ENDLOOP; SuperForgetScreenLR[widget, errorWindow] }; }; <<>> deadConnection: Xl.Connection Ź XlUtils.DeadConnection[$NoServer]; SuperForgetScreenLR: TerminateProc = INLINE { a: Xl.Attributes Ź []; --get an accessible copy with the illegal values widget.depth Ź 0; widget.visual Ź Xl.nullVisual; widget.attributes.backgroundPixmap Ź a.backgroundPixmap; widget.attributes.backgroundPixel Ź a.backgroundPixel; widget.attributes.borderPixmap Ź a.borderPixmap; widget.attributes.borderPixel Ź a.borderPixel; widget.attributes.backingPlanes Ź a.backingPlanes; widget.attributes.backingPixel Ź a.backingPixel; widget.attributes.colorMap Ź a.colorMap; widget.attributes.cursor Ź a.cursor; widget.window Ź Xl.nullWindow; widget.connection Ź deadConnection; --using a non NIL value allows to avoid NIL tests before painting with a widget.connection widget.screenDepth Ź NIL; widget.rootTQ Ź NIL; }; ShallowInternalEnumerateChildren: PUBLIC PROC [widget: Widget, proc: EachChild, data: REF Ź NIL] = { FOR class: Class Ź widget.s.class, class.superWithIEC WHILE class#NIL DO IF class.internalEnumerateChildren#NIL THEN IF class.internalEnumerateChildren[widget, class, proc, data].stop THEN EXIT; ENDLOOP; }; DestroyWindowLR: PUBLIC TerminateProc = { Recurse: EachChild = { DestroyWindowLR[child, reason]; }; IF widget.state=dead THEN RETURN; IF widget.actualMapping=unconfigured THEN RETURN; IF widget.actualMapping=mapped AND reason=normal AND widget.fastAccessAllowed=ok AND Xl.Alive[widget.connection] THEN { widget.actualMapping Ź unmapped; Xl.UnmapWindow[widget.connection, widget.window, detailsForNoErrors]; }; IF widget.fastAccessAllowed=ok THEN FullStopFastAccessLR[widget, reason]; widget.state Ź MAX[screened, widget.state]; ShallowInternalEnumerateChildren[widget, Recurse]; FOR class: Class Ź widget.s.class, class.super WHILE class#NIL DO IF class.destroyWindowLR#NIL THEN class.destroyWindowLR[widget, reason]; ENDLOOP; CallNotifiers[widget, postWindowDestructionLRReal, NIL]; }; <<>> ConfigureLR: PUBLIC ConfigureProc = { existW, createW, destroyW: BOOL; IF widget.state=dead THEN RETURN; IF widget.actualMapping>=unconfigured THEN { widget.actualMapping Ź unconfigured; IF mapping=dontUse AND widget.parent#NIL AND widget.parent.actualMapping { IF widget.actualMapping=mapped THEN mapping Ź unmapped ELSE mapping Ź dontUse }; mapIfUnmapped => { IF widget.actualMapping=unmapped THEN mapping Ź mapped ELSE mapping Ź dontUse }; unmapIfUnconfigured => { IF widget.actualMapping=unconfigured THEN mapping Ź unmapped ELSE mapping Ź dontUse }; mapIfUnconfigured => { IF widget.actualMapping=unconfigured THEN mapping Ź mapped ELSE mapping Ź dontUse }; ENDCASE => { IF mapping = widget.actualMapping THEN mapping Ź dontUse; }; IF mapping<=unmapped THEN { IF widget.parent#NIL THEN { IF widget.parent.actualMapping>=unconfigured THEN mapping Ź dontUse; } ELSE { IF widget.state > screened THEN mapping Ź dontUse; }; }; existW Ź widget.actualMapping CallNotifiers[widget, postWindowCreationLRReal, NIL]; existW => CallNotifiers[widget, postConfigureLRReal, NIL]; ENDCASE => {}; }; }; BorderColorDefined: PROC [w: Widget] RETURNS [BOOL] = INLINE { RETURN [w.attributes.borderPixmap#illegalPixmap OR w.attributes.borderPixel#illegalPixel] }; AssignToActual: PROC [widget: Widget, geometry: Xl.Geometry, mapping: Mapping] = INLINE { <> IF geometry.pos.x # dontUse THEN widget.actual.pos.x Ź geometry.pos.x; IF geometry.pos.y # dontUse THEN widget.actual.pos.y Ź geometry.pos.y; IF geometry.size.width # dontUse THEN widget.actual.size.width Ź geometry.size.width; IF geometry.size.height # dontUse THEN widget.actual.size.height Ź geometry.size.height; IF geometry.borderWidth # dontUse THEN widget.actual.borderWidth Ź geometry.borderWidth; IF mapping # dontUse THEN widget.actualMapping Ź mapping; }; SimpleConfigureOneLevelLR: PUBLIC ConfigureProc = { EntryOrEventMask: ENTRY PROC [widget: Widget] = { widget.attributes.eventMask Ź Xl.ORSetOfEvents[widget.attributes.eventMask, widget.s.class.eventMask]; }; existW, createW, destroyW: BOOL; existW Ź widget.actualMapping widget.attributes.cursor Ź XlCursor.SharedStandardCursor[widget.connection, rc]; rwp: REF WidgetProc => rwp[widget]; ENDCASE => {}; }; IF widget.attributes.backgroundPixel=illegalPixel AND IllegalPixmap[widget.attributes.backgroundPixmap] THEN { WITH widget.s.class.backgroundKey SELECT FROM a: ATOM => { widget.attributes.backgroundPixel Ź SELECT a FROM $white => widget.screenDepth.screen.whitePixel, $black => widget.screenDepth.screen.blackPixel, $none => illegalPixel, ENDCASE => widget.screenDepth.screen.whitePixel; }; rwp: REF WidgetProc => rwp[widget]; ENDCASE => {}; }; IF ~BorderColorDefined[widget] THEN { WITH widget.s.class.borderColorKey SELECT FROM a: ATOM => { widget.attributes.borderPixel Ź SELECT a FROM $white => widget.screenDepth.screen.whitePixel, $black => widget.screenDepth.screen.blackPixel, $none => illegalPixel, ENDCASE => widget.screenDepth.screen.blackPixel; }; rwp: REF WidgetProc => rwp[widget]; ENDCASE => {}; }; }; IF geometry.pos.x = widget.actual.pos.x THEN geometry.pos.x Ź dontUse; IF geometry.pos.y = widget.actual.pos.y THEN geometry.pos.y Ź dontUse; IF geometry.size.width = widget.actual.size.width THEN geometry.size.width Ź dontUse; IF geometry.size.height = widget.actual.size.height THEN geometry.size.height Ź dontUse; IF geometry.borderWidth = widget.actual.borderWidth THEN geometry.borderWidth Ź dontUse; IF mapping = widget.actualMapping THEN mapping Ź dontUse; <<-->> AssignToActual[widget, geometry, mapping]; <<-->> SELECT TRUE FROM createW => { EntryOrEventMask[widget]; IF mapping=dontUse THEN widget.actualMapping Ź mapping Ź mapped; widget.s.class.actualCreateWindowLR[widget]; }; existW => { c: Xl.Connection ~ widget.connection; win: Xl.Window ~ widget.window; IF Xl.Alive[c] AND win#Xl.nullWindow THEN { IF mapping=unmapped THEN Xl.UnmapWindow[c, win, detailsForNoErrors]; Xl.ConfigureWindow[c: c, window: win, geometry: geometry]; IF mapping=mapped THEN Xl.MapWindow[c, win, detailsForNoErrors]; }; }; ENDCASE => { }; }; SimpleDestroyWindowLR: PUBLIC TerminateProc = { c: Xl.Connection ~ widget.connection; win: Xl.Window ~ widget.window; widget.actualMapping Ź MAX[widget.actualMapping, unconfigured]; IF reason=normal AND Xl.Alive[c] AND win#Xl.nullWindow THEN { Xl.DestroyWindow[c, win, detailsForNoErrors]; }; widget.window Ź Xl.nullWindow; }; DontMapCreateWindowLR: PUBLIC WidgetProc = { visual: Visual Ź FindVisual[widget]; parentWindow: Xl.Window Ź widget.parent.window; widget.window Ź Xl.CreateWindow[c: widget.connection, matchList: CollectMatchesLR[widget], parent: parentWindow, geometry: widget.actual, visual: visual, depth: widget.depth, attributes: widget.attributes]; }; DefaultActualCreateWindowLR: PUBLIC WidgetProc = { DontMapCreateWindowLR[widget]; IF widget.actualMapping=mapped THEN Xl.MapWindow[widget.connection, widget.window]; }; IgnorePleaseResizeChild: PUBLIC WidgetNChildProc = { }; CollectMatchesLR: PUBLIC PROC [widget: Widget] RETURNS [ml: Xl.MatchList Ź NIL] = { FOR lx: LIST OF MatchRep Ź widget.matchListX, lx.rest WHILE lx # NIL DO m: Match Ź NEW[MatchRep Ź lx.first]; IF m.tq=NIL THEN m.tq Ź widget.rootTQ; ml Ź CONS[m, ml]; ENDLOOP; IF widget.matchList1 # NIL THEN { GetMatchList1: ENTRY PROC [widget: Widget] RETURNS [ml: Xl.MatchList] = { ml Ź widget.matchList1; widget.matchList1 Ź NIL; }; FOR lx: Xl.MatchList Ź GetMatchList1[widget], lx.rest WHILE lx # NIL DO m: Match Ź NEW[MatchRep Ź lx.first]; IF m.tq=NIL THEN m.tq Ź widget.rootTQ; ml Ź CONS[m, ml]; ENDLOOP; }; }; PropagateUpPleaseResizeChild: PUBLIC WidgetNChildProc = { IF widget.parent#NIL THEN { PleaseResizeChild[widget.parent, widget]; }; }; SimplePreferredSizeOneLevel: PUBLIC PreferredSizeProc = { RETURN [widget.s.geometry]; }; SimpleClassName: PUBLIC ClassNameProc = { RETURN [widget.s.class.classNameHint]; }; NoteChildChangePropagate: PUBLIC PROC [widget: Widget, top: Widget Ź NIL] = { WHILE widget#NIL AND widget.state> NoteGeometryChange: PUBLIC PROC [widget: Widget, geometry: Geometry Ź []] = { IF widget.state>=dead THEN ERROR; IF geometry.size.width>0 THEN widget.s.geometry.size.width Ź geometry.size.width; IF geometry.size.height>0 THEN widget.s.geometry.size.height Ź geometry.size.height; IF geometry.pos.x#dontUse THEN widget.s.geometry.pos.x Ź geometry.pos.x; IF geometry.pos.y#dontUse THEN widget.s.geometry.pos.y Ź geometry.pos.y; IF geometry.borderWidth#dontUse THEN widget.s.geometry.borderWidth Ź geometry.borderWidth; IF widget.s.geometry#widget.actual OR widget.s.mapping=dontUse THEN { IF widget.parent#NIL THEN NoteChildChange[widget.parent]; }; }; <<>> NoteMappingChange: PUBLIC PROC [widget: Widget, mapping: Mapping Ź dontUse] = { IF widget.state>=dead THEN ERROR; IF mapping#dontUse THEN widget.s.mapping Ź mapping; IF widget.s.mapping#widget.actualMapping OR widget.s.mapping=dontUse THEN { IF widget.parent#NIL THEN NoteChildChange[widget.parent]; }; }; <<>> NoteAndStartReconfigure: PUBLIC PROC [widget: Widget, geometry: Geometry Ź [], mapping: Mapping Ź dontUse] = { ReconfigureParentNow: PROC [widget: Widget] = { parent: Widget Ź widget.parent; IF parent=NIL THEN ERROR; --shell to be handled differently... StartReconfigureChildren[parent]; }; IF widget.state>=dead THEN ERROR; NoteMappingChange[widget, mapping]; NoteGeometryChange[widget, geometry]; ReconfigureParentNow[widget]; }; <<>> NoteGeometryChangePropagate: PUBLIC PROC [widget: Widget, geometry: Geometry Ź [], top: Widget Ź NIL] = { NoteGeometryChange[widget, geometry]; IF widget.s.geometry#widget.actual OR widget.s.mapping=dontUse THEN { NoteChildChangePropagate[widget.parent, top]; }; }; <<>> NoteMappingChangePropagate: PUBLIC PROC [widget: Widget, mapping: Mapping Ź dontUse, top: Widget Ź NIL] = { NoteMappingChange[widget, mapping]; IF widget.s.mapping#widget.actualMapping OR widget.s.mapping=dontUse THEN { NoteChildChangePropagate[widget.parent, top]; }; }; <<>> ReconfigureChildrenLR: PUBLIC PROC [self: Widget] = { IF self#NIL AND self.state> DestroyWidget: PUBLIC PROC [widget: Widget, startReconfigureParent: BOOL Ź TRUE] = { action: PROC = { parent: Widget Ź widget.parent; IF parent#NIL AND widget.state op[orphan]; ENDCASE => DestroyWidgetLR[orphan]; }; <<>> defaultSuper: REF ClassRec Ź NEW[ClassRec[0]]; --used for defaults in CreateClass; NOT used in runtime chaining for efficiency reasons. defaultSuper.configureLR Ź SimpleConfigureOneLevelLR; defaultSuper.preferredSizeLR Ź SimplePreferredSizeOneLevel; defaultSuper.pleaseResizeChild Ź IgnorePleaseResizeChild; defaultSuper.className Ź SimpleClassName; defaultSuper.actualCreateWindowLR Ź DefaultActualCreateWindowLR; END.