lisp/emacs-lisp/oclosure.el: Signal errors for invalid code

* test/lisp/emacs-lisp/oclosure-tests.el (oclosure-tests): Remove left-over
debugging messages.
(oclosure-tests--limits): New test.

* lisp/emacs-lisp/oclosure.el (oclosure-define): Fill the `index-table` and
signal an error in case of duplicate slot names.
(oclosure-lambda): Change use of `oclosure--fix-type` so `cconv-convert` can use
it to detect store-converted slots.  Tweak generated code to avoid
a warning.
(oclosure--fix-type): Adjust accordingly.

* lisp/emacs-lisp/cconv.el (cconv-convert): Signal an error if we
store-convert a OClosure slot.

diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index 66e0c359415b5409635c5077e2b582d161c9c00d..90d2157847efcb6501145b202084d5e2236698b3 100644 (file)
--- 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.
 
+    (`(oclosure--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/oclosure.el b/lisp/emacs-lisp/oclosure.el
index 3462e62a43c4ce409f950a6e2556fb8cef0c74fe..65785a7ed8c58aba2f4e82907416ae4ca155a77c 100644 (file)
--- a/lisp/emacs-lisp/oclosure.el
+++ b/lisp/emacs-lisp/oclosure.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 `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.
+
 (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 (oclosure--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)) (oclosure)
-                        ,(format "Return slot `%S' of OClosure, of type `%S'."
-                                 slot name)
-                        (oclosure-get oclosure ,i))))
+                          ,(format "Return slot `%S' of OClosure, of type `%S'."
+                                   slot name)
+                          (oclosure-get oclosure ,i))))
                    slotdescs))
        ,@(oclosure--defstruct-make-copiers copiers slots name))))
 
@@ -186,6 +203,12 @@
     (put name 'cl-deftype-satisfies predname)))
 
 (defmacro oclosure-lambda (type fields args &rest 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'.
   (declare (indent 3) (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
@@ -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).
-       (oclosure--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).
+         (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 ,@(mapcar #'car slotbinds))
           (lambda ,args
             (:documentation ',type)
             ,@prebody
@@ -233,8 +263,10 @@
             (if t nil ,@(mapcar #'car slotbinds))
             ,@body))))))
 
-(defun oclosure--fix-type (oclosure)
+(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

diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el
index d7f9af18994e9cfe926bc5e21d2c3048677c03f9..479afe12c0dc735817eda428ea93bd1454604059 100644 (file)
--- 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/oclosure-tests.el b/test/lisp/emacs-lisp/oclosure-tests.el
index 04b214b9ea55b14b24567733abf01f5261154da7..50d05738d394bed9ea7aff2cdc09bf1cef990595 100644 (file)
--- a/test/lisp/emacs-lisp/oclosure-tests.el
+++ b/test/lisp/emacs-lisp/oclosure-tests.el
@@ -47,29 +47,58 @@
          (ocl2 (oclosure-lambda oclosure-test ((name (cl-incf i)) (fst (cl-incf i)))
                            ()
                  (list fst snd 152 i))))
-    (message "hello-1")
     (should (equal (list (oclosure-test--fst ocl1)
                          (oclosure-test--snd ocl1)
                          (oclosure-test--name ocl1))
                    '(1 2 "hi")))
-    (message "hello-2")
     (should (equal (list (oclosure-test--fst ocl2)
                          (oclosure-test--snd ocl2)
                          (oclosure-test--name ocl2))
                    '(44 nil 43)))
-    (message "hello-3")
     (should (equal (funcall ocl1) '(1 2 44)))
-    (message "hello-4")
     (should (equal (funcall ocl2) '(44 nil 152 44)))
-    (message "hello-5")
     (should (equal (funcall (oclosure-test-copy ocl1 :fst 7)) '(7 2 44)))
-    (message "hello-6")
     (should (cl-typep ocl1 'oclosure-test))
-    (message "hello-7")
     (should (cl-typep ocl1 'oclosure-object))
     (should (member (oclosure-test-gen ocl1)
                     '("#<oclosure-test:#<oclosure:#<cons>>>"
                       "#<oclosure-test:#<oclosure:#<bytecode>>>")))
     ))
 
+(ert-deftest oclosure-tests--limits ()
+  (should
+   (condition-case err
+       (let ((lexical-binding t)
+             (byte-compile-debug t))
+         (byte-compile '(lambda ()
+                          (let ((inc-where nil))
+                            (oclosure-lambda advice ((where 'foo)) ()
+                              (setq inc-where (lambda () (setq where (1+ where))))
+                              where))))
+         nil)
+     (error
+      (and (eq 'error (car err))
+           (string-match "where.*mutated" (cadr err))))))
+  (should
+   (condition-case err
+       (progn (macroexpand '(oclosure-define oclosure--foo a a))
+              nil)
+     (error
+      (and (eq 'error (car err))
+           (string-match "Duplicate slot name: a$" (cadr err))))))
+  (should
+   (condition-case err
+       (progn (macroexpand '(oclosure-define (oclosure--foo (:parent advice)) where))
+              nil)
+     (error
+      (and (eq 'error (car err))
+           (string-match "Duplicate slot name: where$" (cadr err))))))
+  (should
+   (condition-case err
+       (progn (macroexpand '(oclosure-lambda advice ((where 1) (where 2)) () where))
+              nil)
+     (error
+      (and (eq 'error (car err))
+           (string-match "Duplicate slot: where$" (cadr err)))))))
+
 ;;; oclosure-tests.el ends here.