From ed99f8ff2e73e6c7395f9cb6e567f9141dd05fe4 Mon Sep 17 00:00:00 2001 From: Glenn Morris Date: Fri, 20 Apr 2012 20:32:15 -0400 Subject: Comment fix --- lisp/emacs-lisp/check-declare.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el index 3135b9b5827..d4213899ef6 100644 --- a/lisp/emacs-lisp/check-declare.el +++ b/lisp/emacs-lisp/check-declare.el @@ -1,6 +1,6 @@ ;;; check-declare.el --- Check declare-function statements -;; Copyright (C) 2007-2012 Free Software Foundation, Inc. +;; Copyright (C) 2007-2012 Free Software Foundation, Inc. ;; Author: Glenn Morris ;; Keywords: lisp, tools, maint @@ -28,7 +28,7 @@ ;; checks that all such statements in a file or directory are accurate. ;; The entry points are `check-declare-file' and `check-declare-directory'. -;; For more information, see Info node `elisp(Declaring Functions)'. +;; For more information, see Info node `(elisp)Declaring Functions'. ;;; TODO: -- 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') 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 e95a67dc75c3d41c428d6e215426f321b5a2f9e5 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 26 Apr 2012 08:43:28 -0400 Subject: Replace lexical-let by lexical-binding (except Gnus, CEDET, ERT). * lisp/term/ns-win.el (ns-define-service): * lisp/progmodes/pascal.el (pascal-goto-defun): * lisp/progmodes/js.el (js--read-tab): * lisp/progmodes/etags.el (tags-lazy-completion-table): * lisp/emacs-lisp/syntax.el (syntax-propertize-via-font-lock): * lisp/emacs-lisp/ewoc.el (ewoc--wrap): * lisp/emacs-lisp/assoc.el (aput, adelete, amake): * lisp/doc-view.el (doc-view-convert-current-doc): * lisp/url/url.el (url-retrieve-synchronously): * lisp/vc/diff.el (diff-no-select): Replace lexical-let by lexical-binding. --- lisp/ChangeLog | 13 ++++++++++++ lisp/dired.el | 50 +++++++++++++++++++++++------------------------ lisp/doc-view.el | 13 ++++++------ lisp/emacs-lisp/assoc.el | 18 ++++++++--------- lisp/emacs-lisp/ewoc.el | 9 ++++----- lisp/emacs-lisp/syntax.el | 15 +++++++------- lisp/mpc.el | 2 +- lisp/progmodes/etags.el | 4 ++-- lisp/progmodes/js.el | 14 ++++--------- lisp/progmodes/pascal.el | 8 ++++---- lisp/term/ns-win.el | 37 +++++++++++++++++------------------ lisp/url/ChangeLog | 13 ++++++++---- lisp/url/url.el | 6 +++--- lisp/vc/diff.el | 20 ++++++++----------- 14 files changed, 113 insertions(+), 109 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index ad6fd35bc5d..a02521ca147 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,16 @@ +2012-04-26 Stefan Monnier + + + * term/ns-win.el (ns-define-service): + * progmodes/pascal.el (pascal-goto-defun): + * progmodes/js.el (js--read-tab): + * progmodes/etags.el (tags-lazy-completion-table): + * emacs-lisp/syntax.el (syntax-propertize-via-font-lock): + * emacs-lisp/ewoc.el (ewoc--wrap): + * emacs-lisp/assoc.el (aput, adelete, amake): + * doc-view.el (doc-view-convert-current-doc): + * vc/diff.el (diff-no-select): Replace lexical-let by lexical-binding. + 2012-04-26 Chong Yidong * image.el (image-type-from-buffer): Only return supported image diff --git a/lisp/dired.el b/lisp/dired.el index 77fe9cb7614..f6f7d71c636 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -670,31 +670,31 @@ Don't use that together with FILTER." ;; (dolist (ext completion-ignored-extensions) ;; (if (eq ?/ (aref ext (1- (length ext)))) (push ext cie))) ;; (setq cie (concat (regexp-opt cie "\\(?:") "\\'")) -;; (lexical-let* ((default (and buffer-file-name -;; (abbreviate-file-name buffer-file-name))) -;; (cie cie) -;; (completion-table -;; ;; We need a mix of read-file-name and -;; ;; read-directory-name so that completion to directories -;; ;; is preferred, but if the user wants to enter a global -;; ;; pattern, he can still use completion on filenames to -;; ;; help him write the pattern. -;; ;; Essentially, we want to use -;; ;; (completion-table-with-predicate -;; ;; 'read-file-name-internal 'file-directory-p nil) -;; ;; but that doesn't work because read-file-name-internal -;; ;; does not obey its `predicate' argument. -;; (completion-table-in-turn -;; (lambda (str pred action) -;; (let ((read-file-name-predicate -;; (lambda (f) -;; (and (not (member f '("./" "../"))) -;; ;; Hack! Faster than file-directory-p! -;; (eq (aref f (1- (length f))) ?/) -;; (not (string-match cie f)))))) -;; (complete-with-action -;; action 'read-file-name-internal str nil))) -;; 'read-file-name-internal))) +;; (let* ((default (and buffer-file-name +;; (abbreviate-file-name buffer-file-name))) +;; (cie cie) +;; (completion-table +;; ;; We need a mix of read-file-name and +;; ;; read-directory-name so that completion to directories +;; ;; is preferred, but if the user wants to enter a global +;; ;; pattern, he can still use completion on filenames to +;; ;; help him write the pattern. +;; ;; Essentially, we want to use +;; ;; (completion-table-with-predicate +;; ;; 'read-file-name-internal 'file-directory-p nil) +;; ;; but that doesn't work because read-file-name-internal +;; ;; does not obey its `predicate' argument. +;; (completion-table-in-turn +;; (lambda (str pred action) +;; (let ((read-file-name-predicate +;; (lambda (f) +;; (and (not (member f '("./" "../"))) +;; ;; Hack! Faster than file-directory-p! +;; (eq (aref f (1- (length f))) ?/) +;; (not (string-match cie f)))))) +;; (complete-with-action +;; action 'read-file-name-internal str nil))) +;; 'read-file-name-internal))) ;; (minibuffer-with-setup-hook ;; (lambda () ;; (setq minibuffer-default default) diff --git a/lisp/doc-view.el b/lisp/doc-view.el index 53e7811bad1..78b6610ff3c 100644 --- a/lisp/doc-view.el +++ b/lisp/doc-view.el @@ -960,13 +960,12 @@ Those files are saved in the directory given by the function (odf ;; ODF files have to be converted to PDF before Ghostscript can ;; process it. - (lexical-let - ((pdf (expand-file-name "doc.pdf" doc-view-current-cache-dir)) - (opdf (expand-file-name (concat (file-name-sans-extension - (file-name-nondirectory doc-view-buffer-file-name)) - ".pdf") - doc-view-current-cache-dir)) - (png-file png-file)) + (let ((pdf (expand-file-name "doc.pdf" doc-view-current-cache-dir)) + (opdf (expand-file-name (concat (file-name-sans-extension + (file-name-nondirectory doc-view-buffer-file-name)) + ".pdf") + doc-view-current-cache-dir)) + (png-file png-file)) ;; The unoconv tool only supports a output directory, but no ;; file name. It's named like the input file with the ;; extension replaced by pdf. diff --git a/lisp/emacs-lisp/assoc.el b/lisp/emacs-lisp/assoc.el index 264374ed721..d3185c444d7 100644 --- a/lisp/emacs-lisp/assoc.el +++ b/lisp/emacs-lisp/assoc.el @@ -1,4 +1,4 @@ -;;; assoc.el --- insert/delete functions on association lists +;;; assoc.el --- insert/delete functions on association lists -*- lexical-binding: t -*- ;; Copyright (C) 1996, 2001-2012 Free Software Foundation, Inc. @@ -36,7 +36,7 @@ the order of any other key-value pair. Side effect sets alist to new sorted list." (set alist-symbol (sort (copy-alist (symbol-value alist-symbol)) - (function (lambda (a b) (equal (car a) key)))))) + (lambda (a _b) (equal (car a) key))))) (defun aelement (key value) @@ -71,8 +71,8 @@ If VALUE is not supplied, or is nil, the key-value pair will not be modified, but will be moved to the head of the alist. If the key-value pair cannot be found in the alist, it will be inserted into the head of the alist (with value nil if VALUE is nil or not supplied)." - (lexical-let ((elem (aelement key value)) - alist) + (let ((elem (aelement key value)) + alist) (asort alist-symbol key) (setq alist (symbol-value alist-symbol)) (cond ((null alist) (set alist-symbol elem)) @@ -86,7 +86,7 @@ of the alist (with value nil if VALUE is nil or not supplied)." Alist is referenced by ALIST-SYMBOL and the key-value pair to remove is pair matching KEY. Returns the altered alist." (asort alist-symbol key) - (lexical-let ((alist (symbol-value alist-symbol))) + (let ((alist (symbol-value alist-symbol))) (cond ((null alist) nil) ((anot-head-p alist key) alist) (t (set alist-symbol (cdr alist)))))) @@ -123,10 +123,10 @@ KEYLIST and VALUELIST should have the same number of elements, but this isn't enforced. If VALUELIST is smaller than KEYLIST, remaining keys are associated with nil. If VALUELIST is larger than KEYLIST, extra values are ignored. Returns the created alist." - (lexical-let ((keycar (car keylist)) - (keycdr (cdr keylist)) - (valcar (car valuelist)) - (valcdr (cdr valuelist))) + (let ((keycar (car keylist)) + (keycdr (cdr keylist)) + (valcar (car valuelist)) + (valcdr (cdr valuelist))) (cond ((null keycdr) (aput alist-symbol keycar valcar)) (t diff --git a/lisp/emacs-lisp/ewoc.el b/lisp/emacs-lisp/ewoc.el index 4fd87209b38..9e214a9703c 100644 --- a/lisp/emacs-lisp/ewoc.el +++ b/lisp/emacs-lisp/ewoc.el @@ -1,4 +1,4 @@ -;;; ewoc.el --- utility to maintain a view of a list of objects in a buffer +;;; ewoc.el --- utility to maintain a view of a list of objects in a buffer -*- lexical-binding: t -*- ;; Copyright (C) 1991-2012 Free Software Foundation, Inc. @@ -216,10 +216,9 @@ NODE and leaving the new node's start there. Return the new node." (ewoc--adjust m (point) R dll))) (defun ewoc--wrap (func) - (lexical-let ((ewoc--user-pp func)) - (lambda (data) - (funcall ewoc--user-pp data) - (insert "\n")))) + (lambda (data) + (funcall func data) + (insert "\n"))) ;;; =========================================================================== diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el index 611a766922a..583d0b151c9 100644 --- a/lisp/emacs-lisp/syntax.el +++ b/lisp/emacs-lisp/syntax.el @@ -1,4 +1,4 @@ -;;; syntax.el --- helper functions to find syntactic context +;;; syntax.el --- helper functions to find syntactic context -*- lexical-binding: t -*- ;; Copyright (C) 2000-2012 Free Software Foundation, Inc. @@ -274,13 +274,12 @@ Note: back-references in REGEXPs do not work." "Propertize for syntax in START..END using font-lock syntax. KEYWORDS obeys the format used in `font-lock-syntactic-keywords'. The return value is a function suitable for `syntax-propertize-function'." - (lexical-let ((keywords keywords)) - (lambda (start end) - (with-no-warnings - (let ((font-lock-syntactic-keywords keywords)) - (font-lock-fontify-syntactic-keywords-region start end) - ;; In case it was eval'd/compiled. - (setq keywords font-lock-syntactic-keywords)))))) + (lambda (start end) + (with-no-warnings + (let ((font-lock-syntactic-keywords keywords)) + (font-lock-fontify-syntactic-keywords-region start end) + ;; In case it was eval'd/compiled. + (setq keywords font-lock-syntactic-keywords))))) (defun syntax-propertize (pos) "Ensure that syntax-table properties are set until POS." diff --git a/lisp/mpc.el b/lisp/mpc.el index ea7f6793309..a908e4bedac 100644 --- a/lisp/mpc.el +++ b/lisp/mpc.el @@ -406,7 +406,7 @@ which will be concatenated with proper quoting before passing them to MPD." (funcall callback (prog1 (mpc-proc-buf-to-alist (current-buffer)) (set-buffer buf)))))) - ;; (lexical-let ((res nil)) + ;; (let ((res nil)) ;; (mpc-proc-cmd-to-alist cmd (lambda (alist) (setq res alist))) ;; (mpc-proc-sync) ;; res) diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index d8a561340d3..638410ae627 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -1,4 +1,4 @@ -;;; etags.el --- etags facility for Emacs +;;; etags.el --- etags facility for Emacs -*- lexical-binding: t -*- ;; Copyright (C) 1985-1986, 1988-1989, 1992-1996, 1998, 2000-2012 ;; Free Software Foundation, Inc. @@ -781,7 +781,7 @@ tags table and its (recursively) included tags tables." (setq tags-completion-table nil))))) (defun tags-lazy-completion-table () - (lexical-let ((buf (current-buffer))) + (let ((buf (current-buffer))) (lambda (string pred action) (with-current-buffer buf (save-excursion diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el index 69da6737520..1c8a1f45e57 100644 --- a/lisp/progmodes/js.el +++ b/lisp/progmodes/js.el @@ -1,4 +1,4 @@ -;;; js.el --- Major mode for editing JavaScript +;;; js.el --- Major mode for editing JavaScript -*- lexical-binding: t -*- ;; Copyright (C) 2008-2012 Free Software Foundation, Inc. @@ -1036,17 +1036,12 @@ LIMIT defaults to point." (c-save-buffer-state (open-items - orig-match-start - orig-match-end - orig-depth parse prev-parse-point name case-fold-search filtered-class-styles - new-item - goal-point - end-prop) + goal-point) ;; Figure out which class styles we need to look for (setq filtered-class-styles @@ -2956,8 +2951,8 @@ browser, respectively." (ido-mode -1)) (with-js - (lexical-let ((tabs (js--get-tabs)) selected-tab-cname - selected-tab prev-hitab) + (let ((tabs (js--get-tabs)) selected-tab-cname + selected-tab prev-hitab) ;; Disambiguate names (setq tabs (loop with tab-names = (make-hash-table :test 'equal) @@ -3053,7 +3048,6 @@ browser, respectively." "gBrowser" "selectedTab") - with index = 0 for match in ido-matches for candidate-tab = (find-tab-by-cname match) if (eq (fourth candidate-tab) tab-to-match) diff --git a/lisp/progmodes/pascal.el b/lisp/progmodes/pascal.el index 8f7f313753c..5a6f4e20fbc 100644 --- a/lisp/progmodes/pascal.el +++ b/lisp/progmodes/pascal.el @@ -1353,21 +1353,21 @@ The default is a name found in the buffer around point." (default (if (pascal-comp-defun default nil 'lambda) default "")) (label - ;; Do completion with default + ;; Do completion with default. (completing-read (if (not (string= default "")) (concat "Label (default " default "): ") "Label: ") ;; Complete with the defuns found in the ;; current-buffer. - (lexical-let ((buf (current-buffer))) + (let ((buf (current-buffer))) (lambda (s p a) (with-current-buffer buf (pascal-comp-defun s p a)))) nil t ""))) - ;; If there was no response on prompt, use default value + ;; If there was no response on prompt, use default value. (if (string= label "") (setq label default)) - ;; Goto right place in buffer if label is not an empty string + ;; Goto right place in buffer if label is not an empty string. (or (string= label "") (progn (goto-char (point-min)) diff --git a/lisp/term/ns-win.el b/lisp/term/ns-win.el index b681ec3440f..feac0f1c537 100644 --- a/lisp/term/ns-win.el +++ b/lisp/term/ns-win.el @@ -1,4 +1,4 @@ -;;; ns-win.el --- lisp side of interface with NeXT/Open/GNUstep/MacOS X window system +;;; ns-win.el --- lisp side of interface with NeXT/Open/GNUstep/MacOS X window system -*- lexical-binding: t -*- ;; Copyright (C) 1993-1994, 2005-2012 Free Software Foundation, Inc. @@ -44,7 +44,7 @@ (error "%s: Loading ns-win.el but not compiled for GNUstep/MacOS" (invocation-name))) -(eval-when-compile (require 'cl)) ; lexical-let +(eval-when-compile (require 'cl)) ;; Documentation-purposes only: actually loaded in loadup.el. (require 'frame) @@ -65,7 +65,7 @@ ;; nsterm.m. (defvar ns-input-file) -(defun ns-handle-nxopen (switch &optional temp) +(defun ns-handle-nxopen (_switch &optional temp) (setq unread-command-events (append unread-command-events (if temp '(ns-open-temp-file) '(ns-open-file))) @@ -74,7 +74,7 @@ (defun ns-handle-nxopentemp (switch) (ns-handle-nxopen switch t)) -(defun ns-ignore-1-arg (switch) +(defun ns-ignore-1-arg (_switch) (setq x-invocation-args (cdr x-invocation-args))) (defun ns-parse-geometry (geom) @@ -201,21 +201,20 @@ The properties returned may include `top', `left', `height', and `width'." (mapconcat 'identity (cons "ns-service" path) "-"))))) ;; This defines the function. (defalias name - (lexical-let ((service service)) - (lambda (arg) - (interactive "p") - (let* ((in-string - (cond ((stringp arg) arg) - (mark-active - (buffer-substring (region-beginning) (region-end))))) - (out-string (ns-perform-service service in-string))) - (cond - ((stringp arg) out-string) - ((and out-string (or (not in-string) - (not (string= in-string out-string)))) - (if mark-active (delete-region (region-beginning) (region-end))) - (insert out-string) - (setq deactivate-mark nil))))))) + (lambda (arg) + (interactive "p") + (let* ((in-string + (cond ((stringp arg) arg) + (mark-active + (buffer-substring (region-beginning) (region-end))))) + (out-string (ns-perform-service service in-string))) + (cond + ((stringp arg) out-string) + ((and out-string (or (not in-string) + (not (string= in-string out-string)))) + (if mark-active (delete-region (region-beginning) (region-end))) + (insert out-string) + (setq deactivate-mark nil)))))) (cond ((lookup-key global-map mapping) (while (cdr path) diff --git a/lisp/url/ChangeLog b/lisp/url/ChangeLog index 3c9313e3e7d..7ce3489cfcc 100644 --- a/lisp/url/ChangeLog +++ b/lisp/url/ChangeLog @@ -1,3 +1,8 @@ +2012-04-26 Stefan Monnier + + * url.el (url-retrieve-synchronously): Replace lexical-let by + lexical-binding. + 2012-04-10 William Xu (tiny change) * url.el (url-retrieve-internal): Hexify multibye URL string first @@ -28,8 +33,8 @@ 2012-03-11 Chong Yidong - * url-http.el (url-http-end-of-document-sentinel): Handle - keepalive expiry by calling url-http again (Bug#10223). + * url-http.el (url-http-end-of-document-sentinel): + Handle keepalive expiry by calling url-http again (Bug#10223). (url-http): New arg, for the above. 2012-03-11 Devon Sean McCullough @@ -180,8 +185,8 @@ 2011-07-03 Lars Magne Ingebrigtsen - * url-http.el (url-http-wait-for-headers-change-function): Remove - pointless "HTTP/0.9 How I hate thee!" message (bug#6735). + * url-http.el (url-http-wait-for-headers-change-function): + Remove pointless "HTTP/0.9 How I hate thee!" message (bug#6735). 2011-06-04 Andreas Schwab diff --git a/lisp/url/url.el b/lisp/url/url.el index f3ef553bbce..7884882c6e7 100644 --- a/lisp/url/url.el +++ b/lisp/url/url.el @@ -1,4 +1,4 @@ -;;; url.el --- Uniform Resource Locator retrieval tool +;;; url.el --- Uniform Resource Locator retrieval tool -*- lexical-binding: t -*- ;; Copyright (C) 1996-1999, 2001, 2004-2012 Free Software Foundation, Inc. @@ -225,8 +225,8 @@ associated with it (the case for dired, info, or mailto URLs that need no further processing). URL is either a string or a parsed URL." (url-do-setup) - (lexical-let ((retrieval-done nil) - (asynch-buffer nil)) + (let ((retrieval-done nil) + (asynch-buffer nil)) (setq asynch-buffer (url-retrieve url (lambda (&rest ignored) (url-debug 'retrieval "Synchronous fetching done (%S)" (current-buffer)) diff --git a/lisp/vc/diff.el b/lisp/vc/diff.el index dd4b4757e88..2eefdee1836 100644 --- a/lisp/vc/diff.el +++ b/lisp/vc/diff.el @@ -1,4 +1,4 @@ -;;; diff.el --- run `diff' +;;; diff.el --- run `diff' -*- lexical-binding: t -*- ;; Copyright (C) 1992, 1994, 1996, 2001-2012 Free Software Foundation, Inc. @@ -147,11 +147,8 @@ specified in `diff-switches' are passed to the diff command." (buffer-enable-undo (current-buffer)) (diff-mode) (set (make-local-variable 'revert-buffer-function) - (lexical-let ((old old) (new new) - (switches switches) - (no-async no-async)) - (lambda (ignore-auto noconfirm) - (diff-no-select old new switches no-async (current-buffer))))) + (lambda (_ignore-auto _noconfirm) + (diff-no-select old new switches no-async (current-buffer)))) (setq default-directory thisdir) (let ((inhibit-read-only t)) (insert command "\n")) @@ -159,12 +156,11 @@ specified in `diff-switches' are passed to the diff command." (let ((proc (start-process "Diff" buf shell-file-name shell-command-switch command))) (set-process-filter proc 'diff-process-filter) - (lexical-let ((old-alt old-alt) (new-alt new-alt)) - (set-process-sentinel - proc (lambda (proc msg) - (with-current-buffer (process-buffer proc) - (diff-sentinel (process-exit-status proc) - old-alt new-alt)))))) + (set-process-sentinel + proc (lambda (proc _msg) + (with-current-buffer (process-buffer proc) + (diff-sentinel (process-exit-status proc) + old-alt new-alt))))) ;; Async processes aren't available. (let ((inhibit-read-only t)) (diff-sentinel -- cgit v1.2.3 From 657c21e46b0b1262421c27040e50bccb35b01cd6 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 26 Apr 2012 14:21:03 -0400 Subject: * lisp/emacs-lisp/assoc.el (aget): Fix dynamic-scoping issue. Fixes: debbugs:11352 --- lisp/ChangeLog | 1 + lisp/emacs-lisp/assoc.el | 1 + 2 files changed, 2 insertions(+) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index a02521ca147..87b525d7e66 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,6 @@ 2012-04-26 Stefan Monnier + * emacs-lisp/assoc.el (aget): Fix dynamic-scoping issue (bug#11352). * term/ns-win.el (ns-define-service): * progmodes/pascal.el (pascal-goto-defun): diff --git a/lisp/emacs-lisp/assoc.el b/lisp/emacs-lisp/assoc.el index d3185c444d7..8e6f7711d5b 100644 --- a/lisp/emacs-lisp/assoc.el +++ b/lisp/emacs-lisp/assoc.el @@ -101,6 +101,7 @@ returned. If no key-value pair matching KEY could be found in ALIST, or ALIST is nil then nil is returned. ALIST is not altered." + (defvar copy) (let ((copy (copy-alist alist))) (cond ((null alist) nil) ((progn (asort 'copy key) -- cgit v1.2.3 From 797e6e88e9cfae3c03287ef198223e7152da7c33 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 26 Apr 2012 20:30:56 -0400 Subject: * emacs-lisp/assoc.el: Move to obsolete/. --- etc/NEWS | 5 ++ lisp/ChangeLog | 4 ++ lisp/emacs-lisp/assoc.el | 140 ---------------------------------------------- lisp/obsolete/assoc.el | 141 +++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 150 insertions(+), 140 deletions(-) delete mode 100644 lisp/emacs-lisp/assoc.el create mode 100644 lisp/obsolete/assoc.el (limited to 'lisp/emacs-lisp') diff --git a/etc/NEWS b/etc/NEWS index 254e774a65e..156933410ba 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -144,6 +144,11 @@ server properties. ** Obsolete packages: +*** assoc.el +In most cases, assoc+member+push+delq work just as well. +And in any case it's just a terrible package: ugly semantics, terrible +inefficiency, and not namespace-clean. + *** mailpost.el *** mouse-sel.el diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 87b525d7e66..9afa98fc2fe 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,7 @@ +2012-04-27 Stefan Monnier + + * emacs-lisp/assoc.el: Move to obsolete/. + 2012-04-26 Stefan Monnier * emacs-lisp/assoc.el (aget): Fix dynamic-scoping issue (bug#11352). diff --git a/lisp/emacs-lisp/assoc.el b/lisp/emacs-lisp/assoc.el deleted file mode 100644 index 8e6f7711d5b..00000000000 --- a/lisp/emacs-lisp/assoc.el +++ /dev/null @@ -1,140 +0,0 @@ -;;; assoc.el --- insert/delete functions on association lists -*- lexical-binding: t -*- - -;; Copyright (C) 1996, 2001-2012 Free Software Foundation, Inc. - -;; Author: Barry A. Warsaw -;; Keywords: extensions - -;; 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: - -;; Association list utilities providing insertion, deletion, sorting -;; fetching off key-value pairs in association lists. - -;;; Code: -(eval-when-compile (require 'cl)) - -(defun asort (alist-symbol key) - "Move a specified key-value pair to the head of an alist. -The alist is referenced by ALIST-SYMBOL. Key-value pair to move to -head is one matching KEY. Returns the sorted list and doesn't affect -the order of any other key-value pair. Side effect sets alist to new -sorted list." - (set alist-symbol - (sort (copy-alist (symbol-value alist-symbol)) - (lambda (a _b) (equal (car a) key))))) - - -(defun aelement (key value) - "Make a list of a cons cell containing car of KEY and cdr of VALUE. -The returned list is suitable for concatenating with an existing -alist, via `nconc'." - (list (cons key value))) - - -(defun aheadsym (alist) - "Return the key symbol at the head of ALIST." - (car (car alist))) - - -(defun anot-head-p (alist key) - "Find out if a specified key-value pair is not at the head of an alist. -The alist to check is specified by ALIST and the key-value pair is the -one matching the supplied KEY. Returns nil if ALIST is nil, or if -key-value pair is at the head of the alist. Returns t if key-value -pair is not at the head of alist. ALIST is not altered." - (not (equal (aheadsym alist) key))) - - -(defun aput (alist-symbol key &optional value) - "Insert a key-value pair into an alist. -The alist is referenced by ALIST-SYMBOL. The key-value pair is made -from KEY and optionally, VALUE. Returns the altered alist. - -If the key-value pair referenced by KEY can be found in the alist, and -VALUE is supplied non-nil, then the value of KEY will be set to VALUE. -If VALUE is not supplied, or is nil, the key-value pair will not be -modified, but will be moved to the head of the alist. If the key-value -pair cannot be found in the alist, it will be inserted into the head -of the alist (with value nil if VALUE is nil or not supplied)." - (let ((elem (aelement key value)) - alist) - (asort alist-symbol key) - (setq alist (symbol-value alist-symbol)) - (cond ((null alist) (set alist-symbol elem)) - ((anot-head-p alist key) (set alist-symbol (nconc elem alist))) - (value (setcar alist (car elem)) alist) - (t alist)))) - - -(defun adelete (alist-symbol key) - "Delete a key-value pair from the alist. -Alist is referenced by ALIST-SYMBOL and the key-value pair to remove -is pair matching KEY. Returns the altered alist." - (asort alist-symbol key) - (let ((alist (symbol-value alist-symbol))) - (cond ((null alist) nil) - ((anot-head-p alist key) alist) - (t (set alist-symbol (cdr alist)))))) - - -(defun aget (alist key &optional keynil-p) - "Return the value in ALIST that is associated with KEY. -Optional KEYNIL-P describes what to do if the value associated with -KEY is nil. If KEYNIL-P is not supplied or is nil, and the value is -nil, then KEY is returned. If KEYNIL-P is non-nil, then nil would be -returned. - -If no key-value pair matching KEY could be found in ALIST, or ALIST is -nil then nil is returned. ALIST is not altered." - (defvar copy) - (let ((copy (copy-alist alist))) - (cond ((null alist) nil) - ((progn (asort 'copy key) - (anot-head-p copy key)) nil) - ((cdr (car copy))) - (keynil-p nil) - ((car (car copy))) - (t nil)))) - - -(defun amake (alist-symbol keylist &optional valuelist) - "Make an association list. -The association list is attached to the alist referenced by -ALIST-SYMBOL. Each element in the KEYLIST becomes a key and is -associated with the value in VALUELIST with the same index. If -VALUELIST is not supplied or is nil, then each key in KEYLIST is -associated with nil. - -KEYLIST and VALUELIST should have the same number of elements, but -this isn't enforced. If VALUELIST is smaller than KEYLIST, remaining -keys are associated with nil. If VALUELIST is larger than KEYLIST, -extra values are ignored. Returns the created alist." - (let ((keycar (car keylist)) - (keycdr (cdr keylist)) - (valcar (car valuelist)) - (valcdr (cdr valuelist))) - (cond ((null keycdr) - (aput alist-symbol keycar valcar)) - (t - (amake alist-symbol keycdr valcdr) - (aput alist-symbol keycar valcar)))) - (symbol-value alist-symbol)) - -(provide 'assoc) - -;;; assoc.el ends here diff --git a/lisp/obsolete/assoc.el b/lisp/obsolete/assoc.el new file mode 100644 index 00000000000..d0738dfeb2c --- /dev/null +++ b/lisp/obsolete/assoc.el @@ -0,0 +1,141 @@ +;;; assoc.el --- insert/delete functions on association lists -*- lexical-binding: t -*- + +;; Copyright (C) 1996, 2001-2012 Free Software Foundation, Inc. + +;; Author: Barry A. Warsaw +;; Keywords: extensions +;; Obsolete-since: 24.2 + +;; 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: + +;; Association list utilities providing insertion, deletion, sorting +;; fetching off key-value pairs in association lists. + +;;; Code: +(eval-when-compile (require 'cl)) + +(defun asort (alist-symbol key) + "Move a specified key-value pair to the head of an alist. +The alist is referenced by ALIST-SYMBOL. Key-value pair to move to +head is one matching KEY. Returns the sorted list and doesn't affect +the order of any other key-value pair. Side effect sets alist to new +sorted list." + (set alist-symbol + (sort (copy-alist (symbol-value alist-symbol)) + (lambda (a _b) (equal (car a) key))))) + + +(defun aelement (key value) + "Make a list of a cons cell containing car of KEY and cdr of VALUE. +The returned list is suitable for concatenating with an existing +alist, via `nconc'." + (list (cons key value))) + + +(defun aheadsym (alist) + "Return the key symbol at the head of ALIST." + (car (car alist))) + + +(defun anot-head-p (alist key) + "Find out if a specified key-value pair is not at the head of an alist. +The alist to check is specified by ALIST and the key-value pair is the +one matching the supplied KEY. Returns nil if ALIST is nil, or if +key-value pair is at the head of the alist. Returns t if key-value +pair is not at the head of alist. ALIST is not altered." + (not (equal (aheadsym alist) key))) + + +(defun aput (alist-symbol key &optional value) + "Insert a key-value pair into an alist. +The alist is referenced by ALIST-SYMBOL. The key-value pair is made +from KEY and optionally, VALUE. Returns the altered alist. + +If the key-value pair referenced by KEY can be found in the alist, and +VALUE is supplied non-nil, then the value of KEY will be set to VALUE. +If VALUE is not supplied, or is nil, the key-value pair will not be +modified, but will be moved to the head of the alist. If the key-value +pair cannot be found in the alist, it will be inserted into the head +of the alist (with value nil if VALUE is nil or not supplied)." + (let ((elem (aelement key value)) + alist) + (asort alist-symbol key) + (setq alist (symbol-value alist-symbol)) + (cond ((null alist) (set alist-symbol elem)) + ((anot-head-p alist key) (set alist-symbol (nconc elem alist))) + (value (setcar alist (car elem)) alist) + (t alist)))) + + +(defun adelete (alist-symbol key) + "Delete a key-value pair from the alist. +Alist is referenced by ALIST-SYMBOL and the key-value pair to remove +is pair matching KEY. Returns the altered alist." + (asort alist-symbol key) + (let ((alist (symbol-value alist-symbol))) + (cond ((null alist) nil) + ((anot-head-p alist key) alist) + (t (set alist-symbol (cdr alist)))))) + + +(defun aget (alist key &optional keynil-p) + "Return the value in ALIST that is associated with KEY. +Optional KEYNIL-P describes what to do if the value associated with +KEY is nil. If KEYNIL-P is not supplied or is nil, and the value is +nil, then KEY is returned. If KEYNIL-P is non-nil, then nil would be +returned. + +If no key-value pair matching KEY could be found in ALIST, or ALIST is +nil then nil is returned. ALIST is not altered." + (defvar copy) + (let ((copy (copy-alist alist))) + (cond ((null alist) nil) + ((progn (asort 'copy key) + (anot-head-p copy key)) nil) + ((cdr (car copy))) + (keynil-p nil) + ((car (car copy))) + (t nil)))) + + +(defun amake (alist-symbol keylist &optional valuelist) + "Make an association list. +The association list is attached to the alist referenced by +ALIST-SYMBOL. Each element in the KEYLIST becomes a key and is +associated with the value in VALUELIST with the same index. If +VALUELIST is not supplied or is nil, then each key in KEYLIST is +associated with nil. + +KEYLIST and VALUELIST should have the same number of elements, but +this isn't enforced. If VALUELIST is smaller than KEYLIST, remaining +keys are associated with nil. If VALUELIST is larger than KEYLIST, +extra values are ignored. Returns the created alist." + (let ((keycar (car keylist)) + (keycdr (cdr keylist)) + (valcar (car valuelist)) + (valcdr (cdr valuelist))) + (cond ((null keycdr) + (aput alist-symbol keycar valcar)) + (t + (amake alist-symbol keycdr valcdr) + (aput alist-symbol keycar valcar)))) + (symbol-value alist-symbol)) + +(provide 'assoc) + +;;; assoc.el ends here -- cgit v1.2.3 From 2bd785a208c84e7ae73884d09a1087da52780b4a Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 2 May 2012 22:39:23 -0400 Subject: * lisp/emacs-lisp/bytecomp.el (byte-compile-file-form-custom-declare-variable): Compile all elements, since cconv.el might have introduced :fun-body, internal-make-closure, and friends for bytecomp to handle. * lisp/custom.el (defcustom): Avoid ((λ ..) ..). MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes: debbugs:11391 --- lisp/ChangeLog | 8 ++++++++ lisp/custom.el | 2 +- lisp/emacs-lisp/bytecomp.el | 14 +------------- 3 files changed, 10 insertions(+), 14 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 40df0618c0e..69e887f0d19 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,11 @@ +2012-05-03 Stefan Monnier + + * emacs-lisp/bytecomp.el + (byte-compile-file-form-custom-declare-variable): Compile all elements, + since cconv.el might have introduced :fun-body, internal-make-closure, + and friends for bytecomp to handle (bug#11391). + * custom.el (defcustom): Avoid ((λ ..) ..). + 2012-05-02 Stefan Monnier * subr.el (read-passwd): Better clean after ourselves (bug#11392). diff --git a/lisp/custom.el b/lisp/custom.el index 611d5688f30..d0eadcc23ff 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -335,7 +335,7 @@ for more information." ;; expression is checked by the byte-compiler, and that ;; lexical-binding is obeyed, so quote the expression with ;; `lambda' rather than with `quote'. - `(list (lambda () ,standard)) + ``(funcall #',(lambda () ,standard)) `',standard) ,doc ,@args)) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 93c6518d215..9cb0a376e36 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2267,19 +2267,7 @@ list that represents a doc string reference. (when (byte-compile-warning-enabled-p 'callargs) (byte-compile-nogroup-warn form)) (push (nth 1 (nth 1 form)) byte-compile-bound-variables) - ;; Don't compile the expression because it may be displayed to the user. - ;; (when (eq (car-safe (nth 2 form)) 'quote) - ;; ;; (nth 2 form) is meant to evaluate to an expression, so if we have the - ;; ;; final value already, we can byte-compile it. - ;; (setcar (cdr (nth 2 form)) - ;; (byte-compile-top-level (cadr (nth 2 form)) nil 'file))) - (let ((tail (nthcdr 4 form))) - (while tail - (unless (keywordp (car tail)) ;No point optimizing keywords. - ;; Compile the keyword arguments. - (setcar tail (byte-compile-top-level (car tail) nil 'file))) - (setq tail (cdr tail)))) - form) + (byte-compile-keep-pending form)) (put 'require 'byte-hunk-handler 'byte-compile-file-form-require) (defun byte-compile-file-form-require (form) -- cgit v1.2.3 From 78f3273aab4817ead42af0db41e703dc7e90260b Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Fri, 4 May 2012 13:14:14 +0800 Subject: Convert more defvars to defcustoms. * dos-w32.el (file-name-buffer-file-type-alist) (direct-print-region-use-command-dot-com): * ffap.el (ffap-menu-regexp): * follow.el (follow-debug): * forms.el (forms--debug): * iswitchb.el (iswitchb-all-frames): * ido.el (ido-all-frames): * mail/feedmail.el (feedmail-mail-send-hook) (feedmail-mail-send-hook-queued): * mail/footnote.el (footnote-signature-separator): * mail/mailabbrev.el (mail-alias-separator-string) (mail-abbrev-mode-regexp): * mail/rmail.el (rmail-speedbar-match-folder-regexp): * progmodes/idlwave.el (idlwave-libinfo-file) (idlwave-default-completion-case-is-down) (idlwave-library-routines): Convert defvars to defcustoms. * mail/rmail.el (rmail-decode-mime-charset): * progmodes/idlw-shell.el (idlwave-shell-print-expression-function) (idlwave-shell-fix-inserted-breaks) (idlwave-shell-activate-alt-keybindings) (idlwave-shell-use-breakpoint-glyph): * facemenu.el (facemenu-unlisted-faces): Delete obsolete vars. * doc/lispref/os.texi (Timers): Use defopt for timer-max-repeats. --- doc/lispref/ChangeLog | 4 ++++ doc/lispref/os.texi | 4 ++-- etc/NEWS | 5 +++++ lisp/ChangeLog | 28 ++++++++++++++++++++++++++++ lisp/dos-w32.el | 17 +++++++++++------ lisp/emacs-lisp/timer.el | 6 ++++-- lisp/facemenu.el | 9 --------- lisp/ffap.el | 8 +++++--- lisp/find-file.el | 16 ++++++++-------- lisp/follow.el | 7 ++++--- lisp/forms.el | 6 ++++-- lisp/ido.el | 11 ++++++++--- lisp/iswitchb.el | 9 +++++++-- lisp/mail/feedmail.el | 30 ++++++++++++------------------ lisp/mail/footnote.el | 10 ++++++---- lisp/mail/mailabbrev.el | 16 ++++++++++------ lisp/mail/rmail.el | 24 +++++++----------------- lisp/progmodes/idlw-shell.el | 15 --------------- lisp/progmodes/idlwave.el | 9 --------- 19 files changed, 125 insertions(+), 109 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/ChangeLog b/doc/lispref/ChangeLog index 3be41afe975..8c6165c826f 100644 --- a/doc/lispref/ChangeLog +++ b/doc/lispref/ChangeLog @@ -1,3 +1,7 @@ +2012-05-04 Chong Yidong + + * os.texi (Timers): Use defopt for timer-max-repeats. + 2012-05-03 Paul Eggert * os.texi (Time of Day): Do not limit current-time-string diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi index 0fdb3e20694..ac6711f4827 100644 --- a/doc/lispref/os.texi +++ b/doc/lispref/os.texi @@ -1735,11 +1735,11 @@ between them). If you want a timer to run again no less than @var{n} seconds after the last invocation, don't use the @var{repeat} argument. Instead, the timer function should explicitly reschedule the timer. -@defvar timer-max-repeats +@defopt timer-max-repeats This variable's value specifies the maximum number of times to repeat calling a timer function in a row, when many previously scheduled calls were unavoidably delayed. -@end defvar +@end defopt @defmac with-timeout (seconds timeout-forms@dots{}) body@dots{} Execute @var{body}, but give up after @var{seconds} seconds. If diff --git a/etc/NEWS b/etc/NEWS index a9e4a7832ed..8764030c736 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -187,6 +187,11 @@ third argument is a frame (that usage was obsolete since Emacs 22.2). but keywords or keyword-string pairs. The old argument list will still be supported for Emacs 24.x. +** The following obsolete variables and varaliases have been removed: + +*** `facemenu-unlisted-faces' +*** `rmail-decode-mime-charset' + * Lisp changes in Emacs 24.2 diff --git a/lisp/ChangeLog b/lisp/ChangeLog index b75a6606779..d57d93a7060 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,31 @@ +2012-05-04 Chong Yidong + + * dos-w32.el (file-name-buffer-file-type-alist) + (direct-print-region-use-command-dot-com): + * ffap.el (ffap-menu-regexp): + * find-file.el (ff-special-constructs): + * follow.el (follow-debug): + * forms.el (forms--debug): + * iswitchb.el (iswitchb-all-frames): + * ido.el (ido-all-frames): + * emacs-lisp/timer.el (timer-max-repeats): + * mail/feedmail.el (feedmail-mail-send-hook) + (feedmail-mail-send-hook-queued): + * mail/footnote.el (footnote-signature-separator): + * mail/mailabbrev.el (mail-alias-separator-string) + (mail-abbrev-mode-regexp): + * mail/rmail.el (rmail-speedbar-match-folder-regexp): + * progmodes/idlwave.el (idlwave-libinfo-file) + (idlwave-default-completion-case-is-down) + (idlwave-library-routines): Convert defvars to defcustoms. + + * mail/rmail.el (rmail-decode-mime-charset): + * progmodes/idlw-shell.el (idlwave-shell-print-expression-function) + (idlwave-shell-fix-inserted-breaks) + (idlwave-shell-activate-alt-keybindings) + (idlwave-shell-use-breakpoint-glyph): + * facemenu.el (facemenu-unlisted-faces): Delete obsolete vars. + 2012-05-03 Stefan Monnier * minibuffer.el (completion--twq-all): Beware completion-ignore-case. diff --git a/lisp/dos-w32.el b/lisp/dos-w32.el index 071c7b71263..f68af7a73be 100644 --- a/lisp/dos-w32.el +++ b/lisp/dos-w32.el @@ -38,9 +38,8 @@ (setq null-device "NUL") ;; For distinguishing file types based upon suffixes. -(defvar file-name-buffer-file-type-alist - '( - ("[:/].*config.sys$" . nil) ; config.sys text +(defcustom file-name-buffer-file-type-alist + '(("[:/].*config.sys$" . nil) ; config.sys text ("\\.\\(obj\\|exe\\|com\\|lib\\|sys\\|bin\\|ico\\|pif\\|class\\)$" . t) ; MS-Dos stuff ("\\.\\(dll\\|drv\\|386\\|vxd\\|fon\\|fnt\\|fot\\|ttf\\|grp\\)$" . t) @@ -57,7 +56,10 @@ ) "Alist for distinguishing text files from binary files. Each element has the form (REGEXP . TYPE), where REGEXP is matched -against the file name, and TYPE is nil for text, t for binary.") +against the file name, and TYPE is nil for text, t for binary." + :type '(repeat (cons regexp boolean)) + :group 'dos-fns + :group 'w32) ;; Return the pair matching filename on file-name-buffer-file-type-alist, ;; or nil otherwise. @@ -282,8 +284,11 @@ filesystem mounted on drive Z:, FILESYSTEM could be \"Z:\"." ;;; Support for printing under DOS/Windows, see lpr.el and ps-print.el. -(defvar direct-print-region-use-command-dot-com t - "Control whether command.com is used to print on Windows 9x.") +(defcustom direct-print-region-use-command-dot-com t + "If non-nil, use command.com to print on Windows 9x." + :type 'boolean + :group 'dos-fns + :group 'w32) ;; Function to actually send data to the printer port. ;; Supports writing directly, and using various programs. diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index 87b6cceb24b..11ec0f0614c 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -240,12 +240,14 @@ and idle timers such as are scheduled by `run-with-idle-timer'." (defvar timer-event-last-2 nil "Third-to-last timer that was run.") -(defvar timer-max-repeats 10 +(defcustom timer-max-repeats 10 "Maximum number of times to repeat a timer, if many repeats are delayed. Timer invocations can be delayed because Emacs is suspended or busy, or because the system's time changes. If such an occurrence makes it appear that many invocations are overdue, this variable controls -how many will really happen.") +how many will really happen." + :type 'integer + :group 'internal) (defun timer-until (timer time) "Calculate number of seconds from when TIMER will run, until TIME. diff --git a/lisp/facemenu.el b/lisp/facemenu.el index e76b61fdacb..bcef25eb893 100644 --- a/lisp/facemenu.el +++ b/lisp/facemenu.el @@ -127,15 +127,6 @@ just before \"Other\" at the end." :type 'boolean :group 'facemenu) -(defvar facemenu-unlisted-faces - `(modeline region secondary-selection highlight scratch-face - ,(purecopy "^font-lock-") ,(purecopy "^gnus-") ,(purecopy "^message-") - ,(purecopy "^ediff-") ,(purecopy "^term-") ,(purecopy "^vc-") - ,(purecopy "^widget-") ,(purecopy "^custom-") ,(purecopy "^vm-")) - "List of faces that are of no interest to the user.") -(make-obsolete-variable 'facemenu-unlisted-faces 'facemenu-listed-faces - "22.1,\n and has no effect on the Face menu") - (defcustom facemenu-listed-faces nil "List of faces to include in the Face menu. Each element should be a symbol, the name of a face. diff --git a/lisp/ffap.el b/lisp/ffap.el index 7ab6a75406d..905d7873dc2 100644 --- a/lisp/ffap.el +++ b/lisp/ffap.el @@ -1457,10 +1457,12 @@ and the functions `ffap-file-at-point' and `ffap-url-at-point'." ;;; Menu support (`ffap-menu'): -(defvar ffap-menu-regexp nil - "If non-nil, overrides `ffap-next-regexp' during `ffap-menu'. +(defcustom ffap-menu-regexp nil + "If non-nil, regexp overriding `ffap-next-regexp' in `ffap-menu'. Make this more restrictive for faster menu building. -For example, try \":/\" for URL (and some ftp) references.") +For example, try \":/\" for URL (and some ftp) references." + :type '(choice (const nil) regexp) + :group 'ffap) (defvar ffap-menu-alist nil "Buffer local cache of menu presented by `ffap-menu'.") diff --git a/lisp/find-file.el b/lisp/find-file.el index fe1ab96add9..1deafc9734c 100644 --- a/lisp/find-file.el +++ b/lisp/find-file.el @@ -181,21 +181,21 @@ To override this, give an argument to `ff-find-other-file'." :group 'ff) ;;;###autoload -(defvar ff-special-constructs - `( - ;; C/C++ include, for NeXTstep too - (,(purecopy "^\#\\s *\\(include\\|import\\)\\s +[<\"]\\(.*\\)[>\"]") . +(defcustom ff-special-constructs + ;; C/C++ include, for NeXTstep too + `((,(purecopy "^\#\\s *\\(include\\|import\\)\\s +[<\"]\\(.*\\)[>\"]") . (lambda () - (buffer-substring (match-beginning 2) (match-end 2)))) - ) + (buffer-substring (match-beginning 2) (match-end 2))))) ;; We include `ff-treat-as-special' documentation here so that autoload ;; can make it available to be read prior to loading this file. - "List of special constructs for `ff-treat-as-special' to recognize. + "List of special constructs recognized by `ff-treat-as-special'. Each element, tried in order, has the form (REGEXP . EXTRACT). If REGEXP matches the current line (from the beginning of the line), `ff-treat-as-special' calls function EXTRACT with no args. If EXTRACT returns nil, keep trying. Otherwise, return the -filename that EXTRACT returned.") +filename that EXTRACT returned." + :type '(repeat (cons regexp function)) + :group 'ff) (defvaralias 'ff-related-file-alist 'ff-other-file-alist) (defcustom ff-other-file-alist 'cc-other-file-alist diff --git a/lisp/follow.el b/lisp/follow.el index 4c76b43da2d..0dea1917f85 100644 --- a/lisp/follow.el +++ b/lisp/follow.el @@ -321,9 +321,10 @@ The commands in this list are checked at load time. To mark other commands as suitable for caching, set the symbol property `follow-mode-use-cache' to non-nil.") -(defvar follow-debug nil - "Non-nil when debugging Follow mode.") - +(defcustom follow-debug nil + "If non-nil, emit Follow mode debugging messages." + :type 'boolean + :group 'follow) ;; Internal variables: diff --git a/lisp/forms.el b/lisp/forms.el index 38670e42bdd..69433de0e14 100644 --- a/lisp/forms.el +++ b/lisp/forms.el @@ -2030,8 +2030,10 @@ Usage: (setq forms-number-of-fields ;;; Debugging -(defvar forms--debug nil - "Enables forms-mode debugging if not nil.") +(defcustom forms--debug nil + "If non-nil, enable Forms mode debugging." + :type 'boolean + :group 'forms) (defun forms--debug (&rest args) "Internal debugging routine." diff --git a/lisp/ido.el b/lisp/ido.el index bbf3fe2a1d0..f3deba7ae8b 100644 --- a/lisp/ido.el +++ b/lisp/ido.el @@ -893,9 +893,14 @@ Otherwise, only the current list of matches is shown." :type 'boolean :group 'ido) -(defvar ido-all-frames 'visible - "Argument to pass to `walk-windows' when finding visible files. -See documentation of `walk-windows' for useful values.") +(defcustom ido-all-frames 'visible + "Argument to pass to `walk-windows' when Ido is finding buffers. +See documentation of `walk-windows' for useful values." + :type '(choice (const :tag "Selected frame only" nil) + (const :tag "All existing frames" t) + (const :tag "All visible frames" visible) + (const :tag "All frames on this terminal" 0)) + :group 'ido) (defcustom ido-minibuffer-setup-hook nil "Ido-specific customization of minibuffer setup. diff --git a/lisp/iswitchb.el b/lisp/iswitchb.el index 9600bd1db2d..a31828514bd 100644 --- a/lisp/iswitchb.el +++ b/lisp/iswitchb.el @@ -373,8 +373,13 @@ See also `iswitchb-newbuffer'." :group 'iswitchb) (defvar iswitchb-all-frames 'visible - "Argument to pass to `walk-windows' when finding visible buffers. -See documentation of `walk-windows' for useful values.") + "Argument to pass to `walk-windows' when iswitchb is finding buffers. +See documentation of `walk-windows' for useful values." + :type '(choice (const :tag "Selected frame only" nil) + (const :tag "All existing frames" t) + (const :tag "All visible frames" visible) + (const :tag "All frames on this terminal" 0)) + :group 'iswitchb) (defcustom iswitchb-minibuffer-setup-hook nil "Iswitchb-specific customization of minibuffer setup. diff --git a/lisp/mail/feedmail.el b/lisp/mail/feedmail.el index f35560841e2..df18abbc532 100644 --- a/lisp/mail/feedmail.el +++ b/lisp/mail/feedmail.el @@ -1366,17 +1366,19 @@ call to `feedmail-run-the-queue'." (feedmail-say-debug ">in-> feedmail-mail-send-hook-splitter %s" feedmail-queue-runner-is-active) (if feedmail-queue-runner-is-active (run-hooks 'feedmail-mail-send-hook-queued) - (run-hooks 'feedmail-mail-send-hook)) - ) - - -(defvar feedmail-mail-send-hook nil - "See documentation for `feedmail-mail-send-hook-splitter'.") + (run-hooks 'feedmail-mail-send-hook))) +(defcustom feedmail-mail-send-hook nil + "Hook run by `feedmail-mail-send-hook-splitter' for immediate mail. +See documentation of `feedmail-mail-send-hook-splitter' for details." + :type 'hook + :group 'feedmail) -(defvar feedmail-mail-send-hook-queued nil - "See documentation for `feedmail-mail-send-hook-splitter'.") - +(defcustom feedmail-mail-send-hook-queued nil + "Hook run by `feedmail-mail-send-hook-splitter' for queued mail. +See documentation of `feedmail-mail-send-hook-splitter' for details." + :type 'hook + :group 'feedmail) (defun feedmail-confirm-addresses-hook-example () "An example of a `feedmail-last-chance-hook'. @@ -1387,9 +1389,7 @@ It shows the simple addresses and gets a confirmation. Use as: (erase-buffer) (insert (mapconcat 'identity feedmail-address-list " ")) (if (not (y-or-n-p "How do you like them apples? ")) - (error "FQM: Sending...gave up in last chance hook") - ))) - + (error "FQM: Sending...gave up in last chance hook")))) (defcustom feedmail-last-chance-hook nil "User's last opportunity to modify the message on its way out. @@ -2027,12 +2027,6 @@ backup file names and the like)." (if (looking-at ".*\r\n.*\r\n") (while (search-forward "\r\n" nil t) (replace-match "\n" nil t))) -;; ;; work around text-vs-binary weirdness -;; ;; if we don't find the normal M-H-S, try reading the file a different way -;; (if (not (feedmail-find-eoh t)) -;; (let ((file-name-buffer-file-type-alist nil) (default-buffer-file-type nil)) -;; (erase-buffer) -;; (insert-file-contents maybe-file))) (funcall feedmail-queue-runner-mode-setter arg) (condition-case signal-stuff ; don't give up the loop if user skips some (let ((feedmail-enable-queue nil) diff --git a/lisp/mail/footnote.el b/lisp/mail/footnote.el index c0a63ef197c..f0c6b21513e 100644 --- a/lisp/mail/footnote.el +++ b/lisp/mail/footnote.el @@ -126,10 +126,12 @@ has no effect on buffers already displaying footnotes." :type 'string :group 'footnote) -(defvar footnote-signature-separator (if (boundp 'message-signature-separator) - message-signature-separator - "^-- $") - "String used to recognize .signatures.") +(defcustom footnote-signature-separator (if (boundp 'message-signature-separator) + message-signature-separator + "^-- $") + "Regexp used by Footnote mode to recognize signatures." + :type 'regexp + :group 'footnote) ;;; Private variables diff --git a/lisp/mail/mailabbrev.el b/lisp/mail/mailabbrev.el index fb8e1502f91..290c57c1c55 100644 --- a/lisp/mail/mailabbrev.el +++ b/lisp/mail/mailabbrev.el @@ -254,10 +254,12 @@ By default this is the file specified by `mail-personal-alias-file'." mail-abbrevs) (message "Parsing %s... done" file)) -(defvar mail-alias-separator-string ", " - "A string inserted between addresses in multi-address mail aliases. +(defcustom mail-alias-separator-string ", " + "String inserted between addresses in multi-address mail aliases. This has to contain a comma, so \", \" is a reasonable value. You might -also want something like \",\\n \" to get each address on its own line.") +also want something like \",\\n \" to get each address on its own line." + :type 'string + :group 'mail-abbrev) ;; define-mail-abbrev sets this flag, which causes mail-resolve-all-aliases ;; to be called before expanding abbrevs if it's necessary. @@ -421,14 +423,16 @@ fill-column, break the line at the previous comma, and indent the next line." ;;; Syntax tables and abbrev-expansion -(defvar mail-abbrev-mode-regexp +(defcustom mail-abbrev-mode-regexp "^\\(Resent-\\)?\\(To\\|From\\|CC\\|BCC\\|Reply-to\\):" - "Regexp to select mail-headers in which mail abbrevs should be expanded. + "Regexp matching mail headers in which mail abbrevs should be expanded. This string will be handed to `looking-at' with point at the beginning of the current line; if it matches, abbrev mode will be turned on, otherwise it will be turned off. (You don't need to worry about continuation lines.) This should be set to match those mail fields in which you want abbreviations -turned on.") +turned on." + :type 'regexp + :group 'mail-abbrev) (defvar mail-abbrev-syntax-table nil "The syntax-table used for abbrev-expansion purposes. diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el index df2f8be533a..14bf9d90a16 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -713,19 +713,6 @@ to an appropriate value, and optionally also set `rmail-insert-mime-forwarded-message-function', and `rmail-insert-mime-resent-message-function'.") -;; FIXME this is unused since 23.1. -(defvar rmail-decode-mime-charset t - "Non-nil means a message is decoded by MIME's charset specification. -If this variable is nil, or the message has not MIME specification, -the message is decoded as normal way. - -If the variable `rmail-enable-mime' is non-nil, this variable is -ignored, and all the decoding work is done by a feature specified by -the variable `rmail-mime-feature'.") - -(make-obsolete-variable 'rmail-decode-mime-charset - "it does nothing." "23.1") - (defvar rmail-mime-charset-pattern (concat "^content-type:[ \t]*text/plain;" "\\(?:[ \t\n]*\\(?:format\\|delsp\\)=\"?[-a-z0-9]+\"?;\\)*" @@ -4231,10 +4218,13 @@ This has an effect only if a summary buffer exists." ;;; Speedbar support for RMAIL files. (eval-when-compile (require 'speedbar)) -(defvar rmail-speedbar-match-folder-regexp "^[A-Z0-9]+\\(\\.[A-Z0-9]+\\)?$" - "This regex is used to match folder names to be displayed in speedbar. -Enabling this will permit speedbar to display your folders for easy -browsing, and moving of messages.") +(defcustom rmail-speedbar-match-folder-regexp "^[A-Z0-9]+\\(\\.[A-Z0-9]+\\)?$" + "Regexp matching Rmail folder names to be displayed in Speedbar. +Enabling this permits Speedbar to display your folders for easy +browsing, and moving of messages." + :type 'regexp + :group 'rmail + :group 'speedbar) (defvar rmail-speedbar-last-user nil "The last user to be displayed in the speedbar.") diff --git a/lisp/progmodes/idlw-shell.el b/lisp/progmodes/idlw-shell.el index d843de04913..ca51eef6e8e 100644 --- a/lisp/progmodes/idlw-shell.el +++ b/lisp/progmodes/idlw-shell.el @@ -183,12 +183,6 @@ so that the name will be unique among multiple Emacs processes." :group 'idlwave-shell-general-setup :type 'string) -(defvar idlwave-shell-fix-inserted-breaks nil - "OBSOLETE VARIABLE, is no longer used. - -The documentation of this variable used to be: -If non-nil then run `idlwave-shell-remove-breaks' to clean up IDL messages.") - (defcustom idlwave-shell-prefix-key "\C-c\C-d" "The prefix key for the debugging map `idlwave-shell-mode-prefix-map'. This variable must already be set when idlwave-shell.el is loaded. @@ -223,9 +217,6 @@ window, but is useful for stepping, etc." ;; (defcustom idlwave-shell-debug-modifiers... See idlwave.el -(defvar idlwave-shell-activate-alt-keybindings nil - "Obsolete variable. See `idlwave-shell-debug-modifiers'.") - (defcustom idlwave-shell-use-truename nil "Non-nil means, use `file-truename' when looking for buffers. If this variable is non-nil, Emacs will use the function `file-truename' to @@ -335,9 +326,6 @@ expression being examined." (string :tag "Label ") (string :tag "Command")))) -(defvar idlwave-shell-print-expression-function nil - "OBSOLETE VARIABLE, is no longer used.") - (defcustom idlwave-shell-separate-examine-output t "Non-nil means, put output of examine commands in their own buffer." :group 'idlwave-shell-command-setup @@ -520,9 +508,6 @@ t Glyph when possible, otherwise face (same effect as 'glyph)." (const :tag "Display glyph (red dot)" glyph) (const :tag "Glyph or face." t))) -(defvar idlwave-shell-use-breakpoint-glyph t - "Obsolete variable. See `idlwave-shell-mark-breakpoints'.") - (defcustom idlwave-shell-breakpoint-face 'idlwave-shell-bp "The face for breakpoint lines in the source code. Allows you to choose the font, color and other properties for diff --git a/lisp/progmodes/idlwave.el b/lisp/progmodes/idlwave.el index 74f37df9b2d..015f58df3fb 100644 --- a/lisp/progmodes/idlwave.el +++ b/lisp/progmodes/idlwave.el @@ -456,9 +456,6 @@ value of `!DIR'. See also `idlwave-library-path'." (defvar idlwave-xml-system-rinfo-converted-file "idl_xml_rinfo.el") (defvar idlwave-path-file "idlpath.el") -(defvar idlwave-libinfo-file nil - "Obsolete variable, no longer used.") - (defcustom idlwave-special-lib-alist nil "Alist of regular expressions matching special library directories. When listing routine source locations, IDLWAVE gives a short hint where @@ -555,10 +552,6 @@ completions." :group 'idlwave-completion :type 'boolean) -(defvar idlwave-default-completion-case-is-down nil - "Obsolete variable. See `idlwave-complete-empty-string-as-lower-case' and -`idlwave-completion-case'.") - (defcustom idlwave-buffer-case-takes-precedence nil "Non-nil means, the case of tokens in buffers dominates over system stuff. To make this possible, we need to re-case everything each time we update @@ -4525,8 +4518,6 @@ information updated immediately, leave NO-CONCATENATE nil." nil 'idlwave-load-rinfo-next-step))) (error nil)))) -(defvar idlwave-library-routines nil "Obsolete variable.") - ;;------ XML Help routine info system (defun idlwave-load-system-routine-info () ;; Load the system routine info from the cached routine info file, -- cgit v1.2.3 From 0bfcf5c598d7c351591827b14482253adf9ab015 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Thu, 3 May 2012 23:13:18 -0700 Subject: Fix minor Y10k bugs. * lisp/arc-mode.el (archive-unixdate): * lisp/autoinsert.el (auto-insert-alist): * lisp/calc/calc-forms.el (math-this-year): * lisp/gnus/nnweb.el (nnweb-google-parse-1): * lisp/emacs-lisp/copyright.el (copyright-current-year) (copyright-update-year, copyright): * lisp/tar-mode.el (tar-clip-time-string): * lisp/time.el (display-time-update): Don't assume years have 4 digits. --- lisp/ChangeLog | 12 ++++++++++++ lisp/arc-mode.el | 5 +++-- lisp/autoinsert.el | 6 +++--- lisp/calc/calc-forms.el | 2 +- lisp/emacs-lisp/copyright.el | 7 +++---- lisp/gnus/ChangeLog | 5 +++++ lisp/gnus/nnweb.el | 2 +- lisp/tar-mode.el | 2 +- lisp/time.el | 2 +- 9 files changed, 30 insertions(+), 13 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index d57d93a7060..7d7cf56cd77 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,15 @@ +2012-05-04 Paul Eggert + + Fix minor Y10k bugs. + * arc-mode.el (archive-unixdate): + * autoinsert.el (auto-insert-alist): + * calc/calc-forms.el (math-this-year): + * emacs-lisp/copyright.el (copyright-current-year) + (copyright-update-year, copyright): + * tar-mode.el (tar-clip-time-string): + * time.el (display-time-update): + Don't assume years have 4 digits. + 2012-05-04 Chong Yidong * dos-w32.el (file-name-buffer-file-type-alist) diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el index 8b17208983f..c776a3f8b5c 100644 --- a/lisp/arc-mode.el +++ b/lisp/arc-mode.el @@ -622,11 +622,12 @@ the mode is invalid. If ERROR is nil then nil will be returned." (defun archive-unixdate (low high) "Stringify Unix (LOW HIGH) date." - (let ((str (current-time-string (cons high low)))) + (let* ((time (cons high low)) + (str (current-time-string time))) (format "%s-%s-%s" (substring str 8 10) (substring str 4 7) - (substring str 20 24)))) + (format-time-string "%Y" time)))) (defun archive-unixtime (low high) "Stringify Unix (LOW HIGH) time." diff --git a/lisp/autoinsert.el b/lisp/autoinsert.el index de2835580c2..e7639b6f8a3 100644 --- a/lisp/autoinsert.el +++ b/lisp/autoinsert.el @@ -135,7 +135,7 @@ If this contains a %s, that will be replaced by the matching rule." (("\\.[1-9]\\'" . "Man page skeleton") "Short description: " - ".\\\" Copyright (C), " (substring (current-time-string) -4) " " + ".\\\" Copyright (C), " (format-time-string "%Y") " " (getenv "ORGANIZATION") | (progn user-full-name) " .\\\" You may distribute this file under the terms of the GNU Free @@ -166,7 +166,7 @@ If this contains a %s, that will be replaced by the matching rule." "Short description: " ";;; " (file-name-nondirectory (buffer-file-name)) " --- " str " -;; Copyright (C) " (substring (current-time-string) -4) " " +;; Copyright (C) " (format-time-string "%Y") " " (getenv "ORGANIZATION") | (progn user-full-name) " ;; Author: " (user-full-name) @@ -222,7 +222,7 @@ If this contains a %s, that will be replaced by the matching rule." @copying\n" (setq short-description (read-string "Short description: ")) ".\n\n" - "Copyright @copyright{} " (substring (current-time-string) -4) " " + "Copyright @copyright{} " (format-time-string "%Y") " " (getenv "ORGANIZATION") | (progn user-full-name) " @quotation diff --git a/lisp/calc/calc-forms.el b/lisp/calc/calc-forms.el index 96cc74f7ef6..dfc5dfc6588 100644 --- a/lisp/calc/calc-forms.el +++ b/lisp/calc/calc-forms.el @@ -444,7 +444,7 @@ (defun math-this-year () - (string-to-number (substring (current-time-string) -4))) + (nth 5 (decode-time))) (defun math-leap-year-p (year) (if (Math-lessp year 1752) diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el index 09b456b54ba..8e96d95c5dd 100644 --- a/lisp/emacs-lisp/copyright.el +++ b/lisp/emacs-lisp/copyright.el @@ -110,7 +110,7 @@ When this is `function', only ask when called non-interactively." ;; This is a defvar rather than a defconst, because the year can ;; change during the Emacs session. -(defvar copyright-current-year (substring (current-time-string) -4) +(defvar copyright-current-year (format-time-string "%Y") "String representing the current year.") (defsubst copyright-limit () ; re-search-forward BOUND @@ -181,8 +181,7 @@ skips to the end of all the years." ;; This uses the match-data from copyright-find-copyright/end. (goto-char (match-end 1)) (copyright-find-end) - ;; Note that `current-time-string' isn't locale-sensitive. - (setq copyright-current-year (substring (current-time-string) -4)) + (setq copyright-current-year (format-time-string "%Y")) (unless (string= (buffer-substring (- (match-end 3) 2) (match-end 3)) (substring copyright-current-year -2)) (if (or noquery @@ -347,7 +346,7 @@ independently replaces consecutive years with a range." "Insert a copyright by $ORGANIZATION notice at cursor." "Company: " comment-start - "Copyright (C) " `(substring (current-time-string) -4) " by " + "Copyright (C) " `(format-time-string "%Y") " by " (or (getenv "ORGANIZATION") str) '(if (copyright-offset-too-large-p) diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 4938336742a..9000ccb9fef 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,8 @@ +2012-05-04 Paul Eggert + + Fix minor Y10k bug. + * nnweb.el (nnweb-google-parse-1): Don't assume years have 4 digits. + 2012-05-01 Stefan Monnier * nnimap.el (nnimap-open-connection-1): Don't leave an "opening..." diff --git a/lisp/gnus/nnweb.el b/lisp/gnus/nnweb.el index a171cb35ae4..8c9c984ba2e 100644 --- a/lisp/gnus/nnweb.el +++ b/lisp/gnus/nnweb.el @@ -365,7 +365,7 @@ Valid types include `google', `dejanews', and `gmane'.") (match-string 1) (match-string 2) (or (match-string 3) - (substring (current-time-string) -4))) + (format-time-string "%Y"))) (current-time-string))) (setq From (match-string 4))) (widen) diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el index 7c95f47e0fb..82329677643 100644 --- a/lisp/tar-mode.el +++ b/lisp/tar-mode.el @@ -396,7 +396,7 @@ write-date, checksum, link-type, and link-name." (defun tar-clip-time-string (time) (let ((str (current-time-string time))) - (concat " " (substring str 4 16) (substring str 19 24)))) + (concat " " (substring str 4 16) (format-time-string " %Y" time)))) (defun tar-grind-file-mode (mode) "Construct a `-rw--r--r--' string indicating MODE. diff --git a/lisp/time.el b/lisp/time.el index c7fa5927e48..8d43b565416 100644 --- a/lisp/time.el +++ b/lisp/time.el @@ -465,7 +465,7 @@ update which can wait for the next redisplay." (seconds (substring time 17 19)) (time-zone (car (cdr (current-time-zone now)))) (day (substring time 8 10)) - (year (substring time 20 24)) + (year (format-time-string "%Y" now)) (monthname (substring time 4 7)) (month (cdr -- cgit v1.2.3 From 71873e2b335b721e0b3c585e88211c9564f4c743 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 4 May 2012 19:16:47 -0400 Subject: Add new error and function `user-error'. * lisp/subr.el (user-error): New function. * lisp/window.el (switch-to-buffer): * lisp/vc/smerge-mode.el (smerge-resolve-function, smerge-resolve) (smerge-match-conflict): * lisp/simple.el (previous-matching-history-element) (next-matching-history-element, goto-history-element, undo-more) (undo-start): * lisp/progmodes/etags.el (visit-tags-table-buffer, find-tag-tag) (find-tag-noselect, find-tag-in-order, etags-goto-tag-location) (next-file, tags-loop-scan, list-tags, complete-tag): * lisp/progmodes/compile.el (compilation-loop): * lisp/mouse.el (mouse-minibuffer-check): * lisp/man.el (Man-bgproc-sentinel, Man-goto-page): * lisp/info.el (Info-find-node-2, Info-extract-pointer, Info-history-back) (Info-history-forward, Info-follow-reference, Info-menu) (Info-extract-menu-item, Info-extract-menu-counting) (Info-forward-node, Info-backward-node, Info-next-menu-item) (Info-last-menu-item, Info-next-preorder, Info-last-preorder) (Info-next-reference, Info-prev-reference, Info-index) (Info-index-next, Info-follow-nearest-node) (Info-copy-current-node-name): * lisp/imenu.el (imenu--make-index-alist) (imenu-default-create-index-function, imenu-add-to-menubar): * lisp/files.el (basic-save-buffer, recover-file): * lisp/emacs-lisp/easy-mmode.el (easy-mmode-define-navigation): * lisp/emacs-lisp/checkdoc.el (checkdoc-continue, checkdoc-comments) (checkdoc-message-text, checkdoc-defun): * lisp/dabbrev.el (dabbrev-completion, dabbrev--abbrev-at-point): * lisp/cus-edit.el (customize-changed-options, customize-rogue) (customize-saved, custom-variable-set, custom-variable-mark-to-save) (custom-variable-mark-to-reset-standard) (custom-variable-reset-backup, custom-face-mark-to-reset-standard) (custom-file): * lisp/completion.el (check-completion-length): * lisp/comint.el (comint-search-arg) (comint-previous-matching-input-string-position) (comint-previous-matching-input) (comint-replace-by-expanded-history-before-point, comint-send-input) (comint-copy-old-input, comint-backward-matching-input) (comint-goto-process-mark, comint-set-process-mark): * lisp/calendar/calendar.el (calendar-cursor-to-date): Use it. * lisp/bindings.el (debug-ignored-errors): Remove regexps, add `user-error'. * src/data.c (PUT_ERROR): New macro. (syms_of_data): Use it. Add new error type `user-error'. * src/undo.c (user_error): New function. (Fprimitive_undo): Use it. * src/print.c (print_error_message): Adjust print style for `user-error'. * src/keyboard.c (user_error): New function. (Fexit_recursive_edit, Fabort_recursive_edit): Use it. --- doc/emacs/ChangeLog | 90 +++++++++++------------ etc/NEWS | 1 + lisp/ChangeLog | 45 ++++++++++++ lisp/bindings.el | 19 ++--- lisp/calendar/calendar.el | 4 +- lisp/comint.el | 28 +++----- lisp/completion.el | 8 +-- lisp/cus-edit.el | 35 ++++----- lisp/dabbrev.el | 17 ++--- lisp/emacs-lisp/checkdoc.el | 33 +++------ lisp/emacs-lisp/easy-mmode.el | 6 +- lisp/files.el | 4 +- lisp/imenu.el | 14 ++-- lisp/info.el | 74 ++++++++----------- lisp/man.el | 9 +-- lisp/mouse.el | 2 +- lisp/progmodes/compile.el | 7 +- lisp/progmodes/etags.el | 56 ++++++--------- lisp/simple.el | 28 ++++---- lisp/subr.el | 11 +++ lisp/vc/smerge-mode.el | 9 +-- lisp/window.el | 4 +- src/ChangeLog | 14 +++- src/data.c | 164 ++++++++++++------------------------------ src/fileio.c | 10 +-- src/keyboard.c | 10 ++- src/lisp.h | 2 +- src/print.c | 40 ++++++----- src/undo.c | 15 ++-- 29 files changed, 335 insertions(+), 424 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/emacs/ChangeLog b/doc/emacs/ChangeLog index a2bae546f1c..a6d9ea6a8bc 100644 --- a/doc/emacs/ChangeLog +++ b/doc/emacs/ChangeLog @@ -438,7 +438,7 @@ 2012-01-09 Chong Yidong - * custom.texi (Custom Themes): Switched custom-safe-themes to use + * custom.texi (Custom Themes): Switch custom-safe-themes to use SHA-256. 2012-01-07 Chong Yidong @@ -455,8 +455,8 @@ (Screen Garbled): Don't refer to terminal "manufacturers". (Total Frustration): Node deleted. Eliza is documented in Amusements now. - (Known Problems): More info about using the bug tracker. Mention - debbugs package. + (Known Problems): More info about using the bug tracker. + Mention debbugs package. (Bug Criteria): Copyedits. (Understanding Bug Reporting): Mention emacs -Q. @@ -519,8 +519,8 @@ Document browse-url-mailto-function. (Goto Address mode): Add index entries. Add xref to Browse-URL. (FFAP): FFAP is not a minor mode. - (Amusements): M-x lm was renamed to M-x landmark. Document - nato-region. + (Amusements): M-x lm was renamed to M-x landmark. + Document nato-region. 2012-01-01 Chong Yidong @@ -558,8 +558,8 @@ 2011-12-26 Chong Yidong - * dired.texi (Dired Enter, Misc Dired Features): Document - dired-use-ls-dired changes. Mention quit-window. + * dired.texi (Dired Enter, Misc Dired Features): + Document dired-use-ls-dired changes. Mention quit-window. (Dired Navigation): Add index entries. (Dired Visiting): Fix View Mode xref. (Marks vs Flags): Prefer C-/ binding for undo. @@ -602,8 +602,8 @@ * vc1-xtra.texi (Version Headers): Note that these are for Subversion, CVS, etc. only. - (General VC Options): De-document vc-keep-workfiles. Fix - RCS-isms. + (General VC Options): De-document vc-keep-workfiles. + Fix RCS-isms. 2011-12-22 Eli Zaretskii @@ -619,8 +619,8 @@ * vc1-xtra.texi (Remote Repositories): Update introduction. (Local Version Control): Node deleted (obsolete with DVCSes). - (Remote Repositories, Version Backups): Node deleted. Move - documentation of vc-cvs-stay-local to CVS Options. + (Remote Repositories, Version Backups): Node deleted. + Move documentation of vc-cvs-stay-local to CVS Options. (CVS Options): Reduce verbosity of description of obscure CVS locking feature. (Making Revision Tags, Revision Tag Caveats): Merge into Revision @@ -673,11 +673,11 @@ less CVS-specific. (VC With A Merging VCS, VC With A Locking VCS): Add xref to Registering node. - (Secondary VC Commands): Deleted. Promote subnodes. + (Secondary VC Commands): Delete. Promote subnodes. (Log Buffer): Add command name for C-c C-c. Fix the name of the log buffer. Add index entries. - (VCS Changesets, Types of Log File, VC With A Merging VCS): Use - "commit" terminology. + (VCS Changesets, Types of Log File, VC With A Merging VCS): + Use "commit" terminology. (Old Revisions): Move it to just before VC Change Log. "Tag" here doesn't refer to tags tables. Note other possible forms of the revision ID. C-x v = does not save. @@ -702,8 +702,8 @@ (Lisp Eval): Note that listed commands are available globally. Explain the meaning of "defun" in the C-M-x context. (Lisp Interaction): Copyedits. - (External Lisp): Fix name of inferior Lisp buffer. Mention - Scheme. + (External Lisp): Fix name of inferior Lisp buffer. + Mention Scheme. (Compilation): Define "inferior process". 2011-12-10 Eli Zaretskii @@ -718,8 +718,8 @@ (Compilation Mode): Add xref for grep, occur, and mouse references. Define "locus". (Grep Searching): Use @command. - (Debuggers, Commands of GUD, GDB Graphical Interface): Clarify - intro. + (Debuggers, Commands of GUD, GDB Graphical Interface): + Clarify intro. (Starting GUD): Clarify how arguments are specified. (Debugger Operation): Index entry for "GUD interaction buffer", and move basic description here from Commands of GUD node. @@ -727,8 +727,8 @@ (Source Buffers): Remove gdb-find-source-frame, which is not in gdb-mi.el. (Other GDB Buffers): Remove gdb-use-separate-io-buffer and - toggle-gdb-all-registers, which are not in gdb-mi.el. Don't - re-document GUD interaction buffers. + toggle-gdb-all-registers, which are not in gdb-mi.el. + Don't re-document GUD interaction buffers. * programs.texi (Symbol Completion): M-TAB can now use Semantic. (Semantic): Add cindex entries for Semantic. @@ -758,8 +758,8 @@ * programs.texi (Program Modes): Mention modes that are not included with Emacs. Fix references to other manuals for tex. - Add index entry for backward-delete-char-untabify. Mention - prog-mode-hook. + Add index entry for backward-delete-char-untabify. + Mention prog-mode-hook. (Which Function): Use "global minor mode" terminology. (Basic Indent, Multi-line Indent): Refer to previous descriptions in Indentation chapter to avoid duplication. @@ -791,12 +791,12 @@ (TeX Editing): Add xref to documentation for Occur. (LaTeX Editing): Add xref to Completion node. (TeX Print): Fix description of tex-directory. - (Enriched Text): Renamed from Formatted Text. Make this node and + (Enriched Text): Rename from Formatted Text. Make this node and its subnodes less verbose, since text/enriched files are practically unused. - (Enriched Mode): Renamed from Requesting Formatted Text. + (Enriched Mode): Rename from Requesting Formatted Text. (Format Colors): Node deleted. - (Enriched Faces): Renamed from Format Faces. Describe commands + (Enriched Faces): Rename from Format Faces. Describe commands for applying colors too. (Forcing Enriched Mode): Node deleted; merged into Enriched Mode. @@ -1031,12 +1031,12 @@ 2011-10-18 Chong Yidong * display.texi (Faces): Simplify discussion. Move documentation - of list-faces-display here, from Standard Faces node. Note - special role of `default' background. - (Standard Faces): Note special role of `default' background. Note - that region face may be taken fom GTK. Add xref to Text Display. - (Text Scale): Rename from "Temporary Face Changes". Callers - changed. Don't bother documenting variable-pitch-mode. + of list-faces-display here, from Standard Faces node. + Note special role of `default' background. + (Standard Faces): Note special role of `default' background. + Note that region face may be taken fom GTK. Add xref to Text Display. + (Text Scale): Rename from "Temporary Face Changes". + Callers changed. Don't bother documenting variable-pitch-mode. (Font Lock): Copyedits. Remove font-lock-maximum-size. (Useless Whitespace): Simplify description of delete-trailing-whitespace. Note active region case. @@ -1058,8 +1058,8 @@ 2011-10-13 Chong Yidong - * killing.texi (Deletion): Add xref to Using Region. Document - delete-forward-char. + * killing.texi (Deletion): Add xref to Using Region. + Document delete-forward-char. (Yanking): Move yank-excluded-properties to Lisp manual. Move C-y description here. Recommend C-u C-SPC for jumping to mark. (Kill Ring): Move kill ring variable documentation here. @@ -1079,10 +1079,10 @@ selection changes. Mention that commands like C-y set the mark. (Marking Objects): Add xref to Words node. Note that mark-word and mark-sexp also have the "extend region" behavior. - (Using Region): Mention M-$ in the table. Document - mark-even-if-inactive here instead of in Mark Ring. - (Mark Ring): Move mark-even-if-inactive to Using Region. Take - note of the "Mark Set" behavior. + (Using Region): Mention M-$ in the table. + Document mark-even-if-inactive here instead of in Mark Ring. + (Mark Ring): Move mark-even-if-inactive to Using Region. + Take note of the "Mark Set" behavior. (Disabled Transient Mark): Rename from "Persistent Mark" (Bug#9688). Callers changed. @@ -1097,8 +1097,8 @@ (Name Help): Remove an over-long joke. (Apropos): Document prefix args. Remove duplicated descriptions. (Help Mode): Add C-c C-b to table. Update TAB binding. - (Package Keywords): Rename from "Library by Keyword". Describe - new package menu interface. + (Package Keywords): Rename from "Library by Keyword". + Describe new package menu interface. (Help Files, Help Echo): Tweak description. * mini.texi (Completion Options): Add completion-cycle-threshold. @@ -1110,8 +1110,8 @@ 2011-10-08 Chong Yidong - * basic.texi (Position Info): Omit page commands. Document - count-words-region and count-words. + * basic.texi (Position Info): Omit page commands. + Document count-words-region and count-words. * text.texi (Pages): Move what-page documentation here. @@ -1134,8 +1134,8 @@ 2011-10-07 Chong Yidong - * basic.texi (Inserting Text): Add xref to Completion. Add - ucs-insert example, and document prefix argument. + * basic.texi (Inserting Text): Add xref to Completion. + Add ucs-insert example, and document prefix argument. (Moving Point): Fix introduction; C-f/C-b are no longer equivalent to left/right. Tweak left-char and right-char descriptions. M-left and M-right are now bound to left-word/right-word. @@ -1539,8 +1539,8 @@ 2011-04-24 Chong Yidong - * maintaining.texi (List Tags): Document next-file. Suggested by - Uday S Reddy. + * maintaining.texi (List Tags): Document next-file. + Suggested by Uday S Reddy. 2011-04-23 Juanma Barranquero diff --git a/etc/NEWS b/etc/NEWS index 71e6bce9b7a..ca9b018a2f7 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -199,6 +199,7 @@ still be supported for Emacs 24.x. * Lisp changes in Emacs 24.2 +** New error type and new function `user-error'. Doesn't trigger the debugger. ** Completion *** New function `completion-table-with-quoting' to handle completion diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 0c5c2050754..5c38eb86fa7 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,48 @@ +2012-05-04 Stefan Monnier + + * subr.el (user-error): New function. + * window.el (switch-to-buffer): + * vc/smerge-mode.el (smerge-resolve-function, smerge-resolve) + (smerge-match-conflict): + * simple.el (previous-matching-history-element) + (next-matching-history-element, goto-history-element, undo-more) + (undo-start): + * progmodes/etags.el (visit-tags-table-buffer, find-tag-tag) + (find-tag-noselect, find-tag-in-order, etags-goto-tag-location) + (next-file, tags-loop-scan, list-tags, complete-tag): + * progmodes/compile.el (compilation-loop): + * mouse.el (mouse-minibuffer-check): + * man.el (Man-bgproc-sentinel, Man-goto-page): + * info.el (Info-find-node-2, Info-extract-pointer, Info-history-back) + (Info-history-forward, Info-follow-reference, Info-menu) + (Info-extract-menu-item, Info-extract-menu-counting) + (Info-forward-node, Info-backward-node, Info-next-menu-item) + (Info-last-menu-item, Info-next-preorder, Info-last-preorder) + (Info-next-reference, Info-prev-reference, Info-index) + (Info-index-next, Info-follow-nearest-node) + (Info-copy-current-node-name): + * imenu.el (imenu--make-index-alist) + (imenu-default-create-index-function, imenu-add-to-menubar): + * files.el (basic-save-buffer, recover-file): + * emacs-lisp/easy-mmode.el (easy-mmode-define-navigation): + * emacs-lisp/checkdoc.el (checkdoc-continue, checkdoc-comments) + (checkdoc-message-text, checkdoc-defun): + * dabbrev.el (dabbrev-completion, dabbrev--abbrev-at-point): + * cus-edit.el (customize-changed-options, customize-rogue) + (customize-saved, custom-variable-set, custom-variable-mark-to-save) + (custom-variable-mark-to-reset-standard) + (custom-variable-reset-backup, custom-face-mark-to-reset-standard) + (custom-file): + * completion.el (check-completion-length): + * comint.el (comint-search-arg) + (comint-previous-matching-input-string-position) + (comint-previous-matching-input) + (comint-replace-by-expanded-history-before-point, comint-send-input) + (comint-copy-old-input, comint-backward-matching-input) + (comint-goto-process-mark, comint-set-process-mark): + * calendar/calendar.el (calendar-cursor-to-date): Use it. + * bindings.el (debug-ignored-errors): Remove regexps, add `user-error'. + 2012-05-04 Stefan Monnier * dabbrev.el (dabbrev--ignore-case-p): New function. diff --git a/lisp/bindings.el b/lisp/bindings.el index 8cfeecf5b40..f04ee723220 100644 --- a/lisp/bindings.el +++ b/lisp/bindings.el @@ -623,24 +623,13 @@ is okay. See `mode-line-format'.") ;; Packages should add to this list appropriately when they are ;; loaded, rather than listing everything here. (setq debug-ignored-errors + ;; FIXME: Maybe beginning-of-line, beginning-of-buffer, end-of-line, + ;; end-of-buffer, end-of-file, buffer-read-only, and + ;; file-supersession should all be user-errors! `(beginning-of-line beginning-of-buffer end-of-line end-of-buffer end-of-file buffer-read-only file-supersession - ,(purecopy "^Previous command was not a yank$") - ,(purecopy "^Minibuffer window is not active$") - ,(purecopy "^No previous history search regexp$") - ,(purecopy "^No later matching history item$") - ,(purecopy "^No earlier matching history item$") - ,(purecopy "^End of history; no default available$") - ,(purecopy "^End of defaults; no next item$") - ,(purecopy "^Beginning of history; no preceding item$") - ,(purecopy "^No recursive edit is in progress$") - ,(purecopy "^Changes to be undone are outside visible portion of buffer$") - ,(purecopy "^No undo information in this buffer$") - ,(purecopy "^No further undo information") - ,(purecopy "^Save not confirmed$") - ,(purecopy "^Recover-file cancelled\\.$") - ,(purecopy "^Cannot switch buffers in a dedicated window$") + user-error ;; That's the main one! )) diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el index d9ec27b4f88..4d4f7e14187 100644 --- a/lisp/calendar/calendar.el +++ b/lisp/calendar/calendar.el @@ -1888,7 +1888,7 @@ use instead of point." ;; or on or before the digit of a 1-digit date. (if (not (and (looking-at "[ 0-9]?[0-9][^0-9]") (get-text-property (point) 'date))) - (if error (error "Not on a date!")) + (if error (user-error "Not on a date!")) ;; Convert segment to real month and year. (if (zerop month) (setq month 12)) ;; Go back to before the first date digit. @@ -1903,8 +1903,6 @@ use instead of point." ((and (= 1 month) (= segment 2)) (1+ displayed-year)) (t displayed-year)))))))) -(add-to-list 'debug-ignored-errors "Not on a date!") - ;; The following version of calendar-gregorian-from-absolute is preferred for ;; reasons of clarity, BUT it's much slower than the version that follows it. diff --git a/lisp/comint.el b/lisp/comint.el index 8103db0e9bb..43e42c87be7 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -1076,10 +1076,10 @@ See also `comint-read-input-ring'." (defun comint-search-arg (arg) ;; First make sure there is a ring and that we are after the process mark (cond ((not (comint-after-pmark-p)) - (error "Not at command line")) + (user-error "Not at command line")) ((or (null comint-input-ring) (ring-empty-p comint-input-ring)) - (error "Empty input ring")) + (user-error "Empty input ring")) ((zerop arg) ;; arg of zero resets search from beginning, and uses arg of 1 (setq comint-input-ring-index nil) @@ -1146,7 +1146,7 @@ Moves relative to `comint-input-ring-index'." Moves relative to START, or `comint-input-ring-index'." (if (or (not (ring-p comint-input-ring)) (ring-empty-p comint-input-ring)) - (error "No history")) + (user-error "No history")) (let* ((len (ring-length comint-input-ring)) (motion (if (> arg 0) 1 -1)) (n (mod (- (or start (comint-search-start arg)) motion) len)) @@ -1186,7 +1186,7 @@ If N is negative, find the next or Nth next match." (let ((pos (comint-previous-matching-input-string-position regexp n))) ;; Has a match been found? (if (null pos) - (error "Not found") + (user-error "Not found") ;; If leaving the edit line, save partial input (if (null comint-input-ring-index) ;not yet on ring (setq comint-stored-incomplete-input @@ -1372,7 +1372,7 @@ actual side-effect." (goto-char (match-beginning 0)) (if (not (search-forward old pos t)) (or silent - (error "Not found")) + (user-error "Not found")) (replace-match new t t) (message "History item: substituted")))) (t @@ -1777,7 +1777,7 @@ Similarly for Soar, Scheme, etc." (interactive) ;; Note that the input string does not include its terminal newline. (let ((proc (get-buffer-process (current-buffer)))) - (if (not proc) (error "Current buffer has no process") + (if (not proc) (user-error "Current buffer has no process") (widen) (let* ((pmark (process-mark proc)) (intxt (if (>= (point) (marker-position pmark)) @@ -2201,7 +2201,7 @@ Calls `comint-get-old-input' to get old input." (let ((input (funcall comint-get-old-input)) (process (get-buffer-process (current-buffer)))) (if (not process) - (error "Current buffer has no process") + (user-error "Current buffer has no process") (goto-char (process-mark process)) (insert input)))) @@ -2508,7 +2508,7 @@ If N is negative, find the next or Nth next match." (save-excursion (while (/= n 0) (unless (re-search-backward regexp nil t dir) - (error "Not found")) + (user-error "Not found")) (unless (get-char-property (point) 'field) (setq n (- n dir)))) (field-beginning)))) @@ -3364,7 +3364,7 @@ The process mark separates output, and input already sent, from input that has not yet been sent." (interactive) (let ((proc (or (get-buffer-process (current-buffer)) - (error "Current buffer has no process")))) + (user-error "Current buffer has no process")))) (goto-char (process-mark proc)) (when (called-interactively-p 'interactive) (message "Point is now at the process mark")))) @@ -3389,7 +3389,7 @@ the process mark is at the beginning of the accumulated input." "Set the process mark at point." (interactive) (let ((proc (or (get-buffer-process (current-buffer)) - (error "Current buffer has no process")))) + (user-error "Current buffer has no process")))) (set-marker (process-mark proc) (point)) (message "Process mark set"))) @@ -3741,14 +3741,6 @@ REGEXP-GROUP is the regular expression group in REGEXP to use." (match-end regexp-group)) results)) results))) - -(dolist (x '("^Not at command line$" - "^Empty input ring$" - "^No history$" - "^Not found$" ; Too common? - "^Current buffer has no process$")) - (add-to-list 'debug-ignored-errors x)) - ;; Converting process modes to use comint mode ;; =========================================================================== diff --git a/lisp/completion.el b/lisp/completion.el index 9c6cd60c96c..75f8920920c 100644 --- a/lisp/completion.el +++ b/lisp/completion.el @@ -1301,8 +1301,8 @@ String must be longer than `completion-prefix-min-length'." (defun check-completion-length (string) (if (< (length string) completion-min-length) - (error "The string `%s' is too short to be saved as a completion" - string) + (user-error "The string `%s' is too short to be saved as a completion" + string) (list string))) (defun add-completion (string &optional num-uses last-use-time) @@ -2467,10 +2467,6 @@ if ARG is omitted or nil." (defvaralias 'cmpl-syntax-table 'completion-syntax-table) (defalias 'initialize-completions 'completion-initialize) -(dolist (x '("^To complete, the point must be after a symbol at least [0-9]* character long\\.$" - "^The string \".*\" is too short to be saved as a completion\\.$")) - (add-to-list 'debug-ignored-errors x)) - (provide 'completion) ;;; completion.el ends here diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 4458bb7b56f..52308319f15 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -1254,8 +1254,8 @@ that were added or redefined since that version." (if found (custom-buffer-create (custom-sort-items found t 'first) "*Customize Changed Options*") - (error "No user option defaults have been changed since Emacs %s" - since-version)))) + (user-error "No user option defaults have been changed since Emacs %s" + since-version)))) (defun customize-package-emacs-version (symbol package-version) "Return the Emacs version in which SYMBOL's meaning last changed. @@ -1386,7 +1386,7 @@ suggest to customize that face, if it's customizable." (default-value symbol)))) (push (list symbol 'custom-variable) found))))) (if (not found) - (error "No rogue user options") + (user-error "No rogue user options") (custom-buffer-create (custom-sort-items found t nil) "*Customize Rogue*")))) ;;;###autoload @@ -1403,8 +1403,8 @@ suggest to customize that face, if it's customizable." (get symbol 'saved-variable-comment)) (boundp symbol) (push (list symbol 'custom-variable) found)))) - (if (not found ) - (error "No saved user options") + (if (not found) + (user-error "No saved user options") (custom-buffer-create (custom-sort-items found t nil) "*Customize Saved*")))) @@ -2879,7 +2879,7 @@ Optional EVENT is the location for the menu." (comment (widget-value comment-widget)) val) (cond ((eq state 'hidden) - (error "Cannot set hidden variable")) + (user-error "Cannot set hidden variable")) ((setq val (widget-apply child :validate)) (goto-char (widget-get val :from)) (error "%s" (widget-get val :error))) @@ -2921,7 +2921,7 @@ Optional EVENT is the location for the menu." (comment (widget-value comment-widget)) val) (cond ((eq state 'hidden) - (error "Cannot set hidden variable")) + (user-error "Cannot set hidden variable")) ((setq val (widget-apply child :validate)) (goto-char (widget-get val :from)) (error "Saving %s: %s" symbol (widget-get val :error))) @@ -2995,7 +2995,7 @@ redraw the widget immediately." (let* ((symbol (widget-value widget))) (if (get symbol 'standard-value) (custom-variable-backup-value widget) - (error "No standard setting known for %S" symbol)) + (user-error "No standard setting known for %S" symbol)) (put symbol 'variable-comment nil) (put symbol 'customized-value nil) (put symbol 'customized-variable-comment nil) @@ -3057,7 +3057,7 @@ to switch between two values." (condition-case nil (funcall set symbol (car value)) (error nil))) - (error "No backup value for %s" symbol)) + (user-error "No backup value for %s" symbol)) (put symbol 'customized-value (list (custom-quote (car value)))) (put symbol 'variable-comment comment) (put symbol 'customized-variable-comment comment) @@ -3795,7 +3795,7 @@ redraw the widget immediately." (value (get symbol 'face-defface-spec)) (comment-widget (widget-get widget :comment-widget))) (unless value - (error "No standard setting for this face")) + (user-error "No standard setting for this face")) (put symbol 'customized-face nil) (put symbol 'customized-face-comment nil) (custom-push-theme 'theme-face symbol 'user 'reset) @@ -4414,7 +4414,7 @@ if only the first line of the docstring is shown.")) ;; sense. (if no-error nil - (error "Saving settings from \"emacs -q\" would overwrite existing customizations")) + (user-error "Saving settings from \"emacs -q\" would overwrite existing customizations")) (file-chase-links (or custom-file user-init-file)))) ;; If recentf-mode is non-nil, this is defined. @@ -4875,18 +4875,7 @@ if that value is non-nil." (put 'custom-mode 'mode-class 'special) (define-obsolete-variable-alias 'custom-mode-hook 'Custom-mode-hook "23.1") -(dolist (regexp - '("^No user option defaults have been changed since Emacs " - "^Invalid face:? " - "^No \\(?:customized\\|rogue\\|saved\\) user options" - "^No customizable items matching " - "^There are unset changes" - "^Cannot set hidden variable" - "^No \\(?:saved\\|backup\\) value for " - "^No standard setting known for " - "^No standard setting for this face" - "^Saving settings from \"emacs -q\" would overwrite existing customizations")) - (add-to-list 'debug-ignored-errors regexp)) +(add-to-list 'debug-ignored-errors "^Invalid face:? ") ;;; The End. diff --git a/lisp/dabbrev.el b/lisp/dabbrev.el index c169e07ac30..87a03fd24da 100644 --- a/lisp/dabbrev.el +++ b/lisp/dabbrev.el @@ -406,10 +406,10 @@ then it searches *all* buffers." (dabbrev--find-all-expansions abbrev ignore-case-p)) (completion-ignore-case ignore-case-p)) (or (consp completion-list) - (error "No dynamic expansion for \"%s\" found%s" - abbrev - (if dabbrev--check-other-buffers - "" " in this-buffer"))) + (user-error "No dynamic expansion for \"%s\" found%s" + abbrev + (if dabbrev--check-other-buffers + "" " in this-buffer"))) (setq list (cond ((not (and ignore-case-p dabbrev-case-replace)) @@ -585,7 +585,7 @@ all skip characters." "Extract the symbol at point to serve as abbreviation." ;; Check for error (if (bobp) - (error "No possible abbreviation preceding point")) + (user-error "No possible abbreviation preceding point")) ;; Return abbrev at point (save-excursion ;; Record the end of the abbreviation. @@ -603,7 +603,7 @@ all skip characters." "\\sw\\|\\s_") nil t) (forward-char 1) - (error "No possible abbreviation preceding point")))) + (user-error "No possible abbreviation preceding point")))) ;; Now find the beginning of that one. (dabbrev--goto-start-of-abbrev) (buffer-substring-no-properties @@ -974,11 +974,6 @@ Leaves point at the location of the start of the expansion." (cons found-string dabbrev--last-table)) result))))) -(dolist (mess '("^No dynamic expansion for .* found" - "^No further dynamic expansion for .* found$" - "^No possible abbreviation preceding point$")) - (add-to-list 'debug-ignored-errors mess)) - (provide 'dabbrev) ;;; dabbrev.el ends here diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 7a9a33fc2cc..ee8cbd2c3bc 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -916,7 +916,7 @@ is the starting location. If this is nil, `point-min' is used instead." (progn (goto-char wrong) (if (not take-notes) - (error "%s" (checkdoc-error-text msg))))) + (user-error "%s" (checkdoc-error-text msg))))) (checkdoc-show-diagnostics) (if (called-interactively-p 'interactive) (message "No style warnings.")))) @@ -949,7 +949,7 @@ if there is one." (e (checkdoc-file-comments-engine)) (checkdoc-generate-compile-warnings-flag (or take-notes checkdoc-generate-compile-warnings-flag))) - (if e (error "%s" (checkdoc-error-text e))) + (if e (user-error "%s" (checkdoc-error-text e))) (checkdoc-show-diagnostics) e)) @@ -987,7 +987,7 @@ Optional argument TAKE-NOTES causes all errors to be logged." (if (not (called-interactively-p 'interactive)) e (if e - (error "%s" (checkdoc-error-text e)) + (user-error "%s" (checkdoc-error-text e)) (checkdoc-show-diagnostics))) (goto-char p)) (if (called-interactively-p 'interactive) @@ -1027,19 +1027,14 @@ space at the end of each line." (car (memq checkdoc-spellcheck-documentation-flag '(defun t)))) (beg (save-excursion (beginning-of-defun) (point))) - (end (save-excursion (end-of-defun) (point))) - (msg (checkdoc-this-string-valid))) - (if msg (if no-error - (message "%s" (checkdoc-error-text msg)) - (error "%s" (checkdoc-error-text msg))) - (setq msg (checkdoc-message-text-search beg end)) - (if msg (if no-error - (message "%s" (checkdoc-error-text msg)) - (error "%s" (checkdoc-error-text msg))) - (setq msg (checkdoc-rogue-space-check-engine beg end)) - (if msg (if no-error - (message "%s" (checkdoc-error-text msg)) - (error "%s" (checkdoc-error-text msg)))))) + (end (save-excursion (end-of-defun) (point)))) + (dolist (fun (list #'checkdoc-this-string-valid + (lambda () (checkdoc-message-text-search beg end)) + (lambda () (checkdoc-rogue-space-check-engine beg end)))) + (let ((msg (funcall fun))) + (if msg (if no-error + (message "%s" (checkdoc-error-text msg)) + (user-error "%s" (checkdoc-error-text msg)))))) (if (called-interactively-p 'interactive) (message "Checkdoc: done.")))))) @@ -2644,12 +2639,6 @@ function called to create the messages." (custom-add-option 'emacs-lisp-mode-hook 'checkdoc-minor-mode) -(add-to-list 'debug-ignored-errors - "Argument `.*' should appear (as .*) in the doc string") -(add-to-list 'debug-ignored-errors - "Lisp symbol `.*' should appear in quotes") -(add-to-list 'debug-ignored-errors "Disambiguate .* by preceding .*") - (provide 'checkdoc) ;;; checkdoc.el ends here diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 0d6716a2e63..301947f0735 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -572,8 +572,6 @@ BODY is executed after moving to the destination location." (when was-narrowed (,narrowfun))))))) (unless name (setq name base-name)) `(progn - (add-to-list 'debug-ignored-errors - ,(concat "^No \\(previous\\|next\\) " (regexp-quote name))) (defun ,next-sym (&optional count) ,(format "Go to the next COUNT'th %s." name) (interactive "p") @@ -584,7 +582,7 @@ BODY is executed after moving to the destination location." `(if (not (re-search-forward ,re nil t count)) (if (looking-at ,re) (goto-char (or ,(if endfun `(,endfun)) (point-max))) - (error "No next %s" ,name)) + (user-error "No next %s" ,name)) (goto-char (match-beginning 0)) (when (and (eq (current-buffer) (window-buffer (selected-window))) (called-interactively-p 'interactive)) @@ -603,7 +601,7 @@ BODY is executed after moving to the destination location." (if (< count 0) (,next-sym (- count)) ,(funcall when-narrowed `(unless (re-search-backward ,re nil t count) - (error "No previous %s" ,name))) + (user-error "No previous %s" ,name))) ,@body)) (put ',prev-sym 'definition-name ',base)))) diff --git a/lisp/files.el b/lisp/files.el index ee455f4bf42..dd80ce69811 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -4497,7 +4497,7 @@ Before and after saving the buffer, this function runs (format "%s has changed since visited or saved. Save anyway? " (file-name-nondirectory buffer-file-name))) - (error "Save not confirmed")) + (user-error "Save not confirmed")) (save-restriction (widen) (save-excursion @@ -5364,7 +5364,7 @@ non-nil, it is called instead of rereading visited file contents." (insert-file-contents file-name nil) (set-buffer-file-coding-system coding-system)) (after-find-file nil nil t)) - (t (error "Recover-file cancelled"))))) + (t (user-error "Recover-file cancelled"))))) (defun recover-session () "Recover auto save files from a previous Emacs session. diff --git a/lisp/imenu.el b/lisp/imenu.el index 12ac3540925..feebb96d379 100644 --- a/lisp/imenu.el +++ b/lisp/imenu.el @@ -579,7 +579,7 @@ See `imenu--index-alist' for the format of the index alist." (funcall imenu-create-index-function)))) (imenu--truncate-items imenu--index-alist))) (or imenu--index-alist noerror - (error "No items suitable for an index found in this buffer")) + (user-error "No items suitable for an index found in this buffer")) (or imenu--index-alist (setq imenu--index-alist (list nil))) ;; Add a rescan option to the index. @@ -695,7 +695,7 @@ The alternate method, which is the one most often used, is to call ((and imenu-generic-expression) (imenu--generic-function imenu-generic-expression)) (t - (error "This buffer cannot use `imenu-default-create-index-function'")))) + (user-error "This buffer cannot use `imenu-default-create-index-function'")))) ;;; ;;; Generic index gathering function. @@ -968,8 +968,8 @@ See the command `imenu' for more information." `(menu-item ,name ,(make-sparse-keymap "Imenu"))) (use-local-map newmap) (add-hook 'menu-bar-update-hook 'imenu-update-menubar))) - (error "The mode `%s' does not support Imenu" - (format-mode-line mode-name)))) + (user-error "The mode `%s' does not support Imenu" + (format-mode-line mode-name)))) ;;;###autoload (defun imenu-add-menubar-index () @@ -1058,12 +1058,6 @@ for more information." (apply function (car index-item) position rest)) (run-hooks 'imenu-after-jump-hook))) -(dolist (mess - '("^No items suitable for an index found in this buffer$" - "^This buffer cannot use `imenu-default-create-index-function'$" - "^The mode `.*' does not support Imenu$")) - (add-to-list 'debug-ignored-errors mess)) - (provide 'imenu) ;;; imenu.el ends here diff --git a/lisp/info.el b/lisp/info.el index 042ff158362..1e3b14632e6 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -1071,7 +1071,7 @@ a case-insensitive match is tried." (throw 'foo t)) ;; No such anchor in tag table or node in tag table or file - (error "No such node or anchor: %s" nodename)) + (user-error "No such node or anchor: %s" nodename)) (Info-select-node) (goto-char (point-min)) @@ -2012,8 +2012,8 @@ if ERRORNAME is nil, just return nil." (concat name ":" (Info-following-node-name-re)) bound t) (match-string-no-properties 1)) ((not (eq errorname t)) - (error "Node has no %s" - (capitalize (or errorname name))))))))) + (user-error "Node has no %s" + (capitalize (or errorname name))))))))) (defun Info-following-node-name-re (&optional allowedchars) "Return a regexp matching a node name. @@ -2082,7 +2082,7 @@ If SAME-FILE is non-nil, do not move to a different Info file." "Go back in the history to the last node visited." (interactive) (or Info-history - (error "This is the first Info node you looked at")) + (user-error "This is the first Info node you looked at")) (let ((history-forward (cons (list Info-current-file Info-current-node (point)) Info-history-forward)) @@ -2102,7 +2102,7 @@ If SAME-FILE is non-nil, do not move to a different Info file." "Go forward in the history of visited nodes." (interactive) (or Info-history-forward - (error "This is the last Info node you looked at")) + (user-error "This is the last Info node you looked at")) (let ((history-forward (cdr Info-history-forward)) filename nodename opoint) (setq filename (car (car Info-history-forward))) @@ -2388,7 +2388,7 @@ new buffer." completions nil t))) (list (if (equal input "") default input) current-prefix-arg)) - (error "No cross-references in this node")))) + (user-error "No cross-references in this node")))) (unless footnotename (error "No reference was specified")) @@ -2419,7 +2419,8 @@ new buffer." (abs (- prev-ref (point)))) next-ref prev-ref)) ((or next-ref prev-ref)) - ((error "No cross-reference named %s" footnotename)))) + ((user-error "No cross-reference named %s" + footnotename)))) (setq target (Info-extract-menu-node-name t)))) (while (setq i (string-match "[ \t\n]+" target i)) (setq target (concat (substring target 0 i) " " @@ -2564,7 +2565,7 @@ new buffer." (save-excursion (goto-char (point-min)) (if (not (search-forward "\n* menu:" nil t)) - (error "No menu in this node")) + (user-error "No menu in this node")) (setq beg (point)) (and (< (point) p) (save-excursion @@ -2605,10 +2606,10 @@ new buffer." (let ((case-fold-search t)) (goto-char (point-min)) (or (search-forward "\n* menu:" nil t) - (error "No menu in this node")) + (user-error "No menu in this node")) (or (re-search-forward (concat "\n\\* +" menu-item ":") nil t) (re-search-forward (concat "\n\\* +" menu-item) nil t) - (error "No such item in menu")) + (user-error "No such item in menu")) (beginning-of-line) (forward-char 2) (Info-extract-menu-node-name nil (Info-index-node)))))) @@ -2624,7 +2625,7 @@ new buffer." (match-beginning 0)))) (goto-char (point-min)) (or (search-forward "\n* menu:" bound t) - (error "No menu in this node")) + (user-error "No menu in this node")) (if count (or (search-forward "\n* " bound t count) (error "Too few items in menu")) @@ -2696,7 +2697,7 @@ N is the digit argument used to invoke this command." (if Info-history-skip-intermediate-nodes (setq Info-history old-history))))) (no-error nil) - (t (error "No pointer forward from this node"))))) + (t (user-error "No pointer forward from this node"))))) (defun Info-backward-node () "Go backward one node, considering all nodes as forming one sequence." @@ -2705,7 +2706,7 @@ N is the digit argument used to invoke this command." (upnode (Info-extract-pointer "up" t)) (case-fold-search t)) (cond ((and upnode (string-match "(" upnode)) - (error "First node in file")) + (user-error "First node in file")) ((and upnode (or (null prevnode) ;; Use string-equal, not equal, ;; to ignore text properties. @@ -2723,7 +2724,7 @@ N is the digit argument used to invoke this command." (if Info-history-skip-intermediate-nodes (setq Info-history old-history)))) (t - (error "No pointer backward from this node"))))) + (user-error "No pointer backward from this node"))))) (defun Info-exit () "Exit Info by selecting some other buffer." @@ -2744,7 +2745,7 @@ N is the digit argument used to invoke this command." (and (search-forward "\n* " nil t) (Info-extract-menu-node-name))))) (if node (Info-goto-node node) - (error "No more items in menu")))) + (user-error "No more items in menu")))) (defun Info-last-menu-item () "Go to the node of the previous menu item." @@ -2757,7 +2758,7 @@ N is the digit argument used to invoke this command." (and (search-backward "\n* menu:" nil t) (point))))) (or (and beg (search-backward "\n* " beg t)) - (error "No previous items in menu"))) + (user-error "No previous items in menu"))) (Info-goto-node (save-excursion (goto-char (match-end 0)) (Info-extract-menu-node-name))))) @@ -2782,7 +2783,7 @@ N is the digit argument used to invoke this command." (if Info-history-skip-intermediate-nodes (setq Info-history old-history)))) (t - (error "No more nodes")))) + (user-error "No more nodes")))) (defun Info-last-preorder () "Go to the last node, popping up a level if there is none." @@ -2822,7 +2823,7 @@ N is the digit argument used to invoke this command." (let ((case-fold-search t)) (or (search-forward "\n* Menu:" nil t) (goto-char (point-max))))) - (t (error "No previous nodes")))) + (t (user-error "No previous nodes")))) (defun Info-scroll-up () "Scroll one screenful forward in Info, considering all nodes as one sequence. @@ -2911,11 +2912,11 @@ See `Info-scroll-down'." (or (re-search-forward pat nil t) (progn (goto-char old-pt) - (error "No cross references in this node"))))) + (user-error "No cross references in this node"))))) (goto-char (or (match-beginning 1) (match-beginning 0))) (if (looking-at "\\* Menu:") (if recur - (error "No cross references in this node") + (user-error "No cross references in this node") (Info-next-reference t)) (if (looking-at "^\\* ") (forward-char 2))))) @@ -2932,11 +2933,11 @@ See `Info-scroll-down'." (or (re-search-backward pat nil t) (progn (goto-char old-pt) - (error "No cross references in this node"))))) + (user-error "No cross references in this node"))))) (goto-char (or (match-beginning 1) (match-beginning 0))) (if (looking-at "\\* Menu:") (if recur - (error "No cross references in this node") + (user-error "No cross references in this node") (Info-prev-reference t)) (if (looking-at "^\\* ") (forward-char 2))))) @@ -3107,7 +3108,7 @@ Give an empty topic name to go to the Index node itself." (or matches (progn (Info-goto-node orignode) - (error "No `%s' in index" topic))) + (user-error "No `%s' in index" topic))) ;; Here it is a feature that assoc is case-sensitive. (while (setq found (assoc topic matches)) (setq exact (cons found exact) @@ -3120,7 +3121,7 @@ Give an empty topic name to go to the Index node itself." "Go to the next matching index item from the last \\\\[Info-index] command." (interactive "p") (or Info-index-alternatives - (error "No previous `i' command")) + (user-error "No previous `i' command")) (while (< num 0) (setq num (+ num (length Info-index-alternatives)))) (while (> num 0) @@ -3640,7 +3641,7 @@ If FORK is a string, it is the name to use for the new buffer." ;; Don't raise an error when mouse-1 is bound to this - it's ;; often used to simply select the window or frame. (eq 'mouse-1 (event-basic-type last-input-event))) - (error "Point neither on reference nor in menu item description"))) + (user-error "Point neither on reference nor in menu item description"))) ;; Common subroutine. (defun Info-try-follow-nearest-node (&optional fork) @@ -3907,7 +3908,7 @@ The name of the Info file is prepended to the node name in parentheses. With a zero prefix arg, put the name inside a function call to `info'." (interactive "P") (unless Info-current-node - (error "No current Info node")) + (user-error "No current Info node")) (let ((node (if (stringp Info-current-file) (concat "(" (file-name-nondirectory Info-current-file) ") " Info-current-node)))) @@ -4899,25 +4900,8 @@ BUFFER is the buffer speedbar is requesting buttons for." (erase-buffer)) (Info-speedbar-hierarchy-buttons nil 0)) -(dolist (mess '("^First node in file$" - "^No `.*' in index$" - "^No cross-reference named" - "^No cross.references in this node$" - "^No current Info node$" - "^No menu in this node$" - "^No more items in menu$" - "^No more nodes$" - "^No pointer \\(?:forward\\|backward\\) from this node$" - "^No previous `i' command$" - "^No previous items in menu$" - "^No previous nodes$" - "^No such item in menu$" - "^No such node or anchor" - "^Node has no" - "^Point neither on reference nor in menu item description$" - "^This is the \\(?:first\\|last\\) Info node you looked at$" - search-failed)) - (add-to-list 'debug-ignored-errors mess)) +;; FIXME: Really? Why here? +(add-to-list 'debug-ignored-errors 'search-failed) ;;;; Desktop support diff --git a/lisp/man.el b/lisp/man.el index 6912486dffa..dd64613c495 100644 --- a/lisp/man.el +++ b/lisp/man.el @@ -1273,8 +1273,8 @@ manpage command." (if (not Man-page-list) (let ((args Man-arguments)) (kill-buffer (current-buffer)) - (error "Can't find the %s manpage" - (Man-page-from-arguments args))) + (user-error "Can't find the %s manpage" + (Man-page-from-arguments args))) (set-buffer-modified-p nil)))) ;; Restore case-fold-search before calling ;; Man-notify-when-ready because it may switch buffers. @@ -1649,7 +1649,7 @@ Specify which REFERENCE to use; default is based on word at point." (when Man-page-list (if (or (< page 1) (> page (length Man-page-list))) - (error "No manpage %d found" page)) + (user-error "No manpage %d found" page)) (let* ((page-range (nth (1- page) Man-page-list)) (page-start (car page-range)) (page-end (car (cdr page-range)))) @@ -1742,9 +1742,6 @@ Uses `Man-name-local-regexp'." ;; Init the man package variables, if not already done. (Man-init-defvars) -(add-to-list 'debug-ignored-errors "^No manpage [0-9]* found$") -(add-to-list 'debug-ignored-errors "^Can't find the .* manpage$") - (provide 'man) ;;; man.el ends here diff --git a/lisp/mouse.el b/lisp/mouse.el index 46e50ed9508..f40a0199525 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -298,7 +298,7 @@ Use the former if the menu bar is showing, otherwise the latter." (let ((w (posn-window (event-start event)))) (and (window-minibuffer-p w) (not (minibuffer-window-active-p w)) - (error "Minibuffer window is not active"))) + (user-error "Minibuffer window is not active"))) ;; Give temporary modes such as isearch a chance to turn off. (run-hooks 'mouse-leave-buffer-hook)) diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 2608ba0b0c3..f22ee4f7ea5 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -2132,14 +2132,14 @@ and runs `compilation-filter-hook'." (if (or (eq (get-text-property ,limit 'compilation-message) (get-text-property opt 'compilation-message)) (eq pt opt)) - (error ,error compilation-error) + (user-error ,error compilation-error) (setq pt ,limit))) ;; prop 'compilation-message usually has 2 changes, on and off, so ;; re-search if off (or (setq msg (get-text-property pt 'compilation-message)) (if (setq pt (,property-change pt 'compilation-message nil ,limit)) (setq msg (get-text-property pt 'compilation-message))) - (error ,error compilation-error)) + (user-error ,error compilation-error)) (or (< (compilation--message->type msg) compilation-skip-threshold) (if different-file (eq (prog1 last @@ -2660,9 +2660,6 @@ The file-structure looks like this: (if (eq v fs) (remhash k compilation-locs))) compilation-locs))) -(add-to-list 'debug-ignored-errors "\\`No more [-a-z ]+s yet\\'") -(add-to-list 'debug-ignored-errors "\\`Moved past last .*") - ;;; Compatibility with the old compile.el. (defvaralias 'compilation-last-buffer 'next-error-last-buffer) diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index 638410ae627..2664b51eea9 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -554,11 +554,10 @@ Returns t if it visits a tags table, or nil if there are no more in the list." (cond ((eq cont 'same) ;; Use the ambient value of tags-file-name. (or tags-file-name - (error "%s" - (substitute-command-keys - (concat "No tags table in use; " - "use \\[visit-tags-table] to select one"))))) - + (user-error "%s" + (substitute-command-keys + (concat "No tags table in use; " + "use \\[visit-tags-table] to select one"))))) ((eq t cont) ;; Find the next table. (if (tags-next-table) @@ -566,7 +565,6 @@ Returns t if it visits a tags table, or nil if there are no more in the list." (while (and (not (or (get-file-buffer tags-file-name) (file-exists-p tags-file-name))) (tags-next-table))))) - (t ;; Pick a table out of our hat. (tags-table-check-computed-list) ;Get it up to date, we might use it. @@ -706,7 +704,8 @@ Returns t if it visits a tags table, or nil if there are no more in the list." (kill-local-variable 'tags-file-name) (if (eq local-tags-file-name tags-file-name) (setq tags-file-name nil)) - (error "File %s is not a valid tags table" local-tags-file-name))))) + (user-error "File %s is not a valid tags table" + local-tags-file-name))))) (defun tags-reset-tags-tables () "Reset tags state to cancel effect of any previous \\[visit-tags-table] or \\[find-tag]." @@ -831,7 +830,7 @@ If no tags table is loaded, do nothing and return nil." (tags-lazy-completion-table) nil nil nil nil default))) (if (equal spec "") - (or default (error "There is no default tag")) + (or default (user-error "There is no default tag")) spec))) (defvar last-tag nil @@ -886,7 +885,7 @@ See documentation of variable `tags-file-name'." (if (eq '- next-p) ;; Pop back to a previous location. (if (ring-empty-p tags-location-ring) - (error "No previous tag locations") + (user-error "No previous tag locations") (let ((marker (ring-remove tags-location-ring 0))) (prog1 ;; Move to the saved location. @@ -1150,8 +1149,8 @@ error message." (set-marker (car tag-lines-already-matched) nil nil) (setq tag-lines-already-matched (cdr tag-lines-already-matched))) (set-marker match-marker nil nil) - (error "No %stags %s %s" (if first-search "" "more ") - matching pattern)) + (user-error "No %stags %s %s" (if first-search "" "more ") + matching pattern)) ;; Found a tag; extract location info. (beginning-of-line) @@ -1391,8 +1390,8 @@ hits the start of file." offset (* 3 offset))) ; expand search window (or found (re-search-forward pat nil t) - (error "Rerun etags: `%s' not found in %s" - pat buffer-file-name))) + (user-error "Rerun etags: `%s' not found in %s" + pat buffer-file-name))) ;; Position point at the right place ;; if the search string matched an extra Ctrl-m at the beginning. (and (eq selective-display t) @@ -1742,7 +1741,7 @@ if the file was newly read in, the value is the filename." (and novisit (get-buffer " *next-file*") (kill-buffer " *next-file*")) - (error "All files processed")) + (user-error "All files processed")) (let* ((next (car next-file-list)) (buffer (get-file-buffer next)) (new (not buffer))) @@ -1775,9 +1774,9 @@ if the file was newly read in, the value is the filename." "Form for `tags-loop-continue' to eval to change one file.") (defvar tags-loop-scan - '(error "%s" - (substitute-command-keys - "No \\[tags-search] or \\[tags-query-replace] in progress")) + '(user-error "%s" + (substitute-command-keys + "No \\[tags-search] or \\[tags-query-replace] in progress")) "Form for `tags-loop-continue' to eval to scan one file. If it returns non-nil, this file needs processing by evalling \`tags-loop-operate'. Otherwise, move on to the next file.") @@ -1937,7 +1936,7 @@ directory specification." (if (funcall list-tags-function file) (setq gotany t))) (or gotany - (error "File %s not in current tags tables" file))))) + (user-error "File %s not in current tags tables" file))))) (with-current-buffer "*Tags List*" (require 'apropos) (with-no-warnings @@ -2067,28 +2066,15 @@ for \\[find-tag] (which see)." (interactive) (or tags-table-list tags-file-name - (error "%s" - (substitute-command-keys - "No tags table loaded; try \\[visit-tags-table]"))) + (user-error "%s" + (substitute-command-keys + "No tags table loaded; try \\[visit-tags-table]"))) (let ((comp-data (tags-completion-at-point-function))) (if (null comp-data) - (error "Nothing to complete") + (user-error "Nothing to complete") (completion-in-region (car comp-data) (cadr comp-data) (nth 2 comp-data) (plist-get (nthcdr 3 comp-data) :predicate))))) - -(dolist (x '("^No tags table in use; use .* to select one$" - "^There is no default tag$" - "^No previous tag locations$" - "^File .* is not a valid tags table$" - "^No \\(more \\|\\)tags \\(matching\\|containing\\) " - "^Rerun etags: `.*' not found in " - "^All files processed$" - "^No .* or .* in progress$" - "^File .* not in current tags tables$" - "^No tags table loaded" - "^Nothing to complete$")) - (add-to-list 'debug-ignored-errors x)) (provide 'etags) diff --git a/lisp/simple.el b/lisp/simple.el index 3d8a3a38dbd..2b7d5580ba2 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -1465,7 +1465,7 @@ See also `minibuffer-history-case-insensitive-variables'." (list (if (string= regexp "") (if minibuffer-history-search-history (car minibuffer-history-search-history) - (error "No previous history search regexp")) + (user-error "No previous history search regexp")) regexp) (prefix-numeric-value current-prefix-arg)))) (unless (zerop n) @@ -1491,9 +1491,9 @@ See also `minibuffer-history-case-insensitive-variables'." (setq prevpos pos) (setq pos (min (max 1 (+ pos (if (< n 0) -1 1))) (length history))) (when (= pos prevpos) - (error (if (= pos 1) - "No later matching history item" - "No earlier matching history item"))) + (user-error (if (= pos 1) + "No later matching history item" + "No earlier matching history item"))) (setq match-string (if (eq minibuffer-history-sexp-flag (minibuffer-depth)) (let ((print-level nil)) @@ -1536,7 +1536,7 @@ makes the search case-sensitive." (list (if (string= regexp "") (if minibuffer-history-search-history (car minibuffer-history-search-history) - (error "No previous history search regexp")) + (user-error "No previous history search regexp")) regexp) (prefix-numeric-value current-prefix-arg)))) (previous-matching-history-element regexp (- n))) @@ -1595,11 +1595,11 @@ The argument NABS specifies the absolute history position." (setq minibuffer-text-before-history (minibuffer-contents-no-properties))) (if (< nabs minimum) - (if minibuffer-default - (error "End of defaults; no next item") - (error "End of history; no default available"))) + (user-error (if minibuffer-default + "End of defaults; no next item" + "End of history; no default available"))) (if (> nabs (length (symbol-value minibuffer-history-variable))) - (error "Beginning of history; no preceding item")) + (user-error "Beginning of history; no preceding item")) (unless (memq last-command '(next-history-element previous-history-element)) (let ((prompt-end (minibuffer-prompt-end))) @@ -1945,8 +1945,8 @@ Some change-hooks test this variable to do something different.") Call `undo-start' to get ready to undo recent changes, then call `undo-more' one or more times to undo them." (or (listp pending-undo-list) - (error (concat "No further undo information" - (and undo-in-region " for region")))) + (user-error (concat "No further undo information" + (and undo-in-region " for region")))) (let ((undo-in-progress t)) ;; Note: The following, while pulling elements off ;; `pending-undo-list' will call primitive change functions which @@ -1972,7 +1972,7 @@ If BEG and END are specified, then only undo elements that apply to text between BEG and END are used; other undo elements are ignored. If BEG and END are nil, all undo elements are used." (if (eq buffer-undo-list t) - (error "No undo information in this buffer")) + (user-error "No undo information in this buffer")) (setq pending-undo-list (if (and beg end (not (= beg end))) (undo-make-selective-list (min beg end) (max beg end)) @@ -3244,10 +3244,6 @@ move the yanking point; just return the Nth kill forward." :type 'boolean :group 'killing) -(put 'text-read-only 'error-conditions - '(text-read-only buffer-read-only error)) -(put 'text-read-only 'error-message (purecopy "Text is read-only")) - (defun kill-region (beg end &optional yank-handler) "Kill (\"cut\") text between point and mark. This deletes the text from the buffer and saves it in the kill ring. diff --git a/lisp/subr.el b/lisp/subr.el index 1f9f3aee9fa..8cfb1eeea16 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -274,6 +274,17 @@ for the sake of consistency." (signal 'error (list (apply 'format args))))) (set-advertised-calling-convention 'error '(string &rest args) "23.1") +(defun user-error (format &rest args) + "Signal a pilot error, making error message by passing all args to `format'. +In Emacs, the convention is that error messages start with a capital +letter but *do not* end with a period. Please follow this convention +for the sake of consistency. +This is just like `error' except that `user-error's are expected to be the +result of an incorrect manipulation on the part of the user, rather than the +result of an actual problem." + (while t + (signal 'user-error (list (apply #'format format args))))) + ;; We put this here instead of in frame.el so that it's defined even on ;; systems where frame.el isn't loaded. (defun frame-configuration-p (object) diff --git a/lisp/vc/smerge-mode.el b/lisp/vc/smerge-mode.el index d2881b40ad0..3db1f669d63 100644 --- a/lisp/vc/smerge-mode.el +++ b/lisp/vc/smerge-mode.el @@ -342,12 +342,11 @@ Can be nil if the style is undecided, or else: )))) (defvar smerge-resolve-function - (lambda () (error "Don't know how to resolve")) + (lambda () (user-error "Don't know how to resolve")) "Mode-specific merge function. The function is called with zero or one argument (non-nil if the resolution function should only apply safe heuristics) and with the match data set according to `smerge-match-conflict'.") -(add-to-list 'debug-ignored-errors "Don't know how to resolve") (defvar smerge-text-properties `(help-echo "merge conflict: mouse-3 shows a menu" @@ -626,7 +625,7 @@ major modes. Uses `smerge-resolve-function' to do the actual work." (set-match-data md) (smerge-keep-n choice)) (t - (error "Don't know how to resolve")))) + (user-error "Don't know how to resolve")))) (if (buffer-name buf) (kill-buffer buf)) (if m (delete-file m)) (if b (delete-file b)) @@ -810,9 +809,7 @@ An error is raised if not inside a conflict." (when base-start (1- base-start)) base-start (1- other-start) other-start)) t) - (search-failed (error "Point not in conflict region"))))) - -(add-to-list 'debug-ignored-errors "Point not in conflict region") + (search-failed (user-error "Point not in conflict region"))))) (defun smerge-conflict-overlay (pos) "Return the conflict overlay at POS if any." diff --git a/lisp/window.el b/lisp/window.el index 9557dbf057e..a650c5602ba 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -5094,11 +5094,11 @@ Return the buffer switched to." ((eq buffer (window-buffer))) ((window-minibuffer-p) (if force-same-window - (error "Cannot switch buffers in minibuffer window") + (user-error "Cannot switch buffers in minibuffer window") (pop-to-buffer buffer norecord))) ((eq (window-dedicated-p) t) (if force-same-window - (error "Cannot switch buffers in a dedicated window") + (user-error "Cannot switch buffers in a dedicated window") (pop-to-buffer buffer norecord))) (t (set-window-buffer nil buffer))) diff --git a/src/ChangeLog b/src/ChangeLog index 2c2902e937a..8063c8d8166 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,13 @@ +2012-05-04 Stefan Monnier + + * data.c (PUT_ERROR): New macro. + (syms_of_data): Use it. Add new error type `user-error'. + * undo.c (user_error): New function. + (Fprimitive_undo): Use it. + * print.c (print_error_message): Adjust print style for `user-error'. + * keyboard.c (user_error): New function. + (Fexit_recursive_edit, Fabort_recursive_edit): Use it. + 2012-05-03 Paul Eggert Do not limit current-time-string to years 1000..9999. @@ -19,8 +29,8 @@ localtime/gmtime, but also accessing these functions' results including their tm_zone values if any, and any related TZ setting. (format_time_string): Last arg is now struct tm *, not struct tm **, - so that the struct tm is saved in the critical section. All - callers changed. Simplify allocation of initial buffer, partly + so that the struct tm is saved in the critical section. + All callers changed. Simplify allocation of initial buffer, partly motivated by the fact that memory allocation needs to be outside the critical section. diff --git a/src/data.c b/src/data.c index bd1d89992cb..feacea2c08b 100644 --- a/src/data.c +++ b/src/data.c @@ -51,7 +51,7 @@ along with GNU Emacs. If not, see . */ Lisp_Object Qnil, Qt, Qquote, Qlambda, Qunbound; static Lisp_Object Qsubr; Lisp_Object Qerror_conditions, Qerror_message, Qtop_level; -Lisp_Object Qerror, Qquit, Qargs_out_of_range; +Lisp_Object Qerror, Quser_error, Qquit, Qargs_out_of_range; static Lisp_Object Qwrong_type_argument; Lisp_Object Qvoid_variable, Qvoid_function; static Lisp_Object Qcyclic_function_indirection; @@ -2937,6 +2937,7 @@ syms_of_data (void) DEFSYM (Qtop_level, "top-level"); DEFSYM (Qerror, "error"); + DEFSYM (Quser_error, "user-error"); DEFSYM (Qquit, "quit"); DEFSYM (Qwrong_type_argument, "wrong-type-argument"); DEFSYM (Qargs_out_of_range, "args-out-of-range"); @@ -3004,102 +3005,42 @@ syms_of_data (void) Fput (Qerror, Qerror_message, make_pure_c_string ("error")); - Fput (Qquit, Qerror_conditions, - pure_cons (Qquit, Qnil)); - Fput (Qquit, Qerror_message, - make_pure_c_string ("Quit")); - - Fput (Qwrong_type_argument, Qerror_conditions, - pure_cons (Qwrong_type_argument, error_tail)); - Fput (Qwrong_type_argument, Qerror_message, - make_pure_c_string ("Wrong type argument")); - - Fput (Qargs_out_of_range, Qerror_conditions, - pure_cons (Qargs_out_of_range, error_tail)); - Fput (Qargs_out_of_range, Qerror_message, - make_pure_c_string ("Args out of range")); - - Fput (Qvoid_function, Qerror_conditions, - pure_cons (Qvoid_function, error_tail)); - Fput (Qvoid_function, Qerror_message, - make_pure_c_string ("Symbol's function definition is void")); - - Fput (Qcyclic_function_indirection, Qerror_conditions, - pure_cons (Qcyclic_function_indirection, error_tail)); - Fput (Qcyclic_function_indirection, Qerror_message, - make_pure_c_string ("Symbol's chain of function indirections contains a loop")); - - Fput (Qcyclic_variable_indirection, Qerror_conditions, - pure_cons (Qcyclic_variable_indirection, error_tail)); - Fput (Qcyclic_variable_indirection, Qerror_message, - make_pure_c_string ("Symbol's chain of variable indirections contains a loop")); - +#define PUT_ERROR(sym, tail, msg) \ + Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \ + Fput (sym, Qerror_message, make_pure_c_string (msg)) + + PUT_ERROR (Qquit, Qnil, "Quit"); + + PUT_ERROR (Quser_error, error_tail, ""); + PUT_ERROR (Qwrong_type_argument, error_tail, "Wrong type argument"); + PUT_ERROR (Qargs_out_of_range, error_tail, "Args out of range"); + PUT_ERROR (Qvoid_function, error_tail, + "Symbol's function definition is void"); + PUT_ERROR (Qcyclic_function_indirection, error_tail, + "Symbol's chain of function indirections contains a loop"); + PUT_ERROR (Qcyclic_variable_indirection, error_tail, + "Symbol's chain of variable indirections contains a loop"); DEFSYM (Qcircular_list, "circular-list"); - Fput (Qcircular_list, Qerror_conditions, - pure_cons (Qcircular_list, error_tail)); - Fput (Qcircular_list, Qerror_message, - make_pure_c_string ("List contains a loop")); - - Fput (Qvoid_variable, Qerror_conditions, - pure_cons (Qvoid_variable, error_tail)); - Fput (Qvoid_variable, Qerror_message, - make_pure_c_string ("Symbol's value as variable is void")); - - Fput (Qsetting_constant, Qerror_conditions, - pure_cons (Qsetting_constant, error_tail)); - Fput (Qsetting_constant, Qerror_message, - make_pure_c_string ("Attempt to set a constant symbol")); - - Fput (Qinvalid_read_syntax, Qerror_conditions, - pure_cons (Qinvalid_read_syntax, error_tail)); - Fput (Qinvalid_read_syntax, Qerror_message, - make_pure_c_string ("Invalid read syntax")); - - Fput (Qinvalid_function, Qerror_conditions, - pure_cons (Qinvalid_function, error_tail)); - Fput (Qinvalid_function, Qerror_message, - make_pure_c_string ("Invalid function")); - - Fput (Qwrong_number_of_arguments, Qerror_conditions, - pure_cons (Qwrong_number_of_arguments, error_tail)); - Fput (Qwrong_number_of_arguments, Qerror_message, - make_pure_c_string ("Wrong number of arguments")); - - Fput (Qno_catch, Qerror_conditions, - pure_cons (Qno_catch, error_tail)); - Fput (Qno_catch, Qerror_message, - make_pure_c_string ("No catch for tag")); - - Fput (Qend_of_file, Qerror_conditions, - pure_cons (Qend_of_file, error_tail)); - Fput (Qend_of_file, Qerror_message, - make_pure_c_string ("End of file during parsing")); + PUT_ERROR (Qcircular_list, error_tail, "List contains a loop"); + PUT_ERROR (Qvoid_variable, error_tail, "Symbol's value as variable is void"); + PUT_ERROR (Qsetting_constant, error_tail, + "Attempt to set a constant symbol"); + PUT_ERROR (Qinvalid_read_syntax, error_tail, "Invalid read syntax"); + PUT_ERROR (Qinvalid_function, error_tail, "Invalid function"); + PUT_ERROR (Qwrong_number_of_arguments, error_tail, + "Wrong number of arguments"); + PUT_ERROR (Qno_catch, error_tail, "No catch for tag"); + PUT_ERROR (Qend_of_file, error_tail, "End of file during parsing"); arith_tail = pure_cons (Qarith_error, error_tail); - Fput (Qarith_error, Qerror_conditions, - arith_tail); - Fput (Qarith_error, Qerror_message, - make_pure_c_string ("Arithmetic error")); - - Fput (Qbeginning_of_buffer, Qerror_conditions, - pure_cons (Qbeginning_of_buffer, error_tail)); - Fput (Qbeginning_of_buffer, Qerror_message, - make_pure_c_string ("Beginning of buffer")); - - Fput (Qend_of_buffer, Qerror_conditions, - pure_cons (Qend_of_buffer, error_tail)); - Fput (Qend_of_buffer, Qerror_message, - make_pure_c_string ("End of buffer")); - - Fput (Qbuffer_read_only, Qerror_conditions, - pure_cons (Qbuffer_read_only, error_tail)); - Fput (Qbuffer_read_only, Qerror_message, - make_pure_c_string ("Buffer is read-only")); - - Fput (Qtext_read_only, Qerror_conditions, - pure_cons (Qtext_read_only, error_tail)); - Fput (Qtext_read_only, Qerror_message, - make_pure_c_string ("Text is read-only")); + Fput (Qarith_error, Qerror_conditions, arith_tail); + Fput (Qarith_error, Qerror_message, make_pure_c_string ("Arithmetic error")); + + PUT_ERROR (Qbeginning_of_buffer, error_tail, "Beginning of buffer"); + PUT_ERROR (Qend_of_buffer, error_tail, "End of buffer"); + PUT_ERROR (Qbuffer_read_only, error_tail, "Buffer is read-only"); + PUT_ERROR (Qtext_read_only, pure_cons (Qbuffer_read_only, error_tail), + "Text is read-only"); DEFSYM (Qrange_error, "range-error"); DEFSYM (Qdomain_error, "domain-error"); @@ -3107,30 +3048,17 @@ syms_of_data (void) DEFSYM (Qoverflow_error, "overflow-error"); DEFSYM (Qunderflow_error, "underflow-error"); - Fput (Qdomain_error, Qerror_conditions, - pure_cons (Qdomain_error, arith_tail)); - Fput (Qdomain_error, Qerror_message, - make_pure_c_string ("Arithmetic domain error")); - - Fput (Qrange_error, Qerror_conditions, - pure_cons (Qrange_error, arith_tail)); - Fput (Qrange_error, Qerror_message, - make_pure_c_string ("Arithmetic range error")); - - Fput (Qsingularity_error, Qerror_conditions, - pure_cons (Qsingularity_error, Fcons (Qdomain_error, arith_tail))); - Fput (Qsingularity_error, Qerror_message, - make_pure_c_string ("Arithmetic singularity error")); - - Fput (Qoverflow_error, Qerror_conditions, - pure_cons (Qoverflow_error, Fcons (Qdomain_error, arith_tail))); - Fput (Qoverflow_error, Qerror_message, - make_pure_c_string ("Arithmetic overflow error")); - - Fput (Qunderflow_error, Qerror_conditions, - pure_cons (Qunderflow_error, Fcons (Qdomain_error, arith_tail))); - Fput (Qunderflow_error, Qerror_message, - make_pure_c_string ("Arithmetic underflow error")); + PUT_ERROR (Qdomain_error, arith_tail, "Arithmetic domain error"); + + PUT_ERROR (Qrange_error, arith_tail, "Arithmetic range error"); + + PUT_ERROR (Qsingularity_error, Fcons (Qdomain_error, arith_tail), + "Arithmetic singularity error"); + + PUT_ERROR (Qoverflow_error, Fcons (Qdomain_error, arith_tail), + "Arithmetic overflow error"); + PUT_ERROR (Qunderflow_error, Fcons (Qdomain_error, arith_tail), + "Arithmetic underflow error"); staticpro (&Qnil); staticpro (&Qt); diff --git a/src/fileio.c b/src/fileio.c index 69b2c9cb0f2..f09ba2c394c 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -87,17 +87,17 @@ along with GNU Emacs. If not, see . */ #define FILE_SYSTEM_CASE(filename) (filename) #endif -/* Nonzero during writing of auto-save files */ +/* Nonzero during writing of auto-save files. */ static int auto_saving; -/* Nonzero umask during creation of auto-save directories */ +/* Nonzero umask during creation of auto-save directories. */ static int auto_saving_dir_umask; /* Set by auto_save_1 to mode of original file so Fwrite_region will create - a new file with the same mode as the original */ + a new file with the same mode as the original. */ static int auto_save_mode_bits; -/* Set by auto_save_1 if an error occurred during the last auto-save. */ +/* Set by auto_save_1 if an error occurred during the last auto-save. */ static int auto_save_error_occurred; /* The symbol bound to coding-system-for-read when @@ -111,7 +111,7 @@ static Lisp_Object Qauto_save_coding; which gives a list of operations it handles.. */ static Lisp_Object Qoperations; -/* Lisp functions for translating file formats */ +/* Lisp functions for translating file formats. */ static Lisp_Object Qformat_decode, Qformat_annotate_function; /* Lisp function for setting buffer-file-coding-system and the diff --git a/src/keyboard.c b/src/keyboard.c index a1ad1fed325..249e5ee9544 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -1200,6 +1200,12 @@ This also exits all active minibuffers. */) Fthrow (Qtop_level, Qnil); } +static void user_error (const char*) NO_RETURN; +static void user_error (const char *msg) +{ + xsignal1 (Quser_error, build_string (msg)); +} + static Lisp_Object Fexit_recursive_edit (void) NO_RETURN; DEFUN ("exit-recursive-edit", Fexit_recursive_edit, Sexit_recursive_edit, 0, 0, "", doc: /* Exit from the innermost recursive edit or minibuffer. */) @@ -1208,7 +1214,7 @@ DEFUN ("exit-recursive-edit", Fexit_recursive_edit, Sexit_recursive_edit, 0, 0, if (command_loop_level > 0 || minibuf_level > 0) Fthrow (Qexit, Qnil); - error ("No recursive edit is in progress"); + user_error ("No recursive edit is in progress"); } static Lisp_Object Fabort_recursive_edit (void) NO_RETURN; @@ -1219,7 +1225,7 @@ DEFUN ("abort-recursive-edit", Fabort_recursive_edit, Sabort_recursive_edit, 0, if (command_loop_level > 0 || minibuf_level > 0) Fthrow (Qexit, Qt); - error ("No recursive edit is in progress"); + user_error ("No recursive edit is in progress"); } #if defined (HAVE_MOUSE) || defined (HAVE_GPM) diff --git a/src/lisp.h b/src/lisp.h index 16c10f2688c..1f839750609 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2377,7 +2377,7 @@ extern Lisp_Object Qerror, Qquit, Qargs_out_of_range; extern Lisp_Object Qvoid_variable, Qvoid_function; extern Lisp_Object Qinvalid_read_syntax; extern Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch; -extern Lisp_Object Qend_of_file, Qarith_error, Qmark_inactive; +extern Lisp_Object Quser_error, Qend_of_file, Qarith_error, Qmark_inactive; extern Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only; extern Lisp_Object Qtext_read_only; extern Lisp_Object Qinteractive_form; diff --git a/src/print.c b/src/print.c index b8ee44d0d10..c2edde590fe 100644 --- a/src/print.c +++ b/src/print.c @@ -865,7 +865,6 @@ print_error_message (Lisp_Object data, Lisp_Object stream, const char *context, { Lisp_Object errname, errmsg, file_error, tail; struct gcpro gcpro1; - int i; if (context != 0) write_string_1 (context, -1, stream); @@ -893,9 +892,8 @@ print_error_message (Lisp_Object data, Lisp_Object stream, const char *context, } else { - Lisp_Object error_conditions; + Lisp_Object error_conditions = Fget (errname, Qerror_conditions); errmsg = Fget (errname, Qerror_message); - error_conditions = Fget (errname, Qerror_conditions); file_error = Fmemq (Qfile_error, error_conditions); } @@ -909,22 +907,30 @@ print_error_message (Lisp_Object data, Lisp_Object stream, const char *context, if (!NILP (file_error) && CONSP (tail)) errmsg = XCAR (tail), tail = XCDR (tail); - if (STRINGP (errmsg)) - Fprinc (errmsg, stream); - else - write_string_1 ("peculiar error", -1, stream); + { + const char *sep = ": "; - for (i = 0; CONSP (tail); tail = XCDR (tail), i = 1) - { - Lisp_Object obj; + if (!STRINGP (errmsg)) + write_string_1 ("peculiar error", -1, stream); + else if (SCHARS (errmsg)) + Fprinc (errmsg, stream); + else + sep = NULL; - write_string_1 (i ? ", " : ": ", 2, stream); - obj = XCAR (tail); - if (!NILP (file_error) || EQ (errname, Qend_of_file)) - Fprinc (obj, stream); - else - Fprin1 (obj, stream); - } + for (; CONSP (tail); tail = XCDR (tail), sep = ", ") + { + Lisp_Object obj; + + if (sep) + write_string_1 (sep, 2, stream); + obj = XCAR (tail); + if (!NILP (file_error) + || EQ (errname, Qend_of_file) || EQ (errname, Quser_error)) + Fprinc (obj, stream); + else + Fprin1 (obj, stream); + } + } UNGCPRO; } diff --git a/src/undo.c b/src/undo.c index 4041a2adacc..b0acd0c216f 100644 --- a/src/undo.c +++ b/src/undo.c @@ -436,6 +436,13 @@ truncate_undo_list (struct buffer *b) unbind_to (count, Qnil); } + +static void user_error (const char*) NO_RETURN; +static void user_error (const char *msg) +{ + xsignal1 (Quser_error, build_string (msg)); +} + DEFUN ("primitive-undo", Fprimitive_undo, Sprimitive_undo, 2, 2, 0, doc: /* Undo N records from the front of the list LIST. @@ -528,7 +535,7 @@ Return what remains of the list. */) end = Fcdr (cdr); if (XINT (beg) < BEGV || XINT (end) > ZV) - error ("Changes to be undone are outside visible portion of buffer"); + user_error ("Changes to be undone are outside visible portion of buffer"); Fput_text_property (beg, end, prop, val, Qnil); } else if (INTEGERP (car) && INTEGERP (cdr)) @@ -537,7 +544,7 @@ Return what remains of the list. */) if (XINT (car) < BEGV || XINT (cdr) > ZV) - error ("Changes to be undone are outside visible portion of buffer"); + user_error ("Changes to be undone are outside visible portion of buffer"); /* Set point first thing, so that undoing this undo does not send point back to where it is now. */ Fgoto_char (car); @@ -588,14 +595,14 @@ Return what remains of the list. */) if (pos < 0) { if (-pos < BEGV || -pos > ZV) - error ("Changes to be undone are outside visible portion of buffer"); + user_error ("Changes to be undone are outside visible portion of buffer"); SET_PT (-pos); Finsert (1, &membuf); } else { if (pos < BEGV || pos > ZV) - error ("Changes to be undone are outside visible portion of buffer"); + user_error ("Changes to be undone are outside visible portion of buffer"); SET_PT (pos); /* Now that we record marker adjustments -- cgit v1.2.3 From 5342bb062f39a387e9a770b3edef881ee4a72f17 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 4 May 2012 22:05:49 -0400 Subject: * lisp/emacs-lisp/pcase.el (pcase--let*): New function. (pcase--expand, pcase-codegen, pcase--q1): Use it to reduce nesting a bit more. (pcase--split-pred): Be more clever about ruling out overlap between a predicate and some constant pattern. (pcase--q1): Use `null' instead of (eq foo nil). --- lisp/ChangeLog | 7 ++++++ lisp/emacs-lisp/pcase.el | 64 +++++++++++++++++++++++++++++------------------- 2 files changed, 46 insertions(+), 25 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 276cd7fca6f..9780e1265fb 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,12 @@ 2012-05-05 Stefan Monnier + * emacs-lisp/pcase.el (pcase--let*): New function. + (pcase--expand, pcase-codegen, pcase--q1): Use it to reduce nesting + a bit more. + (pcase--split-pred): Be more clever about ruling out overlap between + a predicate and some constant pattern. + (pcase--q1): Use `null' instead of (eq foo nil). + * subr.el (setq-local, defvar-local): New macros. (kbd): Redefine as an alias. (with-selected-window): Leave unrelated frames alone. diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index afbc5df85ce..0d115cc56f5 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -148,6 +148,7 @@ of the form (UPAT EXP)." `(let ,(nreverse bindings) (pcase-let* ,matches ,@body))))) (defmacro pcase-dolist (spec &rest body) + (declare (indent 1)) (if (pcase--trivial-upat-p (car spec)) `(dolist ,spec ,@body) (let ((tmpvar (make-symbol "x"))) @@ -217,10 +218,10 @@ of the form (UPAT EXP)." (cdr case)))) cases)))) (if (null defs) main - `(let ,defs ,main)))) + (pcase--let* defs main)))) (defun pcase-codegen (code vars) - `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars) + `(let* ,(mapcar (lambda (b) (list (car b) (cdr b))) vars) ,@code)) (defun pcase--small-branch-p (code) @@ -255,6 +256,13 @@ of the form (UPAT EXP)." ((memq (car-safe then) '(if cond)) (pcase--if `(not ,test) else then)) (t `(if ,test ,then ,else)))) +;; Again, try and reduce nesting. +(defun pcase--let* (binders body) + (if (eq (car-safe body) 'let*) + `(let* ,(append binders (nth 1 body)) + ,@(nthcdr 2 body)) + `(let* ,binders ,body))) + (defun pcase--upat (qpattern) (cond ((eq (car-safe qpattern) '\,) (cadr qpattern)) @@ -433,26 +441,26 @@ MATCH is the pattern that needs to be matched, of the form: (defun pcase--split-pred (upat pat) ;; FIXME: For predicates like (pred (> a)), two such predicates may ;; actually refer to different variables `a'. - (cond - ((equal upat pat) (cons :pcase--succeed :pcase--fail)) - ((and (eq 'pred (car upat)) - (eq 'pred (car-safe pat)) - (or (member (cons (cadr upat) (cadr pat)) - pcase-mutually-exclusive-predicates) - (member (cons (cadr pat) (cadr upat)) - pcase-mutually-exclusive-predicates))) - (cons :pcase--fail nil)) - ;; ((and (eq 'pred (car upat)) - ;; (eq '\` (car-safe pat)) - ;; (symbolp (cadr upat)) - ;; (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat))) - ;; (get (cadr upat) 'side-effect-free) - ;; (progn (message "Trying predicate %S" (cadr upat)) - ;; (ignore-errors - ;; (funcall (cadr upat) (cadr pat))))) - ;; (message "Simplify pred %S against %S" upat pat) - ;; (cons nil :pcase--fail)) - )) + (let (test) + (cond + ((equal upat pat) (cons :pcase--succeed :pcase--fail)) + ((and (eq 'pred (car upat)) + (eq 'pred (car-safe pat)) + (or (member (cons (cadr upat) (cadr pat)) + pcase-mutually-exclusive-predicates) + (member (cons (cadr pat) (cadr upat)) + pcase-mutually-exclusive-predicates))) + (cons :pcase--fail nil)) + ((and (eq 'pred (car upat)) + (eq '\` (car-safe pat)) + (symbolp (cadr upat)) + (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat))) + (get (cadr upat) 'side-effect-free) + (ignore-errors + (setq test (list (funcall (cadr upat) (cadr pat)))))) + (if (car test) + (cons nil :pcase--fail) + (cons :pcase--fail nil)))))) (defun pcase--fgrep (vars sexp) "Check which of the symbols VARS appear in SEXP." @@ -673,16 +681,22 @@ Otherwise, it defers to REST which is a list of branches of the form ;; The byte-compiler could do that for us, but it would have to pay ;; attention to the `consp' test in order to figure out that car/cdr ;; can't signal errors and our byte-compiler is not that clever. - `(let (,@(if (get syma 'pcase-used) `((,syma (car ,sym)))) + ;; FIXME: Some of those let bindings occur too early (they are used in + ;; `then-body', but only within some sub-branch). + (pcase--let* + `(,@(if (get syma 'pcase-used) `((,syma (car ,sym)))) ,@(if (get symd 'pcase-used) `((,symd (cdr ,sym))))) - ,then-body) + then-body) (pcase--u else-rest)))) ((or (integerp qpat) (symbolp qpat) (stringp qpat)) (let* ((splitrest (pcase--split-rest sym (apply-partially 'pcase--split-equal qpat) rest)) (then-rest (car splitrest)) (else-rest (cdr splitrest))) - (pcase--if `(,(if (stringp qpat) #'equal #'eq) ,sym ',qpat) + (pcase--if (cond + ((stringp qpat) `(equal ,sym ,qpat)) + ((null qpat) `(null ,sym)) + (t `(eq ,sym ',qpat))) (pcase--u1 matches code vars then-rest) (pcase--u else-rest)))) (t (error "Unknown QPattern %s" qpat)))) -- cgit v1.2.3 From f677562b6c90b283d338725992d87a2770848560 Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Sat, 5 May 2012 13:13:27 +0800 Subject: Fix package.el handling of local variables on first line. * lisp/emacs-lisp/package.el (package-buffer-info): Avoid putting local variables into description. --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/package.el | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 7a83c95ec3a..2442582114d 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2012-05-05 Chong Yidong + + * emacs-lisp/package.el (package-buffer-info): Avoid putting local + variables into description. + 2012-05-05 Stefan Monnier * shell.el (shell-completion-vars): Set pcomplete-arg-quote-list like diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 5b158eb994f..73afdb82509 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -943,7 +943,7 @@ If the buffer does not contain a conforming package, signal an error. If there is a package, narrow the buffer to the file's boundaries." (goto-char (point-min)) - (unless (re-search-forward "^;;; \\([^ ]*\\)\\.el --- \\(.*\\)$" nil t) + (unless (re-search-forward "^;;; \\([^ ]*\\)\\.el ---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$" nil t) (error "Packages lacks a file header")) (let ((file-name (match-string-no-properties 1)) (desc (match-string-no-properties 2)) -- cgit v1.2.3 From 25f292cd48febec5f9b133db922b3b0dc32185c3 Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Sun, 6 May 2012 12:05:43 +0800 Subject: * emacs-lisp/package.el (package-built-in-p): Handle `emacs' package. Fixes: debbugs:11410 --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/package.el | 7 +++++-- 2 files changed, 10 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 2442582114d..ad22a25cfd7 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2012-05-06 Chong Yidong + + * emacs-lisp/package.el (package-built-in-p): Handle the `emacs' + package (Bug#11410). + 2012-05-05 Chong Yidong * emacs-lisp/package.el (package-buffer-info): Avoid putting local diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 73afdb82509..4ed8aacf0b6 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -469,8 +469,11 @@ NAME and VERSION are both strings." Optional arg MIN-VERSION, if non-nil, should be a version list specifying the minimum acceptable version." (require 'finder-inf nil t) ; For `package--builtins'. - (let ((elt (assq package package--builtins))) - (and elt (version-list-<= min-version (package-desc-vers (cdr elt)))))) + (if (eq package 'emacs) + (version-list-<= min-version (version-to-list emacs-version)) + (let ((elt (assq package package--builtins))) + (and elt (version-list-<= min-version + (package-desc-vers (cdr elt))))))) ;; This function goes ahead and activates a newer version of a package ;; if an older one was already activated. This is not ideal; we'd at -- cgit v1.2.3 From 6632d361114f2d104b689e2213dce1eb3474de0a Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Sun, 6 May 2012 16:32:37 +0800 Subject: Improvements for Tabulated List mode. * lisp/emacs-lisp/tabulated-list.el (tabulated-list-format): Accept additional plist in column descriptors. (tabulated-list-init-header): Obey it. (tabulated-list-get-entry): New function. (tabulated-list-put-tag): Use it. Use string-width instead of length. (tabulated-list--column-number): New function. (tabulated-list-print): Use it. (tabulated-list-print-col): New function. Set `tabulated-list-column-name' property on each column's text. (tabulated-list-print-entry): Use it. (tabulated-list-delete-entry, tabulated-list-set-col): New functions. (tabulated-list-sort-column): New command. Fixes: debbugs:11337 --- etc/NEWS | 5 + lisp/ChangeLog | 17 +++ lisp/emacs-lisp/tabulated-list.el | 245 +++++++++++++++++++++++++++----------- 3 files changed, 200 insertions(+), 67 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/etc/NEWS b/etc/NEWS index 57c492ffa4c..df386fa7e4f 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -161,6 +161,11 @@ details. The function `notifications-get-capabilities' returns the supported server properties. +** Tabulated List and packages derived from it + +*** New command `tabulated-list-sort-column' bound to `S' sorts column +at point, or the Nth column if a numeric prefix argument is given. + ** Obsolete packages: *** assoc.el diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 134c208e544..b925e47880b 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,20 @@ +2012-05-06 Chong Yidong + + * emacs-lisp/tabulated-list.el (tabulated-list-format): Accept + additional plist in column descriptors. + (tabulated-list-init-header): Obey it. + (tabulated-list-get-entry): New function. + (tabulated-list-put-tag): Use it. Use string-width instead of + length. + (tabulated-list--column-number): New function. + (tabulated-list-print): Use it. + (tabulated-list-print-col): New function. Set + `tabulated-list-column-name' property on each column's text. + (tabulated-list-print-entry): Use it. + (tabulated-list-delete-entry, tabulated-list-set-col): New + functions. + (tabulated-list-sort-column): New command (Bug#11337). + 2012-05-06 Troels Nielsen (tiny change) * progmodes/compile.el (compilation-internal-error-properties): diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 9439fba2b86..bd734a4fbe0 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -22,22 +22,26 @@ ;;; Commentary: -;; This file defines `tabulated-list-mode', a generic major mode for displaying -;; lists of tabulated data, intended for other major modes to inherit from. It -;; provides several utility routines, e.g. for pretty-printing lines of -;; tabulated data to fit into the appropriate columns. +;; This file defines Tabulated List mode, a generic major mode for +;; displaying lists of tabulated data, intended for other major modes +;; to inherit from. It provides several utility routines, e.g. for +;; pretty-printing lines of tabulated data to fit into the appropriate +;; columns. ;; For usage information, see the documentation of `tabulated-list-mode'. -;; This package originated from Tom Tromey's Package Menu mode, extended and -;; generalized to be used by other modes. +;; This package originated from Tom Tromey's Package Menu mode, +;; extended and generalized to be used by other modes. ;;; Code: (defvar tabulated-list-format nil "The format of the current Tabulated List mode buffer. -This should be a vector of elements (NAME WIDTH SORT), where: +This should be a vector of elements (NAME WIDTH SORT . PROPS), +where: - NAME is a string describing the column. + This is the label for the column in the header line. + Different columns must have non-`equal' names. - WIDTH is the width to reserve for the column. For the final element, its numerical value is ignored. - SORT specifies how to sort entries by this column. @@ -45,7 +49,11 @@ This should be a vector of elements (NAME WIDTH SORT), where: If t, sort by comparing the string value printed in the column. Otherwise, it should be a predicate function suitable for `sort', accepting arguments with the same form as the elements - of `tabulated-list-entries'.") + of `tabulated-list-entries'. + - PROPS is a plist of additional column properties. + Currently supported properties are: + - `:pad-right': Number of additional padding spaces to the + right of the column (defaults to 1 if omitted).") (make-variable-buffer-local 'tabulated-list-format) (defvar tabulated-list-entries nil @@ -95,12 +103,18 @@ NAME is a string matching one of the column names in non-nil, means to invert the resulting sort.") (make-variable-buffer-local 'tabulated-list-sort-key) -(defun tabulated-list-get-id (&optional pos) - "Obtain the entry ID of the Tabulated List mode entry at POS. -This is an ID object from `tabulated-list-entries', or nil. +(defsubst tabulated-list-get-id (&optional pos) + "Return the entry ID of the Tabulated List entry at POS. +The value is an ID object from `tabulated-list-entries', or nil. POS, if omitted or nil, defaults to point." (get-text-property (or pos (point)) 'tabulated-list-id)) +(defsubst tabulated-list-get-entry (&optional pos) + "Return the Tabulated List entry at POS. +The value is a vector of column descriptors, or nil if there is +no entry at POS. POS, if omitted or nil, defaults to point." + (get-text-property (or pos (point)) 'tabulated-list-entry)) + (defun tabulated-list-put-tag (tag &optional advance) "Put TAG in the padding area of the current line. TAG should be a string, with length <= `tabulated-list-padding'. @@ -111,16 +125,16 @@ If ADVANCE is non-nil, move forward by one line afterwards." (error "Unable to tag the current line")) (save-excursion (beginning-of-line) - (when (get-text-property (point) 'tabulated-list-id) + (when (tabulated-list-get-entry) (let ((beg (point)) (inhibit-read-only t)) (forward-char tabulated-list-padding) (insert-and-inherit - (if (<= (length tag) tabulated-list-padding) - (concat tag - (make-string (- tabulated-list-padding (length tag)) - ?\s)) - (substring tag 0 tabulated-list-padding))) + (let ((width (string-width tag))) + (if (<= width tabulated-list-padding) + (concat tag + (make-string (- tabulated-list-padding width) ?\s)) + (truncate-string-to-width tag tabulated-list-padding)))) (delete-region beg (+ beg tabulated-list-padding))))) (if advance (forward-line))) @@ -130,6 +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 [follow-link] 'mouse-face) (define-key map [mouse-2] 'mouse-select-window) map) @@ -154,7 +169,7 @@ If ADVANCE is non-nil, move forward by one line afterwards." (defun tabulated-list-init-header () "Set up header line for the Tabulated List buffer." - (let ((x tabulated-list-padding) + (let ((x (max tabulated-list-padding 0)) (button-props `(help-echo "Click to sort by column" mouse-face highlight keymap ,tabulated-list-sort-button-map)) @@ -163,9 +178,11 @@ If ADVANCE is non-nil, move forward by one line afterwards." (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)) (width (nth 1 col)) - (label (car col))) - (setq x (+ x 1 width)) + (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))) @@ -190,11 +207,12 @@ If ADVANCE is non-nil, move forward by one line afterwards." (t (apply 'propertize label 'tabulated-list-column-name (car col) button-props))) - cols)) - (push (propertize " " - 'display (list 'space :align-to x) - 'face 'fixed-pitch) - cols)) + cols) + (if (> pad-right 0) + (push (propertize " " + 'display `(space :align-to ,x) + 'face 'fixed-pitch) + cols)))) (setq header-line-format (mapconcat 'identity (nreverse cols) "")))) (defun tabulated-list-revert (&rest ignored) @@ -206,6 +224,17 @@ It runs `tabulated-list-revert-hook', then calls `tabulated-list-print'." (run-hooks 'tabulated-list-revert-hook) (tabulated-list-print t)) +(defun tabulated-list--column-number (name) + (let ((len (length tabulated-list-format)) + (n 0) + found) + (while (and (< n len) (null found)) + (if (equal (car (aref tabulated-list-format n)) name) + (setq found n)) + (setq n (1+ n))) + (or found + (error "No column named %s" name)))) + (defun tabulated-list-print (&optional remember-pos) "Populate the current Tabulated List mode buffer. This sorts the `tabulated-list-entries' list if sorting is @@ -224,18 +253,13 @@ to the entry with the same ID element as the current line." (setq saved-col (current-column))) (erase-buffer) ;; Sort the buffers, if necessary. - (when tabulated-list-sort-key - (let ((sort-column (car tabulated-list-sort-key)) - (len (length tabulated-list-format)) - (n 0) - sorter) - ;; Which column is to be sorted? - (while (and (< n len) - (not (equal (car (aref tabulated-list-format n)) - sort-column))) - (setq n (1+ n))) - (when (< n len) - (setq sorter (nth 2 (aref tabulated-list-format n))) + (when (and tabulated-list-sort-key + (car tabulated-list-sort-key)) + (let* ((sort-column (car tabulated-list-sort-key)) + (n (tabulated-list--column-number sort-column)) + (sorter (nth 2 (aref tabulated-list-format n)))) + ;; Is the specified column sortable? + (when sorter (when (eq sorter t) (setq sorter ; Default sorter checks column N: (lambda (A B) @@ -267,31 +291,105 @@ to the entry with the same ID element as the current line." This is the default `tabulated-list-printer' function. ID is a Lisp object identifying the entry to print, and COLS is a vector of column descriptors." - (let ((beg (point)) - (x (max tabulated-list-padding 0)) - (len (length tabulated-list-format))) + (let ((beg (point)) + (x (max tabulated-list-padding 0)) + (ncols (length tabulated-list-format)) + (inhibit-read-only t)) (if (> tabulated-list-padding 0) (insert (make-string x ?\s))) - (dotimes (n len) - (let* ((format (aref tabulated-list-format n)) - (desc (aref cols n)) - (width (nth 1 format)) - (label (if (stringp desc) desc (car desc))) - (help-echo (concat (car format) ": " label))) - ;; Truncate labels if necessary (except last column). - (and (< (1+ n) len) - (> (string-width label) width) - (setq label (truncate-string-to-width label width nil nil t))) - (setq label (bidi-string-mark-left-to-right label)) - (if (stringp desc) - (insert (propertize label 'help-echo help-echo)) - (apply 'insert-text-button label (cdr desc))) - (setq x (+ x 1 width))) - ;; No need to append any spaces if this is the last column. - (if (< (1+ n) len) - (indent-to x 1))) + (dotimes (n ncols) + (setq x (tabulated-list-print-col n (aref cols n) x))) (insert ?\n) - (put-text-property beg (point) 'tabulated-list-id id))) + (put-text-property beg (point) 'tabulated-list-id id) + (put-text-property beg (point) 'tabulated-list-entry cols))) + +(defun tabulated-list-print-col (n col-desc x) + "Insert a specified Tabulated List entry at point. +N is the column number, COL-DESC is a column descriptor \(see +`tabulated-list-entries'), and X is the column number at point. +Return the column number after insertion." + (let* ((format (aref tabulated-list-format n)) + (name (nth 0 format)) + (width (nth 1 format)) + (props (nthcdr 3 format)) + (pad-right (or (plist-get props :pad-right) 1)) + (label (if (stringp col-desc) col-desc (car col-desc))) + (help-echo (concat (car format) ": " label)) + (opoint (point)) + (not-last-col (< (1+ n) (length tabulated-list-format)))) + ;; Truncate labels if necessary (except last column). + (and not-last-col + (> (string-width label) width) + (setq label (truncate-string-to-width label width nil nil t))) + (setq label (bidi-string-mark-left-to-right label)) + (if (stringp col-desc) + (insert (propertize label 'help-echo help-echo)) + (apply 'insert-text-button label (cdr col-desc))) + (setq x (+ x pad-right width)) + ;; No need to append any spaces if this is the last column. + (if not-last-col + (indent-to x pad-right)) + (put-text-property opoint (point) 'tabulated-list-column-name name) + x)) + +(defun tabulated-list-delete-entry () + "Delete the Tabulated List entry at point. +Return a list (ID COLS), where ID is the ID of the deleted entry +and COLS is a vector of its column descriptors. Move point to +the beginning of the deleted entry. Return nil if there is no +entry at point. + +This function only changes the buffer contents; it does not alter +`tabulated-list-entries'." + ;; Assume that each entry occupies one line. + (let* ((id (tabulated-list-get-id)) + (cols (tabulated-list-get-entry)) + (inhibit-read-only t)) + (when cols + (delete-region (line-beginning-position) (1+ (line-end-position))) + (list id cols)))) + +(defun tabulated-list-set-col (col desc &optional change-entry-data) + "Change the Tabulated List entry at point, setting COL to DESC. +COL is the column number to change, or the name of the column to change. +DESC is the new column descriptor, which is inserted via +`tabulated-list-print-col'. + +If CHANGE-ENTRY-DATA is non-nil, modify the underlying entry data +by setting the appropriate slot of the vector originally used to +print this entry. If `tabulated-list-entries' has a list value, +this is the vector stored within it." + (let* ((opoint (point)) + (eol (line-end-position)) + (pos (line-beginning-position)) + (id (tabulated-list-get-id pos)) + (entry (tabulated-list-get-entry pos)) + (prop 'tabulated-list-column-name) + (inhibit-read-only t) + name) + (cond ((numberp col) + (setq name (car (aref tabulated-list-format col)))) + ((stringp col) + (setq name col + col (tabulated-list--column-number col))) + (t + (error "Invalid column %s" col))) + (unless entry + (error "No Tabulated List entry at position %s" opoint)) + (unless (equal (get-text-property pos prop) name) + (while (and (setq pos + (next-single-property-change pos prop nil eol)) + (< pos eol) + (not (equal (get-text-property pos prop) name))))) + (when (< pos eol) + (delete-region pos (next-single-property-change pos prop nil eol)) + (goto-char pos) + (tabulated-list-print-col col desc (current-column)) + (if change-entry-data + (aset entry col desc)) + (put-text-property pos (point) 'tabulated-list-id id) + (put-text-property pos (point) 'tabulated-list-entry entry) + (goto-char opoint)))) (defun tabulated-list-col-sort (&optional e) "Sort Tabulated List entries by the column of the mouse click E." @@ -302,14 +400,27 @@ of column descriptors." 'tabulated-list-column-name (car obj)))) (with-current-buffer (window-buffer (posn-window pos)) - (when (derived-mode-p 'tabulated-list-mode) - ;; Flip the sort order on a second click. - (if (equal name (car tabulated-list-sort-key)) - (setcdr tabulated-list-sort-key - (not (cdr tabulated-list-sort-key))) - (setq tabulated-list-sort-key (cons name nil))) - (tabulated-list-init-header) - (tabulated-list-print t))))) + (tabulated-list--sort-by-column-name name)))) + +(defun tabulated-list-sort-column (&optional n) + "Sort Tabulated List entries by the column at point. +With a numeric prefix argument N, sort the Nth column." + (interactive "P") + (let ((name (if n + (car (aref tabulated-list-format n)) + (get-text-property (point) + 'tabulated-list-column-name)))) + (tabulated-list--sort-by-column-name name))) + +(defun tabulated-list--sort-by-column-name (name) + (when (derived-mode-p 'tabulated-list-mode) + ;; Flip the sort order on a second click. + (if (equal name (car tabulated-list-sort-key)) + (setcdr tabulated-list-sort-key + (not (cdr tabulated-list-sort-key))) + (setq tabulated-list-sort-key (cons name nil))) + (tabulated-list-init-header) + (tabulated-list-print t))) ;;; The mode definition: -- cgit v1.2.3 From e129292c44b6392adadb27bbd4bce94893316ff9 Mon Sep 17 00:00:00 2001 From: Christopher Schmidt Date: Sun, 6 May 2012 11:38:30 -0400 Subject: * lisp/emacs-lisp/cl-macs.el (cl-expr-contains): Handle cons cells whose cdr is not a cons cell correctly. Fixes: debbugs:11038 --- lisp/ChangeLog | 17 +++++++++++------ lisp/emacs-lisp/cl-macs.el | 7 ++++++- 2 files changed, 17 insertions(+), 7 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 929451a85ed..afa4ae803f9 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,18 +1,23 @@ +2012-05-06 Christopher Schmidt + + * emacs-lisp/cl-macs.el (cl-expr-contains): Handle cons cells + whose cdr is not a cons cell correctly (bug#11038). + 2012-05-06 Chong Yidong - * emacs-lisp/tabulated-list.el (tabulated-list-format): Accept - additional plist in column descriptors. + * emacs-lisp/tabulated-list.el (tabulated-list-format): + Accept additional plist in column descriptors. (tabulated-list-init-header): Obey it. (tabulated-list-get-entry): New function. (tabulated-list-put-tag): Use it. Use string-width instead of length. (tabulated-list--column-number): New function. (tabulated-list-print): Use it. - (tabulated-list-print-col): New function. Set - `tabulated-list-column-name' property on each column's text. + (tabulated-list-print-col): New function. + Set `tabulated-list-column-name' property on each column's text. (tabulated-list-print-entry): Use it. - (tabulated-list-delete-entry, tabulated-list-set-col): New - functions. + (tabulated-list-delete-entry, tabulated-list-set-col): + New functions. (tabulated-list-sort-column): New command (Bug#11337). * buff-menu.el (list-buffers): Move C-x C-b binding from diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 35cda8cfcf6..8050da400fe 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -143,11 +143,16 @@ ;;; Count number of times X refers to Y. Return nil for 0 times. (defun cl-expr-contains (x y) + ;; FIXME: This is naive, and it will count Y as referred twice in + ;; (let ((Y 1)) Y) even though it should be 0. Also it is often called on + ;; non-macroexpanded code, so it may also miss some occurrences that would + ;; only appear in the expanded code. (cond ((equal y x) 1) ((and (consp x) (not (memq (car-safe x) '(quote function function*)))) (let ((sum 0)) - (while x + (while (consp x) (setq sum (+ sum (or (cl-expr-contains (pop x) y) 0)))) + (setq sum (+ sum (or (cl-expr-contains x y) 0))) (and (> sum 0) sum))) (t nil))) -- 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') 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 1241b724c80c73731c7e5710a98886b745a211a8 Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Mon, 7 May 2012 13:37:38 +0800 Subject: Restore Buffer-menu-use-header-line functionality. * lisp/emacs-lisp/tabulated-list.el: Add no-header-line alternative. (tabulated-list-use-header-line): New var. (tabulated-list-init-header): Use it. (tabulated-list-print-fake-header): New function. (tabulated-list-print): Use it. (tabulated-list-sort-button-map): Add non-header-line commands. (tabulated-list-init-header): Add column name property to basic labels as well. (tabulated-list-col-sort): Handle non-header-line button case. (tabulated-list--sort-by-column-name): Fix a corner case. * lisp/buff-menu.el (list-buffers--refresh): Handle Buffer-menu-use-header-line. --- lisp/ChangeLog | 16 +++++++++++++ lisp/buff-menu.el | 1 + lisp/emacs-lisp/tabulated-list.el | 48 +++++++++++++++++++++++++++++++-------- 3 files changed, 55 insertions(+), 10 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 149c43fc9a7..1db2fb1c715 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,19 @@ +2012-05-07 Chong Yidong + + * emacs-lisp/tabulated-list.el: Add no-header-line alternative. + (tabulated-list-use-header-line): New var. + (tabulated-list-init-header): Use it. + (tabulated-list-print-fake-header): New function. + (tabulated-list-print): Use it. + (tabulated-list-sort-button-map): Add non-header-line commands. + (tabulated-list-init-header): Add column name property to basic + labels as well. + (tabulated-list-col-sort): Handle non-header-line button case. + (tabulated-list--sort-by-column-name): Fix a corner case. + + * buff-menu.el (list-buffers--refresh): Handle + Buffer-menu-use-header-line. + 2012-05-06 Chong Yidong * buff-menu.el: Convert to Tabulated List mode. diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el index e28c2c0f60b..4ea9dcea8b4 100644 --- a/lisp/buff-menu.el +++ b/lisp/buff-menu.el @@ -574,6 +574,7 @@ means list those buffers and no others." `("Size" ,size-width tabulated-list-entry-size->) `("Mode" ,Buffer-menu-mode-width t) '("File" 1 t)))) + (setq tabulated-list-use-header-line Buffer-menu-use-header-line) ;; Collect info for each buffer we're interested in. (let ((buffer-menu-buffer (current-buffer)) (show-non-file (not Buffer-menu-files-only)) diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 4291f3aacc6..5471640e039 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -56,6 +56,10 @@ where: right of the column (defaults to 1 if omitted).") (make-variable-buffer-local 'tabulated-list-format) +(defvar tabulated-list-use-header-line t + "Whether the Tabulated List buffer should use a header line.") +(make-variable-buffer-local 'tabulated-list-use-header-line) + (defvar tabulated-list-entries nil "Entries displayed in the current Tabulated List buffer. This should be either a function, or a list. @@ -154,6 +158,9 @@ If ADVANCE is non-nil, move forward by one line afterwards." (let ((map (make-sparse-keymap))) (define-key map [header-line mouse-1] 'tabulated-list-col-sort) (define-key map [header-line mouse-2] 'tabulated-list-col-sort) + (define-key map [mouse-1] 'tabulated-list-col-sort) + (define-key map [mouse-2] 'tabulated-list-col-sort) + (define-key map "\C-m" 'tabulated-list-sort) (define-key map [follow-link] 'mouse-face) map) "Local keymap for `tabulated-list-mode' sort buttons.") @@ -167,6 +174,9 @@ If ADVANCE is non-nil, move forward by one line afterwards." table) "The `glyphless-char-display' table in Tabulated List buffers.") +(defvar tabulated-list--header-string nil) +(defvar tabulated-list--header-overlay nil) + (defun tabulated-list-init-header () "Set up header line for the Tabulated List buffer." (let ((x (max tabulated-list-padding 0)) @@ -185,7 +195,8 @@ If ADVANCE is non-nil, move forward by one line afterwards." (push (cond ;; An unsortable column - ((not (nth 2 col)) label) + ((not (nth 2 col)) + (propertize label 'tabulated-list-column-name label)) ;; The selected sort column ((equal (car col) (car tabulated-list-sort-key)) (apply 'propertize @@ -197,11 +208,11 @@ If ADVANCE is non-nil, move forward by one line afterwards." " ▲") (t " ▼"))) 'face 'bold - 'tabulated-list-column-name (car col) + 'tabulated-list-column-name label button-props)) ;; Unselected sortable column. (t (apply 'propertize label - 'tabulated-list-column-name (car col) + 'tabulated-list-column-name label button-props))) cols) (if (> pad-right 0) @@ -209,7 +220,22 @@ If ADVANCE is non-nil, move forward by one line afterwards." 'display `(space :align-to ,x) 'face 'fixed-pitch) cols)))) - (setq header-line-format (mapconcat 'identity (nreverse cols) "")))) + (setq cols (apply 'concat (nreverse cols))) + (if tabulated-list-use-header-line + (setq header-line-format cols) + (setq header-line-format nil) + (set (make-local-variable 'tabulated-list--header-string) cols)))) + +(defun tabulated-list-print-fake-header () + "Insert a fake Tabulated List \"header line\" at the start of the buffer." + (goto-char (point-min)) + (let ((inhibit-read-only t)) + (insert tabulated-list--header-string "\n") + (if tabulated-list--header-overlay + (move-overlay tabulated-list--header-overlay (point-min) (point)) + (set (make-local-variable 'tabulated-list--header-overlay) + (make-overlay (point-min) (point)))) + (overlay-put tabulated-list--header-overlay 'face 'underline))) (defun tabulated-list-revert (&rest ignored) "The `revert-buffer-function' for `tabulated-list-mode'. @@ -248,6 +274,8 @@ to the entry with the same ID element as the current line." (setq entry-id (tabulated-list-get-id)) (setq saved-col (current-column))) (erase-buffer) + (unless tabulated-list-use-header-line + (tabulated-list-print-fake-header)) ;; Sort the buffers, if necessary. (when (and tabulated-list-sort-key (car tabulated-list-sort-key)) @@ -391,12 +419,12 @@ this is the vector stored within it." "Sort Tabulated List entries by the column of the mouse click E." (interactive "e") (let* ((pos (event-start e)) - (obj (posn-object pos)) - (name (get-text-property (if obj (cdr obj) (posn-point pos)) - 'tabulated-list-column-name - (car obj)))) + (obj (posn-object pos))) (with-current-buffer (window-buffer (posn-window pos)) - (tabulated-list--sort-by-column-name name)))) + (tabulated-list--sort-by-column-name + (get-text-property (if obj (cdr obj) (posn-point pos)) + 'tabulated-list-column-name + (car obj)))))) (defun tabulated-list-sort (&optional n) "Sort Tabulated List entries by the column at point. @@ -409,7 +437,7 @@ With a numeric prefix argument N, sort the Nth column." (tabulated-list--sort-by-column-name name))) (defun tabulated-list--sort-by-column-name (name) - (when (derived-mode-p 'tabulated-list-mode) + (when (and name (derived-mode-p 'tabulated-list-mode)) ;; Flip the sort order on a second click. (if (equal name (car tabulated-list-sort-key)) (setcdr tabulated-list-sort-key -- cgit v1.2.3 From f0809a9d058443cd92f7145a70c25ce10d285971 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 7 May 2012 12:29:55 -0400 Subject: * lisp/buff-menu.el (list-buffers--refresh): Mark `size' as right-align. * lisp/emacs-lisp/tabulated-list.el (tabulated-list-init-header): Handle new :right-align column property. (tabulated-list-print-col): Idem, plus use `display' text-property to try and preserve alignment for variable pitch fonts. --- lisp/ChangeLog | 14 +++++++-- lisp/buff-menu.el | 5 +++- lisp/emacs-lisp/tabulated-list.el | 60 ++++++++++++++++++++++++++++----------- 3 files changed, 58 insertions(+), 21 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 1db2fb1c715..33138c34809 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,11 @@ +2012-05-07 Stefan Monnier + + * buff-menu.el (list-buffers--refresh): Mark `size' as right-align. + * emacs-lisp/tabulated-list.el (tabulated-list-init-header): + Handle new :right-align column property. + (tabulated-list-print-col): Idem, plus use `display' text-property to + try and preserve alignment for variable pitch fonts. + 2012-05-07 Chong Yidong * emacs-lisp/tabulated-list.el: Add no-header-line alternative. @@ -11,8 +19,8 @@ (tabulated-list-col-sort): Handle non-header-line button case. (tabulated-list--sort-by-column-name): Fix a corner case. - * buff-menu.el (list-buffers--refresh): Handle - Buffer-menu-use-header-line. + * buff-menu.el (list-buffers--refresh): + Handle Buffer-menu-use-header-line. 2012-05-06 Chong Yidong @@ -32,7 +40,7 @@ (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. + Delete. (list-buffers--refresh): New function. (list-buffers-noselect): Use it. (tabulated-list-entry-size->, Buffer-menu--pretty-name) diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el index 4ea9dcea8b4..10c097bbf93 100644 --- a/lisp/buff-menu.el +++ b/lisp/buff-menu.el @@ -269,6 +269,7 @@ ARG, show only buffers that are visiting files." (message "Commands: d, s, x, u; f, o, 1, 2, m, v; ~, %%; q to quit; ? for help.")) +;;;###autoload (defun list-buffers (&optional arg) "Display a list of existing buffers. The list is displayed in a buffer named \"*Buffer List*\". @@ -543,6 +544,7 @@ The current window remains selected." ;;; Functions for populating the Buffer Menu. +;;;###autoload (defun list-buffers-noselect (&optional files-only buffer-list) "Create and return a Buffer Menu buffer. This is called by `buffer-menu' and others as a subroutine. @@ -571,7 +573,8 @@ means list those buffers and no others." '("R" 1 t :pad-right 0) '("M" 1 t) `("Buffer" ,name-width t) - `("Size" ,size-width tabulated-list-entry-size->) + `("Size" ,size-width tabulated-list-entry-size-> + :right-align t) `("Mode" ,Buffer-menu-mode-width t) '("File" 1 t)))) (setq tabulated-list-use-header-line Buffer-menu-use-header-line) diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 5471640e039..e56fea58553 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -52,6 +52,7 @@ where: of `tabulated-list-entries'. - PROPS is a plist of additional column properties. Currently supported properties are: + - `:right-align': if non-nil, the column should be right-aligned. - `:pad-right': Number of additional padding spaces to the right of the column (defaults to 1 if omitted).") (make-variable-buffer-local 'tabulated-list-format) @@ -179,6 +180,7 @@ If ADVANCE is non-nil, move forward by one line afterwards." (defun tabulated-list-init-header () "Set up header line for the Tabulated List buffer." + ;; FIXME: Should share code with tabulated-list-print-col! (let ((x (max tabulated-list-padding 0)) (button-props `(help-echo "Click to sort by column" mouse-face highlight @@ -190,8 +192,9 @@ If ADVANCE is non-nil, move forward by one line afterwards." (label (nth 0 col)) (width (nth 1 col)) (props (nthcdr 3 col)) - (pad-right (or (plist-get props :pad-right) 1))) - (setq x (+ x pad-right width)) + (pad-right (or (plist-get props :pad-right) 1)) + (right-align (plist-get props :right-align)) + (next-x (+ x pad-right width))) (push (cond ;; An unsortable column @@ -202,10 +205,8 @@ If ADVANCE is non-nil, move forward by one line afterwards." (apply 'propertize (concat label (cond - ((> (+ 2 (length label)) width) - "") - ((cdr tabulated-list-sort-key) - " ▲") + ((> (+ 2 (length label)) width) "") + ((cdr tabulated-list-sort-key) " ▲") (t " ▼"))) 'face 'bold 'tabulated-list-column-name label @@ -215,11 +216,22 @@ If ADVANCE is non-nil, move forward by one line afterwards." 'tabulated-list-column-name label button-props))) cols) + (when right-align + (let ((shift (- width (string-width (car cols))))) + (when (> shift 0) + (setq cols + (cons (car cols) + (cons (propertize (make-string shift ?\s) + 'display + `(space :align-to ,(+ x shift))) + (cdr cols)))) + (setq x (+ x shift))))) (if (> pad-right 0) (push (propertize " " - 'display `(space :align-to ,x) + 'display `(space :align-to ,next-x) 'face 'fixed-pitch) - cols)))) + cols)) + (setq x next-x))) (setq cols (apply 'concat (nreverse cols))) (if tabulated-list-use-header-line (setq header-line-format cols) @@ -276,7 +288,7 @@ to the entry with the same ID element as the current line." (erase-buffer) (unless tabulated-list-use-header-line (tabulated-list-print-fake-header)) - ;; Sort the buffers, if necessary. + ;; Sort the entries, if necessary. (when (and tabulated-list-sort-key (car tabulated-list-sort-key)) (let* ((sort-column (car tabulated-list-sort-key)) @@ -332,29 +344,43 @@ of column descriptors." N is the column number, COL-DESC is a column descriptor \(see `tabulated-list-entries'), and X is the column number at point. Return the column number after insertion." + ;; TODO: don't truncate to `width' if the next column is align-right + ;; and has some space left. (let* ((format (aref tabulated-list-format n)) (name (nth 0 format)) (width (nth 1 format)) (props (nthcdr 3 format)) (pad-right (or (plist-get props :pad-right) 1)) + (right-align (plist-get props :right-align)) (label (if (stringp col-desc) col-desc (car col-desc))) + (label-width (string-width label)) (help-echo (concat (car format) ": " label)) (opoint (point)) (not-last-col (< (1+ n) (length tabulated-list-format)))) ;; Truncate labels if necessary (except last column). (and not-last-col - (> (string-width label) width) - (setq label (truncate-string-to-width label width nil nil t))) + (> label-width width) + (setq label (truncate-string-to-width label width nil nil t) + label-width width)) (setq label (bidi-string-mark-left-to-right label)) + (when (and right-align (> width label-width)) + (let ((shift (- width label-width))) + (insert (propertize (make-string shift ?\s) + 'display `(space :align-to ,(+ x shift)))) + (setq width (- width shift)) + (setq x (+ x shift)))) (if (stringp col-desc) (insert (propertize label 'help-echo help-echo)) (apply 'insert-text-button label (cdr col-desc))) - (setq x (+ x pad-right width)) - ;; No need to append any spaces if this is the last column. - (if not-last-col - (indent-to x pad-right)) - (put-text-property opoint (point) 'tabulated-list-column-name name) - x)) + (let ((next-x (+ x pad-right width))) + ;; No need to append any spaces if this is the last column. + (when not-last-col + (when (> pad-right 0) (insert (make-string pad-right ?\s))) + (insert (propertize + (make-string (- next-x x label-width pad-right) ?\s) + 'display `(space :align-to ,next-x)))) + (put-text-property opoint (point) 'tabulated-list-column-name name) + next-x))) (defun tabulated-list-delete-entry () "Delete the Tabulated List entry at point. -- cgit v1.2.3 From e5bd0a28953dcf6c3b811a7d17e7664c8d664a7c Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 12 May 2012 23:05:06 -0400 Subject: Move define-obsolete-variable-alias before the var's definition. * lisp/vc/log-edit.el (vc-comment-ring, vc-comment-ring-index): * lisp/tooltip.el (tooltip-hook): * lisp/textmodes/reftex-toc.el (reftex-toc-map): * lisp/textmodes/reftex-sel.el (reftex-select-label-map) (reftex-select-bib-map): * lisp/textmodes/reftex-index.el (reftex-index-map) (reftex-index-phrases-map): * lisp/speedbar.el (speedbar-syntax-table, speedbar-key-map): * lisp/progmodes/meta-mode.el (meta-mode-map): * lisp/novice.el (disabled-command-hook): * lisp/loadhist.el (unload-hook-features-list): * lisp/frame.el (blink-cursor): * lisp/files.el (find-file-not-found-hooks, write-file-hooks) (write-contents-hooks): * lisp/emulation/tpu-edt.el (GOLD-map): * lisp/emacs-lock.el (emacs-lock-from-exiting): * lisp/emacs-lisp/generic.el (generic-font-lock-defaults): * lisp/emacs-lisp/chart.el (chart-map): * lisp/dos-fns.el (register-name-alist): * lisp/dired-x.el (dired-omit-files-p): * lisp/desktop.el (desktop-enable): * lisp/cus-edit.el (custom-mode-hook): * lisp/buff-menu.el (buffer-menu-mode-hook): * lisp/bookmark.el (bookmark-read-annotation-text-func) (bookmark-exit-hooks): * lisp/allout.el (allout-mode-deactivate-hook) (allout-exposure-change-hook, allout-structure-added-hook) (allout-structure-deleted-hook, allout-structure-shifted-hook): * lisp/dirtrack.el (dirtrack-toggle, dirtrackp, dirtrack-debug-toggle) (dirtrack-debug): Move call to define-obsolete-variable-alias so it comes before the corresponding variable's definition. --- lisp/ChangeLog | 35 +++++++++++++++++++++++++++++++++++ lisp/allout.el | 24 ++++++++++-------------- lisp/bookmark.el | 8 ++++---- lisp/buff-menu.el | 6 +++--- lisp/cus-edit.el | 2 +- lisp/desktop.el | 6 ++---- lisp/dired-x.el | 5 ++--- lisp/dirtrack.el | 13 +++++-------- lisp/dos-fns.el | 6 +++--- lisp/emacs-lisp/chart.el | 2 +- lisp/emacs-lisp/generic.el | 3 ++- lisp/emacs-lock.el | 4 ++-- lisp/emulation/tpu-edt.el | 2 +- lisp/files.el | 10 +++++----- lisp/frame.el | 7 ++++--- lisp/loadhist.el | 4 ++-- lisp/novice.el | 6 +++--- lisp/progmodes/meta-mode.el | 2 +- lisp/speedbar.el | 6 +++--- lisp/textmodes/reftex-index.el | 8 ++++---- lisp/textmodes/reftex-sel.el | 8 ++++---- lisp/textmodes/reftex-toc.el | 2 +- lisp/tooltip.el | 4 ++-- lisp/vc/log-edit.el | 5 +++-- 24 files changed, 103 insertions(+), 75 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 26c4a492fb6..c12bf638243 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,38 @@ +2012-05-13 Stefan Monnier + + Move define-obsolete-variable-alias before the var's definition. + * vc/log-edit.el (vc-comment-ring, vc-comment-ring-index): + * tooltip.el (tooltip-hook): + * textmodes/reftex-toc.el (reftex-toc-map): + * textmodes/reftex-sel.el (reftex-select-label-map) + (reftex-select-bib-map): + * textmodes/reftex-index.el (reftex-index-map) + (reftex-index-phrases-map): + * speedbar.el (speedbar-syntax-table, speedbar-key-map): + * progmodes/meta-mode.el (meta-mode-map): + * novice.el (disabled-command-hook): + * loadhist.el (unload-hook-features-list): + * frame.el (blink-cursor): + * files.el (find-file-not-found-hooks, write-file-hooks) + (write-contents-hooks): + * emulation/tpu-edt.el (GOLD-map): + * emacs-lock.el (emacs-lock-from-exiting): + * emacs-lisp/generic.el (generic-font-lock-defaults): + * emacs-lisp/chart.el (chart-map): + * dos-fns.el (register-name-alist): + * dired-x.el (dired-omit-files-p): + * desktop.el (desktop-enable): + * cus-edit.el (custom-mode-hook): + * buff-menu.el (buffer-menu-mode-hook): + * bookmark.el (bookmark-read-annotation-text-func) + (bookmark-exit-hooks): + * allout.el (allout-mode-deactivate-hook) + (allout-exposure-change-hook, allout-structure-added-hook) + (allout-structure-deleted-hook, allout-structure-shifted-hook): + * dirtrack.el (dirtrack-toggle, dirtrackp, dirtrack-debug-toggle) + (dirtrack-debug): Move call to define-obsolete-variable-alias so it + comes before the corresponding variable's definition. + 2012-05-12 Chong Yidong * buff-menu.el (Buffer-menu-buffer+size-width): Doc fix (Bug#11454). diff --git a/lisp/allout.el b/lisp/allout.el index 6e544716247..7077af55e60 100644 --- a/lisp/allout.el +++ b/lisp/allout.el @@ -1405,15 +1405,17 @@ their settings before allout-mode was started." (defvar allout-mode-hook nil "Hook run when allout mode starts.") ;;;_ = allout-mode-deactivate-hook -(defvar allout-mode-deactivate-hook nil - "Hook run when allout mode ends.") (define-obsolete-variable-alias 'allout-mode-deactivate-hook 'allout-mode-off-hook "24.1") +(defvar allout-mode-deactivate-hook nil + "Hook run when allout mode ends.") ;;;_ = allout-exposure-category (defvar allout-exposure-category nil "Symbol for use as allout invisible-text overlay category.") ;;;_ = allout-exposure-change-functions +(define-obsolete-variable-alias 'allout-exposure-change-hook + 'allout-exposure-change-functions "24.2") (defcustom allout-exposure-change-functions nil "Abnormal hook run after allout outline subtree exposure changes. It is run at the conclusion of `allout-flag-region'. @@ -1429,10 +1431,9 @@ This hook might be invoked multiple times by a single command." :group 'allout :version "24.2") -(define-obsolete-variable-alias 'allout-exposure-change-hook - 'allout-exposure-change-functions "24.2") - ;;;_ = allout-structure-added-functions +(define-obsolete-variable-alias 'allout-structure-added-hook + 'allout-structure-added-functions "24.2") (defcustom allout-structure-added-functions nil "Abnormal hook run after adding items to an Allout outline. Functions on the hook should take two arguments: @@ -1445,10 +1446,9 @@ This hook might be invoked multiple times by a single command." :group 'allout :version "24.2") -(define-obsolete-variable-alias 'allout-structure-added-hook - 'allout-structure-added-functions "24.2") - ;;;_ = allout-structure-deleted-functions +(define-obsolete-variable-alias 'allout-structure-deleted-hook + 'allout-structure-deleted-functions "24.2") (defcustom allout-structure-deleted-functions nil "Abnormal hook run after deleting subtrees from an Allout outline. Functions on the hook must take two arguments: @@ -1464,10 +1464,9 @@ This hook might be invoked multiple times by a single command." :group 'allout :version "24.2") -(define-obsolete-variable-alias 'allout-structure-deleted-hook - 'allout-structure-deleted-functions "24.2") - ;;;_ = allout-structure-shifted-functions +(define-obsolete-variable-alias 'allout-structure-shifted-hook + 'allout-structure-shifted-functions "24.2") (defcustom allout-structure-shifted-functions nil "Abnormal hook run after shifting items in an Allout outline. Functions on the hook should take two arguments: @@ -1483,9 +1482,6 @@ This hook might be invoked multiple times by a single command." :group 'allout :version "24.2") -(define-obsolete-variable-alias 'allout-structure-shifted-hook - 'allout-structure-shifted-functions "24.2") - ;;;_ = allout-after-copy-or-kill-hook (defcustom allout-after-copy-or-kill-hook nil "Normal hook run after copying outline text.." diff --git a/lisp/bookmark.el b/lisp/bookmark.el index 33b91fd7db2..f7266dc2250 100644 --- a/lisp/bookmark.el +++ b/lisp/bookmark.el @@ -828,11 +828,11 @@ annotations." "# Date: " (current-time-string) "\n")) +(define-obsolete-variable-alias 'bookmark-read-annotation-text-func + 'bookmark-edit-annotation-text-func "23.1") (defvar bookmark-edit-annotation-text-func 'bookmark-default-annotation-text "Function to return default text to use for a bookmark annotation. It takes one argument, the name of the bookmark, as a string.") -(define-obsolete-variable-alias 'bookmark-read-annotation-text-func - 'bookmark-edit-annotation-text-func "23.1") (defvar bookmark-edit-annotation-mode-map (let ((map (make-sparse-keymap))) @@ -2164,11 +2164,11 @@ strings returned are not." "Hook run at the end of loading library `bookmark.el'.") ;; Exit Hook, called from kill-emacs-hook +(define-obsolete-variable-alias 'bookmark-exit-hooks + 'bookmark-exit-hook "22.1") (defvar bookmark-exit-hook nil "Hook run when Emacs exits.") -(define-obsolete-variable-alias 'bookmark-exit-hooks 'bookmark-exit-hook "22.1") - (defun bookmark-exit-hook-internal () "Save bookmark state, if necessary, at Emacs exit time. This also runs `bookmark-exit-hook'." diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el index 0ecbba09254..f501583b9ba 100644 --- a/lisp/buff-menu.el +++ b/lisp/buff-menu.el @@ -199,6 +199,9 @@ commands.") map) "Local keymap for `Buffer-menu-mode' buffers.") +(define-obsolete-variable-alias 'buffer-menu-mode-hook + 'Buffer-menu-mode-hook "23.1") + (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 @@ -207,9 +210,6 @@ The Buffer Menu is invoked by the commands \\[list-buffers], \\[buffer-menu], an (lambda (&optional _noconfirm) 'fast)) (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 (&optional arg) "Switch to the Buffer Menu. By default, all buffers are listed except those whose names start diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 52308319f15..e946279ee57 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -4825,6 +4825,7 @@ If several parents are listed, go to the first of them." (set (make-local-variable 'widget-link-suffix) "")) (setq show-trailing-whitespace nil)) +(define-obsolete-variable-alias 'custom-mode-hook 'Custom-mode-hook "23.1") (define-derived-mode Custom-mode nil "Custom" "Major mode for editing customization buffers. @@ -4873,7 +4874,6 @@ if that value is non-nil." (Custom-mode)) (make-obsolete 'custom-mode 'Custom-mode "23.1") (put 'custom-mode 'mode-class 'special) -(define-obsolete-variable-alias 'custom-mode-hook 'Custom-mode-hook "23.1") (add-to-list 'debug-ignored-errors "^Invalid face:? ") diff --git a/lisp/desktop.el b/lisp/desktop.el index 674ce72dba3..f7a33f2b05d 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el @@ -145,6 +145,8 @@ backward compatibility.") "Save status of Emacs when you exit." :group 'frames) +;; Maintained for backward compatibility +(define-obsolete-variable-alias 'desktop-enable 'desktop-save-mode "22.1") ;;;###autoload (define-minor-mode desktop-save-mode "Toggle desktop saving (Desktop Save mode). @@ -158,10 +160,6 @@ one session to another. See variable `desktop-save' and function :global t :group 'desktop) -;; Maintained for backward compatibility -(define-obsolete-variable-alias 'desktop-enable - 'desktop-save-mode "22.1") - (defun desktop-save-mode-off () "Disable `desktop-save-mode'. Provided for use in hooks." (desktop-save-mode 0)) diff --git a/lisp/dired-x.el b/lisp/dired-x.el index b45a340706f..1012deccd3c 100644 --- a/lisp/dired-x.el +++ b/lisp/dired-x.el @@ -132,6 +132,8 @@ If nil, there is no maximum size." :type '(choice (const :tag "no maximum" nil) integer) :group 'dired-x) +;; For backward compatibility +(define-obsolete-variable-alias 'dired-omit-files-p 'dired-omit-mode "22.1") (define-minor-mode dired-omit-mode "Toggle omission of uninteresting files in Dired (Dired-Omit mode). With a prefix argument ARG, enable Dired-Omit mode if ARG is @@ -157,9 +159,6 @@ See Info node `(dired-x) Omitting Variables' for more information." (put 'dired-omit-mode 'safe-local-variable 'booleanp) -;; For backward compatibility -(define-obsolete-variable-alias 'dired-omit-files-p 'dired-omit-mode "22.1") - (defcustom dired-omit-files "^\\.?#\\|^\\.$\\|^\\.\\.$" "Filenames matching this regexp will not be displayed. This only has effect when `dired-omit-mode' is t. See interactive function diff --git a/lisp/dirtrack.el b/lisp/dirtrack.el index 4f6236b240e..5e825032741 100644 --- a/lisp/dirtrack.el +++ b/lisp/dirtrack.el @@ -179,6 +179,8 @@ and ends with a forward slash." dir)) +(define-obsolete-function-alias 'dirtrack-toggle 'dirtrack-mode "23.1") +(define-obsolete-variable-alias 'dirtrackp 'dirtrack-mode "23.1") ;;;###autoload (define-minor-mode dirtrack-mode "Toggle directory tracking in shell buffers (Dirtrack mode). @@ -198,10 +200,10 @@ directory." (add-hook 'comint-preoutput-filter-functions 'dirtrack nil t) (remove-hook 'comint-preoutput-filter-functions 'dirtrack t))) -(define-obsolete-function-alias 'dirtrack-toggle 'dirtrack-mode "23.1") -(define-obsolete-variable-alias 'dirtrackp 'dirtrack-mode "23.1") - +(define-obsolete-function-alias 'dirtrack-debug-toggle 'dirtrack-debug-mode + "23.1") +(define-obsolete-variable-alias 'dirtrack-debug 'dirtrack-debug-mode "23.1") (define-minor-mode dirtrack-debug-mode "Toggle Dirtrack debugging. With a prefix argument ARG, enable Dirtrack debugging if ARG is @@ -211,11 +213,6 @@ the mode if ARG is omitted or nil." (if dirtrack-debug-mode (display-buffer (get-buffer-create dirtrack-debug-buffer)))) -(define-obsolete-function-alias 'dirtrack-debug-toggle 'dirtrack-debug-mode - "23.1") -(define-obsolete-variable-alias 'dirtrack-debug 'dirtrack-debug-mode "23.1") - - (defun dirtrack-debug-message (msg1 msg2) "Insert strings at the end of `dirtrack-debug-buffer'." (when dirtrack-debug-mode diff --git a/lisp/dos-fns.el b/lisp/dos-fns.el index 074fd642d67..c317bf84db6 100644 --- a/lisp/dos-fns.el +++ b/lisp/dos-fns.el @@ -233,15 +233,15 @@ returned unaltered." (add-hook 'before-init-hook 'dos-reevaluate-defcustoms) +(define-obsolete-variable-alias + 'register-name-alist 'dos-register-name-alist "24.1") + (defvar dos-register-name-alist '((ax . 0) (bx . 1) (cx . 2) (dx . 3) (si . 4) (di . 5) (cflag . 6) (flags . 7) (al . (0 . 0)) (bl . (1 . 0)) (cl . (2 . 0)) (dl . (3 . 0)) (ah . (0 . 1)) (bh . (1 . 1)) (ch . (2 . 1)) (dh . (3 . 1)))) -(define-obsolete-variable-alias - 'register-name-alist 'dos-register-name-alist "24.1") - (defun dos-make-register () (make-vector 8 0)) diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el index 2e3abb2e9d3..74087014d69 100644 --- a/lisp/emacs-lisp/chart.el +++ b/lisp/emacs-lisp/chart.el @@ -62,8 +62,8 @@ (require 'eieio) ;;; Code: -(defvar chart-mode-map (make-sparse-keymap) "Keymap used in chart mode.") (define-obsolete-variable-alias 'chart-map 'chart-mode-map "24.1") +(defvar chart-mode-map (make-sparse-keymap) "Keymap used in chart mode.") (defvar chart-local-object nil "Local variable containing the locally displayed chart object.") diff --git a/lisp/emacs-lisp/generic.el b/lisp/emacs-lisp/generic.el index 6667a101865..b9db092fafc 100644 --- a/lisp/emacs-lisp/generic.el +++ b/lisp/emacs-lisp/generic.el @@ -97,10 +97,11 @@ ;; Internal Variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define-obsolete-variable-alias 'generic-font-lock-defaults + 'generic-font-lock-keywords "22.1") (defvar generic-font-lock-keywords nil "Keywords for `font-lock-defaults' in a generic mode.") (make-variable-buffer-local 'generic-font-lock-keywords) -(define-obsolete-variable-alias 'generic-font-lock-defaults 'generic-font-lock-keywords "22.1") ;;;###autoload (defvar generic-mode-list nil diff --git a/lisp/emacs-lock.el b/lisp/emacs-lock.el index f5954564a2f..6d91238f2b1 100644 --- a/lisp/emacs-lock.el +++ b/lisp/emacs-lock.el @@ -186,6 +186,8 @@ Return a value appropriate for `kill-buffer-query-functions' (which see)." ;; anything else (turn off) mode)))) +(define-obsolete-variable-alias 'emacs-lock-from-exiting + 'emacs-lock-mode "24.1") ;;;###autoload (define-minor-mode emacs-lock-mode "Toggle Emacs Lock mode in the current buffer. @@ -245,8 +247,6 @@ Other values are interpreted as usual." ;;; Compatibility -(define-obsolete-variable-alias 'emacs-lock-from-exiting 'emacs-lock-mode "24.1") - (defun toggle-emacs-lock () "Toggle `emacs-lock-from-exiting' for the current buffer." (interactive) diff --git a/lisp/emulation/tpu-edt.el b/lisp/emulation/tpu-edt.el index eaf88ccdf85..b8d07e8b744 100644 --- a/lisp/emulation/tpu-edt.el +++ b/lisp/emulation/tpu-edt.el @@ -315,6 +315,7 @@ Otherwise, use `spell-region'." ;;; Global Keymaps ;;; +(define-obsolete-variable-alias 'GOLD-map 'tpu-gold-map "23.1") (defvar tpu-gold-map (let ((map (make-keymap))) ;; Previously we used escape sequences here. We now instead presume @@ -494,7 +495,6 @@ Otherwise, use `spell-region'." map) "Maps the function keys on the VT100 keyboard preceded by PF1. GOLD is the ASCII 7-bit escape sequence OP.") -(define-obsolete-variable-alias 'GOLD-map 'tpu-gold-map "23.1") (defvar tpu-global-map (let ((map (make-sparse-keymap))) diff --git a/lisp/files.el b/lisp/files.el index 2870fedf967..6691b362292 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -415,13 +415,13 @@ location of point in the current buffer." ;;;It is not useful to make this a local variable. ;;;(put 'find-file-not-found-hooks 'permanent-local t) +(define-obsolete-variable-alias 'find-file-not-found-hooks + 'find-file-not-found-functions "22.1") (defvar find-file-not-found-functions nil "List of functions to be called for `find-file' on nonexistent file. These functions are called as soon as the error is detected. Variable `buffer-file-name' is already set up. The functions are called in the order given until one of them returns non-nil.") -(define-obsolete-variable-alias 'find-file-not-found-hooks - 'find-file-not-found-functions "22.1") ;;;It is not useful to make this a local variable. ;;;(put 'find-file-hooks 'permanent-local t) @@ -435,6 +435,7 @@ functions are called." :options '(auto-insert) :version "22.1") +(define-obsolete-variable-alias 'write-file-hooks 'write-file-functions "22.1") (defvar write-file-functions nil "List of functions to be called before writing out a buffer to a file. If one of them returns non-nil, the file is considered already written @@ -451,13 +452,14 @@ coding system and setting mode bits. (See Info node `(elisp)Saving Buffers'.) To perform various checks or updates before the buffer is saved, use `before-save-hook'.") (put 'write-file-functions 'permanent-local t) -(define-obsolete-variable-alias 'write-file-hooks 'write-file-functions "22.1") (defvar local-write-file-hooks nil) (make-variable-buffer-local 'local-write-file-hooks) (put 'local-write-file-hooks 'permanent-local t) (make-obsolete-variable 'local-write-file-hooks 'write-file-functions "22.1") +(define-obsolete-variable-alias 'write-contents-hooks + 'write-contents-functions "22.1") (defvar write-contents-functions nil "List of functions to be called before writing out a buffer to a file. If one of them returns non-nil, the file is considered already written @@ -475,8 +477,6 @@ For hooks that _do_ pertain to the particular visited file, use To perform various checks or updates before the buffer is saved, use `before-save-hook'.") (make-variable-buffer-local 'write-contents-functions) -(define-obsolete-variable-alias 'write-contents-hooks - 'write-contents-functions "22.1") (defcustom enable-local-variables t "Control use of local variables in files you visit. diff --git a/lisp/frame.el b/lisp/frame.el index 1ee9d966ef1..5e380cd8fc6 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -1612,6 +1612,8 @@ itself as a pre-command hook." (cancel-timer blink-cursor-timer) (setq blink-cursor-timer nil))) +(define-obsolete-variable-alias 'blink-cursor 'blink-cursor-mode "22.1") + (define-minor-mode blink-cursor-mode "Toggle cursor blinking (Blink Cursor mode). With a prefix argument ARG, enable Blink Cursor mode if ARG is @@ -1638,8 +1640,6 @@ terminals, cursor blinking is controlled by the terminal." blink-cursor-delay 'blink-cursor-start)))) -(define-obsolete-variable-alias 'blink-cursor 'blink-cursor-mode "22.1") - ;;;; Key bindings @@ -1652,7 +1652,8 @@ terminals, cursor blinking is controlled by the terminal." ;; Misc. ;; Only marked as obsolete in 24.2. -(define-obsolete-variable-alias 'automatic-hscrolling 'auto-hscroll-mode "22.1") +(define-obsolete-variable-alias 'automatic-hscrolling + 'auto-hscroll-mode "22.1") (make-variable-buffer-local 'show-trailing-whitespace) diff --git a/lisp/loadhist.el b/lisp/loadhist.el index d747eb13b79..d5099340a17 100644 --- a/lisp/loadhist.el +++ b/lisp/loadhist.el @@ -143,13 +143,13 @@ These are symbols with hooklike values whose names don't end in `-hook' or `-hooks', from which `unload-feature' should try to remove pertinent symbols.") +(define-obsolete-variable-alias 'unload-hook-features-list + 'unload-function-defs-list "22.2") (defvar unload-function-defs-list nil "List of definitions in the Lisp library being unloaded. This is meant to be used by `FEATURE-unload-function'; see the documentation of `unload-feature' for details.") -(define-obsolete-variable-alias 'unload-hook-features-list - 'unload-function-defs-list "22.2") (defun unload--set-major-mode () (save-current-buffer diff --git a/lisp/novice.el b/lisp/novice.el index a5d38a3a57f..fa41b2bbc1e 100644 --- a/lisp/novice.el +++ b/lisp/novice.el @@ -35,14 +35,14 @@ (eval-when-compile (require 'cl)) +;;;###autoload +(define-obsolete-variable-alias 'disabled-command-hook + 'disabled-command-function "22.1") ;;;###autoload (defvar disabled-command-function 'disabled-command-function "Function to call to handle disabled commands. If nil, the feature is disabled, i.e., all commands work normally.") -;;;###autoload -(define-obsolete-variable-alias 'disabled-command-hook 'disabled-command-function "22.1") - ;; It is ok here to assume that this-command is a symbol ;; because we won't get called otherwise. ;;;###autoload diff --git a/lisp/progmodes/meta-mode.el b/lisp/progmodes/meta-mode.el index d0432f58d60..9978ee62687 100644 --- a/lisp/progmodes/meta-mode.el +++ b/lisp/progmodes/meta-mode.el @@ -829,6 +829,7 @@ The environment marked is the one that contains point or follows point." st) "Syntax table used in Metafont or MetaPost mode.") +(define-obsolete-variable-alias 'meta-mode-map 'meta-common-mode-map "24.1") (defvar meta-common-mode-map (let ((map (make-sparse-keymap))) ;; Comment Paragraphs: @@ -858,7 +859,6 @@ The environment marked is the one that contains point or follows point." ;; (define-key map "\C-c\C-l" 'meta-recenter-output) map) "Keymap used in Metafont or MetaPost mode.") -(define-obsolete-variable-alias 'meta-mode-map 'meta-common-mode-map "24.1") (easy-menu-define meta-mode-menu meta-common-mode-map diff --git a/lisp/speedbar.el b/lisp/speedbar.el index c1e86e17e37..28879fed30b 100644 --- a/lisp/speedbar.el +++ b/lisp/speedbar.el @@ -774,6 +774,8 @@ If you want to change this while speedbar is active, either use (defvar speedbar-update-flag-disable nil "Permanently disable changing of the update flag.") +(define-obsolete-variable-alias + 'speedbar-syntax-table 'speedbar-mode-syntax-table "24.1") (defvar speedbar-mode-syntax-table (let ((st (make-syntax-table))) ;; Turn off paren matching around here. @@ -787,10 +789,9 @@ If you want to change this while speedbar is active, either use (modify-syntax-entry ?\] " " st) st) "Syntax-table used on the speedbar.") -(define-obsolete-variable-alias - 'speedbar-syntax-table 'speedbar-mode-syntax-table "24.1") +(define-obsolete-variable-alias 'speedbar-key-map 'speedbar-mode-map "24.1") (defvar speedbar-mode-map (let ((map (make-keymap))) (suppress-keymap map t) @@ -825,7 +826,6 @@ If you want to change this while speedbar is active, either use (dframe-update-keymap map) map) "Keymap used in speedbar buffer.") -(define-obsolete-variable-alias 'speedbar-key-map 'speedbar-mode-map "24.1") (defun speedbar-make-specialized-keymap () "Create a keymap for use with a speedbar major or minor display mode. diff --git a/lisp/textmodes/reftex-index.el b/lisp/textmodes/reftex-index.el index fdcbf8b0b43..2d395fe3df2 100644 --- a/lisp/textmodes/reftex-index.el +++ b/lisp/textmodes/reftex-index.el @@ -274,6 +274,8 @@ will prompt for other arguments." (and newtag (cdr cell) (not (member newtag (cdr cell))) (push newtag (cdr cell))))) +(define-obsolete-variable-alias + 'reftex-index-map 'reftex-index-mode-map "24.1") (defvar reftex-index-mode-map (let ((map (make-sparse-keymap))) ;; Index map @@ -377,8 +379,6 @@ will prompt for other arguments." map) "Keymap used for *Index* buffers.") -(define-obsolete-variable-alias - 'reftex-index-map 'reftex-index-mode-map "24.1") (defvar reftex-index-menu) @@ -1179,6 +1179,8 @@ This gets refreshed in every phrases command.") "Font lock keywords for reftex-index-phrases-mode.") (defvar reftex-index-phrases-font-lock-defaults nil "Font lock defaults for reftex-index-phrases-mode.") +(define-obsolete-variable-alias + 'reftex-index-phrases-map 'reftex-index-phrases-mode-map "24.1") (defvar reftex-index-phrases-mode-map (let ((map (make-sparse-keymap))) ;; Keybindings and Menu for phrases buffer @@ -1244,8 +1246,6 @@ This gets refreshed in every phrases command.") map) "Keymap used for *toc* buffer.") -(define-obsolete-variable-alias - 'reftex-index-phrases-map 'reftex-index-phrases-mode-map "24.1") (defun reftex-index-phrase-selection-or-word (arg) diff --git a/lisp/textmodes/reftex-sel.el b/lisp/textmodes/reftex-sel.el index c583b67f13a..627dfba0071 100644 --- a/lisp/textmodes/reftex-sel.el +++ b/lisp/textmodes/reftex-sel.el @@ -71,6 +71,8 @@ (define-key map "-" 'negative-argument) map)) +(define-obsolete-variable-alias + 'reftex-select-label-map 'reftex-select-label-mode-map "24.1") (defvar reftex-select-label-mode-map (let ((map (make-sparse-keymap))) (set-keymap-parent map reftex-select-shared-map) @@ -102,8 +104,6 @@ "Keymap used for *RefTeX Select* buffer, when selecting a label. This keymap can be used to configure the label selection process which is started with the command \\[reftex-reference].") -(define-obsolete-variable-alias - 'reftex-select-label-map 'reftex-select-label-mode-map "24.1") (define-derived-mode reftex-select-label-mode fundamental-mode "LSelect" "Major mode for selecting a label in a LaTeX document. @@ -126,6 +126,8 @@ During a selection process, these are the local bindings. ;; We do not set a local map - reftex-select-item does this. ) +(define-obsolete-variable-alias + 'reftex-select-bib-map 'reftex-select-bib-mode-map "24.1") (defvar reftex-select-bib-mode-map (let ((map (make-sparse-keymap))) (set-keymap-parent map reftex-select-shared-map) @@ -147,8 +149,6 @@ During a selection process, these are the local bindings. "Keymap used for *RefTeX Select* buffer, when selecting a BibTeX entry. This keymap can be used to configure the BibTeX selection process which is started with the command \\[reftex-citation].") -(define-obsolete-variable-alias - 'reftex-select-bib-map 'reftex-select-bib-mode-map "24.1") (define-derived-mode reftex-select-bib-mode fundamental-mode "BSelect" "Major mode for selecting a citation key in a LaTeX document. diff --git a/lisp/textmodes/reftex-toc.el b/lisp/textmodes/reftex-toc.el index 5d293d404e6..519236a3621 100644 --- a/lisp/textmodes/reftex-toc.el +++ b/lisp/textmodes/reftex-toc.el @@ -31,6 +31,7 @@ (require 'reftex) ;;; +(define-obsolete-variable-alias 'reftex-toc-map 'reftex-toc-mode-map "24.1") (defvar reftex-toc-mode-map (let ((map (make-sparse-keymap))) @@ -122,7 +123,6 @@ map) "Keymap used for *toc* buffer.") -(define-obsolete-variable-alias 'reftex-toc-map 'reftex-toc-mode-map "24.1") (defvar reftex-toc-menu) (defvar reftex-last-window-height nil) diff --git a/lisp/tooltip.el b/lisp/tooltip.el index 1fab25fe5cd..9d0fbaae9d8 100644 --- a/lisp/tooltip.el +++ b/lisp/tooltip.el @@ -154,6 +154,8 @@ This variable is obsolete; instead of setting it to t, disable ;;; Variables that are not customizable. +(define-obsolete-variable-alias 'tooltip-hook 'tooltip-functions "23.1") + (defvar tooltip-functions nil "Functions to call to display tooltips. Each function is called with one argument EVENT which is a copy @@ -161,8 +163,6 @@ of the last mouse movement event that occurred. If one of these functions displays the tooltip, it should return non-nil and the rest are not called.") -(define-obsolete-variable-alias 'tooltip-hook 'tooltip-functions "23.1") - (defvar tooltip-timeout-id nil "The id of the timeout started when Emacs becomes idle.") diff --git a/lisp/vc/log-edit.el b/lisp/vc/log-edit.el index 2abb1ec9c0a..5ecd5c44b2e 100644 --- a/lisp/vc/log-edit.el +++ b/lisp/vc/log-edit.el @@ -195,7 +195,10 @@ when this variable is set to nil.") (defconst log-edit-maximum-comment-ring-size 32 "Maximum number of saved comments in the comment ring.") +(define-obsolete-variable-alias 'vc-comment-ring 'log-edit-comment-ring "22.1") (defvar log-edit-comment-ring (make-ring log-edit-maximum-comment-ring-size)) +(define-obsolete-variable-alias 'vc-comment-ring-index + 'log-edit-comment-ring-index "22.1") (defvar log-edit-comment-ring-index nil) (defvar log-edit-last-comment-match "") @@ -301,8 +304,6 @@ automatically." (insert "\n")))) ;; Compatibility with old names. -(define-obsolete-variable-alias 'vc-comment-ring 'log-edit-comment-ring "22.1") -(define-obsolete-variable-alias 'vc-comment-ring-index 'log-edit-comment-ring-index "22.1") (define-obsolete-function-alias 'vc-previous-comment 'log-edit-previous-comment "22.1") (define-obsolete-function-alias 'vc-next-comment 'log-edit-next-comment "22.1") (define-obsolete-function-alias 'vc-comment-search-reverse 'log-edit-comment-search-backward "22.1") -- cgit v1.2.3 From 0ae03b6aae534c1a47f7246e791138b41203b036 Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Sun, 13 May 2012 22:23:45 +0800 Subject: Adapt Electric Buffer Menu to recent Buffer Menu changes. * lisp/ebuff-menu.el (electric-buffer-list): Put electric buffer menu command descriptions in this docstring, instead of the docstring of electric-buffer-menu-mode. Code cleanups. (electric-buffer-menu-mode): Use define-derived-mode. Rename from Electric-buffer-menu-mode. (electric-buffer-update-highlight): Minor code cleanup. * lisp/emacs-lisp/tabulated-list.el (tabulated-list-format) (tabulated-list-entries, tabulated-list-padding) (tabulated-list-sort-key): Make permanent-local. Fixes: debbugs:11455 --- lisp/ChangeLog | 14 +++++ lisp/ebuff-menu.el | 127 +++++++++++++++++--------------------- lisp/emacs-lisp/tabulated-list.el | 9 +++ 3 files changed, 78 insertions(+), 72 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 1bde354a551..557e8eb2e48 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,17 @@ +2012-05-13 Chong Yidong + + * emacs-lisp/tabulated-list.el (tabulated-list-format) + (tabulated-list-entries, tabulated-list-padding) + (tabulated-list-sort-key): Make permanent-local. + + * ebuff-menu.el: Adapt to Buffer Menu changes (Bug#11455). + (electric-buffer-list): Put electric buffer menu + command descriptions in this docstring, instead of the docstring + of electric-buffer-menu-mode. Code cleanups. + (electric-buffer-menu-mode): Use define-derived-mode. Rename from + Electric-buffer-menu-mode. + (electric-buffer-update-highlight): Minor code cleanup. + 2012-05-13 Michael Albinus * net/dbus.el (dbus-call-method): Restore events not from D-Bus. diff --git a/lisp/ebuff-menu.el b/lisp/ebuff-menu.el index 50a75c1aa57..e973f45bc44 100644 --- a/lisp/ebuff-menu.el +++ b/lisp/ebuff-menu.el @@ -31,9 +31,6 @@ (require 'electric) -;; this depends on the format of list-buffers (from src/buffer.c) and -;; on stuff in lisp/buff-menu.el - (defvar electric-buffer-menu-mode-map (let ((map (make-keymap))) (fillarray (car (cdr map)) 'Electric-buffer-menu-undefined) @@ -91,25 +88,33 @@ (put 'Helper-describe-bindings :advertised-binding "?") (defvar electric-buffer-menu-mode-hook nil - "Normal hook run by `electric-buffer-list'.") + "Normal hook run by `electric-buffer-menu-mode'.") ;;;###autoload (defun electric-buffer-list (arg) - "Pop up a buffer describing the set of Emacs buffers. -Vaguely like ITS lunar select buffer; combining typeoutoid buffer -listing with menuoid buffer selection. - -If the very next character typed is a space then the buffer list -window disappears. Otherwise, one may move around in the buffer list -window, marking buffers to be selected, saved or deleted. - -To exit and select a new buffer, type a space when the cursor is on -the appropriate line of the buffer-list window. Other commands are -much like those of `Buffer-menu-mode'. + "Pop up the Buffer Menu in an \"electric\" window. +If you type SPC or RET (`Electric-buffer-menu-select'), that +selects the buffer at point and quits the \"electric\" window. +Otherwise, you can move around in the Buffer Menu, marking +buffers to be selected, saved or deleted; these other commands +are much like those of `Buffer-menu-mode'. Run hooks in `electric-buffer-menu-mode-hook' on entry. -\\{electric-buffer-menu-mode-map}" +\\ +\\[keyboard-quit] or \\[Electric-buffer-menu-quit] -- exit buffer menu, returning to previous window and buffer + configuration. If the very first character typed is a space, it + also has this effect. +\\[Electric-buffer-menu-select] -- select buffer of line point is on. + Also show buffers marked with m in other windows, + deletes buffers marked with \"D\", and saves those marked with \"S\". +\\[Buffer-menu-mark] -- mark buffer to be displayed. +\\[Buffer-menu-not-modified] -- clear modified-flag on that buffer. +\\[Buffer-menu-save] -- mark that buffer to be saved. +\\[Buffer-menu-delete] or \\[Buffer-menu-delete-backwards] -- mark that buffer to be deleted. +\\[Buffer-menu-unmark] -- remove all kinds of marks from current line. +\\[Electric-buffer-menu-mode-view-buffer] -- view buffer, returning when done. +\\[Buffer-menu-backup-unmark] -- back up a line and remove marks." (interactive "P") (let (select buffer) (save-window-excursion @@ -118,15 +123,15 @@ Run hooks in `electric-buffer-menu-mode-hook' on entry. (unwind-protect (progn (set-buffer buffer) - (Electric-buffer-menu-mode) + (electric-buffer-menu-mode) + (goto-char (point-min)) + (if (search-forward "\n." nil t) + (forward-char -1)) (electric-buffer-update-highlight) (setq select (catch 'electric-buffer-menu-select - (message "<<< Press Return to bury the buffer list >>>") - (if (eq (setq unread-command-events (list (read-event))) - ?\s) - (progn (setq unread-command-events nil) - (throw 'electric-buffer-menu-select nil))) + (message "<<< Type SPC or RET to bury the buffer list >>>") + (setq unread-command-events (list (read-event))) (let ((start-point (point)) (first (progn (goto-char (point-min)) (unless Buffer-menu-use-header-line @@ -150,15 +155,16 @@ Run hooks in `electric-buffer-menu-mode-hook' on entry. (Buffer-menu-mode) (bury-buffer) ;Get rid of window, if dedicated. (message ""))) - (if select - (progn (set-buffer buffer) - (let ((opoint (point-marker))) - (Buffer-menu-execute) - (goto-char (point-min)) - (if (prog1 (search-forward "\n>" nil t) - (goto-char opoint) (set-marker opoint nil)) - (Buffer-menu-select) - (switch-to-buffer (Buffer-menu-buffer t)))))))) + (when select + (set-buffer buffer) + (let ((opoint (point-marker))) + (Buffer-menu-execute) + (goto-char (point-min)) + (if (prog1 (search-forward "\n>" nil t) + (goto-char opoint) + (set-marker opoint nil)) + (Buffer-menu-select) + (switch-to-buffer (Buffer-menu-buffer t))))))) (defun electric-buffer-menu-looper (state condition) (cond ((and condition @@ -179,50 +185,27 @@ Run hooks in `electric-buffer-menu-mode-hook' on entry. (defvar Helper-return-blurb) -(put 'Electric-buffer-menu-mode 'mode-class 'special) -(defun Electric-buffer-menu-mode () - "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. -\\ -\\[keyboard-quit] or \\[Electric-buffer-menu-quit] -- exit buffer menu, returning to previous window and buffer - configuration. If the very first character typed is a space, it - also has this effect. -\\[Electric-buffer-menu-select] -- select buffer of line point is on. - Also show buffers marked with m in other windows, - deletes buffers marked with \"D\", and saves those marked with \"S\". -\\[Buffer-menu-mark] -- mark buffer to be displayed. -\\[Buffer-menu-not-modified] -- clear modified-flag on that buffer. -\\[Buffer-menu-save] -- mark that buffer to be saved. -\\[Buffer-menu-delete] or \\[Buffer-menu-delete-backwards] -- mark that buffer to be deleted. -\\[Buffer-menu-unmark] -- remove all kinds of marks from current line. -\\[Electric-buffer-menu-mode-view-buffer] -- view buffer, returning when done. -\\[Buffer-menu-backup-unmark] -- back up a line and remove marks. +(define-derived-mode electric-buffer-menu-mode Buffer-menu-mode + "Electric Buffer Menu" + "Toggle Electric Buffer Menu mode in this buffer. +With a prefix argument ARG, enable Long Lines mode if ARG is +positive, and disable it otherwise. If called from Lisp, enable +the mode if ARG is omitted or nil. -\\{electric-buffer-menu-mode-map} - -Entry to this mode via command `electric-buffer-list' calls the value of -`electric-buffer-menu-mode-hook'." - (let ((saved header-line-format)) - (kill-all-local-variables) - (setq header-line-format saved)) - (use-local-map electric-buffer-menu-mode-map) - (setq mode-name "Electric Buffer Menu") +Electric Buffer Menu mode is a minor mode which is automatically +enabled and disabled by the \\[electric-buffer-list] command. +See the documentation of `electric-buffer-list' for details." (setq mode-line-buffer-identification "Electric Buffer List") - (make-local-variable 'Helper-return-blurb) - (setq Helper-return-blurb "return to buffer editing") - (setq truncate-lines t) - (setq buffer-read-only t) - (setq major-mode 'Electric-buffer-menu-mode) - (goto-char (point-min)) - (if (search-forward "\n." nil t) (forward-char -1)) - (run-mode-hooks 'electric-buffer-menu-mode-hook)) + (set (make-local-variable 'Helper-return-blurb) + "return to buffer editing")) + +(define-obsolete-function-alias 'Electric-buffer-menu-mode + 'electric-buffer-menu-mode "24.2") ;; generally the same as Buffer-menu-mode-map ;; (except we don't indirect to global-map) (put 'Electric-buffer-menu-undefined 'suppress-keymap t) - (defun Electric-buffer-menu-exit () (interactive) (setq unread-command-events (listify-key-sequence (this-command-keys))) @@ -274,13 +257,13 @@ Return to Electric Buffer Menu when done." (sit-for 4)))) (defvar electric-buffer-overlay nil) + (defun electric-buffer-update-highlight () - (when (eq major-mode 'Electric-buffer-menu-mode) + (when (derived-mode-p 'electric-buffer-menu-mode) ;; Make sure we have an overlay to use. (or electric-buffer-overlay - (progn - (make-local-variable 'electric-buffer-overlay) - (setq electric-buffer-overlay (make-overlay (point) (point))))) + (set (make-local-variable 'electric-buffer-overlay) + (make-overlay (point) (point)))) (move-overlay electric-buffer-overlay (line-beginning-position) (line-end-position)) diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index e56fea58553..a56a7619ea9 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -35,6 +35,11 @@ ;;; Code: +;; The reason `tabulated-list-format' and other variables are +;; permanent-local is to make it convenient to switch to a different +;; major mode, switch back, and have the original Tabulated List data +;; still valid. See, for example, ebuff-menu.el. + (defvar tabulated-list-format nil "The format of the current Tabulated List mode buffer. This should be a vector of elements (NAME WIDTH SORT . PROPS), @@ -56,6 +61,7 @@ where: - `:pad-right': Number of additional padding spaces to the right of the column (defaults to 1 if omitted).") (make-variable-buffer-local 'tabulated-list-format) +(put 'tabulated-list-format 'permanent-local t) (defvar tabulated-list-use-header-line t "Whether the Tabulated List buffer should use a header line.") @@ -80,12 +86,14 @@ where: If `tabulated-list-entries' is a function, it is called with no arguments and must return a list of the above form.") (make-variable-buffer-local 'tabulated-list-entries) +(put 'tabulated-list-entries 'permanent-local t) (defvar tabulated-list-padding 0 "Number of characters preceding each Tabulated List mode entry. By default, lines are padded with spaces, but you can use the function `tabulated-list-put-tag' to change this.") (make-variable-buffer-local 'tabulated-list-padding) +(put 'tabulated-list-padding 'permanent-local t) (defvar tabulated-list-revert-hook nil "Hook run before reverting a Tabulated List buffer. @@ -107,6 +115,7 @@ NAME is a string matching one of the column names in `tabulated-list-format' then specifies how to sort). FLIP, if non-nil, means to invert the resulting sort.") (make-variable-buffer-local 'tabulated-list-sort-key) +(put 'tabulated-list-sort-key 'permanent-local t) (defsubst tabulated-list-get-id (&optional pos) "Return the entry ID of the Tabulated List entry at POS. -- cgit v1.2.3 From 06bc5e6ea6d36a1166c95b81c29bc3e748d8f652 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sun, 13 May 2012 12:04:37 -0400 Subject: *** empty log message *** --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/smie.el | 6 ++++-- 2 files changed, 9 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 557e8eb2e48..03b9a3ba15b 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2012-05-13 Johan Bockgård + + * emacs-lisp/smie.el (smie-next-sexp): Use accessor `op-forw' rather + than hard-coding `car', to fix misbehavior when moving forward. + 2012-05-13 Chong Yidong * emacs-lisp/tabulated-list.el (tabulated-list-format) diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index cafa1942a09..ae3e060034f 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -728,7 +728,8 @@ Possible return values: (if (and halfsexp (numberp (funcall op-forw toklevels))) (push toklevels levels) (throw 'return - (prog1 (list (or (car toklevels) t) (point) token) + (prog1 (list (or (funcall op-forw toklevels) t) + (point) token) (goto-char pos))))) (t (let ((lastlevels levels)) @@ -773,7 +774,8 @@ Possible return values: ((and lastlevels (smie--associative-p (car lastlevels))) (throw 'return - (prog1 (list (or (car toklevels) t) (point) token) + (prog1 (list (or (funcall op-forw toklevels) t) + (point) token) (goto-char pos)))) ;; - it's an associative operator within a larger construct ;; (e.g. an "elsif"), so we should just ignore it and keep -- cgit v1.2.3 From fdb058c22800a2cce782c74ee3e3918b432b271c Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 15 May 2012 09:25:03 -0400 Subject: * lisp/emacs-lisp/smie.el (smie-indent--bolp-1): New function. (smie-indent-keyword): Use it. --- lisp/ChangeLog | 9 +++++++-- lisp/emacs-lisp/smie.el | 26 ++++++++++++++++++++++++-- 2 files changed, 31 insertions(+), 4 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index d91fc5d0b22..865bdd7c6a3 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2012-05-15 Stefan Monnier + + * emacs-lisp/smie.el (smie-indent--bolp-1): New function. + (smie-indent-keyword): Use it. + 2012-05-14 Stefan Merten * textmodes/rst.el (rst-re-alist): Fix loading (bug#11462). @@ -15,8 +20,8 @@ 2012-05-14 Stefan Monnier - * shell.el (shell-parse-pcomplete-arguments): Obey - pcomplete-arg-quote-list inside double-quoted args (Bug#11348). + * shell.el (shell-parse-pcomplete-arguments): + Obey pcomplete-arg-quote-list inside double-quoted args (Bug#11348). 2012-05-14 Wolfgang Jenkner diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index ae3e060034f..01274b7ba20 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -688,6 +688,7 @@ Possible return values: is too high. FORW-LEVEL is the forw-level of TOKEN, POS is its start position in the buffer. (t POS TOKEN): same thing when we bump on the wrong side of a paren. + Instead of t, the `car' can also be some other non-nil non-number value. (nil POS TOKEN): we skipped over a paren-like pair. nil: we skipped over an identifier, matched parentheses, ..." (catch 'return @@ -795,6 +796,7 @@ Possible return values: is too high. LEFT-LEVEL is the left-level of TOKEN, POS is its start position in the buffer. (t POS TOKEN): same thing but for an open-paren or the beginning of buffer. + Instead of t, the `car' can also be some other non-nil non-number value. (nil POS TOKEN): we skipped over a paren-like pair. nil: we skipped over an identifier, matched parentheses, ..." (smie-next-sexp @@ -814,7 +816,8 @@ Possible return values: (RIGHT-LEVEL POS TOKEN): we couldn't skip TOKEN because its left-level is too high. RIGHT-LEVEL is the right-level of TOKEN, POS is its end position in the buffer. - (t POS TOKEN): same thing but for an open-paren or the beginning of buffer. + (t POS TOKEN): same thing but for a close-paren or the end of buffer. + Instead of t, the `car' can also be some other non-nil non-number value. (nil POS TOKEN): we skipped over a paren-like pair. nil: we skipped over an identifier, matched parentheses, ..." (smie-next-sexp @@ -1076,6 +1079,16 @@ the beginning of a line." "Return non-nil if the current token is the first on the line." (save-excursion (skip-chars-backward " \t") (bolp))) +(defun smie-indent--bolp-1 () + ;; Like smie-indent--bolp but also returns non-nil if it's the first + ;; non-comment token. Maybe we should simply always use this? + "Return non-nil if the current token is the first on the line. +Comments are treated as spaces." + (let ((bol (line-beginning-position))) + (save-excursion + (forward-comment (- (point))) + (<= (point) bol)))) + ;; Dynamically scoped. (defvar smie--parent) (defvar smie--after) (defvar smie--token) @@ -1352,9 +1365,12 @@ should not be computed on the basis of the following token." ;; - middle-of-line: "trust current position". (cond ((smie-indent--rule :before token)) - ((smie-indent--bolp) ;I.e. non-virtual indent. + ((smie-indent--bolp-1) ;I.e. non-virtual indent. ;; For an open-paren-like thingy at BOL, always indent only ;; based on other rules (typically smie-indent-after-keyword). + ;; FIXME: we do the same if after a comment, since we may be trying + ;; to compute the indentation of this comment and we shouldn't indent + ;; based on the indentation of subsequent code. nil) (t ;; By default use point unless we're hanging. @@ -1455,6 +1471,12 @@ should not be computed on the basis of the following token." (save-excursion (forward-comment (point-max)) (skip-chars-forward " \t\r\n") + ;; FIXME: We assume here that smie-indent-calculate will compute the + ;; indentation of the next token based on text before the comment, but + ;; this is not guaranteed, so maybe we should let + ;; smie-indent-calculate return some info about which buffer position + ;; was used as the "indentation base" and check that this base is + ;; before `pos'. (smie-indent-calculate)))) (defun smie-indent-comment-continue () -- cgit v1.2.3 From c41045e6f2b9e9aa5ab8c7c679a2ea04b130fca3 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 15 May 2012 14:45:27 -0400 Subject: * lisp/emacs-lisp/pcase.el (pcase-let*, pcase-let): Fix edebug spec. --- lisp/ChangeLog | 2 ++ lisp/emacs-lisp/pcase.el | 5 +++-- 2 files changed, 5 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index ac2aff0d9c7..717582a6f8f 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,7 @@ 2012-05-15 Stefan Monnier + * emacs-lisp/pcase.el (pcase-let*, pcase-let): Fix edebug spec. + * minibuffer.el (completion--sifn-requote): Handle sifn's truncation behavior. (completion--string-equal-p): New function. diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 0d115cc56f5..28eaa3d3455 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -113,7 +113,8 @@ like `(,a . ,(pred (< a))) or, with more checks: "Like `let*' but where you can use `pcase' patterns for bindings. BODY should be an expression, and BINDINGS should be a list of bindings of the form (UPAT EXP)." - (declare (indent 1) (debug let)) + (declare (indent 1) + (debug ((&rest &or (sexp &optional form) symbolp) body))) (cond ((null bindings) (if (> (length body) 1) `(progn ,@body) (car body))) ((pcase--trivial-upat-p (caar bindings)) @@ -132,7 +133,7 @@ of the form (UPAT EXP)." "Like `let' but where you can use `pcase' patterns for bindings. BODY should be a list of expressions, and BINDINGS should be a list of bindings of the form (UPAT EXP)." - (declare (indent 1) (debug let)) + (declare (indent 1) (debug pcase-let*)) (if (null (cdr bindings)) `(pcase-let* ,bindings ,@body) (let ((matches '())) -- cgit v1.2.3 From ac348012f4f956fa7e64535a3875a32cff91503c Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 17 May 2012 11:15:51 -0400 Subject: * lisp/emacs-lisp/cl-macs.el (cl-transform-lambda): Don't add spurious parens around the arg list. Fixes: debbugs:11499 --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/cl-macs.el | 5 +++-- 2 files changed, 8 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index b1d9323e481..fca6543072c 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2012-05-17 Stefan Monnier + + * emacs-lisp/cl-macs.el (cl-transform-lambda): Don't add spurious + parens around the arg list (bug#11499). + 2012-05-17 Juri Linkov * isearch.el (word-search-regexp, word-search-backward) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 8050da400fe..66fafb9ba41 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -318,8 +318,9 @@ It is a list of elements of the form either: (require 'help-fns) (cons (help-add-fundoc-usage (if (stringp (car hdr)) (pop hdr)) - (format "(fn %S)" - (cl--make-usage-args orig-args))) + (format "%S" + (cons 'fn + (cl--make-usage-args orig-args)))) hdr))) (list (nconc (list 'let* bind-lets) (nreverse bind-forms) body))))))) -- 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') 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') 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 9abdc45d8af50112c9afe3c8ee62ad4b9cce47ed Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 17 May 2012 17:40:47 -0400 Subject: * lisp/emacs-lisp/pcase.el (pcase--u1): Avoid ((lambda ...) ...). --- lisp/ChangeLog | 2 ++ lisp/emacs-lisp/pcase.el | 3 ++- 2 files changed, 4 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index cdb8217ed2c..043797ba7ee 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,7 @@ 2012-05-17 Stefan Monnier + * emacs-lisp/pcase.el (pcase--u1): Avoid ((lambda ...) ...). + * emacs-lisp/cl.el: Add edebug specs from cl-specs.el. * emacs-lisp/cl-macs.el: Idem. * emacs-lisp/cl-specs.el: Remove. diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 28eaa3d3455..67b19443967 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -557,7 +557,8 @@ Otherwise, it defers to REST which is a list of branches of the form (let ((newsym (make-symbol "x"))) (push (list newsym sym) env) (setq sym newsym))) - (if (functionp exp) `(,exp ,sym) + (if (functionp exp) + `(funcall #',exp ,sym) `(,@exp ,sym))))) (if (null vs) call -- cgit v1.2.3 From 70b8ef8f7855b9983d17731acad2fdfb4fb2a5be Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 17 May 2012 17:51:15 -0400 Subject: * lisp/emacs-lisp/cl-macs.el, lisp/emacs-lisp/cl.el: Move indent info. --- lisp/ChangeLog | 4 +++ lisp/emacs-lisp/cl-macs.el | 63 +++++++++++++++++++++++++--------------------- lisp/emacs-lisp/cl.el | 36 -------------------------- 3 files changed, 39 insertions(+), 64 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 043797ba7ee..fcdb2ce65b7 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,7 @@ +2012-05-17 Stefan Monnier + + * emacs-lisp/cl-macs.el, emacs-lisp/cl.el: Move indent info. + 2012-05-17 Stefan Monnier * emacs-lisp/pcase.el (pcase--u1): Avoid ((lambda ...) ...). diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 9fd53d78d92..441ae55758c 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -226,7 +226,8 @@ and BODY is implicitly surrounded by (block NAME ...). cl-lambda-list cl-declarations-or-string [&optional ("interactive" interactive)] - def-body))) + def-body)) + (indent 2)) (let* ((res (cl-transform-lambda (cons args body) name)) (form (list* 'defun name (cdr res)))) (if (car res) (list 'progn (car res) form) form))) @@ -277,7 +278,8 @@ 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))) + (&define name cl-macro-list cl-declarations-or-string def-body)) + (indent 2)) (let* ((res (cl-transform-lambda (cons args body) name)) (form (list* 'defmacro name (cdr res)))) (if (car res) (list 'progn (car res) form) form))) @@ -555,7 +557,8 @@ 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))) + (declare (indent 2) + (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) @@ -576,7 +579,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))) + (declare (indent 1) (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))) @@ -635,7 +638,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)))) + (declare (indent 1) (debug (form &rest (sexp body)))) (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) (head-list nil) (body (cons @@ -666,7 +669,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)) + (declare (indent 1) (debug case)) (list* 'case expr (append clauses '((ecase-error-flag))))) ;;;###autoload @@ -677,7 +680,8 @@ 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)))) + (declare (indent 1) + (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 @@ -702,7 +706,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)) + (declare (indent 1) (debug typecase)) (list* 'typecase expr (append clauses '((ecase-error-flag))))) @@ -718,7 +722,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))) + (declare (indent 1) (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))) @@ -738,7 +742,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))) + (declare (indent 1) (debug (symbolp &optional form))) (let ((name2 (intern (format "--cl-block-%s--" name)))) (list 'cl-block-throw (list 'quote name2) result))) @@ -1479,7 +1483,8 @@ Valid clauses are: "The Common Lisp `do' loop. \(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" - (declare (debug + (declare (indent 2) + (debug ((&rest &or symbolp (symbolp &optional form form)) (form body) cl-declarations body))) @@ -1490,7 +1495,7 @@ Valid clauses are: "The Common Lisp `do*' loop. \(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" - (declare (debug do)) + (declare (indent 2) (debug do)) (cl-expand-do-loop steps endtest body t)) (defun cl-expand-do-loop (steps endtest body star) @@ -1589,7 +1594,8 @@ 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))) + (declare (indent 1) + (debug ((symbolp &optional form form) cl-declarations body))) ;; Apparently this doesn't have an implicit block. (list 'block nil (list 'let (list (car spec)) @@ -1600,7 +1606,7 @@ from OBARRAY. ;;;###autoload (defmacro do-all-symbols (spec &rest body) - (declare (debug ((symbolp &optional form) cl-declarations body))) + (declare (indent 1) (debug ((symbolp &optional form) cl-declarations body))) (list* 'do-symbols (list (car spec) nil (cadr spec)) body)) @@ -1627,7 +1633,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))) + (declare (indent 2) (debug (form form body))) (list 'let '((cl-progv-save nil)) (list 'unwind-protect (list* 'progn (list 'cl-progv-before symbols values) body) @@ -1643,7 +1649,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))) + (declare (indent 1) (debug ((&rest (defun*)) cl-declarations body))) (list* 'letf* (mapcar (function @@ -1676,7 +1682,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)) + (declare (indent 1) (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 @@ -1701,7 +1707,8 @@ 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 + (declare (indent 1) + (debug ((&rest (&define name (&rest arg) cl-declarations-or-string def-body)) cl-declarations body))) @@ -1723,7 +1730,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))) + (declare (indent 1) (debug ((&rest (symbol sexp)) cl-declarations body))) (if (cdr bindings) (list 'symbol-macrolet (list (car bindings)) (list* 'symbol-macrolet (cdr bindings) body)) @@ -1740,7 +1747,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)) + (declare (indent 1) (debug let)) (let* ((cl-closure-vars cl-closure-vars) (vars (mapcar (function (lambda (x) @@ -1793,7 +1800,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)) + (declare (indent 1) (debug let)) (if (null bindings) (cons 'progn body) (setq bindings (reverse bindings)) (while bindings @@ -1819,7 +1826,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))) + (declare (indent 2) (debug ((&rest symbolp) form body))) (let ((temp (make-symbol "--cl-var--")) (n -1)) (list* 'let* (cons (list temp form) (mapcar (function @@ -1837,7 +1844,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))) + (declare (indent 1) (debug ((&rest symbolp) form))) (cond ((null vars) (list 'progn form nil)) ((null (cdr vars)) (list 'setq (car vars) (list 'car form))) (t @@ -1862,7 +1869,7 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). (cons 'progn body)) ;;;###autoload (defmacro the (type form) - (declare (debug (cl-type-spec form))) + (declare (indent 1) (debug (cl-type-spec form))) form) (defvar cl-proclaim-history t) ; for future compilers @@ -2444,7 +2451,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))) + (declare (indent 1) (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) @@ -2502,7 +2509,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)) + (declare (indent 1) (debug letf)) (if (null bindings) (cons 'progn body) (setq bindings (reverse bindings)) @@ -2517,7 +2524,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))) + (declare (indent 2) (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) @@ -2532,7 +2539,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))) + (declare (indent 3) (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))) diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index c5af1d8a4f1..7c486e17dcf 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -651,42 +651,6 @@ If ALIST is non-nil, the new pairs are prepended to it." ;;; Miscellaneous. -;; Define data for indentation and edebug. -(dolist (entry - '(((defun* defmacro*) 2) - ((function*) nil - (&or symbolp ([&optional 'macro] 'lambda (&rest sexp) &rest form))) - ((eval-when) 1 (sexp &rest form)) - ((declare) nil (&rest sexp)) - ((the) 1 (sexp &rest form)) - ((case ecase typecase etypecase) 1 (form &rest (sexp &rest form))) - ((block return-from) 1 (sexp &rest form)) - ((return) nil (&optional form)) - ((do do*) 2 ((&rest &or symbolp (symbolp &optional form form)) - (form &rest form) - &rest form)) - ((do-symbols) 1 ((symbolp form &optional form form) &rest form)) - ((do-all-symbols) 1 ((symbolp form &optional form) &rest form)) - ((psetq setf psetf) nil edebug-setq-form) - ((progv) 2 (&rest form)) - ((flet labels macrolet) 1 - ((&rest (sexp sexp &rest form)) &rest form)) - ((symbol-macrolet lexical-let lexical-let*) 1 - ((&rest &or symbolp (symbolp form)) &rest form)) - ((multiple-value-bind) 2 ((&rest symbolp) &rest form)) - ((multiple-value-setq) 1 ((&rest symbolp) &rest form)) - ((incf decf remf pushnew shiftf rotatef) nil (&rest form)) - ((letf letf*) 1 ((&rest (&rest form)) &rest form)) - ((callf destructuring-bind) 2 (sexp form &rest form)) - ((callf2) 3 (sexp form form &rest form)) - ((loop) nil (&rest &or symbolp form)) - ((ignore-errors) 0 (&rest form)))) - (dolist (func (car entry)) - (put func 'lisp-indent-function (nth 1 entry)) - (put func 'lisp-indent-hook (nth 1 entry)) - (or (get func 'edebug-form-spec) - (put func 'edebug-form-spec (nth 2 entry))))) - ;; Autoload the other portions of the package. ;; We want to replace the basic versions of dolist, dotimes, declare below. (fmakunbound 'dolist) -- 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') 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 From 3858bfe7c9f11d482715879fe40f06ce3dd6c009 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 19 May 2012 14:28:32 -0400 Subject: * lisp/emacs-lisp/bytecomp.el (byte-compile-root-dir): New var. (byte-compile-warning-prefix, batch-byte-compile-file): Use it. --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/bytecomp.el | 51 ++++++++++++++++++++++++--------------------- 2 files changed, 32 insertions(+), 24 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 91778032966..b311fc4fcaa 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2012-05-19 Stefan Monnier + + * emacs-lisp/bytecomp.el (byte-compile-root-dir): New var. + (byte-compile-warning-prefix, batch-byte-compile-file): Use it. + 2012-05-19 Jay Belanger * calc/calc.el (calc-ensure-consistent-units): New variable. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 9cb0a376e36..91db288feef 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1002,12 +1002,14 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (defvar byte-compile-last-warned-form nil) (defvar byte-compile-last-logged-file nil) +(defvar byte-compile-root-dir nil + "Directory relative to which file names in error messages are written.") ;; This is used as warning-prefix for the compiler. ;; It is always called with the warnings buffer current. (defun byte-compile-warning-prefix (level entry) (let* ((inhibit-read-only t) - (dir default-directory) + (dir (or byte-compile-root-dir default-directory)) (file (cond ((stringp byte-compile-current-file) (format "%s:" (file-relative-name byte-compile-current-file dir))) @@ -4515,29 +4517,30 @@ already up-to-date." (kill-emacs (if error 1 0)))) (defun batch-byte-compile-file (file) - (if debug-on-error - (byte-compile-file file) - (condition-case err - (byte-compile-file file) - (file-error - (message (if (cdr err) - ">>Error occurred processing %s: %s (%s)" - ">>Error occurred processing %s: %s") - file - (get (car err) 'error-message) - (prin1-to-string (cdr err))) - (let ((destfile (byte-compile-dest-file file))) - (if (file-exists-p destfile) - (delete-file destfile))) - nil) - (error - (message (if (cdr err) - ">>Error occurred processing %s: %s (%s)" - ">>Error occurred processing %s: %s") - file - (get (car err) 'error-message) - (prin1-to-string (cdr err))) - nil)))) + (let ((byte-compile-root-dir (or byte-compile-root-dir default-directory))) + (if debug-on-error + (byte-compile-file file) + (condition-case err + (byte-compile-file file) + (file-error + (message (if (cdr err) + ">>Error occurred processing %s: %s (%s)" + ">>Error occurred processing %s: %s") + file + (get (car err) 'error-message) + (prin1-to-string (cdr err))) + (let ((destfile (byte-compile-dest-file file))) + (if (file-exists-p destfile) + (delete-file destfile))) + nil) + (error + (message (if (cdr err) + ">>Error occurred processing %s: %s (%s)" + ">>Error occurred processing %s: %s") + file + (get (car err) 'error-message) + (prin1-to-string (cdr err))) + nil))))) (defun byte-compile-refresh-preloaded () "Reload any Lisp file that was changed since Emacs was dumped. -- cgit v1.2.3 From 5dadff364eeed09fbe1eda38e19d17eff729c245 Mon Sep 17 00:00:00 2001 From: Juanma Barranquero Date: Tue, 22 May 2012 18:45:44 +0200 Subject: lisp/emacs-lisp/edebug.el: Do not load cl-specs.el. --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/edebug.el | 8 -------- 2 files changed, 5 insertions(+), 8 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index cd57969f73f..dae3e640cc2 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2012-05-22 Juanma Barranquero + + * emacs-lisp/edebug.el (top): Do not load or setup up loading of + cl-specs.el, which no longer exists. + 2012-05-22 Glenn Morris * info.el (info-emacs-bug): New command. diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index f47feebe5d2..2c7e7cf6362 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1938,7 +1938,6 @@ expressions; a `progn' form will be returned enclosing these forms." ;;;; Edebug Form Specs ;;; ========================================================== -;;; See cl-specs.el for common lisp specs. ;;;;* Spec for def-edebug-spec ;;; Out of date. @@ -4437,13 +4436,6 @@ With prefix argument, make it a temporary breakpoint." ;;; Autoloading of Edebug accessories -(if (featurep 'cl) - (add-hook 'edebug-setup-hook - (function (lambda () (require 'cl-specs)))) - ;; The following causes cl-specs to be loaded if you load cl.el. - (add-hook 'cl-load-hook - (function (lambda () (require 'cl-specs))))) - ;; edebug-cl-read and cl-read are available from liberte@cs.uiuc.edu (if (featurep 'cl-read) (add-hook 'edebug-setup-hook -- cgit v1.2.3