diff --git a/ChangeLog.n b/ChangeLog.n index b556d9212bc2358d3c44a93248cb26e279e9520a..e51eae74a9f9c43fba0a0a115f1993b47c400b7b 100644 --- a/ChangeLog.n +++ b/ChangeLog.n @@ -1,3 +1,46 @@ +2005-07-22 alemmens <alemmens@franz.com> + + * aclpc/acl-class.lisp, aclpc/acl-pref.lisp, + aclpc/acl-scroll.lisp, aclc/acl-widget.lisp: scrollbar + improvements on Windows + * clim/command.lisp: fix bug in DEFCOMMAND + * clim/gadget-output.lisp: (spr30294) don't filter quotes from + text-field + * silica/gadgets.lisp: scrollbar improvements + * tk-silica/xt-frames.lisp: (spr30282) window close event = + cancel gesture + * tk-silica/xt-gadgets.lisp, tk-silica/xm-gadgets.lisp: + scrollbar improvements on Motif + +2005-06-03 <duane@gemini> + +Added files: + + * Makefile.solamd64: Add Solaris/AMD64 + +Modified files: + + * Makefile: add Solaris/AMD64 + * Makefile.macosx: Add 64-bit parameterization + * Makefile.wnn: Leave libcrypt out of Solarios AMD64 + +2005-04-08 Kevin Layer <layer@gemini> + + * Makefile.wnn: add -lcrypt for SUSE + +2004-09-28 <mm@KETCHTOO> + + * acl-frames.lisp (clim-internals::frame-manager-position-dialog): + Make sure values exist before using them [bug14769] + +2004-08-16 <layer@HOBART> + + * aclpc/acl-port.lisp: win:size -> win:win-size + +Thu Jul 22 23:17:23 PDT 2004 Duane Rettig <duane@gemini> + + * aclpc/acl-prel.lisp: win:handle -> win:win-handle + 2004-03-24 <layer@HOBART> * Makefile.generic: remove cat'ing of runlisp.sh -o output, since @@ -58,6 +101,11 @@ join from acl62 to trunk on 12/11/03 next join tag: acl62_to_trunk_via_layer48_merge_121003 ******************************************************************************* +2004-05-27 Charles A. Cox <cox@gemini> + + * ChangeLog.n: Add cvs Revision marker to help track cvs versions + sent to Kido. + 2003-12-23 Kevin Layer <layer@crikey> * Makefile.linux: add dmalloc debugging stuff, turned off by @@ -5933,4 +5981,4 @@ IGNORE JDI SPECIFIC CHANGES TO Makefile Lots of other stuff ******************************************************************************* -$Revision: 2.10 $ +$Revision: 2.11 $ diff --git a/Makefile b/Makefile index 5e51a74851da72433401ce64774a6532f82ac045..f97549f586b311319d8f98c498a6eb655d1e3f79 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -# $Header: /repo/cvs.copy/clim2/Makefile,v 2.5 2004/03/11 02:13:07 layer Exp $ +# $Header: /repo/cvs.copy/clim2/Makefile,v 2.6 2005/08/03 05:07:13 layer Exp $ # If ../makefile.top doesn't exist, then you must specify HOST=xxx on the # `make' command line. @@ -14,6 +14,9 @@ ifeq ($(OS_NAME),sunos) ifeq ($(MACHINE),sparc) HOST = sun4-svr4 endif +ifeq ($(MACHINE),x86_64) +HOST = solamd64 +endif endif ifeq ($(OS_NAME),linux) diff --git a/Makefile.macosx b/Makefile.macosx index dcff62328f0f082ac77d05978456a7543579cbe3..39e74b45ee24c1732c8607cf9151157a017f755a 100644 --- a/Makefile.macosx +++ b/Makefile.macosx @@ -1,4 +1,4 @@ -# $Id: Makefile.macosx,v 2.4 2003/12/15 18:35:11 layer Exp $ +# $Id: Makefile.macosx,v 2.5 2005/08/03 05:07:13 layer Exp $ # # Makefile.macosx for CLIM 2.0 # @@ -26,10 +26,16 @@ XLIB=-L/usr/X11R6/lib -lX11 XINCLUDES=-I/usr/X11R6/include -I/usr/local/motif/include +ifeq ($(SIXTYFOURBIT),yes) +CFLAGS= -arch ppc64 -DAcl64Bit +MAKE_SHARED = sh ../src/bin/make_shared.mac64 +else CFLAGS= +MAKE_SHARED = sh ../src/bin/make_shared.mac +endif + PICFLAGS = SHAREFLAGS = -MAKE_SHARED = sh ../src/bin/make_shared.mac AR = ar cq PRODUCT-OBJS= $(PRODUCT-GENERIC-OBJS) $(STATIC-XM-OBJS) $(SHARED-XM-OBJS) diff --git a/Makefile.solamd64 b/Makefile.solamd64 new file mode 100644 index 0000000000000000000000000000000000000000..e0e13df745fad420150bcf09b0d6e8f362a55c1b --- /dev/null +++ b/Makefile.solamd64 @@ -0,0 +1,44 @@ +# $Id: Makefile.solamd64,v 2.1 2005/08/03 05:07:13 layer Exp $ +# +# Makefile.sun4-svr4 for CLIM 2.0 +# + +include Makefile.defs + +Makefile=Makefile.sun4-svr4 + +# for other Motif versions use +# /net/sole/opt/ICS/Motif1.2.4/usr/include +# /net/vapor/3rd/motif-1.2.2-sol2/ICS/Motif/usr/include + +XINCLUDES=-I/usr/openwin/include -I/usr/dt/include + +# on sol7 and later -lXm is motif 2, and we need 1.x. +## Let's try it again, anyway, since sparc64 has no 1.x: +TKLIB=-lXm +#TKLIB=/usr/dt/lib/libXm.so.3 +XTLIB=-lXt +XLIB=-lX11 + +CFLAGS = -xarch=amd64 -DAcl64Bit +SET_LIBRARY_PATH= \ + LD_LIBRARY_PATH=/usr/lib/amd64; export LD_LIBRARY_PATH + +# for other Motif versions use +# /net/sole/opt/ICS/Motif1.2.4/usr/lib:/usr/lib +# /net/vapor/3rd/motif-1.2.2-sol2/ICS/Motif/usr/lib:/usr/lib + + +PRODUCT-OBJS= $(PRODUCT-GENERIC-OBJS) $(STATIC-XM-OBJS) $(SHARED-XM-OBJS) + +# from here on this file should be the same as Makefile.sun4-svr4-ol + +MOTIFXTRAS=-lgen + +PICFLAGS = -KPIC +SHAREFLAGS = +MAKE_SHARED = ld -G -64 +STD_DEFINES = +AR = ar cq + +include Makefile.generic diff --git a/Makefile.wnn b/Makefile.wnn index 4f68a7ab03f911e334c37aa0d9fb5fcba91b2c24..959aafa6b2b0679d6f331fe0d55edf561cc77b84 100644 --- a/Makefile.wnn +++ b/Makefile.wnn @@ -1,4 +1,4 @@ -# $Id: Makefile.wnn,v 2.5 2004/03/11 02:13:07 layer Exp $ +# $Id: Makefile.wnn,v 2.6 2005/08/03 05:07:13 layer Exp $ # # Makefile.wnn for CLIM 2.0 # @@ -95,6 +95,9 @@ ifeq ($(OS_NAME),linux) ifeq ($(MACHINE),ppc) REDHATLIBS = -lcrypt endif +ifdef SUSE +REDHATLIBS = -lcrypt +endif endif ifeq ($(OS_NAME),freebsd) @@ -102,8 +105,10 @@ REDHATLIBS = -lcrypt endif ifeq ($(MACHINE),x86_64) +ifeq ($(OS_NAME),linux) REDHATLIBS = -lcrypt endif +endif wnn.$(SHARED_EXT): $(WNN_OBJS) $(MAKE_SHARED) $(SHAREFLAGS) -o wnn.$(SHARED_EXT) $(WNN_OBJS) \ diff --git a/aclpc/acl-class.lisp b/aclpc/acl-class.lisp index 5e23dd73b6aee33c082868fd1b31990892acba1e..1bce0a8354b2c6e74ae1ee9c29f7217bf9459c72 100644 --- a/aclpc/acl-class.lisp +++ b/aclpc/acl-class.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: acl-class.lisp,v 2.7 2004/03/21 15:59:48 layer Exp $ +;; $Id: acl-class.lisp,v 2.8 2005/08/03 05:07:13 layer Exp $ #|**************************************************************************** * * @@ -224,7 +224,14 @@ (defvar *level* 0) (defvar *realtime-scrollbar-tracking* t) -(defvar *win-scroll-grain* 1000) + +(defvar *win-scroll-grain* + ;; Must be a 16-bit quantity. + ;; According to Microsoft, WM_HSCROLL and WM_VSCROLL messages + ;; are "limited to 16 bits of position data". + ;; (alemmens, 2004-12-17) + (1- (expt 2 16))) + (defmacro clear-winproc-result (res) (declare (ignore res)) @@ -440,76 +447,93 @@ ) (message-default window msg wparam lparam)) + +;; ;; Process WM_VSCROLL +;; + (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))) - (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)) + (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))) + (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)) + (assert bar) ;; By convention, scroll bar values should always have a range of ;; 0 to *win-scroll-grain*. (multiple-value-bind (action amount) - (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)) - ) + (case scrollcode + (#.win:SB_BOTTOM + ;; Scroll to lower right + (win:SetScrollPos hwnd bar *win-scroll-grain* redraw) + (values :percentage *win-scroll-grain*)) + ((#.win:SB_LINEDOWN #.win:SB_LINERIGHT) + ;; Scroll down/right one line + (move-slug sheet hwnd bar +1 #'silica::scroll-bar-line-increment) + (values :relative-jump +1)) + ((#.win:SB_LINEUP #.win:SB_LINELEFT) + ;; Scroll up/left one line + (move-slug sheet hwnd bar -1 #'silica::scroll-bar-line-increment) + (values :relative-jump -1)) + ((#.win:SB_PAGEDOWN #.win:SB_PAGERIGHT) + ;; Scroll down/right by slug size + (move-slug sheet hwnd bar +1 #'silica::scroll-bar-size) + (values :screenful +1)) + ((#.win:SB_PAGEUP #.win:SB_PAGELEFT) + ;; Scroll up/left by slug size + (move-slug sheet hwnd bar -1 #'silica::scroll-bar-size) + (values :screenful -1)) + (#.win:SB_THUMBPOSITION + ;; Scroll to absolute position. + (when (gadgetp sheet) + (win:SetScrollPos hwnd bar position redraw)) + (values :percentage position)) + (#.win:SB_THUMBTRACK + ;; Scroll to absolute position. + (when (gadgetp sheet) + (win:SetScrollPos hwnd bar position redraw)) + (values :percentage position)) + (#.win:SB_TOP + ;; Scroll to upper left + (when (gadgetp sheet) + (win:SetScrollPos hwnd bar 0 redraw)) + (values :percentage 0)) + ) (when (and action sheet) - (with-slots (event-queue) *acl-port* - (handle-event - sheet - (allocate-event 'silica::scrollbar-event - :orientation message - :action action - :amount amount - :sheet sheet))))) + (with-slots (event-queue) *acl-port* + (handle-event sheet + (allocate-event 'silica::scrollbar-event + :orientation message + :action action + :dragging-p (= scrollcode #.win:SB_THUMBTRACK) + :amount amount + :sheet sheet))))) (clear-winproc-result *win-result*) *win-result*)) +(defun move-slug (scroll-bar hwnd win-code direction delta-function) + ;; Only move slug for independent scroll bar gadgets. + ;; Scroller panes already take care of moving the slug. + ;; (alemmens, 2004-12-24) + (when (gadgetp scroll-bar) + (let* ((delta (funcall delta-function scroll-bar)) + (old-position (win:GetScrollPos hwnd win-code)) + (tentative-new-position + (+ old-position + (* direction (silica::convert-scroll-bar-size-out scroll-bar delta)))) + (new-position (max 0 (min *win-scroll-grain* tentative-new-position))) + (redraw 1)) + (unless (= old-position new-position) + (win:SetScrollPos hwnd win-code new-position redraw))))) + +;; + (defun frame-initialization-time (frame) ;; We need to know when the frame is not fully initialized. (or (not frame) (not (frame-top-level-sheet frame)))) diff --git a/aclpc/acl-frames.lisp b/aclpc/acl-frames.lisp index 33346408055f3925abcfc3ab41887e26361d1f3d..115e2408b4c891ec673c24375ebe2d024b9a8734 100644 --- a/aclpc/acl-frames.lisp +++ b/aclpc/acl-frames.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: acl-frames.lisp,v 2.5 2004/01/16 19:15:39 layer Exp $ +;; $Id: acl-frames.lisp,v 2.6 2005/08/03 05:07:14 layer Exp $ #|**************************************************************************** * * @@ -1991,28 +1991,34 @@ in a second Lisp process. This frame cannot be reused." ;;; it relative to the main-screen. So, here we just ;;; do it all by hand. (defmethod clim-internals::frame-manager-position-dialog - ((framem acl-clim::acl-frame-manager) - frame - own-window-x-position own-window-y-position) + ((framem acl-clim::acl-frame-manager) + frame + own-window-x-position + own-window-y-position) ;; This definition overrides the more general method in clim/accept-values.lisp - (let ((calling-frame nil)) + (let ((calling-frame nil) calling-frame-top-level-sheet frame-top-level-sheet) (multiple-value-bind (x y) (cond ((and own-window-x-position own-window-y-position) ;; If value is specified, use that. (values own-window-x-position own-window-y-position)) ((and (setq calling-frame (frame-calling-frame frame)) - (popup-frame-p frame)) + (popup-frame-p frame) + ;; Make sure these values exist before using them [bug14769] + (setq calling-frame-top-level-sheet + (frame-top-level-sheet calling-frame)) + (setq frame-top-level-sheet (frame-top-level-sheet frame)) + ) ;; If frame is a designated pop-up, ;; try to center over the calling frame. - (let ((calling-frame-top-level-sheet (frame-top-level-sheet calling-frame)) - (frame-top-level-sheet (frame-top-level-sheet frame))) - (multiple-value-bind (calling-frame-left calling-frame-top calling-frame-width) + (let () + (multiple-value-bind (calling-frame-left calling-frame-top + calling-frame-width) (bounding-rectangle* calling-frame-top-level-sheet) (let ((frame-width (bounding-rectangle-size frame-top-level-sheet))) (let ((offset (/ (- calling-frame-width frame-width) 2))) (multiple-value-bind (new-x new-y) - (transform-position - (sheet-delta-transformation calling-frame-top-level-sheet nil) + (transform-position (sheet-delta-transformation + calling-frame-top-level-sheet nil) calling-frame-left calling-frame-top) (values (+ new-x offset) (+ new-y 10)))))))) @@ -2024,3 +2030,4 @@ in a second Lisp process. This frame cannot be reused." (frame-top-level-sheet frame) x y)))) + diff --git a/aclpc/acl-port.lisp b/aclpc/acl-port.lisp index 6f0efd3c37c2cf7b67d01fadac8f22d7c003e2dd..db45fdc7ddff05fae33094096e3cabbdc2183fe3 100644 --- a/aclpc/acl-port.lisp +++ b/aclpc/acl-port.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: acl-port.lisp,v 2.7 2004/03/21 15:59:48 layer Exp $ +;; $Id: acl-port.lisp,v 2.8 2005/08/03 05:07:14 layer Exp $ #|**************************************************************************** * * @@ -576,14 +576,14 @@ or (:style . (family face size))") :face name)))) (defun make-font-width-table (dc last-character first-character default-width) - (let* ((tepsize (ct:ccallocate win:size)) + (let* ((tepsize (ct:ccallocate win:win-size)) (string (make-string 1) ) (array (make-array (1+ last-character)))) (loop for i from first-character to last-character do (setf (char string 0) (code-char i)) (cond ((excl:with-native-string (string string) (win:GetTextExtentPoint dc string 1 tepsize)) - (setf (aref array i) (ct:cref win:size tepsize cx))) + (setf (aref array i) (ct:cref win:win-size tepsize cx))) (t ;; Why does this clause ever run? getlasterror=10035. (check-last-error "GetTextExtentPoint" :action :warn) diff --git a/aclpc/acl-prel.lisp b/aclpc/acl-prel.lisp index c76878d9d3e176d276a61e01207a5035c457cd08..5c88ca07f74bc8faec4fa3b7aacb40eccebab5d9 100644 --- a/aclpc/acl-prel.lisp +++ b/aclpc/acl-prel.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: acl-prel.lisp,v 2.5 2004/01/16 19:15:40 layer Exp $ +;; $Id: acl-prel.lisp,v 2.6 2005/08/03 05:07:14 layer Exp $ #|**************************************************************************** * * @@ -195,9 +195,12 @@ (logior (if (eql orientation :horizontal) win::SBS_HORZ win::SBS_VERT) win::WS_CHILD - win::WS_BORDER + ;; Removed the WS_BORDER flag. + ;; It's non-standard and, what's worse, it resulted + ;; in some garbage pixels (alemmens, 2005-01-19) win::WS_CLIPCHILDREN - win::WS_CLIPSIBLINGS) ; style + win::WS_CLIPSIBLINGS + ) ; style 0 0 0 0 ; x, y, width, height parent 0 @@ -515,7 +518,7 @@ ;; stable after closing the clipboard. (when (zerop hmem) (check-last-error "GetClipboardData")) - (setq string (ct:handle-value win:handle hmem)) + (setq string (ct:handle-value win:win-handle hmem)) (cond ((zerop string) (values nil nil)) (t (when (integerp string) diff --git a/aclpc/acl-scroll.lisp b/aclpc/acl-scroll.lisp index 33a209858497aae2d440b74e8a1221ed3c2f13e0..8f4406f5864d4254e0c8e9f60514d2354c4ffcb6 100644 --- a/aclpc/acl-scroll.lisp +++ b/aclpc/acl-scroll.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: acl-scroll.lisp,v 2.5 2004/01/16 19:15:40 layer Exp $ +;; $Id: acl-scroll.lisp,v 2.6 2005/08/03 05:07:14 layer Exp $ #|**************************************************************************** * * @@ -34,39 +34,52 @@ (in-package :silica) (eval-when (compile load eval) - -(define-event-class scrollbar-event (event) - ((sheet :reader event-sheet :initarg :sheet) - (orientation :initarg :orientation :reader scrollbar-event-orientation) - (action :initarg :action :reader scrollbar-event-action) - (amount :initarg :amount :reader scrollbar-event-amount))) -) ;; eval-when - -(defmethod handle-event ((pane mswin-scroll-bar) - (event silica::scrollbar-event)) - (with-slots (silica::orientation silica::action silica::amount) event - (assert (eql silica::orientation (gadget-orientation pane))) - (multiple-value-bind (min) (gadget-range* pane) + (define-event-class scrollbar-event (event) + ((sheet :reader event-sheet :initarg :sheet) + (orientation :initarg :orientation :reader scrollbar-event-orientation) + (action :initarg :action :reader scrollbar-event-action) + (amount :initarg :amount :reader scrollbar-event-amount) + ;; Added the following slot to distinguish between dragging the slug + ;; and releasing the slug after dragging (alemmens, 2004-12-24). + (dragging-p :initarg :dragging-p :initform nil :reader scroll-bar-event-dragging-p + :documentation "If true, the VALUE-CHANGED-CALLBACK won't be called.")))) + +(defmethod handle-event ((pane mswin-scroll-bar) (event scrollbar-event)) + ;; Added callback invocation (alemmens, 2004-12-24). + (with-slots (orientation action amount dragging-p) event + (assert (eql orientation (gadget-orientation pane))) + (multiple-value-bind (min max) (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) - )))) + (multiple-value-bind (tentative-new-value callback) + (case action + ;; Press arrows + (:relative-jump + ;; AMOUNT is plus or minus one + (values (+ (gadget-value pane) + ;; Replaced size by line-increment (alemmens, 2004-12-17) + (* (scroll-bar-line-increment pane) amount)) + (if (plusp amount) 'scroll-down-line-callback 'scroll-up-line-callback))) + ;; Click near thumb + (:screenful + ;; AMOUNT is plus or minus one + (values (+ (gadget-value pane) (* (scroll-bar-size pane) amount)) + (if (plusp amount) 'scroll-down-page-callback 'scroll-up-page-callback))) + ;; Drag thumb + (:percentage + ;; AMOUNT is absolute position in the scroll range + ;; (from 0 to *win-scroll-grain*). + (values (convert-scroll-bar-value-in pane amount) + 'drag-callback))) + (let ((new-value (max min + (min (- max (scroll-bar-size pane)) tentative-new-value))) + (client (gadget-client pane)) + (id (gadget-id pane))) + (unless (= new-value (gadget-value pane)) + (funcall callback pane client id new-value)) + (when (and (eql action :percentage) (not dragging-p)) + ;; The thumb was released: we can call the value-changed callback. + (value-changed-callback pane client id new-value))))))) + (define-event-resource scrollbar-event 10) diff --git a/aclpc/acl-widget.lisp b/aclpc/acl-widget.lisp index 033cb80d0f91feab880a2894d6f59d32232c340e..c2d5987e25372eb8c38a938ffa50bcbebf636c7c 100644 --- a/aclpc/acl-widget.lisp +++ b/aclpc/acl-widget.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: acl-widget.lisp,v 2.6 2004/03/21 15:59:48 layer Exp $ +;; $Id: acl-widget.lisp,v 2.7 2005/08/03 05:07:14 layer Exp $ #|**************************************************************************** * * @@ -1531,42 +1531,41 @@ (defclass mswin-scroll-bar (acl-gadget-id-mixin mirrored-sheet-mixin - scroll-bar + scroll-bar space-requirement-mixin leaf-pane - ;;sheet-permanently-enabled-mixin basic-pane - ) + ;;sheet-permanently-enabled-mixin basic-pane + ) ()) -(defmethod initialize-instance :after ((object mswin-scroll-bar) - &key &allow-other-keys) - ;; It is a mystery to me how size is 1.0 at this point. - ;; This is in my opinion a poor default value. - ;; The slot has NIL as its initform, - ;; and (SETF SCROLL-BAR-SIZE) is not called. - (assert (not (null (gadget-min-value object)))) - (assert (not (null (gadget-max-value object)))) - (unless (gadget-value object) - (setf (slot-value object 'silica::value) (gadget-min-value object))) - (assert (not (null (gadget-value object)))) - (setf (scroll-bar-size object) (float (/ (gadget-range object) 10)))) + +(defmethod initialize-instance :after ((scroll-bar mswin-scroll-bar) &key &allow-other-keys) + ;; Initialization is now taken care of by an initialize-instance after method + ;; on scroll-bar in silica/gadgets.lisp. This dummy is only necessary as long + ;; as CLIM hasn't been recompiled from scratch. (alemmens, 2004-12-2004) + 'ignore) + + +(defmethod native-gadget-range* ((scroll-bar mswin-scroll-bar)) + (values 0 acl-clim::*win-scroll-grain*)) + (defmethod realize-mirror ((port acl-clim::acl-port) (sheet mswin-scroll-bar)) (multiple-value-bind (left top right bottom) (sheet-native-region* sheet) (fix-coordinates left top right bottom) (let* ((parent (sheet-mirror sheet)) - (parent2 (sheet-mirror (sheet-parent sheet))) + (parent2 (sheet-mirror (sheet-parent sheet))) (window nil) (orientation (gadget-orientation sheet)) - (width (- right left)) - (height (- bottom top)) + (width (- right left)) + (height (- bottom top)) (gadget-id (allocate-gadget-id sheet))) (assert (eq parent parent2) () "parents don't match!") (setq window - (acl-clim::scrollbar-open parent left top width height orientation)) + (acl-clim::scrollbar-open parent left top width height orientation)) (setf (sheet-native-transformation sheet) - (sheet-native-transformation (sheet-parent sheet))) + (sheet-native-transformation (sheet-parent sheet))) (setf (gadget-id->window sheet gadget-id) window) (win:ShowWindow window win:SW_SHOW) (setf (sheet-direct-mirror sheet) window) ; needed only to initialize @@ -1574,10 +1573,10 @@ ;; Make sure defaults are sensible at the time the WIN32 scroll bar is ;; created. (setf (gadget-min-value sheet) - (or (gadget-min-value sheet) 0)) + (or (gadget-min-value sheet) 0)) (setf (gadget-max-value sheet) - (or (gadget-max-value sheet) 1)) - (change-scroll-bar-values ;initialize + (or (gadget-max-value sheet) 1)) + (change-scroll-bar-values sheet ;; remaining from rfe4072 :slider-size (or (scroll-bar-size sheet) 1) @@ -1603,40 +1602,32 @@ :max-width +fill+))))) (defmethod change-scroll-bar-values ((sb mswin-scroll-bar) - &key - slider-size - value - line-increment - (page-increment slider-size)) + &key + slider-size + value + line-increment + (page-increment slider-size)) + ;; I simplified this (and improved dealing with unusual gadget ranges) + ;; by using convert-scroll-bar-xxx-out (alemmens, 2004-12-24). (declare (ignore page-increment line-increment)) (let ((mirror (sheet-direct-mirror sb)) - (range (gadget-range 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 + (setq slider-size (min slider-size range)) ; sanity check (unless value (setq value (gadget-value sb))) - (multiple-value-bind (min max) (gadget-range* sb) - (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 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)))))) + (let* ((struct (ct:ccallocate win:scrollinfo)) + (page (convert-scroll-bar-size-out sb slider-size)) + (position (convert-scroll-bar-value-out sb value))) + (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 win:SB_CTL struct 1))))) (defmethod (setf gadget-value) :before (nv (gadget mswin-scroll-bar) &key invoke-callback) diff --git a/clim/command.lisp b/clim/command.lisp index 06dec113b52241a95488886788384fe93a3b4536..f41d373eb196593ef894de050bcabf1d93e99417 100644 --- a/clim/command.lisp +++ b/clim/command.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: command.lisp,v 2.5 2004/01/16 19:15:40 layer Exp $ +;; $Id: command.lisp,v 2.6 2005/08/03 05:07:14 layer Exp $ (in-package :clim-internals) @@ -1005,8 +1005,12 @@ (setq default (second l)) (return t)))) (push `(,(first argument) ,default) keyword-bindings)) - (t - (push `(,(first argument) ',*unsupplied-argument-marker*) required-bindings)))) + ;; Added extra check that the argument is a cons, because valid-cp-lambda-list-keyword-p + ;; only warns (but does not signal an error) for invalid argument descriptions. + ;; (alemmens, 2004-11-26) + ((consp argument) + (push `(,(first argument) ',*unsupplied-argument-marker*) required-bindings)) + (t (error "~S is not a valid argument description for define-command." argument)))) (values (nreverse required-bindings) (nreverse keyword-bindings)))) (defun deduce-body-arglist (arguments) diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp index 4303927c58922318ce7a642cfab6f22f012b170b..765640f3b1f130e0e1ef13fed01ac5325f2740db 100644 --- a/clim/gadget-output.lisp +++ b/clim/gadget-output.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: gadget-output.lisp,v 2.5 2004/01/16 19:15:40 layer Exp $ +;; $Id: gadget-output.lisp,v 2.6 2005/08/03 05:07:14 layer Exp $ (in-package :clim-internals) @@ -770,28 +770,36 @@ ;; windows CLIM port when apparently it sometimes is nil (cim 1/30/97) (if query (setf (accept-values-query-changed-p query) t))) + + (defmethod accept-values-string-field-changed-callback ((gadget text-field) stream query) (let ((new-value (gadget-value gadget))) ;; Only do the accept when the field has changed ;; Only call the callback if the query is still valid - ;; NB query should never be nil but this test was put in for the - ;; windows CLIM port when apparently it sometimes is nil (cim 1/30/97) (when (and query (accept-values-query-changed-p query) (accept-values-query-valid-p query (accept-values-query-presentation query))) (handler-case - (multiple-value-bind (object type index) - ;; we specify :activation-gestures nil so that we can - ;; accept multi-line strings in text-editors (cim) - (accept-from-string (accept-values-query-type query) - new-value - :activation-gestures nil - :delimiter-gestures nil) - (declare (ignore type)) - (assert (= index (length new-value))) - object) + (let ((ptype (accept-values-query-type query))) + (clim:with-presentation-type-decoded (name) + ptype + (if (eql name 'string) + ;; [spr30294] Accept the raw text-field contents + ;; when we're expecting a string (alemmens, 2005-06-21) + (accept-raw-string ptype new-value) + ;; Normal case: use accept-from-string. + (multiple-value-bind (object type index) + ;; we specify :activation-gestures nil so that we can + ;; accept multi-line strings in text-editors (cim) + (accept-from-string (accept-values-query-type query) + new-value + :activation-gestures nil + :delimiter-gestures nil) + (declare (ignore type)) + (assert (= index (length new-value))) + object)))) (error (c) (setf (accept-values-query-error-p query) c) (let ((frame (pane-frame stream))) @@ -801,6 +809,18 @@ (:no-error (object) (setf (accept-values-query-error-p query) nil) (do-avv-command object stream query)))))) + + +(defun accept-raw-string (ptype gadget-value) + ;; [spr30294] Don't call ACCEPT-FROM-STRING when we just want to + ;; accept a string, because it will filter initial double quote + ;; characters from the string and we don't want that for text-field + ;; gadgets. (alemmens, 2005-06-21) + (with-presentation-type-parameters (string ptype) + (if (or (eq length '*) (= (length gadget-value) length)) + gadget-value + (input-not-of-required-type gadget-value ptype)))) + ;;; Text Editor gadget diff --git a/postscript/postscript-port.lisp b/postscript/postscript-port.lisp index eb58109ed331d785c1d27edc25d8a944792805bb..b5e51b31545e042469a41f14cb153b5c2b37327f 100644 --- a/postscript/postscript-port.lisp +++ b/postscript/postscript-port.lisp @@ -1,12 +1,6 @@ -(sys:defpatch "climps" 1 - "Emit integers in PostScript BoundinBox entry" - :type :clim2 - :feature :clim - :post-loadable t) - ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: POSTSCRIPT-CLIM; Base: 10; Lowercase: Yes -*- -;; $Id: postscript-port.lisp,v 2.4 2003/12/15 18:35:14 layer Exp $ +;; $Id: postscript-port.lisp,v 2.5 2005/08/03 05:07:14 layer Exp $ (provide :climps) diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp index 60ad066b114260ff2f251c0bc5d642da89db92ac..ba864cf59a55a4f49e59f357be085dd81d86cf2c 100644 --- a/silica/gadgets.lisp +++ b/silica/gadgets.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: gadgets.lisp,v 2.5 2004/01/16 19:15:43 layer Exp $ +;; $Id: gadgets.lisp,v 2.6 2005/08/03 05:07:14 layer Exp $ ;;;"Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. ;;; Portions copyright (c) 1992 by Symbolics, Inc. All rights reserved." @@ -313,35 +313,65 @@ (invoke-callback-function callback gadget value)) (call-next-method))) - +;;; ;;; Scroll bar +;;; + (defclass scroll-bar (value-gadget range-gadget-mixin oriented-gadget-mixin) - ((size :initform 1 :initarg :size :accessor scroll-bar-size) + ;; Removed initforms for SIZE and LINE-INCREMENT; these are now initialized + ;; in an after method on INITIALIZE-INSTANCE (alemmens, 2004-12-10). + ((size :initarg :size :accessor scroll-bar-size) + (line-increment :initarg :line-increment :accessor scroll-bar-line-increment) (drag-callback :initarg :drag-callback :initform nil - :reader scroll-bar-drag-callback) - (line-increment :initform 1 - :initarg :line-increment - :accessor scroll-bar-line-increment) + :reader scroll-bar-drag-callback) (scroll-to-bottom-callback :initform nil - :initarg :scroll-to-bottom-callback - :reader scroll-bar-scroll-to-bottom-callback) + :initarg :scroll-to-bottom-callback + :reader scroll-bar-scroll-to-bottom-callback) (scroll-to-top-callback :initform nil - :initarg :scroll-to-top-callback - :reader scroll-bar-scroll-to-top-callback) + :initarg :scroll-to-top-callback + :reader scroll-bar-scroll-to-top-callback) (scroll-down-line-callback :initform nil - :initarg :scroll-down-line-callback - :reader scroll-bar-scroll-down-line-callback) + :initarg :scroll-down-line-callback + :reader scroll-bar-scroll-down-line-callback) (scroll-up-line-callback :initform nil - :initarg :scroll-up-line-callback - :reader scroll-bar-scroll-up-line-callback) + :initarg :scroll-up-line-callback + :reader scroll-bar-scroll-up-line-callback) (scroll-down-page-callback :initform nil - :initarg :scroll-down-page-callback - :reader scroll-bar-scroll-down-page-callback) + :initarg :scroll-down-page-callback + :reader scroll-bar-scroll-down-page-callback) (scroll-up-page-callback :initform nil - :initarg :scroll-up-page-callback - :reader scroll-bar-scroll-up-page-callback) + :initarg :scroll-up-page-callback + :reader scroll-bar-scroll-up-page-callback) )) + +(defmethod initialize-instance :after ((scroll-bar scroll-bar) &key value size line-increment &allow-other-keys) + ;; The default value for SIZE should be (GADGET-RANGE scroll-bar), not 1. + ;; The default value for VALUE should be (GADGET-MIN-VALUE scroll-bar), not NIL. + ;; The default value for LINE-INCREMENT should be a fraction of SIZE, not 1. + ;; (alemmens, 2004-12-10) + (unless value + (setf (slot-value scroll-bar 'value) (gadget-min-value scroll-bar))) + (unless size + (setf (slot-value scroll-bar 'size) (gadget-range scroll-bar))) + (unless line-increment + (setf (slot-value scroll-bar 'line-increment) (* 0.1 (slot-value scroll-bar 'size))))) + +(defmethod print-object ((gadget scroll-bar) stream) + ;; Added this method for easier debugging (alemmens, 2004-12-24). + (print-unreadable-object (gadget stream :type t :identity t) + (format stream "from ~A to ~A (size ~A, line ~A, value ~A)" + (gadget-min-value gadget) + (gadget-max-value gadget) + (if (slot-boundp gadget 'size) + (scroll-bar-size gadget) + 'unbound) + (if (slot-boundp gadget 'line-increment) + (scroll-bar-line-increment gadget) + 'unbound) + (gadget-value gadget)))) + + (defmethod drag-callback :around ((gadget scroll-bar) (client t) (id t) value) (let ((callback (scroll-bar-drag-callback gadget))) (when callback @@ -364,24 +394,27 @@ (value (gadget scroll-bar) &key invoke-callback) (declare (ignore invoke-callback)) (assert (and (<= (+ value (scroll-bar-size gadget)) - (gadget-max-value gadget)) - (>= value (gadget-min-value gadget))) - (value) + (gadget-max-value gadget)) + (>= value (gadget-min-value gadget))) + (value) "Scroll bar value ~A out of range" value) (call-next-method value gadget)) (defmethod (setf line-increment) :around (value (object scroll-bar)) (assert (and (> value (gadget-min-value object)) - (<= value (gadget-max-value object))) - (value) + (<= value (gadget-max-value object))) + (value) "Scroll bar line-increment ~a out of range" value) (call-next-method value object)) -(defmethod change-scroll-bar-values :before - ((pane scroll-bar) - &key line-increment &allow-other-keys) +(defmethod change-scroll-bar-values :before ((pane scroll-bar) + &key line-increment &allow-other-keys) ;; Record line-increment since clim doesn't. - (setf (scroll-bar-line-increment pane) line-increment)) + ;; (Only record it when it's actually given as an argument to + ;; change-scroll-bar-values; the win32 backend doesn't always do that. + ;; alemmens, 2004-12-24) + (when line-increment + (setf (scroll-bar-line-increment pane) line-increment))) ;;; Here are the callbacks that were once called out in the CLIM spec: @@ -415,8 +448,52 @@ (let ((callback (scroll-bar-scroll-down-page-callback pane))) (when callback (funcall callback pane)))) - +;;; +;;; Some scroll bar utilities +;;; + +;; (These came from xt-gadgets.lisp. alemmens, 2004-12-24) + +(defun convert-scroll-bar-value-out (scroll-bar value) + "Convert a scroll bar value from CLIM to native." + (multiple-value-bind + (smin smax) (gadget-range* scroll-bar) + (multiple-value-bind (native-min native-max) + (native-gadget-range* scroll-bar) + (max native-min + (min native-max + (floor + (compute-symmetric-value smin smax value native-min native-max))))))) + +(defun convert-scroll-bar-value-in (scroll-bar value) + "Convert a scroll bar value from native to CLIM." + (multiple-value-bind + (smin smax) (gadget-range* scroll-bar) + (multiple-value-bind (native-min native-max) + (native-gadget-range* scroll-bar) + (max smin + (min smax + (compute-symmetric-value native-min native-max value smin smax)))))) + +;; Converting scroll-bar sizes (e.g. slug size or line increment) went +;; wrong when the scroll-bar's min-value was non-zero. So I added the +;; following two little helper functions (alemmens, 2004-12-10). + +(defun convert-scroll-bar-size-out (scroll-bar size) + "Convert a scroll bar size from CLIM to native." + (convert-scroll-bar-value-out scroll-bar + (+ (gadget-min-value scroll-bar) size))) + +(defun convert-scroll-bar-size-in (scroll-bar native-size) + "Convert a scroll bar size from native to CLIM." + (- (convert-scroll-bar-value-in scroll-bar native-size) + (gadget-min-value scroll-bar))) + + +;;; ;;; Push-button +;;; + (defclass push-button (action-gadget labelled-gadget-mixin) ((show-as-default :initform nil :initarg :show-as-default diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index 98c9a50058f26360179f7186a0b0085d39732bf2..b930cda210f4e1dff65545f03a16ecc256fe648b 100644 --- a/tk-silica/xm-gadgets.lisp +++ b/tk-silica/xm-gadgets.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: xm-gadgets.lisp,v 2.5 2004/01/16 19:15:44 layer Exp $ +;; $Id: xm-gadgets.lisp,v 2.6 2005/08/03 05:07:14 layer Exp $ (in-package :xm-silica) @@ -570,17 +570,24 @@ (defmethod find-widget-initargs-for-sheet ((port motif-port) - (parent t) - (sheet motif-scroll-bar)) + (parent t) + (sheet motif-scroll-bar)) (let ((size (scroll-bar-size sheet)) - (increment (silica::scroll-bar-line-increment sheet))) + (increment (silica::scroll-bar-line-increment sheet))) (append `(:minimum 0 :maximum ,*scroll-bar-quantization*) - (when increment - `(:increment - ,(convert-scroll-bar-value-out sheet increment))) - (when size - `(:slider-size - ,(convert-scroll-bar-value-out sheet size)))))) + (when increment + `(:increment + ,(silica::convert-scroll-bar-size-out sheet increment))) + (when size + (let ((internal-size (silica::convert-scroll-bar-size-out sheet size))) + `(:slider-size ,internal-size + ;; Set page increment too (alemmens, 2004-12-10). + :page-increment ,internal-size))) + ;; Set initial value (alemmens, 2004-12-10). + (let ((value (gadget-value sheet))) + (when value + `(:value + ,(silica::convert-scroll-bar-value-out sheet value))))))) ;;;--- We should use the motif functions for getting and changing the ;;;--- values @@ -648,14 +655,14 @@ sheet (gadget-client sheet) (gadget-id sheet) - (convert-scroll-bar-value-in sheet - (tk::get-values widget :value)))) + (silica::convert-scroll-bar-value-in sheet + (tk::get-values widget :value)))) (defmethod gadget-value ((gadget motif-scroll-bar)) (let ((mirror (sheet-direct-mirror gadget))) (if mirror - (convert-scroll-bar-value-in gadget - (tk::get-values mirror :value)) + (silica::convert-scroll-bar-value-in gadget + (tk::get-values mirror :value)) (call-next-method)))) (defmethod (setf gadget-value) :after @@ -664,13 +671,13 @@ (let ((mirror (sheet-direct-mirror gadget))) (when mirror (tk::set-values mirror - :value (convert-scroll-bar-value-out gadget nv))))) + :value (silica::convert-scroll-bar-value-out gadget nv))))) (defmethod scroll-bar-size ((sheet motif-scroll-bar)) (let ((mirror (sheet-direct-mirror sheet))) (if mirror - (convert-scroll-bar-value-in sheet - (tk::get-values mirror :slider-size)) + (silica::convert-scroll-bar-size-in sheet + (tk::get-values mirror :slider-size)) (call-next-method)))) (defmethod (setf scroll-bar-size) :after (value (object motif-scroll-bar)) @@ -679,7 +686,7 @@ ;; Set the XmNsliderSize and XmNpageIncrement resources so the correct ;; thing happens when the user presses the up-page/down-page buttons. ;; Apparently it is not sufficient just to set slider-size. JPM. - (let ((v (convert-scroll-bar-value-out object value))) + (let ((v (silica::convert-scroll-bar-size-out object value))) (tk::set-values mirror :slider-size v :page-increment v))))) (defmethod compose-space ((m motif-scroll-bar) &key width height) @@ -706,7 +713,7 @@ ;; the user presses the up-line/down-line buttons. (tk::set-values mirror :increment - (convert-scroll-bar-value-out object value))))) + (silica::convert-scroll-bar-size-out object value))))) ;; Should we stick in our preferred scroll-bar geometry here? diff --git a/tk-silica/xt-frames.lisp b/tk-silica/xt-frames.lisp index 69256f3c17fb06e02833446972fc55ca4cf28a59..91698ebf81c59ac55aba3243061ee389871399db 100644 --- a/tk-silica/xt-frames.lisp +++ b/tk-silica/xt-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: xt-frames.lisp,v 2.5 2004/01/16 19:15:44 layer Exp $ +;; $Id: xt-frames.lisp,v 2.6 2005/08/03 05:07:14 layer Exp $ (in-package :xm-silica) @@ -88,7 +88,12 @@ (defmethod handle-event (sheet (event window-manager-delete-event)) (let ((frame (pane-frame sheet))) (and frame - (frame-exit frame)))) + (if (typep frame 'clim-internals::accept-values-own-window) + ;; [spr30282] A window-manager-delete-event (i.e. a window close + ;; event) is supposed to equate to a "cancel" gesture. + ;; (alemmens, 2005-07-04) + (abort) + (frame-exit frame))))) ;;; Menu code diff --git a/tk-silica/xt-gadgets.lisp b/tk-silica/xt-gadgets.lisp index 26b91a3410066ef1cc85e70edd6b41cd36f0188b..81cca7a9ebfc616ec30af94de73aead0b7a95428 100644 --- a/tk-silica/xt-gadgets.lisp +++ b/tk-silica/xt-gadgets.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: xt-gadgets.lisp,v 2.5 2004/01/16 19:15:44 layer Exp $ +;; $Id: xt-gadgets.lisp,v 2.6 2005/08/03 05:07:14 layer Exp $ (in-package :xm-silica) @@ -210,56 +210,50 @@ 'sheet-mirror-event-handler sheet)) +;;; +;;; Scroll bar utilities +;;; -;;; scroll bar utilities +;; I moved most of these to silica/gadgets.lisp because they're relevant for +;; all backends. (alemmens, 2004-12-24) (defvar *scroll-bar-quantization* ;; must be a 32-bit quantity. - (min most-positive-fixnum - (1- (expt 2 31)))) + (min most-positive-fixnum + (1- (expt 2 31)))) -(defun convert-scroll-bar-value-out (scroll-bar value) - (multiple-value-bind - (smin smax) (gadget-range* scroll-bar) - (max 0 - (min *scroll-bar-quantization* - (floor - (compute-symmetric-value - smin smax value 0 *scroll-bar-quantization*)))))) - -(defun convert-scroll-bar-value-in (scroll-bar value) - (multiple-value-bind - (smin smax) (gadget-range* scroll-bar) - (max smin - (min smax - (compute-symmetric-value - 0 *scroll-bar-quantization* value smin smax ))))) +(defmethod silica::native-gadget-range* ((scroll-bar scroll-bar)) + ;; Default method for scroll-bars + (values 0 *scroll-bar-quantization*)) (defun compute-new-scroll-bar-values (scroll-bar value slider-size - line-increment - &optional (page-increment slider-size)) + line-increment + &optional (page-increment slider-size)) ;; It needs to be the case that (<= (+ val slider-size) <maximum-sv-value>). ;; This can fail to be true because of rounding errors when ;; converting from float to integer, which cause motif to whine I ;; assume the maximum sv value is *scroll-bar-quantization* (I'm not ;; sure if this is always true), and round the slider size down if ;; the contraint is violated. - (let ((val (and value (convert-scroll-bar-value-out scroll-bar value))) - (ss (and slider-size - (max 1 - (convert-scroll-bar-value-out scroll-bar slider-size))))) + (let ((val (and value (silica::convert-scroll-bar-value-out scroll-bar value))) + (ss (and slider-size + (max 1 + (silica::convert-scroll-bar-size-out scroll-bar slider-size))))) (values val (and ss ;what assumptions about nullness are - (if val ;safe? - (min ss (- *scroll-bar-quantization* val)) - ss)) - (and line-increment - (max 1 (convert-scroll-bar-value-out scroll-bar - line-increment))) - (and page-increment - (max 1 (convert-scroll-bar-value-out scroll-bar - page-increment)))))) - - + (if val ;safe? + (min ss (- *scroll-bar-quantization* val)) + ss)) + (and line-increment + (max 1 (silica::convert-scroll-bar-size-out scroll-bar + line-increment))) + (and page-increment + (max 1 (silica::convert-scroll-bar-size-out scroll-bar + page-increment)))))) + + +;;; +;;; +;;; (defun wait-for-callback-invocation (port predicate &optional (whostate "Waiting for callback")) (if (eq mp:*current-process* (port-process port)) diff --git a/utils/packages.lisp b/utils/packages.lisp index cecfd40f0aae544bcbabfd40ae3ef0a7ac3f2ea2..d4a3ee3adf170c87b7f8bcd5ea53202728a1f3a1 100644 --- a/utils/packages.lisp +++ b/utils/packages.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: packages.lisp,v 2.6 2004/01/16 19:15:45 layer Exp $ +;; $Id: packages.lisp,v 2.7 2005/08/03 05:07:14 layer Exp $ (in-package :common-lisp-user) @@ -3314,4 +3314,4 @@ (cl:push (cl:cons "CLIM" *clim-version*) excl::*version-info*))) #+(version>= 6 0 pre-final 0) -(excl::lb1215005) ;; license check +(excl::lb1215005) ;; rfe4046