From eed3450af0a0892db67409b073203c9f1454354a Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 22 Dec 2021 10:52:21 -0500 Subject: [PATCH] fcr.el (fcr-defstruct): Use `fcr--copy` to define accessors * lisp/emacs-lisp/fcr.el (fcr-defstruct): Use `fcr--copy` to define accessors. Fix call to `fcr--defstruct-make-copiers`. (fcr--lambda): New macro extracted from `fcr-lambda`. (fcr-lambda): Use it. (fcr--accessor-prototype): New constant. (fcr-accessor): New type. --- lisp/emacs-lisp/fcr.el | 99 ++++++++++++++++++++++++++---------------- 1 file changed, 62 insertions(+), 37 deletions(-) diff --git a/lisp/emacs-lisp/fcr.el b/lisp/emacs-lisp/fcr.el index 51933f0f2bf..77baec8630b 100644 --- a/lisp/emacs-lisp/fcr.el +++ b/lisp/emacs-lisp/fcr.el @@ -195,13 +195,14 @@ (setf (gethash slot it) i) ;; Always use a double hyphen: if users wants to ;; make it public, they can do so with an alias. - ;; FIXME: Use a copier! `(defalias ',(intern (format "%S--%S" name slot)) - (fcr-lambda accessor ((type ',name) (slot ',slot)) - (fcr) - (fcr-get fcr ,i))))) + ;; We use `fcr--copy' instead of `fcr--accessor-copy' + ;; here to circumvent bootstrapping problems. + (fcr--copy fcr--accessor-prototype + ',name ',slot ,i)))) slotdescs)) - ,@(fcr--defstruct-make-copiers copiers slots name)))) + ,@(fcr--defstruct-make-copiers + copiers (mapcar #'cl--slot-descriptor-name slotdescs) name)))) (defun fcr--define (class pred) (let* ((name (cl--class-name class)) @@ -210,13 +211,51 @@ (defalias predname pred) (put name 'cl-deftype-satisfies predname))) -(defmacro fcr-lambda (type fields args &rest body) +(defmacro fcr--lambda (type bindings 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. +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))) + `(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 ,@(mapcar #'car bindings)) + (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 ,@(mapcar #'car bindings)) + ,@body))))) + +(defmacro fcr-lambda (type fields args &rest body) + "Define anonymous FCR function. +TYPE should be an FCR type. +FIELDS is a let-style list of bindings for the various slots of TYPE. +ARGS is and BODY are the same as for `lambda'." (declare (indent 3) (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 @@ -224,14 +263,9 @@ (pcase-let* ((class (cl--find-class type)) (slots (fcr--class-slots class)) - ;; 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)) - (slotbinds (nreverse - (mapcar (lambda (slot) - (list (cl--slot-descriptor-name slot))) - slots))) + (slotbinds (mapcar (lambda (slot) + (list (cl--slot-descriptor-name slot))) + slots)) (tempbinds (mapcar (lambda (field) (let* ((name (car field)) @@ -248,28 +282,7 @@ fields))) ;; FIXME: Optimize temps away when they're provided in the right order? `(let ,tempbinds - (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)))) - slotbinds) - ;; 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 ,@(mapcar #'car slotbinds)) - (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 ,@(mapcar #'car slotbinds)) - ,@body)))))) + (fcr--lambda ,type ,slotbinds ,args ,@body)))) (defun fcr--fix-type (_ignore fcr) (if (byte-code-function-p fcr) @@ -323,8 +336,14 @@ (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)) (fcr) (fcr-get fcr index))) + (fcr-defstruct accessor - "FCR to access the field of an object." + "FCR function to access a specific slot of an object." type slot) (defun fcr--accessor-cl-print (object stream) @@ -340,5 +359,11 @@ \(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) + (provide 'fcr) ;;; fcr.el ends here -- 2.39.5