Mercurial > hg > xemacs-beta
changeset 5645:5d3bb1100832
Remove some utility functions from the global namespace, lisp/
lisp/ChangeLog addition:
2012-04-07 Aidan Kehoe <kehoea@parhasard.net>
Remove some utility functions from the global namespace, it's more
appropriate to have them as labels (that is, lexically-visible
functions.)
* behavior.el:
* behavior.el (behavior-menu-filter-1): Moved to being a label.
* behavior.el (behavior-menu-filter): Use the label.
* cus-edit.el (custom-load-symbol-1): Moved to being a label.
* cus-edit.el (custom-load-symbol): Use the label.
* menubar.el (find-menu-item-1): Moved to being a label.
* menubar.el (find-menu-item): Use the label.
* window-xemacs.el:
* window-xemacs.el (display-buffer-1): Moved to being a label.
* window-xemacs.el (display-buffer): Use the label; use (block
...) instead of (catch ...), use prog1 instead of needlessly
binding a variable.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sat, 07 Apr 2012 21:57:31 +0100 |
| parents | 0df3cedee9ac |
| children | 7aa144d1404b |
| files | lisp/ChangeLog lisp/behavior.el lisp/cus-edit.el lisp/menubar.el lisp/window-xemacs.el |
| diffstat | 5 files changed, 404 insertions(+), 387 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Fri Mar 02 18:26:14 2012 +0000 +++ b/lisp/ChangeLog Sat Apr 07 21:57:31 2012 +0100 @@ -1,3 +1,21 @@ +2012-04-07 Aidan Kehoe <kehoea@parhasard.net> + + Remove some utility functions from the global namespace, it's more + appropriate to have them as labels (that is, lexically-visible + functions.) + * behavior.el: + * behavior.el (behavior-menu-filter-1): Moved to being a label. + * behavior.el (behavior-menu-filter): Use the label. + * cus-edit.el (custom-load-symbol-1): Moved to being a label. + * cus-edit.el (custom-load-symbol): Use the label. + * menubar.el (find-menu-item-1): Moved to being a label. + * menubar.el (find-menu-item): Use the label. + * window-xemacs.el: + * window-xemacs.el (display-buffer-1): Moved to being a label. + * window-xemacs.el (display-buffer): Use the label; use (block + ...) instead of (catch ...), use prog1 instead of needlessly + binding a variable. + 2012-03-02 Aidan Kehoe <kehoea@parhasard.net> * select.el (select-coerce):
--- a/lisp/behavior.el Fri Mar 02 18:26:14 2012 +0000 +++ b/lisp/behavior.el Sat Apr 07 21:57:31 2012 +0100 @@ -414,90 +414,96 @@ ) ) -(defun behavior-menu-filter-1 (menu group) - (submenu-generate-accelerator-spec - (let* ( - ;;options - ;;help - (enable - (menu-split-long-menu - (menu-sort-menu - (let ((group-plist (gethash group behavior-group-hash-table))) - (loop for behavior in (getf group-plist :children) - nconc (if (behavior-group-p behavior) - (list - (cons (getf - (gethash behavior behavior-group-hash-table) - :short-doc) - (behavior-menu-filter-1 menu behavior))) - (let* ((plist (gethash behavior behavior-hash-table)) - (commands (getf plist :commands))) - (nconc - (if (getf plist :enable) - `([,(format "%s (%s) [toggle]" - (getf plist :short-doc) - behavior) - (if (memq ',behavior - enabled-behavior-list) - (disable-behavior ',behavior) - (enable-behavior ',behavior)) - :active ,(if (getf plist :disable) t - (not (memq - ',behavior - enabled-behavior-list))) - :style toggle - :selected (memq ',behavior - enabled-behavior-list)])) - (cond ((null commands) nil) - ((and (eq (length commands) 1) - (vectorp (elt commands 0))) - (let ((comm (copy-sequence - (elt commands 0)))) - (setf (elt comm 0) - (format "%s (%s)" - (elt comm 0) behavior)) - (list comm))) - (t (list - (cons (format "%s (%s) Commands" - (getf plist :short-doc) - behavior) - commands))))))))) - )) - ) - ) - enable) - '(?p))) - (defun behavior-menu-filter (menu) - (append - `(("%_Package Utilities" - ("%_Set Download Site" - ("%_Official Releases" - :filter ,#'(lambda (&rest junk) - (menu-split-long-menu - (submenu-generate-accelerator-spec - (package-ui-download-menu))))) - ("%_Pre-Releases" - :filter ,#'(lambda (&rest junk) - (menu-split-long-menu - (submenu-generate-accelerator-spec - (package-ui-pre-release-download-menu))))) - ("%_Site Releases" - :filter ,#'(lambda (&rest junk) - (menu-split-long-menu - (submenu-generate-accelerator-spec - (package-ui-site-release-download-menu)))))) - "--:shadowEtchedIn" - ["%_Update Package Index" package-get-update-base] - ["%_List and Install" pui-list-packages] - ["U%_pdate Installed Packages" package-get-update-all] - ["%_Help" (Info-goto-node "(xemacs)Packages")]) - "----") - (behavior-menu-filter-1 menu nil))) + (labels + ((behavior-menu-filter-1 (menu group) + (submenu-generate-accelerator-spec + (let* ((enable + (menu-split-long-menu + (menu-sort-menu + (let ((group-plist (gethash group + behavior-group-hash-table))) + (loop for behavior in (getf group-plist :children) + nconc (if (behavior-group-p behavior) + (list + (cons (getf + (gethash behavior + behavior-group-hash-table) + :short-doc) + (behavior-menu-filter-1 + menu behavior))) + (let* ((plist (gethash behavior + behavior-hash-table)) + (commands (getf plist :commands))) + (nconc + (if (getf plist :enable) + `([,(format "%s (%s) [toggle]" + (getf plist :short-doc) + behavior) + (if (memq ',behavior + enabled-behavior-list) + (disable-behavior ',behavior) + (enable-behavior ',behavior)) + :active ,(if (getf plist :disable) + t + (not + (memq + ',behavior + enabled-behavior-list))) + :style toggle + :selected (memq + ',behavior + enabled-behavior-list)])) + (cond ((null commands) nil) + ((and (eq (length commands) 1) + (vectorp (elt commands 0))) + (let ((comm (copy-sequence + (elt commands 0)))) + (setf (elt comm 0) + (format "%s (%s)" + (elt comm 0) + behavior)) + (list comm))) + (t (list + (cons (format "%s (%s) Commands" + (getf plist + :short-doc) + behavior) + commands))))))))) + )) + ) + ) + enable) + '(?p)))) + (append + `(("%_Package Utilities" + ("%_Set Download Site" + ("%_Official Releases" + :filter ,#'(lambda (&rest junk) + (menu-split-long-menu + (submenu-generate-accelerator-spec + (package-ui-download-menu))))) + ("%_Pre-Releases" + :filter ,#'(lambda (&rest junk) + (menu-split-long-menu + (submenu-generate-accelerator-spec + (package-ui-pre-release-download-menu))))) + ("%_Site Releases" + :filter ,#'(lambda (&rest junk) + (menu-split-long-menu + (submenu-generate-accelerator-spec + (package-ui-site-release-download-menu)))))) + "--:shadowEtchedIn" + ["%_Update Package Index" package-get-update-base] + ["%_List and Install" pui-list-packages] + ["U%_pdate Installed Packages" package-get-update-all] + ["%_Help" (Info-goto-node "(xemacs)Packages")]) + "----") + (behavior-menu-filter-1 menu nil)))) ;; Initialize top-level group. (puthash nil '(:children nil :short-doc "Root") behavior-group-hash-table) (provide 'behavior) -;;; finder-inf.el ends here +;;; behavior.el ends here
--- a/lisp/cus-edit.el Fri Mar 02 18:26:14 2012 +0000 +++ b/lisp/cus-edit.el Sat Apr 07 21:57:31 2012 +0100 @@ -1684,33 +1684,28 @@ (defun custom-load-symbol (symbol) "Load all dependencies for SYMBOL." - (unless custom-load-recursion - (let ((custom-load-recursion t) - (loads (get symbol 'custom-loads)) - load) - (while loads - (setq load (car loads) - loads (cdr loads)) - (custom-load-symbol-1 load))))) - -(defun custom-load-symbol-1 (load) - (cond ((symbolp load) - (condition-case nil - (require load) - (error nil))) - ;; Don't reload a file already loaded. - ((and (boundp 'preloaded-file-list) - (member load preloaded-file-list))) - ((assoc load load-history)) - ((assoc (locate-library load) load-history)) - (t - (condition-case nil - ;; Without this, we would load cus-edit recursively. - ;; We are still loading it when we call this, - ;; and it is not in load-history yet. - (or (equal load "cus-edit") - (load-library load)) - (error nil))))) + (labels + ((custom-load-symbol-1 (load) + (cond ((symbolp load) + (condition-case nil + (require load) + (error nil))) + ;; Don't reload a file already loaded. + ((and (boundp 'preloaded-file-list) + (member load preloaded-file-list))) + ((assoc load load-history)) + ((assoc (locate-library load) load-history)) + (t + (condition-case nil + ;; Without this, we would load cus-edit recursively. + ;; We are still loading it when we call this, + ;; and it is not in load-history yet. + (or (equal load "cus-edit") + (load-library load)) + (error nil)))))) + (unless custom-load-recursion + (let ((custom-load-recursion t)) + (map nil #'custom-load-symbol-1 (get symbol 'custom-loads)))))) (defvar custom-already-loaded-custom-defines nil "List of already-loaded `custom-defines' files.")
--- a/lisp/menubar.el Fri Mar 02 18:26:14 2012 +0000 +++ b/lisp/menubar.el Sat Apr 07 21:57:31 2012 +0100 @@ -178,35 +178,36 @@ the item found. If the item does not exist, the car of the returned value is nil. If some menu in the ITEM-PATH-LIST does not exist, an error is signalled." - (find-menu-item-1 menubar item-path-list)) - -(defun find-menu-item-1 (menubar item-path-list &optional parent) - (check-argument-type 'listp item-path-list) - (if (not (consp menubar)) - nil - (let ((rest menubar) - result) - (when (stringp (car rest)) - (setq rest (cdr rest))) - (while (keywordp (car rest)) - (setq rest (cddr rest))) - (while rest - (if (and (car rest) - (stringp (car item-path-list)) - (= 0 (compare-menu-text (car item-path-list) - (menu-item-text (car rest))))) - (setq result (car rest) - rest nil) - (setq rest (cdr rest)))) - (if (cdr item-path-list) - (cond ((consp result) - (find-menu-item-1 (cdr result) (cdr item-path-list) result)) - (result - (signal 'error (list (gettext "not a submenu") result))) - (t - (signal 'error (list (gettext "no such submenu") - (car item-path-list))))) - (cons result parent))))) + (labels + ((find-menu-item-1 (menubar item-path-list &optional parent) + (check-argument-type 'listp item-path-list) + (if (not (consp menubar)) + nil + (let ((rest menubar) + result) + (when (stringp (car rest)) + (setq rest (cdr rest))) + (while (keywordp (car rest)) + (setq rest (cddr rest))) + (while rest + (if (and (car rest) + (stringp (car item-path-list)) + (= 0 (compare-menu-text (car item-path-list) + (menu-item-text (car rest))))) + (setq result (car rest) + rest nil) + (setq rest (cdr rest)))) + (if (cdr item-path-list) + (cond ((consp result) + (find-menu-item-1 (cdr result) (cdr item-path-list) + result)) + (result + (signal 'error (list (gettext "not a submenu") result))) + (t + (signal 'error (list (gettext "no such submenu") + (car item-path-list))))) + (cons result parent)))))) + (find-menu-item-1 menubar item-path-list))) (defun add-menu-item-1 (leaf-p menu-path new-item before in-menu) ;; This code looks like it could be cleaned up some more
--- a/lisp/window-xemacs.el Fri Mar 02 18:26:14 2012 +0000 +++ b/lisp/window-xemacs.el Sat Apr 07 21:57:31 2012 +0100 @@ -756,18 +756,11 @@ :type 'integer :group 'windows) -;; Deiconify the frame containing the window WINDOW, then return WINDOW. - -(defun display-buffer-1 (window) - (if (frame-iconified-p (window-frame window)) - (make-frame-visible (window-frame window))) - window) - ;; Can you believe that all of this crap was formerly in C? ;; Praise Jesus that it's not there any more. (defun display-buffer (buffer &optional not-this-window-p override-frame - shrink-to-fit) + shrink-to-fit) "Make BUFFER appear in some window on the current frame, but don't select it. BUFFER can be a buffer or a buffer name. If BUFFER is shown already in some window in the current frame, @@ -797,271 +790,275 @@ Returns the window displaying BUFFER." (interactive "BDisplay buffer:\nP") - (let ((wconfig (current-window-configuration)) - (result - ;; We just simulate a `return' in C. This function is way ugly - ;; and does `returns' all over the place and there's no sense - ;; in trying to rewrite it to be more Lispy. - (catch 'done - (let (window old-frame target-frame explicit-frame shrink-it) - (setq old-frame (or (last-nonminibuf-frame) (selected-frame))) - (setq buffer (get-buffer buffer)) - (check-argument-type 'bufferp buffer) + (let ((wconfig (current-window-configuration))) + (prog1 + ;; We just simulate a `return' in C. This function is way + ;; ugly and does `returns' all over the place and there's + ;; no sense in trying to rewrite it to be more Lispy. + (block nil + (labels + ((display-buffer-1 (window) + ;; Deiconify the frame containing the window WINDOW, then + ;; return WINDOW. + (if (frame-iconified-p (window-frame window)) + (make-frame-visible (window-frame window))) + window)) + (let (window old-frame target-frame explicit-frame shrink-it) + (setq old-frame (or (last-nonminibuf-frame) (selected-frame))) + (setq buffer (get-buffer buffer)) + (check-argument-type 'bufferp buffer) - (setq explicit-frame - (if pre-display-buffer-function - (funcall pre-display-buffer-function buffer - not-this-window-p - override-frame - shrink-to-fit))) - - ;; Give the user the ability to completely reimplement - ;; this function via the `display-buffer-function'. - (if display-buffer-function - (throw 'done - (funcall display-buffer-function buffer - not-this-window-p - override-frame - shrink-to-fit))) + (setq explicit-frame + (if pre-display-buffer-function + (funcall pre-display-buffer-function buffer + not-this-window-p + override-frame + shrink-to-fit))) - ;; If the buffer has a dedicated frame, that takes - ;; precedence over the current frame, and over what the - ;; pre-display-buffer-function did. - (let ((dedi (buffer-dedicated-frame buffer))) - (if (frame-live-p dedi) (setq explicit-frame dedi))) + ;; Give the user the ability to completely reimplement + ;; this function via the `display-buffer-function'. + (if display-buffer-function + (return (funcall display-buffer-function buffer + not-this-window-p + override-frame + shrink-to-fit))) - ;; if override-frame is supplied, that takes precedence over - ;; everything. This is gonna look bad if the - ;; pre-display-buffer-function raised some other frame - ;; already. - (if override-frame - (progn - (check-argument-type 'frame-live-p override-frame) - (setq explicit-frame override-frame))) + ;; If the buffer has a dedicated frame, that takes + ;; precedence over the current frame, and over what the + ;; pre-display-buffer-function did. + (let ((dedi (buffer-dedicated-frame buffer))) + (if (frame-live-p dedi) (setq explicit-frame dedi))) - (setq target-frame - (or explicit-frame - (last-nonminibuf-frame) - (selected-frame))) + ;; if override-frame is supplied, that takes precedence over + ;; everything. This is gonna look bad if the + ;; pre-display-buffer-function raised some other frame already. + (if override-frame + (progn + (check-argument-type 'frame-live-p override-frame) + (setq explicit-frame override-frame))) - ;; If we have switched frames, then set not-this-window-p - ;; to false. Switching frames means that selected-window - ;; is no longer the same as it was on entry -- it's the - ;; selected-window of target_frame instead of old_frame, - ;; so it's a fine candidate for display. - (if (not (eq old-frame target-frame)) - (setq not-this-window-p nil)) + (setq target-frame + (or explicit-frame + (last-nonminibuf-frame) + (selected-frame))) - ;; if it's in the selected window, and that's ok, then we're done. - (if (and (not not-this-window-p) - (eq buffer (window-buffer (selected-window)))) - (throw 'done (display-buffer-1 (selected-window)))) + ;; If we have switched frames, then set not-this-window-p to + ;; false. Switching frames means that selected-window is no + ;; longer the same as it was on entry -- it's the + ;; selected-window of target_frame instead of old_frame, so + ;; it's a fine candidate for display. + (if (not (eq old-frame target-frame)) + (setq not-this-window-p nil)) - ;; See if the user has specified this buffer should appear - ;; in the selected window. - - (if not-this-window-p - nil + ;; if it's in the selected window, and that's ok, then we're + ;; done. + (if (and (not not-this-window-p) + (eq buffer (window-buffer (selected-window)))) + (return (display-buffer-1 (selected-window)))) - (if (or (member (buffer-name buffer) same-window-buffer-names) - (assoc (buffer-name buffer) same-window-buffer-names)) - (progn - (switch-to-buffer buffer) - (throw 'done (display-buffer-1 (selected-window))))) + ;; See if the user has specified this buffer should + ;; appear in the selected window. - (let ((tem same-window-regexps)) - (while tem - (let ((car (car tem))) - (if (or - (and (stringp car) - (string-match car (buffer-name buffer))) - (and (consp car) (stringp (car car)) - (string-match (car car) (buffer-name buffer)))) - (progn - (switch-to-buffer buffer) - (throw 'done (display-buffer-1 - (selected-window)))))) - (setq tem (cdr tem))))) + (if not-this-window-p + nil + (if (or (member (buffer-name buffer) same-window-buffer-names) + (assoc (buffer-name buffer) same-window-buffer-names)) + (progn + (switch-to-buffer buffer) + (return (display-buffer-1 (selected-window))))) + + (let ((tem same-window-regexps)) + (while tem + (let ((car (car tem))) + (if (or + (and (stringp car) + (string-match car (buffer-name buffer))) + (and (consp car) (stringp (car car)) + (string-match (car car) (buffer-name buffer)))) + (progn + (switch-to-buffer buffer) + (return (display-buffer-1 (selected-window)))))) + (setq tem (cdr tem))))) - ;; If pop-up-frames, look for a window showing BUFFER on - ;; any visible or iconified frame. Otherwise search only - ;; the current frame. - (if (and (not explicit-frame) - (or pop-up-frames (not (last-nonminibuf-frame)))) - (setq target-frame 0)) + ;; If pop-up-frames, look for a window showing BUFFER + ;; on any visible or iconified frame. Otherwise search + ;; only the current frame. + (if (and (not explicit-frame) + (or pop-up-frames (not (last-nonminibuf-frame)))) + (setq target-frame 0)) - ;; Otherwise, find some window that it's already in, and - ;; return that, unless that window is the selected window - ;; and that isn't ok. What a contorted mess! - (setq window (or (if (not explicit-frame) - ;; search the selected frame - ;; first if the user didn't - ;; specify an explicit frame. - (get-buffer-window buffer nil)) - (get-buffer-window buffer target-frame))) - (if (and window - (or (not not-this-window-p) - (not (eq window (selected-window))))) - (throw 'done (display-buffer-1 window))) + ;; Otherwise, find some window that it's already in, + ;; and return that, unless that window is the selected + ;; window and that isn't ok. What a contorted mess! + (setq window (or (if (not explicit-frame) + ;; search the selected frame + ;; first if the user didn't + ;; specify an explicit frame. + (get-buffer-window buffer nil)) + (get-buffer-window buffer target-frame))) + (if (and window + (or (not not-this-window-p) + (not (eq window (selected-window))))) + (return (display-buffer-1 window))) + ;; Certain buffer names get special handling. + (if special-display-function + (progn + (if (member (buffer-name buffer) + special-display-buffer-names) + (return (funcall special-display-function buffer))) - ;; Certain buffer names get special handling. - (if special-display-function - (progn - (if (member (buffer-name buffer) - special-display-buffer-names) - (throw 'done (funcall special-display-function buffer))) - - (let ((tem (assoc (buffer-name buffer) - special-display-buffer-names))) - (if tem - (throw 'done (funcall special-display-function - buffer (cdr tem))))) + (let ((tem (assoc (buffer-name buffer) + special-display-buffer-names))) + (if tem + (return (funcall special-display-function + buffer (cdr tem))))) - (let ((tem special-display-regexps)) - (while tem - (let ((car (car tem))) - (if (and (stringp car) - (string-match car (buffer-name buffer))) - (throw 'done - (funcall special-display-function buffer))) - (if (and (consp car) - (stringp (car car)) - (string-match (car car) - (buffer-name buffer))) - (throw 'done (funcall - special-display-function buffer - (cdr car))))) - (setq tem (cdr tem)))))) + (let ((tem special-display-regexps)) + (while tem + (let ((car (car tem))) + (if (and (stringp car) + (string-match car (buffer-name buffer))) + (return + (funcall special-display-function buffer))) + (if (and (consp car) + (stringp (car car)) + (string-match (car car) + (buffer-name buffer))) + (return (funcall special-display-function buffer + (cdr car))))) + (setq tem (cdr tem)))))) - ;; If there are no frames open that have more than a minibuffer, - ;; we need to create a new frame. - (if (or pop-up-frames - (null (last-nonminibuf-frame))) - (progn - (setq window (frame-selected-window - (funcall pop-up-frame-function))) - (set-window-buffer window buffer) - (throw 'done (display-buffer-1 window)))) + ;; If there are no frames open that have more than a minibuffer, + ;; we need to create a new frame. + (if (or pop-up-frames + (null (last-nonminibuf-frame))) + (progn + (setq window (frame-selected-window + (funcall pop-up-frame-function))) + (set-window-buffer window buffer) + (return (display-buffer-1 window)))) - ;; Otherwise, make it be in some window, splitting if - ;; appropriate/possible. Do not split a window if we are - ;; displaying the buffer in a different frame than that which - ;; was current when we were called. (It is already in a - ;; different window by virtue of being in another frame.) - (if (or (and pop-up-windows (eq target-frame old-frame)) - (eq 'only (frame-property (selected-frame) 'minibuffer)) - ;; If the current frame is a special display frame, - ;; don't try to reuse its windows. - (window-dedicated-p (frame-root-window (selected-frame)))) - (progn - (if (eq 'only (frame-property (selected-frame) 'minibuffer)) - (setq target-frame (last-nonminibuf-frame))) + ;; Otherwise, make it be in some window, splitting if + ;; appropriate/possible. Do not split a window if we + ;; are displaying the buffer in a different frame than + ;; that which was current when we were called. (It is + ;; already in a different window by virtue of being in + ;; another frame.) + (if (or (and pop-up-windows (eq target-frame old-frame)) + (eq 'only (frame-property (selected-frame) 'minibuffer)) + ;; If the current frame is a special display frame, + ;; don't try to reuse its windows. + (window-dedicated-p + (frame-root-window (selected-frame)))) + (progn + (if (eq 'only (frame-property (selected-frame) + 'minibuffer)) + (setq target-frame (last-nonminibuf-frame))) - ;; Don't try to create a window if would get an error with - ;; height. - (if (< split-height-threshold (* 2 window-min-height)) - (setq split-height-threshold (* 2 window-min-height))) + ;; Don't try to create a window if would get an error with + ;; height. + (if (< split-height-threshold (* 2 window-min-height)) + (setq split-height-threshold (* 2 window-min-height))) - ;; Same with width. - (if (< split-width-threshold (* 2 window-min-width)) - (setq split-width-threshold (* 2 window-min-width))) + ;; Same with width. + (if (< split-width-threshold (* 2 window-min-width)) + (setq split-width-threshold (* 2 window-min-width))) - ;; If the frame we would try to split cannot be split, - ;; try other frames. - (if (frame-property (if (null target-frame) - (selected-frame) - (last-nonminibuf-frame)) - 'unsplittable) - (setq window - ;; Try visible frames first. - (or (get-largest-window 'visible) - ;; If that didn't work, try iconified frames. - (get-largest-window 0) - (get-largest-window t))) - (setq window (get-largest-window target-frame))) + ;; If the frame we would try to split cannot be split, + ;; try other frames. + (if (frame-property (if (null target-frame) + (selected-frame) + (last-nonminibuf-frame)) + 'unsplittable) + (setq window + ;; Try visible frames first. + (or (get-largest-window 'visible) + ;; If that didn't work, try iconified frames. + (get-largest-window 0) + (get-largest-window t))) + (setq window (get-largest-window target-frame))) - ;; If we got a tall enough full-width window that - ;; can be split, split it. - (if (and window - (not (frame-property (window-frame window) - 'unsplittable)) - (>= (window-height window) split-height-threshold) - (or (>= (window-width window) - split-width-threshold) - (and (window-leftmost-p window) - (window-rightmost-p window)))) - (setq window (split-window window)) - (let (upper other) - (setq window (get-lru-window target-frame)) - ;; If the LRU window is selected, and big enough, - ;; and can be split, split it. - (if (and window - (not (frame-property (window-frame window) - 'unsplittable)) - (or (eq window (selected-window)) - (not (window-parent window))) - (>= (window-height window) - (* 2 window-min-height))) - (setq window (split-window window))) - ;; If get-lru-window returned nil, try other approaches. - ;; Try visible frames first. - (or window - (setq window (or (get-largest-window 'visible) - ;; If that didn't work, try - ;; iconified frames. - (get-largest-window 0) - ;; Try invisible frames. - (get-largest-window t) - ;; As a last resort, make - ;; a new frame. - (frame-selected-window - (funcall - pop-up-frame-function))))) - ;; If window appears above or below another, - ;; even out their heights. - (if (window-previous-child window) - (setq other (window-previous-child window) - upper other)) - (if (window-next-child window) - (setq other (window-next-child window) - upper window)) - ;; Check that OTHER and WINDOW are vertically arrayed. - (if (and other - (not (= (nth 1 (window-pixel-edges other)) - (nth 1 (window-pixel-edges window)))) - (> (window-pixel-height other) - (window-pixel-height window))) - (enlarge-window (- (/ (+ (window-height other) - (window-height window)) - 2) - (window-height upper)) - nil upper)) - ;; Klaus Berndl <klaus.berndl@sdm.de>: Only in - ;; this situation we shrink-to-fit but we can do - ;; this first after we have displayed buffer in - ;; window (s.b. (set-window-buffer window buffer)) - (setq shrink-it shrink-to-fit)))) + ;; If we got a tall enough full-width window that + ;; can be split, split it. + (if (and window + (not (frame-property (window-frame window) + 'unsplittable)) + (>= (window-height window) split-height-threshold) + (or (>= (window-width window) + split-width-threshold) + (and (window-leftmost-p window) + (window-rightmost-p window)))) + (setq window (split-window window)) + (let (upper other) + (setq window (get-lru-window target-frame)) + ;; If the LRU window is selected, and big enough, + ;; and can be split, split it. + (if (and window + (not (frame-property (window-frame window) + 'unsplittable)) + (or (eq window (selected-window)) + (not (window-parent window))) + (>= (window-height window) + (* 2 window-min-height))) + (setq window (split-window window))) + ;; If get-lru-window returned nil, try other + ;; approaches. Try visible frames first. + (or window + (setq window (or (get-largest-window 'visible) + ;; If that didn't work, try + ;; iconified frames. + (get-largest-window 0) + ;; Try invisible frames. + (get-largest-window t) + ;; As a last resort, make + ;; a new frame. + (frame-selected-window + (funcall + pop-up-frame-function))))) + ;; If window appears above or below another, + ;; even out their heights. + (if (window-previous-child window) + (setq other (window-previous-child window) + upper other)) + (if (window-next-child window) + (setq other (window-next-child window) + upper window)) + ;; Check that OTHER and WINDOW are vertically arrayed. + (if (and other + (not (= (nth 1 (window-pixel-edges other)) + (nth 1 (window-pixel-edges window)))) + (> (window-pixel-height other) + (window-pixel-height window))) + (enlarge-window (- (/ (+ (window-height other) + (window-height window)) + 2) + (window-height upper)) + nil upper)) + ;; Klaus Berndl <klaus.berndl@sdm.de>: Only in + ;; this situation we shrink-to-fit but we can do + ;; this first after we have displayed buffer in + ;; window (s.b. (set-window-buffer window buffer)) + (setq shrink-it shrink-to-fit)))) - (setq window (get-lru-window target-frame))) + (setq window (get-lru-window target-frame))) - ;; Bring the window's previous buffer to the top of the MRU chain. - (if (window-buffer window) - (save-excursion - (save-selected-window - (select-window window) - (record-buffer (window-buffer window))))) - - (set-window-buffer window buffer) + ;; Bring the window's previous buffer to the top of the + ;; MRU chain. + (if (window-buffer window) + (save-excursion + (save-selected-window + (select-window window) + (record-buffer (window-buffer window))))) - ;; Now window's previous buffer has been brought to the top - ;; of the MRU chain and window displays buffer - now we can - ;; shrink-to-fit if necessary - (if shrink-it - (shrink-window-if-larger-than-buffer window)) + (set-window-buffer window buffer) - (display-buffer-1 window))))) - (or (equal wconfig (current-window-configuration)) - (push-window-configuration wconfig)) - result)) + ;; Now window's previous buffer has been brought to the + ;; top of the MRU chain and window displays buffer - + ;; now we can shrink-to-fit if necessary + (if shrink-it + (shrink-window-if-larger-than-buffer window)) + (display-buffer-1 window)))) ;; End of prog1's 1th form. + (or (equal wconfig (current-window-configuration)) + (push-window-configuration wconfig))))) ;;; window-xemacs.el ends here