* 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.
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 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{(:copier @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
--- /dev/null
+;;; 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
projects / emacs.git / commitdiff