X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/4ffd0d6b569d252e4e807d4e9c9d6a5bd5b08640..77c7bcb1157b405bde1227b20ef5f7ce9a90e689:/lisp/winner.el diff --git a/lisp/winner.el b/lisp/winner.el index e5855ad8aa..d808a54a10 100644 --- a/lisp/winner.el +++ b/lisp/winner.el @@ -1,6 +1,6 @@ ;;; winner.el --- Restore old window configurations -;; Copyright (C) 1997-1998, 2001-2011 Free Software Foundation. Inc. +;; Copyright (C) 1997-1998, 2001-2012 Free Software Foundation, Inc. ;; Author: Ivar Rummelhoff ;; Created: 27 Feb 1997 @@ -38,20 +38,17 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) - -(defmacro winner-active-region () +(defun winner-active-region () + (declare (gv-setter (lambda (store) + (if (featurep 'xemacs) + `(if ,store (zmacs-activate-region) + (zmacs-deactivate-region)) + `(setq mark-active ,store))))) (if (boundp 'mark-active) - 'mark-active - '(region-active-p))) - -(defsetf winner-active-region () (store) - (if (featurep 'xemacs) - `(if ,store (zmacs-activate-region) - (zmacs-deactivate-region)) - `(setq mark-active ,store))) + mark-active + (region-active-p))) (defalias 'winner-edges (if (featurep 'xemacs) 'window-pixel-edges 'window-edges)) @@ -107,15 +104,15 @@ You may want to include buffer names such as *Help*, *Apropos*, (defun winner-sorted-window-list () (sort (winner-window-list) (lambda (x y) - (loop for a in (winner-edges x) - for b in (winner-edges y) - while (= a b) - finally return (< a b))))) + (cl-loop for a in (winner-edges x) + for b in (winner-edges y) + while (= a b) + finally return (< a b))))) (defun winner-win-data () ;; Essential properties of the windows in the selected frame. - (loop for win in (winner-sorted-window-list) - collect (cons (winner-edges win) (window-buffer win)))) + (cl-loop for win in (winner-sorted-window-list) + collect (cons (winner-edges win) (window-buffer win)))) ;; This variable is updated with the current window configuration ;; every time it changes. @@ -138,14 +135,14 @@ You may want to include buffer names such as *Help*, *Apropos*, ;; Consult `winner-currents'. (defun winner-configuration (&optional frame) (or (cdr (assq (or frame (selected-frame)) winner-currents)) - (letf (((selected-frame) frame)) + (with-selected-frame frame (winner-conf)))) ;;; Saved configurations -;; This variable contains the window cofiguration rings. +;; This variable contains the window configuration rings. ;; The key in this alist is the frame. (defvar winner-ring-alist nil) @@ -240,15 +237,15 @@ You may want to include buffer names such as *Help*, *Apropos*, (let* ((miniwin (minibuffer-window)) (chosen (selected-window)) (minisize (window-height miniwin))) - (letf (((window-buffer miniwin)) - ((window-point miniwin))) + (cl-letf (((window-buffer miniwin)) + ((window-point miniwin))) (set-window-configuration winconf)) (cond ((window-live-p chosen) (select-window chosen)) ((window-minibuffer-p (selected-window)) (other-window 1))) (when (/= minisize (window-height miniwin)) - (letf (((selected-window) miniwin) ) + (with-selected-window miniwin (setf (window-height) minisize))))) @@ -261,17 +258,17 @@ You may want to include buffer names such as *Help*, *Apropos*, ;; Format of entries: (buffer (mark . mark-active) (window . point) ..) (defun winner-make-point-alist () - (letf (((current-buffer))) - (loop with alist - for win in (winner-window-list) - for entry = - (or (assq (window-buffer win) alist) - (car (push (list (set-buffer (window-buffer win)) - (cons (mark t) (winner-active-region))) - alist))) - do (push (cons win (window-point win)) - (cddr entry)) - finally return alist))) + (save-current-buffer + (cl-loop with alist + for win in (winner-window-list) + for entry = + (or (assq (window-buffer win) alist) + (car (push (list (set-buffer (window-buffer win)) + (cons (mark t) (winner-active-region))) + alist))) + do (push (cons win (window-point win)) + (cddr entry)) + finally return alist))) (defun winner-get-point (buf win) ;; Consult (and possibly extend) `winner-point-alist'. @@ -282,10 +279,10 @@ You may want to include buffer names such as *Help*, *Apropos*, (entry (or (cdr (assq win (cddr entry))) (cdr (assq nil (cddr entry))) - (letf (((current-buffer) buf)) + (with-current-buffer buf (push (cons nil (point)) (cddr entry)) (point)))) - (t (letf (((current-buffer) buf)) + (t (with-current-buffer buf (push (list buf (cons (mark t) (winner-active-region)) (cons nil (point))) @@ -302,11 +299,11 @@ You may want to include buffer names such as *Help*, *Apropos*, (let* ((buffers nil) (alive ;; Possibly update `winner-point-alist' - (loop for buf in (mapcar 'cdr (cdr conf)) - for pos = (winner-get-point buf nil) - if (and pos (not (memq buf buffers))) - do (push buf buffers) - collect pos))) + (cl-loop for buf in (mapcar 'cdr (cdr conf)) + for pos = (winner-get-point buf nil) + if (and pos (not (memq buf buffers))) + do (push buf buffers) + collect pos))) (winner-set-conf (car conf)) (let (xwins) ; to be deleted @@ -320,12 +317,12 @@ You may want to include buffer names such as *Help*, *Apropos*, (push win xwins))) ; delete this window ;; Restore marks - (letf (((current-buffer))) - (loop for buf in buffers - for entry = (cadr (assq buf winner-point-alist)) - do (progn (set-buffer buf) - (set-mark (car entry)) - (setf (winner-active-region) (cdr entry))))) + (save-current-buffer + (cl-loop for buf in buffers + for entry = (cadr (assq buf winner-point-alist)) + do (progn (set-buffer buf) + (set-mark (car entry)) + (setf (winner-active-region) (cdr entry))))) ;; Delete windows, whose buffers are dead or boring. ;; Return t if this is still a possible configuration. (or (null xwins) @@ -422,7 +419,7 @@ In other words, \"undo\" changes in window configuration." (setq winner-pending-undo-ring (winner-ring (selected-frame))) (setq winner-undo-counter 0) (setq winner-undone-data (list (winner-win-data)))) - (incf winner-undo-counter) ; starting at 1 + (cl-incf winner-undo-counter) ; starting at 1 (when (and (winner-undo-this) (not (window-minibuffer-p (selected-window)))) (message "Winner undo (%d / %d)" @@ -433,11 +430,11 @@ In other words, \"undo\" changes in window configuration." (defun winner-undo-this () ; The heart of winner undo. - (loop + (cl-loop (cond ((>= winner-undo-counter (ring-length winner-pending-undo-ring)) (message "No further window configuration undo information") - (return nil)) + (cl-return nil)) ((and ; If possible configuration (winner-set (ring-ref winner-pending-undo-ring @@ -446,7 +443,7 @@ In other words, \"undo\" changes in window configuration." (let ((data (winner-win-data))) (and (not (member data winner-undone-data)) (push data winner-undone-data)))) - (return t)) ; .. then everything is fine. + (cl-return t)) ; .. then everything is fine. (t ;; Otherwise, discharge it (and try the next one). (ring-remove winner-pending-undo-ring winner-undo-counter)))))