From: Stefan Monnier Date: Fri, 31 Dec 2021 20:39:51 +0000 (-0500) Subject: FCR: Rename to OClosure X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=2a34e414a17ae2787e0ac9d98777cf6a9c523df6;p=emacs.git FCR: Rename to OClosure --- 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/fcr.el b/lisp/emacs-lisp/fcr.el deleted file mode 100644 index f4be4fcc109..00000000000 --- a/lisp/emacs-lisp/fcr.el +++ /dev/null @@ -1,514 +0,0 @@ -;;; fcr.el --- FunCallableRecords -*- lexical-binding: t; -*- - -;; Copyright (C) 2015, 2021 Stefan Monnier - -;; Author: Stefan Monnier -;; 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 . - -;;; 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 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/oclosure.el b/lisp/emacs-lisp/oclosure.el new file mode 100644 index 00000000000..8fde69a2b0e --- /dev/null +++ b/lisp/emacs-lisp/oclosure.el @@ -0,0 +1,514 @@ +;;; oclosure.el --- Open Closures -*- lexical-binding: t; -*- + +;; Copyright (C) 2015, 2021 Stefan Monnier + +;; Author: Stefan Monnier +;; 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 . + +;;; 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 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.