[COMMIT] Remove some utility functions from the global namespace, lisp/

APPROVE COMMIT NOTE: This patch has been committed. Not done for functions like #'fontcolor-property-1 in fontcolor.el because it wouldn’t give a decrease in the size of the dumped XEmacs, and so is less clearly a win. # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net&gt; # Date 1333832251 -3600 # Node ID 5d3bb11008322a79591b3535a0658ab36d6610f2 # Parent 0df3cedee9ac6e12eac0e246466909560da38b3b Remove some utility functions from the global namespace, lisp/ lisp/ChangeLog addition: 2012-04-07 Aidan Kehoe <kehoea(a)parhasard.net&gt; 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. diff -r 0df3cedee9ac -r 5d3bb1100832 lisp/ChangeLog --- 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(a)parhasard.net&gt; + + 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(a)parhasard.net&gt; * select.el (select-coerce): diff -r 0df3cedee9ac -r 5d3bb1100832 lisp/behavior.el --- 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 diff -r 0df3cedee9ac -r 5d3bb1100832 lisp/cus-edit.el --- 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.") diff -r 0df3cedee9ac -r 5d3bb1100832 lisp/menubar.el --- 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 diff -r 0df3cedee9ac -r 5d3bb1100832 lisp/window-xemacs.el --- 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))) + (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))) + ;; 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 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))) + ;; 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))) - ;; 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 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))) - (setq target-frame - (or explicit-frame - (last-nonminibuf-frame) - (selected-frame))) + (setq target-frame + (or explicit-frame + (last-nonminibuf-frame) + (selected-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)) + ;; 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)) - ;; 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 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)))) - ;; See if the user has specified this buffer should appear - ;; in the selected window. + ;; See if the user has specified this buffer should + ;; appear in the selected window. - (if not-this-window-p - nil + (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))))) - (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))))) + (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))))) - (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 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))))) + (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))) - ;; 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))) + (let ((tem (assoc (buffer-name buffer) + special-display-buffer-names))) + (if tem + (return (funcall special-display-function + buffer (cdr tem))))) - ;; 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 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)))))) - (let ((tem (assoc (buffer-name buffer) - special-display-buffer-names))) - (if tem - (throw 'done (funcall special-display-function - buffer (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) + (return (display-buffer-1 window)))) - (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)))))) + ;; 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))) - ;; 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)))) + ;; 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))) - ;; 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))) + ;; Same with width. + (if (< split-width-threshold (* 2 window-min-width)) + (setq split-width-threshold (* 2 window-min-width))) - ;; 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))) + ;; 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))) - ;; Same with width. - (if (< split-width-threshold (* 2 window-min-width)) - (setq split-width-threshold (* 2 window-min-width))) + ;; 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(a)sdm.de&gt;: 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 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))) + (setq window (get-lru-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(a)sdm.de&gt;: 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)))) + ;; 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))))) - (setq window (get-lru-window target-frame))) + (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))))) - - (set-window-buffer window buffer) - - ;; 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))))) - (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 -- ‘Iodine deficiency was endemic in parts of the UK until, through what has been described as “an unplanned and accidental public health triumph”, iodine was added to cattle feed to improve milk production in the 1930s.’ (EN Pearce, Lancet, June 2011) _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://lists.xemacs.org/mailman/listinfo/xemacs-patches