(i 0)
(new-env ()))
;; Build the "formal and actual envs" for the closure-converted function.
- ;; Hack for FCR: `nreverse' here intends to put the captured vars
+ ;; 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))
(`(declare . ,_) form) ;The args don't contain code.
- (`(fcr--fix-type (ignore . ,vars) ,exp)
+ (`(oclosure--fix-type (ignore . ,vars) ,exp)
(dolist (var vars)
(let ((x (assq var env)))
(pcase (cdr x)
(list (cl--generic-name generic)))
f))))
-(fcr-defstruct cl--generic-nnm
+(oclosure-define cl--generic-nnm
"Special type for `call-next-method's that just call `no-next-method'.")
(defun cl-generic-call-method (generic method &optional fun)
(if fun
(lambda (&rest cnm-args)
(apply fun (or cnm-args args)))
- (fcr-lambda (cl--generic-nnm) (&rest cnm-args)
+ (oclosure-lambda (cl--generic-nnm) (&rest cnm-args)
(apply #'cl-no-next-method generic method
(or cnm-args args))))
args)))))
(defun cl--generic-isnot-nnm-p (cnm)
"Return non-nil if CNM is the function that calls `cl-no-next-method'."
- (not (eq (fcr-type cnm) 'cl--generic-nnm)))
+ (not (eq (oclosure-type cnm) 'cl--generic-nnm)))
;;; Define some pre-defined generic functions, used internally.
(progn (cl-assert (null modes)) mode)
`(derived-mode ,mode . ,modes))))
-;;; Dispatch on FCR type
+;;; Dispatch on OClosure type
-;; It would make sense to put this into `fcr.el' except that when
-;; `fcr.el' is loaded `cl-defmethod' is not available yet.
+;; 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-fcr-tag (name &rest _)
- `(fcr-type ,name))
+(defun cl--generic-oclosure-tag (name &rest _)
+ `(oclosure-type ,name))
-(defun cl-generic--fcr-specializers (tag &rest _)
+(defun cl-generic--oclosure-specializers (tag &rest _)
(and (symbolp tag)
(let ((class (cl--find-class tag)))
- (when (cl-typep class 'fcr--class)
+ (when (cl-typep class 'oclosure--class)
(cl--class-allparents class)))))
-(cl-generic-define-generalizer cl-generic--fcr-generalizer
+(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 FCRs,
- ;; we first try `fcr-type' before `type-of' since `type-of' will return
- ;; non-nil for an FCR as well.
- 51 #'cl--generic-fcr-tag
- #'cl-generic--fcr-specializers)
-
-(cl-defmethod cl-generic-generalizers :extra "fcr-struct" (type)
- "Support for dispatch on types defined by `fcr-defstruct'."
+ ;; 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 'fcr--class)
- (list cl-generic--fcr-generalizer))))
+ (and (cl-typep class 'oclosure--class)
+ (list cl-generic--oclosure-generalizer))))
(cl-call-next-method)))
-(cl--generic-prefill-dispatchers 0 fcr-object)
+(cl--generic-prefill-dispatchers 0 oclosure-object)
;;; Support for unloading.
'byte-code-function object)))))
(princ ")" stream))
-;; This belongs in fcr.el, of course, but some load-ordering issues make it
+;; This belongs in oclosure.el, of course, but some load-ordering issues make it
;; complicated.
(cl-defmethod cl-print-object ((object accessor) stream)
;; FIXME: η-reduce!
- (fcr--accessor-cl-print object stream))
+ (oclosure--accessor-cl-print object stream))
(cl-defmethod cl-print-object ((object cl-structure-object) stream)
(if (and cl-print--depth (natnump print-level)
+++ /dev/null
-;;; fcr.el --- FunCallableRecords -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2015, 2021 Stefan Monnier
-
-;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Version: 0
-
-;; 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:
-
-;; A FunCallableRecord 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.
-
-;; Here are some cases of "callable objects" where FCRs are used:
-;; - nadvice.el
-;; - 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).
-;; - FCR accessor functions, where the type-dispatch is used to
-;; dynamically compute the docstring, and also to pretty them.
-;; Here are other cases of "callable objects" where FCRs could be used:
-;; - 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)!
-;; - documented functions: this could be a subtype of normal functions, which
-;; simply has an additional `docstring' slot.
-;; - commands: this could be a subtype of documented functions, which simply
-;; has an additional `interactive-form' slot.
-;; - 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 f) generally returns (lambda (x) (not (f x)))
-;; but it can optimize (negate (negate f)) to f and (negate #'<) to
-;; #'>=.
-;; - Autoloads (tho currently our bytecode functions (and hence FCRs)
-;; are too fat for that).
-
-;; Related constructs:
-;; - `funcallable-standard-object' (FSO) in Common-Lisp. These are different
-;; from FCRs 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 FCRs 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 FCRs (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
-;; FCR object comes with its own code, so two FCR objects of the
-;; same type can have different code. Of course, you can get the
-;; same result by turning every `fcr-lambda' into its own class
-;; declaration creating an ad-hoc subclass of the specified type.
-;; In this sense, FCRs 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 FCRs.
-;; - "entities" in Lisp Machine Lisp (LML)
-;; https://hanshuebner.github.io/lmman/fd-clo.xml
-;; These are arguably identical to FCRs, 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: to replace "FCR" we could go with
-;; - open closures
-;; - disclosures
-;; - opening
-;; - object functions/closures
-;; - structured functions/closures (strunctions, strufs)
-;; - slotfuns (slotted functions)
-
-;;; Code:
-
-;; Slots are currently immutable, tho they can be updated functionally
-;; via the "copiers": we could relax this restriction by either allowing
-;; the function itself to mutate the captured variable/slot or by providing
-;; `setf' accessors to the slots (or both), but this comes with some problems:
-;; - mutation from within the function currently would cause cconv
-;; to perform store-conversion on the variable, so we'd either have
-;; to prevent cconv from doing it (which might require a new bytecode op
-;; to update the in-closure variable), or we'd have to keep track of which
-;; slots have been store-converted so `fcr--get' can access their value
-;; correctly.
-;; - If the mutated variable/slot is captured by another (nested) closure
-;; store-conversion is indispensable, so if we want to avoid store-conversion
-;; we'd have to disallow such capture.
-
-;; TODO:
-;; - `fcr-cl-defun', `fcr-cl-defsubst', `fcr-defsubst', `fcr-define-inline'?
-;; - Use accessor in cl-defstruct
-;; - Add pcase patterns for FCRs.
-
-(eval-when-compile (require 'cl-lib))
-(eval-when-compile (require 'subr-x)) ;For `named-let'.
-
-(cl-defstruct (fcr--class
- (:constructor nil)
- (:constructor fcr--class-make ( name docstring slots parents
- allparents))
- (:include cl--class)
- (:copier nil))
- "Metaclass for FunCallableRecord classes."
- (allparents nil :read-only t :type (list-of symbol)))
-
-(setf (cl--find-class 'fcr-object)
- (fcr--class-make 'fcr-object "The root parent of all FCR classes"
- nil nil '(fcr-object)))
-(defun fcr--object-p (fcr)
- (let ((type (fcr-type fcr)))
- (when type
- (memq 'fcr-object (fcr--class-allparents (cl--find-class type))))))
-(cl-deftype fcr-object () '(satisfies fcr--object-p))
-
-(defun fcr--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)))
- (unless (alist-get :read-only
- (cl--slot-descriptor-props desc))
- (push name mutables))
- name))
- slotdescs)))
- (mapcar
- (lambda (copier)
- (pcase-let*
- ((cname (pop copier))
- (args (or (pop copier) `(&key ,@slots)))
- (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 `(fcr--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)))
- `(cl-defun ,cname (&cl-defs (',absent) ,obj ,@args)
- ,doc
- (declare (side-effect-free t))
- (fcr--copy ,obj ',(if (remq nil mutlist) (nreverse mutlist))
- ,@argvals))))
- copiers)))
-
-(defmacro fcr-defstruct (name &optional docstring &rest slots)
- (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))))))
-
- (parent-names (or (or (funcall get-opt :parent)
- (funcall get-opt :include))
- '(fcr-object)))
- (copiers (funcall get-opt :copier 'all))
-
- (parent-slots '())
- (parents
- (mapcar
- (lambda (name)
- (let* ((class (or (cl--find-class name)
- (error "Unknown parent: %S" name))))
- (setq parent-slots
- (named-let merge
- ((slots-a parent-slots)
- (slots-b (cl--class-slots class)))
- (cond
- ((null slots-a) slots-b)
- ((null slots-b) slots-a)
- (t
- (let ((sa (car slots-a))
- (sb (car slots-b)))
- (unless (equal sa sb)
- (error "Slot %s of %s conflicts with slot %s of previous parent"
- (cl--slot-descriptor-name sb)
- name
- (cl--slot-descriptor-name sa)))
- (cons sa (merge (cdr slots-a) (cdr slots-b))))))))
- class))
- parent-names))
- (slotdescs
- (append
- parent-slots
- (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)))
- (allparents (apply #'append (mapcar #'cl--class-allparents
- parents)))
- (class (fcr--class-make name docstring slotdescs parents
- (delete-dups
- (cons name allparents))))
- (it (make-hash-table :test #'eq)))
- (setf (cl--class-index-table class) it)
- `(progn
- ,(when options (macroexp-warn-and-return
- (format "Ignored options: %S" options)
- nil))
- (eval-and-compile
- (fcr--define ',class
- (lambda (fcr)
- (let ((type (fcr-type fcr)))
- (when type
- (memq ',name (fcr--class-allparents
- (cl--find-class type))))))))
- ,@(let ((i -1))
- (mapcar (lambda (desc)
- (let* ((slot (cl--slot-descriptor-name desc))
- (mutable
- (not (alist-get :read-only
- (cl--slot-descriptor-props desc))))
- ;; Always use a double hyphen: if users wants to
- ;; make it public, they can do so with an alias.
- (name (intern (format "%S--%S" name slot))))
- (cl-incf i)
- (when (gethash slot it)
- (error "Duplicate slot name: %S" slot))
- (setf (gethash slot it) i)
- (if (not mutable)
- `(defalias ',name
- ;; We use `fcr--copy' instead of
- ;; `fcr--accessor-copy' here to circumvent
- ;; bootstrapping problems.
- (fcr--copy fcr--accessor-prototype nil
- ',name ',slot ,i))
- `(progn
- (defalias ',name
- (fcr--accessor-copy
- fcr--mut-getter-prototype
- ',name ',slot ,i))
- (defalias ',(gv-setter name)
- (fcr--accessor-copy
- fcr--mut-setter-prototype
- ',name ',slot ,i))))))
- slotdescs))
- ,@(fcr--defstruct-make-copiers
- copiers slotdescs name))))
-
-(defun fcr--define (class pred)
- (let* ((name (cl--class-name class))
- (predname (intern (format "fcr--%s-p" name))))
- (setf (cl--find-class name) class)
- (defalias predname pred)
- (put name 'cl-deftype-satisfies predname)))
-
-(defmacro fcr--lambda (type bindings mutables args &rest body)
- "Low level construction of an FCR object.
-TYPE is expected to be a symbol that is (or will be) defined as an FCR type.
-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 `fcr-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*
- ;; FIXME: Since we use the docstring internally to store the
- ;; type we can't handle actual docstrings. We could fix this by adding
- ;; a docstring slot to FCRs.
- ((`(,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).
- (fcr--fix-type
- ;; This `fcr--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 fcr-lambda (type-and-slots args &rest body)
- "Define anonymous FCR function.
-TYPE-AND-SLOTS should be of the form (TYPE . SLOTS)
-where TYPE is an FCR type name 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 `fcr-defstruct' distinguish "optional" from
- ;; "mandatory" slots, and/or provide default values for slots missing
- ;; from `fields'?
- (pcase-let*
- ((`(,type . ,fields) type-and-slots)
- (class (cl--find-class type))
- (slots (fcr--class-slots class))
- (mutables '())
- (slotbinds (mapcar (lambda (slot)
- (let ((name (cl--slot-descriptor-name slot))
- (props (cl--slot-descriptor-props slot)))
- (unless (alist-get :read-only props)
- (push name mutables))
- (list name)))
- slots))
- (tempbinds (mapcar
- (lambda (field)
- (let* ((name (car field))
- (bind (assq name slotbinds)))
- (cond
- ((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
- (fcr--lambda ,type ,slotbinds ,mutables ,args ,@body))))
-
-(defun fcr--fix-type (_ignore fcr)
- (if (byte-code-function-p fcr)
- ;; Actually, this should never happen since the `cconv.el' should have
- ;; optimized away the call to this function.
- fcr
- ;; 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 fcr)))
- (let ((typename (nth 3 fcr))) ;; The "docstring".
- (cl-assert (stringp typename))
- (push (cons :type (intern typename))
- (cadr fcr))
- fcr)))
-
-(defun fcr--copy (fcr mutlist &rest args)
- (if (byte-code-function-p fcr)
- (apply #'make-closure fcr
- (if (null mutlist)
- args
- (mapcar (lambda (arg) (if (pop mutlist) (list arg) arg)) args)))
- (cl-assert (eq 'closure (car-safe fcr)))
- (cl-assert (eq :type (caar (cadr fcr))))
- (let ((env (cadr fcr)))
- `(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 fcr)))))
-
-(defun fcr--get (fcr index mutable)
- (if (byte-code-function-p fcr)
- (let* ((csts (aref fcr 2))
- (v (aref csts index)))
- (if mutable (car v) v))
- (cl-assert (eq 'closure (car-safe fcr)))
- (cl-assert (eq :type (caar (cadr fcr))))
- (cdr (nth (1+ index) (cadr fcr)))))
-
-(defun fcr--set (v fcr index)
- (if (byte-code-function-p fcr)
- (let* ((csts (aref fcr 2))
- (cell (aref csts index)))
- (setcar cell v))
- (cl-assert (eq 'closure (car-safe fcr)))
- (cl-assert (eq :type (caar (cadr fcr))))
- (setcdr (nth (1+ index) (cadr fcr)) v)))
-
-(defun fcr-type (fcr)
- "Return the type of FCR, or nil if the arg is not a FunCallableRecord."
- (if (byte-code-function-p fcr)
- (let ((type (and (> (length fcr) 4) (aref fcr 4))))
- (if (symbolp type) type))
- (and (eq 'closure (car-safe fcr))
- (let* ((env (car-safe (cdr fcr)))
- (first-var (car-safe env)))
- (and (eq :type (car-safe first-var))
- (cdr first-var))))))
-
-(defconst fcr--accessor-prototype
- ;; Use `fcr--lambda' to circumvent a bootstrapping problem:
- ;; `fcr-accessor' is not yet defined at this point but
- ;; `fcr--accessor-prototype' is needed when defining `fcr-accessor'.
- (fcr--lambda fcr-accessor ((type) (slot) (index)) nil
- (fcr) (fcr--get fcr index nil)))
-
-(fcr-defstruct accessor
- "FCR function to access a specific slot of an object."
- type slot)
-
-(defun fcr--accessor-cl-print (object stream)
- (princ "#f(accessor " stream)
- (prin1 (accessor--type object) stream)
- (princ "." stream)
- (prin1 (accessor--slot object) stream)
- (princ ")" stream))
-
-(defun fcr--accessor-docstring (f)
- (format "Access slot \"%S\" of OBJ of type `%S'.
-
-\(fn OBJ)"
- (accessor--slot f) (accessor--type f)))
-
-(fcr-defstruct (fcr-accessor
- (:parent accessor)
- (:copier fcr--accessor-copy (type slot index)))
- "FCR function to access a specific slot of an FCR function."
- index)
-
-(defconst fcr--mut-getter-prototype
- (fcr-lambda (fcr-accessor (type) (slot) (index)) (fcr)
- (fcr--get fcr index t)))
-(defconst fcr--mut-setter-prototype
- ;; FIXME: The generated docstring is wrong.
- (fcr-lambda (fcr-accessor (type) (slot) (index)) (val fcr)
- (fcr--set val fcr index)))
-
-(provide 'fcr)
-;;; fcr.el ends here
;; as this one), so we have to do it by hand!
(push (purecopy '(nadvice 1 0)) package--builtin-versions)
-(fcr-defstruct (advice
+(oclosure-define (advice
(:copier advice--cons (cdr))
(:copier advice--copy (car cdr where props)))
car cdr where props)
;;;; Lightweight advice/hook
(defvar advice--where-alist
- `((:around ,(fcr-lambda (advice (where :around)) (&rest args)
+ `((:around ,(oclosure-lambda (advice (where :around)) (&rest args)
(apply car cdr args)))
- (:before ,(fcr-lambda (advice (where :before)) (&rest args)
+ (:before ,(oclosure-lambda (advice (where :before)) (&rest args)
(apply car args) (apply cdr args)))
- (:after ,(fcr-lambda (advice (where :after)) (&rest args)
+ (:after ,(oclosure-lambda (advice (where :after)) (&rest args)
(apply cdr args) (apply car args)))
- (:override ,(fcr-lambda (advice (where :override)) (&rest args)
+ (:override ,(oclosure-lambda (advice (where :override)) (&rest args)
(apply car args)))
- (:after-until ,(fcr-lambda (advice (where :after-until)) (&rest args)
+ (:after-until ,(oclosure-lambda (advice (where :after-until)) (&rest args)
(or (apply cdr args) (apply car args))))
- (:after-while ,(fcr-lambda (advice (where :after-while)) (&rest args)
+ (:after-while ,(oclosure-lambda (advice (where :after-while)) (&rest args)
(and (apply cdr args) (apply car args))))
- (:before-until ,(fcr-lambda (advice (where :before-until)) (&rest args)
+ (:before-until ,(oclosure-lambda (advice (where :before-until)) (&rest args)
(or (apply car args) (apply cdr args))))
- (:before-while ,(fcr-lambda (advice (where :before-while)) (&rest args)
+ (:before-while ,(oclosure-lambda (advice (where :before-while)) (&rest args)
(and (apply car args) (apply cdr args))))
- (:filter-args ,(fcr-lambda (advice (where :filter-args)) (&rest args)
+ (:filter-args ,(oclosure-lambda (advice (where :filter-args)) (&rest args)
(apply cdr (funcall car args))))
- (:filter-return ,(fcr-lambda (advice (where :filter-return)) (&rest args)
+ (:filter-return ,(oclosure-lambda (advice (where :filter-return)) (&rest args)
(funcall car (apply cdr args)))))
"List of descriptions of how to add a function.
-Each element has the form (WHERE FCR) where FCR is a \"prototype\"
+Each element has the form (WHERE OCL) where OCL is a \"prototype\"
function of type `advice'.")
(defun advice--p (object)
- ;; (eq (fcr-type object) 'advice)
+ ;; (eq (oclosure-type object) 'advice)
(cl-typep object 'advice))
(defun advice--cd*r (f)
--- /dev/null
+;;; oclosure.el --- Open Closures -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2015, 2021 Stefan Monnier
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Version: 0
+
+;; 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:
+
+;; A 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.
+
+;; Here are some cases of "callable objects" where OClosures are used:
+;; - nadvice.el
+;; - 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).
+;; - OClosure accessor functions, where the type-dispatch is used to
+;; dynamically compute the docstring, and also to pretty them.
+;; Here are other cases of "callable objects" where OClosures could be used:
+;; - 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)!
+;; - documented functions: this could be a subtype of normal functions, which
+;; simply has an additional `docstring' slot.
+;; - commands: this could be a subtype of documented functions, which simply
+;; has an additional `interactive-form' slot.
+;; - 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 f) generally returns (lambda (x) (not (f x)))
+;; but it can optimize (negate (negate f)) to f and (negate #'<) to
+;; #'>=.
+;; - 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: to replace "OClosure" we could go with
+;; - open closures
+;; - disclosures
+;; - opening
+;; - object functions/closures
+;; - structured functions/closures (strunctions, strufs)
+;; - slotfuns (slotted functions)
+
+;;; Code:
+
+;; Slots are currently immutable, tho they can be updated functionally
+;; via the "copiers": we could relax this restriction by either allowing
+;; the function itself to mutate the captured variable/slot or by providing
+;; `setf' accessors to the slots (or both), but this comes with some problems:
+;; - mutation from within the function currently would cause cconv
+;; to perform store-conversion on the variable, so we'd either have
+;; to prevent cconv from doing it (which might require a new bytecode op
+;; to update the in-closure variable), or we'd have to keep track of which
+;; slots have been store-converted so `oclosure--get' can access their value
+;; correctly.
+;; - If the mutated variable/slot is captured by another (nested) closure
+;; store-conversion is indispensable, so if we want to avoid store-conversion
+;; we'd have to disallow such capture.
+
+;; TODO:
+;; - `oclosure-cl-defun', `oclosure-cl-defsubst', `oclosure-defsubst', `oclosure-define-inline'?
+;; - Use accessor in cl-defstruct
+;; - Add pcase patterns for OClosures.
+
+(eval-when-compile (require 'cl-lib))
+(eval-when-compile (require 'subr-x)) ;For `named-let'.
+
+(cl-defstruct (oclosure--class
+ (:constructor nil)
+ (:constructor oclosure--class-make ( name docstring slots parents
+ allparents))
+ (:include cl--class)
+ (:copier nil))
+ "Metaclass for OClosure classes."
+ (allparents nil :read-only t :type (list-of symbol)))
+
+(setf (cl--find-class 'oclosure-object)
+ (oclosure--class-make 'oclosure-object "The root parent of all OClosure classes"
+ nil nil '(oclosure-object)))
+(defun oclosure--object-p (oclosure)
+ (let ((type (oclosure-type oclosure)))
+ (when type
+ (memq 'oclosure-object (oclosure--class-allparents (cl--find-class type))))))
+(cl-deftype oclosure-object () '(satisfies oclosure--object-p))
+
+(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)))
+ (unless (alist-get :read-only
+ (cl--slot-descriptor-props desc))
+ (push name mutables))
+ name))
+ slotdescs)))
+ (mapcar
+ (lambda (copier)
+ (pcase-let*
+ ((cname (pop copier))
+ (args (or (pop copier) `(&key ,@slots)))
+ (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)))
+ `(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)
+ (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))))))
+
+ (parent-names (or (or (funcall get-opt :parent)
+ (funcall get-opt :include))
+ '(oclosure-object)))
+ (copiers (funcall get-opt :copier 'all))
+
+ (parent-slots '())
+ (parents
+ (mapcar
+ (lambda (name)
+ (let* ((class (or (cl--find-class name)
+ (error "Unknown parent: %S" name))))
+ (setq parent-slots
+ (named-let merge
+ ((slots-a parent-slots)
+ (slots-b (cl--class-slots class)))
+ (cond
+ ((null slots-a) slots-b)
+ ((null slots-b) slots-a)
+ (t
+ (let ((sa (car slots-a))
+ (sb (car slots-b)))
+ (unless (equal sa sb)
+ (error "Slot %s of %s conflicts with slot %s of previous parent"
+ (cl--slot-descriptor-name sb)
+ name
+ (cl--slot-descriptor-name sa)))
+ (cons sa (merge (cdr slots-a) (cdr slots-b))))))))
+ class))
+ parent-names))
+ (slotdescs
+ (append
+ parent-slots
+ (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)))
+ (allparents (apply #'append (mapcar #'cl--class-allparents
+ parents)))
+ (class (oclosure--class-make name docstring slotdescs parents
+ (delete-dups
+ (cons name allparents))))
+ (it (make-hash-table :test #'eq)))
+ (setf (cl--class-index-table class) it)
+ `(progn
+ ,(when options (macroexp-warn-and-return
+ (format "Ignored options: %S" options)
+ nil))
+ (eval-and-compile
+ (oclosure--define ',class
+ (lambda (oclosure)
+ (let ((type (oclosure-type oclosure)))
+ (when type
+ (memq ',name (oclosure--class-allparents
+ (cl--find-class type))))))))
+ ,@(let ((i -1))
+ (mapcar (lambda (desc)
+ (let* ((slot (cl--slot-descriptor-name desc))
+ (mutable
+ (not (alist-get :read-only
+ (cl--slot-descriptor-props desc))))
+ ;; Always use a double hyphen: if users wants to
+ ;; make it public, they can do so with an alias.
+ (name (intern (format "%S--%S" name slot))))
+ (cl-incf i)
+ (when (gethash slot it)
+ (error "Duplicate slot name: %S" slot))
+ (setf (gethash slot it) i)
+ (if (not mutable)
+ `(defalias ',name
+ ;; We use `oclosure--copy' instead of
+ ;; `oclosure--accessor-copy' here to circumvent
+ ;; bootstrapping problems.
+ (oclosure--copy oclosure--accessor-prototype nil
+ ',name ',slot ,i))
+ `(progn
+ (defalias ',name
+ (oclosure--accessor-copy
+ oclosure--mut-getter-prototype
+ ',name ',slot ,i))
+ (defalias ',(gv-setter name)
+ (oclosure--accessor-copy
+ oclosure--mut-setter-prototype
+ ',name ',slot ,i))))))
+ slotdescs))
+ ,@(oclosure--defstruct-make-copiers
+ copiers slotdescs name))))
+
+(defun oclosure--define (class pred)
+ (let* ((name (cl--class-name class))
+ (predname (intern (format "oclosure--%s-p" name))))
+ (setf (cl--find-class name) class)
+ (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 is expected to be a symbol that is (or will be) defined as an OClosure type.
+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*
+ ;; FIXME: Since we use the docstring internally to store the
+ ;; type we can't handle actual docstrings. We could fix this by adding
+ ;; a docstring slot to OClosures.
+ ((`(,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 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 (cl--find-class type))
+ (slots (oclosure--class-slots class))
+ (mutables '())
+ (slotbinds (mapcar (lambda (slot)
+ (let ((name (cl--slot-descriptor-name slot))
+ (props (cl--slot-descriptor-props slot)))
+ (unless (alist-get :read-only props)
+ (push name mutables))
+ (list name)))
+ slots))
+ (tempbinds (mapcar
+ (lambda (field)
+ (let* ((name (car field))
+ (bind (assq name slotbinds)))
+ (cond
+ ((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)
+ (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)))
+ (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)
+
+(defun oclosure--accessor-cl-print (object stream)
+ (princ "#f(accessor " stream)
+ (prin1 (accessor--type object) stream)
+ (princ "." stream)
+ (prin1 (accessor--slot object) stream)
+ (princ ")" stream))
+
+(defun oclosure--accessor-docstring (f)
+ (format "Access slot \"%S\" of OBJ of type `%S'.
+
+\(fn OBJ)"
+ (accessor--slot f) (accessor--type f)))
+
+(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)))
+
+(provide 'oclosure)
+;;; oclosure.el ends here
;;; Keyboard macro ring
-(fcr-defstruct kmacro
+(oclosure-define kmacro
"Keyboard macro."
keys (counter :mutable t) format)
;;;###autoload
(defun kmacro (keys &optional counter format)
"Create a `kmacro' for macro bound to symbol or key."
- (fcr-lambda (kmacro (keys (if (stringp keys) (key-parse keys) keys))
+ (oclosure-lambda (kmacro (keys (if (stringp keys) (key-parse keys) keys))
(counter (or counter 0))
(format (or format "%d")))
(&optional arg)
(load "button") ;After loaddefs, because of define-minor-mode!
(load "emacs-lisp/cl-preloaded")
-(load "emacs-lisp/fcr") ;Used by cl-generic and nadvice
+(load "emacs-lisp/oclosure") ;Used by cl-generic and nadvice
(load "obarray") ;abbrev.el is implemented in terms of obarrays.
(load "abbrev") ;lisp-mode.el and simple.el use define-abbrev-table.
(load "help")
(cl-defmethod function-docstring ((function accessor))
;; FIXME: η-reduce!
- (fcr--accessor-docstring function))
+ (oclosure--accessor-docstring function))
(cl-defgeneric interactive-form (cmd &optional original-name)
"Return the interactive form of CMD or nil if none.
+++ /dev/null
-;;; fcr-tests.e; --- Tests for FunCallableRecords -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2021 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 'fcr)
-(require 'cl-lib)
-
-(fcr-defstruct (fcr-test
- (:copier fcr-test-copy)
- (:copier fcr-test-copy1 (fst)))
- "Simple FCR."
- fst snd name)
-
-(cl-defmethod fcr-test-gen ((_x compiled-function)) "#<bytecode>")
-
-(cl-defmethod fcr-test-gen ((_x cons)) "#<cons>")
-
-(cl-defmethod fcr-test-gen ((_x fcr-object))
- (format "#<fcr:%s>" (cl-call-next-method)))
-
-(cl-defmethod fcr-test-gen ((_x fcr-test))
- (format "#<fcr-test:%s>" (cl-call-next-method)))
-
-(ert-deftest fcr-tests ()
- (let* ((i 42)
- (fcr1 (fcr-lambda (fcr-test (fst 1) (snd 2) (name "hi"))
- ()
- (list fst snd i)))
- (fcr2 (fcr-lambda (fcr-test (name (cl-incf i)) (fst (cl-incf i)))
- ()
- (list fst snd 152 i))))
- (should (equal (list (fcr-test--fst fcr1)
- (fcr-test--snd fcr1)
- (fcr-test--name fcr1))
- '(1 2 "hi")))
- (should (equal (list (fcr-test--fst fcr2)
- (fcr-test--snd fcr2)
- (fcr-test--name fcr2))
- '(44 nil 43)))
- (should (equal (funcall fcr1) '(1 2 44)))
- (should (equal (funcall fcr2) '(44 nil 152 44)))
- (should (equal (funcall (fcr-test-copy fcr1 :fst 7)) '(7 2 44)))
- (should (equal (funcall (fcr-test-copy1 fcr1 9)) '(9 2 44)))
- (should (cl-typep fcr1 'fcr-test))
- (should (cl-typep fcr1 'fcr-object))
- (should (member (fcr-test-gen fcr1)
- '("#<fcr-test:#<fcr:#<cons>>>"
- "#<fcr-test:#<fcr:#<bytecode>>>")))
- ))
-
-(ert-deftest fcr-tests--limits ()
- (should
- (condition-case err
- (let ((lexical-binding t)
- (byte-compile-debug t))
- (byte-compile '(lambda ()
- (let ((inc-where nil))
- (fcr-lambda (advice (where 'foo)) ()
- (setq inc-where (lambda () (setq where (1+ where))))
- where))))
- nil)
- (error
- (and (eq 'error (car err))
- (string-match "where.*mutated" (cadr err))))))
- (should
- (condition-case err
- (progn (macroexpand '(fcr-defstruct fcr--foo a a))
- nil)
- (error
- (and (eq 'error (car err))
- (string-match "Duplicate slot name: a$" (cadr err))))))
- (should
- (condition-case err
- (progn (macroexpand '(fcr-defstruct (fcr--foo (:parent advice)) where))
- nil)
- (error
- (and (eq 'error (car err))
- (string-match "Duplicate slot name: where$" (cadr err))))))
- (should
- (condition-case err
- (progn (macroexpand '(fcr-lambda (advice (where 1) (where 2)) () where))
- nil)
- (error
- (and (eq 'error (car err))
- (string-match "Duplicate slot: where$" (cadr err)))))))
-
-(fcr-defstruct (fcr-test-mut
- (:parent fcr-test)
- (:copier fcr-test-mut-copy))
- "Simple FCR with a mutable field."
- (mut :mutable t))
-
-(ert-deftest fcr-test--mutate ()
- (let* ((f (fcr-lambda (fcr-test-mut (fst 0) (mut 3))
- (x)
- (+ x fst mut)))
- (f2 (fcr-test-mut-copy f :fst 50)))
- (should (equal (fcr-test-mut--mut f) 3))
- (should (equal (funcall f 5) 8))
- (should (equal (funcall f2 5) 58))
- (cl-incf (fcr-test-mut--mut f) 7)
- (should (equal (fcr-test-mut--mut f) 10))
- (should (equal (funcall f 5) 15))
- (should (equal (funcall f2 15) 68))))
-
-;;; fcr-tests.el ends here.
--- /dev/null
+;;; oclosure-tests.e; --- Tests for Open Closures -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021 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)
+
+(cl-defmethod oclosure-test-gen ((_x compiled-function)) "#<bytecode>")
+
+(cl-defmethod oclosure-test-gen ((_x cons)) "#<cons>")
+
+(cl-defmethod oclosure-test-gen ((_x oclosure-object))
+ (format "#<oclosure:%s>" (cl-call-next-method)))
+
+(cl-defmethod oclosure-test-gen ((_x oclosure-test))
+ (format "#<oclosure-test:%s>" (cl-call-next-method)))
+
+(ert-deftest oclosure-tests ()
+ (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-object))
+ (should (member (oclosure-test-gen ocl1)
+ '("#<oclosure-test:#<oclosure:#<cons>>>"
+ "#<oclosure-test:#<oclosure:#<bytecode>>>")))
+ ))
+
+(ert-deftest oclosure-tests--limits ()
+ (should
+ (condition-case err
+ (let ((lexical-binding t)
+ (byte-compile-debug t))
+ (byte-compile '(lambda ()
+ (let ((inc-where nil))
+ (oclosure-lambda (advice (where 'foo)) ()
+ (setq inc-where (lambda () (setq where (1+ where))))
+ where))))
+ nil)
+ (error
+ (and (eq 'error (car err))
+ (string-match "where.*mutated" (cadr err))))))
+ (should
+ (condition-case err
+ (progn (macroexpand '(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 '(oclosure-define (oclosure--foo (:parent advice)) where))
+ nil)
+ (error
+ (and (eq 'error (car err))
+ (string-match "Duplicate slot name: where$" (cadr err))))))
+ (should
+ (condition-case err
+ (progn (macroexpand '(oclosure-lambda (advice (where 1) (where 2)) () where))
+ nil)
+ (error
+ (and (eq 'error (car err))
+ (string-match "Duplicate slot: where$" (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.
projects / emacs.git / commitdiff