scratch/fcr 0d45186: lisp/emacs-lisp/fcr.el: Signal errors for invalid code

[Stefan Monnier]

branch: scratch/fcr
commit 0d45186882cec71dc687e76fef624ef8d6976358
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    lisp/emacs-lisp/fcr.el: Signal errors for invalid code
    
    * test/lisp/emacs-lisp/fcr-tests.el (fcr-tests): Remove left-over
    debugging messages.
    (fcr-tests--limits): New test.
    
    * lisp/emacs-lisp/fcr.el (fcr-defstruct): Fill the `index-table` and
    signal an error in case of duplicate slot names.
    (fcr-lambda): Change use of `fcr--fix-type` so `cconv-convert` can use
    it to detect store-converted slots.  Tweak generated code to avoid
    a warning.
    (fcr--fix-type): Adjust accordingly.
    
    * lisp/emacs-lisp/cconv.el (cconv-convert): Signal an error if we
    store-convert a FCR slot.
---
 lisp/emacs-lisp/cconv.el            |  8 +++++
 lisp/emacs-lisp/fcr.el              | 66 +++++++++++++++++++++++++++----------
 test/lisp/emacs-lisp/cconv-tests.el |  1 +
 test/lisp/emacs-lisp/fcr-tests.el   | 43 ++++++++++++++++++++----
 4 files changed, 94 insertions(+), 24 deletions(-)

diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index 4fdcf2b..679d813 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -604,6 +604,14 @@ places where they originally did not directly appear."
 
     (`(declare . ,_) form)              ;The args don't contain code.
 
+    (`(fcr--fix-type (ignore . ,vars) ,exp)
+     (dolist (var vars)
+       (let ((x (assq var env)))
+         (pcase (cdr x)
+           (`(car-safe . ,_) (error "Slot %S should not be mutated" var))
+           (_ (cl-assert (null (cdr x)))))))
+     (cconv-convert exp env extend))
+
     (`(,func . ,forms)
      ;; First element is function or whatever function-like forms are: or, and,
      ;; if, catch, progn, prog1, while, until
diff --git a/lisp/emacs-lisp/fcr.el b/lisp/emacs-lisp/fcr.el
index 548348a..970dcfb 100644
--- a/lisp/emacs-lisp/fcr.el
+++ b/lisp/emacs-lisp/fcr.el
@@ -41,6 +41,20 @@
 
 ;;; 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.
+
 (eval-when-compile (require 'cl-lib))
 (eval-when-compile (require 'subr-x))   ;For `named-let'.
 
@@ -143,7 +157,6 @@
            parent-names))
          (slotdescs (append
                      parent-slots
-                     ;; FIXME: Catch duplicate slot names.
                      (mapcar (lambda (field)
                                (cl--make-slot-descriptor field nil nil
                                                          '((:read-only . t))))
@@ -152,8 +165,9 @@
                                              parents)))
          (class (fcr--class-make name docstring slotdescs parents
                                  (delete-dups
-                                  (cons name allparents)))))
-    ;; FIXME: Use an intermediate function like `cl-struct-define'.
+                                  (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)
@@ -169,12 +183,15 @@
            (mapcar (lambda (desc)
                      (let ((slot (cl--slot-descriptor-name desc)))
                        (cl-incf i)
+                       (when (gethash slot it)
+                         (error "Duplicate slot name: %S" slot))
+                       (setf (gethash slot it) i)
                        ;; Always use a double hyphen: if the user wants to
                        ;; make it public, it can do so with an alias.
                        `(defun ,(intern (format "%S--%S" name slot)) (fcr)
-                        ,(format "Return slot `%S' of FCR, of type `%S'."
-                                 slot name)
-                        (fcr-get fcr ,i))))
+                          ,(format "Return slot `%S' of FCR, of type `%S'."
+                                   slot name)
+                          (fcr-get fcr ,i))))
                    slotdescs))
        ,@(fcr--defstruct-make-copiers copiers slots name))))
 
