Skip to content
Snippets Groups Projects
Commit 979ba695 authored by Kevin Layer's avatar Kevin Layer
Browse files

undo commits fde86cd6f and 98a4b474d

parent 691ae348
No related branches found
No related tags found
No related merge requests found
...@@ -3,11 +3,6 @@ ...@@ -3,11 +3,6 @@
don't forget to change the version in utils/packages.lisp if you do anything don't forget to change the version in utils/packages.lisp if you do anything
user visible. user visible.
******************************************************************************* *******************************************************************************
2009-09-15 Andreas Fuchs <afuchs@franz.com>
* aclpc/acl-mirror.lisp: Restrict window sizes to the maximum available client
rect size for each window. (spr36199).
2009-09-10 Andreas Fuchs <afuchs@franz.com> 2009-09-10 Andreas Fuchs <afuchs@franz.com>
* tk/font.lisp: Fix (obvious, in retrospect) printer error in warning about missing * tk/font.lisp: Fix (obvious, in retrospect) printer error in warning about missing
......
...@@ -36,59 +36,38 @@ ...@@ -36,59 +36,38 @@
;;--- This isn't really right, all ports only have kludges for this ;;--- This isn't really right, all ports only have kludges for this
(defmethod sheet-shell (sheet) sheet) (defmethod sheet-shell (sheet) sheet)
(defun win-full-screen-area ()
"Get the area of the screen that can be occupied by windows (screen - task/tool bars)."
(let ((rect (ct:ccallocate win:rect)))
(win:SystemParametersInfo win:SPI_GETWORKAREA 0 rect 0)
(values (coordinate (ct:cref win:rect rect win::left))
(coordinate (ct:cref win:rect rect win::top))
(coordinate (ct:cref win:rect rect win::right))
(coordinate (ct:cref win:rect rect win::bottom)))))
(defmethod realize-graft ((port acl-port) graft) (defmethod realize-graft ((port acl-port) graft)
(let ((screen (slot-value (screen-device *acl-port*) 'device-handle1))) (let ((screen (slot-value (screen-device *acl-port*) 'device-handle1)))
(setf (port-screen port) screen) (setf (port-screen port) screen)
(init-cursors) (init-cursors)
(with-slots (silica::pixels-per-point (with-slots (silica::pixels-per-point
silica::pixel-width silica::pixel-width
silica::pixel-height silica::pixel-height
silica::mm-width silica::mm-width
silica::mm-height silica::mm-height
silica::units) graft silica::units) graft
(with-dc (screen dc) (with-dc (screen dc)
(multiple-value-bind (screen-left screen-top screen-right screen-bottom) (let ((screen-width (win:GetSystemMetrics win:SM_CXSCREEN))
(win-full-screen-area) (screen-height (win:GetSystemMetrics win:SM_CYSCREEN))
(let ((screen-width (- screen-left screen-right)) (logpixelsx (win:GetDeviceCaps dc win:LOGPIXELSX))
(screen-height (- screen-bottom screen-top)) (logpixelsy (win:GetDeviceCaps dc win:LOGPIXELSY)))
(logpixelsx (win:GetDeviceCaps dc win:LOGPIXELSX)) (setf silica::pixel-width screen-width
(logpixelsy (win:GetDeviceCaps dc win:LOGPIXELSY))) silica::pixel-height screen-height
(setf silica::pixel-width (- screen-left screen-right) silica::mm-width (round (* screen-width 25.4s0) logpixelsx)
silica::pixel-height (- screen-bottom screen-top) silica::mm-height (round (* screen-height 25.4s0) logpixelsy))
silica::mm-width (round (* screen-width 25.4s0) logpixelsx) (let* ((ppp (/ logpixelsy 72s0))
silica::mm-height (round (* screen-height 25.4s0) logpixelsy)) (rounded-ppp (round ppp)))
(let* ((ppp (/ logpixelsy 72s0)) (setf silica::pixels-per-point
(rounded-ppp (round ppp))) (if (< (abs (- ppp rounded-ppp)) .1s0) rounded-ppp ppp)))
(setf silica::pixels-per-point (setf (sheet-region graft)
(if (< (abs (- ppp rounded-ppp)) .1s0) rounded-ppp ppp))) (ecase silica::units
((:device :pixel)
(setf (sheet-region graft) (make-bounding-rectangle
(ecase silica::units 0 0
((:device :pixel) silica::pixel-width silica::pixel-height))))
(make-bounding-rectangle (setf (sheet-native-transformation graft) +identity-transformation+)
screen-left screen-top screen-right screen-bottom)))) (setf (sheet-direct-mirror graft) screen)
(setf (sheet-native-transformation graft) +identity-transformation+) (update-mirror-transformation port graft))))))
(setf (sheet-direct-mirror graft) screen)
(update-mirror-transformation port graft)))))))
(defmethod resize-sheet :around ((sheet acl-top-level-sheet) width height)
"Restrict sheet sizes to the actual available client area."
(multiple-value-bind (-left -top dw dh)
(get-nonclient-deltas sheet)
(declare (ignore -left -top))
(let* ((graft-br (sheet-region (graft sheet)))
(gw (bounding-rectangle-width graft-br))
(gh (bounding-rectangle-height graft-br)))
(call-next-method sheet (min (- gw dw) width) (min (- gh dh) height)))))
(defmethod modal-frame-p ((frame t)) nil) (defmethod modal-frame-p ((frame t)) nil)
(defmethod modal-frame-p ((frame clim-internals::accept-values-own-window)) t) (defmethod modal-frame-p ((frame clim-internals::accept-values-own-window)) t)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment