summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r--lisp/emacs-lisp/cl-loaddefs.el3
-rw-r--r--lisp/emacs-lisp/cl-macs.el49
-rw-r--r--lisp/emacs-lisp/debug.el34
-rw-r--r--lisp/emacs-lisp/derived.el4
-rw-r--r--lisp/emacs-lisp/edebug.el2
-rw-r--r--lisp/emacs-lisp/eieio.el116
-rw-r--r--lisp/emacs-lisp/find-func.el8
-rw-r--r--lisp/emacs-lisp/package.el30
-rw-r--r--lisp/emacs-lisp/tabulated-list.el4
9 files changed, 200 insertions, 50 deletions
diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el
index 270211f6a78..d6512306ad1 100644
--- a/lisp/emacs-lisp/cl-loaddefs.el
+++ b/lisp/emacs-lisp/cl-loaddefs.el
@@ -282,7 +282,7 @@ Not documented
;;;;;; 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" "9452c0e16fd960fce5c19e5c067a7160")
+;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "cc8cbd8c86e2facbe61986e992e6c508")
;;; Generated autoloads from cl-macs.el
(autoload 'gensym "cl-macs" "\
@@ -426,6 +426,7 @@ The Common Lisp `do*' loop.
Loop over a list.
Evaluate BODY with VAR bound to each `car' from LIST, in turn.
Then evaluate RESULT to get return value, default nil.
+An implicit nil block is established around the loop.
\(fn (VAR LIST [RESULT]) BODY...)" nil (quote macro))
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index d6b4643d6a4..d9531cc5261 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -238,6 +238,37 @@ It is a list of elements of the form either:
(declare-function help-add-fundoc-usage "help-fns" (docstring arglist))
+(defun cl--make-usage-var (x)
+ "X can be a var or a (destructuring) lambda-list."
+ (cond
+ ((symbolp x) (make-symbol (upcase (symbol-name x))))
+ ((consp x) (cl--make-usage-args x))
+ (t x)))
+
+(defun cl--make-usage-args (arglist)
+ ;; `orig-args' can contain &cl-defs (an internal
+ ;; CL thingy I don't understand), so remove it.
+ (let ((x (memq '&cl-defs arglist)))
+ (when x (setq arglist (delq (car x) (remq (cadr x) arglist)))))
+ (let ((state nil))
+ (mapcar (lambda (x)
+ (cond
+ ((symbolp x)
+ (if (eq ?\& (aref (symbol-name x) 0))
+ (setq state x)
+ (make-symbol (upcase (symbol-name x)))))
+ ((not (consp x)) x)
+ ((memq state '(nil &rest)) (cl--make-usage-args x))
+ (t ;(VAR INITFORM SVAR) or ((KEYWORD VAR) INITFORM SVAR).
+ (list*
+ (if (and (consp (car x)) (eq state '&key))
+ (list (caar x) (cl--make-usage-var (nth 1 (car x))))
+ (cl--make-usage-var (car x)))
+ (nth 1 x) ;INITFORM.
+ (cl--make-usage-args (nthcdr 2 x)) ;SVAR.
+ ))))
+ arglist)))
+
(defun cl-transform-lambda (form bind-block)
(let* ((args (car form)) (body (cdr form)) (orig-args args)
(bind-defs nil) (bind-enquote nil)
@@ -282,11 +313,8 @@ It is a list of elements of the form either:
(require 'help-fns)
(cons (help-add-fundoc-usage
(if (stringp (car hdr)) (pop hdr))
- ;; orig-args can contain &cl-defs (an internal
- ;; CL thingy I don't understand), so remove it.
- (let ((x (memq '&cl-defs orig-args)))
- (if (null x) orig-args
- (delq (car x) (remq (cadr x) orig-args)))))
+ (format "(fn %S)"
+ (cl--make-usage-args orig-args)))
hdr)))
(list (nconc (list 'let* bind-lets)
(nreverse bind-forms) body)))))))
@@ -1233,6 +1261,7 @@ Valid clauses are:
"Loop over a list.
Evaluate BODY with VAR bound to each `car' from LIST, in turn.
Then evaluate RESULT to get return value, default nil.
+An implicit nil block is established around the loop.
\(fn (VAR LIST [RESULT]) BODY...)"
(let ((temp (make-symbol "--cl-dolist-temp--")))
@@ -2387,9 +2416,8 @@ value, that slot cannot be set via `setf'.
(append
(and pred-check
(list (list 'or pred-check
- (list 'error
- (format "%s accessing a non-%s"
- accessor name)))))
+ `(error "%s accessing a non-%s"
+ ',accessor ',name))))
(list (if (eq type 'vector) (list 'aref 'cl-x pos)
(if (= pos 0) '(car cl-x)
(list 'nth pos 'cl-x)))))) forms)
@@ -2397,9 +2425,8 @@ value, that slot cannot be set via `setf'.
(push (list 'define-setf-method accessor '(cl-x)
(if (cadr (memq :read-only (cddr desc)))
(list 'progn '(ignore cl-x)
- (list 'error
- (format "%s is a read-only slot"
- 'accessor)))
+ `(error "%s is a read-only slot"
+ ',accessor))
;; If cl is loaded only for compilation,
;; the call to cl-struct-setf-expander would
;; cause a warning because it may not be
diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el
index 157749500e7..8276030ccf8 100644
--- a/lisp/emacs-lisp/debug.el
+++ b/lisp/emacs-lisp/debug.el
@@ -778,6 +778,7 @@ Redefining FUNCTION also cancels it."
(not (debugger-special-form-p symbol))))
t nil nil (symbol-name fn)))
(list (if (equal val "") fn (intern val)))))
+ ;; FIXME: Use advice.el.
(when (debugger-special-form-p function)
(error "Function %s is a special form" function))
(if (or (symbolp (symbol-function function))
@@ -835,24 +836,30 @@ To specify a nil argument interactively, exit with an empty minibuffer."
(message "Cancelling debug-on-entry for all functions")
(mapcar 'cancel-debug-on-entry debug-function-list)))
+(defun debug-arglist (definition)
+ ;; FIXME: copied from ad-arglist.
+ "Return the argument list of DEFINITION."
+ (require 'help-fns)
+ (help-function-arglist definition 'preserve-names))
+
(defun debug-convert-byte-code (function)
(let* ((defn (symbol-function function))
(macro (eq (car-safe defn) 'macro)))
(when macro (setq defn (cdr defn)))
- (unless (consp defn)
- ;; Assume a compiled code object.
- (let* ((contents (append defn nil))
+ (when (byte-code-function-p defn)
+ (let* ((args (debug-arglist defn))
(body
- (list (list 'byte-code (nth 1 contents)
- (nth 2 contents) (nth 3 contents)))))
- (if (nthcdr 5 contents)
- (setq body (cons (list 'interactive (nth 5 contents)) body)))
- (if (nth 4 contents)
+ `((,(if (memq '&rest args) #'apply #'funcall)
+ ,defn
+ ,@(remq '&rest (remq '&optional args))))))
+ (if (> (length defn) 5)
+ (push `(interactive ,(aref defn 5)) body))
+ (if (aref defn 4)
;; Use `documentation' here, to get the actual string,
;; in case the compiled function has a reference
;; to the .elc file.
(setq body (cons (documentation function) body)))
- (setq defn (cons 'lambda (cons (car contents) body))))
+ (setq defn `(closure (t) ,args ,@body)))
(when macro (setq defn (cons 'macro defn)))
(fset function defn))))
@@ -861,11 +868,12 @@ To specify a nil argument interactively, exit with an empty minibuffer."
(tail defn))
(when (eq (car-safe tail) 'macro)
(setq tail (cdr tail)))
- (if (not (eq (car-safe tail) 'lambda))
+ (if (not (memq (car-safe tail) '(closure lambda)))
;; Only signal an error when we try to set debug-on-entry.
;; When we try to clear debug-on-entry, we are now done.
(when flag
(error "%s is not a user-defined Lisp function" function))
+ (if (eq (car tail) 'closure) (setq tail (cdr tail)))
(setq tail (cdr tail))
;; Skip the docstring.
(when (and (stringp (cadr tail)) (cddr tail))
@@ -875,9 +883,9 @@ To specify a nil argument interactively, exit with an empty minibuffer."
(setq tail (cdr tail)))
(unless (eq flag (equal (cadr tail) '(implement-debug-on-entry)))
;; Add/remove debug statement as needed.
- (if flag
- (setcdr tail (cons '(implement-debug-on-entry) (cdr tail)))
- (setcdr tail (cddr tail)))))
+ (setcdr tail (if flag
+ (cons '(implement-debug-on-entry) (cdr tail))
+ (cddr tail)))))
defn))
(defun debugger-list-functions ()
diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el
index 4fda2bf1d52..81932f9940a 100644
--- a/lisp/emacs-lisp/derived.el
+++ b/lisp/emacs-lisp/derived.el
@@ -133,10 +133,10 @@ BODY can start with a bunch of keyword arguments. The following keyword
Declare the customization group that corresponds to this mode.
The command `customize-mode' uses this.
:syntax-table TABLE
- Use TABLE instead of the default.
+ Use TABLE instead of the default (CHILD-syntax-table).
A nil value means to simply use the same syntax-table as the parent.
:abbrev-table TABLE
- Use TABLE instead of the default.
+ Use TABLE instead of the default (CHILD-abbrev-table).
A nil value means to simply use the same abbrev-table as the parent.
Here is how you could define LaTeX-Thesis mode as a variant of LaTeX mode:
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index f84de0308bf..57d25c9e169 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -3408,7 +3408,7 @@ go to the end of the last sexp, or if that is the same point, then step."
(message "%s is already instrumented." func)
func)
(t
- (let ((loc (find-function-noselect func)))
+ (let ((loc (find-function-noselect func t)))
(unless (cdr loc)
(error "Could not find the definition in its file"))
(with-current-buffer (car loc)
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index 83c09b6fe0f..f1fe9594fc0 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -1312,20 +1312,20 @@ Summary:
(defun eieio--defmethod (method kind argclass code)
"Work part of the `defmethod' macro defining METHOD with ARGS."
(let ((key
- ;; find optional keys
+ ;; find optional keys
(cond ((or (eq ':BEFORE kind)
(eq ':before kind))
- method-before)
+ method-before)
((or (eq ':AFTER kind)
(eq ':after kind))
- method-after)
+ method-after)
((or (eq ':PRIMARY kind)
(eq ':primary kind))
- method-primary)
+ method-primary)
((or (eq ':STATIC kind)
(eq ':static kind))
- method-static)
- ;; Primary key
+ method-static)
+ ;; Primary key
(t method-primary))))
;; Make sure there is a generic (when called from defclass).
(eieio--defalias
@@ -1338,8 +1338,8 @@ Summary:
;; under the type `primary' which is a non-specific calling of the
;; function.
(if argclass
- (if (not (class-p argclass))
- (error "Unknown class type %s in method parameters"
+ (if (not (class-p argclass))
+ (error "Unknown class type %s in method parameters"
argclass))
(if (= key -1)
(signal 'wrong-type-argument (list :static 'non-class-arg)))
@@ -2864,6 +2864,106 @@ of `eq'."
)
+;;; Obsolete backward compatibility functions.
+;; Needed to run byte-code compiled with the EIEIO of Emacs-23.
+
+(defun eieio-defmethod (method args)
+ "Obsolete work part of an old version of the `defmethod' macro."
+ (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa)
+ ;; find optional keys
+ (setq key
+ (cond ((or (eq ':BEFORE (car args))
+ (eq ':before (car args)))
+ (setq args (cdr args))
+ method-before)
+ ((or (eq ':AFTER (car args))
+ (eq ':after (car args)))
+ (setq args (cdr args))
+ method-after)
+ ((or (eq ':PRIMARY (car args))
+ (eq ':primary (car args)))
+ (setq args (cdr args))
+ method-primary)
+ ((or (eq ':STATIC (car args))
+ (eq ':static (car args)))
+ (setq args (cdr args))
+ method-static)
+ ;; Primary key
+ (t method-primary)))
+ ;; get body, and fix contents of args to be the arguments of the fn.
+ (setq body (cdr args)
+ args (car args))
+ (setq loopa args)
+ ;; Create a fixed version of the arguments
+ (while loopa
+ (setq argfix (cons (if (listp (car loopa)) (car (car loopa)) (car loopa))
+ argfix))
+ (setq loopa (cdr loopa)))
+ ;; make sure there is a generic
+ (eieio-defgeneric
+ method
+ (if (stringp (car body))
+ (car body) (format "Generically created method `%s'." method)))
+ ;; create symbol for property to bind to. If the first arg is of
+ ;; the form (varname vartype) and `vartype' is a class, then
+ ;; that class will be the type symbol. If not, then it will fall
+ ;; under the type `primary' which is a non-specific calling of the
+ ;; function.
+ (setq firstarg (car args))
+ (if (listp firstarg)
+ (progn
+ (setq argclass (nth 1 firstarg))
+ (if (not (class-p argclass))
+ (error "Unknown class type %s in method parameters"
+ (nth 1 firstarg))))
+ (if (= key -1)
+ (signal 'wrong-type-argument (list :static 'non-class-arg)))
+ ;; generics are higher
+ (setq key (eieio-specialized-key-to-generic-key key)))
+ ;; Put this lambda into the symbol so we can find it
+ (if (byte-code-function-p (car-safe body))
+ (eieiomt-add method (car-safe body) key argclass)
+ (eieiomt-add method (append (list 'lambda (reverse argfix)) body)
+ key argclass))
+ )
+
+ (when eieio-optimize-primary-methods-flag
+ ;; Optimizing step:
+ ;;
+ ;; If this method, after this setup, only has primary methods, then
+ ;; we can setup the generic that way.
+ (if (generic-primary-only-p method)
+ ;; If there is only one primary method, then we can go one more
+ ;; optimization step.
+ (if (generic-primary-only-one-p method)
+ (eieio-defgeneric-reset-generic-form-primary-only-one method)
+ (eieio-defgeneric-reset-generic-form-primary-only method))
+ (eieio-defgeneric-reset-generic-form method)))
+
+ method)
+(make-obsolete 'eieio-defmethod 'eieio--defmethod "24.1")
+
+(defun eieio-defgeneric (method doc-string)
+ "Obsolete work part of an old version of the `defgeneric' macro."
+ (if (and (fboundp method) (not (generic-p method))
+ (or (byte-code-function-p (symbol-function method))
+ (not (eq 'autoload (car (symbol-function method)))))
+ )
+ (error "You cannot create a generic/method over an existing symbol: %s"
+ method))
+ ;; Don't do this over and over.
+ (unless (fboundp 'method)
+ ;; This defun tells emacs where the first definition of this
+ ;; method is defined.
+ `(defun ,method nil)
+ ;; Make sure the method tables are installed.
+ (eieiomt-install method)
+ ;; Apply the actual body of this function.
+ (fset method (eieio-defgeneric-form method doc-string))
+ ;; Return the method
+ 'method))
+(make-obsolete 'eieio-defgeneric nil "24.1")
+
;;; Interfacing with edebug
;;
(defun eieio-edebug-prin1-to-string (object &optional noescape)
diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el
index 0194af2e3a8..2c7208db8a3 100644
--- a/lisp/emacs-lisp/find-func.el
+++ b/lisp/emacs-lisp/find-func.el
@@ -312,7 +312,7 @@ The search is done in the source for library LIBRARY."
(cons (current-buffer) nil))))))))
;;;###autoload
-(defun find-function-noselect (function)
+(defun find-function-noselect (function &optional lisp-only)
"Return a pair (BUFFER . POINT) pointing to the definition of FUNCTION.
Finds the source file containing the definition of FUNCTION
@@ -320,6 +320,10 @@ in a buffer and the point of the definition. The buffer is
not selected. If the function definition can't be found in
the buffer, returns (BUFFER).
+If FUNCTION is a built-in function, this function normally
+attempts to find it in the Emacs C sources; however, if LISP-ONLY
+is non-nil, signal an error instead.
+
If the file where FUNCTION is defined is not known, then it is
searched for in `find-function-source-path' if non-nil, otherwise
in `load-path'."
@@ -345,6 +349,8 @@ in `load-path'."
(cond ((eq (car-safe def) 'autoload)
(nth 1 def))
((subrp def)
+ (if lisp-only
+ (error "%s is a built-in function" function))
(help-C-file-name def 'subr))
((symbol-file function 'defun)))))
(find-function-search-for-symbol function nil library))))
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index e42103a7a01..caf0ec2e8b8 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -570,11 +570,11 @@ EXTRA-PROPERTIES is currently unused."
file)
(defun package-generate-autoloads (name pkg-dir)
+ (require 'autoload) ;Load before we let-bind generated-autoload-file!
(let* ((auto-name (concat name "-autoloads.el"))
(ignore-name (concat name "-pkg.el"))
(generated-autoload-file (expand-file-name auto-name pkg-dir))
(version-control 'never))
- (require 'autoload)
(unless (fboundp 'autoload-ensure-default-file)
(package-autoload-ensure-default-file generated-autoload-file))
(update-directory-autoloads pkg-dir)))
@@ -852,18 +852,26 @@ using `package-compute-transaction'."
(t
(error "Unknown package kind: %s" (symbol-name kind)))))))
+(defvar package--initialized nil)
+
;;;###autoload
(defun package-install (name)
"Install the package named NAME.
-Interactively, prompt for the package name.
-The package is found on one of the archives in `package-archives'."
+NAME should be the name of one of the available packages in an
+archive in `package-archives'. Interactively, prompt for NAME."
(interactive
- (list (intern (completing-read "Install package: "
- (mapcar (lambda (elt)
- (cons (symbol-name (car elt))
- nil))
- package-archive-contents)
- nil t))))
+ (progn
+ ;; Initialize the package system to get the list of package
+ ;; symbols for completion.
+ (unless package--initialized
+ (package-initialize t))
+ (list (intern (completing-read
+ "Install package: "
+ (mapcar (lambda (elt)
+ (cons (symbol-name (car elt))
+ nil))
+ package-archive-contents)
+ nil t)))))
(let ((pkg-desc (assq name package-archive-contents)))
(unless pkg-desc
(error "Package `%s' is not available for installation"
@@ -1076,8 +1084,6 @@ makes them available for download."
(car archive)))))
(package-read-all-archive-contents))
-(defvar package--initialized nil)
-
;;;###autoload
(defun package-initialize (&optional no-activate)
"Load Emacs Lisp packages, and activate them.
@@ -1434,7 +1440,7 @@ If optional arg BUTTON is non-nil, describe its associated package."
(defun package-menu-mark-delete (num)
"Mark a package for deletion and move to the next line."
(interactive "p")
- (if (string-equal (package-menu-get-status) "installed")
+ (if (member (package-menu-get-status) '("installed" "obsolete"))
(tabulated-list-put-tag "D" t)
(forward-line)))
diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el
index 2fdfa9525b1..75c9a01323d 100644
--- a/lisp/emacs-lisp/tabulated-list.el
+++ b/lisp/emacs-lisp/tabulated-list.el
@@ -258,7 +258,8 @@ to the entry with the same ID element as the current line."
;; If REMEMBER-POS was specified, move to the "old" location.
(if saved-pt
(progn (goto-char saved-pt)
- (move-to-column saved-col))
+ (move-to-column saved-col)
+ (recenter))
(goto-char (point-min)))))
(defun tabulated-list-print-entry (id cols)
@@ -282,6 +283,7 @@ of column descriptors."
(> (length label) width)
(setq label (concat (substring label 0 (- width 3))
"...")))
+ (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)))
View Lorry Controller Status