From 230617c90cf97285b554cc85de135a46b7587a4d Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 21 Dec 2021 09:57:34 -0500 Subject: [PATCH] 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. --- lisp/emacs-lisp/cconv.el | 8 ++++ lisp/emacs-lisp/oclosure.el | 66 +++++++++++++++++++------- test/lisp/emacs-lisp/cconv-tests.el | 1 + test/lisp/emacs-lisp/oclosure-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 66e0c359415..90d2157847e 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. + (`(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 3462e62a43c..65785a7ed8c 100644 --- 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 d7f9af18994..479afe12c0d 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/oclosure-tests.el b/test/lisp/emacs-lisp/oclosure-tests.el index 04b214b9ea5..50d05738d39 100644 --- 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) '("#>>" "#>>"))) )) +(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. -- 2.39.5