From 2a34e414a17ae2787e0ac9d98777cf6a9c523df6 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 31 Dec 2021 15:39:51 -0500 Subject: [PATCH] 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(-) rename lisp/emacs-lisp/{fcr.el => oclosure.el} (74%) delete mode 100644 test/lisp/emacs-lisp/fcr-tests.el create mode 100644 test/lisp/emacs-lisp/oclosure-tests.el diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 679d8136adc..90d2157847e 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 2700df37de2..36d6276cb1d 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 83af57fd9b4..0131913a060 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 4aeb41d4f26..789431cb35c 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 f4be4fcc109..8fde69a2b0e 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 8311c434048..54ad779d4ae 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 f02dcd6788d..154f831ead8 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 f8d963fd017..d7576a7c036 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 19aba3329d6..00000000000 --- 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 . - -;;; 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)) "#") - -(cl-defmethod fcr-test-gen ((_x cons)) "#") - -(cl-defmethod fcr-test-gen ((_x fcr-object)) - (format "#" (cl-call-next-method))) - -(cl-defmethod fcr-test-gen ((_x fcr-test)) - (format "#" (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) - '("#>>" - "#>>"))) - )) - -(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 00000000000..0a256a5baa4 --- /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 . + +;;; 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)) "#") + +(cl-defmethod oclosure-test-gen ((_x cons)) "#") + +(cl-defmethod oclosure-test-gen ((_x oclosure-object)) + (format "#" (cl-call-next-method))) + +(cl-defmethod oclosure-test-gen ((_x oclosure-test)) + (format "#" (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) + '("#>>" + "#>>"))) + )) + +(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. -- 2.39.5