summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r--lisp/emacs-lisp/benchmark.el3
-rw-r--r--lisp/emacs-lisp/byte-opt.el10
-rw-r--r--lisp/emacs-lisp/bytecomp.el4
-rw-r--r--lisp/emacs-lisp/chart.el2
-rw-r--r--lisp/emacs-lisp/comp.el33
-rw-r--r--lisp/emacs-lisp/eieio-base.el2
-rw-r--r--lisp/emacs-lisp/eieio-core.el127
-rw-r--r--lisp/emacs-lisp/eieio-custom.el2
-rw-r--r--lisp/emacs-lisp/eieio-speedbar.el10
-rw-r--r--lisp/emacs-lisp/eieio.el57
-rw-r--r--lisp/emacs-lisp/elp.el18
-rw-r--r--lisp/emacs-lisp/shortdoc.el48
-rw-r--r--lisp/emacs-lisp/syntax.el4
13 files changed, 217 insertions, 103 deletions
diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el
index 439d3bd363e..64c628822df 100644
--- a/lisp/emacs-lisp/benchmark.el
+++ b/lisp/emacs-lisp/benchmark.el
@@ -37,8 +37,7 @@
"Return the time in seconds elapsed for execution of FORMS."
(declare (indent 0) (debug t))
(let ((t1 (make-symbol "t1")))
- `(let (,t1)
- (setq ,t1 (current-time))
+ `(let ((,t1 (current-time)))
,@forms
(float-time (time-since ,t1)))))
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 10a50da4628..2fff0bd4a5f 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -343,7 +343,7 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.")
(numberp expr)
(stringp expr)
(and (consp expr)
- (eq (car expr) 'quote)
+ (memq (car expr) '(quote function))
(symbolp (cadr expr)))
(keywordp expr)))
@@ -1269,6 +1269,14 @@ See Info node `(elisp) Integer Basics'."
form)
form))
+(put 'cons 'byte-optimizer #'byte-optimize-cons)
+(defun byte-optimize-cons (form)
+ ;; (cons X nil) => (list X)
+ (if (and (= (safe-length form) 3)
+ (null (nth 2 form)))
+ `(list ,(nth 1 form))
+ form))
+
;; Fixme: delete-char -> delete-region (byte-coded)
;; optimize string-as-unibyte, string-as-multibyte, string-make-unibyte,
;; string-make-multibyte for constant args.
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 86c5d32c726..96a0da924fc 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -606,7 +606,7 @@ Each element is (INDEX . VALUE)")
"Non nil while native compiling.")
(defvar byte-native-qualities nil
"To spill default qualities from the compiled file.")
-(defvar byte-native-for-bootstrap nil
+(defvar byte+native-compile nil
"Non nil while compiling for bootstrap."
;; During bootstrap we produce both the .eln and the .elc together.
;; Because the make target is the later this has to be produced as
@@ -2109,7 +2109,7 @@ See also `emacs-lisp-byte-compile-and-load'."
;; recompiled). Previously this was accomplished by
;; deleting target-file before writing it.
(if byte-native-compiling
- (if byte-native-for-bootstrap
+ (if byte+native-compile
;; Defer elc final renaming.
(setf byte-to-native-output-file
(cons tempfile target-file))
diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el
index 5afc6d3bde3..0494497feaf 100644
--- a/lisp/emacs-lisp/chart.el
+++ b/lisp/emacs-lisp/chart.el
@@ -203,7 +203,7 @@ Make sure the width/height is correct."
(defclass chart-bar (chart)
((direction :initarg :direction
- :initform vertical))
+ :initform 'vertical))
"Subclass for bar charts (vertical or horizontal).")
(cl-defmethod chart-draw ((c chart) &optional buff)
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index b09739cb92e..638d4b274cc 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -200,6 +200,9 @@ Emacs Lisp file:
\;; Local Variables:\n;; no-native-compile: t\n;; End:")
;;;###autoload(put 'no-native-compile 'safe-local-variable 'booleanp)
+(defvar native-compile-target-directory nil
+ "When non-nil force the target directory for the eln files being compiled.")
+
(defvar comp-log-time-report nil
"If non-nil, log a time report for each pass.")
@@ -1337,8 +1340,9 @@ clashes."
(unless (comp-ctxt-output comp-ctxt)
(setf (comp-ctxt-output comp-ctxt) (comp-el-to-eln-filename
filename
- (when byte-native-for-bootstrap
- (car (last native-comp-eln-load-path))))))
+ (or native-compile-target-directory
+ (when byte+native-compile
+ (car (last native-comp-eln-load-path)))))))
(setf (comp-ctxt-speed comp-ctxt) (alist-get 'native-comp-speed
byte-native-qualities)
(comp-ctxt-debug comp-ctxt) (alist-get 'native-comp-debug
@@ -3643,7 +3647,7 @@ Prepare every function for final compilation and drive the C back-end."
;; unless during bootstrap or async compilation (bug#45056). GCC
;; leaks memory but also interfere with the ability of Emacs to
;; detect when a sub-process completes (TODO understand why).
- (if (or byte-native-for-bootstrap comp-async-compilation)
+ (if (or byte+native-compile comp-async-compilation)
(comp-final1)
;; Call comp-final1 in a child process.
(let* ((output (comp-ctxt-output comp-ctxt))
@@ -3941,7 +3945,11 @@ display a message."
(load1 load)
(process (make-process
:name (concat "Compiling: " source-file)
- :buffer (get-buffer-create comp-async-buffer-name)
+ :buffer (with-current-buffer
+ (get-buffer-create
+ comp-async-buffer-name)
+ (setf buffer-read-only t)
+ (current-buffer))
:command (list
(expand-file-name invocation-name
invocation-directory)
@@ -3970,8 +3978,9 @@ display a message."
(run-hooks 'native-comp-async-all-done-hook)
(with-current-buffer (get-buffer-create comp-async-buffer-name)
(save-excursion
- (goto-char (point-max))
- (insert "Compilation finished.\n")))
+ (let ((buffer-read-only nil))
+ (goto-char (point-max))
+ (insert "Compilation finished.\n"))))
;; `comp-deferred-pending-h' should be empty at this stage.
;; Reset it anyway.
(clrhash comp-deferred-pending-h)))
@@ -4166,7 +4175,7 @@ it won’t work in an interactive Emacs.
Native compilation equivalent to `batch-byte-compile'."
(comp-ensure-native-compiler)
(cl-loop for file in command-line-args-left
- if (or (null byte-native-for-bootstrap)
+ if (or (null byte+native-compile)
(cl-notany (lambda (re) (string-match re file))
native-comp-bootstrap-deny-list))
do (comp--native-compile file)
@@ -4174,18 +4183,18 @@ Native compilation equivalent to `batch-byte-compile'."
do (byte-compile-file file)))
;;;###autoload
-(defun batch-byte-native-compile-for-bootstrap ()
+(defun batch-byte+native-compile ()
"Like `batch-native-compile', but used for bootstrap.
Generate .elc files in addition to the .eln files.
Force the produced .eln to be outputted in the eln system
-directory (the last entry in `native-comp-eln-load-path').
-If the environment variable 'NATIVE_DISABLED' is set, only byte
-compile."
+directory (the last entry in `native-comp-eln-load-path') unless
+`native-compile-target-directory' is non-nil. If the environment
+variable 'NATIVE_DISABLED' is set, only byte compile."
(comp-ensure-native-compiler)
(if (equal (getenv "NATIVE_DISABLED") "1")
(batch-byte-compile)
(cl-assert (length= command-line-args-left 1))
- (let ((byte-native-for-bootstrap t)
+ (let ((byte+native-compile t)
(byte-to-native-output-file nil))
(batch-native-compile)
(pcase byte-to-native-output-file
diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el
index 641882c9026..ec7c899bddc 100644
--- a/lisp/emacs-lisp/eieio-base.el
+++ b/lisp/emacs-lisp/eieio-base.el
@@ -156,7 +156,7 @@ only one object ever exists."
;; NOTE TO SELF: In next version, make `slot-boundp' support classes
;; with class allocated slots or default values.
(let ((old (oref-default class singleton)))
- (if (eq old eieio-unbound)
+ (if (eq old eieio--unbound)
(oset-default class singleton (cl-call-next-method))
old)))
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index 34b4575182e..8f1e38b613b 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -71,11 +71,10 @@ Currently under control of this var:
- Define <class>-child-p and <class>-list-p predicates.
- Allow object names in constructors.")
-(defconst eieio-unbound
- (if (and (boundp 'eieio-unbound) (symbolp eieio-unbound))
- eieio-unbound
- (make-symbol "unbound"))
+(define-obsolete-variable-alias 'eieio-unbound 'eieio--unbound "28.1")
+(defvar eieio--unbound (make-symbol "eieio--unbound")
"Uninterned symbol representing an unbound slot in an object.")
+(defvar eieio--unbound-form (macroexp-quote eieio--unbound))
;; This is a bootstrap for eieio-default-superclass so it has a value
;; while it is being built itself.
@@ -264,6 +263,7 @@ use \\='%s or turn off `eieio-backward-compatibility' instead" cname)
(object-of-class-p obj class))))
(defvar eieio--known-slot-names nil)
+(defvar eieio--known-class-slot-names nil)
(defun eieio-defclass-internal (cname superclasses slots options)
"Define CNAME as a new subclass of SUPERCLASSES.
@@ -381,7 +381,7 @@ See `defclass' for more information."
(pcase-dolist (`(,name . ,slot) slots)
(let* ((init (or (plist-get slot :initform)
(if (member :initform slot) nil
- eieio-unbound)))
+ eieio--unbound-form)))
(initarg (plist-get slot :initarg))
(docstr (plist-get slot :documentation))
(prot (plist-get slot :protection))
@@ -395,6 +395,14 @@ See `defclass' for more information."
(skip-nil (eieio--class-option-assoc options :allow-nil-initform))
)
+ (unless (or (macroexp-const-p init)
+ (eieio--eval-default-p init))
+ ;; FIXME: We duplicate this test here and in `defclass' because
+ ;; if we move this part to `defclass' we may break some existing
+ ;; code (because the `fboundp' test in `eieio--eval-default-p'
+ ;; returns a different result at compile time).
+ (setq init (macroexp-quote init)))
+
;; Clean up the meaning of protection.
(setq prot
(pcase prot
@@ -457,8 +465,9 @@ See `defclass' for more information."
(n (length slots))
(v (make-vector n nil)))
(dotimes (i n)
- (setf (aref v i) (eieio-default-eval-maybe
- (cl--slot-descriptor-initform (aref slots i)))))
+ (setf (aref v i) (eval
+ (cl--slot-descriptor-initform (aref slots i))
+ t)))
(setf (eieio--class-class-allocation-values newc) v))
;; Attach slot symbols into a hash table, and store the index of
@@ -513,7 +522,7 @@ See `defclass' for more information."
cname
))
-(defsubst eieio-eval-default-p (val)
+(defun eieio--eval-default-p (val)
"Whether the default value VAL should be evaluated for use."
(and (consp val) (symbolp (car val)) (fboundp (car val))))
@@ -522,10 +531,10 @@ See `defclass' for more information."
If SKIPNIL is non-nil, then if default value is nil return t instead."
(let ((value (cl--slot-descriptor-initform slot))
(spec (cl--slot-descriptor-type slot)))
- (if (not (or (eieio-eval-default-p value) ;FIXME: Why?
+ (if (not (or (not (macroexp-const-p value))
eieio-skip-typecheck
(and skipnil (null value))
- (eieio--perform-slot-validation spec value)))
+ (eieio--perform-slot-validation spec (eval value t))))
(signal 'invalid-slot-type (list (cl--slot-descriptor-name slot) spec value)))))
(defun eieio--slot-override (old new skipnil)
@@ -546,7 +555,7 @@ If SKIPNIL is non-nil, then if default value is nil return t instead."
type tp a))
(setf (cl--slot-descriptor-type new) tp))
;; If we have a repeat, only update the initarg...
- (unless (eq d eieio-unbound)
+ (unless (eq d eieio--unbound-form)
(eieio--perform-slot-validation-for-default new skipnil)
(setf (cl--slot-descriptor-initform old) d))
@@ -604,6 +613,8 @@ if default value is nil."
(cold (car (cl-member a (eieio--class-class-slots newc)
:key #'cl--slot-descriptor-name))))
(cl-pushnew a eieio--known-slot-names)
+ (when (eq alloc :class)
+ (cl-pushnew a eieio--known-class-slot-names))
(condition-case nil
(if (sequencep d) (setq d (copy-sequence d)))
;; This copy can fail on a cons cell with a non-cons in the cdr. Let's
@@ -679,7 +690,7 @@ the new child class."
(defun eieio--perform-slot-validation (spec value)
"Return non-nil if SPEC does not match VALUE."
(or (eq spec t) ; t always passes
- (eq value eieio-unbound) ; unbound always passes
+ (eq value eieio--unbound) ; unbound always passes
(cl-typep value spec)))
(defun eieio--validate-slot-value (class slot-idx value slot)
@@ -715,7 +726,7 @@ an error."
INSTANCE is the object being referenced. SLOTNAME is the offending
slot. If the slot is ok, return VALUE.
Argument FN is the function calling this verifier."
- (if (and (eq value eieio-unbound) (not eieio-skip-typecheck))
+ (if (and (eq value eieio--unbound) (not eieio-skip-typecheck))
(slot-unbound instance (eieio--object-class instance) slotname fn)
value))
@@ -755,15 +766,29 @@ Argument FN is the function calling this verifier."
(eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref))))
-(defun eieio-oref-default (obj slot)
+(defun eieio-oref-default (class slot)
"Do the work for the macro `oref-default' with similar parameters.
-Fills in OBJ's SLOT with its default value."
- (declare (gv-setter eieio-oset-default))
- (cl-check-type obj (or eieio-object class))
+Fills in CLASS's SLOT with its default value."
+ (declare (gv-setter eieio-oset-default)
+ (compiler-macro
+ (lambda (exp)
+ (ignore class)
+ (pcase slot
+ ((and (or `',name (and name (pred keywordp)))
+ (guard (not (memq name eieio--known-slot-names))))
+ (macroexp-warn-and-return
+ (format-message "Unknown slot `%S'" name) exp 'compile-only))
+ ((and (or `',name (and name (pred keywordp)))
+ (guard (not (memq name eieio--known-class-slot-names))))
+ (macroexp-warn-and-return
+ (format-message "Slot `%S' is not class-allocated" name)
+ exp 'compile-only))
+ (_ exp)))))
+ (cl-check-type class (or eieio-object class))
(cl-check-type slot symbol)
- (let* ((cl (cond ((symbolp obj) (cl--find-class obj))
- ((eieio-object-p obj) (eieio--object-class obj))
- (t obj)))
+ (let* ((cl (cond ((symbolp class) (cl--find-class class))
+ ((eieio-object-p class) (eieio--object-class class))
+ (t class)))
(c (eieio--slot-name-index cl slot)))
(if (not c)
;; It might be missing because it is a :class allocated slot.
@@ -773,27 +798,13 @@ Fills in OBJ's SLOT with its default value."
;; Oref that slot.
(aref (eieio--class-class-allocation-values cl)
c)
- (slot-missing obj slot 'oref-default))
+ (slot-missing class slot 'oref-default))
(eieio-barf-if-slot-unbound
(let ((val (cl--slot-descriptor-initform
(aref (eieio--class-slots cl)
(- c (eval-when-compile eieio--object-num-slots))))))
- (eieio-default-eval-maybe val))
- obj (eieio--class-name cl) 'oref-default))))
-
-(defun eieio-default-eval-maybe (val)
- "Check VAL, and return what `oref-default' would provide."
- ;; FIXME: What the hell is this supposed to do? Shouldn't it evaluate
- ;; variables as well? Why not just always call `eval'?
- (cond
- ;; Is it a function call? If so, evaluate it.
- ((eieio-eval-default-p val)
- (eval val t))
- ;;;; check for quoted things, and unquote them
- ;;((and (consp val) (eq (car val) 'quote))
- ;; (car (cdr val)))
- ;; return it verbatim
- (t val)))
+ (eval val t))
+ class (eieio--class-name cl) 'oref-default))))
(defun eieio-oset (obj slot value)
"Do the work for the macro `oset'.
@@ -820,6 +831,20 @@ Fills in OBJ's SLOT with VALUE."
(defun eieio-oset-default (class slot value)
"Do the work for the macro `oset-default'.
Fills in the default value in CLASS' in SLOT with VALUE."
+ (declare (compiler-macro
+ (lambda (exp)
+ (ignore class value)
+ (pcase slot
+ ((and (or `',name (and name (pred keywordp)))
+ (guard (not (memq name eieio--known-slot-names))))
+ (macroexp-warn-and-return
+ (format-message "Unknown slot `%S'" name) exp 'compile-only))
+ ((and (or `',name (and name (pred keywordp)))
+ (guard (not (memq name eieio--known-class-slot-names))))
+ (macroexp-warn-and-return
+ (format-message "Slot `%S' is not class-allocated" name)
+ exp 'compile-only))
+ (_ exp)))))
(setq class (eieio--class-object class))
(cl-check-type class eieio--class)
(cl-check-type slot symbol)
@@ -836,22 +861,18 @@ Fills in the default value in CLASS' in SLOT with VALUE."
(signal 'invalid-slot-name (list (eieio--class-name class) slot)))
;; `oset-default' on an instance-allocated slot is allowed by EIEIO but
;; not by CLOS and is mildly inconsistent with the :initform thingy, so
- ;; it'd be nice to get of it. This said, it is/was used at one place by
- ;; gnus/registry.el, so it might be used elsewhere as well, so let's
- ;; keep it for now.
+ ;; it'd be nice to get rid of it.
+ ;; This said, it is/was used at one place by gnus/registry.el, so it
+ ;; might be used elsewhere as well, so let's keep it for now.
;; FIXME: Generate a compile-time warning for it!
;; (error "Can't `oset-default' an instance-allocated slot: %S of %S"
;; slot class)
(eieio--validate-slot-value class c value slot)
;; Set this into the storage for defaults.
- (if (eieio-eval-default-p value)
- (error "Can't set default to a sexp that gets evaluated again"))
(setf (cl--slot-descriptor-initform
- ;; FIXME: Apparently we set it both in `slots' and in
- ;; `object-cache', which seems redundant.
(aref (eieio--class-slots class)
(- c (eval-when-compile eieio--object-num-slots))))
- value)
+ (macroexp-quote value))
;; Take the value, and put it into our cache object.
(eieio-oset (eieio--class-default-object-cache class)
slot value)
@@ -1093,8 +1114,20 @@ These match if the argument is the name of a subclass of CLASS."
(defmacro eieio-declare-slots (&rest slots)
"Declare that SLOTS are known eieio object slot names."
- `(eval-when-compile
- (setq eieio--known-slot-names (append ',slots eieio--known-slot-names))))
+ (let ((slotnames (mapcar (lambda (s) (if (consp s) (car s) s)) slots))
+ (classslots (delq nil
+ (mapcar (lambda (s)
+ (when (and (consp s)
+ (eq :class (plist-get (cdr s)
+ :allocation)))
+ (car s)))
+ slots))))
+ `(eval-when-compile
+ ,@(when classslots
+ (mapcar (lambda (s) `(add-to-list 'eieio--known-class-slot-names ',s))
+ classslots))
+ ,@(mapcar (lambda (s) `(add-to-list 'eieio--known-slot-names ',s))
+ slotnames))))
(provide 'eieio-core)
diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el
index 8257f7a4bae..d7d078b2d94 100644
--- a/lisp/emacs-lisp/eieio-custom.el
+++ b/lisp/emacs-lisp/eieio-custom.el
@@ -46,7 +46,7 @@
:documentation "A string for testing custom.
This is the next line of documentation.")
(listostuff :initarg :listostuff
- :initform ("1" "2" "3")
+ :initform '("1" "2" "3")
:type list
:custom (repeat (string :tag "Stuff"))
:label "List of Strings"
diff --git a/lisp/emacs-lisp/eieio-speedbar.el b/lisp/emacs-lisp/eieio-speedbar.el
index c25ea8acee9..3f2a6537ab8 100644
--- a/lisp/emacs-lisp/eieio-speedbar.el
+++ b/lisp/emacs-lisp/eieio-speedbar.el
@@ -248,7 +248,7 @@ and take the appropriate action."
Possible values are those symbols supported by the `exp-button-type' argument
to `speedbar-make-tag-line'."
:allocation :class)
- (buttonface :initform speedbar-tag-face
+ (buttonface :initform 'speedbar-tag-face
:type (or symbol face)
:documentation
"The face used on the textual part of the button for this class.
@@ -265,15 +265,15 @@ Add one of the child classes to this class to the parent list of a class."
:abstract t)
(defclass eieio-speedbar-directory-button (eieio-speedbar)
- ((buttontype :initform angle)
- (buttonface :initform speedbar-directory-face))
+ ((buttontype :initform 'angle)
+ (buttonface :initform 'speedbar-directory-face))
"Class providing support for objects which behave like a directory."
:method-invocation-order :depth-first
:abstract t)
(defclass eieio-speedbar-file-button (eieio-speedbar)
- ((buttontype :initform bracket)
- (buttonface :initform speedbar-file-face))
+ ((buttontype :initform 'bracket)
+ (buttonface :initform 'speedbar-file-face))
"Class providing support for objects which behave like a file."
:method-invocation-order :depth-first
:abstract t)
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index 31b6b0945bb..1c8c372aaef 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -131,6 +131,7 @@ and reference them using the function `class-option'."
(let ((testsym1 (intern (concat (symbol-name name) "-p")))
(testsym2 (intern (format "%s--eieio-childp" name)))
+ (warnings '())
(accessors ()))
;; Collect the accessors we need to define.
@@ -145,6 +146,8 @@ and reference them using the function `class-option'."
;; Update eieio--known-slot-names already in case we compile code which
;; uses this before the class is loaded.
(cl-pushnew sname eieio--known-slot-names)
+ (when (eq alloc :class)
+ (cl-pushnew sname eieio--known-class-slot-names))
(if eieio-error-unsupported-class-tags
(let ((tmp soptions))
@@ -176,8 +179,22 @@ and reference them using the function `class-option'."
(signal 'invalid-slot-type (list :label label)))
;; Is there an initarg, but allocation of class?
- (if (and initarg (eq alloc :class))
- (message "Class allocated slots do not need :initarg"))
+ (when (and initarg (eq alloc :class))
+ (push (format "Meaningless :initarg for class allocated slot '%S'"
+ sname)
+ warnings))
+
+ (let ((init (plist-get soptions :initform)))
+ (unless (or (macroexp-const-p init)
+ (eieio--eval-default-p init))
+ ;; FIXME: Historically, EIEIO used a heuristic to try and guess
+ ;; whether the initform is a form to be evaluated or just
+ ;; a constant. We use `eieio--eval-default-p' to see what the
+ ;; heuristic says and if it disagrees with normal evaluation
+ ;; then tweak the initform to make it fit and emit
+ ;; a warning accordingly.
+ (push (format "Ambiguous initform needs quoting: %S" init)
+ warnings)))
;; Anyone can have an accessor function. This creates a function
;; of the specified name, and also performs a `defsetf' if applicable
@@ -223,6 +240,8 @@ This method is obsolete."
))
`(progn
+ ,@(mapcar (lambda (w) (macroexp-warn-and-return w `(progn ',w) 'compile-only))
+ warnings)
;; This test must be created right away so we can have self-
;; referencing classes. ei, a class whose slot can contain only
;; pointers to itself.
@@ -282,9 +301,7 @@ This method is obsolete."
;;; Get/Set slots in an object.
;;
(defmacro oref (obj slot)
- "Retrieve the value stored in OBJ in the slot named by SLOT.
-Slot is the name of the slot when created by `defclass' or the label
-created by the :initarg tag."
+ "Retrieve the value stored in OBJ in the slot named by SLOT."
(declare (debug (form symbolp)))
`(eieio-oref ,obj (quote ,slot)))
@@ -292,13 +309,11 @@ created by the :initarg tag."
(defalias 'set-slot-value #'eieio-oset)
(make-obsolete 'set-slot-value "use (setf (slot-value ..) ..) instead" "25.1")
-(defmacro oref-default (obj slot)
- "Get the default value of OBJ (maybe a class) for SLOT.
-The default value is the value installed in a class with the :initform
-tag. SLOT can be the slot name, or the tag specified by the :initarg
-tag in the `defclass' call."
+(defmacro oref-default (class slot)
+ "Get the value of class allocated slot SLOT.
+CLASS can also be an object, in which case we use the object's class."
(declare (debug (form symbolp)))
- `(eieio-oref-default ,obj (quote ,slot)))
+ `(eieio-oref-default ,class (quote ,slot)))
;;; Handy CLOS macros
;;
@@ -538,11 +553,11 @@ OBJECT can be an instance or a class."
((eieio-object-p object) (eieio-oref object slot))
((symbolp object) (eieio-oref-default object slot))
(t (signal 'wrong-type-argument (list 'eieio-object-p object))))
- eieio-unbound))))
+ eieio--unbound))))
(defun slot-makeunbound (object slot)
"In OBJECT, make SLOT unbound."
- (eieio-oset object slot eieio-unbound))
+ (eieio-oset object slot eieio--unbound))
(defun slot-exists-p (object-or-class slot)
"Return non-nil if OBJECT-OR-CLASS has SLOT."
@@ -740,18 +755,14 @@ dynamically set from SLOTS."
(slots (eieio--class-slots this-class)))
(dotimes (i (length slots))
;; For each slot, see if we need to evaluate it.
- ;;
- ;; Paul Landes said in an email:
- ;; > CL evaluates it if it can, and otherwise, leaves it as
- ;; > the quoted thing as you already have. This is by the
- ;; > Sonya E. Keene book and other things I've look at on the
- ;; > web.
(let* ((slot (aref slots i))
- (initform (cl--slot-descriptor-initform slot))
- (dflt (eieio-default-eval-maybe initform)))
- (when (not (eq dflt initform))
+ (initform (cl--slot-descriptor-initform slot)))
+ ;; Those slots whose initform is constant already have the right
+ ;; value set in the default-object.
+ (unless (macroexp-const-p initform)
;; FIXME: We should be able to just do (aset this (+ i <cst>) dflt)!
- (eieio-oset this (cl--slot-descriptor-name slot) dflt)))))
+ (eieio-oset this (cl--slot-descriptor-name slot)
+ (eval initform t))))))
;; Shared initialize will parse our slots for us.
(shared-initialize this slots))
diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el
index 2ee19a35b23..c2b026dc822 100644
--- a/lisp/emacs-lisp/elp.el
+++ b/lisp/emacs-lisp/elp.el
@@ -483,6 +483,10 @@ original definition, use \\[elp-restore-function] or \\[elp-restore-all]."
'face 'link
'help-echo "mouse-2 or RET jumps to definition")))
+(define-derived-mode elp-results-mode special-mode "ELP"
+ "Mode for ELP results."
+ :interactive nil)
+
;;;###autoload
(defun elp-results ()
"Display current profiling results.
@@ -490,11 +494,12 @@ If `elp-reset-after-results' is non-nil, then current profiling
information for all instrumented functions is reset after results are
displayed."
(interactive)
- (let ((curbuf (current-buffer))
- (resultsbuf (if elp-recycle-buffers-p
- (get-buffer-create elp-results-buffer)
- (generate-new-buffer elp-results-buffer))))
- (set-buffer resultsbuf)
+ (pop-to-buffer
+ (if elp-recycle-buffers-p
+ (get-buffer-create elp-results-buffer)
+ (generate-new-buffer elp-results-buffer)))
+ (elp-results-mode)
+ (let ((inhibit-read-only t))
(erase-buffer)
;; get the length of the longest function name being profiled
(let* ((longest 0)
@@ -565,9 +570,6 @@ displayed."
(if elp-sort-by-function
(setq resvec (sort resvec elp-sort-by-function)))
(mapc 'elp-output-result resvec))
- ;; now pop up results buffer
- (set-buffer curbuf)
- (pop-to-buffer resultsbuf)
;; copy results to standard-output?
(if (or elp-use-standard-output noninteractive)
(princ (buffer-substring (point-min) (point-max)))
diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el
index 38d8ad6cc12..16e83074764 100644
--- a/lisp/emacs-lisp/shortdoc.el
+++ b/lisp/emacs-lisp/shortdoc.el
@@ -60,8 +60,10 @@ FUNCTIONS is a list of elements on the form:
:args ARGS
:eval EXAMPLE-FORM
:no-eval EXAMPLE-FORM
+ :no-eval* EXAMPLE-FORM
:no-value EXAMPLE-FORM
:result RESULT-FORM
+ :result-string RESULT-FORM
:eg-result RESULT-FORM
:eg-result-string RESULT-FORM)
@@ -887,6 +889,52 @@ There can be any number of :example/:result elements."
(unlock-buffer
:no-value (lock-buffer)))
+(define-short-documentation-group overlay
+ "Predicates"
+ (overlayp
+ :no-eval (overlayp some-overlay)
+ :eg-result t)
+ "Creation and Deletion"
+ (make-overlay
+ :args (beg end &optional buffer)
+ :no-eval (make-overlay 1 10)
+ :eg-result-string "#<overlay from 1 to 10 in *foo*>")
+ (delete-overlay
+ :no-eval (delete-overlay foo)
+ :eg-result t)
+ "Searching Overlays"
+ (overlays-at
+ :no-eval (overlays-at 15)
+ :eg-result-string "(#<overlay from 1 to 10 in *foo*>)")
+ (overlays-in
+ :no-eval (overlays-in 1 30)
+ :eg-result-string "(#<overlay from 1 to 10 in *foo*>)")
+ (next-overlay-change
+ :no-eval (next-overlay-change 1)
+ :eg-result 20)
+ (previous-overlay-change
+ :no-eval (previous-overlay-change 30)
+ :eg-result 20)
+ "Overlay Properties"
+ (overlay-start
+ :no-eval (overlay-start foo)
+ :eg-result 1)
+ (overlay-end
+ :no-eval (overlay-end foo)
+ :eg-result 10)
+ (overlay-put
+ :no-eval (overlay-put foo 'happy t)
+ :eg-result t)
+ (overlay-get
+ :no-eval (overlay-get foo 'happy)
+ :eg-result t)
+ (overlay-buffer
+ :no-eval (overlay-buffer foo))
+ "Moving Overlays"
+ (move-overlay
+ :no-eval (move-overlay foo 5 20)
+ :eg-result-string "#<overlay from 5 to 20 in *foo*>"))
+
(define-short-documentation-group process
(make-process
:no-eval (make-process :name "foo" :command '("cat" "/tmp/foo"))
diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el
index 6d5b04b83bb..0bb1b8916b1 100644
--- a/lisp/emacs-lisp/syntax.el
+++ b/lisp/emacs-lisp/syntax.el
@@ -125,6 +125,10 @@ otherwise nil. That construct can be a two character comment
delimiter or an Escaped or Char-quoted character."))
(defun syntax-propertize-wholelines (start end)
+ "Extend the region delimited by START and END to whole lines.
+This function is useful for
+`syntax-propertize-extend-region-functions';
+see Info node `(elisp) Syntax Properties'."
(goto-char start)
(cons (line-beginning-position)
(progn (goto-char end)
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-22 20:02:56 +0000