XTkImpl.mesa
Copyright Ó 1988, 1989, 1990, 1991, 1992, 1993 by Xerox Corporation. All rights reserved.
Created by Christian Jacobi, August 3, 1990 1:59 pm PDT
Christian Jacobi, May 4, 1993 2:37 pm PDT
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 <<XTkOps>> 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<unconfigured; --Oops, inside a configure proc state may be realized but window not yet generated
};
realized: BOOL ¬ EntryPart[widget, matchRep, generate];
IF realized AND widget.fastAccessAllowed=ok THEN {
match: Xl.Match ¬ NEW[MatchRep ¬ matchRep];
IF match.tq=NIL THEN match.tq ¬ widget.rootTQ;
Xl.AddDispatch[widget.connection, widget.window, match, generate];
}
};
AddTemporaryMatch: PUBLIC PROC [widget: Widget, matchRep: MatchRep, generate: SetOfEvent] = {
EntryPart: ENTRY PROC [widget: Widget, match: Xl.Match, generate: SetOfEvent] RETURNS [realized: BOOL] = {
widget.attributes.eventMask ¬ Xl.ORSetOfEvents[widget.attributes.eventMask, generate];
widget.matchList1 ¬ CONS[match, widget.matchList1];
realized ¬ widget.state=realized AND widget.window#Xl.nullWindow AND widget.actualMapping<unconfigured; --Oops, inside a configure proc state may be realized but window not yet generated
};
match0: Xl.Match ¬ NEW[MatchRep ¬ matchRep];
realized: BOOL ¬ EntryPart[widget, match0, generate];
IF realized AND widget.fastAccessAllowed=ok THEN {
match: Xl.Match ¬ NEW[MatchRep ¬ matchRep];
IF match.tq=NIL THEN match.tq ¬ widget.rootTQ;
Xl.AddDispatch[widget.connection, widget.window, match, generate];
}
};
PleaseResizeChild: PUBLIC WidgetNChildProc = {
widget.s.class.pleaseResizeChild[widget, child];
};
gAllTrue: GeometryRequest = ALL[TRUE];
PreferredSizeLR: PUBLIC PreferredSizeProc = {
IF maySkip=gAllTrue THEN RETURN [widget.actual];
IF ~IScreenBound[widget] THEN ERROR;
IF widget.state=realized AND GetWidgetFlag[widget, preferredSizeCurrent] THEN {
IF widget.s.geometry.pos.x>=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 = {
<<Any thread>>
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] = {
<<collect threads of slow stoppers (so later a wait can be berformed)>>
<<Root thread because of possible side effects>>
<<Recursing class clients>>
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] = {
<<Root thread because of possible side effects>>
<<Any client; but explicitely not recursion>>
--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<dead THEN {
OrphanizeLR[child, errorWindow]
};
};
IF widget.state<dead THEN {
parent: Widget ¬ widget.parent;
IF IScreenBound[widget] THEN ForgetScreenLR[widget];
widget.state ¬ dead;
IF parent#NIL AND parent.state<dead THEN [] ¬ RemoveChildLR[parent, widget];
FOR class: Class ¬ widget.s.class, class.super WHILE class#NIL DO
IF class.destroyWidget#NIL THEN class.destroyWidget[widget];
ENDLOOP;
ShallowInternalEnumerateChildren[widget, DestroyChild];
CallNotifiers[widget, postWidgetDestructionReal];
widget.matchList1 ¬ NIL;
widget.matchListX ¬ NIL;
widget.parent ¬ NIL;
widget.notifiers ¬ NIL;
TRUSTED {
IF widget.props#NIL THEN UnsafePropList.NiloutPropList[LOOPHOLE[@widget.props]];
};
};
};
RemoveChildLR: PUBLIC PROC [widget: Widget, child: Widget] RETURNS [done: BOOL ¬ FALSE] = {
IF widget.state<dead AND child#NIL THEN {
FOR class: Class ¬ widget.s.class, class.super WHILE class#NIL DO
IF class.removeChildLR#NIL THEN {
IF class.removeChildLR[widget, child] THEN {
done ¬ TRUE;
NoteChildChange[widget];
EXIT
}
}
ENDLOOP;
};
};
NoteChildChange: PUBLIC ENTRY PROC [widget: Widget] = {
widget.flags[mustReConsiderChildren] ¬ TRUE
};
SetWidgetFlag: PUBLIC ENTRY PROC [widget: Widget, key: WidgetFlagKey, value: BOOL ¬ TRUE] = {
widget.flags[key] ¬ value
};
dummyWidgetForLock: Widget ~ NEW[WidgetRep];
SetClassFlag: PUBLIC PROC [class: ImplementorClass, key: ClassFlagKey, value: BOOL ¬ TRUE] = {
EntryDo: ENTRY PROC [widget: Widget, class: ImplementorClass, key: ClassFlagKey, value: BOOL ¬ TRUE] = {
class.flags[key] ¬ value
};
IF class#NIL THEN EntryDo[dummyWidgetForLock, class, key, value];
};
PutWidgetProp: PUBLIC PROC [widget: Widget, key: REF, value: REF ¬ NIL] = TRUSTED {
IF widget=NIL THEN ERROR;
[] ¬ UnsafePropList.PutProp[LOOPHOLE[@widget.props], key, value];
};
GetWidgetProp: PUBLIC PROC [widget: Widget, key: REF] RETURNS [REF] = TRUSTED {
IF widget=NIL THEN ERROR;
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 !
<<DONT RETURN [QueryScreen[of root of widget]] : widget.window is not set up yet>>
--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<<screen is READONLY>>];
ShallowInternalEnumerateChildren[widget, Recurse];
};
};
ForgetScreenLR: PUBLIC PROC [widget: Widget] = {
Recurse: EachChild = {ForgetScreenLR[child]};
IF IScreenBound[widget] THEN {
reason: TerminationReason ¬ errorConnection;
IF widget.fastAccessAllowed<warned THEN reason ¬ normal;
IF widget.actualMapping<unconfigured THEN
DestroyWindowLR[widget: widget, reason: reason];
widget.state ¬ MAX[widget.state, existing];
ShallowInternalEnumerateChildren[widget, Recurse];
CallNotifiers[widget, forgetScreenLRReal, NIL];
--sub to super order for no good reason
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<unconfigured THEN {
mapping ¬ mapped;
};
};
SELECT mapping FROM
unmapIfMapped => {
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<unconfigured;
createW ¬ mapping<unconfigured AND ~existW;
destroyW ¬ mapping=unconfigured AND existW;
IF destroyW THEN {
reason: TerminationReason ¬ IF widget.fastAccessAllowed=ok THEN normal ELSE errorConnection;
DestroyWindowLR[widget, reason];
RETURN;
};
IF createW THEN {
IF widget.window#Xl.nullWindow THEN ERROR;
IF ~IScreenBound[widget] THEN HardScreenFromParentLR[widget];
widget.state ¬ realized;
widget.fastAccessAllowed ¬ ok;
CallNotifiers[widget, preWindowCreationLRReal, NIL];
};
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 createW OR geometry#[[dontUse, dontUse], [dontUse, dontUse], dontUse] OR mapping#dontUse OR (reConsiderChildren AND GetWidgetFlag[widget, mustReConsiderChildren]) THEN {
widget.s.class.configureLR[widget, geometry, mapping, reConsiderChildren];
SELECT TRUE FROM
createW => 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 {
Assigns the defined values into widget, for undefined values leave widget alone.
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<unconfigured;
createW ¬ mapping<unconfigured AND ~existW;
destroyW ¬ mapping=unconfigured AND existW;
IF destroyW THEN ERROR;
IF createW THEN {
IF widget.parent#NIL THEN {
IF widget.depth<0 THEN widget.depth ¬ widget.parent.depth
};
SetupScreenDepth[widget];
IF widget.actual.size.height<=0 THEN widget.actual.size.height ¬ 1;
IF widget.actual.size.width<=0 THEN widget.actual.size.width ¬ 1;
IF widget.actual.borderWidth<0 THEN widget.actual.borderWidth ¬ 0; --neither copy from parent here nor use copy from parent feature of X; this would be to complex for containers.
IF Xl.IllegalCursor[widget.attributes.cursor] THEN {
WITH widget.s.class.cursorKey SELECT FROM
rc: REF XlCursor.StandardFontCursors =>
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<dead DO
NoteChildChange[widget];
IF widget=top THEN RETURN;
widget ¬ widget.parent
ENDLOOP;
};
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<dead AND GetWidgetFlag[self, mustReConsiderChildren] THEN {
ConfigureLR[widget: self, geometry: [], mapping: dontUse, reConsiderChildren: TRUE];
};
};
StartReconfigureChildren: PUBLIC PROC [widget: Widget] = {
action: PROC [] = {ReconfigureChildrenLR[widget]};
IF widget.state<dead THEN {
IF widget.rootTQ=NIL THEN action[] ELSE Xl.CallWithLock[widget.rootTQ, action];
}
};
DestroyWidget: PUBLIC PROC [widget: Widget, startReconfigureParent: BOOL ¬ TRUE] = {
action: PROC = {
parent: Widget ¬ widget.parent;
IF parent#NIL AND widget.state<dead AND parent.state<dead THEN {
NoteChildChange[parent];
};
DestroyWidgetLR[widget];
IF parent#NIL AND GetWidgetFlag[parent, mustReConsiderChildren] AND startReconfigureParent THEN ReconfigureChildrenLR[parent];
};
IF widget.state<dead THEN {
IF widget.rootTQ=NIL THEN action[] ELSE Xl.CallWithLock[widget.rootTQ, action];
}
};
CreateWidget: PUBLIC PROC [widgetSpec: WidgetSpec, class: Class ¬ NIL, arguments: Atom.PropList ¬ NIL] RETURNS [widget: Widget] = {
InitializeChain: PROC [w: Widget, class: Class] = {
IF class.super#NIL THEN InitializeChain[w, class.super];
IF class.initInstPart#NIL THEN class.initInstPart[w, arguments];
};
widgetSpec.class ¬ InitClassField[widgetSpec.class, class];
widget ¬ NEW[WidgetRep[SpecificsCount[widgetSpec.class]]];
widget.s ¬ widgetSpec;
widget.fastAccessAllowed ¬ warned;
InitializeChain[widget, widget.s.class];
};
orphanProcKey: REF ¬ NEW[ATOM];
RegisterOrphanProc: PUBLIC PROC [self: Widget, orphanProcLR: OrphanProc ¬ NIL] = {
ref: REF OrphanProc ~ IF orphanProcLR#NIL THEN NEW[OrphanProc¬orphanProcLR] ELSE NIL;
PutWidgetProp[self, orphanProcKey, ref];
};
OrphanizeLR: PUBLIC PROC [orphan: Widget, parentState: TerminationReason] = {
WITH GetWidgetProp[orphan, orphanProcKey] SELECT FROM
op: REF OrphanProc => 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.