diff --git a/hemlock/bindings.lisp b/hemlock/bindings.lisp index 1d7089cebd2b2531bff3c1e84abffff2eac76ea8..0a0734ac293f2d6aa77ec087cff14287543e7f40 100644 --- a/hemlock/bindings.lisp +++ b/hemlock/bindings.lisp @@ -10,7 +10,8 @@ ;;; ;;; Some bindings: ;;; -(in-package 'hemlock) + +(in-package "HEMLOCK") @@ -282,6 +283,7 @@ ;;; (bind-key "Illegal" #k"control-x" :mode "Echo Area") (bind-key "Illegal" #k"control-meta-c" :mode "Echo Area") +(bind-key "Illegal" #k"control-meta-s" :mode "Echo Area") (bind-key "Illegal" #k"control-meta-l" :mode "Echo Area") (bind-key "Illegal" #k"meta-x" :mode "Echo Area") (bind-key "Illegal" #k"control-s" :mode "Echo Area") @@ -458,10 +460,11 @@ (bind-key "Add Word to Spelling Dictionary" #k"control-x $") (dolist (info (command-bindings (getstring "Self Insert" *command-names*))) - (let* ((key-event (car info)) - (character (key-event-char (svref (car info) 0)))) + (let* ((key (car info)) + (key-event (svref key 0)) + (character (key-event-char key-event))) (unless (or (alpha-char-p character) (eq key-event #k"'")) - (bind-key "Auto Check Word Spelling" (car info) :mode "Spell")))) + (bind-key "Auto Check Word Spelling" key :mode "Spell")))) (bind-key "Auto Check Word Spelling" #k"return" :mode "Spell") (bind-key "Auto Check Word Spelling" #k"tab" :mode "Spell") (bind-key "Auto Check Word Spelling" #k"linefeed" :mode "Spell") diff --git a/hemlock/bit-screen.lisp b/hemlock/bit-screen.lisp index 343724885423641e2dd58a5a92db44e086babce7..bbbc903f7ff121ea655d2d988fd058d2af0ff113 100644 --- a/hemlock/bit-screen.lisp +++ b/hemlock/bit-screen.lisp @@ -17,16 +17,32 @@ (in-package "HEMLOCK-INTERNALS") -(export '(make-window delete-window next-window previous-window - make-xwindow-like-hwindow *create-window-hook* *delete-window-hook* +(export '(make-xwindow-like-hwindow *create-window-hook* *delete-window-hook* *random-typeout-hook* *create-initial-windows-hook*)) (proclaim '(special *echo-area-window*)) +;;; We have an internal notion of window groups on bitmap devices. Every +;;; Hemlock window has a hunk slot which holds a structure with information +;;; about physical real-estate on some device. Bitmap-hunks have an X window +;;; and a window-group. The X window is a child of the window-group's window. +;;; The echo area, pop-up display window, and the initial window are all in +;;; their own group. +;;; +;;; MAKE-WINDOW splits the current window which is some child window in a group. +;;; If the user supplied an X window, it becomes the parent window of some new +;;; group, and we make a child for the Hemlock window. If the user supplies +;;; ask-user, we prompt for a group/parent window. We link the hunks for +;;; NEXT-WINDOW and PREVIOUS-WINDOW only within a group, so the group maintains +;;; a stack of windows that always fill the entire group window. +;;; + ;;; This is the object set for Hemlock windows. All types of incoming ;;; X events on standard editing windows have the same handlers via this set. -;;; +;;; We also include the group/parent windows in here, but they only handle +;;; :configure-notify events. +;;; (defvar *hemlock-windows* (system:make-object-set "Hemlock Windows" #'ext:default-clx-event-handler)) @@ -457,23 +473,32 @@ ;;; This buys us a lot of events we have to write dummy handlers to ignore. ;;; -;;; HUNK-RECONFIGURED must note that the hunk changed to prevent certain -;;; redisplay problems with recentering the window that caused bogus lines -;;; to be drawn after the actual visible text in the window. We must also -;;; indicate the hunk is trashed to eliminate exposure event handling that -;;; comes after resizing. This also causes a full redisplay on the window -;;; which is the easiest and generall best looking thing. +;;; HUNK-RECONFIGURED -- Internal. +;;; +;;; This must note that the hunk changed to prevent certain redisplay problems +;;; with recentering the window that caused bogus lines to be drawn after the +;;; actual visible text in the window. We must also indicate the hunk is +;;; trashed to eliminate exposure event handling that comes after resizing. +;;; This also causes a full redisplay on the window which is the easiest and +;;; generally best looking thing. ;;; -(defun hunk-reconfigured (hunk event-key event-window window x y width height - border-width above-sibling override-redirect-p - send-event-p) +(defun hunk-reconfigured (object event-key event-window window x y width + height border-width above-sibling + override-redirect-p send-event-p) (declare (ignore event-key event-window window x y border-width above-sibling override-redirect-p send-event-p)) - (when (or (/= width (bitmap-hunk-width hunk)) - (/= height (bitmap-hunk-height hunk))) - ;; Under X11, don't redisplay since an exposure event is coming next. - (hunk-changed hunk width height nil) ; :redisplay) - (setf (bitmap-hunk-trashed hunk) t))) + (typecase object + (bitmap-hunk + (when (or (/= width (bitmap-hunk-width object)) + (/= height (bitmap-hunk-height object))) + (hunk-changed object width height nil) + ;; Under X11, don't redisplay since an exposure event is coming next. + (setf (bitmap-hunk-trashed object) t))) + (window-group + (let ((old-width (window-group-width object)) + (old-height (window-group-height object))) + (when (or (/= width old-width) (/= height old-height)) + (window-group-changed object width height)))))) ;;; (ext:serve-configure-notify *hemlock-windows* #'hunk-reconfigured) @@ -564,21 +589,20 @@ ;;;; Handling boundary crossing events. -;;; Entering and leaving a window are handled basically the same except -;;; that it is possible to get an entering event under X without getting -;;; an exiting event; specifically, when the mouse is in a Hemlock window -;;; that is over another window, and the top window is buried, Hemlock -;;; only gets an entering event on the lower window (no exiting event -;;; for the buried window). -;;; +;;; Entering and leaving a window are handled basically the same except that it +;;; is possible to get an entering event under X without getting an exiting +;;; event; specifically, when the mouse is in a Hemlock window that is over +;;; another window, and someone buries the top window, Hemlock only gets an +;;; entering event on the lower window (no exiting event for the buried +;;; window). +;;; ;;; :enter-notify and :leave-notify events are sent because we select ;;; :enter-window and :leave-window events. ;;; (defun hunk-mouse-entered (hunk event-key event-window root child same-screen-p - x y root-x root-y state time mode kind - send-event-p) - (declare (ignore event-key event-window root child same-screen-p + x y root-x root-y state time mode kind send-event-p) + (declare (ignore event-key event-window child root same-screen-p x y root-x root-y state time mode kind focus-p send-event-p)) (when (and *cursor-dropped* (not *hemlock-listener*)) @@ -587,39 +611,33 @@ (let ((current-hunk (window-hunk (current-window)))) (unless (and *current-highlighted-border* (eq *current-highlighted-border* current-hunk)) - (setf (xlib:window-border (bitmap-hunk-xwindow current-hunk)) + (setf (xlib:window-border (window-group-xparent + (bitmap-hunk-window-group current-hunk))) *highlight-border-pixmap*) (xlib:display-force-output (bitmap-device-display (device-hunk-device current-hunk))) (setf *current-highlighted-border* current-hunk))) - (let ((window (device-hunk-window hunk))) - ;; Why was I ever doing this? - ;; -- (find hunk *window-list* :key #'window-hunk))) - ;; - ;; The random typeout hunk does not have a window. + (let ((window (bitmap-hunk-window hunk))) (when window (invoke-hook ed::enter-window-hook window)))) ;;; (ext:serve-enter-notify *hemlock-windows* #'hunk-mouse-entered) (defun hunk-mouse-left (hunk event-key event-window root child same-screen-p - x y root-x root-y state time mode kind - send-event-p) - (declare (ignore event-key event-window root child same-screen-p + x y root-x root-y state time mode kind send-event-p) + (declare (ignore event-key event-window child root same-screen-p x y root-x root-y state time mode kind focus-p send-event-p)) (setf *hemlock-listener* nil) (when *cursor-dropped* (cursor-invert-center)) (when *current-highlighted-border* - (setf (xlib:window-border (bitmap-hunk-xwindow *current-highlighted-border*)) + (setf (xlib:window-border (window-group-xparent + (bitmap-hunk-window-group + *current-highlighted-border*))) *default-border-pixmap*) (xlib:display-force-output (bitmap-device-display (device-hunk-device *current-highlighted-border*))) (setf *current-highlighted-border* nil)) - (let ((window (device-hunk-window hunk))) - ;; Why was I ever doing this? - ;; -- (find hunk *window-list* :key #'window-hunk))) - ;; - ;; The random typeout hunk does not have a window. + (let ((window (bitmap-hunk-window hunk))) (when window (invoke-hook ed::exit-window-hook window)))) ;;; (ext:serve-leave-notify *hemlock-windows* #'hunk-mouse-left) @@ -632,16 +650,6 @@ "If the window created by splitting a window would be shorter than this, then we create an overlapped window the same size instead.") -(defparameter window-y-offset 20 - "When we create an overlapped window, it is positioned this many pixels - farther down the screen than the current window.") - -(defparameter minimum-y-above-root-bottom 10 - "When we create an overlapped window, if the top of the window is within - this many pixels from the bottom of the root window, then nil is returned - to MAKE-WINDOW.") - -;;; These constants are used in DEFAULT-CREATE-WINDOW-HOOK and SET-HUNK-SIZE. ;;; The width must be that of a tab for the screen image builder, and the ;;; height must be one line (two with a modeline). ;;; @@ -650,13 +658,9 @@ (defconstant minimum-window-columns 8 "Windows must be at least this many characters wide.") -(eval-when (compile load eval) - (defconstant xwindow-border-width 2 "X border around X windows") (defconstant xwindow-border-width*2 (* xwindow-border-width 2)) -); eval-when - ;;; We must name windows (set the "name" property) to get around a bug in ;;; awm and twm. They will not handle menu clicks without a window having ;;; a name. We set the name to this silly thing. @@ -667,52 +671,46 @@ (let ((*print-base* 10)) (format nil "Hemlock ~S" (incf *hemlock-window-count*)))) +(proclaim '(inline surplus-window-height surplus-window-height-w/-modeline)) +;;; +(defun surplus-window-height (thumb-bar-p) + (+ hunk-top-border (if thumb-bar-p + hunk-thumb-bar-bottom-border + hunk-bottom-border))) +;;; +(defun surplus-window-height-w/-modeline (thumb-bar-p) + (+ (surplus-window-height thumb-bar-p) + hunk-modeline-top + hunk-modeline-bottom)) + -;;; DEFAULT-CREATE-WINDOW-HOOK is the default value for *create-window-hook*. -;;; It makes an X window on the given display. Start is a mark into a buffer -;;; for which some Hemlock window is being made for which this X window will -;;; be used. When ask-user is non-nil, we supply x, y, width, and height as -;;; standard properties for the X window which guides the window manager in -;;; prompting the user for a window. When ask-user is nil, and there is a -;;; current window, use it to guide making the new one. As a last resort, -;;; which is only used for creating the initial Hemlock window, create a window -;;; according to some variables, prompting the user when all the variables -;;; aren't there. +;;; DEFAULT-CREATE-WINDOW-HOOK -- Internal. ;;; -(defun default-create-window-hook (display start ask-user x y width height +;;; This is the default value for *create-window-hook*. It makes an X window +;;; for a new group/parent on the given display possibly prompting the user. +;;; +(defun default-create-window-hook (display x y width height name font-family &optional modelinep thumb-bar-p) - (let ((name (buffer-name (line-buffer (mark-line start)))) - (root (xlib:screen-root (xlib:display-default-screen display)))) - (cond (ask-user - (maybe-prompt-user-for-window root x y width height - modelinep thumb-bar-p name)) - (*current-window* - (default-create-window-from-current root name)) - (t - (maybe-prompt-user-for-window - root - (value ed::default-initial-window-x) - (value ed::default-initial-window-y) - (value ed::default-initial-window-width) - (value ed::default-initial-window-height) - modelinep thumb-bar-p name))))) - -;;; MAYBE-PROMPT-USER-FOR-WINDOW makes an X window and sets its standard -;;; properties according to supplied values. When some of these are nil, the -;;; window manager should prompt the user for those missing values when the -;;; window gets mapped. Returns the window without mapping it. -;;; -(defun maybe-prompt-user-for-window (parent x y width height + (maybe-prompt-user-for-window + (xlib:screen-root (xlib:display-default-screen display)) + x y width height font-family modelinep thumb-bar-p name)) + +;;; MAYBE-PROMPT-USER-FOR-WINDOW -- Internal. +;;; +;;; This makes an X window and sets its standard properties according to +;;; supplied values. When some of these are nil, the window manager should +;;; prompt the user for those missing values when the window gets mapped. We +;;; use this when making new group/parent windows. Returns the window without +;;; mapping it. +;;; +(defun maybe-prompt-user-for-window (root x y width height font-family modelinep thumb-bar-p icon-name) - (let* ((extra-y (+ hunk-top-border (if thumb-bar-p - hunk-thumb-bar-bottom-border - hunk-bottom-border))) - (font-height (font-family-height *default-font-family*)) - (font-width (font-family-width *default-font-family*)) - (extra-y-w/-modeline (+ extra-y hunk-modeline-top - hunk-modeline-bottom))) + (let ((font-height (font-family-height font-family)) + (font-width (font-family-width font-family)) + (extra-y (surplus-window-height thumb-bar-p)) + (extra-y-w/-modeline (surplus-window-height-w/-modeline thumb-bar-p))) (create-window-with-properties - parent x y + root x y (if width (+ (* width font-width) hunk-left-border)) (if height (if modelinep @@ -722,141 +720,193 @@ (+ (* minimum-window-columns font-width) hunk-left-border) (if modelinep (+ (* (1+ minimum-window-lines) font-height) extra-y-w/-modeline) - (+ (* minimum-window-lines font-height) extra-y))))) - - -;;; DEFAULT-CREATE-WINDOW-FROM-CURRENT makes a window on the given parent window -;;; according to the current window. We split the current window unless the -;;; result would be too small, in which case we create an overlapped window. -;;; When setting standard properties, we set x, y, width, and height to tell -;;; window managers to put the window where we intend without querying the user. -;;; The window name is set to get around an awm and twm bug that inhibits -;;; menu clicks unless the window has a name; this could be used better. -;;; -(defun default-create-window-from-current (parent icon-name) - (let ((cwin (bitmap-hunk-xwindow (window-hunk *current-window*)))) - (xlib:with-state (cwin) - (let ((cw (xlib:drawable-width cwin)) - (ch (xlib:drawable-height cwin))) - (declare (fixnum cw ch)) - (multiple-value-bind (cx cy) - (window-root-xy cwin (xlib:drawable-x cwin) - (xlib:drawable-y cwin)) - (declare (fixnum cx cy)) - (multiple-value-bind (ch/2 rem) (truncate ch 2) - (declare (fixnum ch/2 rem)) - (let ((newh (- ch/2 xwindow-border-width)) - (font-height (font-family-height *default-font-family*)) - (font-width (font-family-width *default-font-family*))) - (declare (fixnum newh)) - (cond - ((>= newh minimum-window-height) - (let ((win (create-window-with-properties - parent cx (+ cy ch/2 rem xwindow-border-width) - cw newh font-width font-height - icon-name))) - ;; No need to reshape current Hemlock window structure - ;; here since this call will send an appropriate event. - (setf (xlib:drawable-height cwin) (+ newh rem)) - win)) - ((> (+ cy window-y-offset) - (- (xlib:drawable-height parent) minimum-y-above-root-bottom)) - nil) - (t - (create-window-with-properties parent cx (+ cy window-y-offset) - cw ch font-width font-height - icon-name)))))))))) + (+ (* minimum-window-lines font-height) extra-y)) + t))) (defvar *create-window-hook* #'default-create-window-hook - "This function is called by MAKE-WINDOW when it wants to make a new - X window. Hemlock passes as arguments the starting mark, ask-user, default, - and modelinep arguments given to MAKE-WINDOW. The function should return a - window.") + "Hemlock calls this function when it makes a new X window for a new group. + It passes as arguments the X display, x (from MAKE-WINDOW), y (from + MAKE-WINDOW), width (from MAKE-WINDOW), height (from MAKE-WINDOW), a name + for the window's icon-name, font-family (from MAKE-WINDOW), modelinep (from + MAKE-WINDOW), and whether the window will have a thumb-bar meter. The + function returns a window or nil.") +;;; BITMAP-MAKE-WINDOW -- Internal. +;;; (defun bitmap-make-window (device start modelinep window font-family ask-user x y width-arg height-arg) (let* ((display (bitmap-device-display device)) (thumb-bar-p (value ed::thumb-bar-meter)) (hunk (make-bitmap-hunk - :font-family font-family - :end the-sentinel :trashed t - :input-handler #'window-input-handler - :device device - :thumb-bar-p (and modelinep thumb-bar-p)))) - (multiple-value-bind (window width height) - (maybe-make-x-window window display start ask-user - x y width-arg height-arg - modelinep thumb-bar-p) - (unless window (return-from bitmap-make-window nil)) - (setf (bitmap-hunk-xwindow hunk) window) - (setf (bitmap-hunk-gcontext hunk) - (default-gcontext window font-family)) - ;; - ;; Select input and enable event service before showing the window. - (setf (xlib:window-event-mask window) interesting-xevents-mask) - (add-xwindow-object window hunk *hemlock-windows*) - (xlib:map-window window) + :font-family font-family + :end the-sentinel :trashed t + :input-handler #'window-input-handler + :device device + :thumb-bar-p (and modelinep thumb-bar-p)))) + (multiple-value-bind + (xparent xwindow) + (maybe-make-x-window-and-parent window display start ask-user x y + width-arg height-arg font-family + modelinep thumb-bar-p) + (unless xwindow (return-from bitmap-make-window nil)) + (let ((window-group (make-window-group xparent + (xlib:drawable-width xparent) + (xlib:drawable-height xparent)))) + (setf (bitmap-hunk-xwindow hunk) xwindow) + (setf (bitmap-hunk-window-group hunk) window-group) + (setf (bitmap-hunk-gcontext hunk) + (default-gcontext xwindow font-family)) + ;; + ;; Select input and enable event service before showing the window. + (setf (xlib:window-event-mask xwindow) child-interesting-xevents-mask) + (setf (xlib:window-event-mask xparent) group-interesting-xevents-mask) + (add-xwindow-object xwindow hunk *hemlock-windows*) + (add-xwindow-object xparent window-group *hemlock-windows*)) + (when xparent (xlib:map-window xparent)) + (xlib:map-window xwindow) (xlib:display-finish-output display) - ;; A window is not really mapped until it is viewable (not visible). - ;; It is said to be mapped if a map request has been sent whether it - ;; is handled or not. - (loop (when (eq (xlib:window-map-state window) :viewable) + ;; A window is not really mapped until it is viewable. It is said to be + ;; mapped if a map request has been sent whether it is handled or not. + (loop (when (and (eq (xlib:window-map-state xwindow) :viewable) + (eq (xlib:window-map-state xparent) :viewable)) (return))) ;; ;; Find out how big it is... - (if width - (set-hunk-size hunk width height modelinep) - (xlib:with-state (window) - (set-hunk-size hunk (xlib:drawable-width window) - (xlib:drawable-height window) modelinep))) - (setf (bitmap-hunk-window hunk) - (window-for-hunk hunk start modelinep)) - ;; - ;; If there is a current window, link this in after it, otherwise - ;; make this circularly linked, and set *current-window* to it. - (cond (*current-window* - (let ((h (window-hunk *current-window*))) - (shiftf (bitmap-hunk-next hunk) (bitmap-hunk-next h) hunk) - (setf (bitmap-hunk-previous (bitmap-hunk-next hunk)) hunk) - (setf (bitmap-hunk-previous hunk) h))) - (t - (setq *current-window* (bitmap-hunk-window hunk)) - (setf (bitmap-hunk-previous hunk) hunk) - (setf (bitmap-hunk-next hunk) hunk))) - (push hunk (device-hunks device)) - (bitmap-hunk-window hunk)))) - -;;; MAYBE-MAKE-X-WINDOW is called by BITMAP-MAKE-WINDOW. If window is an X -;;; window, we clear it and return the window with its width and height. -;;; Otherwise, we call *create-window-hook* on the other arguments passed in, -;;; returning the created window and nil for the width and height. When a -;;; window is created, it may not be mapped, and, therefore, it's width and -;;; height would not be known. -;;; -(defun maybe-make-x-window (window display start ask-user x y width height - modelinep thumb-bar-p) - (cond (window - (check-type window xlib:window) - (xlib:with-state (window) - (let ((width (xlib:drawable-width window)) - (height (xlib:drawable-height window))) - (xlib:clear-area window :width width :height height) - (values window width height)))) - (t - (let ((window (funcall *create-window-hook* - display start ask-user x y width height - modelinep thumb-bar-p))) - (values window nil nil))))) - -;;; MAKE-XWINDOW-LIKE-HWINDOW makes a new X window that overlays the supplied -;;; Hemlock window. When setting standard properties, we set x, y, width, and -;;; height to tell window managers to put the window where we intend without -;;; querying the user. The window name is set to get around an awm and twm bug -;;; that inhibits menu clicks unless the window has a name; this could be used -;;; better. + (xlib:with-state (xwindow) + (set-hunk-size hunk (xlib:drawable-width xwindow) + (xlib:drawable-height xwindow) modelinep))) + (setf (bitmap-hunk-window hunk) + (window-for-hunk hunk start modelinep)) + ;; If window is non-nil, then it is a new group/parent window, so don't + ;; link it into the current window's group. When ask-user is non-nil, + ;; we make a new group too. + (cond ((or window ask-user) + ;; This occurs when we make the world's first Hemlock window. + (unless *current-window* + (setq *current-window* (bitmap-hunk-window hunk))) + (setf (bitmap-hunk-previous hunk) hunk) + (setf (bitmap-hunk-next hunk) hunk)) + (t + (let ((h (window-hunk *current-window*))) + (shiftf (bitmap-hunk-next hunk) (bitmap-hunk-next h) hunk) + (setf (bitmap-hunk-previous (bitmap-hunk-next hunk)) hunk) + (setf (bitmap-hunk-previous hunk) h)))) + (push hunk (device-hunks device)) + (bitmap-hunk-window hunk))) + +;;; MAYBE-MAKE-X-WINDOW-AND-PARENT -- Internal. +;;; +;;; BITMAP-MAKE-WINDOW calls this. If xparent is non-nil, we clear it and +;;; return it with a child that fills it. If xparent is nil, and ask-user is +;;; non-nil, then we invoke *create-window-hook* to get a parent window and +;;; return it with a child that fills it. By default, we make a child in the +;;; CURRENT-WINDOW's parent. +;;; +(defun maybe-make-x-window-and-parent (xparent display start ask-user x y width + height font-family modelinep thumb-p) + (let ((icon-name (buffer-name (line-buffer (mark-line start))))) + (cond (xparent + (check-type xparent xlib:window) + (let ((width (xlib:drawable-width xparent)) + (height (xlib:drawable-height xparent))) + (xlib:clear-area xparent :width width :height height) + (modify-parent-properties :set xparent modelinep thumb-p + (font-family-width font-family) + (font-family-height font-family)) + (values xparent (xwindow-for-xparent xparent icon-name)))) + (ask-user + (let ((xparent (funcall *create-window-hook* + display x y width height icon-name + font-family modelinep thumb-p))) + (values xparent (xwindow-for-xparent xparent icon-name)))) + (t + (let ((xparent (window-group-xparent + (bitmap-hunk-window-group + (window-hunk (current-window)))))) + (values xparent + (create-window-from-current + font-family modelinep thumb-p xparent icon-name))))))) + +;;; XWINDOW-FOR-XPARENT -- Internal. +;;; +;;; This returns a child of xparent that completely fills that parent window. +;;; We supply the font-width and font-height as nil because these are useless +;;; for child windows. +;;; +(defun xwindow-for-xparent (xparent icon-name) + (xlib:with-state (xparent) + (create-window-with-properties xparent 0 0 + (xlib:drawable-width xparent) + (xlib:drawable-height xparent) + nil nil icon-name))) + +;;; CREATE-WINDOW-FROM-CURRENT -- Internal. +;;; +;;; This makes a child window on parent by splitting the current window. If +;;; the result will be too small, this returns nil. If the current window's +;;; height is odd, the extra pixel stays with it, and the new window is one +;;; pixel smaller. +;;; +(defun create-window-from-current (font-family modelinep thumb-p + parent icon-name) + (let* ((cur-hunk (window-hunk *current-window*)) + (cwin (bitmap-hunk-xwindow cur-hunk))) + ;; Compute current window's height and divide by 2. + (xlib:with-state (cwin) + (let ((cw (xlib:drawable-width cwin)) + (ch (xlib:drawable-height cwin))) + (declare (fixnum cw ch)) + (let ((cy (xlib:drawable-y cwin))) + (declare (fixnum cy)) + (multiple-value-bind (ch/2 rem) (truncate ch 2) + (declare (fixnum ch/2 rem)) + ;; See if we have room for a new window. This should really + ;; check the current window and the new one against their + ;; relative fonts and the minimal window columns and line + ;; (including whether there is a modeline). + + + (let* ((font-height (font-family-height font-family)) + (font-width (font-family-width font-family)) + (cwin-min (minimum-window-height + (font-family-height + (bitmap-hunk-font-family cur-hunk)) + (bitmap-hunk-modeline-pos cur-hunk) + (bitmap-hunk-thumb-bar-p cur-hunk))) + (new-min (minimum-window-height font-height modelinep + thumb-p))) + (if (< (+ cwin-min new-min) ch) + (let ((win (create-window-with-properties + parent 0 (+ cy ch/2 rem) + cw ch/2 font-width font-height + icon-name))) + ;; No need to reshape current Hemlock window structure here + ;; since this call will send an appropriate event. + (setf (xlib:drawable-height cwin) (+ ch/2 rem)) + ;; Set hints on parent, so the user can't resize it to be + ;; smaller than what will hold the current number of + ;; children. + (modify-parent-properties :add parent modelinep + thumb-p + (font-family-width font-family) + font-height) + win) + nil)))))))) + + +;;; MAKE-XWINDOW-LIKE-HWINDOW -- Interface. +;;; +;;; The window name is set to get around an awm and twm bug that inhibits menu +;;; clicks unless the window has a name; this could be used better. ;;; (defun make-xwindow-like-hwindow (window) + "This returns an group/parent xwindow with dimensions suitable for making a + Hemlock window like the argument window. The new window's position should + be the same as the argument window's position relative to the root. When + setting standard properties, we set x, y, width, and height to tell window + managers to put the window where we intend without querying the user." (let* ((hunk (window-hunk window)) + (font-family (bitmap-hunk-font-family hunk)) (xwin (bitmap-hunk-xwindow hunk))) (multiple-value-bind (x y) (window-root-xy xwin) @@ -864,63 +914,112 @@ (xlib:screen-root (xlib:display-default-screen (bitmap-device-display (device-hunk-device hunk)))) x y (bitmap-hunk-width hunk) (bitmap-hunk-height hunk) - (font-family-width *default-font-family*) - (font-family-height *default-font-family*) - (buffer-name (window-buffer window)))))) + (font-family-width font-family) + (font-family-height font-family) + (buffer-name (window-buffer window)) + ;; When the user hands this window to MAKE-WINDOW, it will set the + ;; minimum width and height properties. + nil nil + t)))) ;;;; Deleting a window. -;;; DEFAULT-DELETE-WINDOW-HOOK destroys the X window after obtaining its -;;; necessary state information. If the previous or next window (in that -;;; order) is "stacked" over or under the target window, then it is grown to -;;; fill in the newly opened space. We fetch all the necessary configuration -;;; data up front, so we don't have to call XLIB:DESTROY-WINDOW while in the -;;; XLIB:WITH-STATE. -;;; -(defun default-delete-window-hook (xwin hwin) - (multiple-value-bind (h x y) - (xlib:with-state (xwin) - (multiple-value-bind - (x y) - (window-root-xy xwin (xlib:drawable-x xwin) - (xlib:drawable-y xwin)) - (values (xlib:drawable-height xwin) x y))) - (xlib:destroy-window xwin) - (let ((hunk (window-hunk hwin))) - (xlib:free-gcontext (bitmap-hunk-gcontext hunk)) - (unless (default-delete-window-hook-prev-merge hunk x y h) - (default-delete-window-hook-next-merge hunk x y h))))) +;;; DEFAULT-DELETE-WINDOW-HOOK -- Internal. +;;; +(defun default-delete-window-hook (xparent) + (xlib:destroy-window xparent)) ;;; (defvar *delete-window-hook* #'default-delete-window-hook - "This function is called by DELETE-WINDOW when it wants to delete an X - window. It is passed the X window and the Hemlock window as arguments.") + "Hemlock calls this function to delete an X group/parent window. It passes + the X window as an argument.") -;;; DEFAULT-DELETE-WINDOW-HOOK-PREV-MERGE returns non-nil when the previous -;;; hunk to hunk is grown to take up hunk's space on the screen. + +;;; BITMAP-DELETE-WINDOW -- Internal +;;; +;;; +(defun bitmap-delete-window (window) + (let* ((hunk (window-hunk window)) + (xwindow (bitmap-hunk-xwindow hunk)) + (xparent (window-group-xparent (bitmap-hunk-window-group hunk))) + (display (bitmap-device-display (device-hunk-device hunk)))) + (remove-xwindow-object xwindow) + (setq *window-list* (delete window *window-list*)) + (when (eq *current-highlighted-border* hunk) + (setf *current-highlighted-border* nil)) + (when (and (eq *cursor-hunk* hunk) *cursor-dropped*) (lift-cursor)) + (xlib:display-force-output display) + (bitmap-delete-and-reclaim-window-space xwindow window) + (loop (unless (deleting-window-drop-event display xwindow) (return))) + (let ((device (device-hunk-device hunk))) + (setf (device-hunks device) (delete hunk (device-hunks device)))) + (cond ((eq hunk (bitmap-hunk-next hunk)) + ;; Is this the last window in the group? + (remove-xwindow-object xparent) + (xlib:display-force-output display) + (funcall *delete-window-hook* xparent) + (loop (unless (deleting-window-drop-event display xparent) + (return))) + (let ((window (find-if-not #'(lambda (window) + (eq window *echo-area-window*)) + *window-list*))) + (setf (current-buffer) (window-buffer window) + (current-window) window))) + (t + (modify-parent-properties :delete xparent + (bitmap-hunk-modeline-pos hunk) + (bitmap-hunk-thumb-bar-p hunk) + (font-family-width + (bitmap-hunk-font-family hunk)) + (font-family-height + (bitmap-hunk-font-family hunk))) + (let ((next (bitmap-hunk-next hunk)) + (prev (bitmap-hunk-previous hunk))) + (setf (bitmap-hunk-next prev) next) + (setf (bitmap-hunk-previous next) prev)))) + (let ((buffer (window-buffer window))) + (setf (buffer-windows buffer) (delete window (buffer-windows buffer))))) + nil) + +;;; BITMAP-DELETE-AND-RECLAIM-WINDOW-SPACE -- Internal. +;;; +;;; This destroys the X window after obtaining its necessary state information. +;;; If the previous or next window (in that order) is "stacked" over or under +;;; the target window, then it is grown to fill in the newly opened space. We +;;; fetch all the necessary configuration data up front, so we don't have to +;;; call XLIB:DESTROY-WINDOW while in the XLIB:WITH-STATE. +;;; +(defun bitmap-delete-and-reclaim-window-space (xwindow hwindow) + (multiple-value-bind (y height) + (xlib:with-state (xwindow) + (values (xlib:drawable-y xwindow) + (xlib:drawable-height xwindow))) + (xlib:destroy-window xwindow) + (let ((hunk (window-hunk hwindow))) + (xlib:free-gcontext (bitmap-hunk-gcontext hunk)) + (unless (eq hunk (bitmap-hunk-next hunk)) + (unless (maybe-merge-with-previous-window hunk y height) + (merge-with-next-window hunk y height)))))) + +;;; MAYBE-MERGE-WITH-PREVIOUS-WINDOW -- Internal. ;;; -(defun default-delete-window-hook-prev-merge (hunk x y h) - (declare (fixnum x y h)) +;;; This returns non-nil when it grows the previous hunk to include the +;;; argument hunk's screen space. +;;; +(defun maybe-merge-with-previous-window (hunk y h) + (declare (fixnum y h)) (let* ((prev (bitmap-hunk-previous hunk)) (prev-xwin (bitmap-hunk-xwindow prev))) (xlib:with-state (prev-xwin) - (let ((ph (xlib:drawable-height prev-xwin))) - (declare (fixnum ph)) - (multiple-value-bind (px py) - (window-root-xy prev-xwin - (xlib:drawable-x prev-xwin) - (xlib:drawable-y prev-xwin)) - (declare (fixnum px py)) - (if (and (= x px) - (= y (the fixnum (+ py ph xwindow-border-width*2)))) - (setf (xlib:drawable-height prev-xwin) - (the fixnum (+ ph xwindow-border-width*2 h))))))))) - -;;; DEFAULT-DELETE-WINDOW-HOOK-NEXT-MERGE trys to grow the next hunk's window -;;; to make use of the space created by deleting hunk's window. If this is -;;; possible, then we must also move the next window up to where hunk's window -;;; was. + (if (< (xlib:drawable-y prev-xwin) y) + (incf (xlib:drawable-height prev-xwin) h))))) + +;;; MERGE-WITH-NEXT-WINDOW -- Internal. +;;; +;;; This trys to grow the next hunk's window to make use of the space created +;;; by deleting hunk's window. If this is possible, then we must also move the +;;; next window up to where hunk's window was. ;;; ;;; When we reconfigure the window, we must set the hunk trashed. This is a ;;; hack since twm is broken again and is sending exposure events before @@ -928,101 +1027,25 @@ ;;; reconfigures come before exposures to set the hunk trashed before getting ;;; the exposure. For now, we'll do it here too. ;;; -(defun default-delete-window-hook-next-merge (hunk x y h) - (declare (fixnum x y h)) - (let* ((next (bitmap-hunk-next hunk)) - (next-xwin (bitmap-hunk-xwindow next)) - (newy - (xlib:with-state (next-xwin) - (multiple-value-bind (nx ny) - (window-root-xy next-xwin - (xlib:drawable-x next-xwin) - (xlib:drawable-y next-xwin)) - (declare (fixnum nx ny)) - (when (and (= x nx) - (= ny (the fixnum (+ y h xwindow-border-width*2)))) - ;; Fetch height before setting y to save one extra round trip to - ;; the X server. - (let ((nh (xlib:drawable-height next-xwin))) - (declare (fixnum nh)) - (setf (xlib:drawable-y next-xwin) y) - (setf (xlib:drawable-height next-xwin) - (the fixnum (+ h xwindow-border-width*2 nh)))) - y))))) - (when newy - (setf (bitmap-hunk-trashed next) t) - (let ((hints (xlib:wm-normal-hints next-xwin))) - (setf (xlib:wm-size-hints-y hints) newy) - (setf (xlib:wm-normal-hints next-xwin) hints))))) - -#| -;;; DEFAULT-DELETE-WINDOW-HOOK-NEXT-MERGE ... Hack! -;;; -;;; This version works when window managers refuse to allow clients to -;;; reposition windows. What we do instead is to delete the next hunk's X -;;; window, making a new one in the place of hunk's window that fills the empty -;;; space created by deleting both windows. Some code from the default window -;;; creation hook and BITMAP-MAKE-WINDOW is duplicated here. Also, there is -;;; is a funny issue over whether to invoke the "Make Window Hook" even though -;;; we didn't really make a new Hemlock window. -;;; -(defun default-delete-window-hook-next-merge (hunk x y h) +(defun merge-with-next-window (hunk y h) + (declare (fixnum y h)) (let* ((next (bitmap-hunk-next hunk)) - (next-hwin (device-hunk-window next)) (next-xwin (bitmap-hunk-xwindow next))) - (multiple-value-bind - (nx ny nh) - (xlib:with-state (next-xwin) - (multiple-value-bind (nx ny) - (window-root-xy next-xwin - (xlib:drawable-x next-xwin) - (xlib:drawable-y next-xwin)) - (declare (fixnum nx ny)) - (when (and (= x nx) - (= ny (the fixnum (+ y h xwindow-border-width*2)))) - (values x y (the fixnum (+ h xwindow-border-width*2 - (xlib:drawable-height next-xwin))))))) - (when nx - (let* ((font-family (bitmap-hunk-font-family next)) - (display (bitmap-device-display (device-hunk-device next))) - (nwin (create-window-with-properties - (xlib:screen-root (xlib:display-default-screen display)) - nx ny (bitmap-hunk-width next) nh - (font-family-width font-family) - (font-family-height font-family) - (buffer-name (window-buffer next-hwin))))) - ;; - ;; Delete next's X window. - (remove-xwindow-object next-xwin) - (when (eq *current-highlighted-border* next) - (setf *current-highlighted-border* nil)) - (when (and (eq *cursor-hunk* next) *cursor-dropped*) (lift-cursor)) - (xlib:display-force-output display) - (xlib:destroy-window next-xwin) - (xlib:free-gcontext (bitmap-hunk-gcontext next)) - (loop (unless (deleting-window-drop-event display next-xwin) - (return))) - ;; - ;; Install new X window. - (setf (bitmap-hunk-xwindow next) nwin) - (setf (xlib:window-event-mask nwin) interesting-xevents-mask) - (add-xwindow-object nwin next *hemlock-windows*) - (xlib:map-window nwin) - (xlib:display-finish-output display) - (loop (when (eq (xlib:window-map-state nwin) :viewable) - (return))) - (xlib:with-state (nwin) - (hunk-changed next (xlib:drawable-width nwin) - (xlib:drawable-height nwin) nil)) - ;; This normally occurs as a result of "Make Window Hook". Other - ;; problems may occur if users are using this hook to do things to - ;; their X windows. Invoking this hook here could be bad too since - ;; we didn't really create a new Hemlock window. - (define-window-cursor next-hwin)))))) -|# - -;;; DELETING-WINDOW-DROP-EVENT checks for any events on win. If there is one, -;;; it is removed from the queue, and t is returned. Otherwise, returns nil. + ;; Fetch height before setting y to save an extra round trip to the X + ;; server. + (let ((next-h (xlib:drawable-height next-xwin))) + (setf (xlib:drawable-y next-xwin) y) + (setf (xlib:drawable-height next-xwin) (+ next-h h))) + (setf (bitmap-hunk-trashed next) t) + (let ((hints (xlib:wm-normal-hints next-xwin))) + (setf (xlib:wm-size-hints-y hints) y) + (setf (xlib:wm-normal-hints next-xwin) hints)))) + + +;;; DELETING-WINDOW-DROP-EVENT -- Internal. +;;; +;;; This checks for any events on win. If there is one, remove it from the +;;; queue and return t. Otherwise, return nil. ;;; (defun deleting-window-drop-event (display win) (xlib:display-finish-output display) @@ -1036,30 +1059,59 @@ result)) -;;; BITMAP-DELETE-WINDOW -- Internal +;;; MODIFY-PARENT-PROPERTIES -- Internal. ;;; +;;; This adds or deletes from xparent's min-height and min-width hints, so the +;;; window manager will hopefully prevent users from making a window group too +;;; small to hold all the windows in it. We add to the height when we split +;;; windows making additional ones, and we delete from it when we delete a +;;; window. ;;; -(defun bitmap-delete-window (window) - (let* ((hunk (window-hunk window)) - (xwindow (bitmap-hunk-xwindow hunk)) - (display (bitmap-device-display (device-hunk-device hunk)))) - (remove-xwindow-object xwindow) - (setq *window-list* (delete window *window-list*)) - (when (eq *current-highlighted-border* hunk) - (setf *current-highlighted-border* nil)) - (when (and (eq *cursor-hunk* hunk) *cursor-dropped*) (lift-cursor)) - (xlib:display-force-output display) - (funcall *delete-window-hook* xwindow window) - (loop (unless (deleting-window-drop-event display xwindow) (return))) - (let ((device (device-hunk-device hunk))) - (setf (device-hunks device) (delete hunk (device-hunks device)))) - (let ((next (bitmap-hunk-next hunk)) - (prev (bitmap-hunk-previous hunk))) - (setf (bitmap-hunk-next prev) next) - (setf (bitmap-hunk-previous next) prev) - (let ((buffer (window-buffer window))) - (setf (buffer-windows buffer) (delete window (buffer-windows buffer)))))) - nil) +;;; NOTE, THIS FAILS TO MAINTAIN THE WIDTH CORRECTLY. We need to maintain the +;;; width as the MAX of all the windows' minimal widths. A window's minimal +;;; width is its font's width multiplied by minimum-window-columns. +;;; +(defun modify-parent-properties (type xparent modelinep thumb-p + font-width font-height) + (let ((hints (xlib:wm-normal-hints xparent))) + (xlib:set-wm-properties + xparent + :resource-name "Hemlock" + :x (xlib:wm-size-hints-x hints) + :y (xlib:wm-size-hints-y hints) + :width (xlib:drawable-width xparent) + :height (xlib:drawable-height xparent) + :user-specified-position-p t + :user-specified-size-p t + :width-inc (xlib:wm-size-hints-width-inc hints) + :height-inc (xlib:wm-size-hints-height-inc hints) + :min-width (or (xlib:wm-size-hints-min-width hints) + (+ (* minimum-window-columns font-width) hunk-left-border)) + :min-height + (let ((delta (minimum-window-height font-height modelinep thumb-p))) + (ecase type + (:delete + (let ((min-height (xlib:wm-size-hints-min-height hints))) + (unless hints + (error "Existing parent has no min-height hit?!")) + (- min-height delta))) + (:add + (+ (or (xlib:wm-size-hints-min-height hints) 0) + delta)) + (:set delta)))))) + +;;; MINIMUM-WINDOW-HEIGHT -- Internal. +;;; +;;; This returns the minimum height necessary for a window given some of its +;;; parameters. This is the number of lines times font-height plus any extra +;;; pixels for aesthetics. +;;; +(defun minimum-window-height (font-height modelinep thumb-p) + (if modelinep + (+ (* (1+ minimum-window-lines) font-height) + (surplus-window-height-w/-modeline thumb-p)) + (+ (* minimum-window-lines font-height) + (surplus-window-height thumb-p)))) @@ -1157,12 +1209,9 @@ :border-width xwindow-border-width :border *default-border-pixmap* :event-mask random-typeout-xevents-mask - :override-redirect :on :class :input-output)))) + :override-redirect :on :class :input-output + :cursor *hemlock-cursor*)))) (gcontext (if (not window) (default-gcontext win)))) - (unless window - (xlib:with-state (win) - (setf (xlib:window-event-mask win) random-typeout-xevents-mask) - (setf (xlib:window-cursor win) *hemlock-cursor*))) (values win gcontext))) (defvar *random-typeout-hook* #'default-random-typeout-hook @@ -1293,28 +1342,36 @@ ;;; name; this could be used better. ;;; (defun default-create-initial-windows-hook (device) - (let* ((main-win (make-window (buffer-start-mark *current-buffer*) - :device device)) - (main-xwin (bitmap-hunk-xwindow (window-hunk main-win))) - (root (xlib:screen-root (xlib:display-default-screen - (bitmap-device-display device))))) - (multiple-value-bind - (echo-x echo-y echo-width echo-height f-width f-height) - (default-create-initial-windows-echo - (xlib:drawable-height root) - (bitmap-hunk-font-family (window-hunk main-win)) - main-xwin) - (let ((echo-win (create-window-with-properties - root echo-x echo-y echo-width echo-height - f-width f-height "Echo Area"))) - (setf *echo-area-window* - (hlet ((ed::thumb-bar-meter nil)) - (make-window - (buffer-start-mark *echo-area-buffer*) - :device device :window echo-win - :modelinep t))))) - (setf *current-window* main-win) - (setf (xlib:window-border main-xwin) *highlight-border-pixmap*))) + (let ((root (xlib:screen-root (xlib:display-default-screen + (bitmap-device-display device))))) + (let* ((xwindow (maybe-prompt-user-for-window + root + (value ed::default-initial-window-x) + (value ed::default-initial-window-y) + (value ed::default-initial-window-width) + (value ed::default-initial-window-height) + *default-font-family* + t ;modelinep + (value ed::thumb-bar-meter) + "Hemlock"))) + (setf (xlib:window-border xwindow) *highlight-border-pixmap*) + (let ((main-win (make-window (buffer-start-mark *current-buffer*) + :device device + :window xwindow))) + (multiple-value-bind + (echo-x echo-y echo-width echo-height) + (default-create-initial-windows-echo + (xlib:drawable-height root) + (window-hunk main-win)) + (let ((echo-xwin (make-echo-xwindow root echo-x echo-y echo-width + echo-height))) + (setf *echo-area-window* + (hlet ((ed::thumb-bar-meter nil)) + (make-window + (buffer-start-mark *echo-area-buffer*) + :device device :modelinep t + :window echo-xwin))))) + (setf *current-window* main-win))))) ;;; DEFAULT-CREATE-INITIAL-WINDOWS-ECHO makes the echo area window as wide as ;;; the main window and places it directly under it. If the echo area does not @@ -1324,41 +1381,51 @@ ;;; managers (awm and twm) reparent the window, so we have to make sure ;;; main-xwin's x and y are relative to the root and not some false parent. ;;; -(defun default-create-initial-windows-echo (full-height font-family main-xwin) +(defun default-create-initial-windows-echo (full-height hunk) (declare (fixnum full-height)) - (xlib:with-state (main-xwin) - (let ((w (xlib:drawable-width main-xwin)) - (h (xlib:drawable-height main-xwin))) - (declare (fixnum w h)) - (multiple-value-bind (x y) - (window-root-xy main-xwin - (xlib:drawable-x main-xwin) - (xlib:drawable-y main-xwin)) - (declare (fixnum x y)) - (let* ((ff-height (font-family-height font-family)) - (ff-width (font-family-width font-family)) - (echo-height (+ (* ff-height 4) - hunk-top-border hunk-bottom-border - hunk-modeline-top hunk-modeline-bottom))) - (declare (fixnum echo-height)) - (if (<= (+ y h echo-height xwindow-border-width*2) full-height) - (values x (+ y h xwindow-border-width*2) - w echo-height ff-width ff-height) - (let* ((newh (- full-height y echo-height xwindow-border-width*2 - ;; Since y is really the outside y, subtract - ;; two more borders, so the echo area's borders - ;; both appear on the screen. - xwindow-border-width*2))) - (setf (xlib:drawable-height main-xwin) newh) - (values x (+ y newh xwindow-border-width*2) - w echo-height ff-width ff-height)))))))) + (let ((font-family (bitmap-hunk-font-family hunk)) + (xwindow (bitmap-hunk-xwindow hunk)) + (xparent (window-group-xparent (bitmap-hunk-window-group hunk)))) + (xlib:with-state (xwindow) + (let ((w (xlib:drawable-width xwindow)) + (h (xlib:drawable-height xwindow))) + (declare (fixnum w h)) + (multiple-value-bind (x y) + (window-root-xy xwindow + (xlib:drawable-x xwindow) + (xlib:drawable-y xwindow)) + (declare (fixnum x y)) + (let* ((ff-height (font-family-height font-family)) + (ff-width (font-family-width font-family)) + (echo-height (+ (* ff-height 4) + hunk-top-border hunk-bottom-border + hunk-modeline-top hunk-modeline-bottom))) + (declare (fixnum echo-height)) + (if (<= (+ y h echo-height xwindow-border-width*2) full-height) + (values x (+ y h xwindow-border-width*2) + w echo-height ff-width ff-height) + (let* ((newh (- full-height y echo-height xwindow-border-width*2 + ;; Since y is really the outside y, subtract + ;; two more borders, so the echo area's borders + ;; both appear on the screen. + xwindow-border-width*2))) + (setf (xlib:drawable-height xparent) newh) + (values x (+ y newh xwindow-border-width*2) + w echo-height ff-width ff-height))))))))) (defvar *create-initial-windows-hook* #'default-create-initial-windows-hook - "This function is used when the screen manager is initialized to make the - first windows, typically the main and echo area windows. It takes a + "Hemlock uses this function when it initializes the screen manager to make + the first windows, typically the main and echo area windows. It takes a Hemlock device as a required argument. It sets *current-window* and *echo-area-window*.") +(defun make-echo-xwindow (root x y width height) + (let* ((font-width (font-family-width *default-font-family*)) + (font-height (font-family-height *default-font-family*))) + (create-window-with-properties root x y width height + font-width font-height + "Echo Area" nil nil t))) + (defun init-bitmap-screen-manager (display) ;; ;; Setup stuff for X interaction. @@ -1390,16 +1457,6 @@ ;; Create initial windows. (funcall *create-initial-windows-hook* device) ;; - ;; Unlink the echo area window from the next/prev list. - (let* ((hunk (window-hunk *echo-area-window*)) - (next (bitmap-hunk-next hunk)) - (prev (bitmap-hunk-previous hunk))) - (setf (bitmap-hunk-next prev) next) - (setf (bitmap-hunk-previous next) prev) - (setf (bitmap-hunk-previous hunk) hunk) - (setf (bitmap-hunk-next hunk) hunk) - (setf (bitmap-hunk-thumb-bar-p hunk) nil)) - ;; ;; Setup random typeout over the user's main window. (let ((xwindow (bitmap-hunk-xwindow (window-hunk *current-window*)))) (xlib:with-state (xwindow) @@ -1491,6 +1548,34 @@ (funcall (bitmap-hunk-changed-handler hunk) hunk) (when redisplay (dumb-window-redisplay (bitmap-hunk-window hunk)))) +(defun window-group-changed (window-group new-width new-height) + (let ((xparent (window-group-xparent window-group)) + (affected-windows nil) + (count 0)) + (setf (window-group-width window-group) new-width) + (setf (window-group-height window-group) new-height) + (dolist (window *window-list*) + (let ((test (window-group-xparent (bitmap-hunk-window-group + (window-hunk window))))) + (when (eq test xparent) + (push window affected-windows) + (incf count)))) + (multiple-value-bind + (pixels-per-window remainder) + (truncate new-height count) + (let ((count-1 (1- count))) + (do ((windows affected-windows (cdr windows)) + (i 0 (1+ i))) + ((endp windows)) + (let ((xwindow (bitmap-hunk-xwindow (window-hunk (car windows))))) + (setf (xlib:drawable-y xwindow) (* i pixels-per-window)) + (setf (xlib:drawable-width xwindow) new-width) + (if (= i count-1) + (return (setf (xlib:drawable-height + (bitmap-hunk-xwindow + (window-hunk (car windows)))) + (+ pixels-per-window remainder))) + (setf (xlib:drawable-height xwindow) pixels-per-window)))))))) ;;; SET-HUNK-SIZE -- Internal ;;; @@ -1523,6 +1608,8 @@ (if modelinep (- h font-height hunk-modeline-top hunk-modeline-bottom)))))) +;;; BITMAP-HUNK-BOTTOM-BORDER -- Internal. +;;; (defun bitmap-hunk-bottom-border (hunk) (if (bitmap-hunk-thumb-bar-p hunk) hunk-thumb-bar-bottom-border @@ -1571,14 +1658,16 @@ ;;; min-height are optional and only used for prompting the user for a window. ;;; (defun create-window-with-properties (parent x y w h font-width font-height - icon-name &optional min-width min-height) - (let ((win (xlib:create-window - :parent parent :x (or x 0) :y (or y 0) - :width (or w 0) :height (or h 0) - :background *default-background-pixel* - :border-width xwindow-border-width - :border *default-border-pixmap* - :class :input-output))) + icon-name + &optional min-width min-height + window-group-p) + (let* ((win (xlib:create-window + :parent parent :x (or x 0) :y (or y 0) + :width (or w 0) :height (or h 0) + :background (if window-group-p :none *default-background-pixel*) + :border-width (if window-group-p xwindow-border-width 0) + :border (if window-group-p *default-border-pixmap* nil) + :class :input-output))) (xlib:set-wm-properties win :name (new-hemlock-window-name) :icon-name icon-name :resource-name "Hemlock" @@ -1614,7 +1703,7 @@ (or (not (eq auto :echo-only)) (eq window *echo-area-window*))) (let* ((hunk (window-hunk window)) - (win (bitmap-hunk-xwindow hunk))) + (win (window-group-xparent (bitmap-hunk-window-group hunk)))) (xlib:map-window win) (setf (xlib:window-priority win) :above) (xlib:display-force-output diff --git a/hemlock/filecoms.lisp b/hemlock/filecoms.lisp index 554a7217a130328432620aa17b97332a4c5910a1..599a9b1eb178103af736e3a1e5ba28b18bb419c8 100644 --- a/hemlock/filecoms.lisp +++ b/hemlock/filecoms.lisp @@ -1010,10 +1010,10 @@ "Delete the current window, going to the previous window." "Delete the window we are in, going to the previous window." (declare (ignore p)) + (when (= (length *window-list*) 2) + (editor-error "Cannot delete only window.")) (let ((window (current-window))) - (previous-window-command ()) - (when (eq (current-window) window) - (editor-error "Cannot delete current window.")) + (previous-window-command nil) (delete-window window))) (defcommand "Line to Top of Window" (p) @@ -1027,8 +1027,7 @@ "Deletes the next window on display." "Deletes then next window on display." (declare (ignore p)) - (if (eq (next-window (current-window)) - (current-window)) + (if (<= (length *window-list*) 2) (editor-error "Cannot delete only window") (delete-window (next-window (current-window))))) diff --git a/hemlock/hemlock.log b/hemlock/hemlock.log index e28ad8fb89440aaf956b29aa6de1d5df606ee400..3441e3baf037867c8510e87259f71291d01e54c6 100644 --- a/hemlock/hemlock.log +++ b/hemlock/hemlock.log @@ -1,3 +1,85 @@ +.../systems-work/hemlock/mh.lisp, 18-Oct-90 13:41:38, Edit by Chiles. + MAYBE-DELETE-EXTRA-DRAFT-WINDOW modified to correctly delete another window + if one exists when a draft is a split window draft. This had to be modified + to handle separate, unstacked windows correctly. + +.../systems-work/hemlock/bindings.lisp, 06-Sep-90 16:59:32, Edit by Chiles. + We failed to avoid binding "Auto Check Word Spelling" to #k"'" when we added + the new key-event stuff. Actually, Blaine did. + +.../systems-work/hemlock/bindings.lisp, 24-Aug-90 14:04:34, Edit by Chiles. + Bound C-M-s (typically "Shell") to "Illegal" in the echo area. + +.../systems-work/hemlock/bit-screen.lisp, 06-Aug-90 13:48:10, Edit by Chiles. + I modified CREATE-WINDOW-FROM-CURRENT to correctly determin if there is + enough room to split the current window to make the new window. + +.../systems-work/hemlock/bit-screen.lisp, 06-Aug-90 12:59:40, Edit by Chiles. + Made SET-WINDOW-HOOK-RAISE-FUN frob the windows group X window, instead of + the child X window. + +.../systems-work/hemlock/hunk-draw.lisp, 05-Aug-90 12:57:21, Edit by Chiles. + Fixed DROP-CURSOR to beat on the parent borders instead of the non-existent + child borders. + +.../systems-work/hemlock/bit-screen.lisp, 05-Aug-90 11:58:46, Edit by Chiles. + Removed exports for MAKE-WINDOW, DELETE-WINDOW, NEXT-WINDOW, and + PREVIOUS-WINDOW since they're in screen.lisp. + + Modified HUNK-RECONFIGURED to realize it object arg is either a hunk (for a + child changing) or a window-group (for a group/parent window changing). + + Modified HUNK-MOUSE-ENTERED and HUNK-MOUSE-LEFT to frob the group window's + border instead of the child's border. + + Totally redefined *create-window-hook* and *delete-window-hook*. This + affected most of the arrangement of creation and deletion functionality. + + Made the random-typeout window made from keeping a pop-up display, adhere to + the minimum resizing parameters Hemlock windows like to try to keep users + from screwing themselves. + + Made MAYBE-MAKE-X-WINDOW-AND-PARENT set window manager hints for supplied + parents as if Hemlock had made the parent window. + + Made code correctly handle font-family parameters instead of dropping into + lower-level code that incorrectly assumed *default-font-family*. + + Consolidated some code, notably MODIFY-PARENT-PROPERTIES. + + +.../systems-work/hemlock/xcoms.lisp, 01-Aug-90 14:00:43, Edit by Chiles. + Blew away "Stack Window". + +.../systems-work/hemlock/input.lisp, 01-Aug-90 13:49:27, Edit by Chiles. + Blaine modified MAYBE-KEEP-RANDOM-TYPEOUT-WINDOW in accordance with the new + bitmap window group stuff. + +.../systems-work/hemlock/filecoms.lisp, 01-Aug-90 11:23:07, Edit by Chiles. + Blaine modified "Delete Window" and "Delete Next Window" in accordance with + the new bitmap window group stuff. They now test the length of *window-list* + to determine if they can delete the window instead of using next and previous + window commands and primitives and testing against the CURRENT-WINDOW. + +.../systems-work/hemlock/screen.lisp, 01-Aug-90 10:15:53, Edit by Chiles. + Blaine modified DELETE-WINDOW to test for *window-list* having length two or + less, signalling an error if so. This allows the bitmap window deletion + method to delete the current window by changing to another group. The + "Delete Window" command cannot tell there are other windows, and it already + tries to make the previous window the current one before calling the + DELETE-WINDOW primitive. With the new bitmap window groups, this doesn't + work. We still have a problem if a programmer calls DELETE-WINDOW on the + current window which will break Hemlock. + +.../systems-work/hemlock/rompsite.lisp, 01-Aug-90 09:33:02, Edit by Chiles. + Blaine modified the X events masks and the raising and lowering of Hemlock + windows upon entering and leaving in accordance with the new bitmap window + groups. + +.../systems-work/hemlock/struct.lisp, 01-Aug-90 09:07:25, Edit by Chiles. + Blaine added window-group structure and the window-group slot to + bitmap-hunks for the new bitmap window groups. + .../systems-work/hemlock/keysym-defs.lisp, 04-Jul-90 12:14:09, Edit by Chiles. Added a few key-event to character translations at the end of the file to make quoting characters work better when running under X. diff --git a/hemlock/hunk-draw.lisp b/hemlock/hunk-draw.lisp index 39462830d1ab52c3720fc5eee28c1e51be9498d6..b39b53190bdf4b9e759260339548223eb64667e0 100644 --- a/hemlock/hunk-draw.lisp +++ b/hemlock/hunk-draw.lisp @@ -347,13 +347,20 @@ (cond (*current-highlighted-border* (unless (eq *current-highlighted-border* *cursor-hunk*) (setf (xlib:window-border - (bitmap-hunk-xwindow *current-highlighted-border*)) + (window-group-xparent + (bitmap-hunk-window-group *current-highlighted-border*))) *default-border-pixmap*) - (setf (xlib:window-border (bitmap-hunk-xwindow *cursor-hunk*)) + (setf (xlib:window-border + (window-group-xparent + (bitmap-hunk-window-group *cursor-hunk*))) *highlight-border-pixmap*) + ;; For complete gratuitous pseudo-generality, should force + ;; output on *current-highlighted-border* device too. (xlib:display-force-output (bitmap-device-display (device-hunk-device *cursor-hunk*))))) - (t (setf (xlib:window-border (bitmap-hunk-xwindow *cursor-hunk*)) + (t (setf (xlib:window-border + (window-group-xparent + (bitmap-hunk-window-group *cursor-hunk*))) *highlight-border-pixmap*) (xlib:display-force-output (bitmap-device-display (device-hunk-device *cursor-hunk*))))) diff --git a/hemlock/input.lisp b/hemlock/input.lisp index 2bba85e6c07758d6c7cf65c41a4db9b2714a7d3d..fa549430f77d13ba19a4758e576f45f620432940 100644 --- a/hemlock/input.lisp +++ b/hemlock/input.lisp @@ -223,7 +223,7 @@ ;;;; Editor input from windowing system. -#+clx + (defstruct (windowed-editor-input (:include editor-input (:get #'windowed-get-key-event) @@ -232,21 +232,18 @@ (:clear #'windowed-clear-input)) (:print-function (lambda (s stream d) - (declare (ignore s d)) + (declare (ignore s d write)) (write-string "#<Editor-Window-Input stream>" stream))) (:constructor make-windowed-editor-input (&optional (head (make-input-event)) (tail head)))) hunks) ; List of bitmap-hunks which input to this stream. -#+clx (defun windowed-get-key-event (stream ignore-abort-attempts-p) (editor-input-method-macro)) -#+clx (defun windowed-unget-key-event (key-event stream) (un-event key-event stream)) -#+clx (defun windowed-clear-input (stream) (loop (unless (system:serve-event 0) (return))) (without-interrupts @@ -258,7 +255,6 @@ *free-input-events* next) (setf (editor-input-tail stream) head))))) -#+clx (defun windowed-listen (stream) (loop (unless (system:serve-event 0) ;; If nothing is pending, check the queued input. @@ -406,8 +402,11 @@ (update-modeline-field buffer window :more-prompt) (random-typeout-redisplay window)) (buffer-start (buffer-point buffer)) - (unless (make-window start :window (make-xwindow-like-hwindow window)) - (editor-error "Could not create random typeout window."))))) + (let* ((xwindow (make-xwindow-like-hwindow window)) + (window (make-window start :window xwindow))) + (unless window + (xlib:destroy-window xwindow) + (editor-error "Could not create random typeout window.")))))) (defun end-random-typeout (stream) (let ((*more-prompt-action* :flush) diff --git a/hemlock/mh.lisp b/hemlock/mh.lisp index 278f0e7e4c44766dd9fc2a536727f2d403d65293..05b7ea6abd0b24e963827eb144dce8493cd1794b 100644 --- a/hemlock/mh.lisp +++ b/hemlock/mh.lisp @@ -1156,12 +1156,14 @@ ;;; (defun maybe-delete-extra-draft-window (dbuffer dbuffer-window) (when (and (hemlock-bound-p 'split-window-draft :buffer dbuffer) - (> (length (the list *window-list*)) 2)) - (delete-window - (find-if #'(lambda (w) - (not (or (eq w dbuffer-window) - (eq w *echo-area-window*)))) - *window-list*)) + ;; Since we now bitmap devices have window groups, this loop is + ;; more correct than testing the length of *window-list* and + ;; accounting for *echo-area-window* being in there. + (do ((start dbuffer-window) + (count 1 (1+ count)) + (w (next-window dbuffer-window) (next-window w))) + ((eq start w) (> count 1)))) + (delete-window (next-window dbuffer-window)) (delete-variable 'split-window-draft :buffer dbuffer))) diff --git a/hemlock/rompsite.lisp b/hemlock/rompsite.lisp index 093542e3daa229add9f3a7d12730c1e2cdeff3c3..d4b66d7758b8537155d5c0fff437a370ee01850b 100644 --- a/hemlock/rompsite.lisp +++ b/hemlock/rompsite.lisp @@ -184,33 +184,22 @@ ;;; These are used for selecting X events. ;;; -;;; This says to send :key-press, :button-press, :button-release, :enter-notify, -;;; and :leave-notify events. -;;; -(defconstant input/boundary-xevents-selection-keys - '(:key-press :button-press :button-release :enter-window :leave-window)) -(defconstant input/boundary-xevents-mask - (apply #'xlib:make-event-mask input/boundary-xevents-selection-keys)) -;;; -;;; This says to send :exposure, :destroy-notify, :unmap-notify, :map-notify, -;;; :reparent-notify, :configure-notify, :gravity-notify, and :circulate-notify -;;; in addition to the above events. Of those enumerated here, we only care -;;; about :exposure and :configure-notify. -;;; -(defconstant interesting-xevents-receive-keys - '(:key-press :button-press :button-release :enter-notify :leave-notify - :exposure :graphics-exposure :configure-notify :destroy-notify :unmap-notify - :map-notify :reparent-notify :gravity-notify :circulate-notify)) -(defconstant interesting-xevents-mask - (apply #'xlib:make-event-mask - (append input/boundary-xevents-selection-keys - '(:exposure :structure-notify)))) - +(defconstant group-interesting-xevents + '(:structure-notify)) +(defconstant group-interesting-xevents-mask + (apply #'xlib:make-event-mask group-interesting-xevents)) + +(defconstant child-interesting-xevents + '(:key-press :button-press :button-release :structure-notify :exposure + :enter-window :leave-window)) +(defconstant child-interesting-xevents-mask + (apply #'xlib:make-event-mask child-interesting-xevents)) + +(defconstant random-typeout-xevents + '(:key-press :button-press :button-release :enter-window :leave-window + :exposure)) (defconstant random-typeout-xevents-mask - (apply #'xlib:make-event-mask - (append input/boundary-xevents-selection-keys - '(:exposure)))) - + (apply #'xlib:make-event-mask random-typeout-xevents)) (proclaim '(special ed::*open-paren-highlight-font* ed::*active-region-highlight-font*)) @@ -481,13 +470,16 @@ ;;; This should do something more sophisticated when we know what that is. ;;; (defun default-hemlock-window-mngt (display on) - (let ((win (bitmap-hunk-xwindow (window-hunk *current-window*))) - (ewin (bitmap-hunk-xwindow (window-hunk *echo-area-window*)))) - (cond (on (setf (xlib:window-priority ewin) :above) + (let ((xparent (window-group-xparent + (bitmap-hunk-window-group (window-hunk *current-window*)))) + (echo-xparent (window-group-xparent + (bitmap-hunk-window-group + (window-hunk *echo-area-window*))))) + (cond (on (setf (xlib:window-priority echo-xparent) :above) (clear-editor-input *editor-input*) - (setf (xlib:window-priority win) :above)) - (t (setf (xlib:window-priority ewin) :below) - (setf (xlib:window-priority win) :below)))) + (setf (xlib:window-priority xparent) :above)) + (t (setf (xlib:window-priority echo-xparent) :below) + (setf (xlib:window-priority xparent) :below)))) (xlib:display-force-output display)) (defvar *hemlock-window-mngt* #'default-hemlock-window-mngt diff --git a/hemlock/screen.lisp b/hemlock/screen.lisp index 076589e1ae97ff8cd6c349686fbc21ad2d2ca57e..e9251a7d90805eb721b60545d51dadc621f49c90 100644 --- a/hemlock/screen.lisp +++ b/hemlock/screen.lisp @@ -51,26 +51,26 @@ x y (width (value ed::default-window-width)) (height (value ed::default-window-height))) - "Make a window that displays text starting at the mark Start. + "Make a window that displays text starting at the mark Start. The default + action is to split the current window to make room for the new window. Modelinep specifies whether the window should display buffer modelines. Device is the Hemlock device to make the window on. If it is nil, then the window is made on the same device as CURRENT-WINDOW. - Window is an X window to be used for the Hemlock window. If not specified, - we make one by calling the function in *create-window-hook*. This hook maps - the window to the screen. + Window is an X window to be used with the Hemlock window. The supplied + window becomes the parent window for a new group of windows that behave + in a stack orientation as windows do on the terminal. Font-Family is the font-family used for displaying text in the window. - If Ask-User is non-nil, the user is prompted for missing X, Y, Width, and - Height arguments. X and Y are supplied as pixels, but Width and Height are - supplied in characters. Otherwise, the current window's height is halved, - and the new window fills the created space. If halving the current window - results in too small of a window, then a new one is made the same size as - the current, offsetting its vertical placement on the screen some pixels." - + If Ask-User is non-nil, Hemlock prompts the user for missing X, Y, Width, + and Height arguments to make a new group of windows that behave in a stack + orientation as windows do on the terminal. This occurs by invoking + hi::*create-window-hook*. X and Y are supplied as pixels, but Width and + Height are supplied in characters." + (let* ((device (or device (device-hunk-device (window-hunk (current-window))))) (window (funcall (device-make-window device) device start modelinep window font-family @@ -80,14 +80,26 @@ window)) (defun delete-window (window) - "Make Window go away, removing it from the screen. Uses *delete-window-hook* - to get rid of bitmap window system windows." - (when (eq window *current-window*) - (error "Cannot kill the current window.")) + "Make Window go away, removing it from the screen. This uses + hi::*delete-window-hook* to get rid of parent windows on a bitmap device + when you delete the last Hemlock window in a group." + (when (<= (length *window-list*) 2) + (error "Cannot kill the only window.")) (invoke-hook ed::delete-window-hook window) (setq *window-list* (delq window *window-list*)) (funcall (device-delete-window (device-hunk-device (window-hunk window))) - window)) + window) + ;; + ;; Since the programmer's interface fails to allow users to determine if + ;; they're commands delete the current window, this primitive needs to + ;; make sure Hemlock doesn't get screwed. This inadequacy comes from the + ;; bitmap window groups and the vague descriptions of PREVIOUS-WINDOW and + ;; NEXT-WINDOW. + (when (eq window *current-window*) + (let ((window (find-if-not #'(lambda (w) (eq w *echo-area-window*)) + *window-list*))) + (setf (current-buffer) (window-buffer window) + (current-window) window)))) (defun next-window (window) "Return the next window after Window, wrapping around if Window is the @@ -176,7 +188,7 @@ (list (make-modeline-field :name :more-prompt :function #'(lambda (buffer window) - (declare (ignore window)) + (declare (ignore buffer window)) (ecase *more-prompt-action* (:more "--More--") (:flush "--Flush--") diff --git a/hemlock/struct.lisp b/hemlock/struct.lisp index fa4c7f3137a7d2790a57c20dadf4716e36e228a5..6152c4a8aaa73c568ad58691923c97580d7e3e7d 100644 --- a/hemlock/struct.lisp +++ b/hemlock/struct.lisp @@ -462,7 +462,22 @@ -;;;; Device screen hunks. +;;;; Device screen hunks and window-group. + +;;; Window groups are used to keep track of the old width and height of a group +;;; so that when a configure-notify event is sent, we can determine if the size +;;; of the window actually changed or not. +;;; +(defstruct (window-group (:print-function %print-window-group) + (:constructor + make-window-group (xparent width height))) + xparent + width + height) + +(defun %print-window-group (object stream depth) + (declare (ignore object depth)) + (format stream "#<Hemlock Window Group>")) ;;; Device-hunks are used to claim a piece of the screen and for ordering ;;; pieces of the screen. Window motion primitives and splitting/merging @@ -503,7 +518,7 @@ char-height ; Height of text body in characters. char-width ; Width in characters. xwindow ; X window for this hunk. - gcontext ; X gcontext for xwindow. + gcontext ; X gcontext for xwindow. start ; Head of dis-line list (no dummy). end ; Exclusive end, i.e. nil if nil-terminated. modeline-dis-line ; Dis-line for modeline, or NIL if none. @@ -513,7 +528,8 @@ font-family ; Font-family used in this window. input-handler ; Gets hunk, char, x, y when char read. changed-handler ; Gets hunk when size changed. - (thumb-bar-p nil)) ; True if we draw a thumb bar in the top border. + (thumb-bar-p nil) ; True if we draw a thumb bar in the top border. + window-group) ; The window-group to which this hunk belongs. ;;; Terminal hunks. diff --git a/hemlock/things-to-do.txt b/hemlock/things-to-do.txt index 4a4d6792ea5e1e89341c72470ae45e901c9230db..80872e909c7ae3c4bcc943a7bed5780f7c838934 100644 --- a/hemlock/things-to-do.txt +++ b/hemlock/things-to-do.txt @@ -1,35 +1,24 @@ -*- Mode: Text; Package: Hemlock; Editor: t -*- - -;;;; eval servers. - -"Remote Compile File" is losing now. - -Flakey prompt handling when eval text is used and it gets and error. - - ;;;; X problems. -Intermittant line blanking while typing, like server isn't really forcing -output. Tracing shows that it really happens. +Compute mininum width of a window group by taking the maximum of all the +windows' font-widths, each multiplied by minimum-window-columns. Right now it +just uses the default font or current window. + +Compute minimum window split correctly: look at current window's font-height +and new window's font-height, extra height pixels, whether each has a modeline, +and minimum-window-lines to determine if we can split the current window. Server not implementing DRAW-IMAGE-GLYPHS correctly, so we don't have to do our pixmap hack. -Possibly auto saving and typing ahead tickles the servers force output problem. -There is the remote chance that Hemlock is slipping up and not calling -redisplay or something under perverse conditions. - ;;;; Bill and/or Rob. -Blow away default case translations. Change bindings to lowercase, unless -inappropriate. Modify tty code to always translate to lowercase control -characters on input. - Make editor-error messages; that is just make many of the (editor-error) forms have some string to be printed. Importance: often beeps and don't know why. @@ -52,7 +41,7 @@ function position. Think about whizzy, general definition location logging and finding mechanism that is user extensible. Think about regular expression searching. - Importance: probably should be there by Spring 89. + Importance: it would be used weekly by some and daily by others. Make illegal setting window width and height, (or support this). @@ -267,8 +256,6 @@ Do something about message headers when reading mail. Suggestions include a list of headers components that get deleted from the buffer and simply scrolling the window past the "Received:" lines. -"Examine Message" - Add more folder support and possibly something specific for Bovik groveling. For example, rehashing the cached folder names and/or adding new ones from a folder spec or root directory (allows adding the bovik folders). @@ -646,9 +633,6 @@ Synchronization/exclusion issues: Redisplay? Typescript code? -Flush case in keyboard events? Instead, have a shift bit that is used by -text-character. You would still want shift-8 to be *, though.... - Online documentation stuff: What to do and how to do it. Rob has some notes on this from a year or two ago. Importance: something to do. diff --git a/hemlock/xcoms.lisp b/hemlock/xcoms.lisp index a80852f6fba6b68b68c848ee08b2daf0f224742c..8e4d22e2f54af85aa3fa9140106e1f566ce4c604 100644 --- a/hemlock/xcoms.lisp +++ b/hemlock/xcoms.lisp @@ -13,7 +13,7 @@ ;;; Written by Bill Chiles. ;;; -(in-package 'hemlock) +(in-package "HEMLOCK") (defcommand "Region to Cut Buffer" (p) @@ -37,22 +37,3 @@ (insert-string (current-point) str)) (editor-error "X cut buffer empty."))) (setf (last-command-type) :ephemerally-active)) - - -(defcommand "Stack Window" (p) - "Make a new window that overlays the current window. - The new window is made the current window and displays starting at - the same place as the current window." - "Create a new window which displays starting at the same place - as the current window." - (declare (ignore p)) - (let ((cw (current-window))) - (unless (typep (hi::device-hunk-device (hi::window-hunk cw)) - 'hi::bitmap-device) - (editor-error - "This command is only valid when running under a graphical windowing ~ - system.")) - (let ((new (make-window (window-display-start cw) - :window (make-xwindow-like-hwindow cw)))) - (unless new (editor-error "Could not make a new window.")) - (setf (current-window) new))))