Copyright (C) 1994, Digital Equipment Corp.
Digital Internal Use Only
Created on Mon Jan 16 10:05:17 PST 1995 by najork
UNSAFE MODULE------------------------------------------------------- Trestle methods --- These procedures are; IMPORT Axis, Batch, Ctypes, Fmt, M3toC, Point, ProperSplit, Rect, Region, RTCollectorSRC, RTHeapDep, RTHeapRep, RTParams, RTLinker, ScrnColorMap, ScrnCursor, ScrnPixmap, Split, Text, Thread, Trestle, TrestleClass, TrestleImpl, VBT, VBTClass, VBTRep, WinBase, WinDef, WinGDI, WinKey, WinMsg, WinPaint, WinScreenType, WinScreenTypePrivate, WinScrnColorMap, WinScrnCursor, WinScrnPixmap, WinUser, Word; IMPORT RTIO; EXCEPTION FatalError; CONST False = 0; True = 1; CONST DesktopID = 0; (* The ScreenID of the Windows desktop. *) REVEAL T = Trestle.T BRANDED "WinTrestle.T" OBJECT screen : WinScreenType.T; coverage : CARDINAL := 0; current : VBT.T := NIL; (* The child that is touched by the pointer, or NIL if there is no such child. *) mouseFocus: VBT.T := NIL; (* The child that has received a FirstDown but no corresponding LastUp, or NIL if there is no such child. *) hwnd : WinDef.HWND; timerId : WinDef.UINT; lastPos := WinDef.POINT {-1, -1}; n_cages := 0; queue_status : WinDef.DWORD := 0; OVERRIDES redisplay := Redisplay; beChild := BeChild; replace := Replace; setcage := SetCage; setcursor := SetCursor; paintbatch := PaintBatch; sync := Sync; capture := Capture; screenOf := ScreenOf; newShape := NewShape; acquire := Acquire; release := Release; put := Put; forge := Forge; readUp := ReadUp; writeUp := WriteUp; attach := Attach; decorate := Decorate; iconize := Iconize; overlap := Overlap; moveNear := MoveNear; installOffscreen := InstallOffScreen; setColorMap := SetColorMap; getScreens := GetScreens; captureScreen := CaptureScreen; allCeded := AllCeded; tickTime := TickTime; trestleId := TrestleID; windowId := WindowID; updateChalk := UpdateChalk; updateBuddies := UpdateBuddies; END; REVEAL Child = ProperSplit.Child BRANDED "WinTrestle.Child" OBJECT uid := 0; (* index of this child in the "roots" array *) offScreen := FALSE; (* TRUE for an off-screen window *) cageCovered := FALSE; (* TRUE during delivery of a button click, to avoid setting the cage twice. *) decorated := FALSE; (* TRUE if the window is normal, FALSE if override-redirect; only valid after w is created. (same as in xvbt) *) dead_vbt := FALSE; (* TRUE if the VBT and associated window are scheduled for deletion. *) cageSet := FALSE; (* TRUE if the VBT wants mouse events *) last : Last; (* last button/mouse click info *) title_string : Ctypes.char_star := NIL; (* the installed title string *) hpal : WinDef.HPALETTE := NIL; (* the palette handle or NIL *) hwnd : WinDef.HWND := NIL; (* the window handle *) hdc : WinDef.HDC := NIL; (* the device context *) sh, sv : VBT.SizeRange; (* hor. and vert. window sizes *) trsl : T := NIL; (* the Trestle on which the window is installed *) END; (* The fields of a child record are only modified via WindowProc() which is running in a single thread. I guess you could say their LL = WindowProc. *) WinTrestle
on the Trestle side
. They run while holding
various Trestle and VBT locks. If they want to perform any non-trivial
Win32 operations, they enqueue them for the thread running WindowProc.
PROCEDUREWindows maintains batches of paint requests on a per-thread (as opposed to per-window) basis. Batches are flushed by callingRedisplay (self: T) = (* LL = VBT.mu *) <*FATAL Split.NotAChild*> VAR v := Split.Succ (self, NIL); BEGIN WHILE v # NIL DO IF VBTClass.HasNewShape (v) AND v.st # NIL THEN SetShape (self, v); END; v := Split.Succ (self, v); END; END Redisplay; PROCEDURESetShape (trsl: T; v: VBT.T) = (* LL = VBT.mu *) VAR sizeChange : BOOLEAN; width, height: CARDINAL := 0; ur : Child := v.upRef; new_shape : BOOLEAN := SetSizeHints (ur, width, height); status : WinDef.BOOL; rect : WinDef.RECT; a : Arg; BEGIN (* If the window is not yet installed, bail out ... *) IF ur.hwnd = NIL THEN RETURN; END; IF NOT new_shape THEN RETURN; END; LOCK trsl DO (* Determine the current size of the window. *) status := WinUser.GetClientRect (ur.hwnd, ADR(rect)); <* ASSERT status = True *> END; sizeChange := width # rect.right - rect.left OR height # rect.bottom - rect.top; IF (sizeChange) THEN DEBUG ("size change: target size: " & Fmt.Int (width) & " x " & Fmt.Int (height) & " current size: " & Fmt.Int (rect.right - rect.left) & " x " & Fmt.Int (rect.bottom - rect.top) & "\n"); END; IF sizeChange AND width # 0 AND height # 0 THEN a := NewArg (); a.width := width; a.height := height; PostMsg (ur, WinMsg.RESHAPE_VBT, a); END; END SetShape; PROCEDUREBeChild (self: T; ch: VBT.T) = VAR ur: Child; BEGIN IF ch.upRef = NIL THEN ur := NewChild (self); ch.upRef := ur; ur.ch := ch; ELSE ur := NARROW (ch.upRef, Child); <*ASSERT ur.ch = ch *> END; ur.dead_vbt := FALSE; ch.parent := self; END BeChild; PROCEDUREReplace (<*UNUSED*> self: T; v, new: VBT.T) = <* FATAL FatalError *> VAR ur: Child := v.upRef; BEGIN IF new # NIL THEN RAISE FatalError; END; DiscardVBT (ur); PostMsg (ur, WinMsg.DELETE_VBT, NewArg ()); END Replace; PROCEDUREDiscardVBT (ur: Child) = BEGIN IF ur.dead_vbt THEN RETURN; END; ur.dead_vbt := TRUE; ProperSplit.Delete (ur.trsl, ur); VBTClass.Misc(ur.ch, VBT.MiscRec{VBT.Deleted, VBT.NullDetail, 0, VBT.NilSel}); VBT.Discard(ur.ch); END DiscardVBT; PROCEDURESetCage (self: T; v: VBT.T) = VAR ur : Child := v.upRef; cage := VBTClass.Cage (v); BEGIN IF v.st = NIL OR ur = NIL OR v.parent # self THEN IF NOT (TRUE IN cage.inOut) THEN VBTClass.ForceEscape (v) END; RETURN END; LOCK self DO IF ur.cageCovered THEN RETURN; END; IF NOT ur.cageSet THEN INC (self.n_cages); END; ur.cageSet := TRUE; END; END SetCage; PROCEDURESetCursor (self: T; v: VBT.T) = VAR ur: Child := v.upRef; BEGIN IF ur.hwnd = NIL THEN RETURN; END; WITH cs = v.getcursor() DO LOCK self DO WinScrnCursor.SetCursor (cs); END; END; END SetCursor; PROCEDUREPaintBatch (self: T; v: VBT.T; ba: Batch.T) = VAR ur : Child := v.upRef; hdc := ur.hdc; hwnd := ur.hwnd; status: WinDef.BOOL; BEGIN IF (hdc = NIL) THEN (* the window hasn't been created yet... *) Batch.Free (ba); RETURN; END; WinPaint.PaintBatch (self, v, ba, hdc); (* * Commenting out these two lines breaks "Fours" (the Trstle version * of Tetris) for unknown reasons. "hdc" is a private DC, and according * to the Win32 documentation, ReleaseDC "has no effect on class or * private DC's". *) IF (hwnd # NIL) THEN status := WinUser.ReleaseDC (hwnd, hdc); <* ASSERT status = True *> END; status := WinGDI.GdiFlush(); <* ASSERT status = True *> END PaintBatch;
GdiFlush
. Since
Sync
can be called by a thread different from the ones that do the
painting (WindowProc), it is not sufficient for Sync
to call GdiFlush
.
Instead, we ask the WindowProc thread to call GdiFlush
and then
flush the current thread's batch.
PROCEDURESync (<*UNUSED*> self: T; v: VBT.T; <*UNUSED*> wait: BOOLEAN) = VAR ur : Child := v.upRef; BEGIN IF (v.st = NIL) THEN RETURN; END; PostMsg (ur, WinMsg.SYNC_VBT, NewArg ()); EVAL WinGDI.GdiFlush (); END Sync;
Capture
combines XPaint.Capture
and XPaint.CapturePM
. The X code
does some pretty elaborate stuff to determine a ``bad region'' br
.
I don't do any of that. I guess that the sticky point is what happens
if I try to capture a minimized window.
PROCEDURENote: The TrestleCapture ( self: T; v : VBT.T; READONLY rect: Rect.T; VAR (*out*) br : Region.T): ScrnPixmap.T = VAR ur : Child := v.upRef; dstDc : WinDef.HDC; oldBmp: WinDef.HBITMAP; dstBmp: WinDef.HBITMAP; status: WinDef.BOOL; BEGIN IF (rect.west >= rect.east) OR (v.st = NIL) OR (ur.hdc = NIL) THEN (* empty region, or the window hasn't been created yet... *) br := Region.FromRect(rect); RETURN NIL; END; LOCK self DO br := Region.Empty; dstDc := WinGDI.CreateCompatibleDC (ur.hdc); <* ASSERT dstDc # NIL *> dstBmp := WinGDI.CreateCompatibleBitmap (ur.hdc, rect.east - rect.west, rect.south - rect.north); <* ASSERT dstBmp # NIL *> oldBmp := WinGDI.SelectObject (dstDc, dstBmp); <* ASSERT oldBmp # NIL *> status := WinGDI.BitBlt ((* hdcDest *) dstDc, (* nXDest *) 0, (* nYDest *) 0, (* nWidth *) rect.east - rect.west, (* nHeight *) rect.south - rect.north, (* hdcSrc *) ur.hdc, (* nXSrc *) rect.west, (* nYSrc *) rect.north, (* dwRop *) WinGDI.SRCCOPY); <* ASSERT status = True *> status := WinGDI.DeleteDC (dstDc); <* ASSERT status = True *> RETURN WinScrnPixmap.NewPixmap (v.st, dstBmp, rect, v.st.depth); END; END Capture; PROCEDUREScreenOf ( self: T; v : VBT.T; READONLY pt : Point.T): Trestle.ScreenOfRec = VAR ur : Child := v.upRef; st : WinScreenType.T := v.st; res: Trestle.ScreenOfRec; BEGIN res.trsl := self; IF st = NIL OR ur = NIL OR ur.offScreen THEN res.id := Trestle.NoScreen ELSE LOCK self DO res.id := DesktopID; res.dom := st.rootDom; res.q := pt; IF ur.hwnd # NIL THEN res.q := Point.Add (pt, NorthWest(ur)); END; END; END; RETURN res; END ScreenOf;
self
must not be locked by the calling thread.
PROCEDURENewShape (self: T; ch: VBT.T) = BEGIN IF ch.st # NIL THEN VBT.Mark(self); END; END NewShape; PROCEDUREFmt_Selection (s: VBT.Selection): TEXT = BEGIN IF s = VBT.NilSel THEN RETURN "VBT.NilSel" ELSIF s = VBT.Forgery THEN RETURN "VBT.Forgery" ELSIF s = VBT.KBFocus THEN RETURN "VBT.KBFocus" ELSIF s = VBT.Target THEN RETURN "VBT.Target" ELSIF s = VBT.Source THEN RETURN "VBT.Source" ELSE RETURN "Selection{" & Fmt.Int(s.sel) & "}"; END; END Fmt_Selection; PROCEDUREAcquire (<*UNUSED*> self: T; <*UNUSED*> v : VBT.T; <*UNUSED*> w : VBT.T; s : VBT.Selection; ts : VBT.TimeStamp) (** RAISES {VBT.Error}**) = BEGIN DEBUG ("Called WinTrestle.Acquire: s = " & Fmt_Selection (s) & " ts= " & Fmt.Int (ts) & "\n");
DEBUG (
WARNING: WinTrestle.Acquire is not yet implemented \n
);
END Acquire; PROCEDURE----------------------------------------------------------------------------- TheRelease (<*UNUSED*> self: T; <*UNUSED*> v: VBT.T; <*UNUSED*> w: VBT.T; <*UNUSED*> s: VBT.Selection) = BEGIN DEBUG ("WARNING: WinTrestle.Release is not yet implemented \n"); END Release; PROCEDUREPut (<*UNUSED*> self : T; <*UNUSED*> ch : VBT.T; <*UNUSED*> w : VBT.T; <*UNUSED*> s : VBT.Selection; <*UNUSED*> ts : VBT.TimeStamp; <*UNUSED*> type : VBT.MiscCodeType; <*UNUSED*> READONLY detail: VBT.MiscCodeDetail) (** RAISES {VBT.Error} **) = BEGIN <* ASSERT FALSE *> (* not yet implemented *) END Put; PROCEDUREForge ( self : T; v : VBT.T; <*UNUSED*> w : VBT.T; <*UNUSED*> type : VBT.MiscCodeType; <*UNUSED*> READONLY detail: VBT.MiscCodeDetail) RAISES {VBT.Error} = VAR ur: Child := v.upRef; BEGIN LOCK self DO IF ur = NIL OR ur.offScreen THEN RAISE VBT.Error(VBT.ErrorCode.Uninstalled) END; PostMsg (ur, WinMsg.FORGE_VBT, NewArg ()); END; END Forge; PROCEDUREReadUp (<*UNUSED*> self: T; <*UNUSED*> ch : VBT.T; <*UNUSED*> w : VBT.T; <*UNUSED*> s : VBT.Selection; <*UNUSED*> ts : VBT.TimeStamp; <*UNUSED*> tc : CARDINAL): VBT.Value (*** RAISES {VBT.Error} ***) = BEGIN <* ASSERT FALSE *> (* not yet implemented *) END ReadUp; PROCEDUREWriteUp (<*UNUSED*> self: T; <*UNUSED*> ch : VBT.T; <*UNUSED*> w : VBT.T; <*UNUSED*> s : VBT.Selection; <*UNUSED*> ts : VBT.TimeStamp; <*UNUSED*> val : VBT.Value; <*UNUSED*> tc : CARDINAL) (*** RAISES {VBT.Error} ***) = BEGIN <* ASSERT FALSE *> (* not yet implemented *) END WriteUp; PROCEDUREAttach (self: T; v: VBT.T) = BEGIN LOCK v DO LOCK self DO ProperSplit.Insert (self, NIL, v); END; END; END Attach;
decorate
method is introduced by TrestleClass.Public
.
It is called when the decoration of v
has changed from old
to new
.
There is no specification.
-----------------------------------------------------------------------------
PROCEDURE----------------------------------------------------------------------------- TrestleClass.Public introduces a methodDecorate (<*UNUSED*> self: T; v: VBT.T; old, new: TrestleClass.Decoration) = VAR a: Arg; BEGIN TYPECASE v.upRef OF | NULL => (* skip *) | Child (ur) => a := NewArg (); a.old_dec := old; a.new_dec := new; PostMsg (ur, WinMsg.RETITLE_VBT, a); ELSE (* skip *) END; END Decorate; PROCEDUREIconize (<*UNUSED*> self: T; v: VBT.T) = (* LL = VBT.mu *) BEGIN PostMsg (v.upRef, WinMsg.ICONIZE_VBT, NewArg ()); EVAL WinGDI.GdiFlush (); (* encourage WinProc to hurry up *) END Iconize; PROCEDUREOverlap (<*UNUSED*> trsl: T; v : VBT.T; <*UNUSED*> id : Trestle.ScreenID; READONLY nw : Point.T) = BEGIN InnerOverlap(v, nw, TRUE) END Overlap; PROCEDUREMoveNear (self: T; v, w: VBT.T) = (* LL = VBT.mu *) VAR trsl: Trestle.T; ch : Child; st : WinScreenType.T; nw := Point.T {50, 50}; BEGIN (* The beginning of this procedure is a bit different from its counterpart in xvbt. The xvbt version has a (pretty mysterious) loop here. *) IF w # NIL THEN IF NOT TrestleImpl.RootChild (w, trsl, w) THEN w := NIL; (* w is not installed in any trestle *) ELSE <* ASSERT self = trsl *> (* ... just a little sanity check *) END; END; (* Assert: w = NIL OR w.parent = self *) IF w = v THEN w := NIL; END; (* Assert: w = NIL OR (v # w AND w.parent = self) *) IF w # NIL THEN ch := w.upRef; IF w.st = NIL OR ch.offScreen THEN w := NIL; END; END; (* w is NIL, or a different on-screen VBT with well-defined screen type *) IF w # NIL THEN st := w.st; LOCK self DO nw := Point.Add (nw, NorthWest (ch)); END; END; InnerOverlap (v, nw, w # NIL); END MoveNear; PROCEDUREInnerOverlap (v: VBT.T; READONLY nw: Point.T; knownPos: BOOLEAN) = (* LL = VBT.mu *) VAR a := NewArg (); BEGIN a.pt := nw; a.bool := knownPos; PostMsg (v.upRef, WinMsg.OVERLAP_VBT, a); EVAL WinGDI.GdiFlush (); (* encourage WinProc to hurry up *) END InnerOverlap; PROCEDUREInstallOffScreen (self : T; v : VBT.T; width, height : CARDINAL; prefst : VBT.ScreenType) = VAR st : WinScreenType.T; (** a: Arg; **) BEGIN (* Determine the screen type *) IF prefst.depth = 1 THEN st := self.screen.bits; ELSE st := self.screen; END; TYPECASE prefst OF | NULL => | WinScreenType.T (wst) => IF wst.trsl = self THEN st := wst END; ELSE END; (* Rescreen the VBT *) VBTClass.Rescreen(v, st); (* Ask the Trestle thread to create the invisible window *) (** a := NewArg (); a.width := width; a.height := height; PostMsg (v.upRef, WinMsg.CREATE_OFFSCREEN_VBT, a); ***) CreateOffscreen (v.upRef, width, height); (* Reshape the VBT *) VBTClass.Reshape (v, Rect.FromSize(width, height), Rect.Empty); END InstallOffScreen;
setColorMap
. There is no
specification for this method. The X version of Trestle binds a procedure
XClient.SetColorMap to the method.
Trestle.SetColorMap is the only place within Trestle that calls this method. Trestle.SetColorMap is dead code, it is neither exported nor used within Trestle.m3. So, it appears to be safe to not provide an implementation. -----------------------------------------------------------------------------
PROCEDURE----------------------------------------------------------------------------- These methods are used by Shared Trestle. According to msm, we can make them no-ops in Windows world,where we don't have network transparency, much less sharing. -----------------------------------------------------------------------------SetColorMap (<*UNUSED*> self: T; <*UNUSED*> v: VBT.T; <*UNUSED*> cm: ScrnColorMap.T) = BEGIN <* ASSERT FALSE *> (* not yet implemented *) END SetColorMap; PROCEDUREGetScreens (self: T): Trestle.ScreenArray = BEGIN LOCK self DO WITH res = NEW (Trestle.ScreenArray, 1) DO res[0] := Trestle.Screen{ id := DesktopID, dom := self.screen.rootDom, delta := Point.Origin, type := self.screen}; RETURN res END; END; END GetScreens; PROCEDURECaptureScreen ( self: T; <*UNUSED*> id : VBT.ScreenID; READONLY clip: Rect.T; VAR (* out *) br : Region.T): ScrnPixmap.T = VAR st := trsl.screen; rect := Rect.Meet (clip, st.rootDom); hwnd : WinDef.HWND; srcDc : WinDef.HDC; dstDc : WinDef.HDC; oldBmp: WinDef.HBITMAP; dstBmp: WinDef.HBITMAP; status: WinDef.BOOL; BEGIN br := Region.Difference (Region.FromRect (clip), Region.FromRect (rect)); IF rect.west >= rect.east THEN RETURN NIL; END; LOCK self DO hwnd := WinUser.GetDesktopWindow (); srcDc := WinUser.GetDC (hwnd); <* ASSERT srcDc # NIL *> dstDc := WinGDI.CreateCompatibleDC (srcDc); <* ASSERT dstDc # NIL *> dstBmp := WinGDI.CreateCompatibleBitmap (srcDc, rect.east - rect.west, rect.south - rect.north); <* ASSERT dstBmp # NIL *> oldBmp := WinGDI.SelectObject (dstDc, dstBmp); <* ASSERT oldBmp # NIL *> status := WinGDI.BitBlt ((* hdcDest *) dstDc, (* nXDest *) 0, (* nYDest *) 0, (* nWidth *) rect.east - rect.west, (* nHeight *) rect.south - rect.north, (* hdcSrc *) srcDc, (* nXSrc *) rect.west, (* nYSrc *) rect.north, (* dwRop *) WinGDI.SRCCOPY); <* ASSERT status = True *> status := WinUser.ReleaseDC (hwnd, srcDc); <* ASSERT status = True *> status := WinGDI.DeleteDC (dstDc); <* ASSERT status = True *> RETURN WinScrnPixmap.NewPixmap (st, dstBmp, rect, st.depth); END; END CaptureScreen; PROCEDUREAllCeded (self: T): BOOLEAN = BEGIN RETURN (self.queue_status = 0); END AllCeded; PROCEDURETickTime (<*UNUSED*> self: T): INTEGER = BEGIN RETURN 1000; END TickTime; PROCEDURETrestleID (<*UNUSED*> self: T; <*UNUSED*> v: VBT.T): TEXT = BEGIN RETURN "Default Trestle" END TrestleID; PROCEDUREWindowID (<*UNUSED*> self: T; v: VBT.T): TEXT = VAR num := LOOPHOLE (WindowHandle (v), Ctypes.int); BEGIN RETURN Fmt.Unsigned (num, base := 16); END WindowID; PROCEDUREWindowHandle (v: VBT.T): WinDef.HWND = (* Return the window handle associated with a VBT (or NIL) *) BEGIN WHILE v # NIL DO TYPECASE v.upRef OF | NULL => (* skip *) | Child (ur) => RETURN ur.hwnd ELSE (* skip *) END; v := v.parent; END; RETURN NIL; END WindowHandle;
PROCEDURE***************************************************************************UpdateChalk (<*UNUSED*> t: T; <*UNUSED*> v: VBT.T; <*UNUSED*> chalk: TEXT) = BEGIN (* do nothing *) END UpdateChalk; PROCEDUREUpdateBuddies (<*UNUSED*> self : T; <*UNUSED*> v : VBT.T; <*UNUSED*> READONLY trsls, ids: ARRAY OF TEXT) = BEGIN (* do nothing *) END UpdateBuddies;
VAR trsl : T := NIL; trslThread: Thread.T; (* for debugging purposes ... *) PROCEDURE***************************************************************************DoConnect (<*UNUSED*> self : TrestleClass.ConnectClosure; <*UNUSED*> inst : TEXT; <*UNUSED*> localOnly: BOOLEAN; VAR (*OUT*) t : Trestle.T): BOOLEAN = BEGIN t := trsl; RETURN TRUE; END DoConnect; PROCEDUREInit () = BEGIN TrestleClass.RegisterConnectClosure( NEW(TrestleClass.ConnectClosure, apply := DoConnect)) END Init;
******* PROCEDURE Reshape (ch: VBT.T; width, height: CARDINAL; sendMoved := FALSE) = (* Reshape ch to new width and height. If this is a no-op, but sendMoved is true, then send a miscellaneous code. LL = VBT.mu
BEGIN IF (ch.domain.east # width) OR (ch.domain.south # height) THEN WITH new = Rect.FromSize(width, height) DO VBTClass.Reshape(ch, new, Rect.Meet(ch.domain, new)) END ELSIF sendMoved THEN VBTClass.Misc( ch, VBT.MiscRec{VBT.Moved, VBT.NullDetail, 0, VBT.NilSel}) END END Reshape; ********) PROCEDURESetSizeHints (ur: Child; VAR width, height: CARDINAL): BOOLEAN = VAR v := ur.ch; s := VBTClass.GetShapes (v); sh := s[Axis.T.Hor]; sv := s[Axis.T.Ver]; st := NARROW (v.st, WinScreenType.T); max_width := MAX(MIN(sh.hi - 1, Rect.HorSize(st.rootDom)), sh.lo); max_height := MAX(MIN(sv.hi - 1, Rect.VerSize(st.rootDom)), sv.lo); changed := (sh # ur.sh) OR (sv # ur.sv); BEGIN IF (changed) THEN ur.sh := sh; ur.sv := sv; END; IF sh.pref # 0 THEN width := MIN (sh.pref, max_width) ELSIF sh.hi > 1 AND sh.hi <= width THEN width := max_width END; IF sv.pref # 0 THEN height := MIN (sv.pref, max_height) ELSIF sv.hi > 1 AND sv.hi <= height THEN height := max_height END; RETURN changed; END SetSizeHints;
NorthWest
serves a similar purpose as the ValidateNW
function in the
X version. The X counterpart of WinTrestle.T
maintains a cache nw
for
the northwest corner), and a flag nwValid
that indicates whether the
cache entry is valid. ValidateNW
will contact the X server only if the
cache entry is stale.
I assume that the call to GetWindowRect
is cheap enough to use it
liberally. Given that, the code gets a lot simpler.
PROCEDURE-------------------------------------- Trestle -> WinProc communication --- Since the Trestle threads may be holding arbitrary locks and various Win32 calls (e.g. CreateThread and ShowWindow) send and wait for synchronous messages on the Win32 message queues, any non-trivial Win32 calls will be performed by WindowProc which is running at LL=0.NorthWest (ch: Child): Point.T = VAR status : WinDef.BOOL; screenPos := WinDef.POINT {0, 0}; BEGIN status := WinUser.ClientToScreen (ch.hwnd, ADR (screenPos)); <* ASSERT status = True *> RETURN Point.T {screenPos.x, screenPos.y}; END NorthWest;
Arg
s are used to pass information from Trestle threads to WindowProc.
Since they contain traced references, they must be traced. Since they're
passed on the Win32 message queue which is untraced, we assign each
one a unique ID and pass the ID instead of the REF.
*************** TYPE ArgResult = MUTEX OBJECT done: BOOLEAN := FALSE; cond: Thread.Condition := NIL; END;
PROCEDURE NewResult (): ArgResult = BEGIN RETURN NEW (ArgResult, done := FALSE, cond := NEW (Thread.Condition)); END NewResult;
PROCEDURE WaitForResult (res: ArgResult) =
BEGIN
DEBUG (waiting for result...\n
);
LOCK res DO
WHILE NOT res.done DO Thread.Wait (res, res.cond); END;
END;
DEBUG (done.\n
);
END WaitForResult;
***********
TYPE Arg = REF RECORD next : Arg; ch : Child; width : INTEGER; height : INTEGER; uid : INTEGER; pt : Point.T; bool : BOOLEAN; old_dec : TrestleClass.Decoration; new_dec : TrestleClass.Decoration; (** result : ArgResult; **) END; VAR (* LL = arg_mu *) arg_mu : MUTEX := NEW (MUTEX); free_args : Arg := NIL; arg_head : Arg := NIL; arg_tail : Arg := NIL; n_args : INTEGER := 0; PROCEDURE-------------------------------------------------- raw seething windows --- NOTE: The helper procedures called by WindowProc lock VBT.mu when calling various Trestle procedures. They do not hold locks while calling Win32 because it knows nothing about Modula-3 locks and it can, on a whim, call WindowProc to do something. The only reason this scheme might work is because we have a single Modula-3 thread that's pulling on the Win32 message queue and calling WindowProc.NewArg (): Arg = VAR a: Arg; BEGIN LOCK arg_mu DO IF free_args # NIL THEN a := free_args; free_args := a.next; ELSE INC (n_args); a := NEW (Arg); a.uid := n_args; END; END; a.next := NIL; RETURN a; END NewArg; PROCEDUREPostMsg (ch: Child; msg: INTEGER; a: Arg) = VAR hwnd := ch.hwnd; BEGIN IF (hwnd = NIL) THEN hwnd := trsl.hwnd; END; <*ASSERT a.next = NIL*> a.ch := ch; (* put the args where the WindowProc can find them... *) LOCK arg_mu DO IF (arg_head = NIL) THEN arg_head := a; ELSE arg_tail.next := a; END; arg_tail := a; END; (* and enqueue the message *) WHILE WinUser.PostMessage (hwnd, msg, 0, a.uid) = False DO Thread.Pause (0.05d0); END; END PostMsg; PROCEDUREGetArg (id: INTEGER): Arg = (* Since Win32 messages are usually delivered in-order and the set of outstanding messages is small, we don't expect the linear search to take long. *) VAR a, b: Arg := NIL; BEGIN LOCK arg_mu DO a := arg_head; WHILE (a.uid # id) DO b := a; a := a.next; END; IF (b = NIL) THEN arg_head := a.next; ELSE b.next := a.next; END; IF a = arg_tail THEN arg_tail := b; END; a.next := NIL; END; RETURN a; END GetArg; PROCEDURERecycleArg (a: Arg) = BEGIN <*ASSERT a.next = NIL*> LOCK arg_mu DO a.ch := NIL; a.old_dec := NIL; a.new_dec := NIL; (** a.result := NIL; **) a.next := free_args; free_args := a; END; END RecycleArg;
Similarly, we don't bother locking around updates to Child records. They are updated by the single Modula-3/WindowProc thread.
VAR hInst : WinDef.HINSTANCE; hAccelTable : WinDef.HANDLE; windowclassName := M3toC.CopyTtoS ("Trestle VBT"); VAR titlebar_y := WinUser.GetSystemMetrics (WinUser.SM_CYSCREEN) - WinUser.GetSystemMetrics (WinUser.SM_CYFULLSCREEN) - 1; nonclient_x := 2 * WinUser.GetSystemMetrics (WinUser.SM_CXFRAME); nonclient_y := 2 * WinUser.GetSystemMetrics (WinUser.SM_CYFRAME) + titlebar_y; screen_x := 2 * WinUser.GetSystemMetrics (WinUser.SM_CXFRAME) + WinUser.GetSystemMetrics (WinUser.SM_CXSCREEN); screen_y := 2 * WinUser.GetSystemMetrics (WinUser.SM_CYFRAME) + WinUser.GetSystemMetrics (WinUser.SM_CYSCREEN); VAR trace_msgs := RTParams.IsPresent ("TraceWinMsgs"); slow_trace := RTParams.IsPresent ("SlowTrace"); <*CALLBACK*> PROCEDURE**** -- didn't the preceding ShowWindow do this?? - WKK 5/17/96 (* Update the window (repaint its client area)WindowProc (hwnd : WinDef.HWND; message: WinDef.UINT; wParam : WinDef.WPARAM; lParam : WinDef.LPARAM ): WinDef.LRESULT = CONST InterestingEvents = WinUser.QS_ALLINPUT - WinUser.QS_TIMER; VAR a: Arg := NIL; result := 0; debug_id: INTEGER; BEGIN <* ASSERT Thread.Self() = trslThread *> IF trace_msgs THEN debug_id := PrintMessageType(message, 0); END; (* let others know if we've cleared the queue... *) trsl.queue_status := WinUser.GetQueueStatus (InterestingEvents); CASE message OF | WinMsg.CREATE_OFFSCREEN_VBT => a := GetArg (lParam); CreateOffscreen (a.ch, a.width, a.height); | WinMsg.RESHAPE_VBT => a := GetArg (lParam); ReshapeVBT (a.ch, a.width, a.height); | WinMsg.SYNC_VBT => a := GetArg (lParam); EVAL WinGDI.GdiFlush (); | WinMsg.FORGE_VBT => a := GetArg (lParam); ForgeVBTEvent (a.ch); | WinMsg.ICONIZE_VBT => a := GetArg (lParam); IconizeVBT (a.ch); | WinMsg.OVERLAP_VBT => a := GetArg (lParam); OverlapVBT (a.ch, a.pt, a.bool); | WinMsg.RETITLE_VBT => a := GetArg (lParam); RetitleVBT (a.ch, a.old_dec, a.new_dec); | WinMsg.DELETE_VBT => a := GetArg (lParam); DeleteVBT (a.ch); | WinUser.WM_DESTROY => DestroyVBT (GetChild (hwnd)); result := WinUser.WM_DESTROY; | WinUser.WM_GETMINMAXINFO => GetVBTSize (hwnd, lParam); | WinUser.WM_PAINT => PaintVBT (hwnd); | WinUser.WM_WINDOWPOSCHANGED => MoveVBT (hwnd); | WinUser.WM_ACTIVATE => ActivateVBT (hwnd, wParam); | WinUser.WM_SETCURSOR => IF WinDef.LOWORD (lParam) # WinUser.HTCLIENT THEN result := WinUser.DefWindowProc (hwnd, message, wParam, lParam); ELSE SetVBTCursor (hwnd); END; | WinUser.WM_QUERYNEWPALETTE => QueryVBTPalette (hwnd); result := True; | WinUser.WM_KEYDOWN => VBTKeyPress (hwnd, wParam, TRUE); | WinUser.WM_KEYUP => VBTKeyPress (hwnd, wParam, FALSE); | WinUser.WM_LBUTTONDOWN => ButtonEvent (hwnd, lParam, wParam, Button.Left, Transition.Press); | WinUser.WM_LBUTTONUP => ButtonEvent (hwnd, lParam, wParam, Button.Left, Transition.Release); | WinUser.WM_MBUTTONDOWN => ButtonEvent (hwnd, lParam, wParam, Button.Middle, Transition.Press); | WinUser.WM_MBUTTONUP => ButtonEvent (hwnd, lParam, wParam, Button.Middle, Transition.Release); | WinUser.WM_RBUTTONDOWN => ButtonEvent (hwnd, lParam, wParam, Button.Right, Transition.Press); | WinUser.WM_RBUTTONUP => ButtonEvent (hwnd, lParam, wParam, Button.Right, Transition.Release); | WinUser.WM_MOUSEMOVE => DeliverMousePos (hwnd, lParam, wParam); | WinUser.WM_TIMER => TimerTick (hwnd); ELSE result := WinUser.DefWindowProc (hwnd, message, wParam, lParam); END; IF (a # NIL) THEN (**** IF (a.result # NIL) THEN a.result.done := TRUE; Thread.Broadcast (a.result.cond); END; ****) RecycleArg (a); END; IF trace_msgs THEN EVAL PrintMessageType(message, debug_id); END; RETURN result; END WindowProc; VAR (* HACK, HACK, HACK.... (See CreateWindow() and GetVBTSize()) *) create_child: Child := NIL; create_width: CARDINAL; create_height: CARDINAL; PROCEDURECreateVBT (ur: Child; st: WinScreenType.T; READONLY nw: Point.T; iconic: BOOLEAN) = CONST DefaultWidth = 133.0; (* millimeters *) DefaultHeight = 100.0; VAR v : VBT.T := ur.ch; dec : TrestleClass.Decoration; width : CARDINAL; height : CARDINAL; BEGIN LOCK VBT.mu DO VBTClass.Rescreen (v, st); width := ROUND(VBT.MMToPixels(v, DefaultWidth, Axis.T.Hor)); height := ROUND(VBT.MMToPixels(v, DefaultHeight, Axis.T.Ver)); EVAL SetSizeHints (ur, width, height); dec := VBT.GetProp (v, TYPECODE(TrestleClass.Decoration)); END; (* create the window *) <*ASSERT create_child = NIL *> create_child := ur; create_width := width; create_height := height; IF dec = NIL THEN ur.title_string := NIL; ur.hwnd := WinUser.CreateWindowEx (WinUser.WS_EX_TOPMOST, windowclassName, NIL, WinUser.WS_POPUP, nw.h, nw.v, width, height, NIL, NIL, hInst, NIL); ELSE IF iconic THEN ur.title_string := M3toC.CopyTtoS (dec.iconTitle); ELSE ur.title_string := M3toC.CopyTtoS (dec.windowTitle); END; INC (width, nonclient_x); INC (height, nonclient_y); ur.hwnd := WinUser.CreateWindow (windowclassName, ur.title_string, WinUser.WS_OVERLAPPEDWINDOW, nw.h, nw.v, width, height, NIL, NIL, hInst, NIL); END; create_child := NIL; <* ASSERT ur.hwnd # NIL *> (* Cache the device context in the "Child" record. Note that we can do this only because we declared the device context to be private ("CS_OWNDC"). *) ur.hdc := WinUser.GetDC (ur.hwnd); <* ASSERT ur.hdc # NIL *> InstallDefaultPalette (ur); ur.decorated := dec # NIL; RetitleVBT (ur, NIL, dec); EVAL WinUser.ShowWindow (ur.hwnd, WinUser.SW_SHOWDEFAULT);
status := WinUser.UpdateWindow (ur.hwnd); <* ASSERT status # 0 *> ****************************************************************) END CreateVBT; PROCEDURECreateOffscreen (ur: Child; width, height: INTEGER) = BEGIN ur.decorated := FALSE; ur.offScreen := TRUE; ur.hwnd := NIL; ur.title_string := NIL; ur.hdc := CreateMemoryDC (width, height); InstallDefaultPalette (ur); END CreateOffscreen; PROCEDURECreateMemoryDC (width, height: INTEGER): WinDef.HDC = VAR deskHwnd : WinDef.HWND; deskHdc : WinDef.HDC; memHdc : WinDef.HDC; newHbmp : WinDef.HBITMAP; oldHbmp : WinDef.HBITMAP; BEGIN deskHwnd := WinUser.GetDesktopWindow (); deskHdc := WinUser.GetDC (deskHwnd); <* ASSERT deskHdc # NIL *> memHdc := WinGDI.CreateCompatibleDC (deskHdc); <* ASSERT memHdc # NIL *> newHbmp := WinGDI.CreateCompatibleBitmap (deskHdc, width, height); <* ASSERT newHbmp # NIL *> oldHbmp := WinGDI.SelectObject (memHdc, newHbmp); <* ASSERT oldHbmp # NIL *> RETURN memHdc; END CreateMemoryDC; PROCEDUREInstallDefaultPalette (ur: Child) = (* Select the default palette into the device context, and realize it. *) VAR numCols: INTEGER; oldPal : WinDef.HPALETTE; BEGIN ur.hpal := WinScrnColorMap.DefaultPalette (); oldPal := WinGDI.SelectPalette (ur.hdc, ur.hpal, False); <* ASSERT oldPal # NIL *> numCols := WinGDI.RealizePalette (ur.hdc); <* ASSERT numCols # WinGDI.GDI_ERROR *> END InstallDefaultPalette; PROCEDUREReshapeVBT (ur: Child; width, height: INTEGER) = CONST Flags = WinUser.SWP_NOMOVE + WinUser.SWP_NOZORDER + WinUser.SWP_NOACTIVATE; BEGIN IF ur.hwnd # NIL THEN EVAL WinUser.SetWindowPos (ur.hwnd, NIL, 0, 0, width, height, Flags); END; END ReshapeVBT; PROCEDUREDeleteVBT (ur: Child) = VAR status: WinDef.BOOL; BEGIN IF (ur = NIL) THEN RETURN END; <*ASSERT ur.dead_vbt*> LOCK ur.trsl DO IF ur.offScreen THEN FreeGDIObjects (ur); ur.hwnd := NIL; DeleteChild (ur); ELSE (* make sure Windows gets rid of this guy too! *) status := WinUser.PostMessage (ur.hwnd, WinUser.WM_CLOSE, 0, 0); <* ASSERT status = True *> END; END; END DeleteVBT; PROCEDUREDestroyVBT (ur: Child) = BEGIN IF (ur = NIL) THEN RETURN END; IF (NOT ur.dead_vbt) THEN (* Windows called us, not Trestle *) LOCK VBT.mu DO DiscardVBT (ur); END; END; LOCK ur.trsl DO FreeGDIObjects (ur); ur.hwnd := NIL; DeleteChild (ur); END; END DestroyVBT; PROCEDUREFreeGDIObjects (ur: Child) = VAR status: WinDef.BOOL; hbmp: WinDef.HBITMAP; BEGIN IF (ur.hdc # NIL) THEN IF (ur.offScreen) THEN hbmp := WinGDI.GetCurrentObject (ur.hdc, WinGDI.OBJ_BITMAP); IF (hbmp # NIL) THEN status := WinGDI.DeleteObject (hbmp); <* ASSERT status = True *> END; status := WinGDI.DeleteDC (ur.hdc); <* ASSERT status = True *> END; ur.hdc := NIL; END; IF (ur.hpal # NIL) THEN (**** WinScrnColorMap.DefaultPalette returns a single global one... status := WinGDI.DeleteObject (ur.hpal); <* ASSERT status = True *> ******************************************************************) ur.hpal := NIL; END; END FreeGDIObjects; PROCEDUREForgeVBTEvent (ur: Child) = BEGIN LOCK VBT.mu DO VBTClass.Misc (ur.ch, VBT.MiscRec {VBT.TrestleInternal, VBT.NullDetail, WinBase.GetTickCount (), VBT.Forgery}); END; END ForgeVBTEvent; PROCEDUREIconizeVBT (ur: Child) = CONST DefaultNW = Point.T {50, 50}; CONST NewView = ARRAY BOOLEAN OF INTEGER { WinUser.SW_HIDE, WinUser.SW_MINIMIZE }; BEGIN IF ur.ch.st # NIL THEN EVAL WinUser.ShowWindow (ur.hwnd, NewView [ur.decorated]); ELSE CreateVBT (ur, NIL, DefaultNW, iconic := TRUE); END; END IconizeVBT; PROCEDUREOverlapVBT (ur : Child; READONLY nw : Point.T; knownPos : BOOLEAN) = CONST NOSIZE = WinUser.SWP_NOSIZE; NOMOVE = WinUser.SWP_NOMOVE; CONST Flags = ARRAY BOOLEAN OF INTEGER { NOSIZE + NOMOVE, NOSIZE }; VAR status: WinDef.BOOL; BEGIN IF ur.ch.st # NIL THEN (* The VBT is already mapped onto the screen *) status := WinUser.SetWindowPos (ur.hwnd, WinUser.HWND_TOP, nw.h, nw.v, 0, 0, Flags[knownPos]); <* ASSERT status = True *> ELSE (* The VBT is not yet mapped onto the screen *) CreateVBT (ur, trsl.screen, nw, iconic := FALSE); END; END OverlapVBT; PROCEDURERetitleVBT (ur: Child; old, new: TrestleClass.Decoration) = (* The decorations for hwnd have changed from old to new; this procedure relays this change to Windows. *) BEGIN IF new = NIL OR ur.hwnd = NIL THEN RETURN; END; IF WinUser.IsIconic (ur.hwnd) = 0 THEN (* window is not iconized *) IF old = NIL OR NOT Text.Equal (old.windowTitle, new.windowTitle) THEN SetWindowText (ur, new.windowTitle); END; ELSE (* window is iconized *) IF old = NIL OR NOT Text.Equal (old.iconTitle, new.iconTitle) THEN SetWindowText (ur, new.iconTitle); END; END; END RetitleVBT; PROCEDURESetWindowText (ur: Child; title: TEXT) = VAR status: WinDef.BOOL; BEGIN IF (ur.title_string # NIL) THEN M3toC.FreeCopiedS (ur.title_string); END; ur.title_string := M3toC.CopyTtoS (title); status := WinUser.SetWindowText (ur.hwnd, ur.title_string); <* ASSERT status # 0 *> END SetWindowText; PROCEDUREGetVBTSize (hwnd : WinDef.HWND; lParam : WinDef.LPARAM) = (* LL = 0 *) (* This code is taken almost verbatim from Steve. It determines the shape of the VBT corresponding to hwnd, and tells Windows to constrain the window accordingly. *) VAR v : VBT.T; sizes: ARRAY Axis.T OF VBT.SizeRange; got_sizes := FALSE; info := LOOPHOLE (lParam, WinUser.LPMINMAXINFO); (* lParam points to a windows structure. So, assigning to this structure changes a Windows data structure. In effect, lParam is an OUT parameter. *) BEGIN (* If "trsl.hwnd" is NIL, then we are right now in the process of creating the "null window" that represents the Trestle. In this case, we simply return. *) IF trsl.hwnd = NIL THEN RETURN; END; v:= GetVBT (hwnd); IF v = NIL THEN (* Windows insists on sending a WM_GETMINMAXINFO message for a freshly created window before returning that window's handle. As a hack, we'll capture the handle now. If we're wrong, the child record will get corrected when the CreateWindow() call returns... *) IF (create_child # NIL) AND (create_child.hwnd = NIL) THEN create_child.hwnd := hwnd; v := create_child.ch; sizes[Axis.T.Hor].lo := create_width; sizes[Axis.T.Hor].hi := create_width; sizes[Axis.T.Ver].lo := create_height; sizes[Axis.T.Ver].hi := create_height; got_sizes := TRUE; END; IF v = NIL THEN RETURN; END; END; IF NOT got_sizes THEN LOCK VBT.mu DO sizes := VBTClass.GetShapes (v); END; END; info.ptMaxSize.x := MIN (sizes[Axis.T.Hor].hi - 1 + nonclient_x, screen_x); info.ptMaxSize.y := MIN (sizes[Axis.T.Ver].hi - 1 + nonclient_y, screen_y); info.ptMinTrackSize.x := sizes[Axis.T.Hor].lo + nonclient_x; info.ptMinTrackSize.y := sizes[Axis.T.Ver].lo + nonclient_y; info.ptMaxTrackSize.x := info.ptMaxSize.x; info.ptMaxTrackSize.y := info.ptMaxSize.y; END GetVBTSize; PROCEDUREPaintVBT (hwnd: WinDef.HWND) = (* Repaint the damaged portion of the window *) VAR ur := GetChild (hwnd); info : WinUser.PAINTSTRUCT; hdc : WinDef.HDC; rgn : Region.T; rect : Rect.T;
* rc: WinDef.RECT; *
BEGIN
********* DEBUG (Paint: hwnd =
& Fmt.Unsigned(LOOPHOLE(hwnd, INTEGER))); DEBUG (hdc =
& Fmt.Unsigned(LOOPHOLE(ur.hdc, INTEGER))); EVAL WinUser.GetClientRect (hwnd, ADR(rc)); DEBUG (dom =
); PrintRect (ToRect (rc)); DEBUG (\n
); *********
hdc := WinUser.BeginPaint (hwnd, ADR (info)); IF (hdc # info.hdc) THEN DEBUG ("WM_PAINT: BeginPaint HDC # info HDC\n"); END; IF (hdc # NIL) AND (ur # NIL) AND (ur.ch # NIL) THEN (* there's still a vbt to paint... *) IF (hdc # ur.hdc) THEN DEBUG ("WM_PAINT: BeginPaint HDC # ur.hdc\n"); END; rect := ToRect (info.rcPaint);
* DEBUG (paint
); PrintRect (rect); DEBUG (\n
);**
rgn := Region.FromRect (Rect.Full (* rect*)); LOCK VBT.mu DO VBTClass.Repaint (ur.ch, rgn); END; END; EVAL WinUser.EndPaint (hwnd, ADR (info)); END PaintVBT;****************** PROCEDURE PaintVBT (hwnd: WinDef.HWND) = (* Repaint the damaged portion of the window
VAR r : WinDef.RECT; status: WinDef.BOOL; v := GetVBT (hwnd); rgn : Region.T; BEGIN (*** If the VBT is already deleted, bail out ***) IF (v = NIL) THEN RETURN; END; IF WinUser.GetUpdateRect (hwnd, ADR(r), False) = True THEN status := WinUser.ValidateRect (hwnd, ADR(r)); <* ASSERT status = True *> rgn := Region.FromRect (ToRect (r)); LOCK VBT.mu DO VBTClass.Repaint (v, rgn); END; END; END PaintVBT; ***************) PROCEDUREMoveVBT (hwnd: WinDef.HWND) = VAR rc : WinDef.RECT; new : Rect.T; v : VBT.T := GetVBT (hwnd); status: WinDef.BOOL; BEGIN (*** If the VBT is already deleted, bail out ***) IF v = NIL THEN RETURN; END; status := WinUser.GetClientRect (hwnd, ADR(rc)); <* ASSERT status = True *> new := ToRect (rc); LOCK VBT.mu DO IF v.domain # new THEN VBTClass.Reshape (v, new, Rect.Meet(v.domain, new)); ELSE VBTClass.Misc (v, VBT.MiscRec{VBT.Moved, VBT.NullDetail, 0, VBT.NilSel}); END; END; END MoveVBT; PROCEDUREActivateVBT (hwnd: WinDef.HWND; wParam: WinDef.WPARAM) = (* This is derived from "XMessenger.EnterLeave". The original procedure does a lot more ... *) VAR v := GetVBT (hwnd); time := WinUser.GetMessageTime () + 1; BEGIN (*** If the VBT is already deleted, bail out ***) IF v = NIL THEN RETURN; END; EVAL WinUser.SetFocus (hwnd); LOCK VBT.mu DO IF WinDef.LOWORD (wParam) = WinUser.WA_INACTIVE THEN VBTClass.Misc(v, VBT.MiscRec{VBT.Lost, VBT.NullDetail, 0, VBT.KBFocus}) ELSE VBTClass.Misc(v, VBT.MiscRec{VBT.TakeSelection, VBT.NullDetail, time, VBT.KBFocus}); END; END; END ActivateVBT; PROCEDURESetVBTCursor (hwnd: WinDef.HWND) = VAR v := GetVBT (hwnd); cs: ScrnCursor.T; BEGIN IF (v # NIL) THEN LOCK VBT.mu DO LOCK v DO cs := v.getcursor(); END; END; WinScrnCursor.SetCursor (cs); END; END SetVBTCursor; PROCEDUREQueryVBTPalette (hwnd: WinDef.HWND) = VAR v := GetVBT (hwnd); ur : Child; numCols : INTEGER; status : WinDef.BOOL; oldPal : WinDef.HPALETTE; BEGIN (*** If the VBT is already deleted, bail out ***) IF (v = NIL) THEN RETURN; END; ur := v.upRef; IF (ur # NIL) AND (ur.hpal # NIL) THEN oldPal := WinGDI.SelectPalette (ur.hdc, ur.hpal, False); <* ASSERT oldPal # NIL *> status := WinGDI.UnrealizeObject (ur.hpal); <* ASSERT status = True *> numCols := WinGDI.RealizePalette (ur.hdc); <* ASSERT numCols # WinGDI.GDI_ERROR *> END; END QueryVBTPalette; PROCEDUREVBTKeyPress (hwnd: WinDef.HWND; wParam: WinDef.WPARAM; down: BOOLEAN) = (* need to update the per-Trestle modifier set and translate the Windows virtual key into a Trestle KeySym. *) VAR v := GetVBT (hwnd); keysym := WinKey.Translate (wParam); time := WinUser.GetMessageTime(); modifiers := GetModifiers (); BEGIN (*** If the VBT is already deleted, bail out ***) IF (v = NIL)THEN RETURN; END; LOCK VBT.mu DO VBTClass.Key (v, VBT.KeyRec {keysym, time, down, modifiers}); END; END VBTKeyPress; TYPE Button = {None, Left, Middle, Right}; Transition = {Press, Release}; Last = RECORD x, y : INTEGER := 0; time : WinDef.LONG := 0; button : Button := Button.None; clickCount : CARDINAL := 0; safetyRadius : CARDINAL := 3; doubleClickInterval : CARDINAL := 500; END;
last.{x,y} = position of last mouseclick; last.time = time of last mouseClick; last.clickCount = clickcount of last mouseclick, as defined in the VBT interface; last.button = button that last went up or down.
PROCEDUREButtonEvent (hwnd : WinDef.HWND; lParam: WinDef.LPARAM; wParam: WinDef.WPARAM; button: Button; trans : Transition) = VAR oldFocus := trsl.mouseFocus; time := WinUser.GetMessageTime (); clientPos := WinDef.POINT {WinDef.LOWORD (lParam), WinDef.HIWORD (lParam)}; screenPos := clientPos; focusPos := clientPos; status : WinDef.BOOL; v : VBT.T; ur : Child; cd : VBT.MouseRec; CONST NonButtons = VBT.Modifiers{FIRST(VBT.Modifier).. LAST(VBT.Modifier)} - VBT.Buttons; BEGIN status := WinUser.ClientToScreen (hwnd, ADR (screenPos)); <* ASSERT status = True *> (* If "hwnd" refers to the window that has captured the mouse (as opposed to the topmost window beneath the mouse cursor), we determine what window (if any) is below the cursor. If there is one, we set "hwnd" to be the window handle of this window, and translate "clientPos" to be in the coordinate space of this window. *) IF trsl.mouseFocus # NIL THEN WITH topHwnd = WinUser.WindowFromPoint (screenPos) DO IF topHwnd # NIL THEN hwnd := topHwnd; clientPos := screenPos; status := WinUser.ScreenToClient (hwnd, ADR (clientPos)); <* ASSERT status = True *> END; END; END; v := GetVBT (hwnd); (* Determine "cd.button", "cd.modifiers", and "cd.clickType". *) cd.modifiers := ExtractModifiers (wParam); CASE button OF | Button.None => <* ASSERT FALSE *> | Button.Left => cd.whatChanged := VBT.Modifier.MouseL; | Button.Middle => cd.whatChanged := VBT.Modifier.MouseM; | Button.Right => cd.whatChanged := VBT.Modifier.MouseR; END; IF trans = Transition.Press THEN cd.modifiers := cd.modifiers - VBT.Modifiers{cd.whatChanged}; IF cd.modifiers <= NonButtons THEN cd.clickType := VBT.ClickType.FirstDown; trsl.mouseFocus := v; IF v # NIL THEN EVAL WinUser.SetCapture (hwnd); END; ELSE cd.clickType := VBT.ClickType.OtherDown END ELSE IF cd.modifiers <= NonButtons THEN cd.clickType := VBT.ClickType.LastUp; trsl.mouseFocus := NIL; status := WinUser.ReleaseCapture (); <* ASSERT status = True *> ELSE cd.clickType := VBT.ClickType.OtherUp END; cd.modifiers := cd.modifiers + VBT.Modifiers{cd.whatChanged}; END; cd.time := time; IF v # NIL THEN ur := v.upRef; IF Word.Minus(time, ur.last.time) <= ur.last.doubleClickInterval AND ABS(ur.last.x - clientPos.x) <= ur.last.safetyRadius AND ABS(ur.last.y - clientPos.y) <= ur.last.safetyRadius AND ur.last.button = button THEN INC(ur.last.clickCount) ELSE ur.last.clickCount := 0; ur.last.x := clientPos.x; ur.last.y := clientPos.y; ur.last.button := button END; ur.last.time := time; SetCursorPosition (clientPos.x, clientPos.y, hwnd, cd.cp); cd.clickCount := ur.last.clickCount; LOCK VBT.mu DO ur.cageCovered := TRUE; VBTClass.Position (v, VBT.PositionRec{cd.cp, cd.time, cd.modifiers}); VBTClass.Mouse(v, cd); ur.cageCovered := FALSE; END; LOCK v DO trsl.setcage (v); END; END; IF oldFocus # NIL AND oldFocus # v THEN cd.cp.offScreen := FALSE; cd.cp.pt.h := focusPos.x; cd.cp.pt.v := focusPos.y; cd.cp.gone := TRUE; LOCK VBT.mu DO VBTClass.Mouse(oldFocus, cd); END; END;
*** Enter(trsl); TRY FOR s := FIRST(trsl.sel^) TO LAST(trsl.sel^) DO WITH sr = trsl.sel[s] DO IF s = VBT.KBFocus.sel THEN IF sr.v = v AND ur.isXFocus THEN X.XSetInputFocus(trsl.dpy, ur.w, X.RevertToParent, time); sr.ts := time END ELSIF sr.v = v THEN X.XSetSelectionOwner(trsl.dpy, sr.name, ur.w, time); sr.ts := time END END END FINALLY Exit(trsl) END ***
END ButtonEvent;
ExtractModifiers
takes a WinDef.WPARAM
that was typically delivered by
a Windows Mouse Input Message (e.g. WM_MOUSEMOVE or WM_LBUTTONDOWN), and
converts it into a Trestle VBT.Modifiers
, that is, into a set of modifier
keys and buttons.
Note: I handle only 5 out of 12 modifiers. In particular, I don't handle
Option
and Shift Lock
.
PROCEDURENote: This procedure may not be called with trsl being held, since the call toExtractModifiers (wParam: WinDef.WPARAM): VBT.Modifiers = VAR mods := VBT.Modifiers {}; BEGIN IF Word.And (wParam, WinUser.MK_SHIFT) # 0 THEN mods := mods + VBT.Modifiers {VBT.Modifier.Shift}; END; IF Word.And (wParam, WinUser.MK_CONTROL) # 0 THEN mods := mods + VBT.Modifiers {VBT.Modifier.Control}; END; IF Word.And (wParam, WinUser.MK_LBUTTON) # 0 THEN mods := mods + VBT.Modifiers {VBT.Modifier.MouseL}; END; IF Word.And (wParam, WinUser.MK_MBUTTON) # 0 THEN mods := mods + VBT.Modifiers {VBT.Modifier.MouseM}; END; IF Word.And (wParam, WinUser.MK_RBUTTON) # 0 THEN mods := mods + VBT.Modifiers {VBT.Modifier.MouseR}; END; IF Word.And (WinUser.GetKeyState (WinUser.VK_LMENU),16_8000) # 0 THEN mods := mods + VBT.Modifiers {VBT.Modifier.Option}; END; IF Word.And (WinUser.GetKeyState (WinUser.VK_CAPITAL),16_0001) # 0 THEN mods := mods + VBT.Modifiers {VBT.Modifier.Lock}; END; RETURN mods; END ExtractModifiers; PROCEDUREGetModifiers (): VBT.Modifiers = VAR mods := VBT.Modifiers {}; BEGIN IF Word.And (WinUser.GetKeyState (WinUser.VK_CONTROL),16_8000) # 0 THEN mods := mods + VBT.Modifiers {VBT.Modifier.Control}; END; IF Word.And (WinUser.GetKeyState (WinUser.VK_SHIFT),16_8000) # 0 THEN mods := mods + VBT.Modifiers {VBT.Modifier.Shift}; END; IF Word.And (WinUser.GetKeyState (WinUser.VK_LMENU),16_8000) # 0 THEN mods := mods + VBT.Modifiers {VBT.Modifier.Option}; END; IF Word.And (WinUser.GetKeyState (WinUser.VK_CAPITAL),16_0001) # 0 THEN mods := mods + VBT.Modifiers {VBT.Modifier.Lock}; END; IF Word.And (WinUser.GetKeyState (WinUser.VK_LBUTTON),16_8000) # 0 THEN mods := mods + VBT.Modifiers {VBT.Modifier.MouseL}; END; IF Word.And (WinUser.GetKeyState (WinUser.VK_MBUTTON),16_8000) # 0 THEN mods := mods + VBT.Modifiers {VBT.Modifier.MouseM}; END; IF Word.And (WinUser.GetKeyState (WinUser.VK_RBUTTON),16_8000) # 0 THEN mods := mods + VBT.Modifiers {VBT.Modifier.MouseR}; END; RETURN mods; END GetModifiers; PROCEDURESetCursorPosition (x, y: INTEGER; hwnd: WinDef.HWND; VAR(*OUT*) cp: VBT.CursorPosition) = VAR r : WinDef.RECT; status := WinUser.GetClientRect (hwnd, ADR (r)); BEGIN <* ASSERT status = True *> cp.pt.h := x; cp.pt.v := y; cp.screen := DesktopID; cp.offScreen := FALSE; cp.gone := x < r.left OR x >= r.right OR y < r.top OR y >= r.bottom; END SetCursorPosition; PROCEDURETimerTick (hwnd: WinDef.HWND) = VAR status : WinDef.BOOL; screenPos: WinDef.POINT; lParam : WinDef.LPARAM; BEGIN IF trsl.mouseFocus = NIL THEN status := WinUser.GetCursorPos (ADR (screenPos)); <* ASSERT status = True *> lParam := LOOPHOLE (WinDef.POINTS {screenPos.x, screenPos.y}, WinDef.LPARAM); DeliverMousePos (hwnd, lParam, 0); END; END TimerTick; PROCEDUREDeliverMousePos (hwnd : WinDef.HWND; lParam: WinDef.LPARAM; wParam: WinDef.WPARAM) = (* LL = VBT.mu *) VAR screenPos := WinDef.POINT {WinDef.LOWORD (lParam), WinDef.HIWORD (lParam)}; clientPos : WinDef.POINT; status : WinDef.BOOL; copy : RootList; ur : Child; BEGIN IF hwnd # trsl.hwnd THEN status := WinUser.ClientToScreen (hwnd, ADR (screenPos)); <* ASSERT status = True *> END; LOCK trsl DO IF (trsl.lastPos = screenPos) AND (trsl.n_cages <= 0) THEN (* the mouse didn't move and nobody cares... *) RETURN; ELSE (* reset the existing cages and deliver the new position *) trsl.n_cages := 0; trsl.lastPos := screenPos; END; END; (* grab a copy of the existing roots *) copy := CopyRoots (); FOR i := FIRST (copy^) TO LAST (copy^) DO ur := copy[i]; IF (ur # NIL) (* AND (ur.cageSet)*) THEN ur.cageSet := FALSE; IF (ur.hwnd # NIL) AND (ur.ch # NIL) THEN clientPos := screenPos; status := WinUser.ScreenToClient (ur.hwnd, ADR (clientPos)); <* ASSERT status = True *> MouseMotion (ur.hwnd, ur.ch, clientPos, wParam); END; END; END; RecycleCopy (copy); END DeliverMousePos;
VBTClass.Position
might lead to a call back into WinTrestle
and an
attempt to acquire trsl
.
PROCEDURE*** IF ur # NIL AND lost THEN LOCK trsl DO XProperties.ExtendOwns(ur.owns, VBT.KBFocus); ur.owns[VBT.KBFocus.sel] := FALSE; IF trsl.sel[VBT.KBFocus.sel].v = v THEN trsl.sel[VBT.KBFocus.sel].v := NIL END END; VBTClass.Misc( v, VBT.MiscRec{VBT.Lost, VBT.NullDetail, 0, VBT.KBFocus}) ELSIF takeFocus THEN LOCK trsl DO ur.recentlyOutside := FALSE END; VBTClass.Misc(v, VBT.MiscRec{VBT.TakeSelection, VBT.NullDetail, time, VBT.KBFocus}) END ***MouseMotion (hwnd : WinDef.HWND; v : VBT.T; clientPos: WinDef.POINT; wParam : WinDef.WPARAM ) = (* LL = 0 *) VAR cd: VBT.PositionRec; BEGIN cd.time := WinUser.GetMessageTime (); cd.modifiers := ExtractModifiers (wParam); SetCursorPosition (clientPos.x, clientPos.y, hwnd, cd.cp); IF cd.cp.gone AND v = trsl.current THEN trsl.current := NIL; ELSIF NOT cd.cp.gone AND v # NIL THEN trsl.current := v END; LOCK VBT.mu DO VBTClass.Position (v, cd); END;
END MouseMotion; PROCEDURE------------------------------ VBT <-> Child <-> Window Handle mappings ---ToRect (READONLY r: WinDef.RECT): Rect.T = BEGIN RETURN Rect.T{west := r.left, east := r.right, north := r.top, south := r.bottom} END ToRect;
TYPE RootList = REF ARRAY OF Child; VAR root_mu := NEW (MUTEX); n_roots := 0; roots := NEW (RootList, 10); spare_copy : RootList := NIL; (* "roots" provides the mapping from child uids to children. It is also searched to convert a window handle to a VBT. The following relationships hold: "roots[ur.uid] = ur = ur.ch.upRef". LL = root_mu *) PROCEDURE*************************************************************************** Garbage-Collection Cursor ***************************************************************************NewChild (trsl: T): Child = (* LL < root_mu *) VAR ch := NEW (Child); i := 0; BEGIN LOCK root_mu DO IF (n_roots >= NUMBER (roots^)) THEN ExpandRoots (); END; WHILE (roots[i] # NIL) DO INC (i); END; ch.uid := i; ch.trsl := trsl; roots[i] := ch; INC (n_roots); END; RETURN ch; END NewChild; PROCEDUREExpandRoots () = (* LL = root_mu *) VAR n := NUMBER (roots^); new := NEW (RootList, n + n); BEGIN SUBARRAY (new^, 0, n) := roots^; roots := new; END ExpandRoots; PROCEDUREDeleteChild (ch: Child) = (* LL < root_mu *) BEGIN LOCK root_mu DO roots [ch.uid] := NIL; ch.uid := -1; ch.trsl := NIL; END; END DeleteChild; PROCEDUREGetChild (hwnd: WinDef.HWND): Child = (* LL < root_mu *) VAR ch: Child; BEGIN LOCK root_mu DO FOR i := 0 TO LAST (roots^) DO ch := roots[i]; IF (ch # NIL) AND (ch.hwnd = hwnd) THEN RETURN ch; END; END; END; RETURN NIL; END GetChild; PROCEDUREGetVBT (hwnd: WinDef.HWND): VBT.T = VAR ch := GetChild (hwnd); BEGIN IF (ch # NIL) AND (ch.ch # NIL) THEN RETURN ch.ch; END; (***** DEBUG ("Could not map window handle " & Fmt.Unsigned (LOOPHOLE (hwnd, INTEGER))); IF (ch = NIL) THEN DEBUG (" to a WinTrestle.Child ...\n"); ELSE DEBUG (" to a VBT.T ...\n"); END; ******) RETURN NIL; END GetVBT; PROCEDURECopyRoots (): RootList = VAR copy: RootList; n := 0; ch: Child; BEGIN LOCK root_mu DO copy := spare_copy; spare_copy := NIL; IF (copy = NIL) OR (NUMBER (copy^) < n_roots) THEN copy := NEW (RootList, NUMBER (roots^)) END; FOR i := FIRST (roots^) TO LAST (roots^) DO ch := roots[i]; IF (ch # NIL) THEN copy[n] := ch; INC (n); END; END; END; FOR i := n TO LAST (copy^) DO copy[i] := NIL; END; RETURN copy; END CopyRoots; PROCEDURERecycleCopy (copy: RootList) = BEGIN IF (copy = NIL) THEN RETURN; END; LOCK root_mu DO IF (spare_copy = NIL) OR (NUMBER (copy^) > NUMBER (spare_copy^)) THEN spare_copy := copy; END; END; END RecycleCopy;
VAR showGC := NOT RTParams.IsPresent("StarTrek") AND NOT (RTCollectorSRC.incremental AND RTHeapDep.VM AND RTHeapRep.disableVMCount = 0);
If showGC is TRUE, the cursor of every installed window will change to the Star Trek cursor whenever the garbage collector is running. At runtime, you can force no StarTrek cursor by running your program @M3StarTrek.
TYPE GCClosure = RTHeapRep.MonitorClosure OBJECT trsl: T; OVERRIDES before := HackOn; after := HackOff END; PROCEDURE****** PROCEDURE HackToggle (trsl: T; on: BOOLEAN) = <*FATAL Split.NotAChild*> BEGIN IF on THEN oldCursor := WinUser.SetCursor (gcCursor); DEBUG (DoHackInit (trsl: T) = BEGIN IF showGC THEN RTHeapRep.RegisterMonitor(NEW(GCClosure, trsl := trsl)) END; END DoHackInit; PROCEDUREHackOn (cl: GCClosure) = BEGIN IF NOT ((RTCollectorSRC.incremental AND RTHeapDep.VM AND RTHeapRep.disableVMCount = 0)) THEN HackToggle(cl.trsl, TRUE); hacking := TRUE END END HackOn; PROCEDUREHackOff (cl: GCClosure) = BEGIN IF hacking THEN HackToggle(cl.trsl, FALSE); hacking := FALSE END END HackOff; VAR hacking := FALSE; (** oldCursor : WinDef.HCURSOR; **) (** gcCursor : WinDef.HCURSOR; **) PROCEDUREHackToggle (<*UNUSED*> trsl: T; <*UNUSED*> on: BOOLEAN) = BEGIN END HackToggle;
Starting GC ................................\n
);
ELSE
EVAL WinUser.SetCursor (oldCursor);
DEBUG (................................ Finished GC\n
);
END;
IF NOT trsl.dead THEN
VAR v := Split.Succ(trsl, NIL);
BEGIN
WHILE v # NIL DO
VAR ur: Child := v.upRef;
BEGIN
IF ur # NIL AND ur.hwnd # NIL AND ur.xcage # X.None THEN
IF on THEN
EVAL Win.SetCursor (ur.X.XDefineCursor(dpy, ur.w, trsl.gcCursor)
ELSE
X.XDefineCursor(dpy, ur.w, ur.csid)
END
END
END;
v := Split.Succ(trsl, v)
END
END;
END
END HackToggle;
****
*************************************************************************** Window-creation and message-handling thread ***************************************************************************
VAR messenger_started := FALSE; cond := NEW (Thread.Condition); (* used to signal the main thread that "trsl.hwnd" has been created. *) PROCEDURE------------------------------------------------------------- Debugging ---CreateTrestle () = VAR mu := NEW (MUTEX); BEGIN trsl := NEW(T); DoHackInit(trsl); trsl.st := NEW(VBT.ScreenType); (* The st is irrelevant except that it must be non-NIL so that marking the trsl for redisplay is not a noop. *) trsl.screen := WinScreenType.New(trsl); EVAL Thread.Fork (NEW (Thread.Closure, apply := MessengerApply)); (* wait for the messenger thread to finish its setup *) LOCK mu DO WHILE NOT messenger_started DO Thread.Wait (mu, cond); END; END; END CreateTrestle; PROCEDUREMessengerApply (<*UNUSED*> cl: Thread.Closure): REFANY = VAR class := M3toC.CopyTtoS("Trestle Desktop"); msg : WinUser.MSG; BEGIN trslThread := Thread.Self (); (* First, we have to register a window class for the "null window". *) RegisterWindowClass (class, topLevel := TRUE); (* Now, we can actually create the "null window" *) trsl.hwnd := WinUser.CreateWindow( class, NIL, WinUser.WS_DISABLED, WinUser.CW_USEDEFAULT, WinUser.CW_USEDEFAULT, WinUser.CW_USEDEFAULT, WinUser.CW_USEDEFAULT, NIL, NIL, hInst, NIL); <* ASSERT trsl.hwnd # NIL *> (* Register a class for the rest of the Trestle windows *) RegisterWindowClass (windowclassName, topLevel := FALSE); (* Signal "CreateTrestle" that the null window is created. *) messenger_started := TRUE; Thread.Signal (cond); (* Start a Windows Timer with 0.1 sec clicks *) trsl.timerId := WinUser.SetTimer (trsl.hwnd, 1, 100, NIL); (* start the message loop for all windows belonging to this Trestle *) WHILE WinUser.GetMessage (ADR(msg), NIL, 0, 0) = True DO EVAL WinUser.TranslateMessage (ADR(msg)); EVAL WinUser.DispatchMessage (ADR(msg)); END; (* received WM_QUIT message -- exiting *) RETURN NIL; END MessengerApply; PROCEDURERegisterWindowClass (name: Ctypes.char_star; topLevel: BOOLEAN) = VAR wc : WinUser.WNDCLASS; status: WinDef.BOOL; BEGIN hInst := RTLinker.info.instance; wc.style := WinUser.CS_HREDRAW + WinUser.CS_VREDRAW; wc.lpfnWndProc := WindowProc; wc.cbClsExtra := 0; wc.cbWndExtra := 0; wc.hInstance := hInst; wc.hIcon := WinUser.LoadIcon (NIL, WinUser.IDI_APPLICATION); wc.hCursor := NIL; wc.hbrBackground := NIL; wc.lpszMenuName := NIL; wc.lpszClassName := name; IF topLevel THEN wc.hCursor := WinUser.LoadCursor (NIL, WinUser.IDC_ARROW); ELSE hAccelTable := WinUser.LoadAccelerators(hInst, windowclassName); INC (wc.style, WinUser.CS_OWNDC); (* other styles to consider: CS_GLOBALCLASS, CS_PARENTDC, CS_SAVEBITS *) (** gcCursor := WinUser.LoadCursor (NIL, WinUser.IDC_APPSTARTING); **) END; status := WinUser.RegisterClass (ADR(wc)); <* ASSERT status # 0 *> END RegisterWindowClass;
PROCEDURE*********** PROCEDURE PrintChild (ur: Child) = BEGIN DEBUG (Fmt.Unsigned (LOOPHOLE (ur, INTEGER)) &DEBUG (msg: TEXT) = BEGIN RTIO.PutText (msg); RTIO.Flush (); END DEBUG;
{ ch:
& Fmt.Unsigned (LOOPHOLE (ur.ch, INTEGER))
& hwnd:
& Fmt.Unsigned (LOOPHOLE (ur.hwnd, INTEGER))
& hdc:
& Fmt.Unsigned (LOOPHOLE (ur.hdc, INTEGER))
& offS:
& Fmt.Bool (ur.offScreen)
& }
);
END PrintChild;
***********
*********
PROCEDURE PrintRect (READONLY r: Rect.T) =
BEGIN
DEBUG ([
& Fmt.Int (r.west) & ..
& Fmt.Int (r.east)
& x
& Fmt.Int (r.north) & ..
& Fmt.Int (r.south)
& ]
);
END PrintRect;
**********
VAR msg_indent := 0; msg_uid := 1; PROCEDURE************ PROCEDURE DumpSystemPalette (hdc : WinDef.HDC) = TYPE PaletteList = REF ARRAY OF WinGDI.PALETTEENTRY; VAR num1, num2 : INTEGER; entries : PaletteList; BEGIN (* Determine size of system palettePrintMessageType (message: WinDef.UINT; debug_id: INTEGER): INTEGER = VAR txt: TEXT; BEGIN IF (message = WinUser.WM_TIMER) THEN RETURN msg_uid; END; IF (debug_id # 0) THEN DEC (msg_indent); END; IF (debug_id # msg_uid) THEN FOR i := 1 TO msg_indent DO DEBUG (" | "); END; DEBUG("msg " & Fmt.Int(message) & " = "); txt := WinMsg.ToText (message); IF (txt # NIL) THEN DEBUG (txt); ELSE DEBUG ("???"); END; DEBUG("\n"); IF slow_trace THEN Thread.Pause (1.0d0); END; END; IF (debug_id = 0) THEN INC (msg_indent); END; INC (msg_uid); RETURN msg_uid; END PrintMessageType;
num1 := WinGDI.GetSystemPaletteEntries (hdc, 0, 256, NIL); <* ASSERT num1 # 0 *> (* Get the system palette entries *) entries := NEW (PaletteList, num1); num2 := WinGDI.GetSystemPaletteEntries (hdc, 0, num1, ADR(entries[0])); <* ASSERT num2 = num1 *> FOR i := 0 TO num2 - 1 DO DEBUG ("entry[" & Fmt.Int (i) &"] = {" & Fmt.Int (entries[i].peRed) & "," & Fmt.Int (entries[i].peGreen) & "," & Fmt.Int (entries[i].peBlue) & "," & Fmt.Int (entries[i].peFlags) & "}\n"); END; END DumpSystemPalette; ************)-------------------------------------------------------- initialization ---
BEGIN CreateTrestle (); END WinTrestle.