From d96a4f88299679f64c49f44d94fd61d0548b351e Mon Sep 17 00:00:00 2001 From: Glenn Morris Date: Tue, 17 Apr 2012 06:21:15 -0400 Subject: Auto-commit of loaddefs files. --- lisp/emacs-lisp/cl-loaddefs.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp/emacs-lisp/cl-loaddefs.el') diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index 5bb86628bb8..9e0099bb649 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -10,7 +10,7 @@ ;;;;;; ceiling* floor* isqrt lcm gcd cl-progv-before cl-set-frame-visible-p ;;;;;; cl-map-overlays cl-map-intervals cl-map-keymap-recursively ;;;;;; notevery notany every some mapcon mapcan mapl maplist map -;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "c172dda6770ce18b556561481bfefbb2") +;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "5a8a7f7ec2dc453113b8cbda577f2acb") ;;; Generated autoloads from cl-extra.el (autoload 'coerce "cl-extra" "\ -- cgit v1.2.3 From 0d42eb3e961e612b1b04e32e99c2998dd4d5d3be Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 25 Apr 2012 23:18:47 -0400 Subject: * lisp/vc/vc-mtn.el: * lisp/vc/vc-hg.el: * lisp/vc/vc-git.el: * lisp/vc/vc-dir.el: * lisp/vc/vc-cvs.el: * lisp/vc/vc-bzr.el: * lisp/vc/vc-arch.el: * lisp/vc/vc.el: Replace lexical-let by lexical-binding. * lisp/minibuffer.el (lazy-completion-table): Avoid ((λ ...) ...). * lisp/emacs-lisp/cl-macs.el (lexical-let): Fix use in lexical-binding. * lisp/emacs-lisp/cconv.el (cconv-analyse-form): Warn use of ((λ ...) ...). MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- lisp/ChangeLog | 14 +++ lisp/emacs-lisp/cconv.el | 4 +- lisp/emacs-lisp/cl-loaddefs.el | 2 +- lisp/emacs-lisp/cl-macs.el | 22 +++-- lisp/files.el | 3 +- lisp/minibuffer.el | 2 +- lisp/vc/vc-arch.el | 34 ++++--- lisp/vc/vc-bzr.el | 209 ++++++++++++++++++++--------------------- lisp/vc/vc-cvs.el | 16 ++-- lisp/vc/vc-dir.el | 31 +++--- lisp/vc/vc-git.el | 28 +++--- lisp/vc/vc-hg.el | 25 +++-- lisp/vc/vc-mtn.el | 81 ++++++++-------- lisp/vc/vc.el | 173 +++++++++++++++------------------- 14 files changed, 317 insertions(+), 327 deletions(-) (limited to 'lisp/emacs-lisp/cl-loaddefs.el') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 04271849758..bb40b542792 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,17 @@ +2012-04-26 Stefan Monnier + + * vc/vc-mtn.el: + * vc/vc-hg.el: + * vc/vc-git.el: + * vc/vc-dir.el: + * vc/vc-cvs.el: + * vc/vc-bzr.el: + * vc/vc-arch.el: + * vc/vc.el: Replace lexical-let by lexical-binding. + * minibuffer.el (lazy-completion-table): Avoid ((λ ...) ...). + * emacs-lisp/cl-macs.el (lexical-let): Fix use in lexical-binding. + * emacs-lisp/cconv.el (cconv-analyse-form): Warn use of ((λ ...) ...). + 2012-04-26 Chong Yidong * vc/ediff-wind.el (ediff-setup-windows-default): New function. diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index b6b6a78a9bb..3ce0eadab55 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -639,7 +639,9 @@ and updates the data stored in ENV." (cconv-analyse-form (cadr forms) env) (setq forms (cddr forms)))) - (`((lambda . ,_) . ,_) ; first element is lambda expression + (`((lambda . ,_) . ,_) ; First element is lambda expression. + (byte-compile-log-warning + "Use of deprecated ((lambda ...) ...) form" t :warning) (dolist (exp `((function ,(car form)) . ,(cdr form))) (cconv-analyse-form exp env))) diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index 9e0099bb649..48be2f72972 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -286,7 +286,7 @@ This also does some trivial optimizations to make the form prettier. ;;;;;; flet progv psetq do-all-symbols do-symbols dotimes dolist ;;;;;; do* do loop return-from return block etypecase typecase ecase ;;;;;; case load-time-value eval-when destructuring-bind function* -;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "91b45885535a73dd8015973cb8c988e1") +;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "abb2e33c6f61539d69ddbe7c4046261b") ;;; Generated autoloads from cl-macs.el (autoload 'gensym "cl-macs" "\ diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 4fc71bbbc60..35cda8cfcf6 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -1483,18 +1483,24 @@ lexical closures as in Common Lisp. (cons 'progn body) (nconc (mapcar (function (lambda (x) (list (symbol-name (car x)) - (list 'symbol-value (caddr x)) + (list 'symbol-value (caddr x)) t))) vars) (list '(defun . cl-defun-expander)) cl-macro-environment)))) (if (not (get (car (last cl-closure-vars)) 'used)) - (list 'let (mapcar (function (lambda (x) - (list (caddr x) (cadr x)))) vars) - (sublis (mapcar (function (lambda (x) - (cons (caddr x) - (list 'quote (caddr x))))) - vars) - ebody)) + ;; Turn (let ((foo (gensym))) (set foo ) ...(symbol-value foo)...) + ;; into (let ((foo )) ...(symbol-value 'foo)...). + ;; This is good because it's more efficient but it only works with + ;; dynamic scoping, since with lexical scoping we'd need + ;; (let ((foo )) ...foo...). + `(progn + ,@(mapcar (lambda (x) `(defvar ,(caddr x))) vars) + (let ,(mapcar (lambda (x) (list (caddr x) (cadr x))) vars) + ,(sublis (mapcar (lambda (x) + (cons (caddr x) + (list 'quote (caddr x)))) + vars) + ebody))) (list 'let (mapcar (function (lambda (x) (list (caddr x) (list 'make-symbol diff --git a/lisp/files.el b/lisp/files.el index 703b443765d..96a5b40e791 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -3642,7 +3642,8 @@ and `file-local-variables-alist', without applying them." (when (and enable-local-variables (not (file-remote-p (or (buffer-file-name) default-directory)))) ;; Find the variables file. - (let ((variables-file (dir-locals-find-file (or (buffer-file-name) default-directory))) + (let ((variables-file (dir-locals-find-file + (or (buffer-file-name) default-directory))) (class nil) (dir-name nil)) (cond diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 733a132bb1c..59bd0d231dc 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -199,7 +199,7 @@ You should give VAR a non-nil `risky-local-variable' property." `(completion-table-dynamic (lambda (,str) (when (functionp ,var) - (setq ,var (,fun))) + (setq ,var (funcall #',fun))) ,var)))) (defun completion-table-case-fold (table &optional dont-fold) diff --git a/lisp/vc/vc-arch.el b/lisp/vc/vc-arch.el index 052e6784b08..18dfbe1f5fa 100644 --- a/lisp/vc/vc-arch.el +++ b/lisp/vc/vc-arch.el @@ -1,4 +1,4 @@ -;;; vc-arch.el --- VC backend for the Arch version-control system +;;; vc-arch.el --- VC backend for the Arch version-control system -*- lexical-binding: t -*- ;; Copyright (C) 2004-2012 Free Software Foundation, Inc. @@ -59,7 +59,7 @@ ;;; Properties of the backend (defun vc-arch-revision-granularity () 'repository) -(defun vc-arch-checkout-model (files) 'implicit) +(defun vc-arch-checkout-model (_files) 'implicit) ;;; ;;; Customization options @@ -227,7 +227,7 @@ Only the value `maybe' can be trusted :-(." (vc-file-setprop file 'arch-root root))))) -(defun vc-arch-register (files &optional rev comment) +(defun vc-arch-register (files &optional rev _comment) (if rev (error "Explicit initial revision not supported for Arch")) (dolist (file files) (let ((tagmet (vc-arch-tagging-method file))) @@ -258,7 +258,7 @@ Only the value `maybe' can be trusted :-(." ;; Strip the terminating newline. (buffer-substring (point-min) (1- (point-max))))))))) -(defun vc-arch-workfile-unchanged-p (file) +(defun vc-arch-workfile-unchanged-p (_file) "Stub: arch workfiles are always considered to be in a changed state," nil) @@ -508,12 +508,11 @@ CALLBACK expects (ENTRIES &optional MORE-TO-COME); see "*")))))) (defun vc-arch-revision-completion-table (files) - (lexical-let ((files files)) - (lambda (string pred action) - ;; FIXME: complete revision patches as well. - (let* ((root (expand-file-name "{arch}" (vc-arch-root (car files)))) - (table (vc-arch--version-completion-table root string))) - (complete-with-action action table string pred))))) + (lambda (string pred action) + ;; FIXME: complete revision patches as well. + (let* ((root (expand-file-name "{arch}" (vc-arch-root (car files)))) + (table (vc-arch--version-completion-table root string))) + (complete-with-action action table string pred)))) ;;; Trimming revision libraries. @@ -547,13 +546,12 @@ CALLBACK expects (ENTRIES &optional MORE-TO-COME); see minrev)) (defun vc-arch-trim-make-sentinel (revs) - (if (null revs) (lambda (proc msg) (message "VC-Arch trimming ... done")) - (lexical-let ((revs revs)) - (lambda (proc msg) - (message "VC-Arch trimming %s..." (file-name-nondirectory (car revs))) - (rename-file (car revs) (concat (car revs) "*rm*")) - (setq proc (start-process "vc-arch-trim" nil - "rm" "-rf" (concat (car revs) "*rm*"))) + (if (null revs) (lambda (_proc _msg) (message "VC-Arch trimming ... done")) + (lambda (_proc _msg) + (message "VC-Arch trimming %s..." (file-name-nondirectory (car revs))) + (rename-file (car revs) (concat (car revs) "*rm*")) + (let ((proc (start-process "vc-arch-trim" nil + "rm" "-rf" (concat (car revs) "*rm*")))) (set-process-sentinel proc (vc-arch-trim-make-sentinel (cdr revs))))))) (defun vc-arch-trim-one-revlib (dir) @@ -572,7 +570,7 @@ CALLBACK expects (ENTRIES &optional MORE-TO-COME); see 'car-less-than-car)) (subdirs nil)) (when (cddr revs) - (dotimes (i (/ (length revs) 2)) + (dotimes (_i (/ (length revs) 2)) (let ((minrev (vc-arch-trim-find-least-useful-rev revs))) (setq revs (delq minrev revs)) (push minrev subdirs))) diff --git a/lisp/vc/vc-bzr.el b/lisp/vc/vc-bzr.el index 505e40f46ba..5488e53e32f 100644 --- a/lisp/vc/vc-bzr.el +++ b/lisp/vc/vc-bzr.el @@ -1,4 +1,4 @@ -;;; vc-bzr.el --- VC backend for the bzr revision control system +;;; vc-bzr.el --- VC backend for the bzr revision control system -*- lexical-binding: t -*- ;; Copyright (C) 2006-2012 Free Software Foundation, Inc. @@ -41,7 +41,7 @@ ;;; Properties of the backend (defun vc-bzr-revision-granularity () 'repository) -(defun vc-bzr-checkout-model (files) 'implicit) +(defun vc-bzr-checkout-model (_files) 'implicit) ;;; Code: @@ -208,9 +208,9 @@ in the repository root directory of FILE." ;; + working ( = packed_stat ) ;; parent = common ( as above ) + history ( = rev_id ) ;; kinds = (r)elocated, (a)bsent, (d)irectory, (f)ile, (l)ink - (lexical-let ((root (vc-bzr-root file))) + (let ((root (vc-bzr-root file))) (when root ; Short cut. - (lexical-let ((dirstate (expand-file-name vc-bzr-admin-dirstate root))) + (let ((dirstate (expand-file-name vc-bzr-admin-dirstate root))) (condition-case nil (with-temp-buffer (insert-file-contents dirstate) @@ -303,9 +303,8 @@ in the repository root directory of FILE." (defun vc-bzr-file-name-relative (filename) "Return file name FILENAME stripped of the initial Bzr repository path." - (lexical-let* - ((filename* (expand-file-name filename)) - (rootdir (vc-bzr-root filename*))) + (let* ((filename* (expand-file-name filename)) + (rootdir (vc-bzr-root filename*))) (when rootdir (file-relative-name filename* rootdir)))) @@ -412,9 +411,8 @@ in the branch repository (or whose status not be determined)." (with-temp-buffer ;; This is with-demoted-errors without the condition-case-unless-debug ;; annoyance, which makes it fail during ert testing. - (let (err) - (condition-case err (vc-bzr-command "status" t 0 file) - (error (message "Error: %S" err) nil))) + (condition-case err (vc-bzr-command "status" t 0 file) + (error (message "Error: %S" err) nil)) (let ((status 'unchanged)) ;; the only secure status indication in `bzr status' output ;; is a couple of lines following the pattern:: @@ -433,7 +431,7 @@ in the branch repository (or whose status not be determined)." (if (file-directory-p file) "/?" "\\*?") "[ \t\n]*$") nil t) - (lexical-let ((statusword (match-string 1))) + (let ((statusword (match-string 1))) ;; Erase the status text that matched. (delete-region (match-beginning 0) (match-end 0)) (setq status @@ -452,7 +450,7 @@ in the branch repository (or whose status not be determined)." (unless (eobp) (buffer-substring (point) (point-max)))))))) (defun vc-bzr-state (file) - (lexical-let ((result (vc-bzr-status file))) + (let ((result (vc-bzr-status file))) (when (consp result) (let ((warnings (cdr result))) (when warnings @@ -504,16 +502,15 @@ in the branch repository (or whose status not be determined)." (defun vc-bzr-working-revision (file) ;; Together with the code in vc-state-heuristic, this makes it possible ;; to get the initial VC state of a Bzr file even if Bzr is not installed. - (lexical-let* - ((rootdir (vc-bzr-root file)) - (branch-format-file (expand-file-name vc-bzr-admin-branch-format-file - rootdir)) - (revhistory-file (expand-file-name vc-bzr-admin-revhistory rootdir)) - (lastrev-file (expand-file-name vc-bzr-admin-lastrev rootdir))) + (let* ((rootdir (vc-bzr-root file)) + (branch-format-file (expand-file-name vc-bzr-admin-branch-format-file + rootdir)) + (revhistory-file (expand-file-name vc-bzr-admin-revhistory rootdir)) + (lastrev-file (expand-file-name vc-bzr-admin-lastrev rootdir))) ;; This looks at internal files to avoid forking a bzr process. ;; May break if they change their format. (if (and (file-exists-p branch-format-file) - ;; For lightweight checkouts (obtained with bzr checkout --lightweight) + ;; For lightweight checkouts (obtained with bzr co --lightweight) ;; the branch-format-file does not contain the revision ;; information, we need to look up the branch-format-file ;; in the place where the lightweight checkout comes @@ -532,17 +529,21 @@ in the branch repository (or whose status not be determined)." (when (re-search-forward "file://\\(.+\\)" nil t) (let ((l-c-parent-dir (match-string 1))) (when (and (memq system-type '(ms-dos windows-nt)) - (string-match-p "^/[[:alpha:]]:" l-c-parent-dir)) - ;;; The non-Windows code takes a shortcut by using the host/path - ;;; separator slash as the start of the absolute path. That - ;;; does not work on Windows, so we must remove it (bug#5345) + (string-match-p "^/[[:alpha:]]:" + l-c-parent-dir)) + ;;; The non-Windows code takes a shortcut by using + ;;; the host/path separator slash as the start of + ;;; the absolute path. That does not work on + ;;; Windows, so we must remove it (bug#5345) (setq l-c-parent-dir (substring l-c-parent-dir 1))) (setq branch-format-file (expand-file-name vc-bzr-admin-branch-format-file l-c-parent-dir)) (setq lastrev-file - (expand-file-name vc-bzr-admin-lastrev l-c-parent-dir)) - ;; FIXME: maybe it's overkill to check if both these files exist. + (expand-file-name vc-bzr-admin-lastrev + l-c-parent-dir)) + ;; FIXME: maybe it's overkill to check if both these + ;; files exist. (and (file-exists-p branch-format-file) (file-exists-p lastrev-file))))) t))) @@ -564,11 +565,10 @@ in the branch repository (or whose status not be determined)." (when (re-search-forward "[0-9]+" nil t) (buffer-substring (match-beginning 0) (match-end 0)))))) ;; fallback to calling "bzr revno" - (lexical-let* - ((result (vc-bzr-command-discarding-stderr - vc-bzr-program "revno" (file-relative-name file))) - (exitcode (car result)) - (output (cdr result))) + (let* ((result (vc-bzr-command-discarding-stderr + vc-bzr-program "revno" (file-relative-name file))) + (exitcode (car result)) + (output (cdr result))) (cond ((eq exitcode 0) (substring output 0 -1)) (t nil)))))) @@ -577,21 +577,21 @@ in the branch repository (or whose status not be determined)." "Create a new Bzr repository." (vc-bzr-command "init" nil 0 nil)) -(defun vc-bzr-init-revision (&optional file) +(defun vc-bzr-init-revision (&optional _file) "Always return nil, as Bzr cannot register explicit versions." nil) -(defun vc-bzr-previous-revision (file rev) +(defun vc-bzr-previous-revision (_file rev) (if (string-match "\\`[0-9]+\\'" rev) (number-to-string (1- (string-to-number rev))) (concat "before:" rev))) -(defun vc-bzr-next-revision (file rev) +(defun vc-bzr-next-revision (_file rev) (if (string-match "\\`[0-9]+\\'" rev) (number-to-string (1+ (string-to-number rev))) (error "Don't know how to compute the next revision of %s" rev))) -(defun vc-bzr-register (files &optional rev comment) +(defun vc-bzr-register (files &optional rev _comment) "Register FILES under bzr. Signal an error unless REV is nil. COMMENT is ignored." @@ -640,7 +640,7 @@ REV non-nil gets an error." (vc-bzr-command "cat" t 0 file "-r" rev) (vc-bzr-command "cat" t 0 file)))) -(defun vc-bzr-checkout (file &optional editable rev) +(defun vc-bzr-checkout (_file &optional _editable rev) (if rev (error "Operation not supported") ;; Else, there's nothing to do. nil)) @@ -791,7 +791,7 @@ Each line is tagged with the revision number, which has a `help-echo' property containing author and date information." (apply #'vc-bzr-command "annotate" buffer 'async file "--long" "--all" (if revision (list "-r" revision))) - (lexical-let ((table (make-hash-table :test 'equal))) + (let ((table (make-hash-table :test 'equal))) (set-process-filter (get-buffer-process buffer) (lambda (proc string) @@ -956,7 +956,7 @@ stream. Standard error output is discarded." ;; frob the results accordingly. (file-relative-name ,dir (vc-bzr-root ,dir))))) -(defun vc-bzr-dir-status-files (dir files default-state update-function) +(defun vc-bzr-dir-status-files (dir files _default-state update-function) "Return a list of conses (file . state) for DIR." (apply 'vc-bzr-command "status" (current-buffer) 'async dir "-v" "-S" files) (vc-exec-after @@ -1193,74 +1193,73 @@ stream. Standard error output is discarded." "revno" "submit" "tag"))) (defun vc-bzr-revision-completion-table (files) - (lexical-let ((files files)) - ;; What about using `files'?!? --Stef - (lambda (string pred action) - (cond - ((string-match "\\`\\(ancestor\\|branch\\|\\(revno:\\)?[-0-9]+:\\):" - string) - (completion-table-with-context (substring string 0 (match-end 0)) - (apply-partially - 'completion-table-with-predicate - 'completion-file-name-table - 'file-directory-p t) - (substring string (match-end 0)) - pred - action)) - ((string-match "\\`\\(before\\):" string) - (completion-table-with-context (substring string 0 (match-end 0)) - (vc-bzr-revision-completion-table files) - (substring string (match-end 0)) - pred - action)) - ((string-match "\\`\\(tag\\):" string) - (let ((prefix (substring string 0 (match-end 0))) - (tag (substring string (match-end 0))) - (table nil) - process-file-side-effects) - (with-temp-buffer - ;; "bzr-1.2 tags" is much faster with --show-ids. - (process-file vc-bzr-program nil '(t) nil "tags" "--show-ids") - ;; The output is ambiguous, unless we assume that revids do not - ;; contain spaces. - (goto-char (point-min)) - (while (re-search-forward "^\\(.*[^ \n]\\) +[^ \n]*$" nil t) - (push (match-string-no-properties 1) table))) - (completion-table-with-context prefix table tag pred action))) - - ((string-match "\\`annotate:" string) - (completion-table-with-context - (substring string 0 (match-end 0)) - (apply-partially #'completion-table-with-terminator '(":" . "\\`a\\`") - #'completion-file-name-table) - (substring string (match-end 0)) pred action)) - - ((string-match "\\`date:" string) - (completion-table-with-context - (substring string 0 (match-end 0)) - '("yesterday" "today" "tomorrow") - (substring string (match-end 0)) pred action)) - - ((string-match "\\`\\([a-z]+\\):" string) - ;; no actual completion for the remaining keywords. - (completion-table-with-context (substring string 0 (match-end 0)) - (if (member (match-string 1 string) - vc-bzr-revision-keywords) - ;; If it's a valid keyword, - ;; use a non-empty table to - ;; indicate it. - '("") nil) - (substring string (match-end 0)) - pred - action)) - (t - ;; Could use completion-table-with-terminator, except that it - ;; currently doesn't work right w.r.t pcm and doesn't give - ;; the *Completions* output we want. - (complete-with-action action (eval-when-compile - (mapcar (lambda (s) (concat s ":")) - vc-bzr-revision-keywords)) - string pred)))))) + ;; What about using `files'?!? --Stef + (lambda (string pred action) + (cond + ((string-match "\\`\\(ancestor\\|branch\\|\\(revno:\\)?[-0-9]+:\\):" + string) + (completion-table-with-context (substring string 0 (match-end 0)) + (apply-partially + 'completion-table-with-predicate + 'completion-file-name-table + 'file-directory-p t) + (substring string (match-end 0)) + pred + action)) + ((string-match "\\`\\(before\\):" string) + (completion-table-with-context (substring string 0 (match-end 0)) + (vc-bzr-revision-completion-table files) + (substring string (match-end 0)) + pred + action)) + ((string-match "\\`\\(tag\\):" string) + (let ((prefix (substring string 0 (match-end 0))) + (tag (substring string (match-end 0))) + (table nil) + process-file-side-effects) + (with-temp-buffer + ;; "bzr-1.2 tags" is much faster with --show-ids. + (process-file vc-bzr-program nil '(t) nil "tags" "--show-ids") + ;; The output is ambiguous, unless we assume that revids do not + ;; contain spaces. + (goto-char (point-min)) + (while (re-search-forward "^\\(.*[^ \n]\\) +[^ \n]*$" nil t) + (push (match-string-no-properties 1) table))) + (completion-table-with-context prefix table tag pred action))) + + ((string-match "\\`annotate:" string) + (completion-table-with-context + (substring string 0 (match-end 0)) + (apply-partially #'completion-table-with-terminator '(":" . "\\`a\\`") + #'completion-file-name-table) + (substring string (match-end 0)) pred action)) + + ((string-match "\\`date:" string) + (completion-table-with-context + (substring string 0 (match-end 0)) + '("yesterday" "today" "tomorrow") + (substring string (match-end 0)) pred action)) + + ((string-match "\\`\\([a-z]+\\):" string) + ;; no actual completion for the remaining keywords. + (completion-table-with-context (substring string 0 (match-end 0)) + (if (member (match-string 1 string) + vc-bzr-revision-keywords) + ;; If it's a valid keyword, + ;; use a non-empty table to + ;; indicate it. + '("") nil) + (substring string (match-end 0)) + pred + action)) + (t + ;; Could use completion-table-with-terminator, except that it + ;; currently doesn't work right w.r.t pcm and doesn't give + ;; the *Completions* output we want. + (complete-with-action action (eval-when-compile + (mapcar (lambda (s) (concat s ":")) + vc-bzr-revision-keywords)) + string pred))))) (provide 'vc-bzr) diff --git a/lisp/vc/vc-cvs.el b/lisp/vc/vc-cvs.el index 2d8d132a249..4d06e766a35 100644 --- a/lisp/vc/vc-cvs.el +++ b/lisp/vc/vc-cvs.el @@ -1,4 +1,4 @@ -;;; vc-cvs.el --- non-resident support for CVS version-control +;;; vc-cvs.el --- non-resident support for CVS version-control -*- lexical-binding: t -*- ;; Copyright (C) 1995, 1998-2012 Free Software Foundation, Inc. @@ -280,7 +280,7 @@ committed and support display of sticky tags." ;;; State-changing functions ;;; -(defun vc-cvs-register (files &optional rev comment) +(defun vc-cvs-register (files &optional _rev comment) "Register FILES into the CVS version-control system. COMMENT can be used to provide an initial description of FILES. Passes either `vc-cvs-register-switches' or `vc-register-switches' @@ -502,7 +502,7 @@ Will fail unless you have administrative privileges on the repo." (declare-function vc-rcs-print-log-cleanup "vc-rcs" ()) -(defun vc-cvs-print-log (files buffer &optional shortlog start-revision-ignored limit) +(defun vc-cvs-print-log (files buffer &optional _shortlog _start-revision limit) "Get change logs associated with FILES." (require 'vc-rcs) ;; It's just the catenation of the individual logs. @@ -1006,7 +1006,7 @@ state." (vc-exec-after `(vc-cvs-after-dir-status (quote ,update-function)))))) -(defun vc-cvs-dir-status-files (dir files default-state update-function) +(defun vc-cvs-dir-status-files (dir files _default-state update-function) "Create a list of conses (file . state) for DIR." (apply 'vc-cvs-command (current-buffer) 'async dir "-f" "status" files) (vc-exec-after @@ -1021,7 +1021,7 @@ state." (buffer-substring (point) (point-max))) (file-error nil))) -(defun vc-cvs-dir-extra-headers (dir) +(defun vc-cvs-dir-extra-headers (_dir) "Extract and represent per-directory properties of a CVS working copy." (let ((repo (condition-case nil @@ -1206,10 +1206,8 @@ is non-nil." res))) (defun vc-cvs-revision-completion-table (files) - (lexical-let ((files files) - table) - (setq table (lazy-completion-table - table (lambda () (vc-cvs-revision-table (car files))))) + (letrec ((table (lazy-completion-table + table (lambda () (vc-cvs-revision-table (car files)))))) table)) diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index 4c32eea2f72..acb1a4d8862 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -1,4 +1,4 @@ -;;; vc-dir.el --- Directory status display under VC +;;; vc-dir.el --- Directory status display under VC -*- lexical-binding: t -*- ;; Copyright (C) 2007-2012 Free Software Foundation, Inc. @@ -529,7 +529,7 @@ If a prefix argument is given, move by that many lines." (defun vc-dir-mark-unmark (mark-unmark-function) (if (use-region-p) - (let ((firstl (line-number-at-pos (region-beginning))) + (let (;; (firstl (line-number-at-pos (region-beginning))) (lastl (line-number-at-pos (region-end)))) (save-excursion (goto-char (region-beginning)) @@ -546,7 +546,7 @@ If a prefix argument is given, move by that many lines." ;; Non-nil iff a parent directory of arg is marked. ;; Return value, if non-nil is the `ewoc-data' for the marked parent. (let* ((argdir (vc-dir-node-directory arg)) - (arglen (length argdir)) + ;; (arglen (length argdir)) (crt arg) (found nil)) ;; Go through the predecessors, checking if any directory that is @@ -814,7 +814,7 @@ child files." ;; FIXME: use vc-dir-child-files-and-states here instead of duplicating it. (if (vc-dir-fileinfo->directory crt-data) (let* ((dir (vc-dir-fileinfo->directory crt-data)) - (dirlen (length dir)) + ;; (dirlen (length dir)) data) (while (and (setq crt (ewoc-next vc-ewoc crt)) @@ -842,7 +842,7 @@ If it is a file, return the corresponding cons for the file itself." result) (if (vc-dir-fileinfo->directory crt-data) (let* ((dir (vc-dir-fileinfo->directory crt-data)) - (dirlen (length dir)) + ;; (dirlen (length dir)) data) (while (and (setq crt (ewoc-next vc-ewoc crt)) @@ -861,7 +861,7 @@ If it is a file, return the corresponding cons for the file itself." (defun vc-dir-recompute-file-state (fname def-dir) (let* ((file-short (file-relative-name fname def-dir)) - (remove-me-when-CVS-works + (_remove-me-when-CVS-works (when (eq vc-dir-backend 'CVS) ;; FIXME: Warning: UGLY HACK. The CVS backend caches the state ;; info, this forces the backend to update it. @@ -875,15 +875,14 @@ If it is a file, return the corresponding cons for the file itself." ;; Give a DIRNAME string return the list of all child files shown in ;; the current *vc-dir* buffer. (let ((crt (ewoc-nth vc-ewoc 0)) - children - dname) + children) ;; Find DIR (while (and crt (not (string-prefix-p dirname (vc-dir-node-directory crt)))) (setq crt (ewoc-next vc-ewoc crt))) (while (and crt (string-prefix-p dirname - (setq dname (vc-dir-node-directory crt)))) + (vc-dir-node-directory crt))) (let ((data (ewoc-data crt))) (unless (vc-dir-fileinfo->directory data) (push (expand-file-name (vc-dir-fileinfo->name data)) children))) @@ -1014,7 +1013,7 @@ specific headers." (unless (buffer-live-p vc-dir-process-buffer) (setq vc-dir-process-buffer (generate-new-buffer (format " *VC-%s* tmp status" backend)))) - (lexical-let ((buffer (current-buffer))) + (let ((buffer (current-buffer))) (with-current-buffer vc-dir-process-buffer (setq default-directory def-dir) (erase-buffer) @@ -1045,7 +1044,7 @@ specific headers." (not (vc-dir-fileinfo->needs-update info)))))))))))) -(defun vc-dir-revert-buffer-function (&optional ignore-auto noconfirm) +(defun vc-dir-revert-buffer-function (&optional _ignore-auto _noconfirm) (vc-dir-refresh)) (defun vc-dir-refresh () @@ -1079,7 +1078,7 @@ Throw an error if another update process is in progress." ;; Bzr has serious locking problems, so setup the headers first (this is ;; synchronous) rather than doing it while dir-status is running. (ewoc-set-hf vc-ewoc (vc-dir-headers backend def-dir) "") - (lexical-let ((buffer (current-buffer))) + (let ((buffer (current-buffer))) (with-current-buffer vc-dir-process-buffer (setq default-directory def-dir) (erase-buffer) @@ -1219,7 +1218,7 @@ These are the commands available for use in the file status buffer: (let ((use-vc-backend backend)) (vc-dir-mode)))) -(defun vc-default-dir-extra-headers (backend dir) +(defun vc-default-dir-extra-headers (_backend _dir) ;; Be loud by default to remind people to add code to display ;; backend specific headers. ;; XXX: change this to return nil before the release. @@ -1234,7 +1233,7 @@ These are the commands available for use in the file status buffer: map) "Local keymap for visiting a file.") -(defun vc-default-dir-printer (backend fileentry) +(defun vc-default-dir-printer (_backend fileentry) "Pretty print FILEENTRY." ;; If you change the layout here, change vc-dir-move-to-goal-column. ;; VC backends can implement backend specific versions of this @@ -1267,10 +1266,10 @@ These are the commands available for use in the file status buffer: 'mouse-face 'highlight 'keymap vc-dir-filename-mouse-map)))) -(defun vc-default-extra-status-menu (backend) +(defun vc-default-extra-status-menu (_backend) nil) -(defun vc-default-status-fileinfo-extra (backend file) +(defun vc-default-status-fileinfo-extra (_backend _file) "Default absence of extra information returned for a file." nil) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index b71dc95dba2..c185c4e8fab 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -1,4 +1,4 @@ -;;; vc-git.el --- VC backend for the git version control system +;;; vc-git.el --- VC backend for the git version control system -*- lexical-binding: t -*- ;; Copyright (C) 2006-2012 Free Software Foundation, Inc. @@ -160,7 +160,7 @@ matching the resulting Git log output, and KEYWORDS is a list of ;;; BACKEND PROPERTIES (defun vc-git-revision-granularity () 'repository) -(defun vc-git-checkout-model (files) 'implicit) +(defun vc-git-checkout-model (_files) 'implicit) ;;; STATE-QUERYING FUNCTIONS @@ -233,7 +233,7 @@ matching the resulting Git log output, and KEYWORDS is a list of (vc-git--state-code diff-letter))) (if (vc-git--empty-db-p) 'added 'up-to-date))))) -(defun vc-git-working-revision (file) +(defun vc-git-working-revision (_file) "Git-specific version of `vc-working-revision'." (let* (process-file-side-effects (str (with-output-to-string @@ -471,14 +471,14 @@ or an empty string if none." (vc-exec-after `(vc-git-after-dir-status-stage ',stage ',files ',update-function))) -(defun vc-git-dir-status (dir update-function) +(defun vc-git-dir-status (_dir update-function) "Return a list of (FILE STATE EXTRA) entries for DIR." ;; Further things that would have to be fixed later: ;; - how to handle unregistered directories ;; - how to support vc-dir on a subdir of the project tree (vc-git-dir-status-goto-stage 'update-index nil update-function)) -(defun vc-git-dir-status-files (dir files default-state update-function) +(defun vc-git-dir-status-files (_dir files _default-state update-function) "Return a list of (FILE STATE EXTRA) entries for FILES in DIR." (vc-git-dir-status-goto-stage 'update-index files update-function)) @@ -512,7 +512,7 @@ or an empty string if none." :help "Show the contents of the current stash")) map)) -(defun vc-git-dir-extra-headers (dir) +(defun vc-git-dir-extra-headers (_dir) (let ((str (with-output-to-string (with-current-buffer standard-output (vc-git--out-ok "symbolic-ref" "HEAD")))) @@ -590,7 +590,7 @@ The car of the list is the current branch." "Create a new Git repository." (vc-git-command nil 0 nil "init")) -(defun vc-git-register (files &optional rev comment) +(defun vc-git-register (files &optional _rev _comment) "Register FILES into the git version-control system." (let (flist dlist) (dolist (crt files) @@ -609,7 +609,7 @@ The car of the list is the current branch." (declare-function log-edit-extract-headers "log-edit" (headers string)) -(defun vc-git-checkin (files rev comment) +(defun vc-git-checkin (files _rev comment) (let ((coding-system-for-write vc-git-commits-coding-system)) (apply 'vc-git-command nil 0 files (nconc (list "commit" "-m") @@ -635,7 +635,7 @@ The car of the list is the current branch." nil "cat-file" "blob" (concat (if rev rev "HEAD") ":" fullname)))) -(defun vc-git-checkout (file &optional editable rev) +(defun vc-git-checkout (file &optional _editable rev) (vc-git-command nil 0 file "checkout" (or rev "HEAD"))) (defun vc-git-revert (file &optional contents-done) @@ -821,7 +821,7 @@ or BRANCH^ (where \"^\" can be repeated)." (append (vc-switches 'git 'diff) (list "-p" (or rev1 "HEAD") rev2 "--"))))) -(defun vc-git-revision-table (files) +(defun vc-git-revision-table (_files) ;; What about `files'?!? --Stef (let (process-file-side-effects (table (list "HEAD"))) @@ -834,10 +834,8 @@ or BRANCH^ (where \"^\" can be repeated)." table)) (defun vc-git-revision-completion-table (files) - (lexical-let ((files files) - table) - (setq table (lazy-completion-table - table (lambda () (vc-git-revision-table files)))) + (letrec ((table (lazy-completion-table + table (lambda () (vc-git-revision-table files))))) table)) (defun vc-git-annotate-command (file buf &optional rev) @@ -876,7 +874,7 @@ or BRANCH^ (where \"^\" can be repeated)." (vc-git-command nil 0 nil "checkout" "-b" name) (vc-git-command nil 0 nil "tag" name))))) -(defun vc-git-retrieve-tag (dir name update) +(defun vc-git-retrieve-tag (dir name _update) (let ((default-directory dir)) (vc-git-command nil 0 nil "checkout" name) ;; FIXME: update buffers if `update' is true diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index a2728268816..e3af8a353ef 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -1,4 +1,4 @@ -;;; vc-hg.el --- VC backend for the mercurial version control system +;;; vc-hg.el --- VC backend for the mercurial version control system -*- lexical-binding: t -*- ;; Copyright (C) 2006-2012 Free Software Foundation, Inc. @@ -168,7 +168,7 @@ highlighting the Log View buffer." (defvar vc-hg-history nil) (defun vc-hg-revision-granularity () 'repository) -(defun vc-hg-checkout-model (files) 'implicit) +(defun vc-hg-checkout-model (_files) 'implicit) ;;; State querying functions @@ -338,10 +338,8 @@ highlighting the Log View buffer." ;; Modeled after the similar function in vc-cvs.el (defun vc-hg-revision-completion-table (files) - (lexical-let ((files files) - table) - (setq table (lazy-completion-table - table (lambda () (vc-hg-revision-table files)))) + (letrec ((table (lazy-completion-table + table (lambda () (vc-hg-revision-table files))))) table)) (defun vc-hg-annotate-command (file buffer &optional revision) @@ -377,12 +375,12 @@ Optional arg REVISION is a revision to annotate from." (expand-file-name (match-string-no-properties 4) (vc-hg-root default-directory))))))) -(defun vc-hg-previous-revision (file rev) +(defun vc-hg-previous-revision (_file rev) (let ((newrev (1- (string-to-number rev)))) (when (>= newrev 0) (number-to-string newrev)))) -(defun vc-hg-next-revision (file rev) +(defun vc-hg-next-revision (_file rev) (let ((newrev (1+ (string-to-number rev))) (tip-revision (with-temp-buffer @@ -408,7 +406,7 @@ Optional arg REVISION is a revision to annotate from." "Rename file from OLD to NEW using `hg mv'." (vc-hg-command nil 0 new "mv" old)) -(defun vc-hg-register (files &optional rev comment) +(defun vc-hg-register (files &optional _rev _comment) "Register FILES under hg. REV is ignored. COMMENT is ignored." @@ -438,7 +436,7 @@ COMMENT is ignored." (declare-function log-edit-extract-headers "log-edit" (headers string)) -(defun vc-hg-checkin (files rev comment) +(defun vc-hg-checkin (files _rev comment) "Hg-specific version of `vc-backend-checkin'. REV is ignored." (apply 'vc-hg-command nil 0 files @@ -455,7 +453,7 @@ REV is ignored." (vc-hg-command buffer 0 file "cat")))) ;; Modeled after the similar function in vc-bzr.el -(defun vc-hg-checkout (file &optional editable rev) +(defun vc-hg-checkout (file &optional _editable rev) "Retrieve a revision of FILE. EDITABLE is ignored. REV is the revision to check out into WORKFILE." @@ -511,8 +509,7 @@ REV is the revision to check out into WORKFILE." 'face 'font-lock-comment-face))))) (defun vc-hg-after-dir-status (update-function) - (let ((status-char nil) - (file nil) + (let ((file nil) (translation '((?= . up-to-date) (?C . up-to-date) (?A . added) @@ -567,7 +564,7 @@ REV is the revision to check out into WORKFILE." (vc-exec-after `(vc-hg-after-dir-status (quote ,update-function)))) -(defun vc-hg-dir-status-files (dir files default-state update-function) +(defun vc-hg-dir-status-files (dir files _default-state update-function) (apply 'vc-hg-command (current-buffer) 'async dir "status" "-C" files) (vc-exec-after `(vc-hg-after-dir-status (quote ,update-function)))) diff --git a/lisp/vc/vc-mtn.el b/lisp/vc/vc-mtn.el index 122743c3747..bd3a6207b73 100644 --- a/lisp/vc/vc-mtn.el +++ b/lisp/vc/vc-mtn.el @@ -1,4 +1,4 @@ -;;; vc-mtn.el --- VC backend for Monotone +;;; vc-mtn.el --- VC backend for Monotone -*- lexical-binding: t -*- ;; Copyright (C) 2007-2012 Free Software Foundation, Inc. @@ -76,7 +76,7 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches." ;;;###autoload (vc-mtn-registered file)))) (defun vc-mtn-revision-granularity () 'repository) -(defun vc-mtn-checkout-model (files) 'implicit) +(defun vc-mtn-checkout-model (_files) 'implicit) (defun vc-mtn-root (file) (setq file (if (file-directory-p file) @@ -173,7 +173,7 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches." (t ?:)) branch))) -(defun vc-mtn-register (files &optional rev comment) +(defun vc-mtn-register (files &optional _rev _comment) (vc-mtn-command nil 0 files "add")) (defun vc-mtn-responsible-p (file) (vc-mtn-root file)) @@ -181,7 +181,7 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches." (declare-function log-edit-extract-headers "log-edit" (headers string)) -(defun vc-mtn-checkin (files rev comment) +(defun vc-mtn-checkin (files _rev comment) (apply 'vc-mtn-command nil 0 files (nconc (list "commit" "-m") (log-edit-extract-headers '(("Author" . "--author") @@ -201,7 +201,7 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches." ;; (defun vc-mtn-rollback (files) ;; ) -(defun vc-mtn-print-log (files buffer &optional shortlog start-revision limit) +(defun vc-mtn-print-log (files buffer &optional _shortlog start-revision limit) (apply 'vc-mtn-command buffer 0 files "log" (append (when start-revision (list "--from" (format "%s" start-revision))) @@ -304,44 +304,43 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches." (push (match-string 0) ids)) ids))) -(defun vc-mtn-revision-completion-table (files) +(defun vc-mtn-revision-completion-table (_files) ;; TODO: Implement completion for selectors ;; TODO: Implement completion for composite selectors. - (lexical-let ((files files)) - ;; What about using `files'?!? --Stef - (lambda (string pred action) - (cond - ;; "Tag" selectors. - ((string-match "\\`t:" string) - (complete-with-action action - (mapcar (lambda (tag) (concat "t:" tag)) - (vc-mtn-list-tags)) - string pred)) - ;; "Branch" selectors. - ((string-match "\\`b:" string) - (complete-with-action action - (mapcar (lambda (tag) (concat "b:" tag)) - (vc-mtn-list-branches)) - string pred)) - ;; "Head" selectors. Not sure how they differ from "branch" selectors. - ((string-match "\\`h:" string) - (complete-with-action action - (mapcar (lambda (tag) (concat "h:" tag)) - (vc-mtn-list-branches)) - string pred)) - ;; "ID" selectors. - ((string-match "\\`i:" string) - (complete-with-action action - (mapcar (lambda (tag) (concat "i:" tag)) - (vc-mtn-list-revision-ids - (substring string (match-end 0)))) - string pred)) - (t - (complete-with-action action - '("t:" "b:" "h:" "i:" - ;; Completion not implemented for these. - "a:" "c:" "d:" "e:" "l:") - string pred)))))) + ;; What about using `files'?!? --Stef + (lambda (string pred action) + (cond + ;; "Tag" selectors. + ((string-match "\\`t:" string) + (complete-with-action action + (mapcar (lambda (tag) (concat "t:" tag)) + (vc-mtn-list-tags)) + string pred)) + ;; "Branch" selectors. + ((string-match "\\`b:" string) + (complete-with-action action + (mapcar (lambda (tag) (concat "b:" tag)) + (vc-mtn-list-branches)) + string pred)) + ;; "Head" selectors. Not sure how they differ from "branch" selectors. + ((string-match "\\`h:" string) + (complete-with-action action + (mapcar (lambda (tag) (concat "h:" tag)) + (vc-mtn-list-branches)) + string pred)) + ;; "ID" selectors. + ((string-match "\\`i:" string) + (complete-with-action action + (mapcar (lambda (tag) (concat "i:" tag)) + (vc-mtn-list-revision-ids + (substring string (match-end 0)))) + string pred)) + (t + (complete-with-action action + '("t:" "b:" "h:" "i:" + ;; Completion not implemented for these. + "a:" "c:" "d:" "e:" "l:") + string pred))))) diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 433383502da..ad828d6f78f 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -1,4 +1,4 @@ -;;; vc.el --- drive a version-control system from within Emacs +;;; vc.el --- drive a version-control system from within Emacs -*- lexical-binding: t -*- ;; Copyright (C) 1992-1998, 2000-2012 Free Software Foundation, Inc. @@ -1075,7 +1075,7 @@ For old-style locking-based version control systems, like RCS: (let* ((vc-fileset (vc-deduce-fileset nil t 'state-model-only-files)) (backend (car vc-fileset)) (files (nth 1 vc-fileset)) - (fileset-only-files (nth 2 vc-fileset)) + ;; (fileset-only-files (nth 2 vc-fileset)) ;; FIXME: We used to call `vc-recompute-state' here. (state (nth 3 vc-fileset)) ;; The backend should check that the checkout-model is consistent @@ -1410,34 +1410,31 @@ that the version control system supports this mode of operation. Runs the normal hooks `vc-before-checkin-hook' and `vc-checkin-hook'." (when vc-before-checkin-hook (run-hooks 'vc-before-checkin-hook)) - (lexical-let - ((backend backend)) - (vc-start-logentry - files comment initial-contents - "Enter a change comment." - "*vc-log*" - (lambda () - (vc-call-backend backend 'log-edit-mode)) - (lexical-let ((rev rev)) - (lambda (files comment) - (message "Checking in %s..." (vc-delistify files)) - ;; "This log message intentionally left almost blank". - ;; RCS 5.7 gripes about white-space-only comments too. - (or (and comment (string-match "[^\t\n ]" comment)) - (setq comment "*** empty log message ***")) - (with-vc-properties - files - ;; We used to change buffers to get local value of - ;; vc-checkin-switches, but 'the' local buffer is - ;; not a well-defined concept for filesets. - (progn - (vc-call-backend backend 'checkin files rev comment) - (mapc 'vc-delete-automatic-version-backups files)) - `((vc-state . up-to-date) - (vc-checkout-time . ,(nth 5 (file-attributes file))) - (vc-working-revision . nil))) - (message "Checking in %s...done" (vc-delistify files)))) - 'vc-checkin-hook))) + (vc-start-logentry + files comment initial-contents + "Enter a change comment." + "*vc-log*" + (lambda () + (vc-call-backend backend 'log-edit-mode)) + (lambda (files comment) + (message "Checking in %s..." (vc-delistify files)) + ;; "This log message intentionally left almost blank". + ;; RCS 5.7 gripes about white-space-only comments too. + (or (and comment (string-match "[^\t\n ]" comment)) + (setq comment "*** empty log message ***")) + (with-vc-properties + files + ;; We used to change buffers to get local value of + ;; vc-checkin-switches, but 'the' local buffer is + ;; not a well-defined concept for filesets. + (progn + (vc-call-backend backend 'checkin files rev comment) + (mapc 'vc-delete-automatic-version-backups files)) + `((vc-state . up-to-date) + (vc-checkout-time . ,(nth 5 (file-attributes file))) + (vc-working-revision . nil))) + (message "Checking in %s...done" (vc-delistify files))) + 'vc-checkin-hook)) ;;; Additional entry points for examining version histories @@ -1671,7 +1668,7 @@ Return t if the buffer had changes, nil otherwise." (list files rev1 rev2)))) ;;;###autoload -(defun vc-version-diff (files rev1 rev2) +(defun vc-version-diff (_files rev1 rev2) "Report diffs between revisions of the fileset in the repository history." (interactive (vc-diff-build-argument-list-internal)) ;; All that was just so we could do argument completion! @@ -1883,11 +1880,9 @@ The headers are reset to their non-expanded form." "Enter a replacement change comment." "*vc-log*" (lambda () (vc-call-backend backend 'log-edit-mode)) - (lexical-let ((rev rev) - (backend backend)) - (lambda (files comment) - (vc-call-backend backend - 'modify-change-comment files rev comment)))))) + (lambda (files comment) + (vc-call-backend backend + 'modify-change-comment files rev comment))))) ;;;###autoload (defun vc-merge () @@ -1952,7 +1947,7 @@ changes from the current branch." (error "Sorry, merging is not implemented for %s" backend))))) -(defun vc-maybe-resolve-conflicts (file status &optional name-A name-B) +(defun vc-maybe-resolve-conflicts (file status &optional _name-A _name-B) (vc-resynch-buffer file t (not (buffer-modified-p))) (if (zerop status) (message "Merge successful") (smerge-mode 1) @@ -2077,22 +2072,20 @@ Not all VC backends support short logs!") (when (and limit (not (eq 'limit-unsupported pl-return)) (not is-start-revision)) (goto-char (point-max)) - (lexical-let ((working-revision working-revision) - (limit limit)) - (insert "\n") - (insert-text-button "Show 2X entries" - 'action (lambda (&rest ignore) - (vc-print-log-internal - log-view-vc-backend log-view-vc-fileset - working-revision nil (* 2 limit))) - 'help-echo "Show the log again, and double the number of log entries shown") - (insert " ") - (insert-text-button "Show unlimited entries" - 'action (lambda (&rest ignore) - (vc-print-log-internal - log-view-vc-backend log-view-vc-fileset - working-revision nil nil)) - 'help-echo "Show the log again, including all entries")))) + (insert "\n") + (insert-text-button "Show 2X entries" + 'action (lambda (&rest _ignore) + (vc-print-log-internal + log-view-vc-backend log-view-vc-fileset + working-revision nil (* 2 limit))) + 'help-echo "Show the log again, and double the number of log entries shown") + (insert " ") + (insert-text-button "Show unlimited entries" + 'action (lambda (&rest _ignore) + (vc-print-log-internal + log-view-vc-backend log-view-vc-fileset + working-revision nil nil)) + 'help-echo "Show the log again, including all entries"))) (defun vc-print-log-internal (backend files working-revision &optional is-start-revision limit) @@ -2102,8 +2095,7 @@ Not all VC backends support short logs!") (let ((dir-present nil) (vc-short-log nil) (buffer-name "*vc-change-log*") - type - pl-return) + type) (dolist (file files) (when (file-directory-p file) (setq dir-present t))) @@ -2112,25 +2104,20 @@ Not all VC backends support short logs!") (memq 'directory vc-log-short-style) (memq 'file vc-log-short-style))))) (setq type (if vc-short-log 'short 'long)) - (lexical-let - ((working-revision working-revision) - (backend backend) - (limit limit) - (shortlog vc-short-log) - (files files) - (is-start-revision is-start-revision)) + (let ((shortlog vc-short-log)) (vc-log-internal-common backend buffer-name files type - (lambda (bk buf type-arg files-arg) - (vc-call-backend bk 'print-log files-arg buf - shortlog (when is-start-revision working-revision) limit)) - (lambda (bk files-arg ret) + (lambda (bk buf _type-arg files-arg) + (vc-call-backend bk 'print-log files-arg buf shortlog + (when is-start-revision working-revision) limit)) + (lambda (_bk _files-arg ret) (vc-print-log-setup-buttons working-revision is-start-revision limit ret)) (lambda (bk) (vc-call-backend bk 'show-log-entry working-revision)) - (lambda (ignore-auto noconfirm) - (vc-print-log-internal backend files working-revision is-start-revision limit)))))) + (lambda (_ignore-auto _noconfirm) + (vc-print-log-internal backend files working-revision + is-start-revision limit)))))) (defvar vc-log-view-type nil "Set this to differentiate the different types of logs.") @@ -2168,20 +2155,12 @@ Not all VC backends support short logs!") (defun vc-incoming-outgoing-internal (backend remote-location buffer-name type) (vc-log-internal-common backend buffer-name nil type - (lexical-let - ((remote-location remote-location)) - (lambda (bk buf type-arg files) - (vc-call-backend bk type-arg buf remote-location))) - (lambda (bk files-arg ret)) - (lambda (bk) - (goto-char (point-min))) - (lexical-let - ((backend backend) - (remote-location remote-location) - (buffer-name buffer-name) - (type type)) - (lambda (ignore-auto noconfirm) - (vc-incoming-outgoing-internal backend remote-location buffer-name type))))) + (lambda (bk buf type-arg _files) + (vc-call-backend bk type-arg buf remote-location)) + (lambda (_bk _files-arg _ret) nil) + (lambda (_bk) (goto-char (point-min))) + (lambda (_ignore-auto _noconfirm) + (vc-incoming-outgoing-internal backend remote-location buffer-name type)))) ;;;###autoload (defun vc-print-log (&optional working-revision limit) @@ -2246,11 +2225,11 @@ When called interactively with a prefix argument, prompt for REMOTE-LOCATION.." (interactive (when current-prefix-arg (list (read-string "Remote location (empty for default): ")))) - (let ((backend (vc-deduce-backend)) - rootdir working-revision) + (let ((backend (vc-deduce-backend))) (unless backend (error "Buffer is not version controlled")) - (vc-incoming-outgoing-internal backend remote-location "*vc-incoming*" 'log-incoming))) + (vc-incoming-outgoing-internal backend remote-location "*vc-incoming*" + 'log-incoming))) ;;;###autoload (defun vc-log-outgoing (&optional remote-location) @@ -2259,11 +2238,11 @@ When called interactively with a prefix argument, prompt for REMOTE-LOCATION." (interactive (when current-prefix-arg (list (read-string "Remote location (empty for default): ")))) - (let ((backend (vc-deduce-backend)) - rootdir working-revision) + (let ((backend (vc-deduce-backend))) (unless backend (error "Buffer is not version controlled")) - (vc-incoming-outgoing-internal backend remote-location "*vc-outgoing*" 'log-outgoing))) + (vc-incoming-outgoing-internal backend remote-location "*vc-outgoing*" + 'log-outgoing))) ;;;###autoload (defun vc-revert () @@ -2688,23 +2667,23 @@ log entries should be gathered." (when index (substring rev 0 index)))) -(defun vc-default-responsible-p (backend file) +(defun vc-default-responsible-p (_backend _file) "Indicate whether BACKEND is responsible for FILE. The default is to return nil always." nil) -(defun vc-default-could-register (backend file) +(defun vc-default-could-register (_backend _file) "Return non-nil if BACKEND could be used to register FILE. The default implementation returns t for all files." t) -(defun vc-default-latest-on-branch-p (backend file) +(defun vc-default-latest-on-branch-p (_backend _file) "Return non-nil if FILE is the latest on its branch. This default implementation always returns non-nil, which means that editing non-current revisions is not supported by default." t) -(defun vc-default-init-revision (backend) vc-default-init-revision) +(defun vc-default-init-revision (_backend) vc-default-init-revision) (defun vc-default-find-revision (backend file rev buffer) "Provide the new `find-revision' op based on the old `checkout' op. @@ -2718,7 +2697,7 @@ to provide the `find-revision' operation instead." (insert-file-contents-literally tmpfile))) (delete-file tmpfile)))) -(defun vc-default-rename-file (backend old new) +(defun vc-default-rename-file (_backend old new) (condition-case nil (add-name-to-file old new) (error (rename-file old new))) @@ -2730,11 +2709,11 @@ to provide the `find-revision' operation instead." (declare-function log-edit-mode "log-edit" ()) -(defun vc-default-log-edit-mode (backend) (log-edit-mode)) +(defun vc-default-log-edit-mode (_backend) (log-edit-mode)) -(defun vc-default-log-view-mode (backend) (log-view-mode)) +(defun vc-default-log-view-mode (_backend) (log-view-mode)) -(defun vc-default-show-log-entry (backend rev) +(defun vc-default-show-log-entry (_backend rev) (with-no-warnings (log-view-goto-rev rev))) @@ -2800,7 +2779,7 @@ to provide the `find-revision' operation instead." (defalias 'vc-default-revision-completion-table 'ignore) (defalias 'vc-default-mark-resolved 'ignore) -(defun vc-default-dir-status-files (backend dir files default-state update-function) +(defun vc-default-dir-status-files (_backend _dir files default-state update-function) (funcall update-function (mapcar (lambda (file) (list file default-state)) files))) -- cgit v1.2.3 From e5f9458fe818fd87ec99354420c3633ca928d62c Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Mon, 7 May 2012 00:45:46 +0800 Subject: * lisp/buff-menu.el: Convert to Tabulated List mode. (Buffer-menu-buffer+size-width): Make obsolete. (Buffer-menu-name-width, Buffer-menu-size-width): New variables. (Buffer-menu-mode-map): Inherit from tabulated-list-mode-map. (Buffer-menu-mode): Derive from tabulated-list-mode. Move command documentation into docstring of buffer-menu. (Buffer-menu-toggle-files-only): Add an informative message. (Buffer-menu-sort): Convert to alias for tabulated-list-sort. (Buffer-menu-buffer, Buffer-menu-beginning, Buffer-menu-mark) (Buffer-menu-unmark, Buffer-menu-backup-unmark) (Buffer-menu-delete, Buffer-menu-save, Buffer-menu-not-modified) (Buffer-menu-execute, Buffer-menu-select) (Buffer-menu-marked-buffers, Buffer-menu-toggle-read-only) (Buffer-menu-bury): Use Tabulated List machinery. (Buffer-menu-mouse-select, Buffer-menu-sort-by-column) (Buffer-menu-sort-button-map, Buffer-menu-make-sort-button): Deleted. (list-buffers--refresh): New function. (list-buffers-noselect): Use it. (tabulated-list-entry-size->, Buffer-menu--pretty-name) (Buffer-menu--pretty-file-name): New helper functions. * lisp/loadup.el: Preload tabulated-list. * lisp/emacs-lisp/tabulated-list.el (tabulated-list-sort): Rename from tabulated-list-sort-column. (tabulated-list-init-header): Add the initial aligning space even if tabulated-list-padding is zero. * src/lisp.mk (lisp): Update. --- etc/NEWS | 2 +- lisp/ChangeLog | 31 ++ lisp/buff-menu.el | 966 +++++++++++++------------------------- lisp/emacs-lisp/cl-loaddefs.el | 2 +- lisp/emacs-lisp/tabulated-list.el | 11 +- lisp/loadup.el | 1 + src/ChangeLog | 4 + src/lisp.mk | 1 + 8 files changed, 373 insertions(+), 645 deletions(-) (limited to 'lisp/emacs-lisp/cl-loaddefs.el') diff --git a/etc/NEWS b/etc/NEWS index df386fa7e4f..6b59601fd81 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -163,7 +163,7 @@ server properties. ** Tabulated List and packages derived from it -*** New command `tabulated-list-sort-column' bound to `S' sorts column +*** New command `tabulated-list-sort', bound to `S', sorts the column at point, or the Nth column if a numeric prefix argument is given. ** Obsolete packages: diff --git a/lisp/ChangeLog b/lisp/ChangeLog index afa4ae803f9..149c43fc9a7 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,34 @@ +2012-05-06 Chong Yidong + + * buff-menu.el: Convert to Tabulated List mode. + (Buffer-menu-buffer+size-width): Make obsolete. + (Buffer-menu-name-width, Buffer-menu-size-width): New variables. + (Buffer-menu-mode-map): Inherit from tabulated-list-mode-map. + (Buffer-menu-mode): Derive from tabulated-list-mode. Move command + documentation into docstring of buffer-menu. + (Buffer-menu-toggle-files-only): Add an informative message. + (Buffer-menu-sort): Convert to alias for tabulated-list-sort. + (Buffer-menu-buffer, Buffer-menu-beginning, Buffer-menu-mark) + (Buffer-menu-unmark, Buffer-menu-backup-unmark) + (Buffer-menu-delete, Buffer-menu-save, Buffer-menu-not-modified) + (Buffer-menu-execute, Buffer-menu-select) + (Buffer-menu-marked-buffers, Buffer-menu-toggle-read-only) + (Buffer-menu-bury): Use Tabulated List machinery. + (Buffer-menu-mouse-select, Buffer-menu-sort-by-column) + (Buffer-menu-sort-button-map, Buffer-menu-make-sort-button): + Deleted. + (list-buffers--refresh): New function. + (list-buffers-noselect): Use it. + (tabulated-list-entry-size->, Buffer-menu--pretty-name) + (Buffer-menu--pretty-file-name): New helper functions. + + * loadup.el: Preload tabulated-list. + + * emacs-lisp/tabulated-list.el (tabulated-list-sort): Rename from + tabulated-list-sort-column. + (tabulated-list-init-header): Add the initial aligning space even + if tabulated-list-padding is zero. + 2012-05-06 Christopher Schmidt * emacs-lisp/cl-macs.el (cl-expr-contains): Handle cons cells diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el index 105ee50958e..e28c2c0f60b 100644 --- a/lisp/buff-menu.el +++ b/lisp/buff-menu.el @@ -1,4 +1,4 @@ -;;; buff-menu.el --- buffer menu main function and support functions -*- coding:utf-8 -*- +;;; buff-menu.el --- Interface for viewing and manipulating buffers ;; Copyright (C) 1985-1987, 1993-1995, 2000-2012 ;; Free Software Foundation, Inc. @@ -24,44 +24,13 @@ ;;; Commentary: -;; Edit, delete, or change attributes of all currently active Emacs -;; buffers from a list summarizing their state. A good way to browse -;; any special or scratch buffers you have loaded, since you can't find -;; them by filename. The single entry point is `list-buffers', -;; normally bound to C-x C-b. - -;;; Change Log: - -;; Buffer-menu-view: New function -;; Buffer-menu-view-other-window: New function - -;; Merged by esr with recent mods to Emacs 19 buff-menu, 23 Mar 1993 -;; -;; Modified by Bob Weiner, Motorola, Inc., 4/14/89 -;; -;; Added optional backup argument to 'Buffer-menu-unmark' to make it undelete -;; current entry and then move to previous one. -;; -;; Based on FSF code dating back to 1985. +;; The Buffer Menu is used to view, edit, delete, or change attributes +;; of buffers. The entry points are C-x C-b (`list-buffers') and +;; M-x buffer-menu. ;;; Code: -;;Trying to preserve the old window configuration works well in -;;simple scenarios, when you enter the buffer menu, use it, and exit it. -;;But it does strange things when you switch back to the buffer list buffer -;;with C-x b, later on, when the window configuration is different. -;;The choice seems to be, either restore the window configuration -;;in all cases, or in no cases. -;;I decided it was better not to restore the window config at all. -- rms. - -;;But since then, I changed buffer-menu to use the selected window, -;;so q now once again goes back to the previous window configuration. - -;;(defvar Buffer-menu-window-config nil -;; "Window configuration saved from entry to `buffer-menu'.") - -;; Put buffer *Buffer List* into proper mode right away -;; so that from now on even list-buffers is enough to get a buffer menu. +(require 'tabulated-list) (defgroup Buffer-menu nil "Show a menu of all buffers in a buffer." @@ -69,23 +38,41 @@ :group 'convenience) (defcustom Buffer-menu-use-header-line t - "Non-nil means to use an immovable header-line." + "If non-nil, use the header line to display Buffer Menu column titles." :type 'boolean :group 'Buffer-menu) (defface buffer-menu-buffer '((t (:weight bold))) - "Face used to highlight buffer names in the buffer menu." + "Face for buffer names in the Buffer Menu." :group 'Buffer-menu) (put 'Buffer-menu-buffer 'face-alias 'buffer-menu-buffer) -(defcustom Buffer-menu-buffer+size-width 26 - "How wide to jointly make the buffer name and size columns." +(defcustom Buffer-menu-buffer+size-width nil + "Combined width of buffer name and size columns in Buffer Menu. +If nil, use `Buffer-menu-name-width' and `Buffer-menu-size-width'." :type 'number - :group 'Buffer-menu) + :group 'Buffer-menu + :version "24.2") + +(make-obsolete-variable 'Buffer-menu-buffer+size-width + "`Buffer-menu-name-width' and `Buffer-menu-size-width'" + "24.2") + +(defcustom Buffer-menu-name-width 19 + "Width of buffer size column in the Buffer Menu." + :type 'number + :group 'Buffer-menu + :version "24.2") + +(defcustom Buffer-menu-size-width 7 + "Width of buffer name column in the Buffer Menu." + :type 'number + :group 'Buffer-menu + :version "24.2") (defcustom Buffer-menu-mode-width 16 - "How wide to make the mode name column." + "Width of mode name column in the Buffer Menu." :type 'number :group 'Buffer-menu) @@ -99,35 +86,19 @@ as it is by default." :group 'Buffer-menu :version "22.1") -;; This should get updated & resorted when you click on a column heading -(defvar Buffer-menu-sort-column nil - "Which column to sort the menu on. -Use 2 to sort by buffer names, or 5 to sort by file names. -A nil value means sort by visited order (the default).") - -(defconst Buffer-menu-buffer-column 4) - (defvar Buffer-menu-files-only nil - "Non-nil if the current buffer-menu lists only file buffers. -This variable determines whether reverting the buffer lists only -file buffers. It affects both manual reverting and reverting by -Auto Revert Mode.") + "Non-nil if the current Buffer Menu lists only file buffers. +This is set by the prefix argument to `buffer-menu' and related +commands.") (make-variable-buffer-local 'Buffer-menu-files-only) -(defvar Buffer-menu--buffers nil - "If non-nil, list of buffers shown in the current buffer-menu. -This variable determines whether reverting the buffer lists only -these buffers. It affects both manual reverting and reverting by -Auto Revert Mode.") -(make-variable-buffer-local 'Buffer-menu--buffers) - -(defvar Info-current-file) ;; from info.el -(defvar Info-current-node) ;; from info.el +(defvar Info-current-file) ; from info.el +(defvar Info-current-node) ; from info.el (defvar Buffer-menu-mode-map - (let ((map (make-keymap)) + (let ((map (make-sparse-keymap)) (menu-map (make-sparse-keymap))) - (suppress-keymap map t) + (set-keymap-parent map tabulated-list-mode-map) (define-key map "v" 'Buffer-menu-select) (define-key map "2" 'Buffer-menu-2-window) (define-key map "1" 'Buffer-menu-1-window) @@ -139,12 +110,10 @@ Auto Revert Mode.") (define-key map "s" 'Buffer-menu-save) (define-key map "d" 'Buffer-menu-delete) (define-key map "k" 'Buffer-menu-delete) - (define-key map "\C-d" 'Buffer-menu-delete-backwards) (define-key map "\C-k" 'Buffer-menu-delete) + (define-key map "\C-d" 'Buffer-menu-delete-backwards) (define-key map "x" 'Buffer-menu-execute) (define-key map " " 'next-line) - (define-key map "n" 'next-line) - (define-key map "p" 'previous-line) (define-key map "\177" 'Buffer-menu-backup-unmark) (define-key map "~" 'Buffer-menu-not-modified) (define-key map "u" 'Buffer-menu-unmark) @@ -154,10 +123,9 @@ Auto Revert Mode.") (define-key map "b" 'Buffer-menu-bury) (define-key map "V" 'Buffer-menu-view) (define-key map "T" 'Buffer-menu-toggle-files-only) - (define-key map [mouse-2] 'Buffer-menu-mouse-select) - (define-key map [follow-link] 'mouse-face) (define-key map (kbd "M-s a C-s") 'Buffer-menu-isearch-buffers) (define-key map (kbd "M-s a M-C-s") 'Buffer-menu-isearch-buffers-regexp) + (define-key map [menu-bar Buffer-menu-mode] (cons (purecopy "Buffer-Menu") menu-map)) (define-key menu-map [quit] `(menu-item ,(purecopy "Quit") quit-window @@ -224,143 +192,123 @@ Auto Revert Mode.") map) "Local keymap for `Buffer-menu-mode' buffers.") -;; Buffer Menu mode is suitable only for specially formatted data. -(put 'Buffer-menu-mode 'mode-class 'special) - -(define-derived-mode Buffer-menu-mode special-mode "Buffer Menu" - "Major mode for editing a list of buffers. -Each line describes one of the buffers in Emacs. -Letters do not insert themselves; instead, they are commands. -\\ -\\[Buffer-menu-mouse-select] -- select buffer you click on, in place of the buffer menu. -\\[Buffer-menu-this-window] -- select current line's buffer in place of the buffer menu. -\\[Buffer-menu-other-window] -- select that buffer in another window, - so the buffer menu buffer remains visible in its window. -\\[Buffer-menu-view] -- select current line's buffer, but in view-mode. -\\[Buffer-menu-view-other-window] -- select that buffer in - another window, in view-mode. -\\[Buffer-menu-switch-other-window] -- make another window display that buffer. -\\[Buffer-menu-mark] -- mark current line's buffer to be displayed. -\\[Buffer-menu-select] -- select current line's buffer. - Also show buffers marked with m, in other windows. -\\[Buffer-menu-1-window] -- select that buffer in full-frame window. -\\[Buffer-menu-2-window] -- select that buffer in one window, - together with buffer selected before this one in another window. -\\[Buffer-menu-isearch-buffers] -- Do incremental search in the marked buffers. -\\[Buffer-menu-isearch-buffers-regexp] -- Isearch for regexp in the marked buffers. -\\[Buffer-menu-visit-tags-table] -- visit-tags-table this buffer. -\\[Buffer-menu-not-modified] -- clear modified-flag on that buffer. -\\[Buffer-menu-save] -- mark that buffer to be saved, and move down. -\\[Buffer-menu-delete] -- mark that buffer to be deleted, and move down. -\\[Buffer-menu-delete-backwards] -- mark that buffer to be deleted, and move up. -\\[Buffer-menu-execute] -- delete or save marked buffers. -\\[Buffer-menu-unmark] -- remove all kinds of marks from current line. - With prefix argument, also move up one line. -\\[Buffer-menu-backup-unmark] -- back up a line and remove marks. -\\[Buffer-menu-toggle-read-only] -- toggle read-only status of buffer on this line. -\\[revert-buffer] -- update the list of buffers. -\\[Buffer-menu-toggle-files-only] -- toggle whether the menu displays only file buffers. -\\[Buffer-menu-bury] -- bury the buffer listed on this line." - (set (make-local-variable 'revert-buffer-function) - 'Buffer-menu-revert-function) +(define-derived-mode Buffer-menu-mode tabulated-list-mode "Buffer Menu" + "Major mode for Buffer Menu buffers. +The Buffer Menu is invoked by the commands \\[list-buffers], \\[buffer-menu], and +\\[buffer-menu-other-window]. See `buffer-menu' for details." (set (make-local-variable 'buffer-stale-function) (lambda (&optional _noconfirm) 'fast)) - (setq truncate-lines t) - (setq buffer-read-only t) - ;; Force L2R direction, to avoid messing the display if the first - ;; buffer in the list happens to begin with a strong R2L character. - (setq bidi-paragraph-direction 'left-to-right)) + (add-hook 'tabulated-list-revert-hook 'list-buffers--refresh nil t)) (define-obsolete-variable-alias 'buffer-menu-mode-hook 'Buffer-menu-mode-hook "23.1") -(defun Buffer-menu-revert-function (_ignore1 _ignore2) - (or (eq buffer-undo-list t) - (setq buffer-undo-list nil)) - ;; We can not use save-excursion here. The buffer gets erased. - (let ((opoint (point)) - (eobp (eobp)) - (ocol (current-column)) - (oline (progn (move-to-column Buffer-menu-buffer-column) - (get-text-property (point) 'buffer))) - (prop (point-min)) - ;; do not make undo records for the reversion. - (buffer-undo-list t)) - ;; We can be called by Auto Revert Mode with the "*Buffer Menu*" - ;; temporarily the current buffer. Make sure that the - ;; interactively current buffer is correctly identified with a `.' - ;; by `list-buffers-noselect'. - (with-current-buffer (window-buffer) - (list-buffers-noselect Buffer-menu-files-only Buffer-menu--buffers)) - (if oline - (while (setq prop (next-single-property-change prop 'buffer)) - (when (eq (get-text-property prop 'buffer) oline) - (goto-char prop) - (move-to-column ocol))) - (goto-char (if eobp (point-max) opoint))))) +(defun buffer-menu (&optional arg) + "Switch to the Buffer Menu. +By default, all buffers are listed except those whose names start +with a space (which are for internal use). With prefix argument +ARG, show only buffers that are visiting files. -(defun Buffer-menu-toggle-files-only (arg) - "Toggle whether the current buffer-menu displays only file buffers. -With a positive ARG display only file buffers. With zero or -negative ARG, display other buffers as well." - (interactive "P") - (setq Buffer-menu-files-only - (cond ((not arg) (not Buffer-menu-files-only)) - ((> (prefix-numeric-value arg) 0) t))) - (revert-buffer)) +The first column (denoted \"C\") shows \".\" for the buffer from +which you came. It shows \">\" for buffers you mark to be +displayed, and \"D\" for those you mark for deletion. - -(defun Buffer-menu-buffer (error-if-non-existent-p) - "Return buffer described by this line of buffer menu." - (let* ((where (+ (line-beginning-position) Buffer-menu-buffer-column)) - (name (and (not (eobp)) (get-text-property where 'buffer-name))) - (buf (and (not (eobp)) (get-text-property where 'buffer)))) - (if name - (or (get-buffer name) - (and buf (buffer-name buf) buf) - (if error-if-non-existent-p - (error "No buffer named `%s'" name) - nil)) - (or (and buf (buffer-name buf) buf) - (if error-if-non-existent-p - (error "No buffer on this line") - nil))))) - -(defun buffer-menu (&optional arg) - "Make a menu of buffers so you can save, delete or select them. -With argument, show only buffers that are visiting files. -Type ? after invocation to get help on commands available. -Type q to remove the buffer menu from the display. - -The first column shows `>' for a buffer you have -marked to be displayed, `D' for one you have marked for -deletion, and `.' for the current buffer. - -The C column has a `.' for the buffer from which you came. -The R column has a `%' if the buffer is read-only. -The M column has a `*' if it is modified, -or `S' if you have marked it for saving. -After this come the buffer name, its size in characters, -its major mode, and the visited file name (if any)." +The \"R\" column has a \"%\" if the buffer is read-only. +The \"M\" column has a \"*\" if it is modified, or \"S\" if you +have marked it for saving. + +After this come the buffer name, its size in characters, its +major mode, and the visited file name (if any). + + +In the Buffer Menu, the following commands are defined: +\\ +\\[quit-window] Remove the Buffer Menu from the display. +\\[Buffer-menu-this-window] Select current line's buffer in place of the buffer menu. +\\[Buffer-menu-other-window] Select that buffer in another window, + so the Buffer Menu remains visible in its window. +\\[Buffer-menu-view] Select current line's buffer, in View mode. +\\[Buffer-menu-view-other-window] Select that buffer in + another window, in view-mode. +\\[Buffer-menu-switch-other-window] Make another window display that buffer. +\\[Buffer-menu-mark] Mark current line's buffer to be displayed. +\\[Buffer-menu-select] Select current line's buffer. + Also show buffers marked with m, in other windows. +\\[Buffer-menu-1-window] Select that buffer in full-frame window. +\\[Buffer-menu-2-window] Select that buffer in one window, together with the + buffer selected before this one in another window. +\\[Buffer-menu-isearch-buffers] Incremental search in the marked buffers. +\\[Buffer-menu-isearch-buffers-regexp] Isearch for regexp in the marked buffers. +\\[Buffer-menu-visit-tags-table] visit-tags-table this buffer. +\\[Buffer-menu-not-modified] Clear modified-flag on that buffer. +\\[Buffer-menu-save] Mark that buffer to be saved, and move down. +\\[Buffer-menu-delete] Mark that buffer to be deleted, and move down. +\\[Buffer-menu-delete-backwards] Mark that buffer to be deleted, and move up. +\\[Buffer-menu-execute] Delete or save marked buffers. +\\[Buffer-menu-unmark] Remove all marks from current line. + With prefix argument, also move up one line. +\\[Buffer-menu-backup-unmark] Back up a line and remove marks. +\\[Buffer-menu-toggle-read-only] Toggle read-only status of buffer on this line. +\\[revert-buffer] Update the list of buffers. +\\[Buffer-menu-toggle-files-only] Toggle whether the menu displays only file buffers. +\\[Buffer-menu-bury] Bury the buffer listed on this line." (interactive "P") -;;; (setq Buffer-menu-window-config (current-window-configuration)) (switch-to-buffer (list-buffers-noselect arg)) (message "Commands: d, s, x, u; f, o, 1, 2, m, v; ~, %%; q to quit; ? for help.")) (defun buffer-menu-other-window (&optional arg) - "Display a list of buffers in another window. -With the buffer list buffer, you can save, delete or select the buffers. -With argument, show only buffers that are visiting files. -Type ? after invocation to get help on commands available. -Type q to remove the buffer menu from the display. -For more information, see the function `buffer-menu'." + "Display the Buffer Menu in another window. +See `buffer-menu' for a description of the Buffer Menu. + +By default, all buffers are listed except those whose names start +with a space (which are for internal use). With prefix argument +ARG, show only buffers that are visiting files." (interactive "P") -;;; (setq Buffer-menu-window-config (current-window-configuration)) (switch-to-buffer-other-window (list-buffers-noselect arg)) (message "Commands: d, s, x, u; f, o, 1, 2, m, v; ~, %%; q to quit; ? for help.")) +(defun list-buffers (&optional arg) + "Display a list of existing buffers. +The list is displayed in a buffer named \"*Buffer List*\". +See `buffer-menu' for details about the Buffer Menu buffer. + +By default, all buffers are listed except those whose names start +with a space (which are for internal use). With prefix argument +ARG, show only buffers that are visiting files." + (interactive "P") + (display-buffer (list-buffers-noselect arg))) + +(defun Buffer-menu-toggle-files-only (arg) + "Toggle whether the current buffer-menu displays only file buffers. +With a positive ARG, display only file buffers. With zero or +negative ARG, display other buffers as well." + (interactive "P") + (setq Buffer-menu-files-only + (cond ((not arg) (not Buffer-menu-files-only)) + ((> (prefix-numeric-value arg) 0) t))) + (message (if Buffer-menu-files-only + "Showing only file-visiting buffers." + "Showing all non-internal buffers.")) + (revert-buffer)) + +(defalias 'Buffer-menu-sort 'tabulated-list-sort) + + +(defun Buffer-menu-buffer (&optional error-if-non-existent-p) + "Return the buffer described by the current Buffer Menu line. +If there is no buffer here, return nil if ERROR-IF-NON-EXISTENT-P +is nil or omitted, and signal an error otherwise." + (let ((buffer (tabulated-list-get-id))) + (cond ((null buffer) + (if error-if-non-existent-p + (error "No buffer on this line"))) + ((not (buffer-live-p buffer)) + (if error-if-non-existent-p + (error "This buffer has been killed"))) + (t buffer)))) + (defun Buffer-menu-no-header () (beginning-of-line) (if (or Buffer-menu-use-header-line @@ -370,166 +318,140 @@ For more information, see the function `buffer-menu'." (forward-line 1) nil)) +(defun Buffer-menu-beginning () + (goto-char (point-min)) + (unless Buffer-menu-use-header-line + (forward-line))) + + +;;; Commands for modifying Buffer Menu entries. + (defun Buffer-menu-mark () - "Mark buffer on this line for being displayed by \\\\[Buffer-menu-select] command." + "Mark the Buffer menu entry at point for later display. +It will be displayed by the \\\\[Buffer-menu-select] command." (interactive) - (when (Buffer-menu-no-header) - (let ((inhibit-read-only t)) - (delete-char 1) - (insert ?>) - (forward-line 1)))) + (tabulated-list-set-col 0 ">" t) + (forward-line)) (defun Buffer-menu-unmark (&optional backup) "Cancel all requested operations on buffer on this line and move down. Optional prefix arg means move up." (interactive "P") - (when (Buffer-menu-no-header) - (let* ((buf (Buffer-menu-buffer t)) - (mod (buffer-modified-p buf)) - (readonly (with-current-buffer buf buffer-read-only)) - (inhibit-read-only t)) - (delete-char 3) - (insert (if readonly (if mod " %*" " % ") (if mod " *" " "))))) + (tabulated-list-set-col 0 " " t) (forward-line (if backup -1 1))) (defun Buffer-menu-backup-unmark () "Move up and cancel all requested operations on buffer on line above." (interactive) (forward-line -1) - (Buffer-menu-unmark) - (forward-line -1)) + (tabulated-list-set-col 0 " " t)) (defun Buffer-menu-delete (&optional arg) - "Mark buffer on this line to be deleted by \\\\[Buffer-menu-execute] command. -Prefix arg is how many buffers to delete. -Negative arg means delete backwards." + "Mark the buffer on this Buffer Menu buffer line for deletion. +A subsequent \\`\\[Buffer-menu-execute]' command +will delete it. + +If prefix argument ARG is non-nil, it specifies the number of +buffers to delete; a negative ARG means to delete backwards." (interactive "p") - (when (Buffer-menu-no-header) - (let ((inhibit-read-only t)) - (if (or (null arg) (= arg 0)) - (setq arg 1)) - (while (> arg 0) - (delete-char 1) - (insert ?D) - (forward-line 1) - (setq arg (1- arg))) - (while (and (< arg 0) - (Buffer-menu-no-header)) - (delete-char 1) - (insert ?D) - (forward-line -1) - (setq arg (1+ arg)))))) + (if (or (null arg) (= arg 0)) + (setq arg 1)) + (while (> arg 0) + (when (Buffer-menu-buffer) + (tabulated-list-set-col 0 "D" t)) + (forward-line 1) + (setq arg (1- arg))) + (while (< arg 0) + (when (Buffer-menu-buffer) + (tabulated-list-set-col 0 "D" t)) + (forward-line -1) + (setq arg (1+ arg)))) (defun Buffer-menu-delete-backwards (&optional arg) - "Mark buffer on this line to be deleted by \\\\[Buffer-menu-execute] command -and then move up one line. Prefix arg means move that many lines." + "Mark the buffer on this Buffer Menu line for deletion, and move up. +Prefix ARG means move that many lines." (interactive "p") (Buffer-menu-delete (- (or arg 1)))) (defun Buffer-menu-save () - "Mark buffer on this line to be saved by \\\\[Buffer-menu-execute] command." + "Mark the buffer on this Buffer Menu line for saving. +A subsequent \\`\\[Buffer-menu-execute]' command +will save it." (interactive) - (when (Buffer-menu-no-header) - (let ((inhibit-read-only t)) - (forward-char 2) - (delete-char 1) - (insert ?S) - (forward-line 1)))) + (when (Buffer-menu-buffer) + (tabulated-list-set-col 2 "S" t) + (forward-line 1))) (defun Buffer-menu-not-modified (&optional arg) - "Mark buffer on this line as unmodified (no changes to save)." + "Mark the buffer on this line as unmodified (no changes to save). +If ARG is non-nil (interactively, with a prefix argument), mark +it as modified." (interactive "P") (with-current-buffer (Buffer-menu-buffer t) (set-buffer-modified-p arg)) - (save-excursion - (beginning-of-line) - (forward-char 2) - (if (= (char-after) (if arg ?\s ?*)) - (let ((inhibit-read-only t)) - (delete-char 1) - (insert (if arg ?* ?\s)))))) - -(defun Buffer-menu-beginning () - (goto-char (point-min)) - (unless Buffer-menu-use-header-line - (forward-line))) + (tabulated-list-set-col 2 (if arg "*" " ") t)) (defun Buffer-menu-execute () - "Save and/or delete buffers marked with \\\\[Buffer-menu-save] or \\\\[Buffer-menu-delete] commands." + "Save and/or delete marked buffers in the Buffer Menu. +Buffers marked with \\`\\[Buffer-menu-save]' are saved. +Buffers marked with \\`\\[Buffer-menu-delete]' are deleted." (interactive) (save-excursion (Buffer-menu-beginning) - (while (re-search-forward "^..S" nil t) - (let ((modp nil)) - (with-current-buffer (Buffer-menu-buffer t) - (save-buffer) - (setq modp (buffer-modified-p))) - (let ((inhibit-read-only t)) - (delete-char -1) - (insert (if modp ?* ?\s)))))) - (save-excursion - (Buffer-menu-beginning) - (let ((buff-menu-buffer (current-buffer)) - (inhibit-read-only t)) - (while (re-search-forward "^D" nil t) - (forward-char -1) - (let ((buf (Buffer-menu-buffer nil))) - (or (eq buf nil) - (eq buf buff-menu-buffer) - (save-excursion (kill-buffer buf))) - (if (and buf (buffer-name buf)) - (progn (delete-char 1) - (insert ?\s)) - (delete-region (point) (progn (forward-line 1) (point))) - (unless (bobp) - (forward-char -1)))))))) + (while (not (eobp)) + (let ((buffer (tabulated-list-get-id)) + (entry (tabulated-list-get-entry))) + (cond ((null entry) + (forward-line 1)) + ((not (buffer-live-p buffer)) + (tabulated-list-delete-entry)) + (t + (let ((delete (eq (char-after) ?D))) + (when (equal (aref entry 2) "S") + (condition-case nil + (progn + (with-current-buffer buffer + (save-buffer)) + (tabulated-list-set-col 2 " " t)) + (error (warn "Error saving %s" buffer)))) + (if delete + (unless (eq buffer (current-buffer)) + (kill-buffer buffer) + (tabulated-list-delete-entry)) + (forward-line 1))))))))) (defun Buffer-menu-select () - "Select this line's buffer; also display buffers marked with `>'. -You can mark buffers with the \\\\[Buffer-menu-mark] command. + "Select this line's buffer; also, display buffers marked with `>'. +You can mark buffers with the \\`\\[Buffer-menu-mark]' command. This command deletes and replaces all the previously existing windows in the selected frame." (interactive) - (let ((buff (Buffer-menu-buffer t)) - (menu (current-buffer)) - (others ()) - tem) - (Buffer-menu-beginning) - (while (re-search-forward "^>" nil t) - (setq tem (Buffer-menu-buffer t)) - (let ((inhibit-read-only t)) - (delete-char -1) - (insert ?\s)) - (or (eq tem buff) (memq tem others) (setq others (cons tem others)))) - (setq others (nreverse others) - tem (/ (1- (frame-height)) (1+ (length others)))) + (let* ((this-buffer (Buffer-menu-buffer t)) + (menu-buffer (current-buffer)) + (others (delq this-buffer (Buffer-menu-marked-buffers t))) + (height (/ (1- (frame-height)) (1+ (length others))))) (delete-other-windows) - (switch-to-buffer buff) - (or (eq menu buff) - (bury-buffer menu)) - (if (equal (length others) 0) - (progn -;;; ;; Restore previous window configuration before displaying -;;; ;; selected buffers. -;;; (if Buffer-menu-window-config -;;; (progn -;;; (set-window-configuration Buffer-menu-window-config) -;;; (setq Buffer-menu-window-config nil))) - (switch-to-buffer buff)) - (while others - (split-window nil tem) - (other-window 1) - (switch-to-buffer (car others)) - (setq others (cdr others))) - (other-window 1) ;back to the beginning! -))) - -(defun Buffer-menu-marked-buffers () - "Return a list of buffers marked with the \\\\[Buffer-menu-mark] command." + (switch-to-buffer this-buffer) + (unless (eq menu-buffer this-buffer) + (bury-buffer menu-buffer)) + (dolist (buffer others) + (split-window nil height) + (other-window 1) + (switch-to-buffer buffer)) + ;; Back to the beginning! + (other-window 1))) + +(defun Buffer-menu-marked-buffers (&optional unmark) + "Return the list of buffers marked with `Buffer-menu-mark'. +If UNMARK is non-nil, unmark them." (let (buffers) (Buffer-menu-beginning) (while (re-search-forward "^>" nil t) - (setq buffers (cons (Buffer-menu-buffer t) buffers))) + (let ((buffer (Buffer-menu-buffer))) + (if (and buffer unmark) + (tabulated-list-set-col 0 " " t)) + (if (buffer-live-p buffer) + (push buffer buffers)))) (nreverse buffers))) (defun Buffer-menu-isearch-buffers () @@ -558,20 +480,6 @@ in the selected frame." (bury-buffer (other-buffer)) (delete-other-windows)) -(defun Buffer-menu-mouse-select (event) - "Select the buffer whose line you click on." - (interactive "e") - (let (buffer) - (with-current-buffer (window-buffer (posn-window (event-end event))) - (save-excursion - (goto-char (posn-point (event-end event))) - (setq buffer (Buffer-menu-buffer t)))) - (select-window (posn-window (event-end event))) - (if (and (window-dedicated-p (selected-window)) - (eq (selected-window) (frame-root-window))) - (switch-to-buffer-other-frame buffer) - (switch-to-buffer buffer)))) - (defun Buffer-menu-this-window () "Select this line's buffer in this window." (interactive) @@ -599,340 +507,128 @@ The current window remains selected." (bury-buffer menu))) (defun Buffer-menu-toggle-read-only () - "Toggle read-only status of buffer on this line, perhaps via version control." + "Toggle read-only status of buffer on this line." (interactive) - (let (char) + (let (read-only) (with-current-buffer (Buffer-menu-buffer t) - (toggle-read-only) - (setq char (if buffer-read-only ?% ?\s))) - (save-excursion - (beginning-of-line) - (forward-char 1) - (if (/= (following-char) char) - (let ((inhibit-read-only t)) - (delete-char 1) - (insert char)))))) + (with-no-warnings (toggle-read-only)) + (setq read-only buffer-read-only)) + (tabulated-list-set-col 1 (if read-only "%" " ") t))) (defun Buffer-menu-bury () "Bury the buffer listed on this line." (interactive) - (when (Buffer-menu-no-header) - (save-excursion - (beginning-of-line) - (bury-buffer (Buffer-menu-buffer t)) - (let ((line (buffer-substring (point) (progn (forward-line 1) (point)))) - (inhibit-read-only t)) - (delete-region (point) (progn (forward-line -1) (point))) - (goto-char (point-max)) - (insert line)) - (message "Buried buffer moved to the end")))) - + (let ((buffer (tabulated-list-get-id))) + (cond ((null buffer)) + ((buffer-live-p buffer) + (bury-buffer buffer) + (save-excursion + (let ((elt (tabulated-list-delete-entry))) + (goto-char (point-max)) + (apply 'tabulated-list-print-entry elt))) + (message "Buffer buried.")) + (t + (tabulated-list-delete-entry) + (message "Buffer is dead; removing from list."))))) (defun Buffer-menu-view () "View this line's buffer in View mode." (interactive) (view-buffer (Buffer-menu-buffer t))) - (defun Buffer-menu-view-other-window () "View this line's buffer in View mode in another window." (interactive) (view-buffer-other-window (Buffer-menu-buffer t))) - -;;;###autoload -(defun list-buffers (&optional files-only) - "Display a list of names of existing buffers. -The list is displayed in a buffer named `*Buffer List*'. -Note that buffers with names starting with spaces are omitted. -Non-null optional arg FILES-ONLY means mention only file buffers. - -For more information, see the function `buffer-menu'." - (interactive "P") - (display-buffer (list-buffers-noselect files-only))) - -(defconst Buffer-menu-short-ellipsis - ;; This file is preloaded, so we can't use char-displayable-p here - ;; because we don't know yet what display we're going to connect to. - ":" ;; (if (char-displayable-p ?…) "…" ":") - ) - -(defun Buffer-menu-buffer+size (name size &optional name-props size-props) - (if (> (+ (string-width name) (string-width size) 2) - Buffer-menu-buffer+size-width) - (setq name - (let ((tail - (if (string-match "<[0-9]+>$" name) - (match-string 0 name) - ""))) - (concat (truncate-string-to-width - name - (- Buffer-menu-buffer+size-width - (max (string-width size) 3) - (string-width tail) - 2)) - Buffer-menu-short-ellipsis - tail))) - ;; Don't put properties on (buffer-name). - (setq name (copy-sequence name))) - (add-text-properties 0 (length name) name-props name) - (add-text-properties 0 (length size) size-props size) - (let ((name+space-width (- Buffer-menu-buffer+size-width - (string-width size)))) - (concat name - (propertize (make-string (- name+space-width (string-width name)) - ?\s) - 'display `(space :align-to - ,(+ Buffer-menu-buffer-column - name+space-width))) - size))) - -(defun Buffer-menu-sort (column) - "Sort the buffer menu by COLUMN." - (interactive "P") - (when column - (setq column (prefix-numeric-value column)) - (if (< column 2) (setq column 2)) - (if (> column 5) (setq column 5))) - (setq Buffer-menu-sort-column column) - (let ((inhibit-read-only t) l buf m1 m2) - (save-excursion - (Buffer-menu-beginning) - (while (not (eobp)) - (when (buffer-live-p - (setq buf (get-text-property - (+ (point) - Buffer-menu-buffer-column) - 'buffer))) - (setq m1 (char-after) - m1 (if (memq m1 '(?> ?D)) m1) - m2 (char-after (+ (point) 2)) - m2 (if (eq m2 ?S) m2)) - (if (or m1 m2) - (push (list buf m1 m2) l))) - (forward-line))) - (revert-buffer) - (save-excursion - (Buffer-menu-beginning) - (while (not (eobp)) - (when (setq buf (assq (get-text-property (+ (point) - Buffer-menu-buffer-column) - 'buffer) l)) - (setq m1 (cadr buf) - m2 (cadr (cdr buf))) - (when m1 - (delete-char 1) - (insert m1) - (backward-char 1)) - (when m2 - (forward-char 2) - (delete-char 1) - (insert m2))) - (forward-line))))) - -(defun Buffer-menu-sort-by-column (&optional e) - "Sort the buffer menu by the column clicked on." - (interactive (list last-input-event)) - (if e (mouse-select-window e)) - (let* ((pos (event-start e)) - (obj (posn-object pos)) - (col (if obj - (get-text-property (cdr obj) 'column (car obj)) - (get-text-property (posn-point pos) 'column)))) - (Buffer-menu-sort col))) - -(defvar Buffer-menu-sort-button-map - (let ((map (make-sparse-keymap))) - ;; This keymap handles both nil and non-nil values for - ;; Buffer-menu-use-header-line. - (define-key map [header-line mouse-1] 'Buffer-menu-sort-by-column) - (define-key map [header-line mouse-2] 'Buffer-menu-sort-by-column) - (define-key map [mouse-2] 'Buffer-menu-sort-by-column) - (define-key map [follow-link] 'mouse-face) - (define-key map "\C-m" 'Buffer-menu-sort-by-column) - map) - "Local keymap for Buffer menu sort buttons.") - -(defun Buffer-menu-make-sort-button (name column) - (if (equal column Buffer-menu-sort-column) (setq column nil)) - (propertize name - 'column column - 'help-echo (concat - (if Buffer-menu-use-header-line - "mouse-1, mouse-2: sort by " - "mouse-2, RET: sort by ") - (if column (downcase name) "visited order")) - 'mouse-face 'highlight - 'keymap Buffer-menu-sort-button-map)) +;;; Functions for populating the Buffer Menu. (defun list-buffers-noselect (&optional files-only buffer-list) - "Create and return a buffer with a list of names of existing buffers. -The buffer is named `*Buffer List*'. -Note that buffers with names starting with spaces are omitted. -Non-null optional arg FILES-ONLY means mention only file buffers. - -If BUFFER-LIST is non-nil, it should be a list of buffers; -it means list those buffers and no others. - -For more information, see the function `buffer-menu'." - (let* ((old-buffer (current-buffer)) - (standard-output standard-output) - (mode-end (make-string (- Buffer-menu-mode-width 2) ?\s)) - (header (concat "CRM " - (Buffer-menu-buffer+size - (Buffer-menu-make-sort-button "Buffer" 2) - (Buffer-menu-make-sort-button "Size" 3)) - " " - (Buffer-menu-make-sort-button "Mode" 4) mode-end - (Buffer-menu-make-sort-button "File" 5) "\n")) - list desired-point) - (when Buffer-menu-use-header-line - (let ((pos 0)) - ;; Turn whitespace chars in the header into stretch specs so - ;; they work regardless of the header-line face. - (while (string-match "[ \t\n]+" header pos) - (setq pos (match-end 0)) - (put-text-property (match-beginning 0) pos 'display - ;; Assume fixed-size chars in the buffer. - (list 'space :align-to pos) - header))) - ;; Try to better align the one-char headers. - (put-text-property 0 3 'face 'fixed-pitch header) - ;; Add a "dummy" leading space to align the beginning of the header - ;; line with the beginning of the text (rather than with the left - ;; scrollbar or the left fringe). --Stef - (setq header (concat (propertize " " 'display '(space :align-to 0)) - header))) - (with-current-buffer (get-buffer-create "*Buffer List*") - (setq buffer-read-only nil) - (erase-buffer) - (setq standard-output (current-buffer)) - ;; Force L2R direction, to avoid messing the display if the - ;; first buffer in the list happens to begin with a strong R2L - ;; character. - (setq bidi-paragraph-direction 'left-to-right) - (unless Buffer-menu-use-header-line - ;; Use U+2014 (EM DASH) to underline if possible, else use ASCII - ;; (i.e. U+002D, HYPHEN-MINUS). - (let ((underline (if (char-displayable-p ?\u2014) ?\u2014 ?-))) - (insert header - (apply 'string - (mapcar (lambda (c) - (if (memq c '(?\n ?\s)) c underline)) - header))))) - ;; Collect info for every buffer we're interested in. - (dolist (buffer (or buffer-list - (buffer-list - (when Buffer-menu-use-frame-buffer-list - (selected-frame))))) - (with-current-buffer buffer - (let ((name (buffer-name)) - (file buffer-file-name)) - (unless (and (not buffer-list) - (or - ;; Don't mention internal buffers. - (and (string= (substring name 0 1) " ") (null file)) - ;; Maybe don't mention buffers without files. - (and files-only (not file)) - (string= name "*Buffer List*"))) - ;; Otherwise output info. - (let ((mode (concat (format-mode-line mode-name nil nil buffer) - (if mode-line-process - (format-mode-line mode-line-process - nil nil buffer)))) - (bits (string - (if (eq buffer old-buffer) ?. ?\s) - ;; Handle readonly status. The output buffer - ;; is special cased to appear readonly; it is - ;; actually made so at a later date. - (if (or (eq buffer standard-output) - buffer-read-only) - ?% ?\s) - ;; Identify modified buffers. - (if (buffer-modified-p) ?* ?\s) - ;; Space separator. - ?\s))) - (unless file - ;; No visited file. Check local value of - ;; list-buffers-directory and, for Info buffers, - ;; Info-current-file. - (cond ((and (boundp 'list-buffers-directory) - list-buffers-directory) - (setq file list-buffers-directory)) - ((eq major-mode 'Info-mode) - (setq file Info-current-file) - (cond - ((equal file "dir") - (setq file "*Info Directory*")) - ((eq file 'apropos) - (setq file "*Info Apropos*")) - ((eq file 'history) - (setq file "*Info History*")) - ((eq file 'toc) - (setq file "*Info TOC*")) - ((not (stringp file)) ;; avoid errors - (setq file nil)) - (t - (setq file (concat "(" - (file-name-nondirectory file) - ") " - Info-current-node))))))) - (push (list buffer bits name (buffer-size) mode file) - list)))))) - ;; Preserve the original buffer-list ordering, just in case. - (setq list (nreverse list)) - ;; Place the buffers's info in the output buffer, sorted if necessary. - (dolist (buffer - (if Buffer-menu-sort-column - (sort list - (if (eq Buffer-menu-sort-column 3) - (lambda (a b) - (< (nth Buffer-menu-sort-column a) - (nth Buffer-menu-sort-column b))) - (lambda (a b) - (string< (nth Buffer-menu-sort-column a) - (nth Buffer-menu-sort-column b))))) - list)) - (if (eq (car buffer) old-buffer) - (setq desired-point (point))) - (insert (cadr buffer) - ;; Put the buffer name into a text property - ;; so we don't have to extract it from the text. - ;; This way we avoid problems with unusual buffer names. - (let ((name (nth 2 buffer)) - (size (int-to-string (nth 3 buffer)))) - (Buffer-menu-buffer+size name size - `(buffer-name ,name - buffer ,(car buffer) - font-lock-face buffer-menu-buffer - mouse-face highlight - help-echo - ,(if (>= (length name) - (- Buffer-menu-buffer+size-width - (max (length size) 3) - 2)) - name - "mouse-2: select this buffer")))) - " " - (if (> (string-width (nth 4 buffer)) Buffer-menu-mode-width) - (truncate-string-to-width (nth 4 buffer) - Buffer-menu-mode-width) - (nth 4 buffer))) - (when (nth 5 buffer) - (indent-to (+ Buffer-menu-buffer-column Buffer-menu-buffer+size-width - Buffer-menu-mode-width 4) 1) - (princ (abbreviate-file-name (nth 5 buffer)))) - (princ "\n")) + "Create and return a Buffer Menu buffer. +This is called by `buffer-menu' and others as a subroutine. + +If FILES-ONLY is non-nil, show only file-visiting buffers. +If BUFFER-LIST is non-nil, it should be a list of buffers; it +means list those buffers and no others." + (let ((old-buffer (current-buffer)) + (buffer (get-buffer-create "*Buffer List*"))) + (with-current-buffer buffer (Buffer-menu-mode) - (when Buffer-menu-use-header-line - (setq header-line-format header)) - ;; DESIRED-POINT doesn't have to be set; it is not when the - ;; current buffer is not displayed for some reason. - (and desired-point - (goto-char desired-point)) - (setq Buffer-menu-files-only files-only) - (setq Buffer-menu--buffers buffer-list) - (set-buffer-modified-p nil) - (current-buffer)))) + (setq Buffer-menu-files-only (and files-only (>= files-only 0))) + (list-buffers--refresh buffer-list old-buffer) + (tabulated-list-print)) + buffer)) + +(defun list-buffers--refresh (&optional buffer-list old-buffer) + ;; Set up `tabulated-list-format'. + (let ((name-width Buffer-menu-name-width) + (size-width Buffer-menu-size-width)) + ;; Handle obsolete variable: + (if Buffer-menu-buffer+size-width + (setq name-width (- Buffer-menu-buffer+size-width size-width))) + (setq tabulated-list-format + (vector '("C" 1 t :pad-right 0) + '("R" 1 t :pad-right 0) + '("M" 1 t) + `("Buffer" ,name-width t) + `("Size" ,size-width tabulated-list-entry-size->) + `("Mode" ,Buffer-menu-mode-width t) + '("File" 1 t)))) + ;; Collect info for each buffer we're interested in. + (let ((buffer-menu-buffer (current-buffer)) + (show-non-file (not Buffer-menu-files-only)) + entries) + (dolist (buffer (or buffer-list + (buffer-list (if Buffer-menu-use-frame-buffer-list + (selected-frame))))) + (with-current-buffer buffer + (let* ((name (buffer-name)) + (file buffer-file-name)) + (when (and (buffer-live-p buffer) + (or buffer-list + (and (not (string= (substring name 0 1) " ")) + (not (eq buffer buffer-menu-buffer)) + (or file show-non-file)))) + (push (list buffer + (vector (if (eq buffer old-buffer) "." " ") + (if buffer-read-only "%" " ") + (if (buffer-modified-p) "*" " ") + (Buffer-menu--pretty-name name) + (number-to-string (buffer-size)) + (concat (format-mode-line mode-name nil nil buffer) + (if mode-line-process + (format-mode-line mode-line-process + nil nil buffer))) + (Buffer-menu--pretty-file-name file))) + entries))))) + (setq tabulated-list-entries (nreverse entries))) + (tabulated-list-init-header)) + +(defun tabulated-list-entry-size-> (entry1 entry2) + (> (string-to-number (aref (cadr entry1) 4)) + (string-to-number (aref (cadr entry2) 4)))) + +(defun Buffer-menu--pretty-name (name) + (propertize name 'font-lock-face 'buffer-menu-buffer)) + +(defun Buffer-menu--pretty-file-name (file) + (cond (file + (abbreviate-file-name file)) + ((and (boundp 'list-buffers-directory) + list-buffers-directory) + list-buffers-directory) + ((eq major-mode 'Info-mode) + (Buffer-menu-info-node-description Info-current-file)) + (t ""))) + +(defun Buffer-menu-info-node-description (file) + (cond + ((equal file "dir") "*Info Directory*") + ((eq file 'apropos) "*Info Apropos*") + ((eq file 'history) "*Info History*") + ((eq file 'toc) "*Info TOC*") + ((not (stringp file)) "") ; Avoid errors + (t + (concat "(" (file-name-nondirectory file) ") " Info-current-node)))) ;;; buff-menu.el ends here diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index 48be2f72972..06c8fe8dba7 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -286,7 +286,7 @@ This also does some trivial optimizations to make the form prettier. ;;;;;; flet progv psetq do-all-symbols do-symbols dotimes dolist ;;;;;; do* do loop return-from return block etypecase typecase ecase ;;;;;; case load-time-value eval-when destructuring-bind function* -;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "abb2e33c6f61539d69ddbe7c4046261b") +;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "e10ebd95224fcfbe6a5edc59f40d695a") ;;; Generated autoloads from cl-macs.el (autoload 'gensym "cl-macs" "\ diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index bd734a4fbe0..4291f3aacc6 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -144,7 +144,7 @@ If ADVANCE is non-nil, move forward by one line afterwards." (set-keymap-parent map button-buffer-map) (define-key map "n" 'next-line) (define-key map "p" 'previous-line) - (define-key map "S" 'tabulated-list-sort-column) + (define-key map "S" 'tabulated-list-sort) (define-key map [follow-link] 'mouse-face) (define-key map [mouse-2] 'mouse-select-window) map) @@ -174,8 +174,7 @@ If ADVANCE is non-nil, move forward by one line afterwards." mouse-face highlight keymap ,tabulated-list-sort-button-map)) (cols nil)) - (if (> tabulated-list-padding 0) - (push (propertize " " 'display `(space :align-to ,x)) cols)) + (push (propertize " " 'display `(space :align-to ,x)) cols) (dotimes (n (length tabulated-list-format)) (let* ((col (aref tabulated-list-format n)) (label (nth 0 col)) @@ -183,9 +182,6 @@ If ADVANCE is non-nil, move forward by one line afterwards." (props (nthcdr 3 col)) (pad-right (or (plist-get props :pad-right) 1))) (setq x (+ x pad-right width)) - (and (<= tabulated-list-padding 0) - (= n 0) - (setq label (concat " " label))) (push (cond ;; An unsortable column @@ -402,7 +398,7 @@ this is the vector stored within it." (with-current-buffer (window-buffer (posn-window pos)) (tabulated-list--sort-by-column-name name)))) -(defun tabulated-list-sort-column (&optional n) +(defun tabulated-list-sort (&optional n) "Sort Tabulated List entries by the column at point. With a numeric prefix argument N, sort the Nth column." (interactive "P") @@ -424,7 +420,6 @@ With a numeric prefix argument N, sort the Nth column." ;;; The mode definition: -;;;###autoload (define-derived-mode tabulated-list-mode special-mode "Tabulated" "Generic major mode for browsing a list of items. This mode is usually not used directly; instead, other major diff --git a/lisp/loadup.el b/lisp/loadup.el index f7ffa27a9ed..5f005a4e709 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -188,6 +188,7 @@ (load "textmodes/fill") (load "replace") +(load "emacs-lisp/tabulated-list") (load "buff-menu") (if (fboundp 'x-create-frame) diff --git a/src/ChangeLog b/src/ChangeLog index a4d7bb64919..f5811569d0d 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,7 @@ +2012-05-06 Chong Yidong + + * lisp.mk (lisp): Update. + 2012-05-05 Jim Meyering * w32font.c (fill_in_logfont): NUL-terminate a string (Bug#11372). diff --git a/src/lisp.mk b/src/lisp.mk index 4895ca40959..ead1abcbaae 100644 --- a/src/lisp.mk +++ b/src/lisp.mk @@ -129,6 +129,7 @@ lisp = \ $(lispsource)/textmodes/text-mode.elc \ $(lispsource)/textmodes/fill.elc \ $(lispsource)/replace.elc \ + $(lispsource)/emacs-lisp/tabulated-list.elc \ $(lispsource)/buff-menu.elc \ $(lispsource)/fringe.elc \ $(lispsource)/emacs-lisp/regexp-opt.elc \ -- cgit v1.2.3 From 4735906a0363f9a5a77f939afe9bfec07765845e Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 17 May 2012 16:04:56 -0400 Subject: Minor renaming of internal CL functions and variables. * lisp/emacs-lisp/cl-seq.el (cl--adjoin): Rename from cl-adjoin. (cl--position): Rename from cl-position. (cl--delete-duplicates): Rename from cl-delete-duplicates. * lisp/emacs-lisp/cl.el (cl--gensym-counter): Rename from *gensym-counter*. (cl--random-state): Rename from *random-state*. --- lisp/ChangeLog | 9 +++++++++ lisp/emacs-lisp/cl-extra.el | 6 +++--- lisp/emacs-lisp/cl-loaddefs.el | 12 ++++++------ lisp/emacs-lisp/cl-macs.el | 10 +++++----- lisp/emacs-lisp/cl-seq.el | 40 ++++++++++++++++++++-------------------- lisp/emacs-lisp/cl.el | 6 +++--- 6 files changed, 46 insertions(+), 37 deletions(-) (limited to 'lisp/emacs-lisp/cl-loaddefs.el') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index fca6543072c..3981911d99b 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,12 @@ +2012-05-17 Stefan Monnier + + Minor renaming of internal CL functions and variables. + * emacs-lisp/cl-seq.el (cl--adjoin): Rename from cl-adjoin. + (cl--position): Rename from cl-position. + (cl--delete-duplicates): Rename from cl-delete-duplicates. + * emacs-lisp/cl.el (cl--gensym-counter): Rename from *gensym-counter*. + (cl--random-state): Rename from *random-state*. + 2012-05-17 Stefan Monnier * emacs-lisp/cl-macs.el (cl-transform-lambda): Don't add spurious diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 9a3d8cf705b..420480d16ea 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -434,7 +434,7 @@ With two arguments, return rounding and remainder of their quotient." (defun random* (lim &optional state) "Return a random nonnegative number less than LIM, an integer or float. Optional second arg STATE is a random-state object." - (or state (setq state *random-state*)) + (or state (setq state cl--random-state)) ;; Inspired by "ran3" from Numerical Recipes. Additive congruential method. (let ((vec (aref state 3))) (if (integerp vec) @@ -457,9 +457,9 @@ Optional second arg STATE is a random-state object." ;;;###autoload (defun make-random-state (&optional state) - "Return a copy of random-state STATE, or of `*random-state*' if omitted. + "Return a copy of random-state STATE, or of the internal state if omitted. If STATE is t, return a new state object seeded from the time of day." - (cond ((null state) (make-random-state *random-state*)) + (cond ((null state) (make-random-state cl--random-state)) ((vectorp state) (cl-copy-tree state t)) ((integerp state) (vector 'cl-random-state-tag -1 30 state)) (t (make-random-state (cl-random-time))))) diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index 06c8fe8dba7..a00b4550b31 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -10,7 +10,7 @@ ;;;;;; ceiling* floor* isqrt lcm gcd cl-progv-before cl-set-frame-visible-p ;;;;;; cl-map-overlays cl-map-intervals cl-map-keymap-recursively ;;;;;; notevery notany every some mapcon mapcan mapl maplist map -;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "5a8a7f7ec2dc453113b8cbda577f2acb") +;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "1a3a04c6a0286373093bea4b9bcf2e91") ;;; Generated autoloads from cl-extra.el (autoload 'coerce "cl-extra" "\ @@ -169,7 +169,7 @@ Optional second arg STATE is a random-state object. \(fn LIM &optional STATE)" nil nil) (autoload 'make-random-state "cl-extra" "\ -Return a copy of random-state STATE, or of `*random-state*' if omitted. +Return a copy of random-state STATE, or of the internal state if omitted. If STATE is t, return a new state object seeded from the time of day. \(fn &optional STATE)" nil nil) @@ -286,7 +286,7 @@ This also does some trivial optimizations to make the form prettier. ;;;;;; flet progv psetq do-all-symbols do-symbols dotimes dolist ;;;;;; do* do loop return-from return block etypecase typecase ecase ;;;;;; case load-time-value eval-when destructuring-bind function* -;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "e10ebd95224fcfbe6a5edc59f40d695a") +;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "69ccd3344cea28acc44dd28eca07292f") ;;; Generated autoloads from cl-macs.el (autoload 'gensym "cl-macs" "\ @@ -764,13 +764,13 @@ surrounded by (block NAME ...). ;;;;;; nsubst subst-if-not subst-if subsetp nset-exclusive-or set-exclusive-or ;;;;;; nset-difference set-difference nintersection intersection ;;;;;; nunion union rassoc-if-not rassoc-if rassoc* assoc-if-not -;;;;;; assoc-if assoc* cl-adjoin member-if-not member-if member* +;;;;;; assoc-if assoc* cl--adjoin member-if-not member-if member* ;;;;;; merge stable-sort sort* search mismatch count-if-not count-if ;;;;;; count position-if-not position-if position find-if-not find-if ;;;;;; find nsubstitute-if-not nsubstitute-if nsubstitute substitute-if-not ;;;;;; substitute-if substitute delete-duplicates remove-duplicates ;;;;;; delete-if-not delete-if delete* remove-if-not remove-if remove* -;;;;;; replace fill reduce) "cl-seq" "cl-seq.el" "99095e49c83af1c8bec0fdcf517b3f95") +;;;;;; replace fill reduce) "cl-seq" "cl-seq.el" "2d8563fcbdf4bc77e569d0aeb0a35cfc") ;;; Generated autoloads from cl-seq.el (autoload 'reduce "cl-seq" "\ @@ -1047,7 +1047,7 @@ Keywords supported: :key \(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) -(autoload 'cl-adjoin "cl-seq" "\ +(autoload 'cl--adjoin "cl-seq" "\ \(fn CL-ITEM CL-LIST &rest CL-KEYS)" nil nil) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 66fafb9ba41..6ca5e6294d6 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -167,15 +167,15 @@ ;;; Symbols. -(defvar *gensym-counter*) +(defvar cl--gensym-counter) ;;;###autoload (defun gensym (&optional prefix) "Generate a new uninterned symbol. The name is made by appending a number to PREFIX, default \"G\"." (let ((pfix (if (stringp prefix) prefix "G")) (num (if (integerp prefix) prefix - (prog1 *gensym-counter* - (setq *gensym-counter* (1+ *gensym-counter*)))))) + (prog1 cl--gensym-counter + (setq cl--gensym-counter (1+ cl--gensym-counter)))))) (make-symbol (format "%s%d" pfix num)))) ;;;###autoload @@ -184,8 +184,8 @@ The name is made by appending a number to PREFIX, default \"G\"." The name is made by appending a number to PREFIX, default \"G\"." (let ((pfix (if (stringp prefix) prefix "G")) name) - (while (intern-soft (setq name (format "%s%d" pfix *gensym-counter*))) - (setq *gensym-counter* (1+ *gensym-counter*))) + (while (intern-soft (setq name (format "%s%d" pfix cl--gensym-counter))) + (setq cl--gensym-counter (1+ cl--gensym-counter))) (intern name))) diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index f1890fbccf6..233f0c83a6e 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -213,8 +213,8 @@ to avoid corrupting the original SEQ. (if (<= (or cl-count (setq cl-count 8000000)) 0) cl-seq (if (or (nlistp cl-seq) (and cl-from-end (< cl-count 4000000))) - (let ((cl-i (cl-position cl-item cl-seq cl-start cl-end - cl-from-end))) + (let ((cl-i (cl--position cl-item cl-seq cl-start cl-end + cl-from-end))) (if cl-i (let ((cl-res (apply 'delete* cl-item (append cl-seq nil) (append (if cl-from-end @@ -279,8 +279,8 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. (if (and cl-from-end (< cl-count 4000000)) (let (cl-i) (while (and (>= (setq cl-count (1- cl-count)) 0) - (setq cl-i (cl-position cl-item cl-seq cl-start - cl-end cl-from-end))) + (setq cl-i (cl--position cl-item cl-seq cl-start + cl-end cl-from-end))) (if (= cl-i 0) (setq cl-seq (cdr cl-seq)) (let ((cl-tail (nthcdr (1- cl-i) cl-seq))) (setcdr cl-tail (cdr (cdr cl-tail))))) @@ -330,16 +330,16 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. "Return a copy of SEQ with all duplicate elements removed. \nKeywords supported: :test :test-not :key :start :end :from-end \n(fn SEQ [KEYWORD VALUE]...)" - (cl-delete-duplicates cl-seq cl-keys t)) + (cl--delete-duplicates cl-seq cl-keys t)) ;;;###autoload (defun delete-duplicates (cl-seq &rest cl-keys) "Remove all duplicate elements from SEQ (destructively). \nKeywords supported: :test :test-not :key :start :end :from-end \n(fn SEQ [KEYWORD VALUE]...)" - (cl-delete-duplicates cl-seq cl-keys nil)) + (cl--delete-duplicates cl-seq cl-keys nil)) -(defun cl-delete-duplicates (cl-seq cl-keys cl-copy) +(defun cl--delete-duplicates (cl-seq cl-keys cl-copy) (if (listp cl-seq) (cl-parsing-keywords (:test :test-not :key (:start 0) :end :from-end :if) () @@ -348,8 +348,8 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. (setq cl-end (- (or cl-end (length cl-seq)) cl-start)) (while (> cl-end 1) (setq cl-i 0) - (while (setq cl-i (cl-position (cl-check-key (car cl-p)) - (cdr cl-p) cl-i (1- cl-end))) + (while (setq cl-i (cl--position (cl-check-key (car cl-p)) + (cdr cl-p) cl-i (1- cl-end))) (if cl-copy (setq cl-seq (copy-sequence cl-seq) cl-p (nthcdr cl-start cl-seq) cl-copy nil)) (let ((cl-tail (nthcdr cl-i cl-p))) @@ -360,14 +360,14 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. cl-seq) (setq cl-end (- (or cl-end (length cl-seq)) cl-start)) (while (and (cdr cl-seq) (= cl-start 0) (> cl-end 1) - (cl-position (cl-check-key (car cl-seq)) - (cdr cl-seq) 0 (1- cl-end))) + (cl--position (cl-check-key (car cl-seq)) + (cdr cl-seq) 0 (1- cl-end))) (setq cl-seq (cdr cl-seq) cl-end (1- cl-end))) (let ((cl-p (if (> cl-start 0) (nthcdr (1- cl-start) cl-seq) (setq cl-end (1- cl-end) cl-start 1) cl-seq))) (while (and (cdr (cdr cl-p)) (> cl-end 1)) - (if (cl-position (cl-check-key (car (cdr cl-p))) - (cdr (cdr cl-p)) 0 (1- cl-end)) + (if (cl--position (cl-check-key (car (cdr cl-p))) + (cdr (cdr cl-p)) 0 (1- cl-end)) (progn (if cl-copy (setq cl-seq (copy-sequence cl-seq) cl-p (nthcdr (1- cl-start) cl-seq) @@ -376,7 +376,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. (setq cl-p (cdr cl-p))) (setq cl-end (1- cl-end) cl-start (1+ cl-start))) cl-seq))) - (let ((cl-res (cl-delete-duplicates (append cl-seq nil) cl-keys nil))) + (let ((cl-res (cl--delete-duplicates (append cl-seq nil) cl-keys nil))) (if (stringp cl-seq) (concat cl-res) (vconcat cl-res))))) ;;;###autoload @@ -391,7 +391,7 @@ to avoid corrupting the original SEQ. (if (or (eq cl-old cl-new) (<= (or cl-count (setq cl-from-end nil cl-count 8000000)) 0)) cl-seq - (let ((cl-i (cl-position cl-old cl-seq cl-start cl-end))) + (let ((cl-i (cl--position cl-old cl-seq cl-start cl-end))) (if (not cl-i) cl-seq (setq cl-seq (copy-sequence cl-seq)) @@ -502,9 +502,9 @@ Return the index of the matching item, or nil if not found. \n(fn ITEM SEQ [KEYWORD VALUE]...)" (cl-parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end :from-end) () - (cl-position cl-item cl-seq cl-start cl-end cl-from-end))) + (cl--position cl-item cl-seq cl-start cl-end cl-from-end))) -(defun cl-position (cl-item cl-seq cl-start &optional cl-end cl-from-end) +(defun cl--position (cl-item cl-seq cl-start &optional cl-end cl-from-end) (if (listp cl-seq) (let ((cl-p (nthcdr cl-start cl-seq))) (or cl-end (setq cl-end 8000000)) @@ -619,8 +619,8 @@ return nil if there are no matches. (cl-if nil) cl-pos) (setq cl-end2 (- cl-end2 (1- cl-len))) (while (and (< cl-start2 cl-end2) - (setq cl-pos (cl-position cl-first cl-seq2 - cl-start2 cl-end2 cl-from-end)) + (setq cl-pos (cl--position cl-first cl-seq2 + cl-start2 cl-end2 cl-from-end)) (apply 'mismatch cl-seq1 cl-seq2 :start1 (1+ cl-start1) :end1 cl-end1 :start2 (1+ cl-pos) :end2 (+ cl-pos cl-len) @@ -702,7 +702,7 @@ Return the sublist of LIST whose car matches. (apply 'member* nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload -(defun cl-adjoin (cl-item cl-list &rest cl-keys) +(defun cl--adjoin (cl-item cl-list &rest cl-keys) (if (cl-parsing-keywords (:key) t (apply 'member* (cl-check-key cl-item) cl-list cl-keys)) cl-list diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 971024fcbba..2b56e8a9e4b 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -304,7 +304,7 @@ definitions to shadow the loaded ones for use in file byte-compilation. (while (>= (decf i) 0) (setq v (+ (* v 3) (aref time i)))) v)) -(defvar *gensym-counter* (* (logand (cl-random-time) 1023) 100)) +(defvar cl--gensym-counter (* (logand (cl-random-time) 1023) 100)) ;;; Numbers. @@ -331,7 +331,7 @@ always returns nil." "Return t if INTEGER is even." (eq (logand integer 1) 0)) -(defvar *random-state* (vector 'cl-random-state-tag -1 30 (cl-random-time))) +(defvar cl--random-state (vector 'cl-random-state-tag -1 30 (cl-random-time))) (defconst most-positive-float nil "The largest value that a Lisp float can hold. @@ -608,7 +608,7 @@ Otherwise, return LIST unmodified. (if (memq cl-item cl-list) cl-list (cons cl-item cl-list))) ((or (equal cl-keys '(:test equal)) (null cl-keys)) (if (member cl-item cl-list) cl-list (cons cl-item cl-list))) - (t (apply 'cl-adjoin cl-item cl-list cl-keys)))) + (t (apply 'cl--adjoin cl-item cl-list cl-keys)))) (defun subst (cl-new cl-old cl-tree &rest cl-keys) "Substitute NEW for OLD everywhere in TREE (non-destructively). -- cgit v1.2.3 From b1198e177ffc930aaf60c66f1a0b3d54db8ba3b1 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 17 May 2012 17:39:36 -0400 Subject: * lisp/emacs-lisp/cl.el: Add edebug specs from cl-specs.el. * lisp/emacs-lisp/cl-macs.el: Idem. * lisp/emacs-lisp/cl-specs.el: Remove. --- lisp/ChangeLog | 6 + lisp/emacs-lisp/cl-loaddefs.el | 2 +- lisp/emacs-lisp/cl-macs.el | 320 +++++++++++++++++++++++++++- lisp/emacs-lisp/cl-specs.el | 471 ----------------------------------------- lisp/emacs-lisp/cl.el | 8 + 5 files changed, 333 insertions(+), 474 deletions(-) delete mode 100644 lisp/emacs-lisp/cl-specs.el (limited to 'lisp/emacs-lisp/cl-loaddefs.el') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 3981911d99b..cdb8217ed2c 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,9 @@ +2012-05-17 Stefan Monnier + + * emacs-lisp/cl.el: Add edebug specs from cl-specs.el. + * emacs-lisp/cl-macs.el: Idem. + * emacs-lisp/cl-specs.el: Remove. + 2012-05-17 Stefan Monnier Minor renaming of internal CL functions and variables. diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index a00b4550b31..d16b98630c8 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -286,7 +286,7 @@ This also does some trivial optimizations to make the form prettier. ;;;;;; flet progv psetq do-all-symbols do-symbols dotimes dolist ;;;;;; do* do loop return-from return block etypecase typecase ecase ;;;;;; case load-time-value eval-when destructuring-bind function* -;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "69ccd3344cea28acc44dd28eca07292f") +;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "ed94b3ba46080516e6ada69bdf617be5") ;;; Generated autoloads from cl-macs.el (autoload 'gensym "cl-macs" "\ diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 6ca5e6294d6..9fd53d78d92 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -191,6 +191,28 @@ The name is made by appending a number to PREFIX, default \"G\"." ;;; Program structure. +(def-edebug-spec cl-declarations + (&rest ("declare" &rest sexp))) + +(def-edebug-spec cl-declarations-or-string + (&or stringp cl-declarations)) + +(def-edebug-spec cl-lambda-list + (([&rest arg] + [&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]] + [&optional ["&rest" arg]] + [&optional ["&key" [cl-&key-arg &rest cl-&key-arg] + &optional "&allow-other-keys"]] + [&optional ["&aux" &rest + &or (symbolp &optional def-form) symbolp]] + ))) + +(def-edebug-spec cl-&optional-arg + (&or (arg &optional def-form arg) arg)) + +(def-edebug-spec cl-&key-arg + (&or ([&or (symbolp arg) arg] &optional def-form arg) arg)) + ;;;###autoload (defmacro defun* (name args &rest body) "Define NAME as a function. @@ -198,10 +220,55 @@ Like normal `defun', except ARGLIST allows full Common Lisp conventions, and BODY is implicitly surrounded by (block NAME ...). \(fn NAME ARGLIST [DOCSTRING] BODY...)" + (declare (debug + ;; Same as defun but use cl-lambda-list. + (&define [&or name ("setf" :name setf name)] + cl-lambda-list + cl-declarations-or-string + [&optional ("interactive" interactive)] + def-body))) (let* ((res (cl-transform-lambda (cons args body) name)) (form (list* 'defun name (cdr res)))) (if (car res) (list 'progn (car res) form) form))) +;; The lambda list for macros is different from that of normal lambdas. +;; Note that &environment is only allowed as first or last items in the +;; top level list. + +(def-edebug-spec cl-macro-list + (([&optional "&environment" arg] + [&rest cl-macro-arg] + [&optional ["&optional" &rest + &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] + [&optional [[&or "&rest" "&body"] cl-macro-arg]] + [&optional ["&key" [&rest + [&or ([&or (symbolp cl-macro-arg) arg] + &optional def-form cl-macro-arg) + arg]] + &optional "&allow-other-keys"]] + [&optional ["&aux" &rest + &or (symbolp &optional def-form) symbolp]] + [&optional "&environment" arg] + ))) + +(def-edebug-spec cl-macro-arg + (&or arg cl-macro-list1)) + +(def-edebug-spec cl-macro-list1 + (([&optional "&whole" arg] ;; only allowed at lower levels + [&rest cl-macro-arg] + [&optional ["&optional" &rest + &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] + [&optional [[&or "&rest" "&body"] cl-macro-arg]] + [&optional ["&key" [&rest + [&or ([&or (symbolp cl-macro-arg) arg] + &optional def-form cl-macro-arg) + arg]] + &optional "&allow-other-keys"]] + [&optional ["&aux" &rest + &or (symbolp &optional def-form) symbolp]] + . [&or arg nil]))) + ;;;###autoload (defmacro defmacro* (name args &rest body) "Define NAME as a macro. @@ -209,15 +276,32 @@ Like normal `defmacro', except ARGLIST allows full Common Lisp conventions, and BODY is implicitly surrounded by (block NAME ...). \(fn NAME ARGLIST [DOCSTRING] BODY...)" + (declare (debug + (&define name cl-macro-list cl-declarations-or-string def-body))) (let* ((res (cl-transform-lambda (cons args body) name)) (form (list* 'defmacro name (cdr res)))) (if (car res) (list 'progn (car res) form) form))) +(def-edebug-spec cl-lambda-expr + (&define ("lambda" cl-lambda-list + ;;cl-declarations-or-string + ;;[&optional ("interactive" interactive)] + def-body))) + +;; Redefine function-form to also match function* +(def-edebug-spec function-form + ;; form at the end could also handle "function", + ;; but recognize it specially to avoid wrapping function forms. + (&or ([&or "quote" "function"] &or symbolp lambda-expr) + ("function*" function*) + form)) + ;;;###autoload (defmacro function* (func) "Introduce a function. Like normal `function', except that if argument is a lambda form, its argument list allows full Common Lisp conventions." + (declare (debug (&or symbolp cl-lambda-expr))) (if (eq (car-safe func) 'lambda) (let* ((res (cl-transform-lambda (cdr func) 'cl-none)) (form (list 'function (cons 'lambda (cdr res))))) @@ -471,6 +555,7 @@ It is a list of elements of the form either: ;;;###autoload (defmacro destructuring-bind (args expr &rest body) + (declare (debug (&define cl-macro-list def-form cl-declarations def-body))) (let* ((bind-lets nil) (bind-forms nil) (bind-inits nil) (bind-defs nil) (bind-block 'cl-none) (bind-enquote nil)) (cl-do-arglist (or args '(&aux)) expr) @@ -491,6 +576,7 @@ If `load' is in WHEN, BODY is evaluated when loaded after top-level compile. If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level. \(fn (WHEN...) BODY...)" + (declare (debug ((&rest &or "compile" "load" "eval") body))) (if (and (fboundp 'cl-compiling-file) (cl-compiling-file) (not cl-not-toplevel) (not (boundp 'for-effect))) ; horrible kludge (let ((comp (or (memq 'compile when) (memq :compile-toplevel when))) @@ -519,6 +605,7 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level. (defmacro load-time-value (form &optional read-only) "Like `progn', but evaluates the body at load time. The result of the body appears to the compiler as a quoted constant." + (declare (debug (form &optional sexp))) (if (cl-compiling-file) (let* ((temp (gentemp "--cl-load-time--")) (set (list 'set (list 'quote temp) form))) @@ -548,6 +635,7 @@ place of a KEYLIST of one atom. A KEYLIST of t or `otherwise' is allowed only in the final clause, and matches if no other keys match. Key values are compared by `eql'. \n(fn EXPR (KEYLIST BODY...)...)" + (declare (debug (form &rest (sexp body)))) (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) (head-list nil) (body (cons @@ -578,6 +666,7 @@ Key values are compared by `eql'. "Like `case', but error if no case fits. `otherwise'-clauses are not allowed. \n(fn EXPR (KEYLIST BODY...)...)" + (declare (debug case)) (list* 'case expr (append clauses '((ecase-error-flag))))) ;;;###autoload @@ -588,6 +677,7 @@ satisfies TYPE, the corresponding BODY is evaluated. If no clause succeeds, typecase returns nil. A TYPE of t or `otherwise' is allowed only in the final clause, and matches if no other keys match. \n(fn EXPR (TYPE BODY...)...)" + (declare (debug (form &rest ([&or cl-type-spec "otherwise"] body)))) (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) (type-list nil) (body (cons @@ -612,6 +702,7 @@ final clause, and matches if no other keys match. "Like `typecase', but error if no case fits. `otherwise'-clauses are not allowed. \n(fn EXPR (TYPE BODY...)...)" + (declare (debug typecase)) (list* 'typecase expr (append clauses '((ecase-error-flag))))) @@ -627,6 +718,7 @@ quoted symbol or other form; and second, NAME is lexically rather than dynamically scoped: Only references to it within BODY will work. These references may appear inside macro expansions, but not inside functions called from BODY." + (declare (debug (symbolp body))) (if (cl-safe-expr-p (cons 'progn body)) (cons 'progn body) (list 'cl-block-wrapper (list* 'catch (list 'quote (intern (format "--cl-block-%s--" name))) @@ -636,6 +728,7 @@ called from BODY." (defmacro return (&optional result) "Return from the block named nil. This is equivalent to `(return-from nil RESULT)'." + (declare (debug (&optional form))) (list 'return-from nil result)) ;;;###autoload @@ -645,6 +738,7 @@ This jumps out to the innermost enclosing `(block NAME ...)' form, returning RESULT from that form (or nil if RESULT is omitted). This is compatible with Common Lisp, but note that `defun' and `defmacro' do not create implicit blocks as they do in Common Lisp." + (declare (debug (symbolp &optional form))) (let ((name2 (intern (format "--cl-block-%s--" name)))) (list 'cl-block-throw (list 'quote name2) result))) @@ -674,6 +768,7 @@ Valid clauses are: finally return EXPR, named NAME. \(fn CLAUSE...)" + (declare (debug (&rest &or symbolp form))) (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list loop-args)))))) (list 'block nil (list* 'while t loop-args)) (let ((loop-name nil) (loop-bindings nil) @@ -725,6 +820,158 @@ Valid clauses are: (setq body (list (list* 'symbol-macrolet loop-symbol-macs body)))) (list* 'block loop-name body))))) +;; Below is a complete spec for loop, in several parts that correspond +;; to the syntax given in CLtL2. The specs do more than specify where +;; the forms are; it also specifies, as much as Edebug allows, all the +;; syntactically valid loop clauses. The disadvantage of this +;; completeness is rigidity, but the "for ... being" clause allows +;; arbitrary extensions of the form: [symbolp &rest &or symbolp form]. + +;; (def-edebug-spec loop +;; ([&optional ["named" symbolp]] +;; [&rest +;; &or +;; ["repeat" form] +;; loop-for-as +;; loop-with +;; loop-initial-final] +;; [&rest loop-clause] +;; )) + +;; (def-edebug-spec loop-with +;; ("with" loop-var +;; loop-type-spec +;; [&optional ["=" form]] +;; &rest ["and" loop-var +;; loop-type-spec +;; [&optional ["=" form]]])) + +;; (def-edebug-spec loop-for-as +;; ([&or "for" "as"] loop-for-as-subclause +;; &rest ["and" loop-for-as-subclause])) + +;; (def-edebug-spec loop-for-as-subclause +;; (loop-var +;; loop-type-spec +;; &or +;; [[&or "in" "on" "in-ref" "across-ref"] +;; form &optional ["by" function-form]] + +;; ["=" form &optional ["then" form]] +;; ["across" form] +;; ["being" +;; [&or "the" "each"] +;; &or +;; [[&or "element" "elements"] +;; [&or "of" "in" "of-ref"] form +;; &optional "using" ["index" symbolp]];; is this right? +;; [[&or "hash-key" "hash-keys" +;; "hash-value" "hash-values"] +;; [&or "of" "in"] +;; hash-table-p &optional ["using" ([&or "hash-value" "hash-values" +;; "hash-key" "hash-keys"] sexp)]] + +;; [[&or "symbol" "present-symbol" "external-symbol" +;; "symbols" "present-symbols" "external-symbols"] +;; [&or "in" "of"] package-p] + +;; ;; Extensions for Emacs Lisp, including Lucid Emacs. +;; [[&or "frame" "frames" +;; "screen" "screens" +;; "buffer" "buffers"]] + +;; [[&or "window" "windows"] +;; [&or "of" "in"] form] + +;; [[&or "overlay" "overlays" +;; "extent" "extents"] +;; [&or "of" "in"] form +;; &optional [[&or "from" "to"] form]] + +;; [[&or "interval" "intervals"] +;; [&or "in" "of"] form +;; &optional [[&or "from" "to"] form] +;; ["property" form]] + +;; [[&or "key-code" "key-codes" +;; "key-seq" "key-seqs" +;; "key-binding" "key-bindings"] +;; [&or "in" "of"] form +;; &optional ["using" ([&or "key-code" "key-codes" +;; "key-seq" "key-seqs" +;; "key-binding" "key-bindings"] +;; sexp)]] +;; ;; For arbitrary extensions, recognize anything else. +;; [symbolp &rest &or symbolp form] +;; ] + +;; ;; arithmetic - must be last since all parts are optional. +;; [[&optional [[&or "from" "downfrom" "upfrom"] form]] +;; [&optional [[&or "to" "downto" "upto" "below" "above"] form]] +;; [&optional ["by" form]] +;; ])) + +;; (def-edebug-spec loop-initial-final +;; (&or ["initially" +;; ;; [&optional &or "do" "doing"] ;; CLtL2 doesn't allow this. +;; &rest loop-non-atomic-expr] +;; ["finally" &or +;; [[&optional &or "do" "doing"] &rest loop-non-atomic-expr] +;; ["return" form]])) + +;; (def-edebug-spec loop-and-clause +;; (loop-clause &rest ["and" loop-clause])) + +;; (def-edebug-spec loop-clause +;; (&or +;; [[&or "while" "until" "always" "never" "thereis"] form] + +;; [[&or "collect" "collecting" +;; "append" "appending" +;; "nconc" "nconcing" +;; "concat" "vconcat"] form +;; [&optional ["into" loop-var]]] + +;; [[&or "count" "counting" +;; "sum" "summing" +;; "maximize" "maximizing" +;; "minimize" "minimizing"] form +;; [&optional ["into" loop-var]] +;; loop-type-spec] + +;; [[&or "if" "when" "unless"] +;; form loop-and-clause +;; [&optional ["else" loop-and-clause]] +;; [&optional "end"]] + +;; [[&or "do" "doing"] &rest loop-non-atomic-expr] + +;; ["return" form] +;; loop-initial-final +;; )) + +;; (def-edebug-spec loop-non-atomic-expr +;; ([¬ atom] form)) + +;; (def-edebug-spec loop-var +;; ;; The symbolp must be last alternative to recognize e.g. (a b . c) +;; ;; loop-var => +;; ;; (loop-var . [&or nil loop-var]) +;; ;; (symbolp . [&or nil loop-var]) +;; ;; (symbolp . loop-var) +;; ;; (symbolp . (symbolp . [&or nil loop-var])) +;; ;; (symbolp . (symbolp . loop-var)) +;; ;; (symbolp . (symbolp . symbolp)) == (symbolp symbolp . symbolp) +;; (&or (loop-var . [&or nil loop-var]) [gate symbolp])) + +;; (def-edebug-spec loop-type-spec +;; (&optional ["of-type" loop-d-type-spec])) + +;; (def-edebug-spec loop-d-type-spec +;; (&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec)) + + + (defun cl-parse-loop-clause () ; uses loop-* (let ((word (pop loop-args)) (hash-types '(hash-key hash-keys hash-value hash-values)) @@ -1232,6 +1479,10 @@ Valid clauses are: "The Common Lisp `do' loop. \(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" + (declare (debug + ((&rest &or symbolp (symbolp &optional form form)) + (form body) + cl-declarations body))) (cl-expand-do-loop steps endtest body nil)) ;;;###autoload @@ -1239,6 +1490,7 @@ Valid clauses are: "The Common Lisp `do*' loop. \(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" + (declare (debug do)) (cl-expand-do-loop steps endtest body t)) (defun cl-expand-do-loop (steps endtest body star) @@ -1270,6 +1522,7 @@ Then evaluate RESULT to get return value, default nil. An implicit nil block is established around the loop. \(fn (VAR LIST [RESULT]) BODY...)" + (declare (debug ((symbolp form &optional form) cl-declarations body))) (let ((temp (make-symbol "--cl-dolist-temp--"))) ;; FIXME: Copy&pasted from subr.el. `(block nil @@ -1303,6 +1556,7 @@ to COUNT, exclusive. Then evaluate RESULT to get return value, default nil. \(fn (VAR COUNT [RESULT]) BODY...)" + (declare (debug dolist)) (let ((temp (make-symbol "--cl-dotimes-temp--")) (end (nth 1 spec))) ;; FIXME: Copy&pasted from subr.el. @@ -1335,6 +1589,7 @@ Evaluate BODY with VAR bound to each interned symbol, or to each symbol from OBARRAY. \(fn (VAR [OBARRAY [RESULT]]) BODY...)" + (declare (debug ((symbolp &optional form form) cl-declarations body))) ;; Apparently this doesn't have an implicit block. (list 'block nil (list 'let (list (car spec)) @@ -1345,6 +1600,7 @@ from OBARRAY. ;;;###autoload (defmacro do-all-symbols (spec &rest body) + (declare (debug ((symbolp &optional form) cl-declarations body))) (list* 'do-symbols (list (car spec) nil (cadr spec)) body)) @@ -1357,6 +1613,7 @@ This is like `setq', except that all VAL forms are evaluated (in order) before assigning any symbols SYM to the corresponding values. \(fn SYM VAL SYM VAL ...)" + (declare (debug setq)) (cons 'psetf args)) @@ -1370,6 +1627,7 @@ Each symbol in the first list is bound to the corresponding value in the second list (or made unbound if VALUES is shorter than SYMBOLS); then the BODY forms are executed and their result is returned. This is much like a `let' form, except that the list of symbols can be computed at run-time." + (declare (debug (form form body))) (list 'let '((cl-progv-save nil)) (list 'unwind-protect (list* 'progn (list 'cl-progv-before symbols values) body) @@ -1385,6 +1643,7 @@ function definitions in place, then the definitions are undone (the FUNCs go back to their previous definitions, or lack thereof). \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" + (declare (debug ((&rest (defun*)) cl-declarations body))) (list* 'letf* (mapcar (function @@ -1417,6 +1676,7 @@ This is like `flet', except the bindings are lexical instead of dynamic. Unlike `flet', this macro is fully compliant with the Common Lisp standard. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" + (declare (debug flet)) (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment)) (while bindings ;; Use `gensym' rather than `make-symbol'. It's important that @@ -1441,6 +1701,10 @@ Unlike `flet', this macro is fully compliant with the Common Lisp standard. This is like `flet', but for macros instead of functions. \(fn ((NAME ARGLIST BODY...) ...) FORM...)" + (declare (debug + ((&rest (&define name (&rest arg) cl-declarations-or-string + def-body)) + cl-declarations body))) (if (cdr bindings) (list 'macrolet (list (car bindings)) (list* 'macrolet (cdr bindings) body)) @@ -1459,6 +1723,7 @@ Within the body FORMs, references to the variable NAME will be replaced by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). \(fn ((NAME EXPANSION) ...) FORM...)" + (declare (debug ((&rest (symbol sexp)) cl-declarations body))) (if (cdr bindings) (list 'symbol-macrolet (list (car bindings)) (list* 'symbol-macrolet (cdr bindings) body)) @@ -1475,6 +1740,7 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). The main visible difference is that lambdas inside BODY will create lexical closures as in Common Lisp. \n(fn BINDINGS BODY)" + (declare (debug let)) (let* ((cl-closure-vars cl-closure-vars) (vars (mapcar (function (lambda (x) @@ -1527,6 +1793,7 @@ successive bindings within BINDINGS, will create lexical closures as in Common Lisp. This is similar to the behavior of `let*' in Common Lisp. \n(fn BINDINGS BODY)" + (declare (debug let)) (if (null bindings) (cons 'progn body) (setq bindings (reverse bindings)) (while bindings @@ -1552,6 +1819,7 @@ simulate true multiple return values. For compatibility, (values A B C) is a synonym for (list A B C). \(fn (SYM...) FORM BODY)" + (declare (debug ((&rest symbolp) form body))) (let ((temp (make-symbol "--cl-var--")) (n -1)) (list* 'let* (cons (list temp form) (mapcar (function @@ -1569,6 +1837,7 @@ each of the symbols SYM in turn. This is analogous to the Common Lisp values. For compatibility, (values A B C) is a synonym for (list A B C). \(fn (SYM...) FORM)" + (declare (debug ((&rest symbolp) form))) (cond ((null vars) (list 'progn form nil)) ((null (cdr vars)) (list 'setq (car vars) (list 'car form))) (t @@ -1588,9 +1857,13 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). ;;; Declarations. ;;;###autoload -(defmacro locally (&rest body) (cons 'progn body)) +(defmacro locally (&rest body) + (declare (debug t)) + (cons 'progn body)) ;;;###autoload -(defmacro the (type form) form) +(defmacro the (type form) + (declare (debug (cl-type-spec form))) + form) (defvar cl-proclaim-history t) ; for future compilers (defvar cl-declare-stack t) ; for future compilers @@ -1670,6 +1943,8 @@ list, a store-variables list (of length one), a store-form, and an access- form. See `defsetf' for a simpler way to define most setf-methods. \(fn NAME ARGLIST BODY...)" + (declare (debug + (&define name cl-lambda-list cl-declarations-or-string def-body))) (append '(eval-when (compile load eval)) (if (stringp (car body)) (list (list 'put (list 'quote func) '(quote setf-documentation) @@ -1699,6 +1974,11 @@ Example: (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v)) \(fn NAME [FUNC | ARGLIST (STORE) BODY...])" + (declare (debug + (&define name + [&or [symbolp &optional stringp] + [cl-lambda-list (symbolp)]] + cl-declarations-or-string def-body))) (if (and (listp arg1) (consp args)) (let* ((largs nil) (largsr nil) (temps nil) (tempsr nil) @@ -2037,6 +2317,7 @@ For example, (setf (cadar x) y) is equivalent to (setcar (cdar x) y). The return value is the last VAL in the list. \(fn PLACE VAL PLACE VAL ...)" + (declare (debug (&rest [place form]))) (if (cdr (cdr args)) (let ((sets nil)) (while args (push (list 'setf (pop args) (pop args)) sets)) @@ -2054,6 +2335,7 @@ This is like `setf', except that all VAL forms are evaluated (in order) before assigning any PLACEs to the corresponding values. \(fn PLACE VAL PLACE VAL ...)" + (declare (debug setf)) (let ((p args) (simple t) (vars nil)) (while p (if (or (not (symbolp (car p))) (cl-expr-depends-p (nth 1 p) vars)) @@ -2089,6 +2371,7 @@ before assigning any PLACEs to the corresponding values. "Remove TAG from property list PLACE. PLACE may be a symbol, or any generalized variable allowed by `setf'. The form returns true if TAG was found and removed, nil otherwise." + (declare (debug (place form))) (let* ((method (cl-setf-do-modify place t)) (tag-temp (and (not (cl-const-expr-p tag)) (make-symbol "--cl-remf-tag--"))) (val-temp (and (not (cl-simple-expr-p place)) @@ -2112,6 +2395,7 @@ Example: (shiftf A B C) sets A to B, B to C, and returns the old A. Each PLACE may be a symbol, or any generalized variable allowed by `setf'. \(fn PLACE... VAL)" + (declare (debug (&rest place))) (cond ((null args) place) ((symbolp place) `(prog1 ,place (setq ,place (shiftf ,@args)))) @@ -2128,6 +2412,7 @@ Example: (rotatef A B C) sets A to B, B to C, and C to A. It returns nil. Each PLACE may be a symbol, or any generalized variable allowed by `setf'. \(fn PLACE...)" + (declare (debug (&rest place))) (if (not (memq nil (mapcar 'symbolp args))) (and (cdr args) (let ((sets nil) @@ -2159,6 +2444,7 @@ As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', the PLACE is not modified before executing BODY. \(fn ((PLACE VALUE) ...) BODY...)" + (declare (debug ((&rest (gate place &optional form)) body))) (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings))) (list* 'let bindings body) (let ((lets nil) (sets nil) @@ -2216,6 +2502,7 @@ As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', the PLACE is not modified before executing BODY. \(fn ((PLACE VALUE) ...) BODY...)" + (declare (debug letf)) (if (null bindings) (cons 'progn body) (setq bindings (reverse bindings)) @@ -2230,6 +2517,7 @@ FUNC should be an unquoted function name. PLACE may be a symbol, or any generalized variable allowed by `setf'. \(fn FUNC PLACE ARGS...)" + (declare (debug (function* place &rest form))) (let* ((method (cl-setf-do-modify place (cons 'list args))) (rargs (cons (nth 2 method) args))) (list 'let* (car method) @@ -2244,6 +2532,7 @@ or any generalized variable allowed by `setf'. Like `callf', but PLACE is the second argument of FUNC, not the first. \(fn FUNC ARG1 PLACE ARGS...)" + (declare (debug (function* form place &rest form))) (if (and (cl-safe-expr-p arg1) (cl-simple-expr-p place) (symbolp func)) (list 'setf place (list* func arg1 place args)) (let* ((method (cl-setf-do-modify place (cons 'list args))) @@ -2260,6 +2549,9 @@ Like `callf', but PLACE is the second argument of FUNC, not the first. "Define a `setf'-like modify macro. If NAME is called, it combines its PLACE argument with the other arguments from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)" + (declare (debug + (&define name cl-lambda-list ;; should exclude &key + symbolp &optional stringp))) (if (memq '&key arglist) (error "&key not allowed in define-modify-macro")) (let ((place (make-symbol "--cl-place--"))) (list 'defmacro* name (cons place arglist) doc @@ -2288,6 +2580,25 @@ one keyword is supported, `:read-only'. If this has a non-nil value, that slot cannot be set via `setf'. \(fn NAME SLOTS...)" + (declare (debug + (&define ;Makes top-level form not be wrapped. + [&or symbolp + (gate + symbolp &rest + (&or [":conc-name" symbolp] + [":constructor" symbolp &optional cl-lambda-list] + [":copier" symbolp] + [":predicate" symbolp] + [":include" symbolp &rest sexp] ;; Not finished. + ;; The following are not supported. + ;; [":print-function" ...] + ;; [":type" ...] + ;; [":initial-offset" ...] + ))] + [&optional stringp] + ;; All the above is for the following def-form. + &rest &or symbolp (symbolp def-form + &optional ":read-only" sexp)))) (let* ((name (if (consp struct) (car struct) struct)) (opts (cdr-safe struct)) (slots nil) @@ -2536,6 +2847,7 @@ value, that slot cannot be set via `setf'. (defmacro deftype (name arglist &rest body) "Define NAME as a new data type. The type name can then be used in `typecase', `check-type', etc." + (declare (debug defmacro*)) (list 'eval-when '(compile load eval) (cl-transform-function-property name 'cl-deftype-handler (cons (list* '&cl-defs ''('*) arglist) body)))) @@ -2587,6 +2899,7 @@ TYPE is a Common Lisp-style type specifier." (defmacro check-type (form type &optional string) "Verify that FORM is of type TYPE; signal an error if not. STRING is an optional description of the desired type." + (declare (debug (place cl-type-spec &optional stringp))) (and (or (not (cl-compiling-file)) (< cl-optimize-speed 3) (= cl-optimize-safety 3)) (let* ((temp (if (cl-simple-expr-p form 3) @@ -2605,6 +2918,7 @@ Second arg SHOW-ARGS means to include arguments of FORM in message. Other args STRING and ARGS... are arguments to be passed to `error'. They are not evaluated unless the assertion fails. If STRING is omitted, a default message listing FORM itself is used." + (declare (debug (form &rest form))) (and (or (not (cl-compiling-file)) (< cl-optimize-speed 3) (= cl-optimize-safety 3)) (let ((sargs (and show-args @@ -2635,6 +2949,7 @@ compiler macros are expanded repeatedly until no further expansions are possible. Unlike regular macros, BODY can decide to \"punt\" and leave the original function call alone by declaring an initial `&whole foo' parameter and then returning foo." + (declare (debug defmacro*)) (let ((p args) (res nil)) (while (consp p) (push (pop p) res)) (setq args (nconc (nreverse res) (and p (list '&rest p))))) @@ -2709,6 +3024,7 @@ ARGLIST allows full Common Lisp conventions, and BODY is implicitly surrounded by (block NAME ...). \(fn NAME ARGLIST [DOCSTRING] BODY...)" + (declare (debug defun*)) (let* ((argns (cl-arglist-args args)) (p argns) (pbody (cons 'progn body)) (unsafe (not (cl-safe-expr-p pbody)))) diff --git a/lisp/emacs-lisp/cl-specs.el b/lisp/emacs-lisp/cl-specs.el deleted file mode 100644 index dbadf06944f..00000000000 --- a/lisp/emacs-lisp/cl-specs.el +++ /dev/null @@ -1,471 +0,0 @@ -;;; cl-specs.el --- Edebug specs for cl.el -*- no-byte-compile: t -*- - -;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc. -;; Author: Daniel LaLiberte -;; Keywords: lisp, tools, maint -;; Package: emacs - -;; LCD Archive Entry: -;; cl-specs.el|Daniel LaLiberte|liberte@holonexus.org -;; |Edebug specs for cl.el - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; Commentary: - -;; These specs are to be used with edebug.el version 3.3 or later and -;; cl.el version 2.03 or later, by Dave Gillespie . - -;; This file need not be byte-compiled, but it shouldn't hurt. - -;;; Code: - -(provide 'cl-specs) -;; Do the above provide before the following require. -;; Otherwise if you load this before edebug if cl is already loaded -;; an infinite loading loop would occur. -(require 'edebug) - -;; Blocks - -(def-edebug-spec block (symbolp body)) -(def-edebug-spec return (&optional form)) -(def-edebug-spec return-from (symbolp &optional form)) - -;; Loops - -(def-edebug-spec case (form &rest (sexp body))) -(def-edebug-spec ecase case) -(def-edebug-spec do - ((&rest &or symbolp (symbolp &optional form form)) - (form body) - cl-declarations body)) -(def-edebug-spec do* do) -(def-edebug-spec dolist - ((symbolp form &optional form) cl-declarations body)) -(def-edebug-spec dotimes dolist) -(def-edebug-spec do-symbols - ((symbolp &optional form form) cl-declarations body)) -(def-edebug-spec do-all-symbols - ((symbolp &optional form) cl-declarations body)) - -;; Multiple values - -(def-edebug-spec multiple-value-list (form)) -(def-edebug-spec multiple-value-call (function-form body)) -(def-edebug-spec multiple-value-bind - ((&rest symbolp) form body)) -(def-edebug-spec multiple-value-setq ((&rest symbolp) form)) -(def-edebug-spec multiple-value-prog1 (form body)) - -;; Bindings - -(def-edebug-spec lexical-let let) -(def-edebug-spec lexical-let* let) - -(def-edebug-spec psetq setq) -(def-edebug-spec progv (form form body)) - -(def-edebug-spec flet ((&rest (defun*)) cl-declarations body)) -(def-edebug-spec labels flet) - -(def-edebug-spec macrolet - ((&rest (&define name (&rest arg) cl-declarations-or-string def-body)) - cl-declarations body)) - -(def-edebug-spec symbol-macrolet - ((&rest (symbol sexp)) cl-declarations body)) - -(def-edebug-spec destructuring-bind - (&define cl-macro-list def-form cl-declarations def-body)) - -;; Setf - -(def-edebug-spec setf (&rest [place form])) ;; sexp is not specific enough -(def-edebug-spec psetf setf) - -(def-edebug-spec letf ;; *not* available in Common Lisp - ((&rest (gate place &optional form)) - body)) -(def-edebug-spec letf* letf) - - -(def-edebug-spec defsetf - (&define name - [&or [symbolp &optional stringp] - [cl-lambda-list (symbolp)]] - cl-declarations-or-string def-body)) - -(def-edebug-spec define-setf-method - (&define name cl-lambda-list cl-declarations-or-string def-body)) - -(def-edebug-spec define-modify-macro - (&define name cl-lambda-list ;; should exclude &key - symbolp &optional stringp)) - -(def-edebug-spec callf (function* place &rest form)) -(def-edebug-spec callf2 (function* form place &rest form)) - -;; Other operations on places - -(def-edebug-spec remf (place form)) - -(def-edebug-spec incf (place &optional form)) -(def-edebug-spec decf incf) -(def-edebug-spec push (form place)) ; different for CL -(def-edebug-spec pushnew - (form place &rest - &or [[&or ":test" ":test-not" ":key"] function-form] - [keywordp form])) -(def-edebug-spec pop (place)) ; different for CL - -(def-edebug-spec shiftf (&rest place)) ;; really [&rest place] form -(def-edebug-spec rotatef (&rest place)) - - -;; Functions with function args. These are only useful if the -;; function arg is quoted with ' instead of function. - -(def-edebug-spec some (function-form form &rest form)) -(def-edebug-spec every some) -(def-edebug-spec notany some) -(def-edebug-spec notevery some) - -;; Mapping - -(def-edebug-spec map (form function-form form &rest form)) -(def-edebug-spec maplist (function-form form &rest form)) -(def-edebug-spec mapc maplist) -(def-edebug-spec mapl maplist) -(def-edebug-spec mapcan maplist) -(def-edebug-spec mapcon maplist) - -;; Sequences - -(def-edebug-spec reduce (function-form form &rest form)) - -;; Types and assertions - -(def-edebug-spec cl-type-spec (sexp)) ;; not worth the trouble to specify, yet. - -(def-edebug-spec deftype defmacro*) -(def-edebug-spec check-type (place cl-type-spec &optional stringp)) -;; (def-edebug-spec assert (form &optional form stringp &rest form)) -(def-edebug-spec assert (form &rest form)) -(def-edebug-spec typecase (form &rest ([&or cl-type-spec "otherwise"] body))) -(def-edebug-spec etypecase typecase) - -(def-edebug-spec ignore-errors t) - -;; Time of Evaluation - -(def-edebug-spec eval-when - ((&rest &or "compile" "load" "eval") body)) -(def-edebug-spec load-time-value (form &optional &or "t" "nil")) - -;; Declarations - -(def-edebug-spec cl-decl-spec - ((symbolp &rest sexp))) - -(def-edebug-spec cl-declarations - (&rest ("declare" &rest cl-decl-spec))) - -(def-edebug-spec cl-declarations-or-string - (&or stringp cl-declarations)) - -(def-edebug-spec declaim (&rest cl-decl-spec)) -(def-edebug-spec declare (&rest cl-decl-spec)) ;; probably not needed. -(def-edebug-spec locally (cl-declarations &rest form)) -(def-edebug-spec the (cl-type-spec form)) - -;;====================================================== -;; Lambda things - -(def-edebug-spec cl-lambda-list - (([&rest arg] - [&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]] - [&optional ["&rest" arg]] - [&optional ["&key" [cl-&key-arg &rest cl-&key-arg] - &optional "&allow-other-keys"]] - [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] - ))) - -(def-edebug-spec cl-&optional-arg - (&or (arg &optional def-form arg) arg)) - -(def-edebug-spec cl-&key-arg - (&or ([&or (symbolp arg) arg] &optional def-form arg) arg)) - -;; The lambda list for macros is different from that of normal lambdas. -;; Note that &environment is only allowed as first or last items in the -;; top level list. - -(def-edebug-spec cl-macro-list - (([&optional "&environment" arg] - [&rest cl-macro-arg] - [&optional ["&optional" &rest - &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] - [&optional [[&or "&rest" "&body"] cl-macro-arg]] - [&optional ["&key" [&rest - [&or ([&or (symbolp cl-macro-arg) arg] - &optional def-form cl-macro-arg) - arg]] - &optional "&allow-other-keys"]] - [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] - [&optional "&environment" arg] - ))) - -(def-edebug-spec cl-macro-arg - (&or arg cl-macro-list1)) - -(def-edebug-spec cl-macro-list1 - (([&optional "&whole" arg] ;; only allowed at lower levels - [&rest cl-macro-arg] - [&optional ["&optional" &rest - &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] - [&optional [[&or "&rest" "&body"] cl-macro-arg]] - [&optional ["&key" [&rest - [&or ([&or (symbolp cl-macro-arg) arg] - &optional def-form cl-macro-arg) - arg]] - &optional "&allow-other-keys"]] - [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] - . [&or arg nil]))) - - -(def-edebug-spec defun* - ;; Same as defun but use cl-lambda-list. - (&define [&or name - ("setf" :name setf name)] - cl-lambda-list - cl-declarations-or-string - [&optional ("interactive" interactive)] - def-body)) -(def-edebug-spec defsubst* defun*) - -(def-edebug-spec defmacro* - (&define name cl-macro-list cl-declarations-or-string def-body)) -(def-edebug-spec define-compiler-macro defmacro*) - - -(def-edebug-spec function* - (&or symbolp cl-lambda-expr)) - -(def-edebug-spec cl-lambda-expr - (&define ("lambda" cl-lambda-list - ;;cl-declarations-or-string - ;;[&optional ("interactive" interactive)] - def-body))) - -;; Redefine function-form to also match function* -(def-edebug-spec function-form - ;; form at the end could also handle "function", - ;; but recognize it specially to avoid wrapping function forms. - (&or ([&or "quote" "function"] &or symbolp lambda-expr) - ("function*" function*) - form)) - -;;====================================================== -;; Structures -;; (def-edebug-spec defstruct (&rest sexp)) would be sufficient, but... - -;; defstruct may contain forms that are evaluated when a structure is created. -(def-edebug-spec defstruct - (&define ; makes top-level form not be wrapped - [&or symbolp - (gate - symbolp &rest - (&or [":conc-name" symbolp] - [":constructor" symbolp &optional cl-lambda-list] - [":copier" symbolp] - [":predicate" symbolp] - [":include" symbolp &rest sexp];; not finished - ;; The following are not supported. - ;; [":print-function" ...] - ;; [":type" ...] - ;; [":initial-offset" ...] - ))] - [&optional stringp] - ;; All the above is for the following def-form. - &rest &or symbolp (symbolp def-form &optional ":read-only" sexp))) - -;;====================================================== -;; Loop - -;; The loop macro is very complex, and a full spec is found below. -;; The following spec only minimally specifies that -;; parenthesized forms are executable, but single variables used as -;; expressions will be missed. You may want to use this if the full -;; spec causes problems for you. - -(def-edebug-spec loop - (&rest &or symbolp form)) - -;; Below is a complete spec for loop, in several parts that correspond -;; to the syntax given in CLtL2. The specs do more than specify where -;; the forms are; it also specifies, as much as Edebug allows, all the -;; syntactically valid loop clauses. The disadvantage of this -;; completeness is rigidity, but the "for ... being" clause allows -;; arbitrary extensions of the form: [symbolp &rest &or symbolp form]. - -(def-edebug-spec loop - ([&optional ["named" symbolp]] - [&rest - &or - ["repeat" form] - loop-for-as - loop-with - loop-initial-final] - [&rest loop-clause] - )) - -(def-edebug-spec loop-with - ("with" loop-var - loop-type-spec - [&optional ["=" form]] - &rest ["and" loop-var - loop-type-spec - [&optional ["=" form]]])) - -(def-edebug-spec loop-for-as - ([&or "for" "as"] loop-for-as-subclause - &rest ["and" loop-for-as-subclause])) - -(def-edebug-spec loop-for-as-subclause - (loop-var - loop-type-spec - &or - [[&or "in" "on" "in-ref" "across-ref"] - form &optional ["by" function-form]] - - ["=" form &optional ["then" form]] - ["across" form] - ["being" - [&or "the" "each"] - &or - [[&or "element" "elements"] - [&or "of" "in" "of-ref"] form - &optional "using" ["index" symbolp]];; is this right? - [[&or "hash-key" "hash-keys" - "hash-value" "hash-values"] - [&or "of" "in"] - hash-table-p &optional ["using" ([&or "hash-value" "hash-values" - "hash-key" "hash-keys"] sexp)]] - - [[&or "symbol" "present-symbol" "external-symbol" - "symbols" "present-symbols" "external-symbols"] - [&or "in" "of"] package-p] - - ;; Extensions for Emacs Lisp, including Lucid Emacs. - [[&or "frame" "frames" - "screen" "screens" - "buffer" "buffers"]] - - [[&or "window" "windows"] - [&or "of" "in"] form] - - [[&or "overlay" "overlays" - "extent" "extents"] - [&or "of" "in"] form - &optional [[&or "from" "to"] form]] - - [[&or "interval" "intervals"] - [&or "in" "of"] form - &optional [[&or "from" "to"] form] - ["property" form]] - - [[&or "key-code" "key-codes" - "key-seq" "key-seqs" - "key-binding" "key-bindings"] - [&or "in" "of"] form - &optional ["using" ([&or "key-code" "key-codes" - "key-seq" "key-seqs" - "key-binding" "key-bindings"] - sexp)]] - ;; For arbitrary extensions, recognize anything else. - [symbolp &rest &or symbolp form] - ] - - ;; arithmetic - must be last since all parts are optional. - [[&optional [[&or "from" "downfrom" "upfrom"] form]] - [&optional [[&or "to" "downto" "upto" "below" "above"] form]] - [&optional ["by" form]] - ])) - -(def-edebug-spec loop-initial-final - (&or ["initially" - ;; [&optional &or "do" "doing"] ;; CLtL2 doesn't allow this. - &rest loop-non-atomic-expr] - ["finally" &or - [[&optional &or "do" "doing"] &rest loop-non-atomic-expr] - ["return" form]])) - -(def-edebug-spec loop-and-clause - (loop-clause &rest ["and" loop-clause])) - -(def-edebug-spec loop-clause - (&or - [[&or "while" "until" "always" "never" "thereis"] form] - - [[&or "collect" "collecting" - "append" "appending" - "nconc" "nconcing" - "concat" "vconcat"] form - [&optional ["into" loop-var]]] - - [[&or "count" "counting" - "sum" "summing" - "maximize" "maximizing" - "minimize" "minimizing"] form - [&optional ["into" loop-var]] - loop-type-spec] - - [[&or "if" "when" "unless"] - form loop-and-clause - [&optional ["else" loop-and-clause]] - [&optional "end"]] - - [[&or "do" "doing"] &rest loop-non-atomic-expr] - - ["return" form] - loop-initial-final - )) - -(def-edebug-spec loop-non-atomic-expr - ([¬ atom] form)) - -(def-edebug-spec loop-var - ;; The symbolp must be last alternative to recognize e.g. (a b . c) - ;; loop-var => - ;; (loop-var . [&or nil loop-var]) - ;; (symbolp . [&or nil loop-var]) - ;; (symbolp . loop-var) - ;; (symbolp . (symbolp . [&or nil loop-var])) - ;; (symbolp . (symbolp . loop-var)) - ;; (symbolp . (symbolp . symbolp)) == (symbolp symbolp . symbolp) - (&or (loop-var . [&or nil loop-var]) [gate symbolp])) - -(def-edebug-spec loop-type-spec - (&optional ["of-type" loop-d-type-spec])) - -(def-edebug-spec loop-d-type-spec - (&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec)) - -;;; cl-specs.el ends here diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 2b56e8a9e4b..c5af1d8a4f1 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -120,6 +120,7 @@ a future Emacs interpreter will be able to use it.") "Increment PLACE by X (1 by default). PLACE may be a symbol, or any generalized variable allowed by `setf'. The return value is the incremented value of PLACE." + (declare (debug (place &optional form))) (if (symbolp place) (list 'setq place (if x (list '+ place x) (list '1+ place))) (list 'callf '+ place (or x 1)))) @@ -128,6 +129,7 @@ The return value is the incremented value of PLACE." "Decrement PLACE by X (1 by default). PLACE may be a symbol, or any generalized variable allowed by `setf'. The return value is the decremented value of PLACE." + (declare (debug incf)) (if (symbolp place) (list 'setq place (if x (list '- place x) (list '1- place))) (list 'callf '- place (or x 1)))) @@ -140,6 +142,7 @@ The return value is the decremented value of PLACE." Analogous to (prog1 (car PLACE) (setf PLACE (cdr PLACE))), though more careful about evaluating each argument only once and in the right order. PLACE may be a symbol, or any generalized variable allowed by `setf'." + (declare (debug (place))) (if (symbolp place) (list 'car (list 'prog1 place (list 'setq place (list 'cdr place)))) (cl-do-pop place))) @@ -149,6 +152,7 @@ PLACE may be a symbol, or any generalized variable allowed by `setf'." Analogous to (setf PLACE (cons X PLACE)), though more careful about evaluating each argument only once and in the right order. PLACE may be a symbol, or any generalized variable allowed by `setf'." + (declare (debug (form place))) (if (symbolp place) (list 'setq place (list 'cons x place)) (list 'callf2 'cons x place))) @@ -158,6 +162,10 @@ Like (push X PLACE), except that the list is unmodified if X is `eql' to an element already on the list. \nKeywords supported: :test :test-not :key \n(fn X PLACE [KEYWORD VALUE]...)" + (declare (debug + (form place &rest + &or [[&or ":test" ":test-not" ":key"] function-form] + [keywordp form]))) (if (symbolp place) (if (null keys) `(let ((x ,x)) -- cgit v1.2.3 From b581bb5c8ac2aed4a610097aaaca4a8d354fe9b4 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 17 May 2012 21:46:20 -0400 Subject: * lisp/emacs-lisp/lisp-mode.el (doc-string-elt): Move those properties to their respective macro declarations. * lisp/skeleton.el (define-skeleton): * lisp/progmodes/compile.el (define-compilation-mode): * lisp/ibuf-macs.el (define-ibuffer-sorter, define-ibuffer-op) (define-ibuffer-filter): * lisp/emacs-lisp/generic.el (define-generic-mode): * lisp/emacs-lisp/easy-mmode.el (define-minor-mode) (define-globalized-minor-mode): * lisp/emacs-lisp/cl-macs.el (defun*, defmacro*, defstruct, deftype): * lisp/emacs-lisp/byte-run.el (defsubst): * lisp/custom.el (deftheme): Add doc-string metadata. --- lisp/ChangeLog | 15 ++++++++++ lisp/cedet/mode-local.el | 4 +++ lisp/custom.el | 1 + lisp/emacs-lisp/byte-run.el | 2 +- lisp/emacs-lisp/cl-loaddefs.el | 66 +++++++++++++++++++++++++++++++++++++++++- lisp/emacs-lisp/cl-macs.el | 7 +++-- lisp/emacs-lisp/cl.el | 9 ++++++ lisp/emacs-lisp/easy-mmode.el | 5 ++-- lisp/emacs-lisp/generic.el | 3 +- lisp/emacs-lisp/lisp-mode.el | 20 ------------- lisp/ibuf-macs.el | 6 ++-- lisp/progmodes/compile.el | 3 ++ lisp/skeleton.el | 2 +- 13 files changed, 112 insertions(+), 31 deletions(-) (limited to 'lisp/emacs-lisp/cl-loaddefs.el') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index fcdb2ce65b7..e22b3d07985 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,18 @@ +2012-05-18 Stefan Monnier + + * emacs-lisp/lisp-mode.el (doc-string-elt): Move those properties to + their respective macro declarations. + * skeleton.el (define-skeleton): + * progmodes/compile.el (define-compilation-mode): + * ibuf-macs.el (define-ibuffer-sorter, define-ibuffer-op) + (define-ibuffer-filter): + * emacs-lisp/generic.el (define-generic-mode): + * emacs-lisp/easy-mmode.el (define-minor-mode) + (define-globalized-minor-mode): + * emacs-lisp/cl-macs.el (defun*, defmacro*, defstruct, deftype): + * emacs-lisp/byte-run.el (defsubst): + * custom.el (deftheme): Add doc-string metadata. + 2012-05-17 Stefan Monnier * emacs-lisp/cl-macs.el, emacs-lisp/cl.el: Move indent info. diff --git a/lisp/cedet/mode-local.el b/lisp/cedet/mode-local.el index 7346e88797d..11968f3fa35 100644 --- a/lisp/cedet/mode-local.el +++ b/lisp/cedet/mode-local.el @@ -522,6 +522,9 @@ See also the function `define-overload'." (list (mode-local--override name args body)) result))) +;;;###autoload +(put 'define-overloadable-function 'doc-string-elt 3) + (defmacro define-overloadable-function (name args docstring &rest body) "Define a new function, as with `defun', which can be overloaded. NAME is the name of the function to create. @@ -546,6 +549,7 @@ defined. The default is to call the function `NAME-default' with the appropriate arguments deduced from ARGS. OVERARGS is a list of arguments passed to the override and `NAME-default' function, in place of those deduced from ARGS." + (declare (doc-string 3)) `(eval-and-compile (defun ,name ,args ,docstring diff --git a/lisp/custom.el b/lisp/custom.el index d0eadcc23ff..50481f2aa7f 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -1048,6 +1048,7 @@ The optional argument DOC is a doc string describing the theme. Any theme `foo' should be defined in a file called `foo-theme.el'; see `custom-make-theme-feature' for more information." + (declare (doc-string 2)) (let ((feature (custom-make-theme-feature theme))) ;; It is better not to use backquote in this file, ;; because that makes a bootstrapping problem diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index dc7166bc2ea..7de3396f8ed 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -96,7 +96,7 @@ The return value of this function is not used." ;; This has a special byte-hunk-handler in bytecomp.el. (defmacro defsubst (name arglist &rest body) "Define an inline function. The syntax is just like that of `defun'." - (declare (debug defun)) + (declare (debug defun) (doc-string 3)) (or (memq (get name 'byte-optimizer) '(nil byte-compile-inline-expand)) (error "`%s' is a primitive" name)) diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index d16b98630c8..a9380619e6a 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -286,7 +286,7 @@ This also does some trivial optimizations to make the form prettier. ;;;;;; flet progv psetq do-all-symbols do-symbols dotimes dolist ;;;;;; do* do loop return-from return block etypecase typecase ecase ;;;;;; case load-time-value eval-when destructuring-bind function* -;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "ed94b3ba46080516e6ada69bdf617be5") +;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "c383ef0fa5f6d28796cd8e9cf65e1c5d") ;;; Generated autoloads from cl-macs.el (autoload 'gensym "cl-macs" "\ @@ -308,6 +308,10 @@ and BODY is implicitly surrounded by (block NAME ...). \(fn NAME ARGLIST [DOCSTRING] BODY...)" nil (quote macro)) +(put 'defun* 'lisp-indent-function '2) + +(put 'defun* 'doc-string-elt '3) + (autoload 'defmacro* "cl-macs" "\ Define NAME as a macro. Like normal `defmacro', except ARGLIST allows full Common Lisp conventions, @@ -315,6 +319,10 @@ and BODY is implicitly surrounded by (block NAME ...). \(fn NAME ARGLIST [DOCSTRING] BODY...)" nil (quote macro)) +(put 'defmacro* 'lisp-indent-function '2) + +(put 'defmacro* 'doc-string-elt '3) + (autoload 'function* "cl-macs" "\ Introduce a function. Like normal `function', except that if argument is a lambda form, @@ -327,6 +335,8 @@ its argument list allows full Common Lisp conventions. \(fn ARGS EXPR &rest BODY)" nil (quote macro)) +(put 'destructuring-bind 'lisp-indent-function '2) + (autoload 'eval-when "cl-macs" "\ Control when BODY is evaluated. If `compile' is in WHEN, BODY is evaluated when compiled at top-level. @@ -335,6 +345,8 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level. \(fn (WHEN...) BODY...)" nil (quote macro)) +(put 'eval-when 'lisp-indent-function '1) + (autoload 'load-time-value "cl-macs" "\ Like `progn', but evaluates the body at load time. The result of the body appears to the compiler as a quoted constant. @@ -352,12 +364,16 @@ Key values are compared by `eql'. \(fn EXPR (KEYLIST BODY...)...)" nil (quote macro)) +(put 'case 'lisp-indent-function '1) + (autoload 'ecase "cl-macs" "\ Like `case', but error if no case fits. `otherwise'-clauses are not allowed. \(fn EXPR (KEYLIST BODY...)...)" nil (quote macro)) +(put 'ecase 'lisp-indent-function '1) + (autoload 'typecase "cl-macs" "\ Evals EXPR, chooses among clauses on that value. Each clause looks like (TYPE BODY...). EXPR is evaluated and, if it @@ -367,12 +383,16 @@ final clause, and matches if no other keys match. \(fn EXPR (TYPE BODY...)...)" nil (quote macro)) +(put 'typecase 'lisp-indent-function '1) + (autoload 'etypecase "cl-macs" "\ Like `typecase', but error if no case fits. `otherwise'-clauses are not allowed. \(fn EXPR (TYPE BODY...)...)" nil (quote macro)) +(put 'etypecase 'lisp-indent-function '1) + (autoload 'block "cl-macs" "\ Define a lexically-scoped block named NAME. NAME may be any symbol. Code inside the BODY forms can call `return-from' @@ -385,6 +405,8 @@ called from BODY. \(fn NAME &rest BODY)" nil (quote macro)) +(put 'block 'lisp-indent-function '1) + (autoload 'return "cl-macs" "\ Return from the block named nil. This is equivalent to `(return-from nil RESULT)'. @@ -400,6 +422,8 @@ This is compatible with Common Lisp, but note that `defun' and \(fn NAME &optional RESULT)" nil (quote macro)) +(put 'return-from 'lisp-indent-function '1) + (autoload 'loop "cl-macs" "\ The Common Lisp `loop' macro. Valid clauses are: @@ -421,11 +445,15 @@ The Common Lisp `do' loop. \(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" nil (quote macro)) +(put 'do 'lisp-indent-function '2) + (autoload 'do* "cl-macs" "\ The Common Lisp `do*' loop. \(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" nil (quote macro)) +(put 'do* 'lisp-indent-function '2) + (autoload 'dolist "cl-macs" "\ Loop over a list. Evaluate BODY with VAR bound to each `car' from LIST, in turn. @@ -449,11 +477,15 @@ from OBARRAY. \(fn (VAR [OBARRAY [RESULT]]) BODY...)" nil (quote macro)) +(put 'do-symbols 'lisp-indent-function '1) + (autoload 'do-all-symbols "cl-macs" "\ \(fn SPEC &rest BODY)" nil (quote macro)) +(put 'do-all-symbols 'lisp-indent-function '1) + (autoload 'psetq "cl-macs" "\ Set SYMs to the values VALs in parallel. This is like `setq', except that all VAL forms are evaluated (in order) @@ -471,6 +503,8 @@ a `let' form, except that the list of symbols can be computed at run-time. \(fn SYMBOLS VALUES &rest BODY)" nil (quote macro)) +(put 'progv 'lisp-indent-function '2) + (autoload 'flet "cl-macs" "\ Make temporary function definitions. This is an analogue of `let' that operates on the function cell of FUNC @@ -480,6 +514,8 @@ go back to their previous definitions, or lack thereof). \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" nil (quote macro)) +(put 'flet 'lisp-indent-function '1) + (autoload 'labels "cl-macs" "\ Make temporary function bindings. This is like `flet', except the bindings are lexical instead of dynamic. @@ -487,12 +523,16 @@ Unlike `flet', this macro is fully compliant with the Common Lisp standard. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" nil (quote macro)) +(put 'labels 'lisp-indent-function '1) + (autoload 'macrolet "cl-macs" "\ Make temporary macro definitions. This is like `flet', but for macros instead of functions. \(fn ((NAME ARGLIST BODY...) ...) FORM...)" nil (quote macro)) +(put 'macrolet 'lisp-indent-function '1) + (autoload 'symbol-macrolet "cl-macs" "\ Make symbol macro definitions. Within the body FORMs, references to the variable NAME will be replaced @@ -500,6 +540,8 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). \(fn ((NAME EXPANSION) ...) FORM...)" nil (quote macro)) +(put 'symbol-macrolet 'lisp-indent-function '1) + (autoload 'lexical-let "cl-macs" "\ Like `let', but lexically scoped. The main visible difference is that lambdas inside BODY will create @@ -507,6 +549,8 @@ lexical closures as in Common Lisp. \(fn BINDINGS BODY)" nil (quote macro)) +(put 'lexical-let 'lisp-indent-function '1) + (autoload 'lexical-let* "cl-macs" "\ Like `let*', but lexically scoped. The main visible difference is that lambdas inside BODY, and in @@ -516,6 +560,8 @@ Common Lisp. \(fn BINDINGS BODY)" nil (quote macro)) +(put 'lexical-let* 'lisp-indent-function '1) + (autoload 'multiple-value-bind "cl-macs" "\ Collect multiple return values. FORM must return a list; the BODY is then executed with the first N elements @@ -526,6 +572,8 @@ a synonym for (list A B C). \(fn (SYM...) FORM BODY)" nil (quote macro)) +(put 'multiple-value-bind 'lisp-indent-function '2) + (autoload 'multiple-value-setq "cl-macs" "\ Collect multiple return values. FORM must return a list; the first N elements of this list are stored in @@ -535,6 +583,8 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). \(fn (SYM...) FORM)" nil (quote macro)) +(put 'multiple-value-setq 'lisp-indent-function '1) + (autoload 'locally "cl-macs" "\ @@ -545,6 +595,8 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). \(fn TYPE FORM)" nil (quote macro)) +(put 'the 'lisp-indent-function '1) + (autoload 'declare "cl-macs" "\ Declare SPECS about the current function while compiling. For instance @@ -649,6 +701,8 @@ the PLACE is not modified before executing BODY. \(fn ((PLACE VALUE) ...) BODY...)" nil (quote macro)) +(put 'letf 'lisp-indent-function '1) + (autoload 'letf* "cl-macs" "\ Temporarily bind to PLACEs. This is the analogue of `let*', but with generalized variables (in the @@ -661,6 +715,8 @@ the PLACE is not modified before executing BODY. \(fn ((PLACE VALUE) ...) BODY...)" nil (quote macro)) +(put 'letf* 'lisp-indent-function '1) + (autoload 'callf "cl-macs" "\ Set PLACE to (FUNC PLACE ARGS...). FUNC should be an unquoted function name. PLACE may be a symbol, @@ -668,12 +724,16 @@ or any generalized variable allowed by `setf'. \(fn FUNC PLACE ARGS...)" nil (quote macro)) +(put 'callf 'lisp-indent-function '2) + (autoload 'callf2 "cl-macs" "\ Set PLACE to (FUNC ARG1 PLACE ARGS...). Like `callf', but PLACE is the second argument of FUNC, not the first. \(fn FUNC ARG1 PLACE ARGS...)" nil (quote macro)) +(put 'callf2 'lisp-indent-function '3) + (autoload 'define-modify-macro "cl-macs" "\ Define a `setf'-like modify macro. If NAME is called, it combines its PLACE argument with the other arguments @@ -699,6 +759,8 @@ value, that slot cannot be set via `setf'. \(fn NAME SLOTS...)" nil (quote macro)) +(put 'defstruct 'doc-string-elt '2) + (autoload 'cl-struct-setf-expander "cl-macs" "\ @@ -710,6 +772,8 @@ The type name can then be used in `typecase', `check-type', etc. \(fn NAME ARGLIST &rest BODY)" nil (quote macro)) +(put 'deftype 'doc-string-elt '3) + (autoload 'typep "cl-macs" "\ Check that OBJECT is of type TYPE. TYPE is a Common Lisp-style type specifier. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 441ae55758c..c547a4f6460 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -227,6 +227,7 @@ and BODY is implicitly surrounded by (block NAME ...). cl-declarations-or-string [&optional ("interactive" interactive)] def-body)) + (doc-string 3) (indent 2)) (let* ((res (cl-transform-lambda (cons args body) name)) (form (list* 'defun name (cdr res)))) @@ -279,6 +280,7 @@ and BODY is implicitly surrounded by (block NAME ...). \(fn NAME ARGLIST [DOCSTRING] BODY...)" (declare (debug (&define name cl-macro-list cl-declarations-or-string def-body)) + (doc-string 3) (indent 2)) (let* ((res (cl-transform-lambda (cons args body) name)) (form (list* 'defmacro name (cdr res)))) @@ -2587,7 +2589,8 @@ one keyword is supported, `:read-only'. If this has a non-nil value, that slot cannot be set via `setf'. \(fn NAME SLOTS...)" - (declare (debug + (declare (doc-string 2) + (debug (&define ;Makes top-level form not be wrapped. [&or symbolp (gate @@ -2854,7 +2857,7 @@ value, that slot cannot be set via `setf'. (defmacro deftype (name arglist &rest body) "Define NAME as a new data type. The type name can then be used in `typecase', `check-type', etc." - (declare (debug defmacro*)) + (declare (debug defmacro*) (doc-string 3)) (list 'eval-when '(compile load eval) (cl-transform-function-property name 'cl-deftype-handler (cons (list* '&cl-defs ''('*) arglist) body)))) diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 7c486e17dcf..137dd1bfb84 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -656,6 +656,15 @@ If ALIST is non-nil, the new pairs are prepended to it." (fmakunbound 'dolist) (fmakunbound 'dotimes) (fmakunbound 'declare) +;;;###autoload +(progn + ;; Autoload, so autoload.el and font-lock can use it even when CL + ;; is not loaded. + (put 'defun* 'doc-string-elt 3) + (put 'defmacro* 'doc-string-elt 3) + (put 'defsubst 'doc-string-elt 3) + (put 'defstruct 'doc-string-elt 2)) + (load "cl-loaddefs" nil 'quiet) ;; This goes here so that cl-macs can find it if it loads right now. diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 301947f0735..a11f213e646 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -142,7 +142,8 @@ For example, you could write (define-minor-mode foo-mode \"If enabled, foo on you!\" :lighter \" Foo\" :require 'foo :global t :group 'hassle :version \"27.5\" ...BODY CODE...)" - (declare (debug (&define name stringp + (declare (doc-string 2) + (debug (&define name stringp [&optional [¬ keywordp] sexp &optional [¬ keywordp] sexp &optional [¬ keywordp] sexp] @@ -335,7 +336,7 @@ enabled, then disabling and reenabling MODE should make MODE work correctly with the current major mode. This is important to prevent problems with derived modes, that is, major modes that call another major mode in their body." - + (declare (doc-string 2)) (let* ((global-mode-name (symbol-name global-mode)) (pretty-name (easy-mmode-pretty-mode-name mode)) (pretty-global-name (easy-mmode-pretty-mode-name global-mode)) diff --git a/lisp/emacs-lisp/generic.el b/lisp/emacs-lisp/generic.el index b9db092fafc..80b6122822e 100644 --- a/lisp/emacs-lisp/generic.el +++ b/lisp/emacs-lisp/generic.el @@ -151,7 +151,8 @@ mode hook `MODE-hook'. See the file generic-x.el for some examples of `define-generic-mode'." (declare (debug (sexp def-form def-form def-form form def-form [&optional stringp] &rest [keywordp form])) - (indent 1)) + (indent 1) + (doc-string 7)) ;; Backward compatibility. (when (eq (car-safe mode) 'quote) diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 95eb8c963be..dfdac92ae32 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -136,34 +136,14 @@ It has `lisp-mode-abbrev-table' as its parent." ;; This was originally in autoload.el and is still used there. (put 'autoload 'doc-string-elt 3) (put 'defun 'doc-string-elt 3) -(put 'defun* 'doc-string-elt 3) (put 'defmethod 'doc-string-elt 3) (put 'defvar 'doc-string-elt 3) -(put 'defcustom 'doc-string-elt 3) -(put 'deftheme 'doc-string-elt 2) -(put 'deftype 'doc-string-elt 3) (put 'defconst 'doc-string-elt 3) (put 'defmacro 'doc-string-elt 3) -(put 'defmacro* 'doc-string-elt 3) -(put 'defsubst 'doc-string-elt 3) -(put 'defstruct 'doc-string-elt 2) -(put 'define-skeleton 'doc-string-elt 2) -(put 'define-derived-mode 'doc-string-elt 4) -(put 'define-compilation-mode 'doc-string-elt 3) -(put 'easy-mmode-define-minor-mode 'doc-string-elt 2) -(put 'define-minor-mode 'doc-string-elt 2) -(put 'easy-mmode-define-global-mode 'doc-string-elt 2) -(put 'define-global-minor-mode 'doc-string-elt 2) -(put 'define-globalized-minor-mode 'doc-string-elt 2) -(put 'define-generic-mode 'doc-string-elt 7) -(put 'define-ibuffer-filter 'doc-string-elt 2) -(put 'define-ibuffer-op 'doc-string-elt 3) -(put 'define-ibuffer-sorter 'doc-string-elt 2) (put 'lambda 'doc-string-elt 2) (put 'defalias 'doc-string-elt 3) (put 'defvaralias 'doc-string-elt 3) (put 'define-category 'doc-string-elt 2) -(put 'define-overloadable-function 'doc-string-elt 3) (defvar lisp-doc-string-elt-property 'doc-string-elt "The symbol property that holds the docstring position info.") diff --git a/lisp/ibuf-macs.el b/lisp/ibuf-macs.el index f47592e82bb..659b8e7d78c 100644 --- a/lisp/ibuf-macs.el +++ b/lisp/ibuf-macs.el @@ -143,7 +143,7 @@ buffer object, and `b' bound to another. BODY should return a non-nil value if and only if `a' is \"less than\" `b'. \(fn NAME DOCUMENTATION (&key DESCRIPTION) &rest BODY)" - (declare (indent 1)) + (declare (indent 1) (doc-string 2)) `(progn (defun ,(intern (concat "ibuffer-do-sort-by-" (symbol-name name))) () ,(or documentation "No :documentation specified for this sorting method.") @@ -202,7 +202,7 @@ COMPLEX means this function is special; see the source code of this macro for exactly what it does. \(fn OP ARGS DOCUMENTATION (&key INTERACTIVE MARK MODIFIER-P DANGEROUS OPSTRING ACTIVE-OPSTRING COMPLEX) &rest BODY)" - (declare (indent 2)) + (declare (indent 2) (doc-string 3)) `(progn (defun ,(intern (concat (if (string-match "^ibuffer-do" (symbol-name op)) "" "ibuffer-do-") (symbol-name op))) @@ -280,7 +280,7 @@ will be evaluated with BUF bound to the buffer object, and QUALIFIER bound to the current value of the filter. \(fn NAME DOCUMENTATION (&key READER DESCRIPTION) &rest BODY)" - (declare (indent 2)) + (declare (indent 2) (doc-string 2)) (let ((fn-name (intern (concat "ibuffer-filter-by-" (symbol-name name))))) `(progn (defun ,fn-name (qualifier) diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 7ffaddb2c49..fe1b63f3048 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -1884,6 +1884,9 @@ Runs `compilation-mode-hook' with `run-mode-hooks' (which see). (setq buffer-read-only t) (run-mode-hooks 'compilation-mode-hook)) +;;;###autoload +(put 'define-compilation-mode 'doc-string-elt 3) + (defmacro define-compilation-mode (mode name doc &rest body) "This is like `define-derived-mode' without the PARENT argument. The parent is always `compilation-mode' and the customizable `compilation-...' diff --git a/lisp/skeleton.el b/lisp/skeleton.el index 328f795ecd2..34d69a74369 100644 --- a/lisp/skeleton.el +++ b/lisp/skeleton.el @@ -121,7 +121,7 @@ are integer buffer positions in the reverse order of the insertion order.") "Define a user-configurable COMMAND that enters a statement skeleton. DOCUMENTATION is that of the command. SKELETON is as defined under `skeleton-insert'." - (declare (debug (&define name stringp skeleton-edebug-spec))) + (declare (doc-string 2) (debug (&define name stringp skeleton-edebug-spec))) (if skeleton-debug (set command skeleton)) `(progn -- cgit v1.2.3