[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
bug#54456: 29.0.50; Add OClosures
|
From: |
Stefan Monnier |
|
Subject: |
bug#54456: 29.0.50; Add OClosures |
|
Date: |
Fri, 18 Mar 2022 19:09:50 -0400 |
Package: Emacs
Version: 29.0.50
This is the first patch extracted from the `scratch/oclosure` branch.
That branch aims mostly to clean up some hacks in `nadvice.el`
and `cl-generic.el` although the functionality is also useful in a few
more cases (e.g. for `kmacro.el`).
Here I just focus on adding the core functionality, tho, without actually
making use of it.
Comments? Objections?
Stefan
2022-03-18 Stefan Monnier <monnier@iro.umontreal.ca>
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`.
diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi
index 207919ea645..556376416f4 100644
--- a/doc/lispref/functions.texi
+++ b/doc/lispref/functions.texi
@@ -22,6 +22,7 @@ Functions
* Function Cells:: Accessing or setting the function definition
of a symbol.
* Closures:: Functions that enclose a lexical environment.
+* OClosures:: Function objects
* Advising Functions:: Adding to the definition of a function.
* Obsolete Functions:: Declaring functions obsolete.
* Inline Functions:: Functions that the compiler will expand inline.
@@ -1509,6 +1510,116 @@ Closures
implementation detail. For this reason, we recommend against directly
examining or altering the structure of closure objects.
+@node OClosures
+@section Open Closures
+
+Traditionally, functions are opaque objects which offer no other
+functionality but to call them. Emacs Lisp functions aren't fully
+opaque since you can extract some info out of them such as their
+docstring, their arglist, or their interactive spec, but they are
+mostly opaque. This is usually what we want, but occasionally we need
+functions to expose a bit more information about themselves.
+
+OClosures are functions which carry an additional type information,
+and expose some information in the form of slots which you can access
+via accessor functions.
+
+They are defined in two steps: first @code{oclosure-define} is used to
+define new OClosure types by specifying the slots carried by those
+OClosures, and then @code{oclosure-lambda} is used to create an
+OClosure object of a given type.
+
+Say we want to define keyboard macros, i.e. interactive functions
+which re-execute a sequence of key events. You could do it with
+a plain function as follows:
+@example
+(defun kbd-macro (key-sequence)
+ (lambda (&optional arg)
+ (interactive "P")
+ (execute-kbd-macro key-sequence arg)))
+@end example
+But with such a definition there is no easy way to extract the
+@var{key-sequence} from that function, for example to print it.
+
+We can solve this problem using OClosures as follows. First we define
+the type of our keyboard macros (to which we decided to add
+a @code{counter} slot while at it):
+@example
+(oclosure-define kbd-macro
+ "Keyboard macro."
+ keys (counter :mutable t))
+@end example
+After which we can rewrite our @code{kbd-macro} function:
+@example
+(defun kbd-macro (key-sequence)
+ (oclosure-lambda (kbd-macro (keys key-sequence) (counter 0))
+ (&optional arg)
+ (interactive "p")
+ (execute-kbd-macro keys arg)
+ (setq counter (1+ counter))))
+@end example
+As you can see, the @code{keys} and @code{counter} slots of the
+OClosure can be accessed as local variables from within the body
+of the OClosure. But we can now also access them from outside of the
+body of the OClosure, for example to describe a keyboard macro:
+@example
+(defun describe-kbd-macro (km)
+ (if (not (eq 'kbd-macro (oclosure-type km)))
+ (message "Not a keyboard macro")
+ (let ((keys (kbd-macro--keys km))
+ (counter (kbd-macro--counter km)))
+ (message "Keys=%S, called %d times" keys counter))))
+@end example
+Where @code{kbd-macro--keys} and @code{kbd-macro--counter} are
+accessor functions generated by the @code{oclosure-define} macro.
+
+@defmac oclosure-define name &optional docstring &rest slots
+This macro defines a new OClosure type along with accessor functions
+for its slots. @var{name} can be a symbol (the name of
+the new type), or a list of the form @code{(@var{name} . @var{type-props})} in
+which case @var{type-props} is a list of additional properties.
+@var{slots} is a list of slot descriptions where each slot can be
+either a symbol (the name of the slot) or it can be of the form
+@code{(@var{slot-name} . @var{slot-props})} where @var{slot-props} is
+a property list.
+
+For each slot, the macro creates an accessor function named
+@code{@var{name}--@var{slot-name}}. By default slots are immutable.
+If you need a slot to be mutable, you need to specify it with the
+@code{:mutable} slot property, after which it can be mutated for
+example with @code{setf}.
+
+Beside slot accessors, the macro can create a predicate and
+functional update functions according to @var{type-props}:
+a @code{(:predicate @var{pred-name})} in the @var{type-props} causes
+the definition of a predicate function under the name @var{pred-name},
+and @code{(:coper @var{copier-name} @var{copier-arglist})} causes the
+definition of a functional update function which takes an OClosure of
+type @var{name} as first argument and returns a copy of it with the
+slots named in @var{copier-arglist} modified to the value passed in the
+corresponding argument.
+@end defmac
+
+@defmac oclosure-lambda (type . slots) arglist &rest body
+This macro creates an anonymous OClosure of type @var{type}.
+@var{slots} should be a list of elements of the form @code{(@var{slot-name}
+@var{exp})}.
+At run time, each @var{exp} is evaluated, in order, after which
+the OClosure is created with its slots initialized with the
+resulting values.
+
+When called as a function, the OClosure will accept arguments
+according to @var{arglist} and will execute the code in @var{body}.
+@var{body} can refer to the value of any of its slot directly as if it
+were a local variable that had been captured by static scoping.
+@end defmac
+
+@defun oclosure-type object
+This function returns the OClosure type (a symbol) of @var{object} if it is an
+OClosure, and nil otherwise.
+@end defun
+
+
@node Advising Functions
@section Advising Emacs Lisp Functions
@cindex advising functions
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index c16619bc45d..be4fea7be14 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -201,7 +201,10 @@ cconv--convert-function
(i 0)
(new-env ()))
;; Build the "formal and actual envs" for the closure-converted function.
- (dolist (fv fvs)
+ ;; Hack for OClosure: `nreverse' here intends to put the captured vars
+ ;; in the closure such that the first one is the one that is bound
+ ;; most closely.
+ (dolist (fv (nreverse fvs))
(let ((exp (or (cdr (assq fv env)) fv)))
(pcase exp
;; If `fv' is a variable that's wrapped in a cons-cell,
@@ -240,7 +243,7 @@ cconv--remap-llv
;; this case better, we'd need to traverse the tree one more time to
;; collect this data, and I think that it's not worth it.
(mapcar (lambda (mapping)
- (if (not (eq (cadr mapping) 'apply-partially))
+ (if (not (eq (cadr mapping) #'apply-partially))
mapping
(cl-assert (eq (car mapping) (nth 2 mapping)))
`(,(car mapping)
@@ -449,6 +452,9 @@ cconv-convert
(let ((var-def (cconv--lifted-arg var env))
(closedsym (make-symbol (format "closed-%s" var))))
(setq new-env (cconv--remap-llv new-env var closedsym))
+ ;; FIXME: `closedsym' doesn't need to be added to `extend'
+ ;; but adding it makes it easier to write the assertion at
+ ;; the beginning of this function.
(setq new-extend (cons closedsym (remq var new-extend)))
(push `(,closedsym ,var-def) binders-new)))
@@ -604,6 +610,14 @@ cconv-convert
(`(declare . ,_) form) ;The args don't contain code.
+ (`(oclosure--fix-type (ignore . ,vars) ,exp)
+ (dolist (var vars)
+ (let ((x (assq var env)))
+ (pcase (cdr x)
+ (`(car-safe . ,_) (error "Slot %S should not be mutated" var))
+ (_ (cl-assert (null (cdr x)))))))
+ (cconv-convert exp env extend))
+
(`(,func . ,forms)
;; First element is function or whatever function-like forms are: or, and,
;; if, catch, progn, prog1, while, until
diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el
new file mode 100644
index 00000000000..3d17c6c668c
--- /dev/null
+++ b/lisp/emacs-lisp/oclosure.el
@@ -0,0 +1,522 @@
+;;; oclosure.el --- Open Closures -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021-2022 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+
+;; This program 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.
+
+;; This program 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 this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; An OClosure is an object that combines the properties of records
+;; with those of a function. More specifically it is a function extended
+;; with a notion of type (e.g. for defmethod dispatch) as well as the
+;; ability to have some fields that are accessible from the outside.
+
+;; See "Open closures", ELS'2022 (https://zenodo.org/record/6228797).
+
+;; Here are some cases of "callable objects" where OClosures have found use:
+;; - nadvice.el (the original motivation)
+;; - kmacros (for cl-print and for `kmacro-extract-lambda')
+;; - cl-generic: turn `cl--generic-isnot-nnm-p' into a mere type test
+;; (by putting the no-next-methods into their own class).
+;; - Slot accessor functions, where the type-dispatch can be used to
+;; dynamically compute the docstring, and also to pretty print them.
+;; - `save-some-buffers-function'
+;; Here are other cases of "callable objects" where OClosures could be used:
+;; - Use the type to distinguish macros from functions.
+;; - Use a `name' and `depth' property from the function passed to
+;; `add-function' (or `add-hook') instead of passing it via "props".
+;; - iterators (generator.el), thunks (thunk.el), streams (stream.el).
+;; - PEG rules: they're currently just functions, but they should carry
+;; their original (macro-expanded) definition (and should be printed
+;; differently from functions)!
+;; - auto-generate docstrings for cl-defstruct slot accessors instead of
+;; storing them in the accessor itself?
+;; - SRFI-17's `setter'.
+;; - coercion wrappers, as in "Threesomes, with and without blame"
+;; https://dl.acm.org/doi/10.1145/1706299.1706342, or
+;; "On the Runtime Complexity of Type-Directed Unboxing"
+;; http://sv.c.titech.ac.jp/minamide/papers.html
+;; - An efficient `negate' operation such that
+;; (negate (negate f)) returns just `f' and (negate #'<) returns #'>=.
+;; - Autoloads (tho currently our bytecode functions (and hence OClosures)
+;; are too fat for that).
+
+;; Related constructs:
+;; - `funcallable-standard-object' (FSO) in Common-Lisp. These are different
+;; from OClosures in that they involve an additional indirection to get
+;; to the actual code, and that they offer the possibility of
+;; changing (via mutation) the code associated with
+;; an FSO. Also the FSO's function can't directly access the FSO's
+;; other fields, contrary to the case with OClosures where those are directly
+;; available as local variables.
+;; - Function objects in Javascript.
+;; - Function objects in Python.
+;; - Callable/Applicable classes in OO languages, i.e. classes with
+;; a single method called `apply' or `call'. The most obvious
+;; difference with OClosures (beside the fact that Callable can be
+;; extended with additional methods) is that all instances of
+;; a given Callable class have to use the same method, whereas every
+;; OClosure object comes with its own code, so two OClosure objects of the
+;; same type can have different code. Of course, you can get the
+;; same result by turning every `oclosure-lambda' into its own class
+;; declaration creating an ad-hoc subclass of the specified type.
+;; In this sense, OClosures are just a generalization of `lambda' which
brings
+;; some of the extra feature of Callable objects.
+;; - Apply hooks and "entities" in MIT Scheme
+;;
https://www.gnu.org/software/mit-scheme/documentation/stable/mit-scheme-ref/Application-Hooks.html
+;; Apply hooks are basically the same as Common-Lisp's FSOs, and "entities"
+;; are a variant of it where the inner function gets the FSO itself as
+;; additional argument (a kind of "self" arg), thus making it easier
+;; for the code to get data from the object's extra info, tho still
+;; not as easy as with OClosures.
+;; - "entities" in Lisp Machine Lisp (LML)
+;; https://hanshuebner.github.io/lmman/fd-clo.xml
+;; These are arguably identical to OClosures, modulo the fact that LML
doesn't
+;; have lexically-scoped closures and uses a form of closures based on
+;; capturing (and reinstating) dynamically scoped bindings instead.
+
+;; Naming: OClosures were originally named FunCallableRecords (FCR), but
+;; that name suggested these were fundamentally records that happened
+;; to be called, whereas OClosures are really just closures that happen
+;; to enjoy some characteristics of records.
+;; The "O" comes from "Open" because OClosures aren't completely opaque
+;; (for that same reason, an alternative name suggested at the time was
+;; "disclosures").
+;; The "O" can also be understood to mean "Object" since you have notions
+;; of inheritance, and the ability to associate methods with particular
+;; OClosure types, just as is the case for OO classes.
+
+;;; Code:
+
+;; TODO:
+;; - `oclosure-(cl-)defun', `oclosure-(cl-)defsubst', `oclosure-define-inline'?
+;; - Use accessor in cl-defstruct.
+;; - Add pcase patterns for OClosures.
+;; - anonymous OClosure types.
+;; - copiers for mixins
+;; - class-allocated slots?
+;; - code-allocated slots?
+;; The `where' slot of `advice' would like to be code-allocated, and the
+;; interactive-spec of commands is currently code-allocated but would like
+;; to be instance-allocated. Their scoping rules are a bit odd, so maybe
+;; it's best to avoid them.
+
+(eval-when-compile (require 'cl-lib))
+(eval-when-compile (require 'subr-x)) ;For `named-let'.
+
+(defun oclosure--index-table (slotdescs)
+ (let ((i -1)
+ (it (make-hash-table :test #'eq)))
+ (dolist (desc slotdescs)
+ (let* ((slot (cl--slot-descriptor-name desc)))
+ (cl-incf i)
+ (when (gethash slot it)
+ (error "Duplicate slot name: %S" slot))
+ (setf (gethash slot it) i)))
+ it))
+
+(cl-defstruct (oclosure--class
+ (:constructor nil)
+ (:constructor oclosure--class-make
+ ( name docstring slots parents
+ &aux (index-table (oclosure--index-table slots))))
+ (:include cl--class)
+ (:copier nil))
+ "Metaclass for OClosure classes.")
+
+(setf (cl--find-class 'oclosure)
+ (oclosure--class-make 'oclosure
+ "The root parent of all OClosure classes"
+ nil nil))
+(defun oclosure--p (oclosure)
+ (not (not (oclosure-type oclosure))))
+
+(cl-deftype oclosure () '(satisfies oclosure--p))
+
+(defun oclosure--slot-mutable-p (slotdesc)
+ (not (alist-get :read-only (cl--slot-descriptor-props slotdesc))))
+
+(defun oclosure--defstruct-make-copiers (copiers slotdescs name)
+ (require 'cl-macs) ;`cl--arglist-args' is not autoloaded.
+ (let* ((mutables '())
+ (slots (mapcar
+ (lambda (desc)
+ (let ((name (cl--slot-descriptor-name desc)))
+ (when (oclosure--slot-mutable-p desc)
+ (push name mutables))
+ name))
+ slotdescs)))
+ (mapcar
+ (lambda (copier)
+ (pcase-let*
+ ((cname (pop copier))
+ (args (or (pop copier) `(&key ,@slots)))
+ (inline (and (eq :inline (car copier)) (pop copier)))
+ (doc (or (pop copier)
+ (format "Copier for objects of type `%s'." name)))
+ (obj (make-symbol "obj"))
+ (absent (make-symbol "absent"))
+ (anames (cl--arglist-args args))
+ (mnames
+ (let ((res '())
+ (tmp args))
+ (while (and tmp
+ (not (memq (car tmp)
+ cl--lambda-list-keywords)))
+ (push (pop tmp) res))
+ res))
+ (index -1)
+ (mutlist '())
+ (argvals
+ (mapcar
+ (lambda (slot)
+ (setq index (1+ index))
+ (let* ((mutable (memq slot mutables))
+ (get `(oclosure--get ,obj ,index ,(not (not mutable)))))
+ (push mutable mutlist)
+ (cond
+ ((not (memq slot anames)) get)
+ ((memq slot mnames) slot)
+ (t
+ `(if (eq ',absent ,slot)
+ ,get
+ ,slot)))))
+ slots)))
+ `(,(if inline 'cl-defsubst 'cl-defun) ,cname
+ (&cl-defs (',absent) ,obj ,@args)
+ ,doc
+ (declare (side-effect-free t))
+ (oclosure--copy ,obj ',(if (remq nil mutlist) (nreverse mutlist))
+ ,@argvals))))
+ copiers)))
+
+
+(defmacro oclosure-define (name &optional docstring &rest slots)
+ "Define a new OClosure type.
+NAME should be a symbol which is the name of the new type.
+It can also be of the form (NAME . PROPS) in which case PROPS
+is a list of additional properties among the following:
+ (:predicate PRED): asks to create a predicate function named PRED.
+ (:parent TYPE): make TYPE (another OClosure type) be a parent of NAME.
+ (:copier COPIER ARGS): asks to create a \"copier\" (i.e. functional update
+ function) named COPIER. It will take an object of type NAME as first
+ argument followed by ARGS. ARGS lists the names of the slots that will
+ be updated with the value of the corresponding argument.
+SLOTS is a list if slot descriptions. Each slot can be a single symbol
+which is the name of the slot, or it can be of the form (SLOT-NAME . SPROPS)
+where SLOT-NAME is then the name of the slot and SPROPS is a property
+list of slot properties. The currently known properties are the following:
+ `:mutable': A non-nil value mean the slot can be mutated.
+ `:type': Specifies the type of the values expected to appear in the slot."
+ (declare (doc-string 2) (indent 1))
+ (unless (stringp docstring)
+ (push docstring slots)
+ (setq docstring nil))
+ (let* ((options (when (consp name)
+ (prog1 (copy-sequence (cdr name))
+ (setq name (car name)))))
+ (get-opt (lambda (opt &optional all)
+ (let ((val (assq opt options))
+ tmp)
+ (when val (setq options (delq val options)))
+ (if (not all)
+ (cdr val)
+ (when val
+ (setq val (list (cdr val)))
+ (while (setq tmp (assq opt options))
+ (push (cdr tmp) val)
+ (setq options (delq tmp options)))
+ (nreverse val))))))
+ (predicate (car (funcall get-opt :predicate)))
+ (parent-names (or (funcall get-opt :parent)
+ (funcall get-opt :include)))
+ (copiers (funcall get-opt :copier 'all)))
+ `(progn
+ ,(when options (macroexp-warn-and-return name
+ (format "Ignored options: %S" options)
+ nil))
+ (eval-and-compile
+ (oclosure--define ',name ,docstring ',parent-names ',slots
+ ,@(when predicate `(:predicate ',predicate))))
+ (oclosure--define-functions ,name ,copiers))))
+
+(defun oclosure--build-class (name docstring parent-names slots)
+ (cl-assert (null (cdr parent-names)))
+ (let* ((parent-class (let ((name (or (car parent-names) 'oclosure)))
+ (or (cl--find-class name)
+ (error "Unknown class: %S" name))))
+ (slotdescs
+ (append
+ (oclosure--class-slots parent-class)
+ (mapcar (lambda (field)
+ (if (not (consp field))
+ (cl--make-slot-descriptor field nil nil
+ '((:read-only . t)))
+ (let ((name (pop field))
+ (type nil)
+ (read-only t)
+ (props '()))
+ (while field
+ (pcase (pop field)
+ (:mutable (setq read-only (not (car field))))
+ (:type (setq type (car field)))
+ (p (message "Unknown property: %S" p)
+ (push (cons p (car field)) props)))
+ (setq field (cdr field)))
+ (cl--make-slot-descriptor name nil type
+ `((:read-only . ,read-only)
+ ,@props)))))
+ slots))))
+ (oclosure--class-make name docstring slotdescs
+ (if (cdr parent-names)
+ (oclosure--class-parents parent-class)
+ (list parent-class)))))
+
+(defmacro oclosure--define-functions (name copiers)
+ (let* ((class (cl--find-class name))
+ (slotdescs (oclosure--class-slots class)))
+ `(progn
+ ,@(let ((i -1))
+ (mapcar (lambda (desc)
+ (let* ((slot (cl--slot-descriptor-name desc))
+ (mutable (oclosure--slot-mutable-p desc))
+ ;; Always use a double hyphen: if users wants to
+ ;; make it public, they can do so with an alias.
+ (aname (intern (format "%S--%S" name slot))))
+ (cl-incf i)
+ (if (not mutable)
+ `(defalias ',aname
+ ;; We use `oclosure--copy' instead of
+ ;; `oclosure--accessor-copy' here to circumvent
+ ;; bootstrapping problems.
+ (oclosure--copy
+ oclosure--accessor-prototype
+ nil ',name ',slot ,i))
+ (require 'gv) ;For `gv-setter'.
+ `(progn
+ (defalias ',aname
+ (oclosure--accessor-copy
+ oclosure--mut-getter-prototype
+ ',name ',slot ,i))
+ (defalias ',(gv-setter aname)
+ (oclosure--accessor-copy
+ oclosure--mut-setter-prototype
+ ',name ',slot ,i))))))
+ slotdescs))
+ ,@(oclosure--defstruct-make-copiers
+ copiers slotdescs name))))
+
+(defun oclosure--define (name docstring parent-names slots
+ &rest props)
+ (let* ((class (oclosure--build-class name docstring parent-names slots))
+ (pred (lambda (oclosure)
+ (eq name (oclosure-type oclosure))))
+ (predname (or (plist-get props :predicate)
+ (intern (format "%s--internal-p" name)))))
+ (setf (cl--find-class name) class)
+ (dolist (slot (oclosure--class-slots class))
+ (put (cl--slot-descriptor-name slot) 'slot-name t))
+ (defalias predname pred)
+ (put name 'cl-deftype-satisfies predname)))
+
+(defmacro oclosure--lambda (type bindings mutables args &rest body)
+ "Low level construction of an OClosure object.
+TYPE should be a form returning an OClosure type (a symbol)
+BINDINGS should list all the slots expected by this type, in the proper order.
+MUTABLE is a list of symbols indicating which of the BINDINGS
+should be mutable.
+No checking is performed,"
+ (declare (indent 3) (debug (sexp (&rest (sexp form)) sexp def-body)))
+ ;; FIXME: Fundamentally `oclosure-lambda' should be a special form.
+ ;; We define it here as a macro which expands to something that
+ ;; looks like "normal code" in order to avoid backward compatibility
+ ;; issues with third party macros that do "code walks" and would
+ ;; likely mishandle such a new special form (e.g. `generator.el').
+ ;; But don't be fooled: this macro is tightly bound to `cconv.el'.
+ (pcase-let*
+ ((`(,prebody . ,body) (macroexp-parse-body body))
+ (rovars (mapcar #'car bindings)))
+ (dolist (mutable mutables)
+ (setq rovars (delq mutable rovars)))
+ `(let ,(mapcar (lambda (bind)
+ (if (cdr bind) bind
+ ;; Bind to something that doesn't look
+ ;; like a value to avoid the "Variable
+ ;; ‘foo’ left uninitialized" warning.
+ `(,(car bind) (progn nil))))
+ (reverse bindings))
+ ;; FIXME: Make sure the slotbinds whose value is duplicable aren't
+ ;; just value/variable-propagated by the optimizer (tho I think our
+ ;; optimizer is too naive to be a problem currently).
+ (oclosure--fix-type
+ ;; This `oclosure--fix-type' + `ignore' call is used by the compiler
(in
+ ;; `cconv.el') to detect and signal an error in case of
+ ;; store-conversion (i.e. if a variable/slot is mutated).
+ (ignore ,@rovars)
+ (lambda ,args
+ (:documentation ,type)
+ ,@prebody
+ ;; Add dummy code which accesses the field's vars to make sure
+ ;; they're captured in the closure.
+ (if t nil ,@rovars ,@(mapcar (lambda (m) `(setq ,m ,m)) mutables))
+ ,@body)))))
+
+(defmacro oclosure-lambda (type-and-slots args &rest body)
+ "Define anonymous OClosure function.
+TYPE-AND-SLOTS should be of the form (TYPE . SLOTS)
+where TYPE is an OClosure type name (defined by `oclosure-define')
+and SLOTS is a let-style list of bindings for the various slots of TYPE.
+ARGS and BODY are the same as for `lambda'."
+ (declare (indent 2) (debug ((sexp &rest (sexp form)) sexp def-body)))
+ ;; FIXME: Should `oclosure-define' distinguish "optional" from
+ ;; "mandatory" slots, and/or provide default values for slots missing
+ ;; from `fields'?
+ (pcase-let*
+ ((`(,type . ,fields) type-and-slots)
+ (class (or (cl--find-class type)
+ (error "Unknown class: %S" type)))
+ (slots (oclosure--class-slots class))
+ (mutables '())
+ (slotbinds (mapcar (lambda (slot)
+ (let ((name (cl--slot-descriptor-name slot)))
+ (when (oclosure--slot-mutable-p slot)
+ (push name mutables))
+ (list name)))
+ slots))
+ (tempbinds (mapcar
+ (lambda (field)
+ (let* ((name (car field))
+ (bind (assq name slotbinds)))
+ (cond
+ ;; FIXME: Should we also warn about missing slots?
+ ((not bind)
+ (error "Unknown slot: %S" name))
+ ((cdr bind)
+ (error "Duplicate slot: %S" name))
+ (t
+ (let ((temp (gensym "temp")))
+ (setcdr bind (list temp))
+ (cons temp (cdr field)))))))
+ fields)))
+ ;; FIXME: Optimize temps away when they're provided in the right order?
+ `(let ,tempbinds
+ (oclosure--lambda ',type ,slotbinds ,mutables ,args ,@body))))
+
+(defun oclosure--fix-type (_ignore oclosure)
+ "Helper function to implement `oclosure-lambda' via a macro.
+This has 2 uses:
+- For interpreted code, this converts the representation of type information
+ by moving it from the docstring to the environment.
+- For compiled code, this is used as a marker which cconv uses to check that
+ immutable fields are indeed not mutated."
+ (if (byte-code-function-p oclosure)
+ ;; Actually, this should never happen since the `cconv.el' should have
+ ;; optimized away the call to this function.
+ oclosure
+ ;; For byte-coded functions, we store the type as a symbol in the docstring
+ ;; slot. For interpreted functions, there's no specific docstring slot
+ ;; so `Ffunction' turns the symbol into a string.
+ ;; We thus have convert it back into a symbol (via `intern') and then
+ ;; stuff it into the environment part of the closure with a special
+ ;; marker so we can distinguish this entry from actual variables.
+ (cl-assert (eq 'closure (car-safe oclosure)))
+ (let ((typename (nth 3 oclosure))) ;; The "docstring".
+ (cl-assert (stringp typename))
+ (push (cons :type (intern typename))
+ (cadr oclosure))
+ oclosure)))
+
+(defun oclosure--copy (oclosure mutlist &rest args)
+ (if (byte-code-function-p oclosure)
+ (apply #'make-closure oclosure
+ (if (null mutlist)
+ args
+ (mapcar (lambda (arg) (if (pop mutlist) (list arg) arg)) args)))
+ (cl-assert (eq 'closure (car-safe oclosure))
+ nil "oclosure not closure: %S" oclosure)
+ (cl-assert (eq :type (caar (cadr oclosure))))
+ (let ((env (cadr oclosure)))
+ `(closure
+ (,(car env)
+ ,@(named-let loop ((env (cdr env)) (args args))
+ (when args
+ (cons (cons (caar env) (car args))
+ (loop (cdr env) (cdr args)))))
+ ,@(nthcdr (1+ (length args)) env))
+ ,@(nthcdr 2 oclosure)))))
+
+(defun oclosure--get (oclosure index mutable)
+ (if (byte-code-function-p oclosure)
+ (let* ((csts (aref oclosure 2))
+ (v (aref csts index)))
+ (if mutable (car v) v))
+ (cl-assert (eq 'closure (car-safe oclosure)))
+ (cl-assert (eq :type (caar (cadr oclosure))))
+ (cdr (nth (1+ index) (cadr oclosure)))))
+
+(defun oclosure--set (v oclosure index)
+ (if (byte-code-function-p oclosure)
+ (let* ((csts (aref oclosure 2))
+ (cell (aref csts index)))
+ (setcar cell v))
+ (cl-assert (eq 'closure (car-safe oclosure)))
+ (cl-assert (eq :type (caar (cadr oclosure))))
+ (setcdr (nth (1+ index) (cadr oclosure)) v)))
+
+(defun oclosure-type (oclosure)
+ "Return the type of OCLOSURE, or nil if the arg is not a OClosure."
+ (if (byte-code-function-p oclosure)
+ (let ((type (and (> (length oclosure) 4) (aref oclosure 4))))
+ (if (symbolp type) type))
+ (and (eq 'closure (car-safe oclosure))
+ (let* ((env (car-safe (cdr oclosure)))
+ (first-var (car-safe env)))
+ (and (eq :type (car-safe first-var))
+ (cdr first-var))))))
+
+(defconst oclosure--accessor-prototype
+ ;; Use `oclosure--lambda' to circumvent a bootstrapping problem:
+ ;; `oclosure-accessor' is not yet defined at this point but
+ ;; `oclosure--accessor-prototype' is needed when defining
`oclosure-accessor'.
+ (oclosure--lambda 'oclosure-accessor ((type) (slot) (index)) nil
+ (oclosure) (oclosure--get oclosure index nil)))
+
+(oclosure-define accessor
+ "OClosure function to access a specific slot of an object."
+ type slot)
+
+(oclosure-define (oclosure-accessor
+ (:parent accessor)
+ (:copier oclosure--accessor-copy (type slot index)))
+ "OClosure function to access a specific slot of an OClosure function."
+ index)
+
+(defconst oclosure--mut-getter-prototype
+ (oclosure-lambda (oclosure-accessor (type) (slot) (index)) (oclosure)
+ (oclosure--get oclosure index t)))
+(defconst oclosure--mut-setter-prototype
+ ;; FIXME: The generated docstring is wrong.
+ (oclosure-lambda (oclosure-accessor (type) (slot) (index)) (val oclosure)
+ (oclosure--set val oclosure index)))
+
+;; Ideally, this should be in `files.el', but that file is loaded
+;; before `oclosure.el'.
+(oclosure-define (save-some-buffers-function
+ (:predicate save-some-buffers-function--p)))
+
+
+(provide 'oclosure)
+;;; oclosure.el ends here
diff --git a/src/doc.c b/src/doc.c
index a9f77b25bfa..e361a86c1a1 100644
--- a/src/doc.c
+++ b/src/doc.c
@@ -514,11 +514,19 @@ store_function_docstring (Lisp_Object obj, EMACS_INT
offset)
{
/* This bytecode object must have a slot for the
docstring, since we've found a docstring for it. */
- if (PVSIZE (fun) > COMPILED_DOC_STRING)
+ 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))))
ASET (fun, COMPILED_DOC_STRING, make_fixnum (offset));
else
{
- AUTO_STRING (format, "No docstring slot for %s");
+ AUTO_STRING (format,
+ (PVSIZE (fun) > COMPILED_DOC_STRING
+ ? "Docstring slot busy for %s"
+ : "No docstring slot for %s"));
CALLN (Fmessage, format,
(SYMBOLP (obj)
? SYMBOL_NAME (obj)
diff --git a/src/eval.c b/src/eval.c
index c46b74ac40c..842746da048 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -559,6 +559,10 @@ DEFUN ("function", Ffunction, Sfunction, 1, UNEVALLED, 0,
{ /* Handle the special (:documentation <form>) to build the docstring
dynamically. */
Lisp_Object docstring = eval_sub (Fcar (XCDR (tmp)));
+ if (SYMBOLP (docstring) && !NILP (docstring))
+ /* Hack for OClosures: Allow the docstring to be a symbol
+ * (the OClosure's type). */
+ docstring = Fsymbol_name (docstring);
CHECK_STRING (docstring);
cdr = Fcons (XCAR (cdr), Fcons (docstring, XCDR (XCDR (cdr))));
}
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 <https://www.gnu.org/licenses/>.
+
+;;; 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.
- bug#54456: 29.0.50; Add OClosures,
Stefan Monnier <=