summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r--lisp/emacs-lisp/byte-run.el70
-rw-r--r--lisp/emacs-lisp/bytecomp.el73
-rw-r--r--lisp/emacs-lisp/cl-extra.el51
-rw-r--r--lisp/emacs-lisp/cl-indent.el62
-rw-r--r--lisp/emacs-lisp/cl-lib.el4
-rw-r--r--lisp/emacs-lisp/cl-macs.el100
-rw-r--r--lisp/emacs-lisp/cl-seq.el6
-rw-r--r--lisp/emacs-lisp/eldoc.el34
-rw-r--r--lisp/emacs-lisp/gulp.el178
-rw-r--r--lisp/emacs-lisp/lisp-mode.el28
-rw-r--r--lisp/emacs-lisp/lisp.el116
-rw-r--r--lisp/emacs-lisp/macroexp.el11
12 files changed, 385 insertions, 348 deletions
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index 4b9e6d8fd23..0edcf6197b4 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -30,6 +30,17 @@
;;; Code:
+(defalias 'function-put
+ ;; We don't want people to just use `put' because we can't conveniently
+ ;; hook into `put' to remap old properties to new ones. But for now, there's
+ ;; no such remapping, so we just call `put'.
+ #'(lambda (f prop value) (put f prop value))
+ "Set function F's property PROP to VALUE.
+The namespace for PROP is shared with symbols.
+So far, F can only be a symbol, not a lambda expression.")
+(function-put 'defmacro 'doc-string-elt 3)
+(function-put 'defmacro 'lisp-indent-function 2)
+
;; `macro-declaration-function' are both obsolete (as marked at the end of this
;; file) but used in many .elc files.
@@ -69,6 +80,7 @@ The return value of this function is not used."
;; handle declarations in macro definitions and this is the first file
;; loaded by loadup.el that uses declarations in macros.
+;; Add any new entries to info node `(elisp)Declare Form'.
(defvar defun-declarations-alist
(list
;; We can only use backquotes inside the lambdas and not for those
@@ -81,27 +93,47 @@ The return value of this function is not used."
#'(lambda (f _args new-name when)
(list 'make-obsolete
(list 'quote f) (list 'quote new-name) (list 'quote when))))
+ (list 'interactive-only
+ #'(lambda (f _args instead)
+ (list 'function-put (list 'quote f)
+ ''interactive-only (list 'quote instead))))
+ ;; FIXME: Merge `pure' and `side-effect-free'.
+ (list 'pure
+ #'(lambda (f _args val)
+ (list 'function-put (list 'quote f)
+ ''pure (list 'quote val)))
+ "If non-nil, the compiler can replace calls with their return value.
+This may shift errors from run-time to compile-time.")
+ (list 'side-effect-free
+ #'(lambda (f _args val)
+ (list 'function-put (list 'quote f)
+ ''side-effect-free (list 'quote val)))
+ "If non-nil, calls can be ignored if their value is unused.
+If `error-free', drop calls even if `byte-compile-delete-errors' is nil.")
(list 'compiler-macro
#'(lambda (f args compiler-function)
`(eval-and-compile
- (put ',f 'compiler-macro
- ,(if (eq (car-safe compiler-function) 'lambda)
- `(lambda ,(append (cadr compiler-function) args)
- ,@(cddr compiler-function))
- `#',compiler-function)))))
+ (function-put ',f 'compiler-macro
+ ,(if (eq (car-safe compiler-function) 'lambda)
+ `(lambda ,(append (cadr compiler-function) args)
+ ,@(cddr compiler-function))
+ `#',compiler-function)))))
(list 'doc-string
#'(lambda (f _args pos)
- (list 'put (list 'quote f) ''doc-string-elt (list 'quote pos))))
+ (list 'function-put (list 'quote f)
+ ''doc-string-elt (list 'quote pos))))
(list 'indent
#'(lambda (f _args val)
- (list 'put (list 'quote f)
+ (list 'function-put (list 'quote f)
''lisp-indent-function (list 'quote val)))))
"List associating function properties to their macro expansion.
Each element of the list takes the form (PROP FUN) where FUN is
a function. For each (PROP . VALUES) in a function's declaration,
the FUN corresponding to PROP is called with the function name,
the function's arglist, and the VALUES and should return the code to use
-to set this property.")
+to set this property.
+
+This is used by `declare'.")
(defvar macro-declarations-alist
(cons
@@ -115,10 +147,10 @@ to set this property.")
Each element of the list takes the form (PROP FUN) where FUN is a function.
For each (PROP . VALUES) in a macro's declaration, the FUN corresponding
to PROP is called with the macro name, the macro's arglist, and the VALUES
-and should return the code to use to set this property.")
+and should return the code to use to set this property.
+
+This is used by `declare'.")
-(put 'defmacro 'doc-string-elt 3)
-(put 'defmacro 'lisp-indent-function 2)
(defalias 'defmacro
(cons
'macro
@@ -218,7 +250,8 @@ The return value is undefined.
(cons arglist body))))))
(if declarations
(cons 'prog1 (cons def declarations))
- def))))
+ def))))
+
;; Redefined in byte-optimize.el.
;; This is not documented--it's not clear that we should promote it.
@@ -389,13 +422,20 @@ If you think you need this, you're probably making a mistake somewhere."
(defmacro eval-when-compile (&rest body)
"Like `progn', but evaluates the body at compile time if you're compiling.
-Thus, the result of the body appears to the compiler as a quoted constant.
-In interpreted code, this is entirely equivalent to `progn'."
+Thus, the result of the body appears to the compiler as a quoted
+constant. In interpreted code, this is entirely equivalent to
+`progn', except that the value of the expression may be (but is
+not necessarily) computed at load time if eager macro expansion
+is enabled."
(declare (debug (&rest def-form)) (indent 0))
(list 'quote (eval (cons 'progn body) lexical-binding)))
(defmacro eval-and-compile (&rest body)
- "Like `progn', but evaluates the body at compile time and at load time."
+ "Like `progn', but evaluates the body at compile time and at
+load time. In interpreted code, this is entirely equivalent to
+`progn', except that the value of the expression may be (but is
+not necessarily) computed at load time if eager macro expansion
+is enabled."
(declare (debug t) (indent 0))
;; When the byte-compiler expands code, this macro is not used, so we're
;; either about to run `body' (plain interpretation) or we're doing eager
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index e5f8a8cc22a..9c52cc44eb4 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -421,31 +421,46 @@ Filled in `cconv-analyse-form' but initialized and consulted here.")
(defvar byte-compiler-error-flag)
+(defun byte-compile-recurse-toplevel (form non-toplevel-case)
+ "Implement `eval-when-compile' and `eval-and-compile'.
+Return the compile-time value of FORM."
+ ;; Macroexpand (not macroexpand-all!) form at toplevel in case it
+ ;; expands into a toplevel-equivalent `progn'. See CLHS section
+ ;; 3.2.3.1, "Processing of Top Level Forms". The semantics are very
+ ;; subtle: see test/automated/bytecomp-tests.el for interesting
+ ;; cases.
+ (setf form (macroexpand form byte-compile-macro-environment))
+ (if (eq (car-safe form) 'progn)
+ (cons 'progn
+ (mapcar (lambda (subform)
+ (byte-compile-recurse-toplevel
+ subform non-toplevel-case))
+ (cdr form)))
+ (funcall non-toplevel-case form)))
+
(defconst byte-compile-initial-macro-environment
- '(
+ `(
;; (byte-compiler-options . (lambda (&rest forms)
;; (apply 'byte-compiler-options-handler forms)))
(declare-function . byte-compile-macroexpand-declare-function)
- (eval-when-compile . (lambda (&rest body)
- (list
- 'quote
- (byte-compile-eval
- (byte-compile-top-level
- (byte-compile-preprocess (cons 'progn body)))))))
- (eval-and-compile . (lambda (&rest body)
- ;; Byte compile before running it. Do it piece by
- ;; piece, in case further expressions need earlier
- ;; ones to be evaluated already, as is the case in
- ;; eieio.el.
- `(progn
- ,@(mapcar (lambda (exp)
- (let ((cexp
- (byte-compile-top-level
- (byte-compile-preprocess
- exp))))
- (eval cexp)
- cexp))
- body)))))
+ (eval-when-compile . ,(lambda (&rest body)
+ (let ((result nil))
+ (byte-compile-recurse-toplevel
+ (cons 'progn body)
+ (lambda (form)
+ (setf result
+ (byte-compile-eval
+ (byte-compile-top-level
+ (byte-compile-preprocess form))))))
+ (list 'quote result))))
+ (eval-and-compile . ,(lambda (&rest body)
+ (byte-compile-recurse-toplevel
+ (cons 'progn body)
+ (lambda (form)
+ (let ((compiled (byte-compile-top-level
+ (byte-compile-preprocess form))))
+ (eval compiled lexical-binding)
+ compiled))))))
"The default macro-environment passed to macroexpand by the compiler.
Placing a macro here will cause a macro to have different semantics when
expanded by the compiler as when expanded by the interpreter.")
@@ -2198,9 +2213,12 @@ list that represents a doc string reference.
(t form)))
;; byte-hunk-handlers cannot call this!
-(defun byte-compile-toplevel-file-form (form)
- (let ((byte-compile-current-form nil)) ; close over this for warnings.
- (byte-compile-file-form (byte-compile-preprocess form t))))
+(defun byte-compile-toplevel-file-form (top-level-form)
+ (byte-compile-recurse-toplevel
+ top-level-form
+ (lambda (form)
+ (let ((byte-compile-current-form nil)) ; close over this for warnings.
+ (byte-compile-file-form (byte-compile-preprocess form t))))))
;; byte-hunk-handlers can call this.
(defun byte-compile-file-form (form)
@@ -2942,8 +2960,11 @@ for symbols generated by the byte compiler itself."
interactive-only))
(t "."))))
(if (eq (car-safe (symbol-function (car form))) 'macro)
- (byte-compile-log-warning
- (format "Forgot to expand macro %s" (car form)) nil :error))
+ (progn
+ (debug)
+ (byte-compile-log-warning
+ (format "Forgot to expand macro %s in %S" (car form) form)
+ nil :error)))
(if (and handler
;; Make sure that function exists.
(and (functionp handler)
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index 9b28289e0b9..3761d04c2c2 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -269,43 +269,20 @@ If so, return the true (non-nil) value returned by PREDICATE.
;;;###autoload
(defun cl--map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg)
(or cl-buffer (setq cl-buffer (current-buffer)))
- (if (fboundp 'overlay-lists)
-
- ;; This is the preferred algorithm, though overlay-lists is undocumented.
- (let (cl-ovl)
- (with-current-buffer cl-buffer
- (setq cl-ovl (overlay-lists))
- (if cl-start (setq cl-start (copy-marker cl-start)))
- (if cl-end (setq cl-end (copy-marker cl-end))))
- (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl)))
- (while (and cl-ovl
- (or (not (overlay-start (car cl-ovl)))
- (and cl-end (>= (overlay-start (car cl-ovl)) cl-end))
- (and cl-start (<= (overlay-end (car cl-ovl)) cl-start))
- (not (funcall cl-func (car cl-ovl) cl-arg))))
- (setq cl-ovl (cdr cl-ovl)))
- (if cl-start (set-marker cl-start nil))
- (if cl-end (set-marker cl-end nil)))
-
- ;; This alternate algorithm fails to find zero-length overlays.
- (let ((cl-mark (with-current-buffer cl-buffer
- (copy-marker (or cl-start (point-min)))))
- (cl-mark2 (and cl-end (with-current-buffer cl-buffer
- (copy-marker cl-end))))
- cl-pos cl-ovl)
- (while (save-excursion
- (and (setq cl-pos (marker-position cl-mark))
- (< cl-pos (or cl-mark2 (point-max)))
- (progn
- (set-buffer cl-buffer)
- (setq cl-ovl (overlays-at cl-pos))
- (set-marker cl-mark (next-overlay-change cl-pos)))))
- (while (and cl-ovl
- (or (/= (overlay-start (car cl-ovl)) cl-pos)
- (not (and (funcall cl-func (car cl-ovl) cl-arg)
- (set-marker cl-mark nil)))))
- (setq cl-ovl (cdr cl-ovl))))
- (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))))
+ (let (cl-ovl)
+ (with-current-buffer cl-buffer
+ (setq cl-ovl (overlay-lists))
+ (if cl-start (setq cl-start (copy-marker cl-start)))
+ (if cl-end (setq cl-end (copy-marker cl-end))))
+ (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl)))
+ (while (and cl-ovl
+ (or (not (overlay-start (car cl-ovl)))
+ (and cl-end (>= (overlay-start (car cl-ovl)) cl-end))
+ (and cl-start (<= (overlay-end (car cl-ovl)) cl-start))
+ (not (funcall cl-func (car cl-ovl) cl-arg))))
+ (setq cl-ovl (cdr cl-ovl)))
+ (if cl-start (set-marker cl-start nil))
+ (if cl-end (set-marker cl-end nil))))
;;; Support for `setf'.
;;;###autoload
diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el
index 6c62ce5c830..2d8a1c4c1c2 100644
--- a/lisp/emacs-lisp/cl-indent.el
+++ b/lisp/emacs-lisp/cl-indent.el
@@ -27,6 +27,8 @@
;; This package supplies a single entry point, common-lisp-indent-function,
;; which performs indentation in the preferred style for Common Lisp code.
+;; It is also a suitable function for indenting Emacs lisp code.
+;;
;; To enable it:
;;
;; (setq lisp-indent-function 'common-lisp-indent-function)
@@ -154,6 +156,15 @@ is set to `defun'.")
(looking-at "\\sw"))
(error t)))
+(defun lisp-indent-find-method (symbol &optional no-compat)
+ "Find the lisp indentation function for SYMBOL.
+If NO-COMPAT is non-nil, do not retrieve indenters intended for
+the standard lisp indent package."
+ (or (and (derived-mode-p 'emacs-lisp-mode)
+ (get symbol 'common-lisp-indent-function-for-elisp))
+ (get symbol 'common-lisp-indent-function)
+ (and (not no-compat)
+ (get symbol 'lisp-indent-function))))
(defun common-lisp-loop-part-indentation (indent-point state)
"Compute the indentation of loop form constituents."
@@ -245,9 +256,17 @@ For example, the function `case' has an indent property
* indent the first argument by 4.
* arguments after the first should be lists, and there may be any number
of them. The first list element has an offset of 2, all the rest
- have an offset of 2+1=3."
+ have an offset of 2+1=3.
+
+If the current mode is actually `emacs-lisp-mode', look for a
+`common-lisp-indent-function-for-elisp' property before looking
+at `common-lisp-indent-function' and, if set, use its value
+instead."
+ ;; FIXME: why do we need to special-case loop?
(if (save-excursion (goto-char (elt state 1))
- (looking-at "([Ll][Oo][Oo][Pp]"))
+ (looking-at (if (derived-mode-p 'emacs-lisp-mode)
+ "(\\(cl-\\)?[Ll][Oo][Oo][Pp]"
+ "([Ll][Oo][Oo][Pp]")))
(common-lisp-loop-part-indentation indent-point state)
(common-lisp-indent-function-1 indent-point state)))
@@ -291,18 +310,29 @@ For example, the function `case' has an indent property
(setq function (downcase (buffer-substring-no-properties
tem (point))))
(goto-char tem)
+ ;; Elisp generally provides CL functionality with a CL
+ ;; prefix, so if we have a special indenter for the
+ ;; unprefixed version, prefer it over whatever's defined
+ ;; for the cl- version. Users can override this
+ ;; heuristic by defining a
+ ;; common-lisp-indent-function-for-elisp property on the
+ ;; cl- version.
+ (when (and (derived-mode-p 'emacs-lisp-mode)
+ (not (lisp-indent-find-method
+ (intern-soft function) t))
+ (string-match "\\`cl-" function)
+ (setf tem (intern-soft
+ (substring function (match-end 0))))
+ (lisp-indent-find-method tem t))
+ (setf function (symbol-name tem)))
(setq tem (intern-soft function)
- method (get tem 'common-lisp-indent-function))
- (cond ((and (null method)
- (string-match ":[^:]+" function))
- ;; The pleblisp package feature
- (setq function (substring function
- (1+ (match-beginning 0)))
- method (get (intern-soft function)
- 'common-lisp-indent-function)))
- ((and (null method))
- ;; backwards compatibility
- (setq method (get tem 'lisp-indent-function)))))
+ method (lisp-indent-find-method tem))
+ ;; The pleblisp package feature
+ (when (and (null tem)
+ (string-match ":[^:]+" function))
+ (setq function (substring function (1+ (match-beginning 0)))
+ tem (intern-soft function)
+ method (lisp-indent-find-method tem))))
(let ((n 0))
;; How far into the containing form is the current form?
(if (< (point) indent-point)
@@ -764,7 +794,11 @@ optional\\|rest\\|key\\|allow-other-keys\\|aux\\|whole\\|body\\|environment\
(put (car el) 'common-lisp-indent-function
(if (symbolp (cdr el))
(get (cdr el) 'common-lisp-indent-function)
- (car (cdr el))))))
+ (car (cdr el))))))
+
+;; In elisp, the else part of `if' is in an implicit progn, so indent
+;; it more.
+(put 'if 'common-lisp-indent-function-for-elisp 2)
;(defun foo (x)
diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el
index 219d76f85d1..929e3dfb2f5 100644
--- a/lisp/emacs-lisp/cl-lib.el
+++ b/lisp/emacs-lisp/cl-lib.el
@@ -152,9 +152,6 @@ an element already on the list.
`(setq ,place (cl-adjoin ,x ,place ,@keys)))
`(cl-callf2 cl-adjoin ,x ,place ,@keys)))
-(defun cl--set-elt (seq n val)
- (if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val)))
-
(defun cl--set-buffer-substring (start end val)
(save-excursion (delete-region start end)
(goto-char start)
@@ -625,7 +622,6 @@ If ALIST is non-nil, the new pairs are prepended to it."
`(insert (prog1 ,store (erase-buffer))))
(gv-define-simple-setter buffer-substring cl--set-buffer-substring)
(gv-define-simple-setter current-buffer set-buffer)
-(gv-define-simple-setter current-case-table set-case-table)
(gv-define-simple-setter current-column move-to-column t)
(gv-define-simple-setter current-global-map use-global-map t)
(gv-define-setter current-input-mode (store)
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 1c163273b64..58c3638b58b 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -135,7 +135,13 @@
(t t)))
(defun cl--const-expr-val (x)
- (and (macroexp-const-p x) (if (consp x) (nth 1 x) x)))
+ "Return the value of X known at compile-time.
+If X is not known at compile time, return nil. Before testing
+whether X is known at compile time, macroexpand it completely in
+`macroexpand-all-environment'."
+ (let ((x (macroexpand-all x macroexpand-all-environment)))
+ (if (macroexp-const-p x)
+ (if (consp x) (nth 1 x) x))))
(defun cl--expr-contains (x y)
"Count number of times X refers to Y. Return nil for 0 times."
@@ -1542,7 +1548,7 @@ If BODY is `setq', then use SPECS for assignments rather than for bindings."
(if (and (cl--unused-var-p temp) (null expr))
nil ;; Don't bother declaring/setting `temp' since it won't
;; be used when `expr' is nil, anyway.
- (when (or (null temp)
+ (when (or (null temp)
(and (eq body 'setq) (cl--unused-var-p temp)))
;; Prefer a fresh uninterned symbol over "_to", to avoid
;; warnings that we set an unused variable.
@@ -2059,10 +2065,21 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C).
(declare (debug t))
(cons 'progn body))
;;;###autoload
-(defmacro cl-the (_type form)
- "At present this ignores TYPE and is simply equivalent to FORM."
+(defmacro cl-the (type form)
+ "Return FORM. If type-checking is enabled, assert that it is of TYPE."
(declare (indent 1) (debug (cl-type-spec form)))
- form)
+ (if (not (or (not (cl--compiling-file))
+ (< cl--optimize-speed 3)
+ (= cl--optimize-safety 3)))
+ form
+ (let* ((temp (if (cl--simple-expr-p form 3)
+ form (make-symbol "--cl-var--")))
+ (body `(progn (unless ,(cl--make-type-test temp type)
+ (signal 'wrong-type-argument
+ (list ',type ,temp ',form)))
+ ,temp)))
+ (if (eq temp form) body
+ `(let ((,temp ,form)) ,body)))))
(defvar cl--proclaim-history t) ; for future compilers
(defvar cl--declare-stack t) ; for future compilers
@@ -2574,21 +2591,38 @@ non-nil value, that slot cannot be set via `setf'.
(put ',name 'cl-struct-include ',include)
(put ',name 'cl-struct-print ,print-auto)
,@(mapcar (lambda (x)
- `(put ',(car x) 'side-effect-free ',(cdr x)))
+ `(function-put ',(car x) 'side-effect-free ',(cdr x)))
side-eff))
forms)
`(progn ,@(nreverse (cons `',name forms)))))
-;;; Types and assertions.
-
-;;;###autoload
-(defmacro cl-deftype (name arglist &rest body)
- "Define NAME as a new data type.
-The type name can then be used in `cl-typecase', `cl-check-type', etc."
- (declare (debug cl-defmacro) (doc-string 3))
- `(cl-eval-when (compile load eval)
- (put ',name 'cl-deftype-handler
- (cl-function (lambda (&cl-defs '('*) ,@arglist) ,@body)))))
+(defun cl-struct-sequence-type (struct-type)
+ "Return the sequence used to build STRUCT-TYPE.
+STRUCT-TYPE is a symbol naming a struct type. Return 'vector or
+'list, or nil if STRUCT-TYPE is not a struct type. "
+ (declare (side-effect-free t) (pure t))
+ (car (get struct-type 'cl-struct-type)))
+
+(defun cl-struct-slot-info (struct-type)
+ "Return a list of slot names of struct STRUCT-TYPE.
+Each entry is a list (SLOT-NAME . OPTS), where SLOT-NAME is a
+slot name symbol and OPTS is a list of slot options given to
+`cl-defstruct'. Dummy slots that represent the struct name and
+slots skipped by :initial-offset may appear in the list."
+ (declare (side-effect-free t) (pure t))
+ (get struct-type 'cl-struct-slots))
+
+(defun cl-struct-slot-offset (struct-type slot-name)
+ "Return the offset of slot SLOT-NAME in STRUCT-TYPE.
+The returned zero-based slot index is relative to the start of
+the structure data type and is adjusted for any structure name
+and :initial-offset slots. Signal error if struct STRUCT-TYPE
+does not contain SLOT-NAME."
+ (declare (side-effect-free t) (pure t))
+ (or (cl-position slot-name
+ (cl-struct-slot-info struct-type)
+ :key #'car :test #'eq)
+ (error "struct %s has no slot %s" struct-type slot-name)))
(defvar byte-compile-function-environment)
(defvar byte-compile-macro-environment)
@@ -2875,19 +2909,47 @@ The function's arguments should be treated as immutable.
;;; Things that are inline.
(cl-proclaim '(inline cl-acons cl-map cl-concatenate cl-notany
- cl-notevery cl--set-elt cl-revappend cl-nreconc gethash))
+ cl-notevery cl-revappend cl-nreconc gethash))
;;; Things that are side-effect-free.
-(mapc (lambda (x) (put x 'side-effect-free t))
+(mapc (lambda (x) (function-put x 'side-effect-free t))
'(cl-oddp cl-evenp cl-signum last butlast cl-ldiff cl-pairlis cl-gcd
cl-lcm cl-isqrt cl-floor cl-ceiling cl-truncate cl-round cl-mod cl-rem
cl-subseq cl-list-length cl-get cl-getf))
;;; Things that are side-effect-and-error-free.
-(mapc (lambda (x) (put x 'side-effect-free 'error-free))
+(mapc (lambda (x) (function-put x 'side-effect-free 'error-free))
'(eql cl-list* cl-subst cl-acons cl-equalp
cl-random-state-p copy-tree cl-sublis))
+;;; Types and assertions.
+
+;;;###autoload
+(defmacro cl-deftype (name arglist &rest body)
+ "Define NAME as a new data type.
+The type name can then be used in `cl-typecase', `cl-check-type', etc."
+ (declare (debug cl-defmacro) (doc-string 3))
+ `(cl-eval-when (compile load eval)
+ (put ',name 'cl-deftype-handler
+ (cl-function (lambda (&cl-defs '('*) ,@arglist) ,@body)))))
+
+;;; Additional functions that we can now define because we've defined
+;;; `cl-defsubst' and `cl-typep'.
+
+(cl-defsubst cl-struct-slot-value (struct-type slot-name inst)
+ ;; The use of `cl-defsubst' here gives us both a compiler-macro
+ ;; and a gv-expander "for free".
+ "Return the value of slot SLOT-NAME in INST of STRUCT-TYPE.
+STRUCT and SLOT-NAME are symbols. INST is a structure instance."
+ (declare (side-effect-free t))
+ (unless (cl-typep inst struct-type)
+ (signal 'wrong-type-argument (list struct-type inst)))
+ ;; We could use `elt', but since the byte compiler will resolve the
+ ;; branch below at compile time, it's more efficient to use the
+ ;; type-specific accessor.
+ (if (eq (cl-struct-sequence-type struct-type) 'vector)
+ (aref inst (cl-struct-slot-offset struct-type slot-name))
+ (nth (cl-struct-slot-offset struct-type slot-name) inst)))
(run-hooks 'cl-macs-load-hook)
diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el
index aa88264c4ab..a7078328748 100644
--- a/lisp/emacs-lisp/cl-seq.el
+++ b/lisp/emacs-lisp/cl-seq.el
@@ -166,7 +166,7 @@ SEQ1 is destructively modified, then returned.
(cl-n (min (- (or cl-end1 cl-len) cl-start1)
(- (or cl-end2 cl-len) cl-start2))))
(while (>= (setq cl-n (1- cl-n)) 0)
- (cl--set-elt cl-seq1 (+ cl-start1 cl-n)
+ (setf (elt cl-seq1 (+ cl-start1 cl-n))
(elt cl-seq2 (+ cl-start2 cl-n))))))
(if (listp cl-seq1)
(let ((cl-p1 (nthcdr cl-start1 cl-seq1))
@@ -392,7 +392,7 @@ to avoid corrupting the original SEQ.
cl-seq
(setq cl-seq (copy-sequence cl-seq))
(or cl-from-end
- (progn (cl--set-elt cl-seq cl-i cl-new)
+ (progn (setf (elt cl-seq cl-i) cl-new)
(setq cl-i (1+ cl-i) cl-count (1- cl-count))))
(apply 'cl-nsubstitute cl-new cl-old cl-seq :count cl-count
:start cl-i cl-keys))))))
@@ -439,7 +439,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible.
(setq cl-end (1- cl-end))
(if (cl--check-test cl-old (elt cl-seq cl-end))
(progn
- (cl--set-elt cl-seq cl-end cl-new)
+ (setf (elt cl-seq cl-end) cl-new)
(setq cl-count (1- cl-count)))))
(while (and (< cl-start cl-end) (> cl-count 0))
(if (cl--check-test cl-old (aref cl-seq cl-start))
diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el
index c64ec52decb..7102b5549eb 100644
--- a/lisp/emacs-lisp/eldoc.el
+++ b/lisp/emacs-lisp/eldoc.el
@@ -298,8 +298,8 @@ Otherwise work like `message'."
;;;###autoload
-(defvar eldoc-documentation-function nil
- "If non-nil, function to call to return doc string.
+(defvar eldoc-documentation-function #'eldoc-documentation-function-default
+ "Function to call to return doc string.
The function of no args should return a one-line string for displaying
doc about a function etc. appropriate to the context around point.
It should return nil if there's no doc appropriate for the context.
@@ -323,22 +323,20 @@ Emacs Lisp mode) that support ElDoc.")
(when eldoc-last-message
(eldoc-message nil)
nil))
- (if eldoc-documentation-function
- (eldoc-message (funcall eldoc-documentation-function))
- (let* ((current-symbol (eldoc-current-symbol))
- (current-fnsym (eldoc-fnsym-in-current-sexp))
- (doc (cond
- ((null current-fnsym)
- nil)
- ((eq current-symbol (car current-fnsym))
- (or (apply 'eldoc-get-fnsym-args-string
- current-fnsym)
- (eldoc-get-var-docstring current-symbol)))
- (t
- (or (eldoc-get-var-docstring current-symbol)
- (apply 'eldoc-get-fnsym-args-string
- current-fnsym))))))
- (eldoc-message doc))))))
+ (eldoc-message (funcall eldoc-documentation-function)))))
+
+(defun eldoc-documentation-function-default ()
+ "Default value for `eldoc-documentation-function' (which see)."
+ (let ((current-symbol (eldoc-current-symbol))
+ (current-fnsym (eldoc-fnsym-in-current-sexp)))
+ (cond ((null current-fnsym)
+ nil)
+ ((eq current-symbol (car current-fnsym))
+ (or (apply #'eldoc-get-fnsym-args-string current-fnsym)
+ (eldoc-get-var-docstring current-symbol)))
+ (t
+ (or (eldoc-get-var-docstring current-symbol)
+ (apply #'eldoc-get-fnsym-args-string current-fnsym))))))
(defun eldoc-get-fnsym-args-string (sym &optional index)
"Return a string containing the parameter list of the function SYM.
diff --git a/lisp/emacs-lisp/gulp.el b/lisp/emacs-lisp/gulp.el
deleted file mode 100644
index d0a89b3075a..00000000000
--- a/lisp/emacs-lisp/gulp.el
+++ /dev/null
@@ -1,178 +0,0 @@
-;;; gulp.el --- ask for updates for Lisp packages
-
-;; Copyright (C) 1996, 2001-2014 Free Software Foundation, Inc.
-
-;; Author: Sam Shteingold <shteingd@math.ucla.edu>
-;; Maintainer: emacs-devel@gnu.org
-;; Keywords: maint
-
-;; 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Search the emacs/{version}/lisp directory for *.el files, extract the
-;; name of the author or maintainer and send him e-mail requesting
-;; update.
-
-;;; Code:
-(defgroup gulp nil
- "Ask for updates for Lisp packages."
- :prefix "-"
- :group 'maint)
-
-(defcustom gulp-discard "^;+ *Maintainer: *\\(FSF\\|emacs-devel@gnu\\.org\\) *$"
- "The regexp matching the packages not requiring the request for updates."
- :version "24.4" ; added emacs-devel
- :type 'regexp
- :group 'gulp)
-
-(defcustom gulp-tmp-buffer "*gulp*"
- "The name of the temporary buffer."
- :type 'string
- :group 'gulp)
-
-(defcustom gulp-max-len 2000
- "Distance into a Lisp source file to scan for keywords."
- :type 'integer
- :group 'gulp)
-
-(defcustom gulp-request-header
- (concat
- "This message was created automatically.
-I'm going to start pretesting a new version of GNU Emacs soon, so I'd
-like to ask if you have any updates for the Emacs packages you work on.
-You're listed as the maintainer of the following package(s):\n\n")
- "The starting text of a gulp message."
- :type 'string
- :group 'gulp)
-
-(defcustom gulp-request-end
- (concat
- "\nIf you have any changes since the version in the previous release ("
- (format "%d.%d" emacs-major-version emacs-minor-version)
- "),
-please send them to me ASAP.
-
-Please don't send the whole file. Instead, please send a patch made with
-`diff -c' that shows precisely the changes you would like me to install.
-Also please include itemized change log entries for your changes;
-please use lisp/ChangeLog as a guide for the style and for what kinds
-of information to include.
-
-Thanks.")
- "The closing text in a gulp message."
- :type 'string
- :group 'gulp)
-
-(declare-function mail-subject "sendmail" ())
-(declare-function mail-send "sendmail" ())
-
-(defun gulp-send-requests (dir &optional time)
- "Send requests for updates to the authors of Lisp packages in directory DIR.
-For each maintainer, the message consists of `gulp-request-header',
-followed by the list of packages (with modification times if the optional
-prefix argument TIME is non-nil), concluded with `gulp-request-end'.
-
-You can't edit the messages, but you can confirm whether to send each one.
-
-The list of addresses for which you decided not to send mail
-is left in the `*gulp*' buffer at the end."
- (interactive "DRequest updates for Lisp directory: \nP")
- (with-current-buffer (get-buffer-create gulp-tmp-buffer)
- (let ((m-p-alist (gulp-create-m-p-alist
- (directory-files dir nil "^[^=].*\\.el$" t)
- dir))
- ;; Temporarily inhibit undo in the *gulp* buffer.
- (buffer-undo-list t)
- mail-setup-hook msg node)
- (setq m-p-alist
- (sort m-p-alist
- (function (lambda (a b)
- (string< (car a) (car b))))))
- (while (setq node (car m-p-alist))
- (setq msg (gulp-create-message (cdr node) time))
- (setq mail-setup-hook
- (lambda ()
- (mail-subject)
- (insert "It's time for Emacs updates again")
- (goto-char (point-max))
- (insert msg)))
- (mail nil (car node))
- (goto-char (point-min))
- (if (y-or-n-p "Send? ") (mail-send)
- (kill-this-buffer)
- (set-buffer gulp-tmp-buffer)
- (insert (format "%s\n\n" node)))
- (setq m-p-alist (cdr m-p-alist))))
- (set-buffer gulp-tmp-buffer)
- (setq buffer-undo-list nil)))
-
-
-(defun gulp-create-message (rec time)
- "Return the message string for REC, which is a list like (FILE TIME)."
- (let (node (str gulp-request-header))
- (while (setq node (car rec))
- (setq str (concat str "\t" (car node)
- (if time (concat "\tLast modified:\t" (cdr node)))
- "\n"))
- (setq rec (cdr rec)))
- (concat str gulp-request-end)))
-
-
-(defun gulp-create-m-p-alist (flist dir)
- "Create the maintainer/package alist for files in FLIST in DIR.
-That is a list of elements, each of the form (MAINTAINER PACKAGES...)."
- (save-excursion
- (let (mplist filen node mnt-tm mnt tm fl-tm)
- (get-buffer-create gulp-tmp-buffer)
- (set-buffer gulp-tmp-buffer)
- (setq buffer-undo-list t)
- (while flist
- (setq fl-tm (gulp-maintainer (setq filen (car flist)) dir))
- (if (setq tm (cdr fl-tm) mnt (car fl-tm));; there is a definite maintainer
- (if (setq node (assoc mnt mplist));; this is not a new maintainer
- (setq mplist (cons (cons mnt (cons (cons filen tm) (cdr node)))
- (delete node mplist)))
- (setq mplist (cons (list mnt (cons filen (cdr fl-tm))) mplist))))
- (setq flist (cdr flist)))
- (erase-buffer)
- mplist)))
-
-(defun gulp-maintainer (filenm dir)
- "Return a list (MAINTAINER TIMESTAMP) for the package FILENM in directory DIR."
- (save-excursion
- (let* ((fl (expand-file-name filenm dir)) mnt
- (timest (format-time-string "%Y-%m-%d %a %T %Z"
- (elt (file-attributes fl) 5))))
- (set-buffer gulp-tmp-buffer)
- (erase-buffer)
- (insert-file-contents fl nil 0 gulp-max-len)
- (goto-char 1)
- (if (re-search-forward gulp-discard nil t)
- (setq mnt nil) ;; do nothing, return nil
- (goto-char 1)
- (if (and (re-search-forward "^;+ *Maintainer: \\(.*\\)$" nil t)
- (> (length (setq mnt (match-string 1))) 0))
- () ;; found!
- (goto-char 1)
- (if (re-search-forward "^;+ *Author: \\(.*\\)$" nil t)
- (setq mnt (match-string 1))))
- (if (= (length mnt) 0) (setq mnt nil))) ;; "^;; Author: $" --> nil
- (cons mnt timest))))
-
-(provide 'gulp)
-
-;;; gulp.el ends here
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el
index 1cdba5b371a..7e00d0b2cf9 100644
--- a/lisp/emacs-lisp/lisp-mode.el
+++ b/lisp/emacs-lisp/lisp-mode.el
@@ -104,7 +104,8 @@ It has `lisp-mode-abbrev-table' as its parent."
(regexp-opt
'("defun" "defun*" "defsubst" "defmacro"
"defadvice" "define-skeleton"
- "define-minor-mode" "define-global-minor-mode"
+ "define-compilation-mode" "define-minor-mode"
+ "define-global-minor-mode"
"define-globalized-minor-mode"
"define-derived-mode" "define-generic-mode"
"define-compiler-macro" "define-modify-macro"
@@ -156,6 +157,23 @@ It has `lisp-mode-abbrev-table' as its parent."
;;;; Font-lock support.
+(defun lisp--match-hidden-arg (limit)
+ (let ((res nil))
+ (while
+ (let ((ppss (parse-partial-sexp (line-beginning-position)
+ (line-end-position)
+ -1)))
+ (if (or (>= (car ppss) 0)
+ (looking-at "[]) \t]*\\(;\\|$\\)"))
+ (progn
+ (forward-line 1)
+ (< (point) limit))
+ (looking-at ".*") ;Set the match-data.
+ (forward-line 1)
+ (setq res (point))
+ nil)))
+ res))
+
(pcase-let
((`(,vdefs ,tdefs
,el-defs-re ,cl-defs-re
@@ -347,6 +365,9 @@ It has `lisp-mode-abbrev-table' as its parent."
;; and that they get the wrong color.
;; ;; CL `with-' and `do-' constructs
;;("(\\(\\(do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face)
+ (lisp--match-hidden-arg
+ (0 '(face font-lock-warning-face
+ help-echo "Hidden behind deeper element; move to another line?")))
))
"Gaudy level highlighting for Emacs Lisp mode.")
@@ -377,6 +398,9 @@ It has `lisp-mode-abbrev-table' as its parent."
;; and that they get the wrong color.
;; ;; CL `with-' and `do-' constructs
;;("(\\(\\(do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face)
+ (lisp--match-hidden-arg
+ (0 '(face font-lock-warning-face
+ help-echo "Hidden behind deeper element; move to another line?")))
))
"Gaudy level highlighting for Lisp modes."))
@@ -465,10 +489,10 @@ font-lock keywords will not be case sensitive."
lisp-cl-font-lock-keywords-2))
nil ,keywords-case-insensitive nil nil
(font-lock-mark-block-function . mark-defun)
+ (font-lock-extra-managed-props help-echo)
(font-lock-syntactic-face-function
. lisp-font-lock-syntactic-face-function)))
(setq-local prettify-symbols-alist lisp--prettify-symbols-alist)
- ;; electric
(when elisp
(setq-local electric-pair-text-pairs
(cons '(?\` . ?\') electric-pair-text-pairs)))
diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el
index 0487515a142..3ff65ff11cd 100644
--- a/lisp/emacs-lisp/lisp.el
+++ b/lisp/emacs-lisp/lisp.el
@@ -57,10 +57,14 @@ Should take the same arguments and behave similarly to `forward-sexp'.")
(defun forward-sexp (&optional arg)
"Move forward across one balanced expression (sexp).
-With ARG, do it that many times. Negative arg -N means
-move backward across N balanced expressions.
-This command assumes point is not in a string or comment.
-Calls `forward-sexp-function' to do the work, if that is non-nil."
+With ARG, do it that many times. Negative arg -N means move
+backward across N balanced expressions. This command assumes
+point is not in a string or comment. Calls
+`forward-sexp-function' to do the work, if that is non-nil. If
+unable to move over a sexp, signal `scan-error' with three
+arguments: a message, the start of the obstacle (usually a
+parenthesis or list marker of some kind), and end of the
+obstacle."
(interactive "^p")
(or arg (setq arg 1))
(if forward-sexp-function
@@ -140,38 +144,92 @@ This command assumes point is not in a string or comment."
(goto-char (or (scan-lists (point) inc -1) (buffer-end arg)))
(setq arg (- arg inc)))))
-(defun backward-up-list (&optional arg)
+(defun backward-up-list (&optional arg escape-strings no-syntax-crossing)
"Move backward out of one level of parentheses.
This command will also work on other parentheses-like expressions
-defined by the current language mode.
-With ARG, do this that many times.
-A negative argument means move forward but still to a less deep spot.
-This command assumes point is not in a string or comment."
- (interactive "^p")
- (up-list (- (or arg 1))))
-
-(defun up-list (&optional arg)
+defined by the current language mode. With ARG, do this that
+many times. A negative argument means move forward but still to
+a less deep spot. If ESCAPE-STRINGS is non-nil (as it is
+interactively), move out of enclosing strings as well. If
+NO-SYNTAX-CROSSING is non-nil (as it is interactively), prefer to
+break out of any enclosing string instead of moving to the start
+of a list broken across multiple strings. On error, location of
+point is unspecified."
+ (interactive "^p\nd\nd")
+ (up-list (- (or arg 1)) escape-strings no-syntax-crossing))
+
+(defun up-list (&optional arg escape-strings no-syntax-crossing)
"Move forward out of one level of parentheses.
This command will also work on other parentheses-like expressions
-defined by the current language mode.
-With ARG, do this that many times.
-A negative argument means move backward but still to a less deep spot.
-This command assumes point is not in a string or comment."
- (interactive "^p")
+defined by the current language mode. With ARG, do this that
+many times. A negative argument means move backward but still to
+a less deep spot. If ESCAPE-STRINGS is non-nil (as it is
+interactively), move out of enclosing strings as well. If
+NO-SYNTAX-CROSSING is non-nil (as it is interactively), prefer to
+break out of any enclosing string instead of moving to the start
+of a list broken across multiple strings. On error, location of
+point is unspecified."
+ (interactive "^p\nd\nd")
(or arg (setq arg 1))
(let ((inc (if (> arg 0) 1 -1))
- pos)
+ (pos nil))
(while (/= arg 0)
- (if (null forward-sexp-function)
- (goto-char (or (scan-lists (point) inc 1) (buffer-end arg)))
- (condition-case err
- (while (progn (setq pos (point))
- (forward-sexp inc)
- (/= (point) pos)))
- (scan-error (goto-char (nth (if (> arg 0) 3 2) err))))
- (if (= (point) pos)
- (signal 'scan-error
- (list "Unbalanced parentheses" (point) (point)))))
+ (condition-case err
+ (save-restriction
+ ;; If we've been asked not to cross string boundaries
+ ;; and we're inside a string, narrow to that string so
+ ;; that scan-lists doesn't find a match in a different
+ ;; string.
+ (when no-syntax-crossing
+ (let* ((syntax (syntax-ppss))
+ (string-comment-start (nth 8 syntax)))
+ (when string-comment-start
+ (save-excursion
+ (goto-char string-comment-start)
+ (narrow-to-region
+ (point)
+ (if (nth 3 syntax) ; in string
+ (condition-case nil
+ (progn (forward-sexp) (point))
+ (scan-error (point-max)))
+ (forward-comment 1)
+ (point)))))))
+ (if (null forward-sexp-function)
+ (goto-char (or (scan-lists (point) inc 1)
+ (buffer-end arg)))
+ (condition-case err
+ (while (progn (setq pos (point))
+ (forward-sexp inc)
+ (/= (point) pos)))
+ (scan-error (goto-char (nth (if (> arg 0) 3 2) err))))
+ (if (= (point) pos)
+ (signal 'scan-error
+ (list "Unbalanced parentheses" (point) (point))))))
+ (scan-error
+ (let ((syntax nil))
+ (or
+ ;; If we bumped up against the end of a list, see whether
+ ;; we're inside a string: if so, just go to the beginning
+ ;; or end of that string.
+ (and escape-strings
+ (or syntax (setf syntax (syntax-ppss)))
+ (nth 3 syntax)
+ (goto-char (nth 8 syntax))
+ (progn (when (> inc 0)
+ (forward-sexp))
+ t))
+ ;; If we narrowed to a comment above and failed to escape
+ ;; it, the error might be our fault, not an indication
+ ;; that we're out of syntax. Try again from beginning or
+ ;; end of the comment.
+ (and no-syntax-crossing
+ (or syntax (setf syntax (syntax-ppss)))
+ (nth 4 syntax)
+ (goto-char (nth 8 syntax))
+ (or (< inc 0)
+ (forward-comment 1))
+ (setf arg (+ arg inc)))
+ (signal (car err) (cdr err))))))
(setq arg (- arg inc)))))
(defun kill-sexp (&optional arg)
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index e3a746fa69e..44727daf76a 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -97,7 +97,10 @@ each clause."
(defun macroexp--compiler-macro (handler form)
(condition-case err
(apply handler form (cdr form))
- (error (message "Compiler-macro error for %S: %S" (car form) err)
+ (error
+ (message "--------------------------------------------------")
+ (backtrace)
+ (message "Compiler-macro error for %S: %S" (car form) err)
form)))
(defun macroexp--funcall-if-compiled (_form)
@@ -402,7 +405,7 @@ symbol itself."
(defvar macroexp--pending-eager-loads nil
"Stack of files currently undergoing eager macro-expansion.")
-(defun internal-macroexpand-for-load (form)
+(defun internal-macroexpand-for-load (form full-p)
;; Called from the eager-macroexpansion in readevalloop.
(cond
;; Don't repeat the same warning for every top-level element.
@@ -425,7 +428,9 @@ symbol itself."
(condition-case err
(let ((macroexp--pending-eager-loads
(cons load-file-name macroexp--pending-eager-loads)))
- (macroexpand-all form))
+ (if full-p
+ (macroexpand-all form)
+ (macroexpand form)))
(error
;; Hopefully this shouldn't happen thanks to the cycle detection,
;; but in case it does happen, let's catch the error and give the
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-22 09:47:30 +0000