diff --git a/ChangeLog.n b/ChangeLog.n index 82fc08b52beaeaa526fe66f04e51e083eee0f4b4..8f161337a956f42483711e5d44c3a7dea5414200 100644 --- a/ChangeLog.n +++ b/ChangeLog.n @@ -10,6 +10,10 @@ Tests for new features: <`no new features', `no tests for new features', or <standard changelog date stamp> * <changes go here...> +******************************************************************************* +2.2.2.3 -- join from acl50 branch +next merge tag: acl50_merge3 + ******************************************************************************* Tue Sep 29 22:55:00 1998 Duane Rettig <duane@beta> @@ -43,6 +47,51 @@ next merge tag: acl50_merge2 (this should have been version 2.2.2.0, but was 2.2.1.17 instead) next merge tag: acl50_merge1 +******************************************************************************* +2.2.1.32 + +Sat Sept 19 12:00:00 1998 Jeff Morrill <jmorrill@pointnclick.com> + + * clim/frames, clim/gestures, silica/classes, tk-silica/xm-frames: + enhancement to support double-click gesture + * clim/output-protocol: add (setf stream-default-view) + for string-output-stream (resolve missing method error) + * aclpc/winwidgh, aclpc/acl-frames, aclpc/acl-class: + partial solution to support tooltips + * aclpc/acl-widget: fixes for checkbox, fix (setf gadget-value) + to anticipate the callback might do a throw, cleanups + * aclpc/acl-port: fix problem mapping text styles to the right font + * aclpc/acl-mirror: fix for checkbox + * aclpc/acl-medium: partial solution to transparent rectangular tile + * aclpc/acl-frames: bulletproofing for select-file, fix menubar to + see command name only, cleanup + * aclpc/acl-class: handle dblclick events correctly, cleanup + +******************************************************************************* +2.2.1.31 + +Wed Aug 12 12:00:00 1998 Jeff Morrill <jmorrill@pointnclick.com> + + * silica/db-label: fix handle-repaint of generic-label-pane + * aclpc/acl-class: scroll correctly in scroll-bars, update menu bars + * aclpc/acl-dc: fixes for flipping-ink, dashed lines, stipples + * aclpc/acl-frames: update menu bars, fix select-file segv, + keep noting-progress from hanging + * aclpc/acl-medium: make color->wincolor more accurate, fix + stipples and draw-pattern* + * aclpc/acl-port: keep the event processor from hanging lisp + * aclpc/acl-prel: fixes for stipples and draw-pattern* + * aclpc/acl-scroll: scroll correctly in scroll-bars + * aclpc/acl-widget: scroll correctly in scroll-bars + +******************************************************************************* +2.2.1.30 + +Wed Aug 12 09:22:38 1998 Kevin Layer <layer@ultra> + + * utils/last.lisp: bug7227: add version specification to + load-patches + ******************************************************************************* 2.2.1.29 diff --git a/aclpc/acl-class.lisp b/aclpc/acl-class.lisp index 0930217e361a5050535b415d331f22b49c465ed3..bb06074f04380bae813f053cfe7a1573b3e1cfd4 100644 --- a/aclpc/acl-class.lisp +++ b/aclpc/acl-class.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-class.lisp,v 1.9 1998/08/06 23:15:41 layer Exp $ +;; $Id: acl-class.lisp,v 1.10 1998/10/08 18:36:19 layer Exp $ #|**************************************************************************** * * @@ -33,11 +33,15 @@ ;; 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)) + (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)) +(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)) (defstruct modstate (numlock nil) @@ -131,6 +135,7 @@ (defvar *clim-wproc-arg-struct* nil) (defvar *clim-ctrl-arg-struct* nil) +(defvar *tooltip-relay-struct* nil) (defstruct (PCCStructure (:print-function print-pccstructure) @@ -165,6 +170,11 @@ (setf *clim-wproc-arg-struct* arg-struct) (ff:register-function 'clim-wind-proc :reuse :return-value)) +(defun init-tooltip-relay (wproc-address arg-struct) + (declare (ignore wproc-address)) + (setf *tooltip-relay-struct* arg-struct) + (ff:register-function 'tooltip-relay :reuse :return-value)) + (defun init-clim-ctrl-proc (wproc-address arg-struct) (declare (ignore wproc-address)) (setf *clim-ctrl-arg-struct* arg-struct) @@ -231,7 +241,7 @@ (sheet (mirror->sheet *acl-port* window))) (declare (ignore keys)) (setq *win-result* - (if (note-pointer-motion *acl-port* sheet mx my) + (if (or (not sheet) (note-pointer-motion *acl-port* sheet mx my)) (win:defwindowproc window msg wparam lparam) win:false)))) @@ -316,148 +326,115 @@ (setf *win-result* (adjust-gadget-colors sheet hdc)))))) -;; Process WM_COMMAND +;; Process WM_COMMAND. +;; This message is sent when the user selects a command item +;; from a menu, when a control sends a notification message to +;; its parent window, or when an accelerator key is translated. (defun oncommand (window msg wparam lparam) (declare (ignore msg)) - (let ((wloword (loword wparam)) - (whiword (hiword wparam)) - (sheet (mirror->sheet *acl-port* window)) - (pointer (port-pointer *acl-port*)) - (modifier-state (make-modifier-state)) - (gadget nil) - (hwnd (ct:ccallocate win:hwnd))) - ;;mm: defined in acl-mirr.lsp later - (declare (special *gadget-id->window*)) - (when pointer - (flush-pointer-motion *acl-port*)) - (cond ((and (zerop lparam) ; menu item - (zerop whiword)) ; otherwise control (or accelerator) + (let* ((port *acl-port*) + (sheet (mirror->sheet port window)) + (control (not (zerop lparam)))) + (flush-pointer-motion port) + (cond ((not control) + ;; User selected a command from the menu bar. (let* ((frame (pane-frame sheet)) - (command (cdr (aref *menu-id->command-table* wloword)))) - ;; pr Aug97 - (with-slots (clim-internals::disabled-commands) frame - (if (member (car command) clim-internals::disabled-commands) - (win:messagebeep 200) - #+old - (queue-put (slot-value *acl-port* 'event-queue) - (allocate-event - 'presentation-event - :frame frame - :sheet (frame-top-level-sheet frame) - :presentation-type - `(command :command-table ,command-table) - :value command)) - (execute-command-in-frame - frame command) - )))) - (t - (setf (ct:handle-value win:hwnd hwnd) lparam) - ;;mm: for the moment, the following seems superfluous - ;;(setf hwndid (silica::gadget-id->window sheet wloword)) - (setf gadget (mirror->sheet *acl-port* hwnd)) - (cond ((typep gadget 'silica::mswin-combo-box-pane) - (let ((sheet (mirror->sheet *acl-port* window))) - (when (and sheet (= whiword win:cbn_closeup)) - (with-slots (event-queue) *acl-port* - (queue-put - event-queue - (multiple-value-bind (left top right bottom) - (mirror-client-region-internal* *acl-port* hwnd window) - (declare (ignore right bottom)) - (allocate-event 'silica::window-change-event - :native-x (+ left 1) - :native-y (+ top 1) - :button +pointer-left-button+ - :modifier-state 0 - :pointer pointer - :sheet sheet - :mswin-control gadget))))))) - ((typep gadget 'silica::mswin-text-edit) - (let ((sheet (mirror->sheet *acl-port* window))) - (when (and sheet (= whiword win:en_killfocus)) - - (with-slots (event-queue) *acl-port* - ;handle-event - ; gadget - (multiple-value-bind (left top right bottom) - (mirror-client-region-internal* *acl-port* hwnd window) - (declare (ignore right bottom)) - (queue-put event-queue - (allocate-event - 'silica::window-change-event - :native-x (+ left 1) - :native-y (+ top 1) - :button +pointer-left-button+ - :modifier-state 0 - :pointer pointer - :sheet sheet - :mswin-control gadget))))))) - ((or (not (typep gadget 'silica::hlist-pane)) - (= whiword hln_selchange)) - (when (typep gadget 'silica::hlist-pane) - (win:setfocus window)) - (with-slots (event-queue) *acl-port* - - (multiple-value-bind (left top right bottom) - (mirror-client-region-internal* *acl-port* hwnd window) - (declare (ignore right bottom)) - (queue-put event-queue - (allocate-event - 'silica::window-change-event - :native-x (+ left 1) - :native-y (+ top 1) - :button +pointer-left-button+ - :modifier-state modifier-state - :pointer pointer - :sheet sheet - :mswin-control gadget)))))))) + (ID (loword wparam)) + (command (cdr (aref *menu-id->command-table* ID)))) + (when command + (with-slots (clim-internals::disabled-commands) frame + (if (member (car command) clim-internals::disabled-commands) + (win:messagebeep 200) + (execute-command-in-frame frame command)))))) + (sheet + ;; User clicked on a control. + (let ((gadget (mirror->sheet port lparam))) + (when gadget + (command-event gadget port sheet wparam lparam))))) (clear-winproc-result *win-result*) - *win-result*)) + *win-result*)) + +(defmethod command-event ((gadget t) port sheet wparam lparam) + "Gadget just issued a WM_COMMAND event." + (declare (ignore wparam)) + (let ((pointer (port-pointer port)) + (modifier-state (make-modifier-state))) + (with-slots (event-queue) port + (multiple-value-bind (left top right bottom) + (mirror-client-region-internal* + port lparam (sheet-mirror sheet)) + (declare (ignore right bottom)) + (queue-put event-queue + (allocate-event + 'silica::window-change-event + :native-x (+ left 1) + :native-y (+ top 1) + :button +pointer-left-button+ + :modifier-state modifier-state + :pointer pointer + :sheet sheet + :mswin-control gadget)))))) ;; Process WM_VSCROLL -(defun onvscroll (window msg wparam lparam) - (let* ((type (loword wparam)) +(defun OnVScroll (window msg wparam lparam) + (let* ((scrollcode (loword wparam)) (position (hiword wparam)) (hwnd (if (zerop lparam) window lparam)) ; JPM for rfe353 (message (cond ((eql msg win:wm_hscroll) :horizontal) ((eql msg win:wm_vscroll) :vertical))) - (flag (cond ((eql msg win:wm_hscroll) win:sb_horz) - ((eql msg win:wm_vscroll) win:sb_vert))) - (sheet (mirror->sheet *acl-port* hwnd))) + (sheet (mirror->sheet *acl-port* hwnd)) + (bar (cond ((gadgetp sheet) win:sb_ctl) + ((eql msg win:wm_hscroll) win:sb_horz) + ((eql msg win:wm_vscroll) win:sb_vert))) + (redraw 1)) (declare (fixnum action position)) + ;; By convention, scroll bar values should always have a range of + ;; 0 to *win-scroll-grain*. (multiple-value-bind (action amount) - (cond ((eql type win:sb_lineup) - (win:setScrollPos window flag - (- (win:getScrollPos window flag) 1) 1) - (values :relative-jump -1)) - ((eql type win:sb_linedown) - (win:setScrollPos window flag - (+ (win:getScrollPos window flag) 1) 1) - (values :relative-jump +1)) - ((eql type win:sb_pageup) - (win:setScrollPos window flag - (- (win:getScrollPos window flag) 1) 1) - (values :screenful -1)) - ((eql type win:sb_pagedown) - (win:setScrollPos window flag - (+ (win:getScrollPos window flag) 1) 1) - (values :screenful +1)) - ((eql type win:sb_thumbposition) - (win:setScrollPos window flag position 1) - (values :percentage position)) - ((and *realtime-scrollbar-tracking* - (eql type win:sb_thumbtrack)) - (win:setScrollPos window flag position 1) - (values :percentage position)) - ((eql type win:sb_top) - (win:setScrollPos window flag 0 1) - (values :percentage 0)) - ((eql type win:sb_bottom) - (win:setScrollPos window flag *win-scroll-grain* 1) - (values :percentage 100))) + (case scrollcode + (#.win:sb_bottom + ;; Scroll to lower right + (win:setScrollPos window bar *win-scroll-grain* redraw) + (values :percentage *win-scroll-grain*)) + ((#.win:sb_linedown #.win:sb_lineright) + ;; Scroll down/right one unit + (win:setScrollPos window bar + (+ (win:getScrollPos window bar) 1) + redraw) + (values :relative-jump +1)) + ((#.win:sb_lineup #.win:sb_lineleft) + ;; Scroll up/left one unit + (win:setScrollPos window bar + (- (win:getScrollPos window bar) 1) + redraw) + (values :relative-jump -1)) + ((#.win:sb_pagedown #.win:sb_pageright) + ;; Scroll down/right by width of window. + (win:setScrollPos window bar + (+ (win:getScrollPos window bar) 1) + redraw) + (values :screenful +1)) + ((#.win:sb_pageup #.win:sb_pageleft) + ;; Scroll up/left by width of window. + (win:setScrollPos window bar + (- (win:getScrollPos window bar) 1) + redraw) + (values :screenful -1)) + (#.win:sb_thumbposition + ;; Scroll to absolute position. + (win:setScrollPos window bar position redraw) + (values :percentage position)) + (#.win:sb_thumbtrack + ;; Scroll to absolute position. + (win:setScrollPos window bar position redraw) + (values :percentage position)) + (#.win:sb_top + ;; Scroll to upper left + (win:setScrollPos window bar 0 redraw) + (values :percentage 0)) + ) (when (and action sheet) (with-slots (event-queue) *acl-port* - ;;(queue-put event-queue (handle-event sheet (allocate-event 'silica::scrollbar-event @@ -471,7 +448,7 @@ (declaim (special *setting-sheet-mirror-edges*)) ;; Process WM_MOVE -(defun onmove (window msg wparam lparam) +(defun OnMove (window msg wparam lparam) (let ((sheet (mirror->sheet *acl-port* window))) (if (and sheet (not (eq sheet *setting-sheet-mirror-edges*)) @@ -483,31 +460,25 @@ ;; set return value to 0 (clear-winproc-result *win-result*)) (setq *win-result* (win:defwindowproc window msg wparam lparam))) - *win-result*)) + *win-result*)) -;; Process WM_GETMINMAXINFO -(defun ongetminmaxinfo (window msg wparam lparam) - #+aclpc ;; pnc Aug97 for clim2bug740 +;; Process WM_SIZE +(defun OnSize (window msg wparam lparam) (let ((sheet (mirror->sheet *acl-port* window))) - (if (typep sheet 'acl-top-level-sheet) - (let ((min-width (acl-top-min-width sheet)) - (min-height (acl-top-min-height sheet))) - ;; someone who knows how to use the pc ff interface should get - ;; rid of all these memrefs! (cim 10/4/96) - (when (and min-width min-height) - (set-measureitemstruct-width-and-height lparam min-width - min-height) - #+ignore - (setf (sys:memref-int lparam 0 24 win:uint) min-width - (sys:memref-int lparam 0 28 win:uint) min-height) - (clear-winproc-result *win-result*))) - #+acl86win32 - (setq *win-result* (win:defwindowproc window msg wparam lparam)) - #+aclpc - (ct:%set-long *win-result* 4 0 - (win:defwindowproc window msg wparam lparam))) - *win-result*) - #-aclpc ; +++ fix this for aclpc +++ + (if (and sheet + (not (eq sheet *setting-sheet-mirror-edges*)) + (not (win:IsIconic window))) + (progn + (handle-event + 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*)) + +;; Process WM_GETMINMAXINFO +(defun OnGetMinMaxInfo (window msg wparam lparam) (let ((sheet (mirror->sheet *acl-port* window))) (if (typep sheet 'acl-top-level-sheet) (let ((min-width (acl-top-min-width sheet)) @@ -518,15 +489,13 @@ (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*))) - #+acl86win32 - (setq *win-result* (win:defwindowproc window msg wparam lparam)) - #+aclpc - (ct:%set-long *win-result* 4 0 - (win:defwindowproc window msg wparam lparam))) + (setq *win-result* (win:defwindowproc window msg wparam lparam))) *win-result*)) ;; PROCESS EN_UPDATE -(defun onupdate (window msg wparam lparam) +(defun OnUpdateText (window msg wparam lparam) + ;; An edit control is about to display modified text. + ;; Resize the edit control, if necessary. (declare (ignore msg wparam lparam)) (let ((sheet (mirror->sheet *acl-port* window))) (when sheet @@ -556,22 +525,19 @@ (shiftstate (win:getKeyState win:vk_shift)) (controlstate (win:getKeyState win:vk_control)) (metastate (win:getKeyState win:vk_menu))) - #+debugg - (format *standard-output* - "caps=~a num=~a shift=~a ctrl=~a meta=~a code=~a~%" - capstate numstate shiftstate controlstate metastate code) - (setf (modstate-control *modstate*) (or (minusp controlstate) (not (zerop (ash controlstate -15))))) (setf (modstate-meta *modstate*) - ; whoops! this was controlstate!? + ;; whoops! this was controlstate!? (or (minusp metastate) (not (zerop (ash metastate -15))))) (setf (modstate-numlock *modstate*) (and (plusp numstate) (zerop (ash numstate -15)))) (setf (modstate-shift *modstate*) - (or (and (or (minusp shiftstate) (not (zerop (ash shiftstate -15)))) + (or (and (or (minusp shiftstate) + (not (zerop (ash shiftstate -15)))) (zerop capstate)) - (and (not (or (minusp shiftstate) (not (zerop (ash shiftstate -15))))) + (and (not (or (minusp shiftstate) + (not (zerop (ash shiftstate -15))))) (and (plusp capstate) (zerop (ash capstate -15))))))) (if pass (progn @@ -609,22 +575,13 @@ (cond ((and (eql msg win:wm_keydown) (setq command (lookup-accelerator frame keysym modstate))) - #+old - (queue-put - event-queue - (allocate-event 'presentation-event - :frame frame - :sheet (frame-top-level-sheet frame) - :presentation-type - `(command :command-table ,command-table) - :value command)) - (execute-command-in-frame - frame command)) + (execute-command-in-frame frame command)) ((and (eql msg win:wm_keydown) (eql keysym :newline) (find-default-gadget frame)) (activate-default-gadget frame)) (t + (setf (port-modifier-state *acl-port*) modstate) (queue-put event-queue (allocate-event (cond ((or (eql msg win:wm_keydown) @@ -635,9 +592,7 @@ 'key-release-event)) :key-name keysym :character char - :modifier-state - (setf (port-modifier-state *acl-port*) - modstate) + :modifier-state modstate :sheet sheet)) ;;added this so that port modifier state is always ;; updated, even on passed characters. -- KR @@ -685,18 +640,17 @@ :mswin-control gadget))) (clim:beep)))) -;; Process WM_BUTTONDOWN -(defun onbuttondown (window msg wparam lparam) +;; Process WM_LBUTTONDOWN +(defun OnButtonDown (window msg wparam lparam) ;; added the following so that clicking on a blank area will ;; move the focus away from any text-fields and cause their ;; value to be correctly updated - this was copied from the ;; handle-event on key-press-event for mswin-text-edit in ;; acl-widg (cim 9/17/96) - (win:setfocus (win:getactivewindow) #-acl86win32 :static) - - (let ((modifier-state - (windows-mask->modifier-state wparam)) - (pointer (port-pointer *acl-port*))) + (win:setfocus (win:getactivewindow)) + (let* ((pointer (port-pointer *acl-port*)) + (sheet (mirror->sheet *acl-port* window)) + (modifier-state (windows-mask->modifier-state wparam))) (when pointer (flush-pointer-motion *acl-port*) (setf (port-modifier-state *acl-port*) modifier-state) @@ -727,12 +681,49 @@ :button button :modifier-state modifier-state :pointer pointer - :sheet (mirror->sheet *acl-port* window))))))) + :sheet sheet)))))) + (clear-winproc-result *win-result*) + *win-result*) + +;; Process WM_LBUTTONDBLCLK +(defun OnButtonDblClk (window msg wparam lparam) + ;; A double click will actually generate four events: + ;; down, up, dblclk, up. This function handles the + ;; double click, the other three are handled by OnButtonDown. + (win:setfocus (win:getactivewindow)) + (let* ((pointer (port-pointer *acl-port*)) + (sheet (mirror->sheet *acl-port* window)) + (modifier-state (windows-mask->modifier-state wparam t))) + (when pointer + (flush-pointer-motion *acl-port*) + (setf (port-modifier-state *acl-port*) modifier-state) + (multiple-value-bind (key button) + (cond ((eql msg win:wm_lbuttondblclk) + (values 'pointer-button-press-event + +pointer-left-button+)) + ((eql msg win:wm_mbuttondblclk) + (values 'pointer-button-press-event + +pointer-middle-button+)) + ((eql msg win:wm_rbuttondblclk) + (values 'pointer-button-press-event + +pointer-right-button+))) + (with-slots (event-queue) *acl-port* + (queue-put event-queue + (allocate-event key + :native-x (loword lparam) + :native-y (hiword lparam) + :button button + :modifier-state modifier-state + :pointer pointer + :sheet sheet)))))) (clear-winproc-result *win-result*) - *win-result*) + *win-result*) ;; Process WM_ACTIVATE -(defun onactivate (window msg wparam lparam) +(defun OnActivate (window msg wparam lparam) + ;; A window or a control is being activated. + ;; If user is activating with a mouse click, + ;; OnMouseActivate is also called. (declare (ignore msg lparam)) (let ((sheet (mirror->sheet *acl-port* window)) (flag (loword wparam))) @@ -762,13 +753,26 @@ *win-result*)) ;; Process WM_INITMENUPOPUP -(defun oninitmenupopup (window msg wparam lparam) - (declare (ignore msg window lparam)) - (update-menu-item-sensitivities wparam) - *win-result*) +(defun OnInitMenuPopup (window msg wparam lparam) + ;; Sent when a drop-down menu or submenu is about to become active. + ;; We use it to activate/deactivate menu items and to update + ;; menus in response to add/remove menu-item-from-command-table. + (declare (ignore msg)) + (let ((sheet (mirror->sheet *acl-port* window)) + (system-menu (plusp (hiword lparam))) + (index (loword lparam)) + (menu-handle wparam)) + (unless system-menu + (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*))) ;; Process WM_NCHITTEST -(defun onnchittest (window msg wparam lparam) +(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))) ;; Allow Windows to provide default message processing. @@ -777,6 +781,36 @@ (setq *win-result* (win:defwindowproc window msg wparam lparam)) *win-result*) +;; Refer to the windows documentation on Tooltip controls. +;; The message stream needs to be relayed to the tooltip +;; control for it to know when and where to display tool tips. +(ff:defun-c-callable tooltip-relay (window msg wparam lparam) + (declare (:convention :stdcall) (:unwind 0) + (special wmsg) + (optimize (safety 0) (speed 3))) + (case msg + ((#.win:wm_mousemove + #.win:wm_lbuttondown + #.win:wm_lbuttonup + #.win:wm_rbuttondown + #.win:wm_rbuttonup) + (let* ((sheet (mirror->sheet *acl-port* window)) + (frame (pane-frame sheet)) + (top (frame-top-level-sheet frame)) + (tt (tooltip-control top)) + (ttm_relayevent #.(+ win:wm_user 7)) + (relay wmsg)) + (when tt + (ct:csets win:msg relay + lparam lparam + wparam wparam + message msg + hwnd window) + (or (plusp (win:sendmessage tt TTM_RELAYEVENT 0 relay)) + (check-last-error "TTM_RELAYEVENT" :Action :warn)))))) + #+optional + (callnexthookex *next-windows-hook* msg wparam lparam)) + (defvar *trace-messages* nil) ;; CLIM-WIND-PROC @@ -831,12 +865,14 @@ (oncommand window msg wparam lparam)) ((#.win:wm_hscroll #.win:wm_vscroll) (onvscroll window msg wparam lparam)) - ((#.win:wm_move #.win:wm_size) + (#.win:wm_move (onmove window msg wparam lparam)) + (#.win:wm_size + (onsize window msg wparam lparam)) (#.win:wm_getminmaxinfo (ongetminmaxinfo window msg wparam lparam)) (#.win:en_update - (onupdate window msg wparam lparam)) + (OnUpdateText window msg wparam lparam)) ;; character typed ((#.win:wm_keydown #.win:wm_syskeydown @@ -850,6 +886,10 @@ #.win:wm_rbuttonup #.win:wm_mbuttonup) (onbuttondown window msg wparam lparam)) + ((#.win:wm_lbuttondblclk + #.win:wm_lbuttondblclk + #.win:wm_lbuttondblclk) + (onbuttondblclk window msg wparam lparam)) (#.win:wm_activate (onactivate window msg wparam lparam)) ((#.win:wm_killfocus @@ -858,7 +898,9 @@ (#.win:wm_initmenupopup (oninitmenupopup window msg wparam lparam)) (#.win:wm_nchittest - (onnchittest window msg wparam lparam)) + (OnNcHitTest window msg wparam lparam)) + (#.win:wm_notify + (message-default window msg wparam lparam)) (otherwise (message-default window msg wparam lparam))) (setf result *win-result*) @@ -913,11 +955,12 @@ (setf (modstate-numlock *ctlmodstate*) (and (plusp numstate) (zerop (ash numstate -15)))) (setf (modstate-shift *ctlmodstate*) - (or (and (or (minusp shiftstate) (not (zerop (ash shiftstate -15)))) + (or (and (or (minusp shiftstate) + (not (zerop (ash shiftstate -15)))) (zerop capstate)) - (and (not (or (minusp shiftstate) (not (zerop (ash shiftstate -15))))) - (and (plusp capstate) (zerop (ash capstate -15)))))) - ) + (and (not (or (minusp shiftstate) + (not (zerop (ash shiftstate -15))))) + (and (plusp capstate) (zerop (ash capstate -15))))))) (when (and (or (<= #x30 vk #x5a)(<= #xba vk #xc0)(<= #xdb vk #xdf)) (modstate-shift *ctlmodstate*)) @@ -949,13 +992,9 @@ (if pass (progn (setq pass nil) - #+acl86win32 - (setq *win-result* (win:callwindowproc std-ctrl-proc-address - window msg wparam lparam)) - #+aclpc - (ct:%set-long *win-result* 4 0 - (win:callwindowproc std-ctrl-proc-address - window msg wparam lparam)) + (setq *win-result* + (win:callwindowproc std-ctrl-proc-address + window msg wparam lparam)) *win-result*) (progn ;; We have decided to handle this character ourselves! @@ -995,6 +1034,8 @@ (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) @@ -1049,6 +1090,9 @@ (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))) + #+not-yet + (setf tooltip-relay-address + (init-tooltip-relay tooltip-relay-address #.(make-cstructure 0 16))) (setq *clim-initialized* t))) (defun acl-clim::register-window-class (hcursor) @@ -1060,28 +1104,35 @@ (icon (win:LoadIcon 0 win:IDI_APPLICATION)) ; (get-clim-icon) (reg nil)) (ct:csets win:wndclassex class - win::cbSize (ct:sizeof win:wndclassex) - win::style (logior win:CS_DBLCLKS - win:CS_BYTEALIGNCLIENT - win:CS_BYTEALIGNWINDOW - ;; win:CS_SAVEBITS ; Can we afford this? - ;; win:CS_OWNDC - ) - win::lpfnwndproc clim-window-proc-address - win::cbClsExtra 0 - win::cbWndExtra 0 - win::hinstance *hinst* - win::hicon icon - win::hcursor hcursor - win::hbrbackground (1+ win:color_btnface) - win::lpszmenuname ct:hnull ;*menu-name* - win::lpszclassname (ff:string-to-char* *clim-class*) - win::hIconSm icon) + cbSize (ct:sizeof win:wndclassex) + style (logior win:CS_DBLCLKS + win:CS_BYTEALIGNCLIENT + win:CS_BYTEALIGNWINDOW + ;; win:CS_SAVEBITS ; Can we afford this? + ;; win:CS_OWNDC + ) + lpfnwndproc clim-window-proc-address + cbClsExtra 0 + cbWndExtra 0 + hinstance *hinst* + hicon icon + hcursor hcursor + hbrbackground (1+ win:color_btnface) + lpszmenuname ct:hnull ;*menu-name* + lpszclassname (ff:string-to-char* *clim-class*) + hIconSm icon) (setq reg (win:registerclassex class)) (when (zerop reg) (check-last-error "RegisterClassEx")) - (setq *wndclass-registered* t)) - )) + (setq *wndclass-registered* t) + (when tooltip-relay-address + (setq *next-windows-hook* + (SetWindowsHookEx win:WH_GETMESSAGE + tooltip-relay-address + 0 0)) + (when (zerop *next-windows-hook*) + (check-last-error "SetWindowsHookEx"))) + t))) ;;; "CreateWindowEx" ;;;(dword lpctstr lpctstr dword int int int int hwnd hmenu handle lpstr) @@ -1119,8 +1170,13 @@ (when pretty (setq *win-name* pretty)) (cond (modal + ;; Accepting-values comes in here. We need + ;; thickframe, even though that is not normally + ;; used for modal dialog boxes, so that AVV is + ;; sizeable. (setq winstyle (logior winstyle + win:ws_thickframe win:ws_popup (if parent win:ds_modalframe 0) win:ds_3dlook @@ -1234,8 +1290,7 @@ (defun wait-for-event () (when (prog1 (win:peekMessage wmsg (ct:null-handle win:hwnd) 0 0 - (logior win:PM_NOYIELD win:PM_NOREMOVE) - #+acl86win32x wres) + (logior win:PM_NOYIELD win:PM_NOREMOVE)) (not (and (zerop (hiword wres)) (zerop (loword wres))))) t)) diff --git a/aclpc/acl-dc.lisp b/aclpc/acl-dc.lisp index a14f76fe983ce3f00f43b2d7c327c4ce01b27013..97b8c6f0b55993af9150ba9a04229a0cbd80107a 100644 --- a/aclpc/acl-dc.lisp +++ b/aclpc/acl-dc.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-dc.lisp,v 1.6 1998/08/06 23:15:41 layer Exp $ +;; $Id: acl-dc.lisp,v 1.7 1998/10/08 18:36:21 layer Exp $ #|**************************************************************************** * * @@ -72,15 +72,18 @@ (defvar *created-font* nil) (defvar *created-region* nil) +;; Device context information (defstruct (dc-image (:predicate nil)) - (bitmap nil) - solid-1-pen - ;; Hash table doesn't appear to be needed anymore. JPM Jan 98. - (pen-table nil #+obsolete (make-hash-table)) - brush - (rop2 win:r2_copypen) - text-color - background-color) + (bitmapinfo nil) ; colors of unmasked bitmap + (bitmap nil) ; bits of unmasked bitmap + solid-1-pen ; style, width, and color of lines + brush ; color/stipple used to fill polygons + (rop2 win:r2_copypen) ; set the foreground mix mode + text-color ; foreground color + background-color ; background color + and-bitmap ; AND part of masked bitmap (monochrome) + and-brush ; AND part of masked brush (monochrome) + ) (defun initialize-dc () (unless (win:iswindow *current-window*) @@ -223,21 +226,32 @@ (win:deleteDc ,cdc)))) (defun set-dc-for-drawing (dc image line-style) + ;; Note: DASHES may be a list, i.e. (5 2). CreatePen + ;; only supports four dash types, and here we only use + ;; one of them. Complex dash patterns cannot be supported + ;; using CreatePen. (let* ((dashes (line-style-dashes line-style)) (thickness (max 1 (round (line-style-thickness line-style)))) (code (if dashes (- thickness) thickness)) (brush *null-brush*) (pen (when (= code 1) (dc-image-solid-1-pen image))) - (rop2 (dc-image-rop2 image))) + (rop2 (dc-image-rop2 image)) + (color (dc-image-text-color image))) (declare (fixnum thickness code)) (unless pen (when *created-pen* (push *created-pen* *extra-objects*)) + (when (and dashes (> thickness 1)) + ;; CreatePen does not support this combination. + ;; So render dashes with thickness=1. + (setq thickness 1)) + (when (= rop2 win:r2_xorpen) + (setq color #xffffff)) ; black (setq pen (setq *created-pen* (createPen (if dashes win:ps_dash win:ps_solid) thickness - (dc-image-text-color image))))) + color)))) (selectobject dc pen) (if dashes (win:setBkMode dc win:TRANSPARENT) @@ -246,7 +260,7 @@ (when rop2 (win:setRop2 dc rop2)) t)) -(defun set-dc-for-filling (dc image) +(defun set-dc-for-filling (dc image &optional xorg yorg) (let ((background-color (dc-image-background-color image)) (text-color (dc-image-text-color image)) (brush (dc-image-brush image)) @@ -255,20 +269,25 @@ (selectobject dc pen) (when background-color (cond ((minusp background-color) + ;; This affects brushes created with CreateHatchBrush. (win:setBkMode dc win:TRANSPARENT)) (t (win:setBkMode dc win:OPAQUE) (win:setBkColor dc background-color)))) (when text-color (win:setTextColor dc text-color)) - (when brush (selectobject dc brush)) + (when brush + (when (and xorg yorg) + ;; Is this working? JPM. + (win:setbrushorgex dc xorg yorg 0)) + (selectobject dc brush)) (when rop2 (win:setRop2 dc rop2)) t)) -(defun set-dc-for-ink (dc medium ink line-style) +(defun set-dc-for-ink (dc medium ink line-style &optional xorg yorg) (let ((image (dc-image-for-ink medium ink))) (if line-style (set-dc-for-drawing dc image line-style) - (set-dc-for-filling dc image)))) + (set-dc-for-filling dc image xorg yorg)))) (defun set-cdc-for-pattern (dc medium ink line-style) (declare (ignore line-style)) @@ -310,6 +329,7 @@ (brush (dc-image-brush image)) (pen (dc-image-solid-1-pen image)) (rop2 (dc-image-rop2 image))) + (win:setmapmode dc win:MM_TEXT) (when font (selectobject dc font)) (cond ((not background-color) (win:setBkMode dc win:transparent)) diff --git a/aclpc/acl-frames.lisp b/aclpc/acl-frames.lisp index 8aa16e10a91decefad6e39ed2c76a8fa954cd3c4..b0107167ab2bd4482e6caef1bd4748c2fdbb41f3 100644 --- a/aclpc/acl-frames.lisp +++ b/aclpc/acl-frames.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-frames.lisp,v 1.7 1998/08/06 23:15:43 layer Exp $ +;; $Id: acl-frames.lisp,v 1.8 1998/10/08 18:36:21 layer Exp $ #|**************************************************************************** * * @@ -90,11 +90,15 @@ (min-height :accessor acl-top-min-height :initform nil) (accelerator-gestures :initform nil :reader top-level-sheet-accelerator-gestures) (sheet-thread :initform nil :accessor clim-internals::sheet-thread) + (tooltip-control :initform nil :accessor tooltip-control) )) -(defun record-accelerator (sheet keysym command) - (push (cons keysym command) - (slot-value sheet 'accelerator-gestures))) +(defun record-accelerator (frame keysym command &optional sheet) + (unless sheet + (setq sheet (frame-top-level-sheet frame))) + (pushnew (cons keysym command) + (slot-value sheet 'accelerator-gestures) + :test #'equal)) (defun keysymeql (keysyma keysymb) (or (eql keysyma keysymb) @@ -192,7 +196,7 @@ ;;; always get repainted in their ungrayed state at the end. pr Aug97 ;(setf (command-enabled command-name frame) enablep) -;(win::EnableMenuItem menu menuid (if enablep win:MF_ENABLED win:MF_GRAYED)) +;(win:EnableMenuItem menu menuid (if enablep win:MF_ENABLED win:MF_GRAYED)) (defun keysym->char (keysym) (if (typep keysym 'character) @@ -327,84 +331,172 @@ (gesture-spec-for-mswin keystroke)) newtext)))) +(defun make-menu-for-command-table (command-table menuhand frame + &optional top-level-sheet top-level-p) + (unless top-level-sheet + (setq top-level-sheet (clim:frame-top-level-sheet frame))) + ;; (re)initialize + (let ((count (win:getmenuitemcount menuhand))) + (when (plusp count) + (dotimes (position count) + ;; Use position = 0 every time because the menu items get + ;; renumbered each time through this loop. + (win:deletemenu menuhand 0 win:MF_BYPOSITION)) + (win:drawmenubar (sheet-mirror (frame-top-level-sheet frame))))) + (setf (gethash menuhand *popup-menu->menu-item-ids*) nil) + (setf (gethash menuhand *popup-menu->command-table*) + (list command-table + (slot-value (find-command-table command-table) + 'clim-internals::menu-tick))) + ;; Make the menu + (map-over-command-table-menu-items + #'(lambda (menu keystroke item) + (let* ((type (command-menu-item-type item)) + (value (command-menu-item-value item)) + (menu-item-available-p + (or (not (eq type :command)) + (command-enabled (car value) frame))) + (menu-item-selected-p nil) + (acckey keystroke) + (flags (logior + win:MF_STRING + (if menu-item-available-p + win:MF_ENABLED win:MF_GRAYED) + (if menu-item-selected-p + win:MF_CHECKED win:MF_UNCHECKED))) + (smflags (logior flags win:MF_POPUP))) + (case type + (:command + (when acckey + (record-accelerator frame acckey value top-level-sheet)) + (let ((menu-item-id (assign-command-menu-item-id value frame))) + (win:AppendMenu + menuhand + flags + menu-item-id + (make-menu-text menu + ;; Don't display the accelerator key if + ;; the command is going to land on the menu bar itself, + ;; Windows will not correctly display such text. + (if top-level-p nil acckey) + item)) + (push menu-item-id (gethash menuhand *popup-menu->menu-item-ids*)))) + (:function + (warn ":function not yet implemented in menu bars") + ) + (:menu + (let* ((submenu (win:CreatePopupMenu)) + (submenu-handle (ct:handle-value 'win:hmenu submenu)) + (menutext (make-menu-text menu acckey item))) + (win:AppendMenu menuhand + smflags + submenu-handle + menutext) + (make-menu-for-command-table value submenu-handle frame top-level-sheet))) + (:divider + (win:AppendMenu menuhand + win:MF_SEPARATOR + 0 + "x") + )))) + command-table)) + (defun compute-msmenu-bar-pane (frame top command-table) (let* ((mirror (sheet-mirror top)) (menu-handle (win:GetMenu mirror)) (command-table (if (listp command-table) (car command-table) command-table))) (when (silica::default-command-table-p command-table) - ;; command-table arg comes from menu-bar slot of frame - ;; and may be NIL T=menu-hbox-pane command-table-arg - (setq command-table (frame-command-table frame))) - (with-look-and-feel-realization ((frame-manager frame) frame) - (labels - ((make-command-table-buttons (command-table menuhand top-level) - (let ((menu-item-ids nil)) - (map-over-command-table-menu-items - #'(lambda (menu keystroke item) - (let* ((type (command-menu-item-type item)) - (value (command-menu-item-value item)) - (menu-item-available-p - (or (not (eq type :command)) - (command-enabled (car value) frame))) - (menu-item-selected-p nil) - (acckey (and (not top-level) keystroke)) - (flags (logior - win:MF_STRING - (if menu-item-available-p - win:MF_ENABLED win:MF_GRAYED) - (if menu-item-selected-p - win:MF_CHECKED win:MF_UNCHECKED))) - (smflags (logior flags win:MF_POPUP))) - (case type - (:command - (when acckey - (record-accelerator top acckey value)) - (let ((menu-item-id - (assign-command-menu-item-id value frame))) - (win:AppendMenu - menuhand - flags - menu-item-id - (make-menu-text menu acckey item)) - (push menu-item-id menu-item-ids))) - (:function - (warn ":function not yet implemented in menu bars") - ) - (:menu - (let* ((popmenu (win::CreatePopupMenu)) - (hmenu (ct:handle-value 'win::hmenu popmenu)) - (menutext (make-menu-text menu acckey item))) - (win::AppendMenu menuhand - smflags - hmenu - menutext) - (setf (gethash hmenu *popup-menu->menu-item-ids*) - (make-command-table-buttons value popmenu nil)))) - (:divider - (unless top-level - (win::AppendMenu menuhand - win:MF_SEPARATOR - 0 - "x") - ))))) - command-table) - menu-item-ids))) - (make-command-table-buttons command-table menu-handle t))))) + ;; command-table arg comes from menu-bar slot of frame + ;; and may be NIL T=menu-hbox-pane command-table-arg + (setq command-table (frame-command-table frame))) + (make-menu-for-command-table command-table menu-handle frame top t))) + +(defun update-menu-contents (sheet menuhand index) + ;; Called just before making a menu active. If the menu is associated + ;; with a command table, make sure to rebuild the menu if the command + ;; table has changed recently. Returns T if the menu was rebuilt. + (declare (ignore index)) + (let* ((frame (pane-frame sheet)) + (pair (gethash menuhand *popup-menu->command-table*)) + (command-table (first pair)) + (tickthen (second pair)) + (ticknow (when tickthen (slot-value (find-command-table command-table) + 'clim-internals::menu-tick)))) + (when (and tickthen ticknow (not (= tickthen ticknow))) + (make-menu-for-command-table command-table menuhand frame t) + t))) (defun update-menu-item-sensitivities (hmenu) + ;; 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)) (frame (first item)) (command (second item)) (top (frame-top-level-sheet frame)) (mirror (sheet-mirror top)) - (menu-handle (win::GetMenu mirror))) - (win::EnableMenuItem menu-handle menu-item-id + (menu-handle (win:GetMenu mirror))) + (win:EnableMenuItem menu-handle menu-item-id (if (command-enabled command frame) win:MF_ENABLED win:MF_GRAYED))))) +(defmethod initialize-tooltips ((frame standard-application-frame)) + ;; Create a tooltip control associated with this frame. + ;; Note that this control won't do anything unless you + ;; set up a message relay to evesdrop on the messages being + ;; sent to other controls. + (let* ((sheet (frame-top-level-sheet frame)) + (tooltip-control (tooltip-control sheet)) + (toolinfo (ct:ccallocate toolinfo)) + (TTM_ADDTOOL #+ics #.(+ win:wm_user 50) ;; TTM_ADDTOOLW + #-ics #.(+ win:wm_user 4) ;; TTM_ADDTOOLA + ) + (TTM_ACTIVATE #.(+ win:wm_user 1)) + (TTF_IDISHWND 1) + (TTS_ALWAYSTIP 1) + (status nil)) + (unless tooltip-control + (win:InitCommonControls) + (setq tooltip-control + (win:CreateWindow "tooltips_class32" + 0 + TTS_ALWAYSTIP + win:CW_USEDEFAULT win:CW_USEDEFAULT + win:CW_USEDEFAULT win:CW_USEDEFAULT + 0 0 + *hinst* 0)) + (setf (tooltip-control sheet) tooltip-control) + (when (zerop tooltip-control) + (check-last-error "CreateWindow" :action :warn) + (return-from initialize-tooltips nil)) + (win:SendMessage tooltip-control TTM_ACTIVATE 1 0) + (flet ((tip (s) + ;; I never got tool tips to work, so I didn't + ;; really finish this part. JPM 8/98. + (ct:csets + toolinfo toolinfo + cbsize (ct:sizeof toolinfo) + uflags TTF_IDISHWND + hwnd (sheet-mirror sheet) + uid (sheet-mirror s) + ;;rect 0 + hinst *hinst* + lpsztext -1 ;(coerce (string (type-of s)) 'simple-string) + #+ign + (lisp-string-to-scratch-c-string + (princ-to-string label))) + (setq status + (win:SendMessage tooltip-control + TTM_ADDTOOL 0 toolinfo)) + (when (zerop status) + (return-from initialize-tooltips nil)))) + (declare (dynamic-extent #'tip)) + (map-over-sheets #'tip sheet) + tooltip-control)))) + (defmethod redisplay-frame-panes :around ((frame standard-application-frame) &key force-p) (declare (ignore force-p)) @@ -418,6 +510,7 @@ (defmethod run-frame-top-level :before ((frame standard-application-frame) &key &allow-other-keys) + (initialize-tooltips frame) (let* ((sheet (frame-top-level-sheet frame)) (thread (when sheet (clim-internals::sheet-thread sheet)))) (unless (eq thread (current-process)) @@ -434,22 +527,22 @@ to be run from another." (when (consp command) (setf command (car command))) (let* ((top (frame-top-level-sheet frame)) (mirror (sheet-mirror top)) - (menu-handle (win::GetMenu mirror)) + (menu-handle (win:GetMenu mirror)) (command-id (find-command-menu-item-id command frame)) (flag win:MF_ENABLED)) (when menu-handle - (win::EnableMenuItem menu-handle command-id flag)))) + (win:EnableMenuItem menu-handle command-id flag)))) ;;--- Should "gray" the command button, if there is one (defmethod note-command-disabled ((framem acl-frame-manager) frame command) (when (consp command) (setf command (car command))) (let* ((top (frame-top-level-sheet frame)) (mirror (sheet-mirror top)) - (menu-handle (win::GetMenu mirror)) + (menu-handle (win:GetMenu mirror)) (command-id (find-command-menu-item-id command frame)) (flag win:MF_GRAYED)) (when menu-handle - (win::EnableMenuItem menu-handle command-id flag)))) + (win:EnableMenuItem menu-handle command-id flag)))) (defmethod note-frame-enabled :around ((framem acl-frame-manager) frame) (call-next-method) @@ -505,11 +598,11 @@ to be run from another." (sheet (frame-top-level-sheet frame))) (when name (let ((win (sheet-mirror sheet)) - (cstr (ct::callocate (:char *) :size 256)) + (cstr (ct:callocate (:char *) :size 256)) (subsize (length name))) (dotimes (i subsize) - (ct::cset (:char 256) cstr ((fixnum i)) (char-int (char name i)))) - (ct::cset (:char 256) cstr ((fixnum subsize)) + (ct:cset (:char 256) cstr ((fixnum i)) (char-int (char name i)))) + (ct:cset (:char 256) cstr ((fixnum subsize)) #-aclpc (char-int #\NULL) #+aclpc 0) (or (win:SetWindowText win cstr) (check-last-error "SetWindowText")))))) @@ -671,7 +764,11 @@ to be run from another." (flet ((print-item (item) (silica::xlat-newline-return (with-output-to-string (stream) - (funcall (or printer #'print-menu-item) item stream))))) + ;; The click-right menu uses PRESENT at this point to + ;; get the menu text, using the stream-default-view, which needs to be + ;; set to textual-menu-view. + (letf-globally (((stream-default-view stream) +textual-menu-view+)) + (funcall (or printer #'print-menu-item) item stream)))))) (declare (dynamic-extent #'print-item)) (incf tick) (ecase (clim-internals::menu-item-type item) @@ -781,24 +878,26 @@ to be run from another." (cdr dotted-pair) (code-char 0)))) (eval-when (compile load eval) - (defconstant *scratch-string-length* 256) + ;; All pathnames returned by SELECT-FILE must fit in the scratch string, + ;; so make it pretty big. + (defconstant *scratch-string-length* 2048) ) (defparameter *scratch-lisp-string* (make-string *scratch-string-length*)) (defparameter *scratch-c-string* - (ff::allocate-fobject-c `(:array :char ,*scratch-string-length*))) + (ff:allocate-fobject-c `(:array :char ,*scratch-string-length*))) (defun lisp-string-to-scratch-c-string (lisp-string) (let ((length (min (length lisp-string) (1- *scratch-string-length*)))) (dotimes (i length ;; null term - (setf (ff::fslot-value-c '(:array :char 1) + (setf (ff:fslot-value-c '(:array :char 1) *scratch-c-string* length) 0)) - (setf (ff::fslot-value-c '(:array char 1) *scratch-c-string* + (setf (ff:fslot-value-c '(:array char 1) *scratch-c-string* i) (char-int (aref lisp-string i)))) *scratch-c-string* @@ -894,28 +993,24 @@ to be run from another." (defun get-pathname (prompt directory stream allowed-types initial-name save-p multiple-p warn-if-exists-p) (flet ((fill-c-string (string) - (let ((c-string (ff::allocate-fobject-c '(:array :char 256))) + (let ((c-string (ff:allocate-fobject-c '(:array :char 256))) (length (length string))) - (dotimes (i length (setf (ff::fslot-value-c '(:array :char 1) + (dotimes (i length (setf (ff:fslot-value-c '(:array :char 1) c-string length) 0)) (setf (ff:fslot-value-c '(:array char 1) c-string i) (char-int (aref string i)))) c-string))) (let* ((open-file-struct (ct:ccallocate win:openfilename)) - (file-filter-string (fill-c-string - (apply #'concatenate 'string - (mapcar #'make-filter-string allowed-types)))) - (initial-dir-string - (ff:string-to-char* directory) - #+ignore - (fill-c-string - (or directory (namestring *default-pathname-defaults*)))) + (file-filter-string + (fill-c-string + (apply #'concatenate 'string + (mapcar #'make-filter-string allowed-types)))) + (initial-dir-string (ff:string-to-char* directory)) (prompt-string (fill-c-string prompt))) (ct:csets win:openfilename open-file-struct lstructsize (ct:sizeof win:openfilename) - hwndowner (or (and stream - (clim::sheet-mirror stream)) + hwndowner (or (and stream (sheet-mirror stream)) 0) hinstance 0 ; no custom dialog lpstrfilter file-filter-string @@ -924,7 +1019,7 @@ to be run from another." nfilterindex 0 ; zero means use custom-filter if supplied ; otherwise the first filter in the list lpstrfile (lisp-string-to-scratch-c-string (or initial-name "")) - nmaxfile 256 + nmaxfile *scratch-string-length* lpstrfiletitle 0 nmaxfiletitle 0 lpstrinitialdir initial-dir-string @@ -937,14 +1032,20 @@ to be run from another." win:ofn_nochangedir win:ofn_hidereadonly ) + nfileoffset 0 nfileextension 0 + lpstrdefext 0 + lcustdata 0 + lpfnhook 0 + lptemplatename 0 ) (let* ((result (if save-p (win:GetSaveFileName open-file-struct) (win:GetOpenFileName open-file-struct)))) - (dolist (c-string (list file-filter-string initial-dir-string prompt-string)) - (ff::free-fobject-c c-string)) + (ff:free-fobject-c file-filter-string) + (ff:free-fobject-c initial-dir-string) + (ff:free-fobject-c prompt-string) (if result ;; t means no errors and user said "OK" (if multiple-p (pathnames-from-directory-and-filenames @@ -962,6 +1063,7 @@ to be run from another." common-dialog-errors)) error-code)))))))))) + (defun get-directory (sheet title) (let* ((info (ct:ccallocate browseinfo))) (ct:csets browseinfo info @@ -980,7 +1082,7 @@ to be run from another." (defmethod frame-manager-select-file ((framem acl-frame-manager) - &key (default nil default-p) + &key (default nil) (frame nil frame-p) (associated-window (if frame-p @@ -1005,7 +1107,7 @@ to be run from another." file-search-proc documentation)) (unless pattern (setq pattern "")) - (when default-p + (when (pathnamep default) (let ((name (pathname-name default)) (type (pathname-type default)) (dir (pathname-directory default)) @@ -1161,7 +1263,7 @@ to be run from another." :height 125)) (setf (work-process frame) worker) (run-frame-top-level frame))))) - (mp:process-wait + (process-wait "Synchronize" #'(lambda () (and frame @@ -1306,7 +1408,7 @@ to be run from another." (let ((sheet (frame-top-level-sheet frame))) (fix-coordinates x y) (or (win:setWindowPos (sheet-mirror sheet) - (ct::null-handle win::hwnd) ; we really want win::HWND_TOP + (ct:null-handle win:hwnd) ; we really want win:HWND_TOP x y 0 0 (logior win:swp_noactivate win:swp_nozorder @@ -1370,12 +1472,14 @@ in a second Lisp process. This frame cannot be reused." (when width (maxf width min-width)) (when height (maxf height min-height)))) (call-next-method frame width height) - (let ((wrect (ct::ccallocate win::rect)) + (let ((wrect (ct:ccallocate win:rect)) (handle (sheet-direct-mirror (frame-top-level-sheet frame)))) - ;;; +++rl don't show the window here - ;;; the code below makes sure that the frame grows or shrinks - ;;; when the user resizes the frame window - #+ignore (win::showWindow handle win::sw_show) + ;;; The code below makes sure that the frame grows or shrinks + ;;; when the user resizes the frame window. + ;; ---- + ;; Actually, the code below repaints the entire frame, + ;; which isn't good because, while resizing with the mouse, + ;; we end up doing this each time the mouse moves. JPM. (or (win:getClientRect handle wrect) (acl-clim::check-last-error "GetClientRect")) (or (win:InvalidateRect handle wrect 1) @@ -1391,17 +1495,17 @@ in a second Lisp process. This frame cannot be reused." (defun frame-find-position (frame) (when frame - (let* ((wrect (ct::ccallocate win::rect)) + (let* ((wrect (ct:ccallocate win:rect)) (sheet (frame-top-level-sheet frame)) (handle (when sheet (sheet-mirror sheet)))) (when handle - (win::GetWindowRect handle wrect) - (values (ct::cref win::rect wrect win::left) - (ct::cref win::rect wrect win::top)))))) + (win:GetWindowRect handle wrect) + (values (ct:cref win:rect wrect left) + (ct:cref win:rect wrect top)))))) (defun frame-set-position (frame x y) (win:setWindowPos (sheet-mirror (frame-top-level-sheet frame)) - (ct::null-handle win::hwnd) ; we really want win::HWND_TOP + (ct:null-handle win:hwnd) ; we really want win:HWND_TOP x y 0 0 (logior win:swp_noactivate win:swp_nozorder diff --git a/aclpc/acl-medium.lisp b/aclpc/acl-medium.lisp index 449b3c5eb5ab7dede826c7969ff78830571771c2..f2b6ddf0f67ef49637d031799e0bc9d2ab1b7fed 100644 --- a/aclpc/acl-medium.lisp +++ b/aclpc/acl-medium.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-medium.lisp,v 1.8 1998/08/06 23:15:44 layer Exp $ +;; $Id: acl-medium.lisp,v 1.9 1998/10/08 18:36:21 layer Exp $ #|**************************************************************************** * * @@ -135,9 +135,9 @@ (defmethod dc-image-for-ink ((medium acl-medium) (ink (eql +background-ink+))) (dc-image-for-ink medium (medium-background medium))) -;; changing the conversion as follows makes CLIM gray colors 1/4, 1/2 -;; and 3/4 gray colors map to the corresponding windows solid system -;; colors avoiding need for windows to stipple. (cim 10/11/96) +(defmethod dc-image-for-ink ((medium acl-medium) (ink t)) + ;; Don't blow out if somebody tries to use a fancy ink like compose-in. + (dc-image-for-ink medium (medium-foreground medium))) (defun color->wincolor (ink &optional medium) (declare (optimize (speed 3) (safety 0))) @@ -150,24 +150,29 @@ )) (flet ((convert (x) (declare (short-float x)) - (setq x (float x)) ; needed? - (if (< x 1.0) - (values (the fixnum (floor (the short-float (* x #x100))))) - #xff))) + ;; the most common cases should be fast + (let ((v 255.0)) + (declare (short-float v)) + (cond ((= x 0.0) 0) + ((= x 1.0) #xff) + (t + (setq v (the short-float (* x v))) + (values (the fixnum (round v)))))))) (multiple-value-bind (red green blue) (color-rgb ink) - (let ((color (dpb (convert blue) (byte 8 16) - (dpb (convert green) (byte 8 8) - (convert red))))) + (let ((color (dpb (convert (float blue)) (byte 8 16) + (dpb (convert (float green)) (byte 8 8) + (convert (float red)))))) color)))) (defun wincolor->color (color) (if (= color -1) +transparent-ink+ (flet ((convert (x) - (if (eql x #xff) - 1.0 - (float (/ x 256))))) + ;; the most common cases should be fast + (cond ((= x 0) 0.0) + ((= x #xff) 1.0) + (t (/ x 255.0))))) (let ((red (ldb (byte 8 0) color)) (green (ldb (byte 8 8) color)) (blue (ldb (byte 8 16) color))) @@ -216,8 +221,16 @@ (defvar *the-dc* nil) ; new just for now, later ; rationalize passing dc +(defun get-bitmapinfo (medium dc-image pixel-map colors) + (or (dc-image-bitmapinfo dc-image) + (setf (dc-image-bitmapinfo dc-image) + (let* ((width (array-dimension pixel-map 1)) + (height (array-dimension pixel-map 0))) + (acl-bitmapinfo colors width height medium))))) + ;;; just for now, later rationalize passing dc -(defun dc-image-for-multi-color-pattern (medium array designs) +(defun dc-image-for-multi-color-pattern (medium ink array designs) + (declare (ignore ink)) (let* ((dc-image (copy-dc-image (slot-value medium 'foreground-dc-image))) (tink (aref designs 1)) @@ -231,14 +244,19 @@ (dotimes (j width) (setf (aref into i j) (aref array i j)))) (setf *bitmap-array* into) - (let ((bitmap (get-texture *the-dc* into designs medium))) - (setf (dc-image-bitmap dc-image) bitmap - *created-bitmap* bitmap) - (setf (dc-image-background-color dc-image) bcolor) - (setf (dc-image-text-color dc-image) tcolor)) + (with-medium-dc (medium dc) + (let* ((bitmapinfo (get-bitmapinfo medium dc-image into designs)) + (bitmap (get-texture dc into bitmapinfo))) + ;; To Do: replace BITMAP with INTO and just use + ;; device-independent bitmap operations. + (setf (dc-image-bitmap dc-image) bitmap + *created-bitmap* bitmap) + (setf (dc-image-background-color dc-image) bcolor) + (setf (dc-image-text-color dc-image) tcolor))) dc-image)) -(defun dc-image-for-two-color-pattern (medium array designs) +(defun dc-image-for-transparent-pattern (medium ink array designs) + (declare (ignore ink)) (let* ((dc-image (copy-dc-image (slot-value medium 'foreground-dc-image))) (tink (aref designs 1)) @@ -248,15 +266,22 @@ (width (array-dimension array 1)) (height (array-dimension array 0)) (into (make-pixel-map width height 256))) + (when (eq tink +transparent-ink+) + (rotatef tink bink) + (rotatef tcolor bcolor)) (dotimes (i height) (dotimes (j width) (setf (aref into i j) (aref array i j)))) (setf *bitmap-array* into) - (let ((bitmap (get-texture *the-dc* into designs medium))) - (setf (dc-image-bitmap dc-image) bitmap - *created-bitmap* bitmap) - (setf (dc-image-background-color dc-image) bcolor) - (setf (dc-image-text-color dc-image) tcolor)) + (with-medium-dc (medium dc) + (let* ((bitmapinfo (get-bitmapinfo medium dc-image into designs)) + (bitmap (get-texture dc into bitmapinfo))) + ;; To Do: replace BITMAP with INTO and just use + ;; device-independent bitmap operations. + (setf (dc-image-bitmap dc-image) bitmap + *created-bitmap* bitmap) + (setf (dc-image-background-color dc-image) bcolor) + (setf (dc-image-text-color dc-image) tcolor))) dc-image)) (defun byte-align-pixmap (a) @@ -290,38 +315,93 @@ (if (>= col y-dim) 0 (if (zerop (aref a row col)) 0 1))))) b)) +(defun pattern-to-hatchbrush (pattern) + (multiple-value-bind (array designs) (decode-pattern pattern) + (let* ((tcolor (position-if #'(lambda (ink) (not (eq ink +transparent-ink+))) + designs)) + (style nil)) + (unless tcolor (return-from pattern-to-hatchbrush nil)) + (when (and (> (array-dimension array 0) 1) + (> (array-dimension array 1) 1)) + (let ((a11 (= (aref array 0 0) tcolor)) + (a12 (= (aref array 0 1) tcolor)) + (a21 (= (aref array 1 0) tcolor)) + (a22 (= (aref array 1 1) tcolor))) + (setq style + (cond ((and a12 a21 a22) win:HS_CROSS) + ((and a12 a21) win:HS_FDIAGONAL) + ((and a11 a22) win:HS_BDIAGONAL) + ((and a11 a12) win:HS_HORIZONTAL) + ((and a11 a21) win:HS_VERTICAL))))) + (unless style (setq style win:HS_FDIAGONAL)) + (win:createhatchbrush + style + (color->wincolor (elt designs tcolor)))))) + (defmethod dc-image-for-ink ((medium acl-medium) (ink pattern)) - (multiple-value-bind (array designs) (decode-pattern ink) - (cond ((= (length designs) 2) - (setq array (byte-align-pixmap array)) - (dc-image-for-two-color-pattern - medium array designs)) - ((find +transparent-ink+ designs) - (error - "Multicolor patterns must not use +transparent-ink+")) - (t - (setq array (byte-align-pixmap array)) - (dc-image-for-multi-color-pattern - medium array designs))))) + ;; The "pattern" part of the ink is put into the brush. + ;; There seems to be a problem with two-color stipples. + (let ((cache (port-dc-cache (port medium)))) + (or (gethash ink cache) + (setf (gethash ink cache) + (multiple-value-bind (array designs) (decode-pattern ink) + (cond ((find +transparent-ink+ designs) + ;; This is a terrible hack. + ;; It avoids blowing out, and gives you a transparent stipple, + ;; but it doesn't use the one you request. + (setq array (byte-align-pixmap array)) + (let ((dc-image (dc-image-for-transparent-pattern + medium ink array designs))) + (setf (dc-image-brush dc-image) + (pattern-to-hatchbrush ink)) + dc-image)) + (t + (setq array (byte-align-pixmap array)) + (let ((dc-image (dc-image-for-multi-color-pattern + medium ink array designs))) + ;; win95: creating brushes from patterns larger than + ;; 8x8 is not supported. + (setf (dc-image-brush dc-image) + (win:createPatternBrush (dc-image-bitmap dc-image))) + dc-image)))))))) + +#| +does anyone know how to make the bitmaps have transparent +backgrounds or how to show gif files? i need to make pictures so that +whats under it will show, but need code in vb3!!! thanks + +Joe, + +You can do this by creating two pictures, +one with white in the transparent area (The Picture) +and the other with black in the transparent area. (The Mask) + +Then use the bitblt API to blit the picture with +the SRCAND (&h8800c6) flag. +Then blit the mask in the same location with +the SRCOR (&hee0086) flag. + +This will give you the transparent effect. + +This works because ANDing any value with 1 and XORing it with 0 +leaves the original value unchanged. To draw a masked image +on-screen, Windows first logically ANDs the values in the AND mask +with the pixel values in the destination DC. This creates a "hole" for +the image composed of pixels with color values of 0. Then Windows +XORs the values in the XOR mask to the destination DC, filling in the +hole left by the AND mask and setting all the 0 pixels to the image +colors. This is standard stuff described in any entry-level graphics +programming course. It's also the technique that Windows uses to +draw icons and mouse cursors on the screen. +|# (defmethod dc-image-for-ink ((medium acl-medium) (ink rectangular-tile)) ;; The only case we handle right now is stipples - (let ((pattern (decode-rectangular-tile ink))) - (multiple-value-bind (array designs) - (decode-pattern pattern) - (unless array - (error - "Rectangular tiles other than stipples are not supported yet.")) - (unless (= (length designs) 2) - (error "Only 2-color stipples are currently supported.")) - (setq array (byte-align-pixmap array)) - #+old - (dc-image-for-ink medium (aref designs 1)) - (let ((dc-image - (dc-image-for-two-color-pattern medium array designs))) - (setf (dc-image-brush dc-image) - (win:createPatternBrush (dc-image-bitmap dc-image))) - dc-image)))) + (let ((cache (port-dc-cache (port medium)))) + (or (gethash ink cache) + (setf (gethash ink cache) + ;; The brush of PATTERN is used as the tile. + (dc-image-for-ink medium (decode-rectangular-tile ink)))))) (defun nyi () (error "This NT CLIM operation is NYI (Not Yet Implemented).")) @@ -457,21 +537,29 @@ left top right bottom) (when (< right left) (rotatef right left)) (when (< bottom top) (rotatef bottom top)) - (cond ((typep ink 'pattern) - ;; DRAW-PATTERN* ultimately does its drawing here. - ;; BUG: Transparent bits aren't transparent. - (with-compatible-dc (dc cdc) - (let ((width (- right left)) - (height (- bottom top)) - (*the-dc* dc)) - (set-cdc-for-pattern cdc medium ink nil) - (win:bitblt dc left top width height - cdc 0 0 win:srccopy)))) + (cond ((typep ink 'pattern) + ;; DRAW-PATTERN* ends up here. In principle + ;; we could skip this case and rely on the "brush" + ;; to correctly paint the rectangle. In practice, + ;; this case is needed to correctly render patterns + ;; larger than 8x8, due to limitations of CreatePatternBrush. + (let ((cdc nil) + (dc-image (dc-image-for-ink medium ink))) + ;; Create compatable memory dc + (setq cdc (win:createcompatibledc dc)) + ;; select a (Device-Dependent) bitmap into the dc + (win:selectobject cdc (dc-image-bitmap dc-image)) + ;; Copy bitmap from memory dc to screen dc + (win:bitblt dc left top (- right left) (- bottom top) + cdc 0 0 win:srccopy) + ;; Delete memory dc + (win:deletedc cdc)) + t) (t - ;; dc=0 for acl-pixmap-medium...FIXME. (let ((*the-dc* dc)) (set-dc-for-ink dc medium ink - (if filled nil line-style))) + (if filled nil line-style) + left top)) (if filled (win:rectangle dc left top (1+ right) (1+ bottom)) (win:rectangle dc left top right bottom)))) @@ -518,8 +606,7 @@ (length (length position-seq)) (numpoints (floor length 2)) (extra (and closed line-style)) - #-acl86win32 (point-vector (ct:ccallocate (win:point 256))) - #+acl86win32 (point-vector (ct:callocate (:long *) :size 512))) ; limit? + (point-vector (ct:callocate (:long *) :size 512))) ; limit? ;; These really are fixnums, since we're fixing coordinates below ;; (declare (type fixnum minx miny)) (with-stack-array (points (if extra (+ length 2) length)) @@ -537,17 +624,7 @@ (ct:cset (:long 512) point-vector ((fixnum (* numpoints 2))) x) (ct:cset (:long 512) point-vector ((fixnum (+ 1 (* numpoints 2)))) y) )))) - (if (or (typep ink 'pattern) (typep ink 'rectangular-tile)) - (if (null line-style) - (let ((*the-dc* dc) - (nink ink - #+ignore - (if (typep ink 'pattern) - (make-rectangular-tile ink 8 8) - ink))) - (set-dc-for-ink dc medium nink line-style)) - (set-dc-for-ink dc medium +foreground-ink+ line-style)) - (set-dc-for-ink dc medium ink line-style)) + (set-dc-for-ink dc medium ink line-style) (if (null line-style) (win:polygon dc point-vector numpoints) (win:polyline dc @@ -579,17 +656,7 @@ (when (null start-angle) (setq start-angle 0.0 end-angle 2pi)) - (if (or (typep ink 'pattern) (typep ink 'rectangular-tile)) - (if (null line-style) - (let ((*the-dc* dc) - (nink ink - #+ignore - (if (typep ink 'pattern) - (make-rectangular-tile ink 8 8) - ink))) - (set-dc-for-ink dc medium nink line-style)) - (set-dc-for-ink dc medium +foreground-ink+ line-style)) - (set-dc-for-ink dc medium ink line-style)) + (set-dc-for-ink dc medium ink line-style) (multiple-value-bind (x-radius y-radius) (cond ((and (= radius-1-dx 0) (= radius-2-dy 0)) (values (abs radius-2-dx) (abs radius-1-dy))) @@ -791,7 +858,8 @@ ;;; reading patterns from bitmap files (defun read-bitmap-file (path &key (format :bitmap) (port (find-port))) - (declare (ignore format port)) + (declare (ignore port)) + (assert (member format '(:ico :bmp :cur))); give caller reasonable error msg (load-pixmap-1 path 0)) (defun load-pixmap-1 (filename index) @@ -864,25 +932,25 @@ char2 (code-char (read-byte stream))) (cond ((and (eql char1 #\B) (eql char2 #\M)) - (setq file-type :pixmap)) + (setq file-type :bmp)) ((and (zerop (char-int char1)) (zerop (char-int char2))) (setq word2 (bm-read-word stream)) (cond ((eql word2 1) - (setq file-type :icon)) + (setq file-type :ico)) ((eql word2 2) - (setq file-type :cursor))))) + (setq file-type :cur))))) (unless file-type (error "Object being read is neither a ~ device-independent bitmap, an icon, nor a cursor.")) (case file-type - (:pixmap + (:bmp (setq file-size (bm-read-long stream)) (bm-read-word stream) ; reserved1 = 0 (bm-read-word stream) ; reserved2 = 0 (setq image-offset (bm-read-long stream)) ) - ((:icon :cursor) + ((:ico :cur) (setq number-of-resources (bm-read-word stream)) (setq bytes-into-file 6) ;; skip the directory entries up to the requested one. @@ -912,7 +980,7 @@ device-independent bitmap, an icon, nor a cursor.")) (setq width (bm-read-long stream) height (bm-read-long stream)) ;; for icons & cursors height is pixmap height + mask height - (unless (eq file-type :pixmap) + (unless (eq file-type :bmp) (setq height (floor height 2))) (bm-read-word stream) ;; bit-planes = 1 (setq bits-per-pixel (bm-read-word stream)) @@ -1013,10 +1081,10 @@ device-independent bitmap, an icon, nor a cursor.")) hotspot-x hotspot-y image-size file-size number-of-resources x-pixels-per-meter y-pixels-per-meter (case file-type - (:pixmap + (:bmp (values pixmap texture-info nil width )) - ((:icon :cursor) + ((:ico :cur) (setq file-width (* 4 (ceiling width 32))) ;; <15> (setq mask (make-pixel-map (* 8 file-width) ;; <15> @@ -1045,10 +1113,12 @@ device-independent bitmap, an icon, nor a cursor.")) (defun make-pattern-from-bitmap-file (path &key designs (format :bitmap) (port (find-port))) + ;; give reasonable error msg: + (assert (member format '(:xbm :xpm :ico :bmp :cur))) (if (member format '(:xbm :xpm)) - (multiple-value-bind (array designs) + (multiple-value-bind (array designs-from-file) (read-xbitmap-file path :format format :port port) - (make-pattern array designs)) + (make-pattern array (or designs designs-from-file))) (multiple-value-bind (array texture-info) (read-bitmap-file path :format format :port port) (setq array (rotate-and-mirror-bitmap array)) @@ -1130,7 +1200,8 @@ device-independent bitmap, an icon, nor a cursor.")) line)))) (defun read-x11-bitmap-file (fstream) - (multiple-value-bind (width height depth left-pad format chars-per-pixel line) + (multiple-value-bind (width height depth left-pad format + chars-per-pixel line) (get-bitmap-file-properties fstream) (declare (ignore format chars-per-pixel line left-pad)) (unless (and width height) (error "Not a BITMAP file")) @@ -1239,6 +1310,7 @@ device-independent bitmap, an icon, nor a cursor.")) (defun read-xbitmap-file (pathname &key (format :xbm) (port (find-port))) (declare (type (or pathname string stream) pathname)) + (assert (member format '(:xbm :xpm))) ; give caller reasonable error msg (let ((palette (and port (port-default-palette port)))) (read-image-file format pathname palette))) @@ -1260,11 +1332,8 @@ device-independent bitmap, an icon, nor a cursor.")) (read-bitmap-file path) (create-icon array texture mask-array)))) -(defun icon-width () - (win:GetSystemMetrics win:SM_CXICON)) - -(defun icon-height () - (win:GetSystemMetrics win:SM_CYICON)) +(defun icon-width () (win:GetSystemMetrics win:SM_CXICON)) +(defun icon-height () (win:GetSystemMetrics win:SM_CYICON)) (defun create-icon (pixmap texture-info mask-bitmap) ;; <7> (win:CreateIcon *hinst* @@ -1274,34 +1343,18 @@ device-independent bitmap, an icon, nor a cursor.")) (texture-info-bits-per-pixel texture-info) mask-bitmap pixmap)) - - -(in-package :clim-utils) - -(setf (gethash "white" clim-utils::*default-named-color-table*) - clim:+white+) - -(setf (gethash "black" clim-utils::*default-named-color-table*) - clim:+black+) - -(setf (gethash "red" clim-utils::*default-named-color-table*) - clim:+red+) - -(setf (gethash "green" clim-utils::*default-named-color-table*) - clim:+green+) - -(setf (gethash "blue" clim-utils::*default-named-color-table*) - clim:+blue+) - -(setf (gethash "cyan" clim-utils::*default-named-color-table*) - clim:+cyan+) - -(setf (gethash "yellow" clim-utils::*default-named-color-table*) - clim:+yellow+) - -(setf (gethash "magenta" clim-utils::*default-named-color-table*) - clim:+magenta+) - - - +(defun initialize-named-colors () + (let ((table clim-utils::*default-named-color-table*)) + (setf (gethash "white" table) +white+) + (setf (gethash "black" table) +black+) + (setf (gethash "red" table) +red+) + (setf (gethash "green" table) +green+) + (setf (gethash "blue" table) +blue+) + (setf (gethash "cyan" table) +cyan+) + (setf (gethash "yellow" table) +yellow+) + (setf (gethash "magenta" table) +magenta+) + table)) + +(eval-when (load eval) + (initialize-named-colors)) diff --git a/aclpc/acl-mirror.lisp b/aclpc/acl-mirror.lisp index 7670d29b9f1e2a561cb68895a58f0112b7eab260..43864fee6660fdf3db48d98f6da0341f2a365c79 100644 --- a/aclpc/acl-mirror.lisp +++ b/aclpc/acl-mirror.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-mirror.lisp,v 1.6 1998/08/06 23:15:44 layer Exp $ +;; $Id: acl-mirror.lisp,v 1.7 1998/10/08 18:36:21 layer Exp $ #|**************************************************************************** * * @@ -158,14 +158,10 @@ ;;mm: allocate gadget-id per parent (setq gadget-id (silica::allocate-gadget-id sheet)) (setq value (slot-value sheet 'silica::value)) - (let ((client (gadget-client sheet))) - (setf buttonstyle - (cond - ((typep client 'silica::radio-box-pane) - win:BS_RADIOBUTTON) - ((typep client 'silica::check-box-pane) - win:BS_CHECKBOX) - (t win:BS_CHECKBOX)))))) + (setq buttonstyle + (ecase (gadget-indicator-type sheet) + (:one-of win:BS_RADIOBUTTON) + (:some-of win:BS_CHECKBOX))))) (when (or (eq control :hbutt) (eq control :hedit)) (multiple-value-bind (cwidth cheight) (compute-gadget-label-size sheet) diff --git a/aclpc/acl-port.lisp b/aclpc/acl-port.lisp index 5c4a63df85824002a84fcd5f1116348dda6a220c..ee3198247f3421fcf87c011abd0e75068b68674a 100644 --- a/aclpc/acl-port.lisp +++ b/aclpc/acl-port.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-port.lisp,v 1.7 1998/08/06 23:15:45 layer Exp $ +;; $Id: acl-port.lisp,v 1.8 1998/10/08 18:36:21 layer Exp $ #|**************************************************************************** * * @@ -298,7 +298,8 @@ (:small 8) (:normal 10) (:large 12) - (:very-large 18))) + (:very-large 18) + (:huge 24))) ;;--- hacked to allow text-styles to be specified as lists ;;--- there's probably a more efficient way... @@ -329,6 +330,7 @@ (multiple-value-bind (family face-name) (case (text-style-family style) (:fix (values (logior win:FIXED_PITCH win:FF_MODERN) + #+ignore "courier")) (:serif (values (logior win:VARIABLE_PITCH win:FF_ROMAN) "times new roman")) @@ -337,13 +339,17 @@ ;;--- some of these specify ugly ugly linedrawn fonts (otherwise (values (logior win:DEFAULT_PITCH win:FF_DONTCARE) (string (text-style-family style))))) - (let ((point-size - (let ((size (text-style-size style))) - (typecase size - (number size) - (otherwise - (or (second (assoc size *acl-logical-size-alist*)) - 12)))))) + (let ((size (text-style-size style)) + (point-size nil)) + (when (numberp size) + (setq point-size size)) + (unless point-size + (setq point-size + (second (assoc size *acl-logical-size-alist*)))) + (unless point-size + (format *trace-output* + "~& Warning: ~S is not a known size, using 12" size) + (setq point-size 12)) (make-windows-font (- (round (* point-size (slot-value port 'logpixelsy)) 72)) :weight weight @@ -362,14 +368,6 @@ (with-slots (text-style->acl-font-mapping) device (or (gethash style text-style->acl-font-mapping) (setf (gethash style text-style->acl-font-mapping) - #+old - (let ((args (silica::device-font-name style))) - (apply #'make-windows-font - (- (round (* (pop args) - (slot-value device 'logpixelsy)) - 72)) - args)) - #-old (let ((name (silica::device-font-name style))) (make-device-font (win:getstockobject name))))))) @@ -390,37 +388,45 @@ (defun make-system-font () (make-device-font (win:getstockobject win:system_font))) +;; This should be in the WIN package but isn't. +;; We use it to specify how Windows matches font requests to a +;; font currently installed on the user's system. CLIM uses a +;; TrueType font when the user's system contains multiple fonts of +;; the same name. With OUT_DEFAULT_PRECIS, :FIX fonts +;; were not always mapping to required sizes. JPM 8/98. +(defconstant OUT_TT_PRECIS 4) + (defun make-windows-font (height &key (width 0) (escapement 0) (orientation 0) (weight win:FW_NORMAL) (italic nil) (underline nil) (strikeout nil) (charset win:ANSI_CHARSET) - (output-precision WIN:OUT_DEFAULT_PRECIS) + (output-precision OUT_TT_PRECIS) (clip-precision WIN:CLIP_DEFAULT_PRECIS) (quality win:PROOF_QUALITY) (pitch-and-family (logior win:DEFAULT_PITCH win:FF_DONTCARE)) (face nil) win-font) - (let ((win-font - (or win-font - (win:createFont height ; logical height - width ; logical average width - escapement ; angle of escapement (tenths of degrees) - orientation; normally the same as escapement - weight ; font weight (FW_NORMAL=400, FW_BOLD=700) - (if italic 1 0) - (if underline 1 0) - (if strikeout 1 0) - charset ; if you want chinese or greek - output-precision - clip-precision - quality - pitch-and-family - (or face "") - )))) - (when (zerop win-font) - (check-last-error "CreateFont")) - (make-device-font win-font))) + (unless win-font + (setq win-font + (win:createFont height ; logical height + width ; logical average width + escapement ; angle of escapement (tenths of degrees) + orientation ; normally the same as escapement + weight ; font weight (FW_NORMAL=400, FW_BOLD=700) + (if italic 1 0) + (if underline 1 0) + (if strikeout 1 0) + charset ; if you want chinese or greek + output-precision + clip-precision + quality + pitch-and-family + (or face "") + ))) + (when (zerop win-font) + (check-last-error "CreateFont")) + (make-device-font win-font)) (defun make-device-font (win-font) (let ((cw (and *application-frame* @@ -445,6 +451,7 @@ (unless (win:iswindow cw) (error "No window found for calculating text font metrics.")) (with-dc (cw dc) + (win:setmapmode dc win:MM_TEXT) (selectobject dc win-font) (or (win:getTextMetrics dc tmstruct) (check-last-error "GetTextMetrics")) @@ -608,7 +615,6 @@ native-x native-y) (values x y native-x native-y root-x root-y))))) - (defun char->keysym (char) (let ((entry (assoc char *keysym-alist*)) (keysym nil)) @@ -693,14 +699,18 @@ motion-pending nil)))) ;;; Convert a MS Windows shift mask into a CLIM modifier-state -(defun windows-mask->modifier-state (mask) - (if (logtest win:mk_shift mask) - (if (logtest win:mk_control mask) - (make-modifier-state :shift :control) - (make-modifier-state :shift)) - (if (logtest win:mk_control mask) - (make-modifier-state :control) - (make-modifier-state)))) +(defun windows-mask->modifier-state (mask &optional double) + (let ((state + (if (logtest win:mk_shift mask) + (if (logtest win:mk_control mask) + #.(make-modifier-state :shift :control) + #.(make-modifier-state :shift)) + (if (logtest win:mk_control mask) + #.(make-modifier-state :control) + #.(make-modifier-state))))) + (if double + (logior state #.(make-modifier-state :double)) + state))) (defmethod event-handler ((port acl-port) args) (declare (ignore args)) @@ -732,6 +742,26 @@ (defvar *clim-pulse-rate* 1.0) ; seconds. +;; Redefine function from utils/processes.lisp. +(defun clim-utils::process-wait (state function &rest args) + (declare (dynamic-extent function args)) + #+someday + (apply #'mp:process-wait state function args) + (let ((result nil)) + (loop + ;; 5/28/98 JPM ACL 5.0.beta + ;; There seems to be a bug in process-wait (on NT) that + ;; it does not run the test function often enough. + ;; Lisp will appear to hang until it receives some Windows + ;; events, which apparently wake up the scheduler. + ;; The workaround is to wake up every so often and + ;; run the test function. + (when (setq result (apply #'mp:process-wait-with-timeout + state *clim-pulse-rate* + function args)) + (return result))))) + + (defmethod process-next-event ((port acl-port) &key (timeout nil) (wait-function nil) @@ -754,17 +784,7 @@ (if timeout (mp:process-wait-with-timeout state timeout #'wait-for-event) - (loop - ;; 5/28/98 JPM ACL 5.0.beta - ;; There seems to be a bug in process-wait that - ;; it does not run the test function often enough. - ;; The workaround is to wake up every so often and - ;; run the test function. - (when (mp:process-wait-with-timeout - state *clim-pulse-rate* #'wait-for-event) - (return))) - #+someday - (mp:process-wait state #'wait-for-event)))) + (process-wait state #'wait-for-event)))) (cond (event (distribute-event port event) t) diff --git a/aclpc/acl-prel.lisp b/aclpc/acl-prel.lisp index 0584cba61287d1c115f9d20efbdf0593a66d962c..e585a63b2c73981db5a9875ba40864956c768f65 100644 --- a/aclpc/acl-prel.lisp +++ b/aclpc/acl-prel.lisp @@ -15,7 +15,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 1.6 1998/08/06 23:15:45 layer Exp $ +;; $Id: acl-prel.lisp,v 1.7 1998/10/08 18:36:21 layer Exp $ #|**************************************************************************** * * @@ -233,6 +233,7 @@ "BUTTON" ; classname (nstringify nlabel) ; windowname (logior buttonstyle + win:WS_TABSTOP win:WS_CHILD win:WS_CLIPCHILDREN win:WS_CLIPSIBLINGS) ; style @@ -363,23 +364,25 @@ ;; return values (values bmi win:DIB_RGB_COLORS))) -(defmethod get-texture (device-context pixel-map colors medium) - (let* ((width (array-dimension pixel-map 1)) - (height (array-dimension pixel-map 0)) - texture-handle) - (multiple-value-bind (bitmapinfo dib-mode) - (acl-bitmapinfo colors width height medium) - (setq texture-handle - (win:CreateDIBitmap - device-context - bitmapinfo - win:CBM_INIT ; initialize bitmap bits - pixel-map - bitmapinfo - dib-mode)) - (when (zerop texture-handle) - (check-last-error "CreateDIBitmap")) - texture-handle))) +(defmethod get-texture (device-context pixel-map bitmapinfo) + ;; The value of this function becomes the dc-image-bitmap. + ;; It gets applied to the device context using SELECT-OBJECT. + (unless (and device-context (not (zerop device-context))) + (error "Device context not valid")) + (let* (texture-handle) + ;; Create nondiscardable Device Dependent Bitmap. + ;; The Windows docs suggest we should be using device independent bitmaps. + (setq texture-handle + (win:CreateDIBitmap + device-context + bitmapinfo + win:CBM_INIT ; initialize bitmap bits + pixel-map + bitmapinfo + win:DIB_RGB_COLORS)) + (when (zerop texture-handle) + (check-last-error "CreateDIBitmap")) + texture-handle)) ;;; about box support diff --git a/aclpc/acl-scroll.lisp b/aclpc/acl-scroll.lisp index 8b7bdc593f2a49251b70b46114e1330c022a153b..a10bf1615309759e0e0a9fa77c8345b0cade23d6 100644 --- a/aclpc/acl-scroll.lisp +++ b/aclpc/acl-scroll.lisp @@ -1,4 +1,4 @@ -;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: ACL-CLIM; Base: 10; Lowercase: Yes -*- +;;; -*- Mode: Lisp; Package: silica -*- ;; copyright (c) 1985,1986 Franz Inc, Alameda, Ca. ;; copyright (c) 1986-1998 Franz Inc, Berkeley, CA - All rights reserved. ;; @@ -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-scroll.lisp,v 1.6 1998/08/06 23:15:45 layer Exp $ +;; $Id: acl-scroll.lisp,v 1.7 1998/10/08 18:36:21 layer Exp $ #|**************************************************************************** * * @@ -45,24 +45,24 @@ (event silica::scrollbar-event)) (with-slots (silica::orientation silica::action silica::amount) event (assert (eql silica::orientation (gadget-orientation pane))) - (multiple-value-bind (min max) (gadget-range* pane) - (let ((new - (max min - (min (- max (scroll-bar-size pane)) - (case silica::action - (:relative-jump ; press arrows - (+ (gadget-value pane) - (* (scroll-bar-size pane) silica::amount))) - (:screenful ; click near thumb - (+ (gadget-value pane) - (* (scroll-bar-size pane) silica::amount))) - (:percentage ; drag thumb - (+ min - (* (- max min (scroll-bar-size pane)) - (/ silica::amount - (float acl-clim::*win-scroll-grain*)))))))))) - #+ignore - (setf (gadget-value pane) new) + (multiple-value-bind (min) (gadget-range* pane) + ;; SCROLL-BAR-SIZE is less than or equal to the range. + (let* ((new (case silica::action + (:relative-jump ; press arrows + ;; AMOUNT is plus or minus one + (+ (gadget-value pane) + (* (scroll-bar-size pane) silica::amount))) + (:screenful ; click near thumb + ;; AMOUNT is plus or minus one + (+ (gadget-value pane) + (* (scroll-bar-size pane) silica::amount))) + (:percentage ; drag thumb + ;; AMOUNT is absolute position in the scroll range + ;; (from 0 to *win-scroll-grain*). + (+ min + (* (gadget-range pane) + (/ silica::amount + (float acl-clim::*win-scroll-grain*)))))))) (value-changed-callback pane (gadget-client pane) (gadget-id pane) new) )))) @@ -119,19 +119,19 @@ (defmethod gadget-supplies-scrolling-p ((sheet acl-clim::acl-text-editor-pane)) t) (defmethod handle-event ((pane mswin-scroller-pane) - (event scrollbar-event)) + (event scrollbar-event)) (with-slots (orientation action amount) event - (case action - (:relative-jump - (case amount - (-1 (scroll-up-line pane orientation)) - (1 (scroll-down-line pane orientation)))) - (:screenful - (case amount - (-1 (scroll-up-page pane orientation)) - (1 (scroll-down-page pane orientation)))) - (:percentage - (scroll-to-position pane orientation amount))))) + (case action + (:relative-jump + (case amount + (-1 (scroll-up-line pane orientation)) + (1 (scroll-down-line pane orientation)))) + (:screenful + (case amount + (-1 (scroll-up-page pane orientation)) + (1 (scroll-down-page pane orientation)))) + (:percentage + (scroll-to-position pane orientation amount))))) (defmethod scroll-bar-value-changed-callback (sheet (client scroller-pane) id value size) @@ -196,8 +196,10 @@ (gmax (float (gadget-max-value scroll-bar) 0s0)) (range (- gmax gmin))) (declare (type single-float range gmin gmax)) - (when (and (and current-size (= (the single-float current-size) range)) - (= min vmin) (> (- vmax vmin) (- max min))) + (when (and current-size + (= (the single-float current-size) range) + (= min vmin) + (> (- vmax vmin) (- max min))) (return-from update-scroll-bar)) ;; The elevator size in 01 units - calculated from the contents (let* ((contents-range (float (- max min) 0.0s0)) @@ -217,33 +219,34 @@ corrected-contents-range)))))))) ;;-- This does not scale by the range (pos (the single-float - (min 1.0s0 (max 0.0s0 - (if (<= corrected-contents-range viewport-range) - 0.0 - (/ (float (- vmin min) 0.0s0) - ;;--- Uh-oh, the home-grown scroll bars - ;;--- seem to have a different contract - ;;--- from Motif/OpenLook. Fix them! - #-(or aclpc acl86win32) - (- contents-range viewport-range) - #+(or aclpc acl86win32) - corrected-contents-range))))))) + (min 1.0s0 + (max 0.0s0 + (if (<= corrected-contents-range viewport-range) + 0.0 + (/ (float (- vmin min) 0.0s0) + ;;--- Uh-oh, the home-grown scroll bars + ;;--- seem to have a different contract + ;;--- from Motif/OpenLook. Fix them! + corrected-contents-range))))))) (declare (type single-float pos size)) (unless (and current-size current-value (= current-size size) (= current-value pos)) - (let ((scrollinfo-struct (ct:ccallocate win::scrollinfo)) - (win-id (if (eq orientation :vertical) win:SB_VERT win:SB_HORZ)) - (win-pos (floor (* pos acl-clim::*win-scroll-grain*))) - (win-size (floor (* size (1+ acl-clim::*win-scroll-grain*))))) - (ct:csets win::scrollinfo scrollinfo-struct - win::cbSize (ct:sizeof win::scrollinfo) - win::fMask #.(logior win::SIF_PAGE win::SIF_POS - win::SIF_DISABLENOSCROLL) - win::nPage win-size - win::nPos win-pos) - (win::SetScrollInfo (sheet-mirror scroll-bar) win-id scrollinfo-struct t)) + (let ((mirror (sheet-mirror scroll-bar)) + (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*)))) + (ct:csets win:scrollinfo struct + cbSize (ct:sizeof win:scrollinfo) + fMask win:SIF_ALL + nmin 0 + nMax acl-clim::*win-scroll-grain* + nPage page + nPos position) + (win:SetScrollInfo mirror bar struct 1)) (case orientation (:vertical (setf (scroller-current-vertical-size scroll-bar) size) @@ -251,9 +254,6 @@ (:horizontal (setf (scroller-current-horizontal-size scroll-bar) size) (setf (scroller-current-horizontal-value scroll-bar) pos))) - ;;-- It would be nice if we could do this at the point of scrolling - #+foo (cerror "foo" "pos=~a size=~a min=~a max=~a vmin=~a vmax=~a contents-range=~a" - pos size min max vmin vmax contents-range) ))))) @@ -281,7 +281,7 @@ (flag (case orientation (:vertical win:sb_vert) (:horizontal win:sb_horz))) - (current-value (/ (win::getScrollPos window flag) + (current-value (/ (win:getScrollPos window flag) (float acl-clim::*win-scroll-grain*))) (current-size (case orientation (:horizontal current-horizontal-size) @@ -293,7 +293,6 @@ (/ (line-scroll-amount scroller-pane orientation :up) (float contents-range 0.0s0))))) (new-value (max 0.0 (- current-value line-value)))) - #+ignore (win::setScrollPos window flag (floor (* new-value *win-scroll-grain*)) 1) (scroll-bar-value-changed-callback scroller-pane scroller-pane orientation new-value current-size)))) @@ -309,7 +308,7 @@ (:vertical win:sb_vert) (:horizontal win:sb_horz))) (window (sheet-mirror scroller-pane)) - (current-value (/ (win::getScrollPos window flag) + (current-value (/ (win:getScrollPos window flag) (float acl-clim::*win-scroll-grain*))) (current-size (case orientation (:horizontal current-horizontal-size) @@ -325,35 +324,34 @@ acl-clim::*win-scroll-grain*) ;; max pos current-size) (+ current-value line-value)))) - #+ignore (win::setScrollPos window flag (floor (* 100 new-value)) 1) (scroll-bar-value-changed-callback scroller-pane scroller-pane orientation new-value current-size) ))) (defmethod scroll-up-page ((scroller-pane mswin-scroller-pane) orientation) (with-slots (current-vertical-size current-vertical-value - current-horizontal-size current-horizontal-value - viewport contents) scroller-pane - (let* ((flag (case orientation - (:vertical win:sb_vert) - (:horizontal win:sb_horz))) - (window (sheet-mirror scroller-pane)) - (current-value (/ (win::getScrollPos window flag) - (float acl-clim::*win-scroll-grain*))) - (current-size (case orientation - (:horizontal current-horizontal-size) - (:vertical current-vertical-size))) - (contents-range (contents-range scroller-pane orientation)) - (viewport-range (bounding-rectangle-max-y viewport)) - new-value) - (if (zerop contents-range) - (setq new-value current-value) - (let ((page-value (the single-float - (/ viewport-range (float contents-range 0.0s0))))) - (setq new-value (max 0.0 (- current-value page-value))))) - #+ignore (win::setScrollPos window flag (floor (* 100 new-value)) 1) - (scroll-bar-value-changed-callback - scroller-pane scroller-pane orientation new-value current-size)))) + current-horizontal-size current-horizontal-value + viewport contents) scroller-pane + (let* ((flag (case orientation + (:vertical win:sb_vert) + (:horizontal win:sb_horz))) + (window (sheet-mirror scroller-pane)) + (current-value (/ (win:getScrollPos window flag) + (float acl-clim::*win-scroll-grain*))) + (current-size (case orientation + (:horizontal current-horizontal-size) + (:vertical current-vertical-size))) + (contents-range (contents-range scroller-pane orientation)) + (viewport-range (bounding-rectangle-max-y viewport)) + new-value) + (if (zerop contents-range) + (setq new-value current-value) + (let ((page-value + (the single-float + (/ viewport-range (float contents-range 0.0s0))))) + (setq new-value (max 0.0 (- current-value page-value))))) + (scroll-bar-value-changed-callback + scroller-pane scroller-pane orientation new-value current-size)))) (defmethod scroll-down-page ((scroller-pane mswin-scroller-pane) orientation) (with-slots (current-vertical-size current-vertical-value @@ -363,7 +361,7 @@ (:vertical win:sb_vert) (:horizontal win:sb_horz))) (window (sheet-mirror scroller-pane)) - (current-value (/ (win::getScrollPos window flag) + (current-value (/ (win:getScrollPos window flag) (float acl-clim::*win-scroll-grain*))) (current-size (case orientation (:horizontal current-horizontal-size) @@ -379,7 +377,6 @@ acl-clim::*win-scroll-grain*) current-size) (+ current-value page-value))))) - #+ignore (win::setScrollPos window flag (floor (* 100 new-value)) 1) (scroll-bar-value-changed-callback scroller-pane scroller-pane orientation new-value current-size)))) @@ -388,19 +385,9 @@ (with-slots (current-vertical-size current-vertical-value current-horizontal-size current-horizontal-value viewport contents) scroller-pane - (let* (#+ignore - (flag (case orientation - (:vertical win:sb_vert) - (:horizontal win:sb_horz))) - #+ignore - (current-value (case orientation - (:horizontal current-horizontal-value) - (:vertical current-vertical-value))) - (current-size (case orientation + (let* ((current-size (case orientation (:horizontal current-horizontal-size) (:vertical current-vertical-size))) - ;;(contents-range (contents-range scroller-pane orientation)) - ;;(viewport-range (bounding-rectangle-max-y viewport)) (new-value (/ pos (float acl-clim::*win-scroll-grain*)))) (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 c9ae0754a738bd5c87b4f16087e2f67dae502f14..b896e3f50d7aa9703a87e48cd9fa7906a660b708 100644 --- a/aclpc/acl-widget.lisp +++ b/aclpc/acl-widget.lisp @@ -1,4 +1,4 @@ -;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: ACL-CLIM; Base: 10; Lowercase: Yes -*- +;;; -*- Mode: Lisp; Package: silica; -*- ;; copyright (c) 1985,1986 Franz Inc, Alameda, Ca. ;; copyright (c) 1986-1998 Franz Inc, Berkeley, CA - All rights reserved. ;; @@ -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-widget.lisp,v 1.9 1998/08/06 23:15:45 layer Exp $ +;; $Id: acl-widget.lisp,v 1.10 1998/10/08 18:36:21 layer Exp $ #|**************************************************************************** * * @@ -95,7 +95,7 @@ (delete new (gadget-value pane)) (push new (gadget-value pane))))))))))) -(defmethod (setf gadget-value) :after +(defmethod (setf gadget-value) :before (value (pane hlist-pane) &key invoke-callback) (declare (ignore invoke-callback)) (with-slots (mode items value-key test) pane @@ -120,12 +120,7 @@ (when i (win:sendMessage hwnd win:LB_SETCURSEL i 0)))) - - ;; check out compute-list-pane-selected-items - ;; in the unix code to see how to do this - ;; (cim 9/25/96) - #+ignore - (win:sendMessage hwnd win:LB_settopindex value 0))))) + )))) (defmethod handle-event :after ((pane hlist-pane) (event pointer-event)) (deallocate-event event)) @@ -173,6 +168,27 @@ :width (+ name-width 20) :height name-height)))) +;;; When items are set in an hlist-pane the mirror must be +;;; made to update its appearance appropriately. +(defmethod (setf set-gadget-items) :before (items (pane hlist-pane)) + (with-slots (name-key mirror) pane + (when mirror + (win:SendMessage mirror win:LB_RESETCONTENT 0 0) + (dolist (item items) + (let ((str (acl-clim::nstringify (funcall name-key item))) + (pos (position item items))) + ;;(break "insert gadget item [~a @ ~a]" str pos) + (win:SendMessage mirror win:LB_INSERTSTRING pos str))) + (win:InvalidateRect mirror ct:hnull win:true)))) ;; make sure it updates + +(defmethod acl-clim::command-event :around ((gadget silica::hlist-pane) + port sheet wparam lparam) + (let ((notifycode (acl-clim::hiword wparam))) + (when (= notifycode win:lbn_selchange) + ;; Selection in list box is about to change. + (win:setfocus (sheet-mirror sheet)) + (call-next-method gadget port sheet wparam lparam)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; mswin-text-edit @@ -362,20 +378,14 @@ cstr)) ;; added back with mods by pr 1May97 (from whence?) -tjm 23May97 -(defmethod (setf gadget-value) :after (str (pane mswin-text-edit) &key invoke-callback) +(defmethod (setf gadget-value) :before (str (pane mswin-text-edit) + &key invoke-callback) (declare (ignore invoke-callback)) (with-slots (mirror value) pane (setq value str) ; Moved outside conditional - smh 26Nov96 (when mirror (win:setWindowText - mirror (xlat-newline-return str)) - ;; I wonder whether this avoidance of the callback is really correct, - ;; or whether it was a quick workaround for bad control structure elsewhere. - ;; It could be causing some of our ds problems, but I'm not changing it - ;; right now. Also, should it be moved outside the conditional? -smh 26Nov96 - (when nil ;+++ invoke-callback - (value-changed-callback pane - (gadget-client pane) (gadget-id pane) str))))) + mirror (xlat-newline-return str))))) (defmethod gadget-value ((pane mswin-text-edit)) (with-slots (mirror value) pane @@ -394,6 +404,13 @@ ;;right -- K. Reti (values value (if (listp value) (length value) 0))))) +(defmethod acl-clim::command-event :around ((gadget silica::mswin-text-edit) + port sheet wparam lparam) + (let ((notifycode (acl-clim::hiword wparam))) + (when (= notifycode win:en_killfocus) + ;; Edit control just lost keyboard focus. + (call-next-method gadget port sheet wparam lparam)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; buttons @@ -542,7 +559,6 @@ ((pixmap :initform nil) (raster-op :initform *default-picture-button-op* :initarg :raster-op)) (:default-initargs :label nil - :indicator-type ':one-of ;; We no longer want this as it overrides the the ;; system font returned by get-sheet-resources ;; in acl-medi.lisp (cim 10/12/96) @@ -600,40 +616,29 @@ ;; with bad redirection of pointer-events - ;; see comment in silica/event.lisp (cim 9/17/96) (event window-change-event)) - ;; removed the armed test that came from db-button.lisp - not - ;; applicable for built in gadgets - check for other gadget classes - ;; (cim 9/17/96) - (setf (gadget-value pane :invoke-callback t) (not (gadget-value pane)))) + (setf (gadget-value pane :invoke-callback t) + (or (eq (gadget-indicator-type pane) :one-of) + (not (gadget-value pane))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; option panes -;;; -;;; mswin option panes have been replced by mswin-combo-box - -;;; clim\db-list -(defclass acl-clim::winwidget-mixin () ()) +(defmethod (setf gadget-indicator-type) :before (value (pane hbutton-pane)) + (declare (ignore value)) + (error "Cannot change the indicator-type of a checkbox at this time")) ;;; When an hbutton is set, update its checkmark appropriately. -(defmethod (setf gadget-value) :after (value (pane hbutton-pane) +(defmethod (setf gadget-value) :before (value (pane hbutton-pane) &key invoke-callback) (declare (ignore invoke-callback)) (with-slots (mirror) pane (when mirror - ;;(break "About to set value of ~a to ~a." pane value) (win:sendmessage mirror win:BM_SETCHECK (if value 1 0) 0)))) -;;; When items are set in an hlist-pane the mirror must be -;;; made to update its appearance appropriately. -(defmethod (setf set-gadget-items) :after (items (pane hlist-pane)) - (with-slots (name-key mirror) pane - (when mirror - (win:SendMessage mirror win:LB_RESETCONTENT 0 0) - (dolist (item items) - (let ((str (acl-clim::nstringify (funcall name-key item))) - (pos (position item items))) - ;;(break "insert gadget item [~a @ ~a]" str pos) - (win:SendMessage mirror win:LB_INSERTSTRING pos str))) - (win:InvalidateRect mirror ct:hnull win:true)))) ;; make sure it updates +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; option panes +;;; +;;; mswin option panes have been replced by mswin-combo-box + +;;; clim\db-list +(defclass acl-clim::winwidget-mixin () ()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Combo Box @@ -667,7 +672,7 @@ (setf index (win:sendmessage mirror win:cb_getcursel 0 0)) (setf (gadget-value pane :invoke-callback t) (funcall value-key (elt items index))))))) -(defmethod (setf gadget-value) :after +(defmethod (setf gadget-value) :before (value (pane mswin-combo-box-pane) &key invoke-callback) (declare (ignore invoke-callback)) (with-slots (mode items value-key test) pane @@ -697,6 +702,13 @@ :width (+ name-width 20) :height (+ name-height 7))))) +(defmethod acl-clim::command-event ((gadget silica::mswin-combo-box-pane) + port sheet wparam lparam) + (let ((notifycode (acl-clim::hiword wparam))) + (when (= notifycode win:cbn_closeup) + ;; List box of a combo box has been closed. + (call-next-method gadget port sheet wparam lparam)))) + (in-package :acl-clim) ;;; This controls the space allocated to a combo-box control. Space is @@ -889,48 +901,42 @@ line-increment (page-increment slider-size)) (declare (ignore page-increment line-increment)) - (let ((mirror (sheet-direct-mirror sb))) + (let ((mirror (sheet-direct-mirror sb)) + (range (gadget-range sb))) (when mirror (unless slider-size (setq slider-size (scroll-bar-size sb))) + (setq slider-size (min slider-size range)); sanity check (unless value (setq value (gadget-value sb))) (multiple-value-bind (min max) (gadget-range* sb) - (let* ((scrollinfo-struct (ct:ccallocate win:scrollinfo)) - (win-id win:SB_CTL) ; a control (decoupled from other panes) - (range (- max min)) - (win-size (floor (* acl-clim::*win-scroll-grain* - ;; Don't divide zero by zero - (if (zerop slider-size) slider-size - (/ slider-size (+ range slider-size)))))) - (win-pos (floor (* (- acl-clim::*win-scroll-grain* - slider-size) - ;; Don't divide zero by zero - (if (= value min) 0 - (/ (- value min) (- range slider-size))))))) + (setf value (max min (min max value))); sanity check + (decf value min) + (let* ((struct (ct:ccallocate win:scrollinfo)) + (page + (floor + (* acl-clim::*win-scroll-grain* + (if (zerop slider-size) + slider-size (/ slider-size range))))) + (position + (floor + (* acl-clim::*win-scroll-grain* + (if (zerop value) value (/ value range)))))) (ct:csets - win:scrollinfo scrollinfo-struct - win::cbSize (ct:sizeof win:scrollinfo) - win::fMask #.(logior - win:SIF_PAGE - win:SIF_POS - 1 ;win:SIF_RANGE - win:SIF_DISABLENOSCROLL) - win::nMin 0 - win::nMax acl-clim::*win-scroll-grain* - win::nPage win-size - win::nPos win-pos) - (win:SetScrollInfo (sheet-mirror sb) win-id scrollinfo-struct t)))))) - -(defmethod (setf gadget-value) :after + win:scrollinfo struct + cbSize (ct:sizeof win:scrollinfo) + fMask win:SIF_ALL + nMin 0 + nMax acl-clim::*win-scroll-grain* + nPage page + nPos position) + (win:SetScrollInfo mirror win:SB_CTL struct 1)))))) + +(defmethod (setf gadget-value) :before (nv (gadget mswin-scroll-bar) &key invoke-callback) (declare (ignore invoke-callback)) - (let ((mirror (sheet-direct-mirror gadget))) - (when mirror - (change-scroll-bar-values gadget :value nv)))) + (change-scroll-bar-values gadget :value nv)) -(defmethod (setf scroll-bar-size) :after (nv (gadget mswin-scroll-bar)) - (let ((mirror (sheet-direct-mirror gadget))) - (when mirror - (change-scroll-bar-values gadget :slider-size nv)))) +(defmethod (setf scroll-bar-size) :before (nv (gadget mswin-scroll-bar)) + (change-scroll-bar-values gadget :slider-size nv)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; pull-down-menu diff --git a/aclpc/winwidgh.lisp b/aclpc/winwidgh.lisp index f54bb02c9cfa1f4efd14025cc9d64d0e730e94c9..ad37226b0756655113acc3047dedcf7a15338192 100644 --- a/aclpc/winwidgh.lisp +++ b/aclpc/winwidgh.lisp @@ -1,4 +1,4 @@ -;;; -*- Package: win; mode: Common-Lisp -*- +;;; -*- Package: acl-clim; mode: Common-Lisp -*- ;; copyright (c) 1985,1986 Franz Inc, Alameda, Ca. ;; copyright (c) 1986-1998 Franz Inc, Berkeley, CA - All rights reserved. ;; @@ -16,13 +16,12 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: winwidgh.lisp,v 1.3 1998/08/06 23:15:46 layer Exp $ +;; $Id: winwidgh.lisp,v 1.4 1998/10/08 18:36:21 layer Exp $ (in-package :acl-clim) ;; These seem to be missing from winapi-dev (defconstant LBS_DISABLENOSCROLL #x1000) -(defconstant HLN_SELCHANGE #x1) (defconstant CB_SETTOPINDEX #x015c) (ff:def-foreign-type browseinfo @@ -35,6 +34,16 @@ (lparam win:lparam) (iImage :int))) +(ff:def-foreign-type toolinfo + (:struct (cbsize win:uint) + (uflags win:uint) + (hwnd win:hwnd) + (uid win:uint) + (rect win:rect) + (hinst win:hinstance) + (lpsztext win:lpstr) + (lparam win:lparam))) + (ff:def-foreign-call (SHBrowseForFolder "SHBrowseForFolder") ((info browseinfo)) :returning :int @@ -74,3 +83,11 @@ :arg-checking nil :call-direct t :returning :int) + +(ff:def-foreign-call (setwindowshookex "SetWindowsHookExA") + ((a :int) (b :int) (c :int) (d :int)) + :returning :int) + +(ff:def-foreign-call (callnexthookex "CallNextHookExA") + ((a :int) (b :int) (c :int) (d :int)) + :returning :int) diff --git a/clim/frames.lisp b/clim/frames.lisp index fdcd458376426a5f3bd8c1c20608c20635dcbc0d..b3298ec407ec0ea3be9d5316d7be15720a22e786 100644 --- a/clim/frames.lisp +++ b/clim/frames.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: frames.lisp,v 1.90 1998/08/06 23:15:56 layer Exp $ +;; $Id: frames.lisp,v 1.91 1998/10/08 18:36:22 layer Exp $ (in-package :clim-internals) @@ -1550,7 +1550,8 @@ (:control "c") (:meta "m") (:super "s") - (:hyper "h"))) + (:hyper "h") + (:double "dbl"))) (defun frame-document-highlighted-presentation-1 (frame presentation input-context window x y stream) @@ -1569,11 +1570,11 @@ (*print-pretty* nil)) (flet ((document-translator (translator presentation context-type button-names separator) - ;; Assumes 5 modifier keys and the reverse ordering of *MODIFIER-KEYS* + ;; Assumes 6 modifier keys and the reverse ordering of *MODIFIER-KEYS* (let ((bit #o20) - (shift-name '(:hyper :super :meta :control :shift))) + (shift-name '(:double :hyper :super :meta :control :shift))) (declare (type fixnum bit)) - (repeat 5 ;length of shift-name + (repeat 6 ;length of shift-name (unless (zerop (logand bit modifier-state)) (write-string (frame-modifier-key-documentation frame diff --git a/clim/gestures.lisp b/clim/gestures.lisp index b9aefd3cfc482ed4af6f06824e28ac8853046e81..d9818fbd021f9d1363a0d6f118dfce3a8b813e96 100644 --- a/clim/gestures.lisp +++ b/clim/gestures.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: gestures.lisp,v 1.27 1998/08/06 23:15:56 layer Exp $ +;; $Id: gestures.lisp,v 1.28 1998/10/08 18:36:22 layer Exp $ (in-package :clim-internals) @@ -27,7 +27,7 @@ ;;; pointer gesture, e.g., Shift-Left. ;;; For now, we are making a few assumptions. -;;; 1) The set of possible modifier bits is :CONTROL, :SHIFT, :META, :SUPER, and :HYPER, +;;; 1) The set of possible modifier bits is :CONTROL, :SHIFT, :META, :SUPER, :HYPER, :DOUBLE ;;; as per CLtL. ;;; 2) The set of possible "mouse buttons" is :LEFT, :MIDDLE, and :RIGHT. @@ -51,7 +51,7 @@ (defun make-modifier-state (&rest modifiers) (declare (dynamic-extent modifiers)) (assert (every #'(lambda (x) (find x *modifier-keys*)) modifiers) (modifiers) - "~S is not a subset of ~S" modifiers '(:shift :control :meta :super :hyper)) + "~S is not a subset of ~S" modifiers '(:shift :control :meta :super :hyper :double)) (let ((state 0)) (dolist (name modifiers) (let ((bit (modifier-key-index name))) @@ -417,12 +417,14 @@ (:super "s-") (:meta "m-") (:control "c-") - (:shift "sh-")) + (:shift "sh-") + (:double "dbl-")) '((:hyper "hyper-") (:super "super-") (:meta "meta-") (:control "control-") - (:shift "shift-"))))) + (:shift "shift-") + (:double "double-"))))) (dolist (shift alist) (when (member (first shift) (rest gesture-spec)) (princ (second shift) stream))) @@ -450,7 +452,8 @@ (:control "c") (:meta "m") (:super "s") - (:hyper "h"))) + (:hyper "h") + (:double "dbl"))) (format stream "~:(~A-~)" name)))))))) diff --git a/clim/output-protocol.lisp b/clim/output-protocol.lisp index 0c2b46203c93f8fe939241b594e62aab173196d2..ec4523cb45e81cd24cc9a627022db587b22a24e6 100644 --- a/clim/output-protocol.lisp +++ b/clim/output-protocol.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: output-protocol.lisp,v 1.48 1998/08/06 23:16:01 layer Exp $ +;; $Id: output-protocol.lisp,v 1.49 1998/10/08 18:36:22 layer Exp $ (in-package :clim-internals) @@ -81,7 +81,10 @@ (setf (slot-value stream 'text-margin) text-margin))) ;;--- I sure don't like having to do this to make string streams work -(defmethod stream-default-view ((stream t)) +textual-view+) +;; JPM: added setf method to help PC port. 8/98. +(defvar *stream-default-view* +textual-view+) +(defmethod stream-default-view ((stream t)) *stream-default-view*) +(defmethod (setf stream-default-view) (new (stream t)) (setq *stream-default-view* new)) (defmethod stream-vertical-spacing ((stream t)) (coordinate 0)) diff --git a/silica/classes.lisp b/silica/classes.lisp index bfc5ac283a5cd0732486ec6d37310ab77b267b24..c7fa7d0fb81fd138795deb090d78194eb83a0637 100644 --- a/silica/classes.lisp +++ b/silica/classes.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: classes.lisp,v 1.41 1998/08/06 23:16:56 layer Exp $ +;; $Id: classes.lisp,v 1.42 1998/10/08 18:36:24 layer Exp $ (in-package :silica) @@ -267,10 +267,16 @@ (defconstant +super-key+ (ash 1 3)) (defconstant +hyper-key+ (ash 1 4)) +;; Of course there is no "double" key. I am choosing to +;; represent a double-click event in one of the unused +;; bits of the modifier mask. JPM 8/98. +(defconstant +double-key+ (ash 1 5)) + ;; The order of this must match the values above -(defconstant *modifier-keys* '#(:shift :control :meta :super :hyper)) +(defconstant *modifier-keys* '#(:shift :control :meta :super :hyper :double)) (deftype shift-keysym () '(member :left-shift :right-shift)) +(deftype double-keysym () '(member :left-double :right-double)) (deftype control-keysym () '(member :left-control :right-control)) (deftype meta-keysym () '(member :left-meta :right-meta)) (deftype super-keysym () '(member :left-super :right-super)) @@ -278,4 +284,5 @@ (deftype lock-keysym () '(member :caps-lock :shift-lock :mode-lock)) (deftype modifier-keysym () - '(or shift-keysym control-keysym meta-keysym super-keysym hyper-keysym)) + '(or shift-keysym control-keysym meta-keysym + super-keysym hyper-keysym double-keysym)) diff --git a/silica/db-label.lisp b/silica/db-label.lisp index 4a099262906690b3cdbbdaceeaf102ff94ad4a9b..464747cda79743e130b1d74ca49be2003354d89e 100644 --- a/silica/db-label.lisp +++ b/silica/db-label.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: db-label.lisp,v 1.6 1998/08/06 23:16:57 layer Exp $ +;; $Id: db-label.lisp,v 1.7 1998/10/08 18:36:24 layer Exp $ ;;; This file also exists in clim2/homegrown. The homegrown directory ;;; contains files to implement CLIM's generic gadgets. Native backends @@ -44,9 +44,8 @@ (defmethod handle-repaint ((pane generic-label-pane) region) (declare (ignore region)) ;not worth checking (with-sheet-medium (medium pane) - (window-clear medium) (with-bounding-rectangle* (left top right bottom) (sheet-region pane) - (declare (ignore bottom)) + (medium-clear-area medium left top right bottom) ;; fixed bug when :align-x not :left (cim 10/14/96) (let* ((align-x (gadget-alignment pane)) (x (ecase align-x diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp index 5ea2618e9b18d1b8231bc95b66106ae91c1c6366..4c74b660cc70d6543b3e7224748df0843582aae8 100644 --- a/tk-silica/xm-frames.lisp +++ b/tk-silica/xm-frames.lisp @@ -15,7 +15,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: xm-frames.lisp,v 1.77 1998/08/06 23:17:25 layer Exp $ +;; $Id: xm-frames.lisp,v 1.78 1998/10/08 18:36:24 layer Exp $ (in-package :xm-silica) @@ -144,7 +144,10 @@ '(:font-list))) ;; menu-text-style used to be (pane-text-style sheet) ;; changed 28May97 -tjm - (menu-text-style clim-internals::*default-menu-text-style*) + ;; changed back 14Sep98 JPM + ;; (X resource database should provide default text styles - spr18064) + (menu-text-style (pane-text-style sheet) + #+ignore clim-internals::*default-menu-text-style*) (frame (pane-frame sheet)) (top-command-table (or (menu-bar-command-table sheet) (frame-command-table frame))) diff --git a/utils/last.lisp b/utils/last.lisp index 947f8bcbb40b5f6bb8b6467aab16fba6ce440a5c..4ebc0c64e763f8fe06a68d493cf3b79acd05c614 100644 --- a/utils/last.lisp +++ b/utils/last.lisp @@ -15,14 +15,15 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: last.lisp,v 1.2 1998/08/06 23:17:34 layer Exp $ +;; $Id: last.lisp,v 1.3 1998/10/08 18:36:26 layer Exp $ (in-package :system) #-(version>= 5 0 pre-final 16) (load-patches "patch" "sys:;update-clim;*.fasl") #+(version>= 5 0 pre-final 16) -(load-patches :product #.*patch-product-code-clim*) +(load-patches :product #.*patch-product-code-clim* + :version #.excl::*cl-patch-version-char*) (provide #+mswindows :climnt diff --git a/utils/packages.lisp b/utils/packages.lisp index c316018743f4015b6ebc0e305e6e3b8e77237906..6fae46b2555651a2dd89d26b5e50864911d25a0c 100644 --- a/utils/packages.lisp +++ b/utils/packages.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: packages.lisp,v 1.87 1998/09/29 21:02:38 duane Exp $ +;; $Id: packages.lisp,v 1.88 1998/10/08 18:36:27 layer Exp $ (in-package :common-lisp-user) @@ -3315,7 +3315,7 @@ (cl:defvar *clim-major-version* 2) (cl:defvar *clim-minor-version* 2) (cl:defvar *clim-generation-version* 2) -(cl:defvar *clim-build-version* 2) +(cl:defvar *clim-build-version* 3) (cl:defparameter *clim-version* (cl:format () "~d.~d.~d.~a"