@@ -186,6 +203,12 @@
     (put name 'cl-deftype-satisfies predname)))
 
 (defmacro fcr-lambda (type fields args &rest 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'.
   (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
@@ -207,24 +230,31 @@
                             (bind (assq name slotbinds)))
                        (cond
                         ((not bind)
-                         (error "Unknown slots: %S" name))
+                         (error "Unknown slot: %S" name))
                         ((cdr bind)
-                         (error "Duplicate slots: %S" name))
+                         (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?
-    ;; FIXME: Slots not specified in `fields' tend to emit "Variable FOO left
-    ;; uninitialized"!
     `(let ,tempbinds
-       ;; FIXME: Prevent store-conversion for fields vars!
-       ;; 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
-        (let ,slotbinds
+       (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
@@ -233,8 +263,10 @@
             (if t nil ,@(mapcar #'car slotbinds))
             ,@body))))))
 
-(defun fcr--fix-type (fcr)
+(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
diff --git a/test/lisp/emacs-lisp/cconv-tests.el 
b/test/lisp/emacs-lisp/cconv-tests.el
index d7f9af1..479afe1 100644
--- a/test/lisp/emacs-lisp/cconv-tests.el
+++ b/test/lisp/emacs-lisp/cconv-tests.el
@@ -23,6 +23,7 @@
 
 (require 'ert)
 (require 'cl-lib)
+(require 'generator)
 
 (ert-deftest cconv-tests-lambda-:documentation ()
   "Docstring for lambda can be specified with :documentation."
diff --git a/test/lisp/emacs-lisp/fcr-tests.el 
b/test/lisp/emacs-lisp/fcr-tests.el
index 379fa27..c9aa00d 100644
--- a/test/lisp/emacs-lisp/fcr-tests.el
+++ b/test/lisp/emacs-lisp/fcr-tests.el
@@ -47,29 +47,58 @@
          (fcr2 (fcr-lambda fcr-test ((name (cl-incf i)) (fst (cl-incf i)))
                            ()
                  (list fst snd 152 i))))
-    (message "hello-1")
     (should (equal (list (fcr-test--fst fcr1)
                          (fcr-test--snd fcr1)
                          (fcr-test--name fcr1))
                    '(1 2 "hi")))
-    (message "hello-2")
     (should (equal (list (fcr-test--fst fcr2)
                          (fcr-test--snd fcr2)
                          (fcr-test--name fcr2))
                    '(44 nil 43)))
-    (message "hello-3")
     (should (equal (funcall fcr1) '(1 2 44)))
-    (message "hello-4")
     (should (equal (funcall fcr2) '(44 nil 152 44)))
-    (message "hello-5")
     (should (equal (funcall (fcr-test-copy fcr1 :fst 7)) '(7 2 44)))
-    (message "hello-6")
     (should (cl-typep fcr1 'fcr-test))
-    (message "hello-7")
     (should (cl-typep fcr1 'fcr-object))
     (should (member (fcr-test-gen fcr1)
                     '("#<fcr-test:#<fcr:#<cons>>>"
                       "#<fcr-test:#<fcr:#<bytecode>>>")))
     ))
 
+(ert-deftest fcr-tests--limits ()
+  (should
+   (condition-case err
+       (let ((lexical-binding t)
+             (byte-compile-debug t))
+         (byte-compile '(lambda ()
+                          (let ((inc-where nil))
+                            (fcr-lambda advice ((where 'foo)) ()
+                              (setq inc-where (lambda () (setq where (1+ 
where))))
+                              where))))
+         nil)
+     (error
+      (and (eq 'error (car err))
+           (string-match "where.*mutated" (cadr err))))))
+  (should
+   (condition-case err
+       (progn (macroexpand '(fcr-defstruct fcr--foo a a))
+              nil)
+     (error
+      (and (eq 'error (car err))
+           (string-match "Duplicate slot name: a$" (cadr err))))))
+  (should
+   (condition-case err
+       (progn (macroexpand '(fcr-defstruct (fcr--foo (:parent advice)) where))
+              nil)
+     (error
+      (and (eq 'error (car err))
+           (string-match "Duplicate slot name: where$" (cadr err))))))
+  (should
+   (condition-case err
+       (progn (macroexpand '(fcr-lambda advice ((where 1) (where 2)) () where))
+              nil)
+     (error
+      (and (eq 'error (car err))
+           (string-match "Duplicate slot: where$" (cadr err)))))))
+
 ;;; fcr-tests.el ends here.