Commit 72ac5de9 authored by cer's avatar cer
Browse files

swm_merge

parent 79aa27e9
--------------------------------------------------------------------------------
from swm: Mon Jul 20 13:49:12 PDT 1992
General bug fixing
- Small problem in OUTPUT-RECORD-ELEMENT for STANDARD-SEQUENCE-OUTPUT-RECORD
- Fixed one problem in incremental redisplay of overlapping output
- Fixed GENERATE-CROSSING-EVENTS not to generate exit events when moving
into a child sheet. Controlled by *GENERATE-EXIT-EVENT-WHEN-ENTERING-CHILD*.
- Renamed MOVE-SHEET*, RESIZE-SHEET*, and MOVE-AND-RESIZE-SHEET* to remove the
"*" from the names.
- Made frames such as menus and dialogs position themselves appropriately.
- Made MAKE-APPLICATION-FRAME position the frame to the requested place.
- Made POINTER-SET-POSITION tell the host to actually move the pointer.
*** You will need to implement SILICA:PORT-SET-POINTER-POSITION for the
Motif and OpenLook ports. ***
- Made the port event loops continually update the modifer state slot in
the port object, and the buttons state in the pointer object. This is
needed so that users can reliably query the state of these objects.
- Put INVALIDATE-CACHED-REGIONS and INVALIDATE-CACHED-TRANSFORMATIONS methods
on the proper classes,
- Fix DEFINE-CLX-KEYSYM, DEFINE-GENERA-KEYSYM, and TK-SILICA::DEFINE-KEYSYM
to evaluate their keysym arguments. (Now I know why the keyboard gesture
stuff was not working for you - it worked by accident on Genera.)
- Extended the demo driver functions to take a port argument, so that
the demos can be used simultaneously on multiple ports. (We needed
this for AAAI.)
General performance work
- Added support for resourced events. This feature is off by default while
I finish debugging it. There is a (harmless) storage leak I haven't found
yet, plus one case where events get multiply deallocated. Overall, this
reduces consing tremendously, and has no performance penalty.
- Implemented MAP-OVER-SHEETS-OVERLAPPING-REGION, which is a non-consing
version of CHILDREN-OVERLAPPING-REGION. This gets used all the time.
- Made RESIZE-SHEET, UPDATE-REGION, and VIEWPORT-REGION-CHANGED, and some
other things avoid consing a new region by reusing the old one.
- Added lots of DYNAMIC-EXTENT declarations to avoid consing excessive lexical
closure environments.
- Change SHEET-SINGLE-CHILD-MIXIN so that SHEET-CHILDREN does not cons.
- Optimized DEFINE-GRAPHICS-GENERIC a little more.
- Changed MEDIUM-COPY-AREA methods for Genera and CLX port to call
SHEET-DEVICE-TRANSFORMATION instead of SHEET-NATIVE-TRANSFORMATION.
The two functions always return the same result, but SHEET-NATIVE-TRANSFORMATION
conses each time it is called.
- Changed CURSOR-SET-POSITION to manage the cursor in a speedier way in some
cases (it doesn't notify the host when FASTP is T). There is still a bug that
needs to be fixed by changing one place to bind the cursor off. This makes
text output about 35-40% faster.
- Made INVALIDATE-CACHED-REGIONS set a flag to indicate that the region should
be recomputed. Then SHEET-DEVICE-REGION reuses the previous invalidated
region instead of creating a new one. This save a *lot* of consing during
scrolling.
The Genera port
- Fixed problems in DRAW-PATTERN*
- Fixed some race conditions with Genera's window system
- Made text output twice as fast.
The CLX port
- Made configuration and exposure notifications work correctly.
- Made pixmaps work
--------------------------------------------------------------------------------
from jdi: Tue May 26 09:50:37 PDT 1992
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: accept-values.lisp,v 1.24 92/07/01 15:46:06 cer Exp $
;; $fiHeader: accept-values.lisp,v 1.25 92/07/08 16:29:51 cer Exp $
(in-package :clim-internals)
......@@ -225,12 +225,12 @@
(make-instance 'accept-values-stream
:stream (setf own-window
(make-pane 'clim-stream-pane
:initial-cursor-visibility nil))))
:initial-cursor-visibility nil))))
own-window)))
(outlining ()
(setf exit-button-stream
(make-pane 'clim-stream-pane
:initial-cursor-visibility nil))))))
:initial-cursor-visibility nil))))))
(:menu-bar nil)
(:top-level (accept-values-top-level))
(:command-table accept-values)
......@@ -239,10 +239,11 @@
(defmethod frame-manager-default-exit-boxes ((framem standard-frame-manager))
'((:abort) (:exit)))
(defmethod frame-manager-exit-box-labels ((framem standard-frame-manager) frame)
(declare (ignore frame))
'((:exit "<End> uses these values")
(:abort "<Abort> aborts")))
(defmethod frame-manager-exit-box-labels
((framem standard-frame-manager) frame view)
(declare (ignore frame view))
'((:exit "Exit")
(:abort "Cancel")))
;; So the continuation can run with the proper value of *APPLICATION-FRAME*
(defvar *avv-calling-frame*)
......@@ -321,8 +322,9 @@
(if own-window
#'(lambda (function stream &rest args)
(declare (dynamic-extent args))
(setq help-window (apply #'display-own-window-help
function help-window own-window stream args)))
(setq help-window
(apply #'display-own-window-help
function help-window own-window stream args)))
*accept-help-displayer*)))
(letf-globally (((stream-default-view stream)
(frame-manager-dialog-view (frame-manager frame))))
......@@ -382,14 +384,14 @@
(changing-space-requirements ()
;; We really want to specify the min/max sizes of
;; the exit-button pane also
(size-menu-appropriately exit-button-stream
(size-frame-from-contents exit-button-stream
:size-setter
#'(lambda (pane w h)
(change-space-requirements pane
:width w :min-width w :max-width w
:height h :min-height h :max-height h)))
(when own-window
(size-menu-appropriately own-window
(size-frame-from-contents own-window
:width own-window-width
:height own-window-height
:right-margin own-window-right-margin
......@@ -422,7 +424,8 @@
(when (and own-window-x-position own-window-y-position)
(setq x own-window-x-position
y own-window-y-position))
(position-window-near-carefully own-window x y))
(position-sheet-carefully
(frame-top-level-sheet (pane-frame own-window)) x y))
(window-expose own-window)
(with-input-focus (own-window)
(replay exit-button-record exit-button-stream)
......@@ -460,16 +463,17 @@
(window-inside-size own-window)
(when (or (> new-width width)
(> new-height height))
(size-menu-appropriately own-window
:right-margin own-window-right-margin
:bottom-margin own-window-bottom-margin)))))))
(size-frame-from-contents own-window
:right-margin own-window-right-margin
:bottom-margin own-window-bottom-margin)))))))
(defun display-own-window-help (function stream near-window original-stream &rest args)
(declare (values help-window))
(declare (dynamic-extent args))
(if stream
(setf (window-visibility stream) nil)
(setq stream (allocate-resource 'menu original-stream (window-root original-stream))))
(setq stream (allocate-resource 'menu
original-stream (window-root original-stream))))
(let ((*original-stream* nil) ;--- reset *INPUT-CONTEXT*, too?
(*accept-help-displayer* 'funcall))
(window-clear stream)
......@@ -480,10 +484,11 @@
(fresh-line stream)
(with-text-face (stream :italic)
(write-line "Press any key to remove this window" stream)))))
(size-menu-appropriately stream)
(size-frame-from-contents stream)
(when near-window
(multiple-value-bind (x y) (bounding-rectangle-position near-window)
(position-window-near-carefully stream x y)))
(position-sheet-carefully
(frame-top-level-sheet (pane-frame stream)) x y)))
(window-expose stream)
(clear-input stream)
(unwind-protect
......@@ -502,7 +507,7 @@
;; previous line gets longer. Maybe there should be some better
;; way of ensuring this.
(fresh-line stream)
(let ((labels (frame-manager-exit-box-labels (frame-manager frame) frame)))
(let ((labels (frame-manager-exit-box-labels (frame-manager frame) frame view)))
(updating-output (stream :unique-id stream :cache-value 'exit-boxes)
(with-slots (exit-boxes) frame
(dolist (exit-box exit-boxes)
......@@ -1058,7 +1063,7 @@
(defmethod display-exit-boxes ((frame accept-values) stream (view gadget-dialog-view))
(fresh-line stream)
(let ((labels (frame-manager-exit-box-labels (frame-manager frame) frame)))
(let ((labels (frame-manager-exit-box-labels (frame-manager frame) frame view)))
(with-slots (exit-boxes) frame
(updating-output (stream :unique-id stream
:cache-value 'exit-boxes)
......@@ -1071,9 +1076,9 @@
(formatting-cell (stream)
(with-output-as-gadget (stream)
(make-pane 'push-button
:label label
:client frame :id value
:activate-callback #'handle-exit-box-callback))))))))))
:label label
:client frame :id value
:activate-callback #'handle-exit-box-callback))))))))))
(defun handle-exit-box-callback (gadget)
(let ((id (gadget-id gadget)))
......@@ -1100,7 +1105,7 @@
(let ((sheet (slot-value client 'stream)))
(process-command-event
sheet
(make-instance 'presentation-event
(allocate-event 'presentation-event
:sheet sheet
:presentation-type 'command
:value `(com-change-query ,query ,new-value)
......@@ -1127,9 +1132,8 @@
(cache-value t) (cache-test #'eql)
resynchronize)
(declare (dynamic-extent prompt))
(updating-output
(stream :unique-id query-identifier :id-test #'equal
:cache-value cache-value :cache-test cache-test)
(updating-output (stream :unique-id query-identifier :id-test #'equal
:cache-value cache-value :cache-test cache-test)
(with-output-as-gadget (stream)
(let ((record (stream-current-output-record (slot-value stream 'stream)))
(client (make-instance 'accept-values-command-button
......@@ -1148,8 +1152,8 @@
:type 'command)
*input-context*
;;--- It would be nice if we had the real event...
(make-instance 'pointer-button-press-event
(allocate-event 'pointer-button-press-event
:sheet (sheet-parent button)
:x 0 :y 0
:modifiers 0
:modifier-state 0
:button +pointer-left-button+)))))))))
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: clim-defs.lisp,v 1.9 92/07/01 15:46:09 cer Exp $
;; $fiHeader: clim-defs.lisp,v 1.10 92/07/08 16:29:53 cer Exp $
(in-package :clim-internals)
......@@ -20,21 +20,35 @@
(defun translate-position-sequence (x-delta y-delta positions)
(let ((new-positions (make-list (length positions))))
(do ((positions positions (cddr positions))
(new-positions new-positions (cddr new-positions)))
((null positions))
(let ((x (first positions))
(y (second positions)))
(translate-positions x-delta y-delta x y)
(setf (first new-positions) x)
(setf (second new-positions) y)))
(if (listp positions)
(do ((positions positions (cddr positions))
(new-positions new-positions (cddr new-positions)))
((null new-positions))
(let ((x (first positions))
(y (second positions)))
(translate-positions x-delta y-delta x y)
(setf (first new-positions) x)
(setf (second new-positions) y)))
(do ((i 0 (+ i 2))
(new-positions new-positions (cddr new-positions)))
((null new-positions))
(let ((x (aref positions i))
(y (aref positions (1+ i))))
(translate-positions x-delta y-delta x y)
(setf (first new-positions) x)
(setf (second new-positions) y))))
new-positions))
;; Destructive version of the above
(defun ntranslate-position-sequence (x-delta y-delta positions)
(do ((positions positions (cddr positions)))
((null positions))
(translate-positions x-delta y-delta (first positions) (second positions)))
(if (listp positions)
(do ((positions positions (cddr positions)))
((null positions))
(translate-positions x-delta y-delta (first positions) (second positions)))
(let ((length (length positions)))
(do ((i 0 (+ i 2)))
((>= i length))
(translate-positions x-delta y-delta (aref positions i) (aref positions (1+ i))))))
positions)
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: command-processor.lisp,v 1.9 92/07/06 18:51:32 cer Exp Locker: cer $
;; $fiHeader: command-processor.lisp,v 1.10 92/07/08 16:29:55 cer Exp $
(in-package :clim-internals)
......@@ -146,6 +146,7 @@
(unless keywords (return))
(let ((keyword (parse-keyword arg-parser delimiter-parser stream keywords
keyword-documentation)))
(unless keyword (return)) ;arg unparser can return NIL
(funcall continuation keyword)
(setq keywords (remove keyword keywords)))
(funcall delimiter-parser stream :optional)))
......@@ -231,6 +232,7 @@
(present command-name presentation-type :stream stream
:acceptably acceptably :for-context-type for-context-type)
command-name))
((null args-to-go) nil)
(t (let ((thing (pop args-to-go)))
(if (unsupplied-argument-p thing)
(with-text-face (stream :italic)
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: command.lisp,v 1.9 92/05/22 19:27:45 cer Exp $
;; $fiHeader: command.lisp,v 1.10 92/07/01 15:46:11 cer Exp $
(in-package :clim-internals)
......@@ -538,7 +538,7 @@
(flet ((body (stream)
(format stream "~A" menu)
(when keystroke
(write-string "(" stream)
(write-string " (" stream)
(describe-gesture-spec keystroke :stream stream)
(write-string ")" stream))
(when (eq type ':menu)
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: cursor.lisp,v 1.12 92/07/01 15:46:13 cer Exp $
;; $fiHeader: cursor.lisp,v 1.13 92/07/08 16:29:58 cer Exp $
(in-package :clim-internals)
......@@ -38,7 +38,7 @@
(stream :initarg :stream)
(flags :initform 0 :type fixnum)
(width :initarg :width :type coordinate)
;;-- [cer] Until I can think of somewhere better
;;--- Until I can think of somewhere better --CER
(plist :initform nil))
(:default-initargs :x (coordinate 0) :y (coordinate 0)
:width (coordinate 8)
......@@ -70,19 +70,22 @@
(defmethod* (setf cursor-position) (x y (cursor standard-text-cursor))
(cursor-set-position cursor x y))
(defmethod cursor-set-position ((cursor standard-text-cursor) nx ny)
(with-slots (x y flags) cursor
(defmethod cursor-set-position ((cursor standard-text-cursor) nx ny &optional fastp)
(with-slots (x y flags stream) cursor
(unless (and (= x (coordinate nx))
(= y (coordinate ny)))
(let ((active (cursor-active cursor)))
(unwind-protect
(progn
(if fastp
(setf x (coordinate nx)
y (coordinate ny))
(let ((active (cursor-active cursor)))
(unwind-protect
(progn
(when active
(setf (cursor-active cursor) nil))
(setf x (coordinate nx)
y (coordinate ny)))
(when active
(setf (cursor-active cursor) nil))
(setf x (coordinate nx)
y (coordinate ny)))
(when active
(setf (cursor-active cursor) active)))))))
(setf (cursor-active cursor) active))))))))
#+CLIM-1-compatibility
(define-compatibility-function (cursor-position* cursor-position)
......@@ -197,41 +200,18 @@
;; draw it with new-focus
(draw-cursor cursor stream x y t new)))))
;;; DRAW-CURSOR is invoked to draw or erase the cursor. on-p T = draw it; NIL = erase it
#+Silica
;; DRAW-CURSOR is invoked to draw or erase the cursor.
(defmethod draw-cursor ((cursor standard-text-cursor) stream x y on-p
&optional (focus nil focus-p))
;; --- protocol violations: output-recording-options
;; --- graphics protocol
;; --- output protocol (line-height)
(declare (ignore on-p))
;;--- protocol violations: output recording protocol (with-output-recording-options)
;;--- graphics protocol (draw-rectangle*)
;;--- output protocol (stream-line-height)
(let ((height (stream-line-height stream))
(width (slot-value cursor 'width)))
(unless focus-p (setq focus (cursor-focus cursor)))
(with-output-recording-options (stream :record nil)
(draw-rectangle* stream x y (+ x width) (+ y height) :filled focus
:ink +flipping-ink+)) ;---yetch
;; --- do we really want to do this here??
(draw-rectangle* stream x y (+ x width) (+ y height)
:filled focus
:ink #+++ignore (if on-p +foreground-ink+ +background-ink+)
#---ignore +flipping-ink+))
(force-output stream)))
#-Silica
(defmethod draw-cursor ((cursor standard-text-cursor) on-p)
(with-slots (x y stream) cursor
(when stream
;; --- protocol violations: output-recording-options
;; --- graphics protocol
;; --- output protocol (line-height)
(let ((height (stream-line-height stream)))
(declare (type coordinate height))
(with-output-recording-options (stream :record nil)
(draw-line-internal
stream (coordinate 0) (coordinate 0)
x (+ y height) (+ x 2) (+ y height 2)
(if on-p +foreground-ink+ +background-ink+) +highlighting-line-style+)
(draw-line-internal
stream (coordinate 0) (coordinate 0)
x (+ y height) (- x 2) (+ y height 2)
(if on-p +foreground-ink+ +background-ink+) +highlighting-line-style+))
;; --- do we really want to do this here??
(force-output stream)))))
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;;
;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved.
;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved.
;;
;; The software, data and information contained herein are proprietary
;; to, and comprise valuable trade secrets of, Franz, Inc. They are
;; given in confidence by Franz, Inc. pursuant to a written license
;; agreement, and may be stored and used only in accordance with the terms
;; of such license.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in FAR
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;;;
;;; Copyright (c) 1990 by Xerox Corporations. All rights reserved.
;;;
;; $fiHeader: db-stream.lisp,v 1.22 92/07/06 18:51:34 cer Exp Locker: cer $
;; $fiHeader: db-stream.lisp,v 1.23 92/07/08 16:30:00 cer Exp $
(in-package :clim-internals)
......@@ -42,13 +21,15 @@
sheet-mute-input-mixin
sheet-multiple-child-mixin
space-requirement-mixin
;; We depend on PERMANENT-MEDIUM-SHEET-OUTPUT-MIXIN, which
;; we get from PANE...
pane)
()
(:default-initargs
:medium t
;;:max-width +fill+ :min-width 0
;;:max-height +fill+ :min-height 0
))
;; Make sure that CLIM streams have fresh translation transformation
;; so that we can modify it during scrolling
:transformation (clim-utils::make-translation-transformation-1 0.0f0 0.0f0)))
;;--- Do we still need this?
(defmethod pane-stream ((pane clim-stream-sheet))
......@@ -65,13 +46,15 @@
(declare (ignore viewport)))
(defmethod viewport-region-changed ((pane clim-stream-sheet) viewport)
(setf (sheet-region pane)
(make-bounding-rectangle
0 0
(max (bounding-rectangle-width pane)
(bounding-rectangle-width viewport))
(max (bounding-rectangle-height pane)
(bounding-rectangle-height viewport))))
(let ((region (sheet-region pane)))
;; It should be safe to modify the sheet's region
(setf (slot-value region 'left) 0
(slot-value region 'top) 0
(slot-value region 'right) (max (bounding-rectangle-width pane)
(bounding-rectangle-width viewport))
(slot-value region 'bottom) (max (bounding-rectangle-height pane)
(bounding-rectangle-height viewport)))
(note-sheet-region-changed pane))
(setf (stream-default-text-margin pane)
(bounding-rectangle-width (sheet-region viewport))))
......@@ -79,7 +62,7 @@
&rest options
&key ink &allow-other-keys)
(declare (dynamic-extent options))
(with-sheet-medium (medium sheet)
(let ((medium (sheet-medium sheet)))
;; Close the current output record if the drawing ink is changing
(unless (eq (medium-ink medium) ink)
(stream-close-text-output-record sheet))
......@@ -107,7 +90,10 @@
(defmethod initialize-instance :after
((pane clim-stream-pane) &key &allow-other-keys)
(setf (sheet-transformation pane) +identity-transformation+))
;; Make sure that CLIM streams have fresh translation transformation
;; so that we can modify it during scrolling
(setf (sheet-transformation pane)
(clim-utils::make-translation-transformation-1 0.0f0 0.0f0)))
(defmethod pane-needs-redisplay ((pane clim-stream-pane))
(with-slots (display-time) pane
......@@ -244,17 +230,16 @@
(:line (+ (* number (stream-line-height pane))
(* (1- number) (stream-vertical-spacing pane))))))))
#+++ignore
#+++ignore ;obsolete now that the default coordinate origin is :NW
(defmethod note-sheet-grafted :after ((pane clim-stream-pane))
(let ((xform (sheet-transformation pane)))
(setq xform (make-scaling-transformation 1 -1))
(setf (sheet-transformation pane) xform)))
;;; This is a soon-to-be-obsolete method, but we need it for now when the
;;; CLIM-STREAM-PANE is a child of the old-style viewport. It shouldn't
;;; get called under the new viewport scheme.
#+++ignore
;; This is a soon-to-be-obsolete method, but we need it for now when the
;; CLIM-STREAM-PANE is a child of the old-style viewport. It shouldn't
;; get called under the new viewport scheme.
#+++ignore ;obsolete now that the default coordinate origin is :NW
(defmethod allocate-space :after ((pane clim-stream-pane) width height)
(declare (ignore width height))
(ecase (graft-origin (graft pane))
......@@ -277,18 +262,10 @@
'pane-stream pane))
pane)
#+++ignore
(defmethod update-region ((pane clim-stream-pane) width height
&key no-repaint &allow-other-keys)
(when (pane-scroller pane)
(update-extent (pane-viewport pane) width height
:no-repaint no-repaint)))
;;; ---This assumes that the stream-pane is always inside a viewport, which
;;; actually defines its visible size. The stream pane's size is supposed
;;; to represent the size of the contents, but may be stretched to fill the
;;; available viewport space.
;; This assumes that the stream-pane is always inside a viewport, which
;; actually defines its visible size. The stream pane's size is supposed
;; to represent the size of the contents, but may be stretched to fill the
;; available viewport space.
(defmethod change-space-requirements :around
((pane clim-stream-pane) &rest keys &key width height)
(declare (dynamic-extent keys))
......@@ -339,8 +316,8 @@
(setq pane `(vertically ()
,pane
(make-pane 'label-pane
:text ,label
:max-width +fill+))))
:text ,label
:max-width +fill+))))
`(outlining (:thickness 1)
,pane))))
......@@ -354,20 +331,20 @@
;;; "Window protocol"
(defmethod window-clear ((stream clim-stream-sheet))
(with-sheet-medium (medium stream)
(let ((medium (sheet-medium stream)))
(letf-globally (((medium-transformation medium) +identity-transformation+))
(clear-output-history stream)
(window-erase-viewport stream)
(when (extended-output-stream-p stream) ;can we assume this?
(stream-set-cursor-position stream 0 0)
;; This is important since if the viewport position is at some
;; -ve position then things get really confused since the
;; negative position then things get really confused since the
;; cursor might be visible at (0,0) and the extent is big
;; enough but ....
;;---- This does a lot of uncessary expensive blitblting
;; but how do we avoid it since a lot of what it does we need
;; to reset the viewport
;; enough but...
;;--- This does a lot of uncessary expensive bitblting, but
;;--- how do we avoid, it since a lot of what it does we need
;;--- to do to reset the viewport
(scroll-extent stream :x 0 :y 0)
(stream-set-cursor-position stream 0 0)
(setf (stream-baseline stream) (coordinate 0)
(stream-current-line-height stream) (coordinate 0)))
;; Flush the old mouse position relative to this window
......@@ -391,7 +368,7 @@
(when text-record (replay text-record stream))))
(defmethod window-erase-viewport ((stream window-stream))
(with-sheet-medium (medium stream)
(let ((medium (sheet-medium stream)))
(multiple-value-call #'draw-rectangle*
medium (bounding-rectangle* (or (pane-viewport stream) stream))
:ink +background-ink+)))
......@@ -435,16 +412,15 @@
(sheet-parent window))
(defun window-root (window)
(do ((win window (window-parent win)))
((null (window-parent win))
win)))
(graft window))
(defun window-top-level-window (