From 52d5771e0a803f57b8cdd7675bf15f2f9b946039 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 28 Mar 2022 10:53:14 -0400 Subject: Add OClosures, a cross between functions and structs We here just add the new type. It is not fully self-contained. It requires cooperation from `cconv.el` on the one hand, and it hijacks the docstring info to hold the type of OClosure objects. This does imply that OClosures can't have docstrings, tho this limitation will be lifted in subsequent patches. * lisp/emacs-lisp/oclosure.el: New file. * test/lisp/emacs-lisp/oclosure-tests.el: New file. * doc/lispref/functions.texi (OClosures): New section. * src/eval.c (Ffunction): Accept symbols instead of strings for docstrings. * src/doc.c (store_function_docstring): Avoid overwriting an OClosure type. * lisp/emacs-lisp/cconv.el (cconv--convert-function): Tweak ordering of captured variables. (cconv-convert): Add case for `oclosure--fix-type`. --- test/lisp/emacs-lisp/oclosure-tests.el | 113 +++++++++++++++++++++++++++++++++ 1 file changed, 113 insertions(+) create mode 100644 test/lisp/emacs-lisp/oclosure-tests.el (limited to 'test/lisp/emacs-lisp/oclosure-tests.el') diff --git a/test/lisp/emacs-lisp/oclosure-tests.el b/test/lisp/emacs-lisp/oclosure-tests.el new file mode 100644 index 00000000000..e7e76fa4bda --- /dev/null +++ b/test/lisp/emacs-lisp/oclosure-tests.el @@ -0,0 +1,113 @@ +;;; oclosure-tests.e; --- Tests for Open Closures -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2022 Free Software Foundation, Inc. + +;; 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 . + +;;; Code: + +(require 'ert) +(require 'oclosure) +(require 'cl-lib) + +(oclosure-define (oclosure-test + (:copier oclosure-test-copy) + (:copier oclosure-test-copy1 (fst))) + "Simple OClosure." + fst snd name) + +(ert-deftest oclosure-test () + (let* ((i 42) + (ocl1 (oclosure-lambda (oclosure-test (fst 1) (snd 2) (name "hi")) + () + (list fst snd i))) + (ocl2 (oclosure-lambda (oclosure-test (name (cl-incf i)) (fst (cl-incf i))) + () + (list fst snd 152 i)))) + (should (equal (list (oclosure-test--fst ocl1) + (oclosure-test--snd ocl1) + (oclosure-test--name ocl1)) + '(1 2 "hi"))) + (should (equal (list (oclosure-test--fst ocl2) + (oclosure-test--snd ocl2) + (oclosure-test--name ocl2)) + '(44 nil 43))) + (should (equal (funcall ocl1) '(1 2 44))) + (should (equal (funcall ocl2) '(44 nil 152 44))) + (should (equal (funcall (oclosure-test-copy ocl1 :fst 7)) '(7 2 44))) + (should (equal (funcall (oclosure-test-copy1 ocl1 9)) '(9 2 44))) + (should (cl-typep ocl1 'oclosure-test)) + (should (cl-typep ocl1 'oclosure)) + )) + +(ert-deftest oclosure-test-limits () + (should + (condition-case err + (let ((lexical-binding t) + (byte-compile-debug t)) + (byte-compile '(lambda () + (let ((inc-fst nil)) + (oclosure-lambda (oclosure-test (fst 'foo)) () + (setq inc-fst (lambda () (setq fst (1+ fst)))) + fst)))) + nil) + (error + (and (eq 'error (car err)) + (string-match "fst.*mutated" (cadr err)))))) + (should + (condition-case err + (progn (macroexpand-all '(oclosure-define oclosure--foo a a)) + nil) + (error + (and (eq 'error (car err)) + (string-match "Duplicate slot name: a$" (cadr err)))))) + (should + (condition-case err + (progn (macroexpand-all + '(oclosure-define (oclosure--foo (:parent oclosure-test)) fst)) + nil) + (error + (and (eq 'error (car err)) + (string-match "Duplicate slot name: fst$" (cadr err)))))) + (should + (condition-case err + (progn (macroexpand '(oclosure-lambda (oclosure-test (fst 1) (fst 2)) + () fst)) + nil) + (error + (and (eq 'error (car err)) + (string-match "Duplicate slot: fst$" (cadr err))))))) + +(oclosure-define (oclosure-test-mut + (:parent oclosure-test) + (:copier oclosure-test-mut-copy)) + "Simple OClosure with a mutable field." + (mut :mutable t)) + +(ert-deftest oclosure-test-mutate () + (let* ((f (oclosure-lambda (oclosure-test-mut (fst 0) (mut 3)) + (x) + (+ x fst mut))) + (f2 (oclosure-test-mut-copy f :fst 50))) + (should (equal (oclosure-test-mut--mut f) 3)) + (should (equal (funcall f 5) 8)) + (should (equal (funcall f2 5) 58)) + (cl-incf (oclosure-test-mut--mut f) 7) + (should (equal (oclosure-test-mut--mut f) 10)) + (should (equal (funcall f 5) 15)) + (should (equal (funcall f2 15) 68)))) + +;;; oclosure-tests.el ends here. -- cgit v1.2.3 From ff067408e460c02e69c5b7fd06a03c9b12a5744b Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 1 Apr 2022 08:54:55 -0400 Subject: OClosure: Add support for defmethod dispatch * lisp/emacs-lisp/oclosure.el (oclosure--class): Add slot `allparents`. (oclosure--class-make): Add corresponding arg `allparents`. (oclosure, oclosure--build-class): Pass the new arg to the constructor. (oclosure--define): Make the predicate function understand subtyping. * lisp/emacs-lisp/cl-preloaded.el (cl--class-allparents): Move from `cl-generic.el`. * lisp/emacs-lisp/cl-generic.el (cl--generic-class-parents): Move to `cl-preloaded.el` and rename to `cl--class-allparents`. Adjust all callers. (cl--generic-oclosure-tag, cl-generic--oclosure-specializers): New functions. (cl-generic-generalizers) : New generalizer. * test/lisp/emacs-lisp/oclosure-tests.el (oclosure-test-gen): New generic function. (oclosure-test): Add test for dispatch on oclosure types. --- lisp/emacs-lisp/cl-generic.el | 51 +++++++++++++++++++++++++--------- lisp/emacs-lisp/cl-preloaded.el | 11 ++++++++ lisp/emacs-lisp/oclosure.el | 16 +++++++---- test/lisp/emacs-lisp/oclosure-tests.el | 13 +++++++++ 4 files changed, 73 insertions(+), 18 deletions(-) (limited to 'test/lisp/emacs-lisp/oclosure-tests.el') diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 5cbdb9523ac..32a5fe5e54b 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -1126,7 +1126,7 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (let ((sclass (cl--find-class specializer)) (tclass (cl--find-class type))) (when (and sclass tclass) - (member specializer (cl--generic-class-parents tclass)))))) + (member specializer (cl--class-allparents tclass)))))) (setq applies t))) applies)) @@ -1255,22 +1255,11 @@ These match if the argument is `eql' to VAL." ;; Use exactly the same code as for `typeof'. `(if ,name (type-of ,name) 'null)) -(defun cl--generic-class-parents (class) - (let ((parents ()) - (classes (list class))) - ;; BFS precedence. FIXME: Use a topological sort. - (while (let ((class (pop classes))) - (cl-pushnew (cl--class-name class) parents) - (setq classes - (append classes - (cl--class-parents class))))) - (nreverse parents))) - (defun cl--generic-struct-specializers (tag &rest _) (and (symbolp tag) (let ((class (get tag 'cl--class))) (when (cl-typep class 'cl-structure-class) - (cl--generic-class-parents class))))) + (cl--class-allparents class))))) (cl-generic-define-generalizer cl--generic-struct-generalizer 50 #'cl--generic-struct-tag @@ -1353,6 +1342,42 @@ Used internally for the (major-mode MODE) context specializers." (progn (cl-assert (null modes)) mode) `(derived-mode ,mode . ,modes)))) +;;; Dispatch on OClosure type + +;; It would make sense to put this into `oclosure.el' except that when +;; `oclosure.el' is loaded `cl-defmethod' is not available yet. + +(defun cl--generic-oclosure-tag (name &rest _) + `(oclosure-type ,name)) + +(defun cl-generic--oclosure-specializers (tag &rest _) + (and (symbolp tag) + (let ((class (cl--find-class tag))) + (when (cl-typep class 'oclosure--class) + (oclosure--class-allparents class))))) + +(cl-generic-define-generalizer cl-generic--oclosure-generalizer + ;; Give slightly higher priority than the struct specializer, so that + ;; for a generic function with methods dispatching structs and on OClosures, + ;; we first try `oclosure-type' before `type-of' since `type-of' will return + ;; non-nil for an OClosure as well. + 51 #'cl--generic-oclosure-tag + #'cl-generic--oclosure-specializers) + +(cl-defmethod cl-generic-generalizers :extra "oclosure-struct" (type) + "Support for dispatch on types defined by `oclosure-define'." + (or + (when (symbolp type) + ;; Use the "cl--struct-class*" (inlinable) functions/macros rather than + ;; the "cl-struct-*" variants which aren't inlined, so that dispatch can + ;; take place without requiring cl-lib. + (let ((class (cl--find-class type))) + (and (cl-typep class 'oclosure--class) + (list cl-generic--oclosure-generalizer)))) + (cl-call-next-method))) + +(cl--generic-prefill-dispatchers 0 oclosure) + ;;; Support for unloading. (cl-defmethod loadhist-unload-element ((x (head cl-defmethod))) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 6aa45526d84..93713f506d2 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -305,6 +305,17 @@ supertypes from the most specific to least specific.") (cl-assert (cl--class-p (cl--find-class 'cl-structure-class))) (cl-assert (cl--class-p (cl--find-class 'cl-structure-object))) +(defun cl--class-allparents (class) + (let ((parents ()) + (classes (list class))) + ;; BFS precedence. FIXME: Use a topological sort. + (while (let ((class (pop classes))) + (cl-pushnew (cl--class-name class) parents) + (setq classes + (append classes + (cl--class-parents class))))) + (nreverse parents))) + ;; Make sure functions defined with cl-defsubst can be inlined even in ;; packages which do not require CL. We don't put an autoload cookie ;; directly on that function, since those cookies only go to cl-loaddefs. diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index db108bd7bee..c37a5352a3a 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -131,16 +131,17 @@ (cl-defstruct (oclosure--class (:constructor nil) (:constructor oclosure--class-make - ( name docstring slots parents + ( name docstring slots parents allparents &aux (index-table (oclosure--index-table slots)))) (:include cl--class) (:copier nil)) - "Metaclass for OClosure classes.") + "Metaclass for OClosure classes." + (allparents nil :read-only t :type (list-of symbol))) (setf (cl--find-class 'oclosure) (oclosure--class-make 'oclosure "The root parent of all OClosure classes" - nil nil)) + nil nil '(oclosure))) (defun oclosure--p (oclosure) (not (not (oclosure-type oclosure)))) @@ -283,7 +284,9 @@ list of slot properties. The currently known properties are the following: (oclosure--class-make name docstring slotdescs (if (cdr parent-names) (oclosure--class-parents parent-class) - (list parent-class))))) + (list parent-class)) + (cons name (oclosure--class-allparents + parent-class))))) (defmacro oclosure--define-functions (name copiers) (let* ((class (cl--find-class name)) @@ -324,7 +327,10 @@ list of slot properties. The currently known properties are the following: &rest props) (let* ((class (oclosure--build-class name docstring parent-names slots)) (pred (lambda (oclosure) - (eq name (oclosure-type oclosure)))) + (let ((type (oclosure-type oclosure))) + (when type + (memq name (oclosure--class-allparents + (cl--find-class type))))))) (predname (or (plist-get props :predicate) (intern (format "%s--internal-p" name))))) (setf (cl--find-class name) class) diff --git a/test/lisp/emacs-lisp/oclosure-tests.el b/test/lisp/emacs-lisp/oclosure-tests.el index e7e76fa4bda..c72a9dbd7ad 100644 --- a/test/lisp/emacs-lisp/oclosure-tests.el +++ b/test/lisp/emacs-lisp/oclosure-tests.el @@ -29,6 +29,16 @@ "Simple OClosure." fst snd name) +(cl-defmethod oclosure-test-gen ((_x compiled-function)) "#") + +(cl-defmethod oclosure-test-gen ((_x cons)) "#") + +(cl-defmethod oclosure-test-gen ((_x oclosure)) + (format "#" (cl-call-next-method))) + +(cl-defmethod oclosure-test-gen ((_x oclosure-test)) + (format "#" (cl-call-next-method))) + (ert-deftest oclosure-test () (let* ((i 42) (ocl1 (oclosure-lambda (oclosure-test (fst 1) (snd 2) (name "hi")) @@ -51,6 +61,9 @@ (should (equal (funcall (oclosure-test-copy1 ocl1 9)) '(9 2 44))) (should (cl-typep ocl1 'oclosure-test)) (should (cl-typep ocl1 'oclosure)) + (should (member (oclosure-test-gen ocl1) + '("#>>" + "#>>"))) )) (ert-deftest oclosure-test-limits () -- cgit v1.2.3 From 1f4f6b956bee611ffa406b3851e5264ee74e3bfb Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 4 Apr 2022 15:06:47 -0400 Subject: OClosure: add support for `slot-value` * lisp/emacs-lisp/oclosure.el (oclosure--slot-index) (oclosure--slot-value, oclosure--set-slot-value): New functions. * lisp/emacs-lisp/eieio-core.el (eieio-oset, eieio-oref): Consolidate the type test. Use `oclosure--(set-)slot-value`. (eieio--validate-slot-value, eieio--validate-class-slot-value): Don't presume `class` is an EIEIO class. (eieio--class): Fix bogus `:type` info. (eieio--object-class): Simplify. (eieio--known-slot-name-p): New function. (eieio-oref, eieio-oref-default, eieio-oset-default): Use it. * test/lisp/emacs-lisp/oclosure-tests.el: Require `eieio`. (oclosure-test): Make `name` field mutable. (oclosure-test-slot-value): New test. --- lisp/emacs-lisp/eieio-core.el | 104 ++++++++++++++++++--------------- lisp/emacs-lisp/oclosure.el | 20 +++++++ test/lisp/emacs-lisp/oclosure-tests.el | 19 +++++- 3 files changed, 95 insertions(+), 48 deletions(-) (limited to 'test/lisp/emacs-lisp/oclosure-tests.el') diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index ed1a28a24fb..d687289b22f 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -92,7 +92,7 @@ Currently under control of this var: (:copier nil)) children initarg-tuples ;; initarg tuples list - (class-slots nil :type eieio--slot) + (class-slots nil :type (vector-of eieio--slot)) class-allocation-values ;; class allocated value vector default-object-cache ;; what a newly created object would look like. ; This will speed up instantiation time as @@ -130,10 +130,7 @@ Currently under control of this var: class)) (defsubst eieio--object-class (obj) - (let ((tag (eieio--object-class-tag obj))) - (if eieio-backward-compatibility - (eieio--class-object tag) - tag))) + (eieio--class-object (eieio--object-class-tag obj))) (defun class-p (x) "Return non-nil if X is a valid class vector. @@ -265,6 +262,10 @@ use '%s or turn off `eieio-backward-compatibility' instead" cname) (defvar eieio--known-slot-names nil) (defvar eieio--known-class-slot-names nil) +(defun eieio--known-slot-name-p (name) + (or (memq name eieio--known-slot-names) + (get name 'slot-name))) + (defun eieio-defclass-internal (cname superclasses slots options) "Define CNAME as a new subclass of SUPERCLASSES. SLOTS are the slots residing in that class definition, and OPTIONS @@ -704,13 +705,13 @@ an error." nil ;; Trim off object IDX junk added in for the object index. (setq slot-idx (- slot-idx (eval-when-compile eieio--object-num-slots))) - (let* ((sd (aref (cl--class-slots class) + (let* ((sd (aref (eieio--class-slots class) slot-idx)) (st (cl--slot-descriptor-type sd))) (cond ((not (eieio--perform-slot-validation st value)) (signal 'invalid-slot-type - (list (eieio--class-name class) slot st value))) + (list (cl--class-name class) slot st value))) ((alist-get :read-only (cl--slot-descriptor-props sd)) (signal 'eieio-read-only (list (cl--class-name class) slot))))))) @@ -725,7 +726,7 @@ an error." slot-idx)))) (if (not (eieio--perform-slot-validation st value)) (signal 'invalid-slot-type - (list (eieio--class-name class) slot st value)))))) + (list (cl--class-name class) slot st value)))))) (defun eieio-barf-if-slot-unbound (value instance slotname fn) "Throw a signal if VALUE is a representation of an UNBOUND slot. @@ -746,31 +747,35 @@ Argument FN is the function calling this verifier." (ignore obj) (pcase slot ((and (or `',name (and name (pred keywordp))) - (guard (not (memq name eieio--known-slot-names)))) + (guard (not (eieio--known-slot-name-p name)))) (macroexp-warn-and-return (format-message "Unknown slot `%S'" name) exp nil 'compile-only name)) (_ exp)))) + ;; FIXME: Make it a gv-expander such that the hash-table lookup is + ;; only performed once when used in `push' and friends? (gv-setter eieio-oset)) (cl-check-type slot symbol) - (cl-check-type obj (or eieio-object class cl-structure-object)) - (let* ((class (cond ((symbolp obj) - (error "eieio-oref called on a class: %s" obj) - (eieio--full-class-object obj)) - (t (eieio--object-class obj)))) - (c (eieio--slot-name-index class slot))) - (if (not c) - ;; It might be missing because it is a :class allocated slot. - ;; Let's check that info out. - (if (setq c (eieio--class-slot-name-index class slot)) - ;; Oref that slot. - (aref (eieio--class-class-allocation-values class) c) - ;; The slot-missing method is a cool way of allowing an object author - ;; to intercept missing slot definitions. Since it is also the LAST - ;; thing called in this fn, its return value would be retrieved. - (slot-missing obj slot 'oref)) - (cl-check-type obj (or eieio-object cl-structure-object)) - (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) + (cond + ((cl-typep obj '(or eieio-object cl-structure-object)) + (let* ((class (eieio--object-class obj)) + (c (eieio--slot-name-index class slot))) + (if (not c) + ;; It might be missing because it is a :class allocated slot. + ;; Let's check that info out. + (if (setq c (eieio--class-slot-name-index class slot)) + ;; Oref that slot. + (aref (eieio--class-class-allocation-values class) c) + ;; The slot-missing method is a cool way of allowing an object author + ;; to intercept missing slot definitions. Since it is also the LAST + ;; thing called in this fn, its return value would be retrieved. + (slot-missing obj slot 'oref)) + (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) + ((cl-typep obj 'oclosure) (oclosure--slot-value obj slot)) + (t + (signal 'wrong-type-argument + (list '(or eieio-object cl-structure-object oclosure) obj))))) + (defun eieio-oref-default (class slot) @@ -782,7 +787,7 @@ Fills in CLASS's SLOT with its default value." (ignore class) (pcase slot ((and (or `',name (and name (pred keywordp))) - (guard (not (memq name eieio--known-slot-names)))) + (guard (not (eieio--known-slot-name-p name)))) (macroexp-warn-and-return (format-message "Unknown slot `%S'" name) exp nil 'compile-only name)) @@ -817,24 +822,29 @@ Fills in CLASS's SLOT with its default value." (defun eieio-oset (obj slot value) "Do the work for the macro `oset'. Fills in OBJ's SLOT with VALUE." - (cl-check-type obj (or eieio-object cl-structure-object)) (cl-check-type slot symbol) - (let* ((class (eieio--object-class obj)) - (c (eieio--slot-name-index class slot))) - (if (not c) - ;; It might be missing because it is a :class allocated slot. - ;; Let's check that info out. - (if (setq c - (eieio--class-slot-name-index class slot)) - ;; Oset that slot. - (progn - (eieio--validate-class-slot-value class c value slot) - (aset (eieio--class-class-allocation-values class) - c value)) - ;; See oref for comment on `slot-missing' - (slot-missing obj slot 'oset value)) - (eieio--validate-slot-value class c value slot) - (aset obj c value)))) + (cond + ((cl-typep obj '(or eieio-object cl-structure-object)) + (let* ((class (eieio--object-class obj)) + (c (eieio--slot-name-index class slot))) + (if (not c) + ;; It might be missing because it is a :class allocated slot. + ;; Let's check that info out. + (if (setq c + (eieio--class-slot-name-index class slot)) + ;; Oset that slot. + (progn + (eieio--validate-class-slot-value class c value slot) + (aset (eieio--class-class-allocation-values class) + c value)) + ;; See oref for comment on `slot-missing' + (slot-missing obj slot 'oset value)) + (eieio--validate-slot-value class c value slot) + (aset obj c value)))) + ((cl-typep obj 'oclosure) (oclosure--set-slot-value obj slot value)) + (t + (signal 'wrong-type-argument + (list '(or eieio-object cl-structure-object oclosure) obj))))) (defun eieio-oset-default (class slot value) "Do the work for the macro `oset-default'. @@ -844,7 +854,7 @@ Fills in the default value in CLASS' in SLOT with VALUE." (ignore class value) (pcase slot ((and (or `',name (and name (pred keywordp))) - (guard (not (memq name eieio--known-slot-names)))) + (guard (not (eieio--known-slot-name-p name)))) (macroexp-warn-and-return (format-message "Unknown slot `%S'" name) exp nil 'compile-only name)) @@ -867,7 +877,7 @@ Fills in the default value in CLASS' in SLOT with VALUE." (eieio--validate-class-slot-value class c value slot) (aset (eieio--class-class-allocation-values class) c value)) - (signal 'invalid-slot-name (list (eieio--class-name class) slot))) + (signal 'invalid-slot-name (list (cl--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 rid of it. diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index c37a5352a3a..3df64ad2806 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -511,6 +511,26 @@ This has 2 uses: "OClosure function to access a specific slot of an OClosure function." index) +(defun oclosure--slot-index (oclosure slotname) + (gethash slotname + (oclosure--class-index-table + (cl--find-class (oclosure-type oclosure))))) + +(defun oclosure--slot-value (oclosure slotname) + (let ((class (cl--find-class (oclosure-type oclosure))) + (index (oclosure--slot-index oclosure slotname))) + (oclosure--get oclosure index + (oclosure--slot-mutable-p + (nth index (oclosure--class-slots class)))))) + +(defun oclosure--set-slot-value (oclosure slotname value) + (let ((class (cl--find-class (oclosure-type oclosure))) + (index (oclosure--slot-index oclosure slotname))) + (unless (oclosure--slot-mutable-p + (nth index (oclosure--class-slots class))) + (signal 'setting-constant (list oclosure slotname))) + (oclosure--set value oclosure index))) + (defconst oclosure--mut-getter-prototype (oclosure-lambda (oclosure-accessor (type) (slot) (index)) (oclosure) (oclosure--get oclosure index t))) diff --git a/test/lisp/emacs-lisp/oclosure-tests.el b/test/lisp/emacs-lisp/oclosure-tests.el index c72a9dbd7ad..d3e2b3870a6 100644 --- a/test/lisp/emacs-lisp/oclosure-tests.el +++ b/test/lisp/emacs-lisp/oclosure-tests.el @@ -22,12 +22,13 @@ (require 'ert) (require 'oclosure) (require 'cl-lib) +(require 'eieio) (oclosure-define (oclosure-test (:copier oclosure-test-copy) (:copier oclosure-test-copy1 (fst))) "Simple OClosure." - fst snd name) + fst snd (name :mutable t)) (cl-defmethod oclosure-test-gen ((_x compiled-function)) "#") @@ -123,4 +124,20 @@ (should (equal (funcall f 5) 15)) (should (equal (funcall f2 15) 68)))) +(ert-deftest oclosure-test-slot-value () + (require 'eieio) + (let ((ocl (oclosure-lambda + (oclosure-test (fst 'fst1) (snd 'snd1) (name 'name1)) + (x) + (list name fst snd x)))) + (should (equal 'fst1 (slot-value ocl 'fst))) + (should (equal 'snd1 (slot-value ocl 'snd))) + (should (equal 'name1 (slot-value ocl 'name))) + (setf (slot-value ocl 'name) 'new-name) + (should (equal 'new-name (slot-value ocl 'name))) + (should (equal '(new-name fst1 snd1 arg) (funcall ocl 'arg))) + (should-error (setf (slot-value ocl 'fst) 'new-fst) :type 'setting-constant) + (should (equal 'fst1 (slot-value ocl 'fst))) + )) + ;;; oclosure-tests.el ends here. -- cgit v1.2.3 From 39e8fd357dd0a1f3776c05eee2cc5be451686712 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 7 Apr 2022 15:59:09 -0400 Subject: OClosure: New function `function-documentation` As mentioned in the original OClosure commit, OClosures (ab)use the bytecode's docstring slot to hold the OClosure's type. This currently prevents OClosures from having their own docstring. Introduce a new generic function `function-documentation` to fetch the docstring of a function, which can then be implemented in various different ways depending on the OClosure's type. * lisp/simple.el (function-documentation): New generic function. (bad-package-check): Strength-reduce `eval` to `symbol-value`. * src/doc.c (Fdocumentation): Use it. * lisp/emacs-lisp/oclosure.el (oclosure--accessor-docstring): New function. * test/lisp/emacs-lisp/oclosure-tests.el (oclosure-test): Add test for accessor's docstrings. --- doc/lispref/help.texi | 7 +++++ etc/NEWS | 6 ++++ lisp/emacs-lisp/oclosure.el | 6 ++++ lisp/simple.el | 34 ++++++++++++++++++++++- src/doc.c | 50 +--------------------------------- test/lisp/emacs-lisp/oclosure-tests.el | 1 + 6 files changed, 54 insertions(+), 50 deletions(-) (limited to 'test/lisp/emacs-lisp/oclosure-tests.el') diff --git a/doc/lispref/help.texi b/doc/lispref/help.texi index 10a12940a15..d53bfad8e9e 100644 --- a/doc/lispref/help.texi +++ b/doc/lispref/help.texi @@ -158,6 +158,13 @@ the function definition has no documentation string. In that case, @code{documentation} returns @code{nil}. @end defun +@defun function-documentation function +Generic function used by @code{documentation} to extract the raw +docstring from a function object. You can specify how to get the +docstring of a specific function type by adding a corresponding method +to it. +@end defun + @defun face-documentation face This function returns the documentation string of @var{face} as a face. diff --git a/etc/NEWS b/etc/NEWS index 85ed817e05e..1043873f2d7 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1335,6 +1335,12 @@ This change is now applied in 'dired-insert-directory'. 'unify-8859-on-decoding-mode', 'unify-8859-on-encoding-mode', 'vc-arch-command'. ++++ +** New generic function 'function-doumentation'. +Can dynamically generate a raw docstring depending on the type of +a function. +Used mainly for docstrings of OClosures. + +++ ** Base64 encoding no longer tolerates latin-1 input. The functions 'base64-encode-string', 'base64url-encode-string', diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index 3df64ad2806..90811199f25 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -505,6 +505,12 @@ This has 2 uses: "OClosure function to access a specific slot of an object." type slot) +(defun oclosure--accessor-docstring (f) + ;; This would like to be a (cl-defmethod function-documentation ...) + ;; but for circularity reason the defmethod is in `simple.el'. + (format "Access slot \"%S\" of OBJ of type `%S'.\n\n(fn OBJ)" + (accessor--slot f) (accessor--type f))) + (oclosure-define (oclosure-accessor (:parent accessor) (:copier oclosure--accessor-copy (type slot index))) diff --git a/lisp/simple.el b/lisp/simple.el index ef520065011..80c27d6e0e5 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -2357,6 +2357,38 @@ maps." (with-suppressed-warnings ((interactive-only execute-extended-command)) (execute-extended-command prefixarg command-name typed))) +(cl-defgeneric function-documentation (function) + "Extract the raw docstring info from FUNCTION. +FUNCTION is expected to be a function value rather than, say, a mere symbol. +This is intended to be specialized via `cl-defmethod' but not called directly: +if you need a function's documentation use `documentation' which will call this +function as needed." + (let ((docstring-p (lambda (doc) + ;; A docstring can be either a string or a reference + ;; into either the `etc/DOC' or a `.elc' file. + (or (stringp doc) + (fixnump doc) (fixnump (cdr-safe doc)))))) + (pcase function + ((pred byte-code-function-p) + (when (> (length function) 4) + (let ((doc (aref function 4))) + (when (funcall docstring-p doc) doc)))) + ((or (pred stringp) (pred vectorp)) "Keyboard macro.") + (`(keymap . ,_) + "Prefix command (definition is a keymap associating keystrokes with commands).") + ((or `(lambda ,_args . ,body) `(closure ,_env ,_args . ,body) + `(autoload ,_file . ,body)) + (let ((doc (car body))) + (when (and (funcall docstring-p doc) + ;; Handle a doc reference--but these never come last + ;; in the function body, so reject them if they are last. + (or (cdr body) (eq 'autoload (car-safe function)))) + doc))) + (_ (signal 'invalid-function (list function)))))) + +(cl-defmethod function-documentation ((function accessor)) + (oclosure--accessor-docstring function)) ;; FIXME: η-reduce! + (defun command-execute (cmd &optional record-flag keys special) ;; BEWARE: Called directly from the C code. "Execute CMD as an editor command. @@ -10007,7 +10039,7 @@ warning using STRING as the message.") (and list (boundp symbol) (or (eq symbol t) - (and (stringp (setq symbol (eval symbol))) + (and (stringp (setq symbol (symbol-value symbol))) (string-match-p (nth 2 list) symbol))) (display-warning package (nth 3 list) :warning))) (error nil))) diff --git a/src/doc.c b/src/doc.c index e361a86c1a1..5326195c6a0 100644 --- a/src/doc.c +++ b/src/doc.c @@ -341,56 +341,8 @@ string is passed through `substitute-command-keys'. */) else if (MODULE_FUNCTIONP (fun)) doc = module_function_documentation (XMODULE_FUNCTION (fun)); #endif - else if (COMPILEDP (fun)) - { - if (PVSIZE (fun) <= COMPILED_DOC_STRING) - return Qnil; - else - { - Lisp_Object tem = AREF (fun, COMPILED_DOC_STRING); - if (STRINGP (tem)) - doc = tem; - else if (FIXNATP (tem) || CONSP (tem)) - doc = tem; - else - return Qnil; - } - } - else if (STRINGP (fun) || VECTORP (fun)) - { - return build_string ("Keyboard macro."); - } - else if (CONSP (fun)) - { - Lisp_Object funcar = XCAR (fun); - if (!SYMBOLP (funcar)) - xsignal1 (Qinvalid_function, fun); - else if (EQ (funcar, Qkeymap)) - return build_string ("Prefix command (definition is a keymap associating keystrokes with commands)."); - else if (EQ (funcar, Qlambda) - || (EQ (funcar, Qclosure) && (fun = XCDR (fun), 1)) - || EQ (funcar, Qautoload)) - { - Lisp_Object tem1 = Fcdr (Fcdr (fun)); - Lisp_Object tem = Fcar (tem1); - if (STRINGP (tem)) - doc = tem; - /* Handle a doc reference--but these never come last - in the function body, so reject them if they are last. */ - else if ((FIXNATP (tem) || (CONSP (tem) && FIXNUMP (XCDR (tem)))) - && !NILP (XCDR (tem1))) - doc = tem; - else - return Qnil; - } - else - goto oops; - } else - { - oops: - xsignal1 (Qinvalid_function, fun); - } + doc = call1 (intern ("function-documentation"), fun); /* If DOC is 0, it's typically because of a dumped file missing from the DOC file (bug in src/Makefile.in). */ diff --git a/test/lisp/emacs-lisp/oclosure-tests.el b/test/lisp/emacs-lisp/oclosure-tests.el index d3e2b3870a6..b6bdebc0a2b 100644 --- a/test/lisp/emacs-lisp/oclosure-tests.el +++ b/test/lisp/emacs-lisp/oclosure-tests.el @@ -65,6 +65,7 @@ (should (member (oclosure-test-gen ocl1) '("#>>" "#>>"))) + (should (stringp (documentation #'oclosure-test--fst))) )) (ert-deftest oclosure-test-limits () -- cgit v1.2.3 From bffc4cb39dc7b83fc4a1bffd23eeed2774b79444 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 26 Apr 2022 10:36:52 -0400 Subject: New generic function `oclosure-interactive-form` It's used by `interactive-form` when it encounters an OClosure. This lets one compute the `interactive-form` of OClosures dynamically by adding appropriate methods. This does not include support for `command-modes` for Oclosures. * lisp/simple.el (oclosure-interactive-form): New generic function. * src/data.c (Finteractive_form): Delegate to `oclosure-interactive-form` if the arg is an OClosure. (syms_of_data): New symbol `Qoclosure_interactive_form`. * src/eval.c (Fcommandp): Delegate to `interactive-form` if the arg is an OClosure. * src/lisp.h (VALID_DOCSTRING_P): New function, extracted from `store_function_docstring`. * src/doc.c (store_function_docstring): Use it. * lisp/kmacro.el (kmacro): Don't carry any interactive form. (oclosure-interactive-form) : New method, instead. * test/lisp/emacs-lisp/oclosure-tests.el (oclosure-interactive-form) : New method. (oclosure-test-interactive-form): New test. * doc/lispref/commands.texi (Using Interactive): Document `oclosure-interactive-form`. --- doc/lispref/commands.texi | 19 +++++++ etc/NEWS | 5 ++ lisp/kmacro.el | 3 +- lisp/simple.el | 11 ++++ src/callint.c | 2 +- src/data.c | 32 ++++++++---- src/doc.c | 4 +- src/eval.c | 94 +++++++++++++++++++++++----------- src/lisp.h | 10 ++++ test/lisp/emacs-lisp/oclosure-tests.el | 21 ++++++++ 10 files changed, 157 insertions(+), 44 deletions(-) (limited to 'test/lisp/emacs-lisp/oclosure-tests.el') diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi index ace0c025512..6c60216796c 100644 --- a/doc/lispref/commands.texi +++ b/doc/lispref/commands.texi @@ -312,6 +312,25 @@ If @var{function} is an interactively callable function specifies how to compute its arguments. Otherwise, the value is @code{nil}. If @var{function} is a symbol, its function definition is used. +When called on an OClosure, the work is delegated to the generic +function @code{oclosure-interactive-form}. +@end defun + +@defun oclosure-interactive-form function +Just like @code{interactive-form}, this function takes a command and +returns its interactive form. The difference is that it is a generic +function and it is only called when @var{function} is an OClosure. +The purpose is to make it possible for some OClosure types to compute +their interactive forms dynamically instead of carrying it in one of +their slots. + +This is used for example for @code{kmacro} functions in order to +reduce their memory size, since they all share the same interactive +form. It is also used for @code{advice} functions, where the +interactive form is computed from the interactive forms of its +components, so as to make this computation more lazily and to +correctly adjust the interactive form when one of its component's +is redefined. @end defun @node Interactive Codes diff --git a/etc/NEWS b/etc/NEWS index dc2e7c616a5..19434ec85b7 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1345,6 +1345,11 @@ remote host are shown. Alternatively, the user option Allows the creation of "functions with slots" or "function objects" via the macros 'oclosure-define' and 'oclosure-lambda'. +*** New generic function 'oclosure-interactive-form'. +Used by 'interactive-form' when called on an OClosure. +This allows specific OClosure types to compute their interactive specs +on demand rather than precompute them when created. + --- ** New theme 'leuven-dark'. This is a dark version of the 'leuven' theme. diff --git a/lisp/kmacro.el b/lisp/kmacro.el index 8a9d89929eb..5476c2395ca 100644 --- a/lisp/kmacro.el +++ b/lisp/kmacro.el @@ -820,13 +820,14 @@ KEYS should be a vector or a string that obeys `key-valid-p'." (counter (or counter 0)) (format (or format "%d"))) (&optional arg) - (interactive "p") ;; Use counter and format specific to the macro on the ring! (let ((kmacro-counter counter) (kmacro-counter-format-start format)) (execute-kbd-macro keys arg #'kmacro-loop-setup-function) (setq counter kmacro-counter)))) +(cl-defmethod oclosure-interactive-form ((_ kmacro)) '(interactive "p")) + ;;;###autoload (defun kmacro-lambda-form (mac &optional counter format) ;; Apparently, there are two different ways this is called: diff --git a/lisp/simple.el b/lisp/simple.el index 1ff101cfcd1..d638e641c3e 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -2389,6 +2389,17 @@ function as needed." (cl-defmethod function-documentation ((function accessor)) (oclosure--accessor-docstring function)) ;; FIXME: η-reduce! +;; This should be in `oclosure.el' but that file is loaded before `cl-generic'. +(cl-defgeneric oclosure-interactive-form (_function) + "Return the interactive form of FUNCTION or nil if none. +This is called by `interactive-form' when invoked on OClosures. +It should return either nil or a two-element list of the form (interactive FORM) +where FORM is like the first arg of the `interactive' special form. +Add your methods to this generic function, but always call `interactive-form' +instead." + ;; (interactive-form function) + nil) + (defun command-execute (cmd &optional record-flag keys special) ;; BEWARE: Called directly from the C code. "Execute CMD as an editor command. diff --git a/src/callint.c b/src/callint.c index 31919d6bb81..92bfaf8d397 100644 --- a/src/callint.c +++ b/src/callint.c @@ -315,7 +315,7 @@ invoke it (via an `interactive' spec that contains, for instance, an Lisp_Object up_event = Qnil; /* Set SPECS to the interactive form, or barf if not interactive. */ - Lisp_Object form = Finteractive_form (function); + Lisp_Object form = call1 (Qinteractive_form, function); if (! CONSP (form)) wrong_type_argument (Qcommandp, function); Lisp_Object specs = Fcar (XCDR (form)); diff --git a/src/data.c b/src/data.c index 72af8a6648e..0347ff363c1 100644 --- a/src/data.c +++ b/src/data.c @@ -1072,6 +1072,7 @@ Value, if non-nil, is a list (interactive SPEC). */) (Lisp_Object cmd) { Lisp_Object fun = indirect_function (cmd); /* Check cycles. */ + bool genfun = false; if (NILP (fun)) return Qnil; @@ -1104,15 +1105,17 @@ Value, if non-nil, is a list (interactive SPEC). */) if (PVSIZE (fun) > COMPILED_INTERACTIVE) { Lisp_Object form = AREF (fun, COMPILED_INTERACTIVE); - if (VECTORP (form)) - /* The vector form is the new form, where the first - element is the interactive spec, and the second is the - command modes. */ - return list2 (Qinteractive, AREF (form, 0)); - else - /* Old form -- just the interactive spec. */ - return list2 (Qinteractive, form); + /* The vector form is the new form, where the first + element is the interactive spec, and the second is the + command modes. */ + return list2 (Qinteractive, VECTORP (form) ? AREF (form, 0) : form); } + else if (PVSIZE (fun) > COMPILED_DOC_STRING) + { + Lisp_Object doc = AREF (fun, COMPILED_DOC_STRING); + /* An invalid "docstring" is a sign that we have an OClosure. */ + genfun = !(NILP (doc) || VALID_DOCSTRING_P (doc)); + } } #ifdef HAVE_MODULES else if (MODULE_FUNCTIONP (fun)) @@ -1135,13 +1138,21 @@ Value, if non-nil, is a list (interactive SPEC). */) if (EQ (funcar, Qclosure)) form = Fcdr (form); Lisp_Object spec = Fassq (Qinteractive, form); - if (NILP (Fcdr (Fcdr (spec)))) + if (NILP (spec) && VALID_DOCSTRING_P (CAR_SAFE (form))) + /* A "docstring" is a sign that we may have an OClosure. */ + genfun = true; + else if (NILP (Fcdr (Fcdr (spec)))) return spec; else return list2 (Qinteractive, Fcar (Fcdr (spec))); } } - return Qnil; + if (genfun + /* Avoid burping during bootstrap. */ + && !NILP (Fsymbol_function (Qoclosure_interactive_form))) + return call1 (Qoclosure_interactive_form, fun); + else + return Qnil; } DEFUN ("command-modes", Fcommand_modes, Scommand_modes, 1, 1, 0, @@ -4123,6 +4134,7 @@ syms_of_data (void) DEFSYM (Qchar_table_p, "char-table-p"); DEFSYM (Qvector_or_char_table_p, "vector-or-char-table-p"); DEFSYM (Qfixnum_or_symbol_with_pos_p, "fixnum-or-symbol-with-pos-p"); + DEFSYM (Qoclosure_interactive_form, "oclosure-interactive-form"); DEFSYM (Qsubrp, "subrp"); DEFSYM (Qunevalled, "unevalled"); diff --git a/src/doc.c b/src/doc.c index 5326195c6a0..71e66853b08 100644 --- a/src/doc.c +++ b/src/doc.c @@ -469,9 +469,7 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset) if (PVSIZE (fun) > COMPILED_DOC_STRING /* Don't overwrite a non-docstring value placed there, * such as the symbols used for Oclosures. */ - && (FIXNUMP (AREF (fun, COMPILED_DOC_STRING)) - || STRINGP (AREF (fun, COMPILED_DOC_STRING)) - || CONSP (AREF (fun, COMPILED_DOC_STRING)))) + && VALID_DOCSTRING_P (AREF (fun, COMPILED_DOC_STRING))) ASET (fun, COMPILED_DOC_STRING, make_fixnum (offset)); else { diff --git a/src/eval.c b/src/eval.c index 37bc03465cc..77ec47e2b79 100644 --- a/src/eval.c +++ b/src/eval.c @@ -2032,8 +2032,7 @@ then strings and vectors are not accepted. */) (Lisp_Object function, Lisp_Object for_call_interactively) { register Lisp_Object fun; - register Lisp_Object funcar; - Lisp_Object if_prop = Qnil; + bool genfun = false; /* If true, we should consult `interactive-form'. */ fun = function; @@ -2041,52 +2040,89 @@ then strings and vectors are not accepted. */) if (NILP (fun)) return Qnil; - /* Check an `interactive-form' property if present, analogous to the - function-documentation property. */ - fun = function; - while (SYMBOLP (fun)) - { - Lisp_Object tmp = Fget (fun, Qinteractive_form); - if (!NILP (tmp)) - if_prop = Qt; - fun = Fsymbol_function (fun); - } - /* Emacs primitives are interactive if their DEFUN specifies an interactive spec. */ if (SUBRP (fun)) - return XSUBR (fun)->intspec.string ? Qt : if_prop; - + { + if (XSUBR (fun)->intspec.string) + return Qt; + } /* Bytecode objects are interactive if they are long enough to have an element whose index is COMPILED_INTERACTIVE, which is where the interactive spec is stored. */ else if (COMPILEDP (fun)) - return (PVSIZE (fun) > COMPILED_INTERACTIVE ? Qt : if_prop); + { + if (PVSIZE (fun) > COMPILED_INTERACTIVE) + return Qt; + else if (PVSIZE (fun) > COMPILED_DOC_STRING) + { + Lisp_Object doc = AREF (fun, COMPILED_DOC_STRING); + /* An invalid "docstring" is a sign that we have an OClosure. */ + genfun = !(NILP (doc) || VALID_DOCSTRING_P (doc)); + } + } #ifdef HAVE_MODULES /* Module functions are interactive if their `interactive_form' field is non-nil. */ else if (MODULE_FUNCTIONP (fun)) - return NILP (module_function_interactive_form (XMODULE_FUNCTION (fun))) - ? if_prop - : Qt; + { + if (!NILP (module_function_interactive_form (XMODULE_FUNCTION (fun)))) + return Qt; + } #endif /* Strings and vectors are keyboard macros. */ - if (STRINGP (fun) || VECTORP (fun)) + else if (STRINGP (fun) || VECTORP (fun)) return (NILP (for_call_interactively) ? Qt : Qnil); /* Lists may represent commands. */ - if (!CONSP (fun)) + else if (!CONSP (fun)) return Qnil; - funcar = XCAR (fun); - if (EQ (funcar, Qclosure)) - return (!NILP (Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun))))) - ? Qt : if_prop); - else if (EQ (funcar, Qlambda)) - return !NILP (Fassq (Qinteractive, Fcdr (XCDR (fun)))) ? Qt : if_prop; - else if (EQ (funcar, Qautoload)) - return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun))))) ? Qt : if_prop; + else + { + Lisp_Object funcar = XCAR (fun); + if (EQ (funcar, Qautoload)) + { + if (!NILP (Fcar (Fcdr (Fcdr (XCDR (fun)))))) + return Qt; + } + else + { + Lisp_Object body = CDR_SAFE (XCDR (fun)); + if (EQ (funcar, Qclosure)) + body = CDR_SAFE (body); + else if (!EQ (funcar, Qlambda)) + return Qnil; + if (!NILP (Fassq (Qinteractive, body))) + return Qt; + else if (VALID_DOCSTRING_P (CAR_SAFE (body))) + /* A "docstring" is a sign that we may have an OClosure. */ + genfun = true; + } + } + + /* By now, if it's not a function we already returned nil. */ + + /* Check an `interactive-form' property if present, analogous to the + function-documentation property. */ + fun = function; + while (SYMBOLP (fun)) + { + Lisp_Object tmp = Fget (fun, Qinteractive_form); + if (!NILP (tmp)) + error ("Found an 'interactive-form' property!"); + fun = Fsymbol_function (fun); + } + + /* If there's no immediate interactive form but it's an OClosure, + then delegate to the generic-function in case it has + a type-specific interactive-form. */ + if (genfun) + { + Lisp_Object iform = call1 (Qinteractive_form, fun); + return NILP (iform) ? Qnil : Qt; + } else return Qnil; } diff --git a/src/lisp.h b/src/lisp.h index 75f369f5245..1ad89fc4689 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2185,6 +2185,16 @@ XSUBR (Lisp_Object a) return &XUNTAG (a, Lisp_Vectorlike, union Aligned_Lisp_Subr)->s; } +/* Return whether a value might be a valid docstring. + Used to distinguish the presence of non-docstring in the docstring slot, + as in the case of OClosures. */ +INLINE bool +VALID_DOCSTRING_P (Lisp_Object doc) +{ + return FIXNUMP (doc) || STRINGP (doc) + || (CONSP (doc) && STRINGP (XCAR (doc)) && FIXNUMP (XCDR (doc))); +} + enum char_table_specials { /* This is the number of slots that every char table must have. This diff --git a/test/lisp/emacs-lisp/oclosure-tests.el b/test/lisp/emacs-lisp/oclosure-tests.el index b6bdebc0a2b..b3a921826b1 100644 --- a/test/lisp/emacs-lisp/oclosure-tests.el +++ b/test/lisp/emacs-lisp/oclosure-tests.el @@ -106,6 +106,27 @@ (and (eq 'error (car err)) (string-match "Duplicate slot: fst$" (cadr err))))))) +(cl-defmethod oclosure-interactive-form ((ot oclosure-test)) + (let ((snd (oclosure-test--snd ot))) + (if (stringp snd) (list 'interactive snd)))) + +(ert-deftest oclosure-test-interactive-form () + (should (equal (interactive-form + (oclosure-lambda (oclosure-test (fst 1) (snd 2)) () fst)) + nil)) + (should (equal (interactive-form + (oclosure-lambda (oclosure-test (fst 1) (snd 2)) () + (interactive "r") + fst)) + '(interactive "r"))) + (should (equal (interactive-form + (oclosure-lambda (oclosure-test (fst 1) (snd "P")) () fst)) + '(interactive "P"))) + (should (not (commandp + (oclosure-lambda (oclosure-test (fst 1) (snd 2)) () fst)))) + (should (commandp + (oclosure-lambda (oclosure-test (fst 1) (snd "P")) () fst)))) + (oclosure-define (oclosure-test-mut (:parent oclosure-test) (:copier oclosure-test-mut-copy)) -- cgit v1.2.3 From d3893d7e8e20b392e531f00981191138e26d8bff Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sun, 26 Jun 2022 13:15:15 -0400 Subject: (oclosure-test-limits): Fix test failure when interpreted * test/lisp/emacs-lisp/oclosure-tests.el (oclosure-test-limits): Make sure we bind `byte-compile-debug` dynamically. --- test/lisp/emacs-lisp/oclosure-tests.el | 1 + 1 file changed, 1 insertion(+) (limited to 'test/lisp/emacs-lisp/oclosure-tests.el') diff --git a/test/lisp/emacs-lisp/oclosure-tests.el b/test/lisp/emacs-lisp/oclosure-tests.el index b3a921826b1..00b008845c0 100644 --- a/test/lisp/emacs-lisp/oclosure-tests.el +++ b/test/lisp/emacs-lisp/oclosure-tests.el @@ -69,6 +69,7 @@ )) (ert-deftest oclosure-test-limits () + (defvar byte-compile-debug) (should (condition-case err (let ((lexical-binding t) -- cgit v1.2.3