diff --git a/ChangeLog.n b/ChangeLog.n index 2b6104acb23726874496d79800bf86823f28d0c9..10ffb2e4ca9db465c7eb123f96dcd0249368556a 100644 --- a/ChangeLog.n +++ b/ChangeLog.n @@ -10,6 +10,52 @@ Tests for new features: <`no new features', `no tests for new features', or <standard changelog date stamp> * <changes go here...> +******************************************************************************* +2.2.1.11 + +Documentation changes: none +Tests for new features: no new features + + +Fri Mar 20 14:10:22 1998 Steve Haflich <smh@romeo> + + * Committing the following merged changes from PNC. + + +Mon Feb 9 18:30:00 1998 jmorrill@pointnclick.com and kreti + + * aclpc/acl-medium: optimize color->wincolor + * aclpc/acl-dc: remove obsolete hash-table from dc-image + * clim/db-stream: + 1. optimize invoke-with-drawing-options + 2. change minimum default-space-requirements from 0 to 1 + * aclpc/acl-frames: + 1. make gesture-spec-for-mswin work for nonprinting characters + 2. add an accelerator table to acl-top-level-sheet + 3. modify note-frame-layout-changed to clear "port-trace-thing" + 4. update make-pane-class to use mswin-scroll-bar instead of the generic one + * aclpc/acl-class: modify clim-wind-proc to + 1. generate presentation-event upon wm_keydown if key is accelerator + 2. utilize the 'hwnd' part of wm_hscroll and wm_vscroll + 3. remove method for wm_setcursor (by commenting out for now) + 4. change register-window-class to take a default cursor + * aclpc/acl-port: change call to register-window-class to pass in default cursor + * tk-silica/xt-graphics: optimize port-draw-rotated-text, medium-draw-text*, + and find-rotated-text-pixmap. + * aclpc/acl-widget: + 1. add an mswin-scroll-bar class and associated methods + 2. fix gadget-value of mswin-text-edit to avoid bashing value to integer + 3. new realize-mirror method for mswin-scroll-bar + * aclpc/acl-prel: open a scrollbar control + * postscript/postscript-port: don't give postscript double-float exponent markers + * Somebody (pr?) put in a lot of calls to scroll-bar-current-size, which does not + exist. Perhaps they meant scroll-bar-size. Remove references in: + silica/db-scroll + silica/gadgets + silica/scroll-pane + clim/prefill + * utils/packages.lisp: incf version number from 4 to 11 + ******************************************************************************* 2.2.1.10 diff --git a/aclpc/acl-class.lisp b/aclpc/acl-class.lisp index d931e994ec9f2a990d095909c745807948fdbb0e..a328dd943e71030ee86ddb166dc4a2e2ddceaee0 100644 --- a/aclpc/acl-class.lisp +++ b/aclpc/acl-class.lisp @@ -363,12 +363,17 @@ (sheet (mirror->sheet *acl-port* window))) (note-pointer-motion *acl-port* sheet mx my))) + #+ignore ;; superseded by setting default cursor in register-window-class ((eql msg win:wm_setcursor) + ;; The MFC doc says DefWindowProc sends a wm_setcursor message + ;; to the parent window, which may explain why we are getting + ;; so many of these, and suggests to me that this response to + ;; the message may be misguided. jpm. (let ((hit-code (pc::loword lparam))) (unless (and (eql hit-code win::htclient) (maybe-set-cursor window)) (setq *cursor-cache* nil) - (setf (pointer-cursor (port-pointer *acl-port*)) :button) + (setf (pointer-cursor (port-pointer *acl-port*)) :default) #+acl86win32 (setq *win-result* (win::defwindowproc window msg wparam lparam)) #+aclpc @@ -576,14 +581,15 @@ *win-result*)) ((or (eql msg win::wm_hscroll) (eql msg win::wm_vscroll)) - (let ((type (pc::loword wparam)) - (position (pc::hiword wparam)) - (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))) - (event nil) - (sheet (mirror->sheet *acl-port* window))) + (let* ((type (pc::loword wparam)) + (position (pc::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))) + (event nil) + (sheet (mirror->sheet *acl-port* hwnd))) (declare (fixnum action position)) (multiple-value-bind (action amount) (cond ((eql type win::sb_lineup) @@ -747,6 +753,10 @@ #+aclpc (ct::%set-long *win-result* 4 0 (win::defwindowproc window msg wparam lparam)) + ;;added this so that port modifier state is always updated, even on passed + ;;characters. -- KR + (setf (port-modifier-state *acl-port*) + (modstate->modifier *modstate*)) *win-result*) (progn (when (and (or (<= #x30 vk #x5a)(<= #xba vk #xc0)(<= #xdb vk #xdf)) @@ -768,19 +778,40 @@ (when (zerop (ldb (byte 2 9) code)) (setf char keysym)) (setf keysym (char->keysym keysym))) - (queue-put event-queue - (allocate-event - (cond ((or (eql msg win:wm_keydown) - (eql msg win:wm_syskeydown)) - 'key-press-event) - ((or (eql msg win:wm_keyup) - (eql msg win:wm_syskeyup)) - 'key-release-event)) - :key-name keysym - :character char - :modifier-state (setf (port-modifier-state *acl-port*) - modstate) - :sheet sheet)) + (let ((frame (pane-frame sheet)) + (command nil)) + (if (and (eql msg win::wm_keydown) + (setq command (lookup-accelerator frame keysym modstate))) + (let ((command-table (frame-command-table frame))) + (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) + )) + + (queue-put event-queue + (allocate-event + (cond ((or (eql msg win:wm_keydown) + (eql msg win:wm_syskeydown)) + 'key-press-event) + ((or (eql msg win:wm_keyup) + (eql msg win:wm_syskeyup)) + 'key-release-event)) + :key-name keysym + :character char + :modifier-state (setf (port-modifier-state *acl-port*) + modstate) + :sheet sheet))) + + ;;added this so that port modifier state is always updated, even on passed + ;;characters. -- KR + (setf (port-modifier-state *acl-port*) + (modstate->modifier *modstate*)) + + ) )) ;; set return value to 0 (clear-winproc-result *win-result*) @@ -1057,7 +1088,7 @@ (defvar *wndclass-registered* nil) #+aclpc -(defun acl-clim::register-window-class () +(defun acl-clim::register-window-class (hcursor) (let ((err1 nil) (err2 nil) (reg nil) @@ -1071,7 +1102,7 @@ win::cbwndextra 0 win::hinstance pc::*hinst* win::hicon (ct::null-handle win::hicon) - win::hcursor (ct::null-handle win::hcursor) + win::hcursor hcursor win::hbrbackground (ct::null-handle win::hbrush) ; (win::GetStockObject win::WHITE_BRUSH) win::lpszmenuname *menu-name* @@ -1218,7 +1249,7 @@ (setq *clim-initialized* t))) #+acl86win32 -(defun acl-clim::register-window-class () +(defun acl-clim::register-window-class (hcursor) ;; initialise window procedure (unless *wndclass-registered* (init-clim-win-proc clim-window-proc-address #.(cg::make-cstructure 0 16)) @@ -1231,7 +1262,7 @@ win::cbWndExtra 0 win::hinstance pc::*hinst* win::hicon (win::LoadIcon pc::*hinst* "ICON_LISP") ;(ct::null-handle win::hicon) - win::hcursor (ct::null-handle win::hcursor) + win::hcursor hcursor win::hbrbackground (ct::null-handle win::hbrush) win::lpszmenuname ct::hnull ;*menu-name* win::lpszclassname *clim-class* @@ -1419,7 +1450,8 @@ ) (when (prog1 (win::peekMessage wmsg (ct::null-handle win::hwnd) 0 0 - (logior win::PM_NOYIELD win::PM_NOREMOVE) wres) + (logior win::PM_NOYIELD win::PM_NOREMOVE) + #+acl86win32x wres) (not (and (zerop (cg::hiword wres)) (zerop (cg::loword wres))))) t))) diff --git a/aclpc/acl-dc.lisp b/aclpc/acl-dc.lisp index 111453b31a500fcc2f7edf55cd4c073eb6350ec0..cd06237f77bd0152f3abc3f958d9fb961764a1de 100644 --- a/aclpc/acl-dc.lisp +++ b/aclpc/acl-dc.lisp @@ -46,7 +46,8 @@ (defstruct (dc-image (:predicate nil)) (bitmap nil) solid-1-pen - (pen-table (make-hash-table)) + ;; 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 diff --git a/aclpc/acl-frames.lisp b/aclpc/acl-frames.lisp index c0d8e02bb7ecd4325b416d3fc570789830ac6173..b3cf83c8509c4f306599d4856f7221a534b766c5 100644 --- a/aclpc/acl-frames.lisp +++ b/aclpc/acl-frames.lisp @@ -70,7 +70,36 @@ (defclass acl-top-level-sheet (top-level-sheet) ((min-width :accessor acl-top-min-width :initform nil) - (min-height :accessor acl-top-min-height :initform nil))) + (min-height :accessor acl-top-min-height :initform nil) + (accelerator-gestures :initform nil :reader top-level-sheet-accelerator-gestures) + )) + +(defun record-accelerator (sheet keysym command) + (push (cons keysym command) + (slot-value sheet 'accelerator-gestures))) + +(defun keysymeql (keysyma keysymb) + (or (eql keysyma keysymb) + (cond ((and (keywordp keysyma) (typep keysymb 'character)) + (eql keysyma (char->keysym keysymb)) + ) + ((and (keywordp keysymb) (typep keysyma 'character)) + (eql keysymb (char->keysym keysyma))) + (t nil)))) + +(defun modstateeql (a b) (eql a b)) + +(defun lookup-accelerator (frame keysym modstate) + (let* ((sheet (frame-top-level-sheet frame)) + (gestures (top-level-sheet-accelerator-gestures sheet))) + (loop with gkeysym and gmodstate + for gesture-and-command in gestures + for (gesture) = gesture-and-command + do (multiple-value-setq (gkeysym gmodstate) + (parse-gesture-spec gesture)) + when (and (keysymeql keysym gkeysym) + (modstateeql modstate gmodstate)) + return (cdr gesture-and-command)))) (defmethod update-frame-settings ((framem acl-frame-manager) (frame t)) @@ -153,28 +182,27 @@ ;(setf (command-enabled command-name frame) enablep) ;(win::EnableMenuItem menu menuid (if enablep pc::MF_ENABLED pc::MF_GRAYED)) +(defun keysym->char (keysym) + (if (typep keysym 'character) + keysym + (let ((entry (rassoc keysym *keysym-alist*)) + (code (position keysym *char->keysym*))) + (if entry + (car entry) + (when code + (code-char code)))))) + (defun gesture-spec-for-mswin (gesture-spec) (let* ((alist '((:shift "SHIFT+") (:control "CTRL+") (:meta "ALT+"))) (keypress (first gesture-spec)) - ;; I think this is what pr meant to do -tjm Aug97 - (nlist (list (or (and (characterp keypress) - (cond ((char= #\Backspace keypress) "Backspace") - ((char= #\space keypress) "Space") - (t keypress))) - keypress)))) + (nlist (list (format nil "~:C" (if (member :shift gesture-spec) + (keysym->char keypress) + (char-downcase (keysym->char keypress))))))) (dolist (shift alist) (when (member (first shift) (rest gesture-spec)) - #-ignore (push (second shift) nlist) - #+ignore - (let ((gesture-mod (second shift))) - (push ;; +++ fix this more generally to deal with all characters - ;; pr Aug97 (what?? -tjm) - (cond ((char= #\Backspace gesture-mod) "Backspace") - ((char= #\space gesture-mod) "Space") - (t gesture-mod)) - nlist)))) + (push (second shift) nlist))) (format nil "~A~{~A~}" #\tab nlist))) (defun make-menu-text (text keystroke item) @@ -227,6 +255,8 @@ (smflags (pc::ilogior flags pc::MF_POPUP))) (case type (:command + (when acckey + (record-accelerator top acckey value)) (let ((menu-item-id (get-command-menu-item-id value frame))) (win::AppendMenu menuhand @@ -333,13 +363,18 @@ #+aclpc (win::pclhandle-value (sheet-mirror sheet)) #+acl86win32 (sheet-mirror sheet))))) -;; added this to workaround some bugs with new layouts not being -;; correctly redisplayed - in particular problems with label-panes -;; - this should be viewed as a temporary fix (cim 10/14/96) - -(defmethod note-frame-layout-changed - :after ((framem acl-frame-manager) frame) - (repaint-sheet (frame-top-level-sheet frame) +everywhere+)) +(defmethod note-frame-layout-changed :after ((framem acl-frame-manager) frame) + ;; added this to workaround some bugs with new layouts not being + ;; correctly redisplayed - in particular problems with label-panes + ;; - this should be viewed as a temporary fix (cim 10/14/96) + (repaint-sheet (frame-top-level-sheet frame) +everywhere+) + ;; Added this next one to fix problem with distribute-event + ;; after changing the layout of the frame. Need to clear + ;; port-trace-thing, otherwise buttons may "go dead" due to a failure + ;; in event distribution. What I don't understand is why Motif doesn't + ;; have to do this. jpm 12/12/97. + (setf (fill-pointer (port-trace-thing (port (frame-manager frame)))) 0) + ) (defmethod frame-manager-note-pretty-name-changed ((framem acl-frame-manager) @@ -488,11 +523,9 @@ (horizontal-divider-pane) (vertical-divider-pane) ))) - (second (assoc class '((scroll-bar scroll-bar-pane) - ;(scroller-pane generic-scroller-pane) - (scroller-pane mswin-scroller-pane) + (second (assoc class '((scroll-bar mswin-scroll-bar) + (scroller-pane silica::mswin-scroller-pane) (viewport viewport) - ; (menu-bar menu-bar-pane) (menu-bar mswin-menu-bar-pane) (menu-bar-button-logic mswin-menu-bar-button) (pull-down-button-logic mswin-pull-down-menu-button) @@ -504,12 +537,10 @@ (top-level-sheet acl-clim::acl-top-level-sheet) (frame-pane frame-pane) (label-pane generic-label-pane) - ;(text-field text-field-pane) ;raw clim text-pane (text-field mswin-text-field) ;;mm: interpose a pane class to manipulate initargs (text-editor acl-clim::acl-text-editor-pane) (list-pane hlist-pane) - ;(option-pane mswin-option-pane) (option-pane mswin-combo-box-pane) ;;--- Need to do these (horizontal-divider-pane) diff --git a/aclpc/acl-medium.lisp b/aclpc/acl-medium.lisp index 5a96f9ee3b4acf93c18ef132d4f60e33ca88493d..c360863de81fc7c2e07d34d7a7c3dfda679be048 100644 --- a/aclpc/acl-medium.lisp +++ b/aclpc/acl-medium.lisp @@ -120,9 +120,12 @@ ;; colors avoiding need for windows to stipple. (cim 10/11/96) (defun color->wincolor (ink) + (declare (optimize (speed 3) (safety 0))) (flet ((convert (x) + (declare (short-float x)) + (setq x (float x)) ; needed? (if (< x 1.0) - (floor (* x #x100)) + (values (the fixnum (floor (the short-float (* x #x100))))) #xff))) (multiple-value-bind (red green blue) (color-rgb ink) diff --git a/aclpc/acl-port.lisp b/aclpc/acl-port.lisp index 7005c278c6741973278b10065c0a74eca49e109b..1897e301703487531e822eca591bbf939973666f 100644 --- a/aclpc/acl-port.lisp +++ b/aclpc/acl-port.lisp @@ -180,7 +180,8 @@ (with-slots (silica::default-palette silica::deep-mirroring vk->keysym) port (setf silica::default-palette (make-palette port :color-p t)) (setf silica::deep-mirroring t) - (register-window-class) + ;;add default cursor to window class -- K Reti + (register-window-class (realize-cursor port :default)) ;(get-clim-icon) +++ (let ((res (ct::callocate :long))) (loop for (vk . keysym) in *vk->keysym* do diff --git a/aclpc/acl-prel.lisp b/aclpc/acl-prel.lisp index 43effe8bdb01bcfb0754d4065c110aa41413a877..4ce28031abc798d784aa395b52d92bd45c07d6f2 100644 --- a/aclpc/acl-prel.lisp +++ b/aclpc/acl-prel.lisp @@ -300,6 +300,34 @@ (showWindow hwnd SW_SHOW))) hwnd)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Open a scrollbar control + +(defun scrollbar-open (parent left top width height orientation) + (let* ((hwnd + (win::createWindowEx + 0 ; style + "SCROLLBAR" ; classname + (cg::nstringify "") ; windowname + (logior (if (eql orientation :horizontal) win::SBS_HORZ win::SBS_VERT) + win::WS_CHILD + win::WS_BORDER + win::WS_CLIPCHILDREN + win::WS_CLIPSIBLINGS) ; style + 0 0 0 0 ; x, y, width, height + parent + (cg::null-handle win::hmenu) + cg::*hinst* + (symbol-name (gensym))))) + (if (cg::null-handle-p hwnd hwnd) + ;; failed + (cerror "proceed" "failed") + ;; else succeed if we can init the position + (win::SetWindowPos hwnd (cg::null-handle hwnd) + left top width height + #.(logior win::SWP_NOACTIVATE win::SWP_NOZORDER))) + hwnd)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Open a botton control diff --git a/aclpc/acl-scroll.lisp b/aclpc/acl-scroll.lisp index 9f16fbf86e0abe7f36449efd4c7d9c557d8b9978..f42719c2ce514c1e22e13f3c07b010cd035236f4 100644 --- a/aclpc/acl-scroll.lisp +++ b/aclpc/acl-scroll.lisp @@ -12,53 +12,6 @@ ;; support for variable thumb size -(in-package :windows) - -#+acl86win32 -(cl:eval-when (cl:compile cl:load cl:eval) - (cl:defconstant SIF_PAGE 2) - (cl:defconstant SIF_POS 4) - (cl:defconstant SIF_DISABLENOSCROLL 8) - (ff:def-foreign-type scrollinfo - (:struct (cbSize uint) - (fMask uint) - (nMin int) - (nMax int) - (nPage uint) - (nPos int) - (nTrackPos int))) - (defctype lpscrollinfo (scrollinfo *))) - -#+acl86win32x ;; won't work, this one not in index -(defapientry setscrollinfo "SetScrollInfo" (hwnd int lpscrollinfo :boolean) - int ??? %oscall) - -#+acl86win32 -(ff:defforeign 'SetScrollInfo - :entry-point "SetScrollInfo" - :arguments '(t t t t) - :return-type :integer) - -#+aclpc ;; the windows package doesn't use cl... -(cl:eval-when (cl:compile cl:load cl:eval) - (cl:defconstant win::SIF_PAGE 2) - (cl:defconstant win::SIF_POS 4) - (cl:defconstant win::SIF_DISABLENOSCROLL 8) - (ct:defcstruct scrollinfo - ((cbSize :unsigned-long) - (fMask :unsigned-long) - (nMin :long) - (nMax :long) - (nPage :unsigned-long) - (nPos :long) - (nTrackPos :long)))) - -#+aclpc -(ct:defun-dll SetScrollInfo ((hwnd :short-handle) (flags :short) (params (scrollinfo *)) (redraw-p :short-bool)) - :return-type :short - :library-name "user32.dll" - :entry-name "SetScrollInfo") - (in-package :silica) (eval-when (compile load eval) @@ -70,6 +23,26 @@ (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 max) (gadget-range* pane) + (setf (gadget-value pane) + (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 *win-scroll-grain*)))))))))))) + (define-event-resource scrollbar-event 10) (defmethod distribute-event ((port acl-clim::acl-port) (event scrollbar-event)) diff --git a/aclpc/acl-widget.lisp b/aclpc/acl-widget.lisp index 7f5e9c6bcac65863b36945318c134ea1947f8a4d..52783d85a194f29f01fa43cd7da183789dd5734f 100644 --- a/aclpc/acl-widget.lisp +++ b/aclpc/acl-widget.lisp @@ -386,10 +386,13 @@ (let* ((wl (win::SendMessage mirror win::WM_GETTEXTLENGTH 0 0 #-acl86win32 :static)) (teb (make-string wl)) (tlen (win::GetWindowText mirror teb (1+ wl)))) + (declare (ignorable tlen)) (setf teb (unxlat-newline-return teb)) ;; pr Aug97 - (setf value (length teb)) + (setf value teb) ;; By the way, does anyone know why the second value is returned? -smh - (values teb tlen)) + (values teb (length teb))) + ;;this used to be (values value (length value)) which I believe is + ;;right -- K. Reti (values value (if (listp value) (length value) 0))))) #+ignore @@ -1065,6 +1068,157 @@ (setf armed t) )))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; scroll-bar + +;; Not to be confused with a scroller-pane, which provides scroll bars +;; to an application pane. This is a naked scroll-bar gadget that +;; acts like a slider gadget. + +(defclass mswin-scroll-bar (silica::acl-gadget-id-mixin + mirrored-sheet-mixin + scroll-bar + sheet-permanently-enabled-mixin + space-requirement-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. + (setf (scroll-bar-size object) (float (/ (gadget-range object) 10)))) + +(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))) + (window nil) + (orientation (gadget-orientation sheet)) + (width (- right left)) + (height (- bottom top)) + (gadget-id (silica::allocate-gadget-id sheet))) + (assert (eq parent parent2) () "parents don't match!") + (setq window + (scrollbar-open parent left top width height orientation)) + (setf (sheet-native-transformation sheet) + (sheet-native-transformation (sheet-parent sheet))) + (setf (silica::gadget-id->window sheet gadget-id) window) + (win::showWindow window win::sw_show) + (setf (sheet-direct-mirror sheet) window) ; needed only to initialize + (change-scroll-bar-values sheet) ; initialize + window))) + +(defmethod compose-space ((m mswin-scroll-bar) &key width height) + (declare (ignore width height)) + (let (x) + (ecase (gadget-orientation m) + (:vertical + (setq x (silica::win-scroll-thick :y)) + (make-space-requirement :width x + :min-height x + :height (* 2 x) + :max-height +fill+)) + (:horizontal + (setq x (silica::win-scroll-thick :x)) + (make-space-requirement :height x + :min-width x + :width (* 2 x) + :max-width +fill+))))) + +(in-package :windows) + +#+acl86win32 +(cl:eval-when (cl:compile cl:load cl:eval) + (cl:defconstant SIF_PAGE 2) + (cl:defconstant SIF_POS 4) + (cl:defconstant SIF_DISABLENOSCROLL 8) + (ff:def-foreign-type scrollinfo + (:struct (cbSize uint) + (fMask uint) + (nMin int) + (nMax int) + (nPage uint) + (nPos int) + (nTrackPos int))) + (defctype lpscrollinfo (scrollinfo *))) + +#+aclpc ;; the windows package doesn't use cl... +(cl:eval-when (cl:compile cl:load cl:eval) + (cl:defconstant win::SIF_PAGE 2) + (cl:defconstant win::SIF_POS 4) + (cl:defconstant win::SIF_DISABLENOSCROLL 8) + (ct:defcstruct scrollinfo + ((cbSize :unsigned-long) + (fMask :unsigned-long) + (nMin :long) + (nMax :long) + (nPage :unsigned-long) + (nPos :long) + (nTrackPos :long)))) + +#+acl86win32x ;; won't work, this one not in index +(defapientry setscrollinfo "SetScrollInfo" (hwnd int lpscrollinfo :boolean) + int ??? %oscall) + +#+acl86win32 +(ff:defforeign 'SetScrollInfo + :entry-point "SetScrollInfo" + :arguments '(t t t t) + :return-type :integer) + +#+aclpc +(ct:defun-dll SetScrollInfo ((hwnd :short-handle) (flags :short) (params (scrollinfo *)) (redraw-p :short-bool)) + :return-type :short + :library-name "user32.dll" + :entry-name "SetScrollInfo") + +(in-package :silica) + +(defmethod change-scroll-bar-values ((sb mswin-scroll-bar) &key + slider-size + value + line-increment + (page-increment slider-size)) + (let ((mirror (sheet-direct-mirror sb))) + (when mirror + (unless slider-size (setq slider-size (scroll-bar-size sb))) + (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 (* *win-scroll-grain* (/ slider-size (+ range slider-size))))) + (win-pos (floor (* (- *win-scroll-grain* slider-size) + (/ (- value min) (- range slider-size)))))) + (ct::csets + win::scrollinfo scrollinfo-struct + win::cbSize (cg::sizeof win::scrollinfo) + win::fMask #.(logior + win::SIF_PAGE + win::SIF_POS + 1 ;win::SIF_RANGE + win::SIF_DISABLENOSCROLL) + win::nMin 0 + win::nMax *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 + (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)))) + +(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)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; pull-down-menu diff --git a/aclpc/clim.ico b/aclpc/clim.ico index 17d8aed49ac7db6f747507b30a4badcd3695f049..70a2c59865d94fb7bd3341341ccfc1da15f5648b 100644 Binary files a/aclpc/clim.ico and b/aclpc/clim.ico differ diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp index 46ae18e86ce8a1f5557753f3e3617a28b0ffc73a..8877a75f286baaef1c485691c933a0a1b3d0d645 100644 --- a/clim/db-stream.lisp +++ b/clim/db-stream.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $Header: /repo/cvs.copy/clim2/clim/db-stream.lisp,v 1.66 1997/10/20 23:10:58 layer Exp $ +;; $Header: /repo/cvs.copy/clim2/clim/db-stream.lisp,v 1.67 1998/03/21 01:54:57 smh Exp $ (in-package :clim-internals) @@ -91,10 +91,11 @@ (defmethod invoke-with-drawing-options ((sheet clim-stream-sheet) continuation - &rest options - &key ink &allow-other-keys) + &rest options) (declare (dynamic-extent options)) - (let* ((medium (sheet-medium sheet)) + ;; Changed arglist to make dynamic-extent declaration effective. JPM Jan 98. + (let* ((ink (second (member :ink options))) + (medium (sheet-medium sheet)) (ink-changing (and ink (not (eq (medium-ink medium) ink))))) (when ink-changing ;; Close the current output record if the drawing ink is changing @@ -108,12 +109,15 @@ (stream-close-text-output-record sheet))))) (defmethod default-space-requirements ((pane clim-stream-sheet) - &key (min-width 0) + &key (min-width 1) (width 100) (max-width +fill+) - (min-height 0) + (min-height 1) (height 100) (max-height +fill+)) + ;; It seems to me that if (method resize-sheet (basic-sheet)) is going to + ;; generate an error for min-width or min-height of zero, then compose-space + ;; had better not suggest zeros by default. Gotta have at least one pixel. JPM (values width min-width max-width height min-height max-height)) (defclass clim-stream-pane (clim-stream-sheet) diff --git a/clim/frames.lisp b/clim/frames.lisp index 414709ad86f5642e5ea59e7d6b8b57569b9497fd..2faeea8e359861758d13ea7001b7b6157725d959 100644 --- a/clim/frames.lisp +++ b/clim/frames.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $Header: /repo/cvs.copy/clim2/clim/frames.lisp,v 1.87 1997/10/04 00:56:25 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/clim/frames.lisp,v 1.88 1998/03/21 01:54:59 smh Exp $ (in-package :clim-internals) @@ -501,7 +501,7 @@ (when port (let ((port-trace-thing (silica::port-trace-thing port))) (when port-trace-thing - (setf (fill-pointer port-trace-thing 0)))))) + (setf (fill-pointer port-trace-thing) 0))))) ;;--- Don't throw, just recompute stream bindings in a principled way (setf (sheet-enabled-p sheets) t)) (note-frame-layout-changed (frame-manager frame) frame) diff --git a/clim/prefill.lisp b/clim/prefill.lisp index 943423ebb00ccdadf0217bf8d3806abb149250e4..4bef53542dea7740646de95a7ff56468852860d1 100644 --- a/clim/prefill.lisp +++ b/clim/prefill.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $Header: /repo/cvs.copy/clim2/clim/prefill.lisp,v 1.17 1997/02/05 01:44:27 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/clim/prefill.lisp,v 1.18 1998/03/21 01:55:01 smh Exp $ (in-package :clim-internals) @@ -2365,14 +2365,6 @@ (scroll-bar-shaft-pane t t) (application-pane t t) (clim-stream-pane t t)) - (scroll-bar-current-size - (scroll-bar-pane)) - ((setf scroll-bar-current-size) - (t scroll-bar-pane)) - (scroll-bar-current-value - (scroll-bar-pane)) - ((setf scroll-bar-current-value) - (t scroll-bar-pane)) (scroller-pane-horizontal-scroll-bar (scroller-pane)) (silica::scroller-pane-scroll-bar-policy diff --git a/postscript/postscript-port.lisp b/postscript/postscript-port.lisp index effea52038cb989cc913c82dc7a8e059b0bc2f5b..d66cd70f1be4ee6cfb3ddecd9e633188376df39b 100644 --- a/postscript/postscript-port.lisp +++ b/postscript/postscript-port.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: POSTSCRIPT-CLIM; Base: 10; Lowercase: Yes -*- -;; $Header: /repo/cvs.copy/clim2/postscript/postscript-port.lisp,v 1.27 1997/10/04 00:56:28 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/postscript/postscript-port.lisp,v 1.28 1998/03/21 01:55:02 smh Exp $ (provide :climps) @@ -358,7 +358,7 @@ ;; Lifted from definition of LGP:FAST-PRINT-NUM in SYS:HARDCOPY;POSTSCRIPT.LISP (if (and (not (zerop n)) (< -1 n 1)) - (format stream "~F" (float n)) + (format stream "~F" (COERCE N 'SINGLE-FLOAT)) ; no double-float exponent markers (multiple-value-bind (integer frac) (etypecase n (integer (values (abs n) 0)) diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp index 74b34e77a63ea8545bd6b870dcfd398ed356ae70..f67b6f5081e2b6cfa7d1809ce76ac049825b0e42 100644 --- a/silica/db-scroll.lisp +++ b/silica/db-scroll.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $Header: /repo/cvs.copy/clim2/silica/db-scroll.lisp,v 1.56 1997/09/03 04:03:36 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/silica/db-scroll.lisp,v 1.57 1998/03/21 01:55:04 smh Exp $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright(c) 1991, 1992 International Lisp Associates. @@ -151,10 +151,6 @@ :horizontal))) ))))))) -#+(or aclpc acl86win32) -(defmethod note-sheet-grafted :before ((sheet scroll-bar)) - (setf (scroll-bar-current-size sheet) nil)) - ;;--- In the case where the viewport is bigger than the window this ;;--- code gets things wrong. Check out the thinkadot demo. It's ;;--- because (- (--) (- vmin)) is negative. @@ -197,8 +193,6 @@ current-value (= current-size size) (= current-value pos)) - #+(or aclpc acl86win32) (setf (scroll-bar-current-value scroll-bar) pos) ;;mm: ??? - #+(or aclpc acl86win32) (setf (scroll-bar-current-size scroll-bar) size) ;;mm: ??? ;;-- It would be nice if we could do this at the point of scrolling (let* ((line-scroll (line-scroll-amount (slot-value scroll-bar 'client) orientation diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp index ff09296c3f5170c985e625b3dac1765cd2a50ef9..c98d8e35b805c5f035008012ad24fb7d6390edf6 100644 --- a/silica/gadgets.lisp +++ b/silica/gadgets.lisp @@ -1,6 +1,6 @@ ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $Header: /repo/cvs.copy/clim2/silica/gadgets.lisp,v 1.64 1997/09/03 04:03:37 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/silica/gadgets.lisp,v 1.65 1998/03/21 01:55:05 smh Exp $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright (c) 1992 by Symbolics, Inc. All rights reserved." @@ -304,11 +304,6 @@ (drag-callback :initarg :drag-callback :initform nil :reader scroll-bar-drag-callback))) -#+(or aclpc acl86win32) -(defmethod destroy-mirror :after ((port basic-port) (sheet scroll-bar)) - ;; This invalidates any caching that is going on - (setf (scroll-bar-current-size sheet) nil)) - (defmethod drag-callback :around ((gadget scroll-bar) (client t) (id t) value) (let ((callback (scroll-bar-drag-callback gadget))) (when callback diff --git a/silica/scroll-pane.lisp b/silica/scroll-pane.lisp index 181b0089b4ae3bdab06a80320834dc458d411d81..c0d5407443da85dfae2c089c404ae93b58c431c6 100644 --- a/silica/scroll-pane.lisp +++ b/silica/scroll-pane.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $Header: /repo/cvs.copy/clim2/silica/scroll-pane.lisp,v 1.7 1997/02/05 01:51:18 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/silica/scroll-pane.lisp,v 1.8 1998/03/21 01:55:06 smh Exp $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright(c) 1991, 1992 International Lisp Associates. @@ -385,7 +385,7 @@ &key slider-size value line-increment) (declare (ignore line-increment)) (setf (gadget-value scroll-bar :invoke-callback nil) value) - (setf (scroll-bar-current-size scroll-bar) slider-size) + ;;(setf (scroll-bar-current-size scroll-bar) slider-size) (let* ((scroller (gadget-client scroll-bar)) (contents (pane-contents scroller))) ;;--- Hmm, if two "linked" panes have callbacks that cause the other @@ -507,7 +507,7 @@ (scroll-value (gadget-value scroll-bar)) (min-value (gadget-min-value scroll-bar)) (max-value (gadget-max-value scroll-bar)) - (gadget-size (or (scroll-bar-current-size scroll-bar) 0)) + (gadget-size 0 #+broken (or (scroll-bar-current-size scroll-bar) 0)) (gadget-range (abs (- max-value min-value))) (identity (sheet-pointer-cursor pane))) (flet ((draw-car (medium left top right bottom which) diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index 693266225b75440b1d3f835d8ffc088dc776e11e..ff3b6b7556e8b9cb8d3d30663a02e099f26e987e 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -19,7 +19,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Header: /repo/cvs.copy/clim2/tk-silica/xt-graphics.lisp,v 1.94 1997/05/31 01:00:46 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/tk-silica/xt-graphics.lisp,v 1.95 1998/03/21 01:55:08 smh Exp $ (in-package :tk-silica) @@ -1547,9 +1547,21 @@ (let ((y-factor 0) (x-factor 1)) - (when (and towards-x towards-y) - (let ((alpha (atan (- towards-y y) (- towards-x x)))) - (setq y-factor (sin alpha) x-factor (cos alpha)))) + (WHEN (AND TOWARDS-X TOWARDS-Y) + (LET ((XXX (- TOWARDS-X X)) + (YYY (- TOWARDS-Y Y))) + (COND ((ZEROP YYY) + (SETQ Y-FACTOR 0) + (SETQ X-FACTOR (IF (MINUSP XXX) -1 1))) + ((ZEROP XXX) + (SETQ X-FACTOR 0) + (SETQ Y-FACTOR (IF (MINUSP YYY) -1 1))) + (T + ;; THIS BRANCH IS RATHER EXPENSIVE. + ;; AVOID THESE CALLS IF THE CALCULATION IS TRIVIAL. JPM. + (LET ((ALPHA (ATAN YYY XXX))) + (SETQ Y-FACTOR (SIN ALPHA)) + (SETQ X-FACTOR (COS ALPHA))))))) (flet ((process-element (codeset start end) (let ((drawable (medium-drawable medium)) @@ -1636,7 +1648,11 @@ (flet ((compute-rotation (x y towards-x towards-y) (decf towards-x x) (decf towards-y y) - (mod (round (atan towards-y towards-x) (/ pi 2.0)) 4))) + #+OLD ; ARE YOU KIDDING? THIS SURE IS THE LONG WAY AROUND THE BARN...JPM + (MOD (ROUND (ATAN TOWARDS-Y TOWARDS-X) (/ PI 2.0)) 4) + (IF (>= TOWARDS-X 0) + (IF (>= TOWARDS-Y 0) 0 2) + (IF (>= TOWARDS-Y 0) 1 3)))) (let* ((rotation (compute-rotation x y towards-x towards-y)) (min-char (xt::font-range font)) (ascent (xt::font-ascent font)) @@ -1689,14 +1705,15 @@ (2 (values (- x pixmap-width) (- y descent))) (3 (values (- x ascent) (- y pixmap-height)))) - (setf (tk::gcontext-clip-mask gcontext) string-pixmap) (decf (ink-gcontext-last-clip-region-tick gcontext)) + (setf (tk::gcontext-clip-mask gcontext) string-pixmap) (setf (tk::gcontext-clip-x-origin gcontext) dst-x (tk::gcontext-clip-y-origin gcontext) dst-y) (tk::draw-rectangle drawable gcontext dst-x dst-y pixmap-width pixmap-height t)))))))) + #+ignore (defun clear-rotation-caches (&optional (port (find-port))) (setf (tk-silica::port-rotated-font-cache port) nil @@ -1835,8 +1852,12 @@ (values string-pixmap pixmap-width pixmap-height))))))) (defun find-rotated-text-pixmap (port font rotation) - (let ((x (assoc (list font rotation) (port-rotated-font-cache port) - :test #'equal))) + (let ((x nil)) + ;; Don't cons a hash key...JPM. + (DOLIST (ITEM (PORT-ROTATED-FONT-CACHE PORT)) + (LET ((KEY (CAR ITEM))) + (WHEN (AND (EQUAL (CAR KEY) FONT) (EQUAL (SECOND KEY) ROTATION)) + (SETQ X ITEM)))) (when x (return-from find-rotated-text-pixmap (values-list (cdr x)))) (multiple-value-bind diff --git a/utils/packages.lisp b/utils/packages.lisp index 11b2aee172b1686d5ccbc9ccac9bb02fc3d9f655..9b5b122c25aee1ee6eb2d61ba238237e6ea9e5d1 100644 --- a/utils/packages.lisp +++ b/utils/packages.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*- -;; $Header: /repo/cvs.copy/clim2/utils/packages.lisp,v 1.82 1998/03/18 20:27:55 layer Exp $ +;; $Header: /repo/cvs.copy/clim2/utils/packages.lisp,v 1.83 1998/03/21 01:55:10 smh Exp $ (in-package :common-lisp-user) @@ -2570,8 +2570,6 @@ radio-box-pane radio-box-selections scroll-bar - #+(or aclpc acl86win32) scroll-bar-current-size - #+(or aclpc acl86win32) scroll-bar-current-value scroll-bar-drag-callback scroll-bar-pane scroll-bar-size @@ -3301,7 +3299,7 @@ (cl:defvar *clim-major-version* 2) (cl:defvar *clim-minor-version* 2) (cl:defvar *clim-generation-version* 1) -(cl:defvar *clim-build-version* 10) +(cl:defvar *clim-build-version* 11) (cl:defparameter *clim-version* (cl:format () "CLIM ~d.~d.~d.~a" @@ -3309,4 +3307,4 @@ *clim-generation-version* *clim-build-version*)) #-aclpc -(si::rcsnote *clim-version* "$Id: packages.lisp,v 1.82 1998/03/18 20:27:55 layer Exp $") +(si::rcsnote *clim-version* "$Id: packages.lisp,v 1.83 1998/03/21 01:55:10 smh Exp $")