[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
scratch/fcr 2a34e414a1: FCR: Rename to OClosure
|
From: |
Stefan Monnier |
|
Subject: |
scratch/fcr 2a34e414a1: FCR: Rename to OClosure |
|
Date: |
Fri, 31 Dec 2021 15:40:33 -0500 (EST) |
branch: scratch/fcr
commit 2a34e414a17ae2787e0ac9d98777cf6a9c523df6
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>
FCR: Rename to OClosure
---
lisp/emacs-lisp/cconv.el | 4 +-
lisp/emacs-lisp/cl-generic.el | 44 +++---
lisp/emacs-lisp/cl-print.el | 4 +-
lisp/emacs-lisp/nadvice.el | 26 ++--
lisp/emacs-lisp/{fcr.el => oclosure.el} | 230 ++++++++++++++++----------------
lisp/kmacro.el | 4 +-
lisp/loadup.el | 2 +-
lisp/simple.el | 2 +-
test/lisp/emacs-lisp/fcr-tests.el | 124 -----------------
test/lisp/emacs-lisp/oclosure-tests.el | 124 +++++++++++++++++
10 files changed, 282 insertions(+), 282 deletions(-)
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index 679d8136ad..90d2157847 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -201,7 +201,7 @@ Returns a form where all lambdas don't have any free
variables."
(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))
@@ -604,7 +604,7 @@ places where they originally did not directly appear."
(`(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)
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 2700df37de..36d6276cb1 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -724,7 +724,7 @@ for all those different tags in the method-cache.")
(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)
@@ -744,7 +744,7 @@ FUN is the function that should be called when METHOD calls
(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)))))
@@ -915,7 +915,7 @@ those methods.")
(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.
@@ -1279,41 +1279,41 @@ Used internally for the (major-mode MODE) context
specializers."
(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.
diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index 83af57fd9b..0131913a06 100644
--- a/lisp/emacs-lisp/cl-print.el
+++ b/lisp/emacs-lisp/cl-print.el
@@ -221,11 +221,11 @@ into a button whose action shows the function's
disassembly.")
'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)
diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el
index 4aeb41d4f2..789431cb35 100644
--- a/lisp/emacs-lisp/nadvice.el
+++ b/lisp/emacs-lisp/nadvice.el
@@ -42,39 +42,39 @@
;; 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)
diff --git a/lisp/emacs-lisp/fcr.el b/lisp/emacs-lisp/oclosure.el
similarity index 74%
rename from lisp/emacs-lisp/fcr.el
rename to lisp/emacs-lisp/oclosure.el
index f4be4fcc10..8fde69a2b0 100644
--- a/lisp/emacs-lisp/fcr.el
+++ b/lisp/emacs-lisp/oclosure.el
@@ -1,4 +1,4 @@
-;;; fcr.el --- FunCallableRecords -*- lexical-binding: t; -*-
+;;; oclosure.el --- Open Closures -*- lexical-binding: t; -*-
;; Copyright (C) 2015, 2021 Stefan Monnier
@@ -20,19 +20,19 @@
;;; Commentary:
-;; A FunCallableRecord is an object that combines the properties of records
+;; 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 FCRs are used:
+;; 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).
-;; - FCR accessor functions, where the type-dispatch is used to
+;; - 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 FCRs could be used:
+;; 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
@@ -52,29 +52,29 @@
;; (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)
+;; - 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 FCRs in that they involve an additional indirection to get
+;; 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 FCRs where those are directly
+;; 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 FCRs (beside the fact that Callable can be
+;; 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
-;; FCR object comes with its own code, so two FCR objects of the
+;; 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 `fcr-lambda' into its own class
+;; same result by turning every `oclosure-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
+;; 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
@@ -82,14 +82,14 @@
;; 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.
+;; 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 FCRs, modulo the fact that LML doesn't
+;; 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 "FCR" we could go with
+;; Naming: to replace "OClosure" we could go with
;; - open closures
;; - disclosures
;; - opening
@@ -107,39 +107,39 @@
;; 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
+;; 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:
-;; - `fcr-cl-defun', `fcr-cl-defsubst', `fcr-defsubst', `fcr-define-inline'?
+;; - `oclosure-cl-defun', `oclosure-cl-defsubst', `oclosure-defsubst',
`oclosure-define-inline'?
;; - Use accessor in cl-defstruct
-;; - Add pcase patterns for FCRs.
+;; - Add pcase patterns for OClosures.
(eval-when-compile (require 'cl-lib))
(eval-when-compile (require 'subr-x)) ;For `named-let'.
-(cl-defstruct (fcr--class
+(cl-defstruct (oclosure--class
(:constructor nil)
- (:constructor fcr--class-make ( name docstring slots parents
+ (:constructor oclosure--class-make ( name docstring slots
parents
allparents))
(:include cl--class)
(:copier nil))
- "Metaclass for FunCallableRecord classes."
+ "Metaclass for OClosure 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)))
+(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 'fcr-object (fcr--class-allparents (cl--find-class type))))))
-(cl-deftype fcr-object () '(satisfies fcr--object-p))
+ (memq 'oclosure-object (oclosure--class-allparents (cl--find-class
type))))))
+(cl-deftype oclosure-object () '(satisfies oclosure--object-p))
-(defun fcr--defstruct-make-copiers (copiers slotdescs name)
+(defun oclosure--defstruct-make-copiers (copiers slotdescs name)
(require 'cl-macs) ;`cl--arglist-args' is not autoloaded.
(let* ((mutables '())
(slots (mapcar
@@ -175,7 +175,7 @@
(lambda (slot)
(setq index (1+ index))
(let* ((mutable (memq slot mutables))
- (get `(fcr--get ,obj ,index ,(not (not mutable)))))
+ (get `(oclosure--get ,obj ,index ,(not (not mutable)))))
(push mutable mutlist)
(cond
((not (memq slot anames)) get)
@@ -188,11 +188,11 @@
`(cl-defun ,cname (&cl-defs (',absent) ,obj ,@args)
,doc
(declare (side-effect-free t))
- (fcr--copy ,obj ',(if (remq nil mutlist) (nreverse mutlist))
+ (oclosure--copy ,obj ',(if (remq nil mutlist) (nreverse mutlist))
,@argvals))))
copiers)))
-(defmacro fcr-defstruct (name &optional docstring &rest slots)
+(defmacro oclosure-define (name &optional docstring &rest slots)
(declare (doc-string 2) (indent 1))
(unless (stringp docstring)
(push docstring slots)
@@ -215,7 +215,7 @@
(parent-names (or (or (funcall get-opt :parent)
(funcall get-opt :include))
- '(fcr-object)))
+ '(oclosure-object)))
(copiers (funcall get-opt :copier 'all))
(parent-slots '())
@@ -266,7 +266,7 @@
slots)))
(allparents (apply #'append (mapcar #'cl--class-allparents
parents)))
- (class (fcr--class-make name docstring slotdescs parents
+ (class (oclosure--class-make name docstring slotdescs parents
(delete-dups
(cons name allparents))))
(it (make-hash-table :test #'eq)))
@@ -276,11 +276,11 @@
(format "Ignored options: %S" options)
nil))
(eval-and-compile
- (fcr--define ',class
- (lambda (fcr)
- (let ((type (fcr-type fcr)))
+ (oclosure--define ',class
+ (lambda (oclosure)
+ (let ((type (oclosure-type oclosure)))
(when type
- (memq ',name (fcr--class-allparents
+ (memq ',name (oclosure--class-allparents
(cl--find-class type))))))))
,@(let ((i -1))
(mapcar (lambda (desc)
@@ -297,40 +297,40 @@
(setf (gethash slot it) i)
(if (not mutable)
`(defalias ',name
- ;; We use `fcr--copy' instead of
- ;; `fcr--accessor-copy' here to circumvent
+ ;; We use `oclosure--copy' instead of
+ ;; `oclosure--accessor-copy' here to circumvent
;; bootstrapping problems.
- (fcr--copy fcr--accessor-prototype nil
+ (oclosure--copy oclosure--accessor-prototype nil
',name ',slot ,i))
`(progn
(defalias ',name
- (fcr--accessor-copy
- fcr--mut-getter-prototype
+ (oclosure--accessor-copy
+ oclosure--mut-getter-prototype
',name ',slot ,i))
(defalias ',(gv-setter name)
- (fcr--accessor-copy
- fcr--mut-setter-prototype
+ (oclosure--accessor-copy
+ oclosure--mut-setter-prototype
',name ',slot ,i))))))
slotdescs))
- ,@(fcr--defstruct-make-copiers
+ ,@(oclosure--defstruct-make-copiers
copiers slotdescs name))))
-(defun fcr--define (class pred)
+(defun oclosure--define (class pred)
(let* ((name (cl--class-name class))
- (predname (intern (format "fcr--%s-p" name))))
+ (predname (intern (format "oclosure--%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.
+(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 `fcr-lambda' should be a special form.
+ ;; 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
@@ -339,7 +339,7 @@ No checking is performed,"
(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.
+ ;; a docstring slot to OClosures.
((`(,prebody . ,body) (macroexp-parse-body body))
(rovars (mapcar #'car bindings)))
(dolist (mutable mutables)
@@ -354,8 +354,8 @@ No checking is performed,"
;; 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
+ (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)
@@ -367,20 +367,20 @@ No checking is performed,"
(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.
+(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 FCR type name and
+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 `fcr-defstruct' distinguish "optional" from
+ ;; 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 (fcr--class-slots class))
+ (slots (oclosure--class-slots class))
(mutables '())
(slotbinds (mapcar (lambda (slot)
(let ((name (cl--slot-descriptor-name slot))
@@ -405,35 +405,35 @@ ARGS and BODY are the same as for `lambda'."
fields)))
;; FIXME: Optimize temps away when they're provided in the right order?
`(let ,tempbinds
- (fcr--lambda ,type ,slotbinds ,mutables ,args ,@body))))
+ (oclosure--lambda ,type ,slotbinds ,mutables ,args ,@body))))
-(defun fcr--fix-type (_ignore fcr)
- (if (byte-code-function-p fcr)
+(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.
- fcr
+ 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 fcr)))
- (let ((typename (nth 3 fcr))) ;; The "docstring".
+ (cl-assert (eq 'closure (car-safe oclosure)))
+ (let ((typename (nth 3 oclosure))) ;; The "docstring".
(cl-assert (stringp typename))
(push (cons :type (intern typename))
- (cadr fcr))
- fcr)))
+ (cadr oclosure))
+ oclosure)))
-(defun fcr--copy (fcr mutlist &rest args)
- (if (byte-code-function-p fcr)
- (apply #'make-closure fcr
+(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 fcr)))
- (cl-assert (eq :type (caar (cadr fcr))))
- (let ((env (cadr fcr)))
+ (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))
@@ -441,74 +441,74 @@ ARGS and BODY are the same as for `lambda'."
(cons (cons (caar env) (car args))
(loop (cdr env) (cdr args)))))
,@(nthcdr (1+ (length args)) env))
- ,@(nthcdr 2 fcr)))))
+ ,@(nthcdr 2 oclosure)))))
-(defun fcr--get (fcr index mutable)
- (if (byte-code-function-p fcr)
- (let* ((csts (aref fcr 2))
+(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 fcr)))
- (cl-assert (eq :type (caar (cadr fcr))))
- (cdr (nth (1+ index) (cadr fcr)))))
+ (cl-assert (eq 'closure (car-safe oclosure)))
+ (cl-assert (eq :type (caar (cadr oclosure))))
+ (cdr (nth (1+ index) (cadr oclosure)))))
-(defun fcr--set (v fcr index)
- (if (byte-code-function-p fcr)
- (let* ((csts (aref fcr 2))
+(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 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))))
+ (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 fcr))
- (let* ((env (car-safe (cdr fcr)))
+ (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 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)))
+(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)))
-(fcr-defstruct accessor
- "FCR function to access a specific slot of an object."
+(oclosure-define accessor
+ "OClosure function to access a specific slot of an object."
type slot)
-(defun fcr--accessor-cl-print (object stream)
+(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 fcr--accessor-docstring (f)
+(defun oclosure--accessor-docstring (f)
(format "Access slot \"%S\" of OBJ of type `%S'.
\(fn OBJ)"
(accessor--slot f) (accessor--type f)))
-(fcr-defstruct (fcr-accessor
+(oclosure-define (oclosure-accessor
(:parent accessor)
- (:copier fcr--accessor-copy (type slot index)))
- "FCR function to access a specific slot of an FCR function."
+ (:copier oclosure--accessor-copy (type slot index)))
+ "OClosure function to access a specific slot of an OClosure 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
+(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.
- (fcr-lambda (fcr-accessor (type) (slot) (index)) (val fcr)
- (fcr--set val fcr index)))
+ (oclosure-lambda (oclosure-accessor (type) (slot) (index)) (val oclosure)
+ (oclosure--set val oclosure index)))
-(provide 'fcr)
-;;; fcr.el ends here
+(provide 'oclosure)
+;;; oclosure.el ends here
diff --git a/lisp/kmacro.el b/lisp/kmacro.el
index 8311c43404..54ad779d4a 100644
--- a/lisp/kmacro.el
+++ b/lisp/kmacro.el
@@ -362,7 +362,7 @@ information."
;;; Keyboard macro ring
-(fcr-defstruct kmacro
+(oclosure-define kmacro
"Keyboard macro."
keys (counter :mutable t) format)
@@ -815,7 +815,7 @@ If kbd macro currently being defined end it before
activating it."
;;;###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)
diff --git a/lisp/loadup.el b/lisp/loadup.el
index f02dcd6788..154f831ead 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -196,7 +196,7 @@
(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")
diff --git a/lisp/simple.el b/lisp/simple.el
index f8d963fd01..d7576a7c03 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -2350,7 +2350,7 @@ FUNCTION is expected to be a function value rather than,
say, a mere symbol."
(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.
diff --git a/test/lisp/emacs-lisp/fcr-tests.el
b/test/lisp/emacs-lisp/fcr-tests.el
deleted file mode 100644
index 19aba3329d..0000000000
--- a/test/lisp/emacs-lisp/fcr-tests.el
+++ /dev/null
@@ -1,124 +0,0 @@
-;;; 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.
diff --git a/test/lisp/emacs-lisp/oclosure-tests.el
b/test/lisp/emacs-lisp/oclosure-tests.el
new file mode 100644
index 0000000000..0a256a5baa
--- /dev/null
+++ b/test/lisp/emacs-lisp/oclosure-tests.el
@@ -0,0 +1,124 @@
+;;; 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.
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- scratch/fcr 2a34e414a1: FCR: Rename to OClosure,
Stefan Monnier <=