diff --git a/ChangeLog.n b/ChangeLog.n index 38a6f69278d70427a2f91ffa2b02f4076b6aaac6..c8e7db73e66c307e03f9520f99e72b434aa75c3c 100644 --- a/ChangeLog.n +++ b/ChangeLog.n @@ -1,3 +1,19 @@ +2007-04-24 Andreas Fuchs <asf@boinkor.net> + + * aclpc/acl-class.lisp, aclpc/acl-port.lisp: + * Refactor most ACL port-specific special variables to be + slots of the acl-port instance. + * Change reset-aclpc-clim to only destroy the port and reset + the few remaining special variables + * aclpc/acl-dc: Refer to the slots of *acl-port*. + * aclpc/acl-frames.lisp: Refer to the slots of *acl-port*. + * aclpc/acl-medium.lisp: Refer to the slots of *acl-port*. + * aclpc/acl-mirror.lisp: Refer to the slots of *acl-port*. + * aclpc/acl-prel.lisp: Refer to the slots of *acl-port*. + * aclpc/acl-scroll.lisp: Refer to the slots of *acl-port*. + * aclpc/acl-widget.lisp: Refer to the slots of *acl-port*. + * sys/odrawpat.lisp: Refer to the slots of *acl-port*. + ******************************************************************************* join from trunk_afuchs2 to trunk changes from: @@ -6155,4 +6171,4 @@ IGNORE JDI SPECIFIC CHANGES TO Makefile Lots of other stuff ******************************************************************************* -$Revision: 2.32 $ +$Revision: 2.33 $ diff --git a/aclpc/acl-class.lisp b/aclpc/acl-class.lisp index d3d4d6a13b04cd766a586f6360be4cafb115ac95..969b514975a12da49e16dbec68c4a7ec3fc2217a 100644 --- a/aclpc/acl-class.lisp +++ b/aclpc/acl-class.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: acl-class.lisp,v 2.18 2007/04/17 21:45:48 layer Exp $ +;; $Id: acl-class.lisp,v 2.19 2007/04/25 20:29:26 layer Exp $ #|**************************************************************************** * * @@ -32,15 +32,6 @@ (defvar *acl-port* nil) -;; this will grow indefinitely as menu-ids are never removed (cim 9/10/96) -(defvar *menu-id->command-table* - (make-array 256 - :element-type t :adjustable t - :fill-pointer 0 :initial-element nil)) - -;; this will grow indefinitely as items are never removed (cim 9/10/96) -(defvar *popup-menu->menu-item-ids* (make-hash-table)) - ;; this will grow indefinitely as items are never removed (cim 9/10/96) (defvar *popup-menu->command-table* (make-hash-table)) @@ -55,19 +46,10 @@ (defun mformat (&rest args) (if *maybe-format* (apply #'format args))) -(defvar *msg-names* nil) - -(defun init-msg-names () - (setq *msg-names* (make-array 4096)) - (dolist (x (remove-duplicates - (apropos-list "WM_" (find-package :win)))) - (when (<= 0 (symbol-value x) 4095) - (push x (svref *msg-names* (symbol-value x)))))) (defun msg-name (msg) - (unless *msg-names* (init-msg-names)) (let ((x (and (< msg 4096) ;; pr Aug97 - (svref *msg-names* msg)))) + (svref (msg-names *acl-port*) msg)))) (unless (cdr x) (setq x (car x))) (or x msg))) @@ -89,27 +71,18 @@ (make-modifier-state :meta) (make-modifier-state))))) -(defvar *modstate* (make-modstate)) -(defvar *ctlmodstate* (make-modstate)) -(defvar *win-result* 0) - -(defparameter arrow-cursor - (ff:allocate-fobject 'win:hcursor :foreign-static-gc nil)) -(defparameter application-icon - (ff:allocate-fobject 'win:hicon :foreign-static-gc nil)) - ;;;;; window procedure args, rebound in each call to window proc ;;;(defvar *hwnd* 0) (defun init-cursors () ;; put back old cursor mechanism for the moment (cim 9/13/96) - (setf arrow-cursor (win:LoadCursor 0 win:IDC_ARROW)) - (when (zerop arrow-cursor) + (setf (arrow-cursor *acl-port*) (win:LoadCursor 0 win:IDC_ARROW)) + (when (zerop (arrow-cursor *acl-port*)) (check-last-error "LoadCursor" :action :warn)) ;; this just does the icon now - the cursor stuff is all handled in ;; realize-cursor methods in acl-port (cim 9/12/96) - (setf application-icon (win:LoadIcon 0 win:IDI_APPLICATION)) - (when (zerop application-icon) + (setf (application-icon *acl-port*) (win:LoadIcon 0 win:IDI_APPLICATION)) + (when (zerop (application-icon *acl-port*)) (check-last-error "LoadIcon" :action :warn)) t) @@ -170,16 +143,6 @@ (defvar *level* 0) -(defvar *realtime-scrollbar-tracking* t) - -(defvar *win-scroll-grain* - ;; Must be a 16-bit quantity. - ;; According to Microsoft, WM_HSCROLL and WM_VSCROLL messages - ;; are "limited to 16 bits of position data". - ;; (alemmens, 2004-12-17) - (1- (expt 2 16))) - - (defmacro clear-winproc-result (res) (declare (ignore res)) nil) @@ -199,7 +162,7 @@ (keys wparam) (sheet (mirror->sheet *acl-port* window))) (declare (ignore keys)) - (setq *win-result* + (setf (win-result *acl-port*) (if (or (not sheet) (note-pointer-motion *acl-port* sheet mx my)) (win:DefWindowProc window msg wparam lparam) @@ -211,7 +174,7 @@ ;; when the cursor is not moving. JPM 5/98. (let* ((hit-code (loword lparam))) (cond ((eql hit-code win:HTCLIENT) - (setq *win-result* + (setf (win-result *acl-port*) (if (maybe-set-cursor (mirror->sheet *acl-port* window)) win:TRUE win:FALSE))) (t @@ -294,7 +257,7 @@ (win:GetClientRect hwnd rect) (silica::draw-picture-button sheet 0 hdc rect))) - (setf *win-result* (adjust-gadget-colors sheet hdc)))))) + (setf (win-result *acl-port*) (adjust-gadget-colors sheet hdc)))))) ;; Process WM_COMMAND. ;; This message is sent when the user selects a command item @@ -311,7 +274,7 @@ ;; User selected a command from the menu bar. (let* ((frame (pane-frame parent)) (ID (loword wparam)) - (command (cdr (aref *menu-id->command-table* ID)))) + (command (cdr (aref (menu-id->command-table port) ID)))) ;;mm bug12977 (handler-case @@ -334,7 +297,7 @@ (let ((gadget (mirror->sheet port lparam))) (when gadget (command-event gadget port parent wparam lparam))))) - (clear-winproc-result *win-result*) + (clear-winproc-result (win-result *acl-port*)) 0)) @@ -418,8 +381,8 @@ (case scrollcode (#.win:SB_BOTTOM ;; Scroll to lower right - (win:SetScrollPos hwnd bar *win-scroll-grain* redraw) - (values :percentage *win-scroll-grain*)) + (win:SetScrollPos hwnd bar (win-scroll-grain *acl-port*) redraw) + (values :percentage (win-scroll-grain *acl-port*))) ((#.win:SB_LINEDOWN #.win:SB_LINERIGHT) ;; Scroll down/right one line (move-slug sheet hwnd bar +1 #'silica::scroll-bar-line-increment) @@ -461,8 +424,8 @@ :dragging-p (= scrollcode #.win:SB_THUMBTRACK) :amount amount :sheet sheet))))) - (clear-winproc-result *win-result*) - *win-result*)) + (clear-winproc-result (win-result *acl-port*)) + (win-result *acl-port*))) (defun move-slug (scroll-bar hwnd win-code direction delta-function) ;; Only move slug for independent scroll bar gadgets. @@ -474,7 +437,7 @@ (tentative-new-position (+ old-position (* direction (silica::convert-scroll-bar-size-out scroll-bar delta)))) - (new-position (max 0 (min *win-scroll-grain* tentative-new-position))) + (new-position (max 0 (min (win-scroll-grain *acl-port*) tentative-new-position))) (redraw 1)) (unless (= old-position new-position) (win:SetScrollPos hwnd win-code new-position redraw))))) @@ -496,9 +459,9 @@ sheet (allocate-event 'window-configuration-event :sheet sheet)) ;; set return value to 0 - (clear-winproc-result *win-result*)) - (setq *win-result* (win:DefWindowProc window msg wparam lparam))) - *win-result*)) + (clear-winproc-result (win-result *acl-port*))) + (setf (win-result *acl-port*) (win:DefWindowProc window msg wparam lparam))) + (win-result *acl-port*))) ;; Process WM_SIZE (defun onsize (window msg wparam lparam) @@ -511,9 +474,9 @@ sheet (allocate-event 'window-configuration-event :sheet sheet)) ;; set return value to 0 - (clear-winproc-result *win-result*)) - (setq *win-result* (win:DefWindowProc window msg wparam lparam))) - *win-result*)) + (clear-winproc-result (win-result *acl-port*))) + (setf (win-result *acl-port*) (win:DefWindowProc window msg wparam lparam))) + (win-result *acl-port*))) ;; Process WM_GETMINMAXINFO (defun ongetminmaxinfo (window msg wparam lparam) @@ -526,9 +489,9 @@ (when (and min-width min-height) (setf (sys:memref-int lparam 0 24 :unsigned-long) min-width (sys:memref-int lparam 0 28 :unsigned-long) min-height) - (clear-winproc-result *win-result*))) - (setq *win-result* (win:DefWindowProc window msg wparam lparam))) - *win-result*)) + (clear-winproc-result (win-result *acl-port*)))) + (setf (win-result *acl-port*) (win:DefWindowProc window msg wparam lparam))) + (win-result *acl-port*))) ;; PROCESS EN_UPDATE (defun onupdatetext (window msg wparam lparam) @@ -543,12 +506,12 @@ ;; sheet ;; (allocate-event 'window-change-event :sheet sheet) )) - (clear-winproc-result *win-result*) - *win-result*)) + (clear-winproc-result (win-result *acl-port*)) + (win-result *acl-port*))) ;; Process WM_KEYDOWN ;;; SPR25900 --pnc -;;; The variable *modstate* is used to specify the alt/meta +;;; The port slot modstate is used to specify the alt/meta ;;; key on mouse-gestures. See the functions onbuttondown ;;; and windows-mask->modifier-state+ (in aclpc/acl-port.lisp). (defun onkeydown (window msg wparam lparam) @@ -567,14 +530,14 @@ (shiftstate (win:GetKeyState win:VK_SHIFT)) (controlstate (win:GetKeyState win:VK_CONTROL)) (metastate (win:GetKeyState win:VK_MENU))) - (setf (modstate-control *modstate*) + (setf (modstate-control (modstate *acl-port*)) (or (minusp controlstate) (not (zerop (ash controlstate -15))))) - (setf (modstate-meta *modstate*) + (setf (modstate-meta (modstate *acl-port*)) ;; whoops! this was controlstate!? (or (minusp metastate) (not (zerop (ash metastate -15))))) - (setf (modstate-numlock *modstate*) + (setf (modstate-numlock (modstate *acl-port*)) (and (plusp numstate) (zerop (ash numstate -15)))) - (setf (modstate-shift *modstate*) + (setf (modstate-shift (modstate *acl-port*)) (or (and (or (minusp shiftstate) (not (zerop (ash shiftstate -15)))) (zerop capstate)) @@ -584,27 +547,27 @@ (if pass (progn (setq pass nil) - (setq *win-result* (win:DefWindowProc window msg wparam lparam)) + (setf (win-result *acl-port*) (win:DefWindowProc window msg wparam lparam)) ;;added this so that port modifier state is always updated, ;; even on passed characters. -- KR (setf (port-modifier-state *acl-port*) - (modstate->modifier *modstate*)) - *win-result*) + (modstate->modifier (modstate *acl-port*))) + (win-result *acl-port*)) (progn (when (and (or (<= #x30 vk #x5a) (<= #xba vk #xc0) (<= #xdb vk #xdf)) - (modstate-shift *modstate*)) + (modstate-shift (modstate *acl-port*))) (setf code (logior #x100 code))) ;; NUM LOCK (when (and (<= #x60 vk #x69) - (not (modstate-numlock *modstate*))) + (not (modstate-numlock (modstate *acl-port*)))) (setf code (logior #x100 code))) (with-slots (event-queue vk->keysym) *acl-port* (let ((keysym (or (gethash (ldb (byte 9 0) code) vk->keysym) (gethash (ldb (byte 8 0) code) vk->keysym))) (char nil) - (modstate (modstate->modifier *modstate*)) + (modstate (modstate->modifier (modstate *acl-port*))) (sheet (mirror->sheet *acl-port* window))) (when (consp keysym) (setf keysym (first keysym))) @@ -641,11 +604,11 @@ ;;added this so that port modifier state is always ;; updated, even on passed characters. -- KR (setf (port-modifier-state *acl-port*) - (modstate->modifier *modstate*)) + (modstate->modifier (modstate *acl-port*))) ))))) ;; set return value to 0 - (clear-winproc-result *win-result*) - *win-result*)))) + (clear-winproc-result (win-result *acl-port*)) + (win-result *acl-port*))))) (defun find-default-gadget (frame) ;; Look for a button that is "show-as-default" @@ -728,8 +691,8 @@ :modifier-state modifier-state :pointer pointer :sheet sheet)))))) - (clear-winproc-result *win-result*) - *win-result*) + (clear-winproc-result (win-result *acl-port*)) + (win-result *acl-port*)) ;; Process WM_LBUTTONDBLCLK (defun onbuttondblclk (window msg wparam lparam) @@ -764,8 +727,8 @@ :modifier-state modifier-state :pointer pointer :sheet sheet)))))) - (clear-winproc-result *win-result*) - *win-result*) + (clear-winproc-result (win-result *acl-port*)) + (win-result *acl-port*)) ;; Process WM_ACTIVATE (defun onactivate (window msg wparam lparam) @@ -780,7 +743,7 @@ (active (loword wparam))) (when (and sheet (not (= active WA_INACTIVE))) (setf (acl-port-mirror-with-focus *acl-port*) window)) - (setq *win-result* (win:DefWindowProc window msg wparam lparam)))) + (setf (win-result *acl-port*) (win:DefWindowProc window msg wparam lparam)))) ;; Process WM_KILLFOCUS (defun onkillfocus (window msg wparam lparam) @@ -798,8 +761,8 @@ (allocate-event 'silica::window-close-event :sheet sheet))))) ;; set return value to 0 - (clear-winproc-result *win-result*) - *win-result*)) + (clear-winproc-result (win-result *acl-port*)) + (win-result *acl-port*))) ;; Process WM_INITMENUPOPUP (defun oninitmenupopup (window msg wparam lparam) @@ -815,23 +778,20 @@ (update-menu-contents sheet menu-handle index) (update-menu-item-sensitivities menu-handle) ;; set return value to 0 - (clear-winproc-result *win-result*) - *win-result*))) + (clear-winproc-result (win-result *acl-port*)) + (win-result *acl-port*)))) ;; Process WM_NCHITTEST (defun onnchittest (window msg wparam lparam) ;; Called on the object that contains the cursor ;; every time the mouse moves. - (setq *win-result* (win:DefWindowProc window msg wparam lparam))) + (setf (win-result *acl-port*) (win:DefWindowProc window msg wparam lparam))) ;; Allow Windows to provide default message processing. (defun message-default (window msg wparam lparam) - (clear-winproc-result *win-result*) - (setq *win-result* (win:DefWindowProc window msg wparam lparam)) - *win-result*) - -(defvar wres (ct:callocate :long)) -(defvar wmsg (ct:ccallocate win:msg)) + (clear-winproc-result (win-result *acl-port*)) + (setf (win-result *acl-port*) (win:DefWindowProc window msg wparam lparam)) + (win-result *acl-port*)) ;; Refer to the windows documentation on Tooltip controls. ;; The message stream needs to be relayed to the tooltip @@ -854,7 +814,7 @@ (top (frame-top-level-sheet frame)) (tt (tooltip-control top)) (ttm_relayevent #.(+ win:WM_USER 7)) - (relay wmsg)) + (relay (wmsg *acl-port*))) (when tt (ct:csets win:msg relay lparam lparam @@ -864,7 +824,7 @@ (or (plusp (win:SendMessage tt ttm_relayevent 0 relay)) (check-last-error "TTM_RELAYEVENT" :Action :warn)))))) #+optional - (callnexthookex *next-windows-hook* msg wparam lparam)) + (callnexthookex (next-windows-hook *acl-port*) msg wparam lparam)) ;;; Windows messages get printed to the value of this, if ;;; *maybe-format* is non-NIL @@ -965,7 +925,7 @@ (message-default window msg wparam lparam)) (otherwise (message-default window msg wparam lparam))) - (setf result *win-result*) + (setf result (win-result *acl-port*)) (mformat *windows-message-trace-output* "~A Out clim-wind-proc msg=~a sheet=~s result=~s~%" *level* @@ -1010,7 +970,6 @@ (ff:defun-foreign-callable clim-ctrl-proc (window msg wparam lparam) (declare (:convention :stdcall) (:unwind 0)) (mp:without-scheduling - (setf *hwnd* window) (let ((result 0) (sheet (mirror->sheet *acl-port* window))) (mformat excl:*initial-terminal-io* @@ -1045,13 +1004,13 @@ (shiftstate (win:GetKeyState win:VK_SHIFT)) (controlstate (win:GetKeyState win:VK_CONTROL)) (metastate (win:GetKeyState win:VK_MENU))) - (setf (modstate-control *ctlmodstate*) + (setf (modstate-control (ctlmodstate *acl-port*)) (or (minusp controlstate) (not (zerop (ash controlstate -15))))) - (setf (modstate-meta *ctlmodstate*) + (setf (modstate-meta (ctlmodstate *acl-port*)) (or (minusp metastate) (not (zerop (ash metastate -15))))) - (setf (modstate-numlock *ctlmodstate*) + (setf (modstate-numlock (ctlmodstate *acl-port*)) (and (plusp numstate) (zerop (ash numstate -15)))) - (setf (modstate-shift *ctlmodstate*) + (setf (modstate-shift (ctlmodstate *acl-port*)) (or (and (or (minusp shiftstate) (not (zerop (ash shiftstate -15)))) (zerop capstate)) @@ -1060,17 +1019,17 @@ (and (plusp capstate) (zerop (ash capstate -15))))))) (when (and (or (<= #x30 vk #x5a)(<= #xba vk #xc0)(<= #xdb vk #xdf)) - (modstate-shift *ctlmodstate*)) + (modstate-shift (ctlmodstate *acl-port*))) (setf code (logior #x100 code))) ;; NUM LOCK (when (and (<= #x60 vk #x69) - (not (modstate-numlock *ctlmodstate*))) + (not (modstate-numlock (ctlmodstate *acl-port*)))) (setf code (logior #x100 code))) (with-slots (event-queue vk->keysym) *acl-port* (let ((keysym (or (gethash (ldb (byte 9 0) code) vk->keysym) (gethash (ldb (byte 8 0) code) vk->keysym))) (char nil) - (modstate (modstate->modifier *ctlmodstate*)) + (modstate (modstate->modifier (ctlmodstate *acl-port*))) ;;(sheet (mirror->sheet *acl-port* window)) ) (when (consp keysym) @@ -1086,17 +1045,18 @@ ;;mm: spr27890 look at :newline or :tab ourselves (case keysym (:newline (eql modstate 0)) - (:tab (or (eql modstate 0) (modstate-shift *ctlmodstate*))))) + (:tab (or (eql modstate 0) (modstate-shift (ctlmodstate + *acl-port*)))))) (setq pass nil)) ;;; Don't pass along the character. (if pass (progn (setq pass nil) (setq - ;;mm *win-result* + ;;mm (win-result *acl-port*) result - (win:CallWindowProc std-ctrl-proc-address + (win:CallWindowProc (std-ctrl-proc-address *acl-port*) window msg wparam lparam)) - *win-result*) + (win-result *acl-port*)) (let ((sheet (mirror->sheet *acl-port* window))) ;; We have decided to handle this character ourselves! @@ -1121,7 +1081,7 @@ :sheet sheet))) sheet) ;; set return value to 0 - ;;(clear-winproc-result *win-result*) + ;;(clear-winproc-result (win-result *acl-port*)) (setq result 0))))))) ;; 17-Mar-03 mm [bug13094] @@ -1133,38 +1093,22 @@ ;; it seems to be coming because of the IsDialogMessage call. ;; We return 0 to pervent special (dialog accelerator) handling ;; for any of the keys that should be translated to WM_CHAR messages. - (clear-winproc-result *win-result*) - (setf *win-result* 0) - *win-result*) + (clear-winproc-result (win-result *acl-port*)) + (setf (win-result *acl-port*) 0) + (win-result *acl-port*)) (t ;; This is where we let the control do its own thing. Most ;; messages come through here. - ;;(clear-winproc-result *win-result*) - (setq ;;*win-result* + ;;(clear-winproc-result (win-result *acl-port*)) + (setq ;;(win-result *acl-port*) result - (win:CallWindowProc std-ctrl-proc-address + (win:CallWindowProc (std-ctrl-proc-address *acl-port*) window msg wparam lparam)) - *win-result*)) - ;;(setf result *win-result*) + (win-result *acl-port*))) + ;;(setf result (win-result *acl-port*)) result))) -(defvar *clim-class* "ClimClass") -(defvar *win-name* "CLIM") -(defvar *menu-name* "ClimMenu") -(defvar *win-x* "x") -(defvar *wndclass-registered* nil) -(defvar clim-window-proc-address nil) -(defvar clim-ctrl-proc-address nil) -(defvar std-ctrl-proc-address nil) -(defvar tooltip-relay-address nil) -(defvar *next-windows-hook* nil) -(defvar *clim-initialized* nil) -(defvar lpcmdline "") -(defvar *hinst* 0) -(defvar *hprevinst* 0) -(defvar *screen-device* nil) - (defun initialize-clim (&optional (mp t)) (declare (ignore mp)) @@ -1186,11 +1130,10 @@ 4 ;; make sure this stays in sync with cl/src/c/dllmain.c :element-type 'signed-nat))) (win:GetWinMainArgs dataobj) - (setq *hinst* (aref dataobj 0) - *hprevinst* (aref dataobj 1) - lpcmdline (aref dataobj 2))) - (setq *screen-device* - (make-instance 'windows-screen-device))) + (setf (hinst *acl-port*) (aref dataobj 0) + ;;(hprevinst *acl-port*) (aref dataobj 1) + (lpcmdline *acl-port*) (aref dataobj 2) + (screen-device *acl-port*) (make-instance 'windows-screen-device)))) (defun make-cstructure (type length) ;; create and return a region of memory of the @@ -1198,23 +1141,37 @@ (declare (ignore type)) (ff:allocate-fobject `(:array :unsigned-char ,length) :foreign-static-gc)) -(defun ensure-clim-initialized () - (unless *clim-initialized* +(defun ensure-clim-initialized (*acl-port*) + (unless (acl-clim-initialized-p *acl-port*) (initialize-cg) - (setf clim-window-proc-address - (init-clim-win-proc clim-window-proc-address (make-cstructure 0 16))) - (setf clim-ctrl-proc-address - (init-clim-ctrl-proc clim-ctrl-proc-address (make-cstructure 0 16))) + (setf (clim-window-proc-address *acl-port*) + (init-clim-win-proc (if (slot-boundp *acl-port* + 'clim-window-proc-address) + (clim-window-proc-address *acl-port*) + nil) + (make-cstructure 0 16))) + (setf (clim-ctrl-proc-address *acl-port*) + (init-clim-ctrl-proc (if (slot-boundp *acl-port* + 'clim-ctrl-proc-address) + (clim-ctrl-proc-address *acl-port*) + nil) + (make-cstructure 0 16))) #+not-yet - (setf tooltip-relay-address - (init-tooltip-relay tooltip-relay-address (make-cstructure 0 16))) - (setq *clim-initialized* t))) + (setf (tooltip-relay-address *acl-port*) + (init-tooltip-relay + (if (slot-boundp *acl-port* + 'tooltip-relay-address) + (tooltip-relay-address *acl-port*) + nil) + (make-cstructure 0 16))) + (setf (clim-initialized-p *acl-port*) t))) (defun acl-clim::register-window-class (hcursor) ;; This is called by initialize-instance of acl-port. ;; It creates a (single) Windows window class for all clim windows. - (unless *wndclass-registered* - (init-clim-win-proc clim-window-proc-address (make-cstructure 0 16)) + (unless (wndclass-registered *acl-port*) + (init-clim-win-proc (clim-window-proc-address *acl-port*) + (make-cstructure 0 16)) (let ((class (ff:allocate-fobject 'win:wndclassex :foreign-static-gc nil)) (icon (win:LoadIcon 0 win:IDI_APPLICATION)) ; (get-clim-icon) @@ -1229,7 +1186,7 @@ win:CS_BYTEALIGNWINDOW)) (setf (ff:fslot-value-typed 'win:wndclassex :foreign class :lpfnWndProc) - clim-window-proc-address) + (clim-window-proc-address *acl-port*)) (setf (ff:fslot-value-typed 'win:wndclassex :foreign class :cbClsExtra) 0) @@ -1238,7 +1195,7 @@ 0) (setf (ff:fslot-value-typed 'win:wndclassex :foreign class :hInstance) - *hinst*) + (hinst *acl-port*)) (setf (ff:fslot-value-typed 'win:wndclassex :foreign class :hIcon) icon) @@ -1253,7 +1210,7 @@ 0) (setf (ff:fslot-value-typed 'win:wndclassex :foreign class :lpszClassName) - (string-to-foreign *clim-class*)) + (string-to-foreign (acl-clim::clim-class *acl-port*))) (setf (ff:fslot-value-typed 'win:wndclassex :foreign class :hIconSm) @@ -1261,13 +1218,13 @@ (setq reg (win:RegisterClassEx class)) (when (zerop reg) (check-last-error "RegisterClassEx")) - (setq *wndclass-registered* t) - (when tooltip-relay-address - (setq *next-windows-hook* + (setf (wndclass-registered *acl-port*) t) + (when (tooltip-relay-address *acl-port*) + (setf (next-windows-hook *acl-port*) (SetWindowsHookEx win:WH_GETMESSAGE - tooltip-relay-address + (tooltip-relay-address *acl-port*) 0 0)) - (when (zerop *next-windows-hook*) + (when (zerop (next-windows-hook *acl-port*)) (check-last-error "SetWindowsHookEx"))) t))) @@ -1300,12 +1257,12 @@ win:WS_EX_WINDOWEDGE win:WS_EX_CONTROLPARENT ; TAB BTWN CONTROLS )) - (*win-name* *win-name*) + (win-name (acl-clim::win-name *acl-port*)) (menu (if menubar (win:CreateMenu) 0)) (window nil)) (when pretty - (setq *win-name* pretty)) + (setq win-name pretty)) (cond (modal ;; Accepting-values comes in here. We need ;; thickframe, even though that is not normally @@ -1329,17 +1286,17 @@ win:WS_MINIMIZEBOX win:WS_MAXIMIZEBOX)))) (setq window - (excl:with-native-string (*clim-class* *clim-class*) - (excl:with-native-string (*win-name* *win-name*) + (excl:with-native-string (clim-class (acl-clim::clim-class *acl-port*)) + (excl:with-native-string (win-name win-name) (win:CreateWindowEx exstyle - *clim-class* - *win-name* + clim-class + win-name winstyle left top width height (or parent 0) menu - *hinst* - *win-x* )))) + (hinst *acl-port*) + (win-x *acl-port*) )))) (when (zerop window) (or (check-last-error "CreateWindowEx") (error "CreateWindowEx: unknown error"))) @@ -1361,22 +1318,22 @@ win:WS_HSCROLL 0) win:WS_CLIPCHILDREN )) - (*win-name* *win-name*)) + (win-name (acl-clim::win-name *acl-port*))) (when pretty - (setq *win-name* pretty)) + (setq win-name pretty)) (let ((window - (excl:with-native-string (*clim-class* *clim-class*) - (excl:with-native-string (*win-name* *win-name*) + (excl:with-native-string (clim-class (acl-clim::clim-class *acl-port*)) + (excl:with-native-string (win-name win-name) (win:CreateWindowEx (if ovl 0 win:WS_EX_TOOLWINDOW) - *clim-class* - *win-name* + clim-class + win-name winstyle left top width height parent 0 - *hinst* - *win-x*))))) + (hinst *acl-port*) + (win-x *acl-port*)))))) (when (zerop window) (check-last-error "CreateWindowEx")) window))) @@ -1403,42 +1360,40 @@ ;; You can ask for a menu bar on a child window, ;; but Windows will not give you one. (menu 0) - (*win-name* *win-name*) + (win-name (acl-clim::win-name *acl-port*)) (window nil)) (when pretty - (setq *win-name* pretty)) + (setq win-name pretty)) (setq window - (excl:with-native-string (*clim-class* *clim-class*) - (excl:with-native-string (*win-name* *win-name*) + (excl:with-native-string (clim-class (acl-clim::clim-class *acl-port*)) + (excl:with-native-string (win-name win-name) (win:CreateWindowEx exstyle - *clim-class* - *win-name* + clim-class + win-name winstyle left top width height parent menu - *hinst* - *win-x*)))) + (hinst *acl-port*) + (win-x *acl-port*))))) (when (zerop window) (check-last-error "CreateWindowEx")) (if (or (eql scroll :both)(eql scroll :vertical)) - (win:SetScrollRange window win:SB_VERT 0 *win-scroll-grain* 1)) + (win:SetScrollRange window win:SB_VERT 0 (win-scroll-grain *acl-port*) 1)) (if (or (eql scroll :both)(eql scroll :horizontal)) - (win:SetScrollRange window win:SB_HORZ 0 *win-scroll-grain* 1)) + (win:SetScrollRange window win:SB_HORZ 0 (win-scroll-grain *acl-port*) 1)) window)) ;; wres and wmsg move up in file to remove compile-time warning (defun wait-for-event () (when (prog1 - (win:PeekMessage wmsg 0 0 0 + (win:PeekMessage (wmsg *acl-port*) 0 0 0 (logior win:PM_NOYIELD win:PM_NOREMOVE)) - (not (and (zerop (hiword wres)) (zerop (loword wres))))) + (not (and (zerop (hiword (wres *acl-port*))) + (zerop (loword (wres *acl-port*)))))) t)) -(defvar msg (ct:ccallocate win:msg)) -(defvar res (ct:callocate :long)) - ;; This is the prototypical way to get and process ;; a windows message from the windows message queue. ;; Note that TAB will not select the next control in @@ -1450,13 +1405,13 @@ (loop (let ((gotmessage (if nonblocking - (win:PeekMessage msg 0 0 0 win:PM_REMOVE) - (win:GetMessage msg 0 0 0)))) + (win:PeekMessage (msg *acl-port*) 0 0 0 win:PM_REMOVE) + (win:GetMessage (msg *acl-port*) 0 0 0)))) (cond ((not gotmessage) (return t)) - ((and hwnd (win:IsDialogMessage hwnd msg))) + ((and hwnd (win:IsDialogMessage hwnd (msg *acl-port*)))) (t - (win:TranslateMessage msg) - (win:DispatchMessage msg))) + (win:TranslateMessage (msg *acl-port*)) + (win:DispatchMessage (msg *acl-port*)))) (when nonblocking (return t)) ))) @@ -1519,11 +1474,7 @@ (setf sys::*default-message-interrupt-function* #'clim-message-interrupt-function) -(defvar *current-window*) -(defvar *dc-initialized* nil) - ;;; Stock objects -(defvar *null-pen*) (defvar *black-pen*) (defvar *ltgray-pen*) (defvar *null-brush*) @@ -1548,68 +1499,16 @@ (clim:destroy-port acl-clim::*acl-port*)) - (setq *acl-port* nil) - (setq *menu-id->command-table* - (make-array 256 - :element-type t :adjustable t - :fill-pointer 0 :initial-element nil)) - (setq *popup-menu->menu-item-ids* (make-hash-table)) - (setq *popup-menu->command-table* (make-hash-table)) - (setq *maybe-format* nil) - (setq *msg-names* nil) - (setq *modstate* (make-modstate)) - (setq *ctlmodstate* (make-modstate)) - (setq *win-result* 0) + (setq *acl-port* nil + *maybe-format* nil + *level* 0 + *windows-message-trace-output* excl:*initial-terminal-io*) + ;;; (setq *hwnd* 0) ;;; (setq *clim-wproc-arg-struct* nil) ;;; (setq *clim-ctrl-arg-struct* nil) ;;; (setq *tooltip-relay-struct* nil) - (setq *level* 0) - (setq *realtime-scrollbar-tracking* t) - (setq *win-scroll-grain* 1000) - (setq wres (ct:callocate :long)) - (setq wmsg (ct:ccallocate win:msg)) - (setq *windows-message-trace-output* excl:*initial-terminal-io*) - (setq *clim-class* "ClimClass") - (setq *win-name* "CLIM") - (setq *menu-name* "ClimMenu") - (setq *win-x* "x") - (setq *wndclass-registered* nil) - (setq clim-window-proc-address nil) - (setq clim-ctrl-proc-address nil) - (setq std-ctrl-proc-address nil) - (setq tooltip-relay-address nil) - (setq *next-windows-hook* nil) - (setq *clim-initialized* nil) - (setq lpcmdline "") - (setq *hinst* 0) - (setq *hprevinst* 0) - (setq *screen-device* nil) - (setq msg (ct:ccallocate win:msg)) - (setq res (ct:callocate :long)) - - - (setq arrow-cursor - (ff:allocate-fobject 'win:hcursor :foreign-static-gc nil)) - (setq application-icon - (ff:allocate-fobject 'win:hicon :foreign-static-gc nil)) - - - (setq *current-window* nil) - (setq *dc-initialized* nil) - - - (setq *null-pen* nil) - (setq *black-pen* nil) - (setq *ltgray-pen* nil) - (setq *null-brush* nil) - (setq *black-brush* nil) - (setq *ltgray-brush* nil) - (setq *blank-image* nil) - (setq *ltgray-image* nil) - - - (setq *background-brush* nil) + ) (push #'reset-aclpc-clim excl::*restart-actions*) diff --git a/aclpc/acl-dc.lisp b/aclpc/acl-dc.lisp index ce041cb0fa9bbfc7c8bc7cd45db82ec3257854be..be6113f53fc7b0a3a852fc5dbcc2d6c51907efb9 100644 --- a/aclpc/acl-dc.lisp +++ b/aclpc/acl-dc.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: acl-dc.lisp,v 2.7 2007/04/17 21:45:48 layer Exp $ +;; $Id: acl-dc.lisp,v 2.8 2007/04/25 20:29:26 layer Exp $ #|**************************************************************************** * * @@ -83,59 +83,59 @@ dc)) (defun initialize-dc () - (unless *dc-initialized* - (unless (win:IsWindow *current-window*) - (error "No Window: ~S" *current-window*)) + (unless (dc-initialized *acl-port*) + (unless (win:IsWindow (current-window *acl-port*)) + (error "No Window: ~S" (current-window *acl-port*))) ;; Stock objects - (setf *null-pen* (win:GetStockObject win:NULL_PEN)) - (setf *black-pen* (win:GetStockObject win:BLACK_PEN)) - (setf *ltgray-pen* + (setf (null-pen *acl-port*)(win:GetStockObject win:NULL_PEN)) + (setf (black-pen *acl-port*)(win:GetStockObject win:BLACK_PEN)) + (setf (ltgray-pen *acl-port*) (CreatePen win:PS_SOLID 1 (win:GetSysColor win:COLOR_BTNFACE))) ;; - (setf *null-brush* (win:GetStockObject win:NULL_BRUSH)) - (setf *black-brush* (win:GetStockObject win:BLACK_BRUSH)) - (setf *ltgray-brush* + (setf (null-brush *acl-port*)(win:GetStockObject win:NULL_BRUSH)) + (setf (black-brush *acl-port*)(win:GetStockObject win:BLACK_BRUSH)) + (setf (ltgray-brush *acl-port*) (win:CreateSolidBrush (win:GetSysColor win:COLOR_BTNFACE))) - (setf *blank-image* - #+possibly - (make-dc-image :solid-1-pen *black-pen* - :brush *black-brush* + (setf (blank-image *acl-port*) + #+possibly + (make-dc-image :solid-1-pen (black-pen *acl-port*) + :brush (black-brush *acl-port*) :text-color #xffffffff ; see CLR_NONE :background-color nil :rop2 win:R2_MERGEPEN ) - (make-dc-image :solid-1-pen *black-pen* - :brush *black-brush* + (make-dc-image :solid-1-pen (black-pen *acl-port*) + :brush (black-brush *acl-port*) :text-color #x000000 :background-color nil :rop2 win:R2_NOP )) ;; - (setf *ltgray-image* - (make-dc-image :solid-1-pen *ltgray-pen* - :brush *ltgray-brush* - :text-color (win:GetSysColor win:COLOR_BTNFACE) - :background-color nil - :rop2 win:R2_COPYPEN)) + (setf (ltgray-image *acl-port*) + (make-dc-image :solid-1-pen (ltgray-pen *acl-port*) + :brush (ltgray-brush *acl-port*) + :text-color (win:GetSysColor win:COLOR_BTNFACE) + :background-color nil + :rop2 win:R2_COPYPEN)) ;; - (setq *dc-initialized* t) + (setf (dc-initialized *acl-port*) t) )) (defun destroy-dc () - (when *dc-initialized* - (setq *null-pen* nil) - (setq *null-brush* nil) + (when (dc-initialized *acl-port*) + (setf (null-pen *acl-port*) nil + (null-brush *acl-port*) nil) - (destroy-dc-image *blank-image*) - (setq *black-pen* nil) - (setq *black-brush* nil) - (setq *blank-image* nil) + (destroy-dc-image (blank-image *acl-port*)) + (setf (black-pen *acl-port*) nil + (black-brush *acl-port*) nil + (blank-image *acl-port*) nil) - (destroy-dc-image *ltgray-image*) - (setq *ltgray-pen* nil) - (setq *ltgray-image* nil) - (setq *ltgray-brush* nil) + (destroy-dc-image (ltgray-image *acl-port*)) + (setf (ltgray-pen *acl-port*) nil + (ltgray-image *acl-port*) nil + (ltgray-brush *acl-port*) nil) - (setq *dc-initialized* nil))) + (setf (dc-initialized *acl-port*) nil))) ;;; @@ -221,7 +221,7 @@ (let* ((dashes (line-style-dashes line-style)) (thickness (max 1 (round (line-style-thickness line-style)))) (code (if dashes (- thickness) thickness)) - (brush *null-brush*) + (brush (null-brush *acl-port*)) (pen (when (= code 1) (dc-image-solid-1-pen image))) (rop2 (dc-image-rop2 image)) (text-color (dc-image-text-color image)) @@ -253,7 +253,7 @@ (let ((background-color (dc-image-background-color image)) (text-color (dc-image-text-color image)) (brush (dc-image-brush image)) - (pen *null-pen*) + (pen (null-pen *acl-port*)) (rop2 (dc-image-rop2 image))) (when (valid-handle pen) (SelectObject dc pen)) (when background-color @@ -293,7 +293,8 @@ ,xorg ,yorg)) ,@body) (when (valid-handle ..winpen..) - (when (valid-handle *black-pen*) (SelectObject ,dc *black-pen*)) + (when (valid-handle (black-pen *acl-port*)) + (SelectObject ,dc (black-pen *acl-port*))) (or (win:DeleteObject ..winpen..) (error "with-set-dc-for-ink: DeleteObject")))))) diff --git a/aclpc/acl-frames.lisp b/aclpc/acl-frames.lisp index ed1dd0eef79ef68c330ae086179d52a48703c28b..be2f8b6cc37b3034a3f1bdf99b6ac5278ead754f 100644 --- a/aclpc/acl-frames.lisp +++ b/aclpc/acl-frames.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: acl-frames.lisp,v 2.11 2007/04/17 21:45:48 layer Exp $ +;; $Id: acl-frames.lisp,v 2.12 2007/04/25 20:29:26 layer Exp $ #|**************************************************************************** * * @@ -149,7 +149,7 @@ (defmethod frame-manager-default-exit-boxes ((framem acl-frame-manager)) '((:exit) (:abort))) -;; Note: items appear never to be removed from *menu-id->command-table* +;; Note: items appear never to be removed from menu-id->command-table ;; so this will grow indefinitely (cim 9/9/96). There really should be ;; a global id counter and the association list should be kept on a ;; per application-frame basis. @@ -159,8 +159,8 @@ ;; It is allowed for the UNIX port, apparently. (when (atom command) (setq command (list command))) (prog1 - (fill-pointer *menu-id->command-table*) - (vector-push-extend (cons frame command) *menu-id->command-table* + (fill-pointer (menu-id->command-table *acl-port*)) + (vector-push-extend (cons frame command) (menu-id->command-table *acl-port*) 256))) (defun find-command-menu-item-id (command frame) @@ -171,11 +171,11 @@ (c (second x))) (and (eq f frame) (eq c command))))) - *menu-id->command-table*)) + (menu-id->command-table *acl-port*))) (defun map-command-menu-ids (frame func &rest args) - (dotimes (id (fill-pointer *menu-id->command-table*)) - (let ((x (aref *menu-id->command-table* id))) + (dotimes (id (fill-pointer (menu-id->command-table *acl-port*))) + (let ((x (aref (menu-id->command-table *acl-port*) id))) (when x (let ((f (first x))) (if (eq f frame) (apply func id args))))))) @@ -212,7 +212,8 @@ (map-command-menu-ids frame #'(lambda (menuid) - (let ((command-name (second (aref *menu-id->command-table* menuid)))) + (let ((command-name (second (aref (menu-id->command-table *acl-port*) + menuid)))) (with-slots (clim-internals::disabled-commands) frame (push command-name clim-internals::disabled-commands))))) ) @@ -420,7 +421,7 @@ (setq top-level-sheet (frame-top-level-sheet frame))) ;; First, delete any pre-existing menu items. (delete-menu-bar frame menuhand t) - (setf (gethash menuhand *popup-menu->menu-item-ids*) nil) + (setf (gethash menuhand (popup-menu->menu-item-ids *acl-port*)) nil) (setf (gethash menuhand *popup-menu->command-table*) (list command-table (slot-value (find-command-table command-table) @@ -461,7 +462,7 @@ flags menu-item-id m)) - (push menu-item-id (gethash menuhand *popup-menu->menu-item-ids*)))) + (push menu-item-id (gethash menuhand (popup-menu->menu-item-ids *acl-port*))))) (:function (warn ":function not yet implemented in menu bars") ) @@ -516,8 +517,8 @@ ;; Called just before making a menu active. If the menu is associated ;; with a command table, make sure to enable or gray the menu ;; items appropriately. - (dolist (menu-item-id (gethash hmenu *popup-menu->menu-item-ids*)) - (let* ((item (aref *menu-id->command-table* menu-item-id)) + (dolist (menu-item-id (gethash hmenu (popup-menu->menu-item-ids *acl-port*))) + (let* ((item (aref (menu-id->command-table *acl-port*) menu-item-id)) (frame (first item)) (command (second item)) (top (frame-top-level-sheet frame)) @@ -576,7 +577,7 @@ win:CW_USEDEFAULT win:CW_USEDEFAULT win:CW_USEDEFAULT win:CW_USEDEFAULT 0 0 - *hinst* 0)) + (hinst *acl-port*) 0)) (setf (tooltip-control sheet) tooltip-control) (when (zerop tooltip-control) (check-last-error "CreateWindow" :action :warn) @@ -594,7 +595,7 @@ hwnd (sheet-mirror sheet) uid (sheet-mirror s) ;;rect 0 - hinst *hinst* + hinst (hinst *acl-port*) lpsztext -1 #+ign (lisp-string-to-scratch-c-string @@ -2271,7 +2272,8 @@ in a second Lisp process. This frame cannot be reused." edit-box dont-go-below-domains include-files) ;; Ensure that the callback procedure is registered. - (unless (and *clim-initialized* *clim-browse-callback-proc-address*) + (unless (and (clim-initialized-p *acl-port*) + *clim-browse-callback-proc-address*) (setf *clim-browse-callback-proc-address* (ff:register-foreign-callable 'browse-callback-proc :reuse :return-value))) diff --git a/aclpc/acl-medium.lisp b/aclpc/acl-medium.lisp index 845a1103e05f048d505f08ffc0cb2c11bf1ef17e..d0c42496130f56948e239c7511afc3825226fa20 100644 --- a/aclpc/acl-medium.lisp +++ b/aclpc/acl-medium.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: acl-medium.lisp,v 2.9 2007/04/17 21:45:48 layer Exp $ +;; $Id: acl-medium.lisp,v 2.10 2007/04/25 20:29:26 layer Exp $ #|**************************************************************************** * * @@ -166,7 +166,7 @@ ;; used by Windows for all the other gadgets, such as ;; buttons and scroll bars. MFC calls this "light ;; gray in the current color scheme" - *ltgray-image*) + (ltgray-image *acl-port*)) (defmethod color-rgb ((color (eql +ltgray+))) (color-rgb (wincolor->color (win:GetSysColor win:COLOR_BTNFACE)))) @@ -1816,7 +1816,7 @@ device-independent bitmap, an icon, nor a cursor.")) (defun icon-height () (win:GetSystemMetrics win:SM_CYICON)) (defun create-icon (pixmap texture-info mask-bitmap) ;; <7> - (win:CreateIcon *hinst* + (win:CreateIcon (hinst *acl-port*) (icon-width) (icon-height) 1 ;; planes (texture-info-bits-per-pixel texture-info) diff --git a/aclpc/acl-mirror.lisp b/aclpc/acl-mirror.lisp index b3c8834144a7e01ccab52bdb034a596d0e37180d..2d5f25802079fa7329ad912e41f6a60ee9e73a64 100644 --- a/aclpc/acl-mirror.lisp +++ b/aclpc/acl-mirror.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: acl-mirror.lisp,v 2.7 2007/04/17 21:45:48 layer Exp $ +;; $Id: acl-mirror.lisp,v 2.8 2007/04/25 20:29:26 layer Exp $ #|**************************************************************************** * * @@ -37,7 +37,7 @@ (defmethod sheet-shell (sheet) sheet) (defmethod realize-graft ((port acl-port) graft) - (let ((screen (slot-value *screen-device* 'device-handle1))) + (let ((screen (slot-value (screen-device *acl-port*) 'device-handle1))) (setf (port-screen port) screen) (init-cursors) (with-slots (silica::pixels-per-point @@ -206,8 +206,8 @@ (setf (sheet-event-queue sheet) (make-acl-event-queue))) (when control (setf (silica::gadget-id->window sheet gadget-id) window)) (unless (or control msscrollwin) - (setq *current-window* window) - (unless *dc-initialized* (initialize-dc)) + (setf (current-window port) window) + (unless (dc-initialized port) (initialize-dc)) (with-dc (window dc) (with-slots (logpixelsy) port (setf logpixelsy (win:GetDeviceCaps dc win:LOGPIXELSY))))) diff --git a/aclpc/acl-port.lisp b/aclpc/acl-port.lisp index a3acbfaafedbe420d9ac9da84eadb9c26f8fc912..33ca8bb89c798b5a5382db8f3cd487401c461d36 100644 --- a/aclpc/acl-port.lisp +++ b/aclpc/acl-port.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: acl-port.lisp,v 2.11 2007/04/17 21:45:48 layer Exp $ +;; $Id: acl-port.lisp,v 2.12 2007/04/25 20:29:26 layer Exp $ #|**************************************************************************** * * @@ -143,7 +143,15 @@ (defclass acl-event-queue (queue) ()) - + +(defun msg-names-initform () + (let ((msg-names (make-array 4096))) + (dolist (x (remove-duplicates + (apropos-list "WM_" (find-package :win)))) + (when (<= 0 (symbol-value x) 4095) + (push x (svref msg-names (symbol-value x))))) + msg-names)) + (define-constructor make-acl-event-queue queue () ) (defclass acl-port (basic-port) @@ -177,7 +185,102 @@ :accessor port-rotated-font-htable) ;; Pixmaps (pixmaps :initform nil :accessor port-pixmaps) - )) + + ;; automatically transformed from special vars. + + ;; this will grow indefinitely as menu-ids are never removed (cim 9/10/96) + (menu-id->command-table :initform (make-array 256 + :element-type t + :adjustable t + :fill-pointer 0 + :initial-element nil) + :accessor menu-id->command-table) + + ;; this will grow indefinitely as items are never removed (cim 9/10/96) + (popup-menu->menu-item-ids :initform (make-hash-table) + :accessor popup-menu->menu-item-ids) + (popup-menu->command-table :initform (make-hash-table) + :accessor popup-menu->command-table) + (msg-names :initform (msg-names-initform) + :accessor msg-names) + (modstate :initform (make-modstate) + :accessor modstate) + (ctlmodstate :initform (make-modstate) + :accessor ctlmodstate) + (win-result :initform 0 + :accessor win-result) + + ;; Must be a 16-bit quantity. + ;; According to Microsoft, WM_HSCROLL and WM_VSCROLL messages + ;; are "limited to 16 bits of position data". + ;; (alemmens, 2004-12-17) + (win-scroll-grain :initform (1- (expt 2 16)) + :accessor win-scroll-grain) + + (wres :initform (ct:callocate :long) + :accessor wres) + (wmsg :initform (ct:ccallocate win:msg) + :accessor wmsg) + (clim-class :initform "ClimClass" + :accessor clim-class) + (win-name :initform "CLIM" + :accessor win-name) + (win-x :initform "x" + :accessor win-x) + (wndclass-registered :initform nil + :accessor wndclass-registered) + (clim-window-proc-address :initform nil + :accessor clim-window-proc-address) + (clim-ctrl-proc-address :initform nil + :accessor clim-ctrl-proc-address) + (std-ctrl-proc-address :initform nil + :accessor std-ctrl-proc-address) + (tooltip-relay-address :initform nil + :accessor tooltip-relay-address) + (next-windows-hook :initform nil + :accessor next-windows-hook) + (clim-initialized-p :initform nil + :accessor clim-initialized-p) + (lpcmdline :initform "" + :accessor lpcmdline) + (hinst :initform 0 + :accessor hinst) + (screen-device :initform nil + :accessor screen-device) + (msg :initform (ct:ccallocate win:msg) + :accessor msg) + (arrow-cursor :initform + (ff:allocate-fobject 'win:hcursor :foreign-static-gc nil) + :accessor arrow-cursor) + (application-icon :initform + (ff:allocate-fobject 'win:hicon :foreign-static-gc nil) + :accessor application-icon) + (current-window :initform nil + :accessor current-window) + (dc-initialized :initform nil + :accessor dc-initialized) + (null-pen :initform nil + :accessor null-pen) + (black-pen :initform nil + :accessor black-pen) + (ltgray-pen :initform nil + :accessor ltgray-pen) + (null-brush :initform nil + :accessor null-brush) + (black-brush :initform nil + :accessor black-brush) + (ltgray-brush :initform nil + :accessor ltgray-brush) + (blank-image :initform nil + :accessor blank-image) + (ltgray-image :initform nil + :accessor ltgray-image) + (background-brush :initform nil + :accessor background-brush))) + +(defun acl-clim-initialized-p (port) + (and (slot-boundp port 'clim-initialized-p) + (clim-initialized-p port))) (defmethod restart-port ((port acl-port)) ;; No need to devote a thread to receiving messages @@ -254,7 +357,7 @@ (setf (medium-text-style medium) style))) (defmethod initialize-instance :before ((port acl-port) &key) - (ensure-clim-initialized) + (ensure-clim-initialized port) (unless (null *acl-port*) (cerror "do it anyway" "There can only be one acl port.")) (setf *acl-port* port)) @@ -268,15 +371,13 @@ (setf silica::deep-mirroring t) (register-window-class (realize-cursor port :default)) ;;(get-clim-icon) +++ - (let ((res (ct:callocate :long))) - (loop for (vk . keysym) in *vk->keysym* do + (loop for (vk . keysym) in *vk->keysym* do (setf (gethash vk vk->keysym) keysym)) - (loop for code from (char-code #\!) to (char-code #\~) + (loop for code from (char-code #\!) to (char-code #\~) for char = (code-char code) do - (let ((scan (loword (win:VkKeyScan code)))) - (push char (gethash scan vk->keysym)))) - ) + (let ((scan (loword (win:VkKeyScan code)))) + (push char (gethash scan vk->keysym)))) ;; Panes that have a direct mirror will get initialized from ;; get-sheet-resources: (setf (port-default-resources port) @@ -639,7 +740,7 @@ or (:style . (family face size))") (frame-top-level-sheet *application-frame*) (sheet-mirror (frame-top-level-sheet *application-frame*)))) (tmstruct (ct:ccallocate win:textmetric))) - (unless cw (setf cw *current-window*)) + (unless cw (setf cw (current-window *acl-port*))) (unless (win:IsWindow cw) ;; This clause is for the rare case that you are doing drawing ;; from a background process the first time you attempt to use @@ -932,8 +1033,8 @@ or (:style . (family face size))") ;;; the variable *modstate*, set in onkeydown (in aclpc/acl-class.lisp) (defun windows-mask->modifier-state+ (mask &optional double) (let ((state (windows-mask->modifier-state mask double))) - (when (and *modstate* - (modstate-meta *modstate*)) + (when (and (modstate *acl-port*) + (modstate-meta (modstate *acl-port*))) (setq state (logior state (make-modifier-state :meta)))) state)) diff --git a/aclpc/acl-prel.lisp b/aclpc/acl-prel.lisp index f0c75aa30e91e85fdc01510c43b1abbf3319b398..8f9c30db55e080321a402df06d7a407c09801263 100644 --- a/aclpc/acl-prel.lisp +++ b/aclpc/acl-prel.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: acl-prel.lisp,v 2.11 2007/04/17 21:45:48 layer Exp $ +;; $Id: acl-prel.lisp,v 2.12 2007/04/25 20:29:26 layer Exp $ #|**************************************************************************** * * @@ -29,11 +29,12 @@ (in-package :acl-clim) + +(declaim (special *acl-port*)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Open a combo box control. -(declaim (special *hinst*)) - (defun combobox-scroll-bars (items) ;; If there are many items, you won't be able ;; to see them without a scroll bar. @@ -65,7 +66,7 @@ win:CBS_DROPDOWNLIST) 0 0 0 0 parent 0 - *hinst* (symbol-name (gensym))))))) + (hinst *acl-port*) (symbol-name (gensym))))))) (if (zerop hwnd) ;; failed (cerror "proceed" "failed") @@ -134,7 +135,7 @@ 0 0 0 0 parent 0 - *hinst* + (hinst *acl-port*) (symbol-name (gensym))))))) (if (zerop hwnd) ;; failed @@ -204,7 +205,7 @@ 0 0 0 0 ; x, y, width, height parent 0 - *hinst* + (hinst *acl-port*) (symbol-name (gensym))))))) (if (zerop hwnd) ;; failed @@ -258,7 +259,7 @@ 0 0 0 0 parent 0 - *hinst* + (hinst *acl-port*) (symbol-name (gensym))))))) (if (zerop hwnd) ;; failed @@ -274,8 +275,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Open an edit control -(declaim (special std-ctrl-proc-address clim-ctrl-proc-address)) - (defun hedit-open (parent id left top width height &key (editstyle 0) (value nil) @@ -305,7 +304,7 @@ 0 0 0 0 parent 0 - *hinst* + (hinst *acl-port*) (symbol-name (gensym))))))) (cond ((zerop hwnd) (cerror "Continue anyway." "Can't create text-edit gadget.") @@ -318,11 +317,11 @@ ;; spr 30683 (alemmens, 2005-11-30) (win:SetWindowText hwnd s1))) ;; Override the default window proc. - (setf std-ctrl-proc-address + (setf (std-ctrl-proc-address *acl-port*) (win:GetWindowLong hwnd win:GWL_WNDPROC)) (win:SetWindowLong hwnd win:GWL_WNDPROC - clim-ctrl-proc-address) + (clim-ctrl-proc-address *acl-port*)) (win:SetWindowPos hwnd 0 left top width height #.(logior win:SWP_NOACTIVATE win:SWP_NOZORDER)) diff --git a/aclpc/acl-scroll.lisp b/aclpc/acl-scroll.lisp index 971c93d8e1af02050cafc646348e086ea631ecde..a76f0bebf6feb34ea08268adaf077ac1cc163a28 100644 --- a/aclpc/acl-scroll.lisp +++ b/aclpc/acl-scroll.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: acl-scroll.lisp,v 2.8 2007/04/17 21:45:48 layer Exp $ +;; $Id: acl-scroll.lisp,v 2.9 2007/04/25 20:29:26 layer Exp $ #|**************************************************************************** * * @@ -259,13 +259,13 @@ (struct (ct:ccallocate win:scrollinfo)) (bar (if (eq orientation :vertical) win:SB_VERT win:SB_HORZ)) - (page (floor (* size acl-clim::*win-scroll-grain*))) - (position (floor (* pos acl-clim::*win-scroll-grain*)))) + (page (floor (* size (acl-clim::win-scroll-grain acl-clim::*acl-port*)))) + (position (floor (* pos (acl-clim::win-scroll-grain acl-clim::*acl-port*))))) (ct:csets win:scrollinfo struct cbSize (ct:sizeof win:scrollinfo) fMask win:SIF_ALL nMin 0 - nMax acl-clim::*win-scroll-grain* + nMax (acl-clim::win-scroll-grain acl-clim::*acl-port*) nPage page nPos position) (win:SetScrollInfo mirror bar struct 1)) @@ -311,7 +311,7 @@ (:vertical win:SB_VERT) (:horizontal win:SB_HORZ))) (current-value (/ (win:GetScrollPos window flag) - (float acl-clim::*win-scroll-grain*))) + (float (acl-clim::win-scroll-grain acl-clim::*acl-port*)))) (current-size (case orientation (:horizontal current-horizontal-size) (:vertical current-vertical-size))) @@ -338,7 +338,7 @@ (:horizontal win:SB_HORZ))) (window (sheet-mirror scroller-pane)) (current-value (/ (win:GetScrollPos window flag) - (float acl-clim::*win-scroll-grain*))) + (float (acl-clim::win-scroll-grain acl-clim::*acl-port*)))) (current-size (case orientation (:horizontal current-horizontal-size) (:vertical current-vertical-size))) @@ -349,8 +349,8 @@ (/ (line-scroll-amount scroller-pane orientation :down) (float contents-range 0.0s0))))) - (new-value (min (- (/ (1+ acl-clim::*win-scroll-grain*) ;; max size - acl-clim::*win-scroll-grain*) ;; max pos + (new-value (min (- (/ (1+ (acl-clim::win-scroll-grain acl-clim::*acl-port*)) ;; max size + (acl-clim::win-scroll-grain acl-clim::*acl-port*)) ;; max pos current-size) (+ current-value line-value)))) (scroll-bar-value-changed-callback @@ -366,7 +366,7 @@ (:horizontal win:SB_HORZ))) (window (sheet-mirror scroller-pane)) (current-value (/ (win:GetScrollPos window flag) - (float acl-clim::*win-scroll-grain*))) + (float (acl-clim::win-scroll-grain acl-clim::*acl-port*)))) (current-size (case orientation (:horizontal current-horizontal-size) (:vertical current-vertical-size))) @@ -391,7 +391,7 @@ (:horizontal win:SB_HORZ))) (window (sheet-mirror scroller-pane)) (current-value (/ (win:GetScrollPos window flag) - (float acl-clim::*win-scroll-grain*))) + (float (acl-clim::win-scroll-grain acl-clim::*acl-port*)))) (current-size (case orientation (:horizontal current-horizontal-size) (:vertical current-vertical-size))) @@ -402,8 +402,8 @@ (setq new-value current-value) (let ((page-value (the single-float (/ viewport-range (float contents-range 0.0s0))))) - (setq new-value (min (- (/ (1+ acl-clim::*win-scroll-grain*) - acl-clim::*win-scroll-grain*) + (setq new-value (min (- (/ (1+ (acl-clim::win-scroll-grain acl-clim::*acl-port*)) + (acl-clim::win-scroll-grain acl-clim::*acl-port*)) current-size) (+ current-value page-value))))) (scroll-bar-value-changed-callback @@ -417,7 +417,7 @@ (let* ((current-size (case orientation (:horizontal current-horizontal-size) (:vertical current-vertical-size))) - (new-value (/ pos (float acl-clim::*win-scroll-grain*)))) + (new-value (/ pos (float (acl-clim::win-scroll-grain acl-clim::*acl-port*))))) (scroll-bar-value-changed-callback scroller-pane scroller-pane orientation new-value current-size)))) diff --git a/aclpc/acl-widget.lisp b/aclpc/acl-widget.lisp index 1b474cffac6500de913e66559faefe8ad8b85682..3748177961c06f1e11b7b09b6c4c891aa1e30476 100644 --- a/aclpc/acl-widget.lisp +++ b/aclpc/acl-widget.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: acl-widget.lisp,v 2.13 2007/04/17 21:45:48 layer Exp $ +;; $Id: acl-widget.lisp,v 2.14 2007/04/25 20:29:26 layer Exp $ #|**************************************************************************** * * @@ -1610,7 +1610,7 @@ (defmethod native-gadget-range* ((scroll-bar mswin-scroll-bar)) - (values 0 acl-clim::*win-scroll-grain*)) + (values 0 (acl-clim::win-scroll-grain acl-clim::*acl-port*))) (defmethod realize-mirror ((port acl-clim::acl-port) (sheet mswin-scroll-bar)) @@ -1687,7 +1687,7 @@ cbSize (ct:sizeof win:scrollinfo) fMask win:SIF_ALL nMin 0 - nMax acl-clim::*win-scroll-grain* + nMax (acl-clim::win-scroll-grain acl-clim::*acl-port*) nPage page nPos position) (win:SetScrollInfo mirror win:SB_CTL struct 1))))) @@ -2026,16 +2026,16 @@ (exstyle win:WS_EX_CLIENTEDGE) (window nil)) (setq window - (excl:with-native-string (*clim-class* *clim-class*) - (excl:with-native-string (*win-name* *win-name*) + (excl:with-native-string (clim-class (clim-class *acl-port*)) + (excl:with-native-string (win-name (win-name *acl-port*)) (win:CreateWindowEx exstyle - *clim-class* - *win-name* + clim-class + win-name winstyle left top width height (or parent 0) 0 ; menu - *hinst* + (hinst *acl-port*) (symbol-name (gensym)) )))) (when (zerop window) (or (check-last-error "CreateWindowEx") diff --git a/sys/odrawpat.lisp b/sys/odrawpat.lisp index da738aeb1e63ea00dbe421d1252553421f86a7c4..69e8d9839fd1c45136245fb1c3419c2a48a49938 100644 --- a/sys/odrawpat.lisp +++ b/sys/odrawpat.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: odrawpat.lisp,v 2.7 2007/04/17 21:45:52 layer Exp $ +;; $Id: odrawpat.lisp,v 2.8 2007/04/25 20:29:26 layer Exp $ (in-package :acl-clim) @@ -31,18 +31,18 @@ (if (or (eql scroll :both)(eql scroll :horizontal)) win:ws_hscroll 0) win:ws_clipsiblings)) - (*win-name* *win-name*) + (win-name (win-name *acl-port*)) (cstr (ct:callocate (:char *) :size 256)) (subsize (when pretty (length pretty))) (window nil)) (when pretty (dotimes (i subsize) (ct:cset (:char 256) cstr ((fixnum i)) (char-int (char pretty i)))) - (setq *win-name* cstr)) + (setq win-name cstr)) (setq window (win:createWindow - *clim-class* ; cl-user::clim-class ; "ClimClass" - *win-name* ; "CLIM" + (clim-class *acl-port*) ; cl-user::clim-class ; "ClimClass" + win-name ; "CLIM" winstyle left top width height parent