[Emacs-diffs] master bec5b60 8/8: ; Merge: Fixes for macroexpansion and compilation

[Noam Postavsky]

branch: master
commit bec5b602597b8b6f596067167f3b3fe0e6eff285
Merge: e6fa083 79a7456
Author: Noam Postavsky <address@hidden>
Commit: Noam Postavsky <address@hidden>

    ; Merge: Fixes for macroexpansion and compilation
---
 lisp/emacs-lisp/bytecomp.el                        |  29 ++++
 lisp/emacs-lisp/eieio.el                           |   2 +-
 lisp/emacs-lisp/ert.el                             |  41 ++++--
 lisp/emacs-lisp/gv.el                              |   7 +-
 lisp/emacs-lisp/testcover.el                       |  10 +-
 src/fns.c                                          |  11 ++
 test/lisp/dom-tests.el                             |   5 +-
 test/lisp/emacs-lisp/bytecomp-tests.el             |  17 +++
 test/lisp/emacs-lisp/cl-lib-tests.el               |   8 ++
 test/lisp/emacs-lisp/ert-tests.el                  |   9 ++
 test/lisp/emacs-lisp/gv-tests.el                   | 147 +++++++++++++++++++++
 .../emacs-lisp/testcover-resources/testcases.el    |  10 ++
 12 files changed, 277 insertions(+), 19 deletions(-)

diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 5fa7389..9e14c91 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -1572,6 +1572,7 @@ extra args."
           ;; macroenvironment.
           (copy-alist byte-compile-initial-macro-environment))
          (byte-compile--outbuffer nil)
+         (overriding-plist-environment nil)
          (byte-compile-function-environment nil)
          (byte-compile-bound-variables nil)
          (byte-compile-lexical-variables nil)
@@ -4714,6 +4715,34 @@ binding slots have been popped."
      'byte-hunk-handler 'byte-compile-form-make-variable-buffer-local)
 (defun byte-compile-form-make-variable-buffer-local (form)
   (byte-compile-keep-pending form 'byte-compile-normal-call))
+
+(put 'function-put 'byte-hunk-handler 'byte-compile-define-symbol-prop)
+(put 'define-symbol-prop 'byte-hunk-handler 'byte-compile-define-symbol-prop)
+(defun byte-compile-define-symbol-prop (form)
+  (pcase form
+    ((and `(,op ,fun ,prop ,val)
+          (guard (and (macroexp-const-p fun)
+                      (macroexp-const-p prop)
+                      (or (macroexp-const-p val)
+                          ;; Also accept anonymous functions, since
+                          ;; we're at top-level which implies they're
+                          ;; also constants.
+                          (pcase val (`(function (lambda . ,_)) t))))))
+     (byte-compile-push-constant op)
+     (byte-compile-form fun)
+     (byte-compile-form prop)
+     (let* ((fun (eval fun))
+            (prop (eval prop))
+            (val (if (macroexp-const-p val)
+                     (eval val)
+                   (byte-compile-lambda (cadr val)))))
+       (push `(,fun
+               . (,prop ,val ,@(alist-get fun overriding-plist-environment)))
+             overriding-plist-environment)
+       (byte-compile-push-constant val)
+       (byte-compile-out 'byte-call 3)))
+
+    (_ (byte-compile-keep-pending form))))
 
 ;;; tags
 
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index 1a7de55..8b92d5b 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -246,7 +246,7 @@ This method is obsolete."
        ;; test, so we can let typep have the CLOS documented behavior
        ;; while keeping our above predicate clean.
 
-       (put ',name 'cl-deftype-satisfies #',testsym2)
+       (define-symbol-prop ',name 'cl-deftype-satisfies #',testsym2)
 
        (eieio-defclass-internal ',name ',superclasses ',slots 
',options-and-doc)
 
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index d7bd331..c232b08 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -260,6 +260,14 @@ DATA is displayed to the user and should state the reason 
for skipping."
   (when ert--should-execution-observer
     (funcall ert--should-execution-observer form-description)))
 
+;; See Bug#24402 for why this exists
+(defun ert--should-signal-hook (error-symbol data)
+  "Stupid hack to stop `condition-case' from catching ert signals.
+It should only be stopped when ran from inside ert--run-test-internal."
+  (when (and (not (symbolp debugger))   ; only run on anonymous debugger
+             (memq error-symbol '(ert-test-failed ert-test-skipped)))
+    (funcall debugger 'error data)))
+
 (defun ert--special-operator-p (thing)
   "Return non-nil if THING is a symbol naming a special operator."
   (and (symbolp thing)
@@ -267,16 +275,22 @@ DATA is displayed to the user and should state the reason 
for skipping."
          (and (subrp definition)
               (eql (cdr (subr-arity definition)) 'unevalled)))))
 
+;; FIXME: Code inside of here should probably be evaluated like it is
+;; outside of tests, with the sole exception of error handling
 (defun ert--expand-should-1 (whole form inner-expander)
   "Helper function for the `should' macro and its variants."
   (let ((form
-         (macroexpand form (append (bound-and-true-p
-                                    byte-compile-macro-environment)
-                                   (cond
-                                    ((boundp 'macroexpand-all-environment)
-                                     macroexpand-all-environment)
-                                    ((boundp 'cl-macro-environment)
-                                     cl-macro-environment))))))
+         ;; catch macroexpansion errors
+         (condition-case err
+             (macroexpand-all form
+                              (append (bound-and-true-p
+                                       byte-compile-macro-environment)
+                                      (cond
+                                       ((boundp 'macroexpand-all-environment)
+                                        macroexpand-all-environment)
+                                       ((boundp 'cl-macro-environment)
+                                        cl-macro-environment))))
+           (error `(signal ',(car err) ',(cdr err))))))
     (cond
      ((or (atom form) (ert--special-operator-p (car form)))
       (let ((value (cl-gensym "value-")))
@@ -297,8 +311,13 @@ DATA is displayed to the user and should state the reason 
for skipping."
               (args (cl-gensym "args-"))
               (value (cl-gensym "value-"))
               (default-value (cl-gensym "ert-form-evaluation-aborted-")))
-          `(let ((,fn (function ,fn-name))
-                 (,args (list ,@arg-forms)))
+          `(let* ((,fn (function ,fn-name))
+                  (,args (condition-case err
+                             (let ((signal-hook-function 
#'ert--should-signal-hook))
+                               (list ,@arg-forms))
+                           (error (progn (setq ,fn #'signal)
+                                         (list (car err)
+                                               (cdr err)))))))
              (let ((,value ',default-value))
                ,(funcall inner-expander
                          `(setq ,value (apply ,fn ,args))
@@ -760,6 +779,10 @@ This mainly sets up debugger-related bindings."
     ;; too expensive, we can remove it.
     (with-temp-buffer
       (save-window-excursion
+        ;; FIXME: Use `signal-hook-function' instead of `debugger' to
+        ;; handle ert errors. Once that's done, remove
+        ;; `ert--should-signal-hook'.  See Bug#24402 and Bug#11218 for
+        ;; details.
         (let ((debugger (lambda (&rest args)
                           (ert--run-test-debugger test-execution-info
                                                   args)))
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index 27376fc..a8b8974 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -146,12 +146,7 @@ NAME is a symbol: the name of a function, macro, or 
special form.
 HANDLER is a function which takes an argument DO followed by the same
 arguments as NAME.  DO is a function as defined in `gv-get'."
   (declare (indent 1) (debug (sexp form)))
-  ;; Use eval-and-compile so the method can be used in the same file as it
-  ;; is defined.
-  ;; FIXME: Just like byte-compile-macro-environment, we should have something
-  ;; like byte-compile-symbolprop-environment so as to handle these things
-  ;; cleanly without affecting the running Emacs.
-  `(eval-and-compile (put ',name 'gv-expander ,handler)))
+  `(function-put ',name 'gv-expander ,handler))
 
 ;;;###autoload
 (defun gv--defun-declaration (symbol name args handler &optional fix)
diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el
index 433ad38..17891fd 100644
--- a/lisp/emacs-lisp/testcover.el
+++ b/lisp/emacs-lisp/testcover.el
@@ -463,7 +463,10 @@ binding `testcover-vector' to the code-coverage vector for 
TESTCOVER-SYM
   (cond
    ((eq (aref testcover-vector idx) 'unknown)
     (aset testcover-vector idx val))
-   ((not (equal (aref testcover-vector idx) val))
+   ((not (condition-case ()
+             (equal (aref testcover-vector idx) val)
+           ;; TODO: Actually check circular lists for equality.
+           (circular-list nil)))
     (aset testcover-vector idx 'ok-coverage)))
   val)
 
@@ -475,7 +478,10 @@ same value during coverage testing."
    ((eq (aref testcover-vector idx) '1value)
     (aset testcover-vector idx (cons '1value val)))
    ((not (and (eq (car-safe (aref testcover-vector idx)) '1value)
-             (equal (cdr (aref testcover-vector idx)) val)))
+             (condition-case ()
+                  (equal (cdr (aref testcover-vector idx)) val)
+                ;; TODO: Actually check circular lists for equality.
+                (circular-list nil))))
     (error "Value of form marked with `1value' does vary: %s" val)))
   val)
 
diff --git a/src/fns.c b/src/fns.c
index d849618..00b6ed6 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -1987,6 +1987,10 @@ This is the last value stored with `(put SYMBOL PROPNAME 
VALUE)'.  */)
   (Lisp_Object symbol, Lisp_Object propname)
 {
   CHECK_SYMBOL (symbol);
+  Lisp_Object propval = Fplist_get (CDR (Fassq (symbol, 
Voverriding_plist_environment)),
+                                    propname);
+  if (!NILP (propval))
+    return propval;
   return Fplist_get (XSYMBOL (symbol)->plist, propname);
 }
 
@@ -5163,6 +5167,13 @@ syms_of_fns (void)
   DEFSYM (Qcursor_in_echo_area, "cursor-in-echo-area");
   DEFSYM (Qwidget_type, "widget-type");
 
+  DEFVAR_LISP ("overriding-plist-environment", Voverriding_plist_environment,
+               doc: /* An alist overrides the plists of the symbols which it 
lists.
+Used by the byte-compiler to apply `define-symbol-prop' during
+compilation.  */);
+  Voverriding_plist_environment = Qnil;
+  DEFSYM (Qoverriding_plist_environment, "overriding-plist-environment");
+
   staticpro (&string_char_byte_cache_string);
   string_char_byte_cache_string = Qnil;
 
diff --git a/test/lisp/dom-tests.el b/test/lisp/dom-tests.el
index 32d231a..24d4b93 100644
--- a/test/lisp/dom-tests.el
+++ b/test/lisp/dom-tests.el
@@ -26,7 +26,10 @@
 
 (require 'dom)
 (require 'ert)
-(eval-when-compile (require 'subr-x))
+
+;; `defsubst's are not inlined inside `ert-deftest' (see Bug#24402),
+;; therefore we can't use `eval-when-compile' here.
+(require 'subr-x)
 
 (defun dom-tests--tree ()
   "Return a DOM tree for testing."
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el 
b/test/lisp/emacs-lisp/bytecomp-tests.el
index d15bd8b..8ef2ce7 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -545,6 +545,23 @@ literals (Bug#20852)."
 This functionality has been obsolete for more than 10 years already
 and will be removed soon.  See (elisp)Backquote in the manual.")))))))
 
+
+(ert-deftest bytecomp-tests-function-put ()
+  "Check `function-put' operates during compilation."
+  (should (boundp 'lread--old-style-backquotes))
+  (bytecomp-tests--with-temp-file source
+    (dolist (form '((function-put 'bytecomp-tests--foo 'foo 1)
+                    (function-put 'bytecomp-tests--foo 'bar 2)
+                    (defmacro bytecomp-tests--foobar ()
+                      `(cons ,(function-get 'bytecomp-tests--foo 'foo)
+                             ,(function-get 'bytecomp-tests--foo 'bar)))
+                    (defvar bytecomp-tests--foobar 1)
+                    (setq bytecomp-tests--foobar (bytecomp-tests--foobar))))
+      (print form (current-buffer)))
+    (write-region (point-min) (point-max) source nil 'silent)
+    (byte-compile-file source t)
+    (should (equal bytecomp-tests--foobar (cons 1 2)))))
+
 ;; Local Variables:
 ;; no-byte-compile: t
 ;; End:
diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el 
b/test/lisp/emacs-lisp/cl-lib-tests.el
index 65bd97f..9e68dce 100644
--- a/test/lisp/emacs-lisp/cl-lib-tests.el
+++ b/test/lisp/emacs-lisp/cl-lib-tests.el
@@ -518,7 +518,15 @@
 (ert-deftest cl-lib-symbol-macrolet-2 ()
   (should (equal (cl-lib-symbol-macrolet-4+5) (+ 4 5))))
 
+(defun cl-lib-tests--dummy-function ()
+  ;; Dummy function to see if the file is compiled.
+  t)
+
 (ert-deftest cl-lib-defstruct-record ()
+  ;; This test fails when compiled, see Bug#24402/27718.
+  :expected-result (if (byte-code-function-p
+                        (symbol-function 'cl-lib-tests--dummy-function))
+                       :failed :passed)
   (cl-defstruct foo x)
   (let ((x (make-foo :x 42)))
     (should (recordp x))
diff --git a/test/lisp/emacs-lisp/ert-tests.el 
b/test/lisp/emacs-lisp/ert-tests.el
index 57463ad..2fbc188 100644
--- a/test/lisp/emacs-lisp/ert-tests.el
+++ b/test/lisp/emacs-lisp/ert-tests.el
@@ -294,6 +294,15 @@ failed or if there was a problem."
                   "the error signaled was a subtype of the expected type")))))
     ))
 
+(ert-deftest ert-test-should-error-argument ()
+  "Errors due to evaluating arguments should not break tests."
+  (should-error (identity (/ 1 0))))
+
+(ert-deftest ert-test-should-error-macroexpansion ()
+  "Errors due to expanding macros should not break tests."
+  (cl-macrolet ((test () (error "Foo")))
+    (should-error (test))))
+
 (ert-deftest ert-test-skip-unless ()
   ;; Don't skip.
   (let ((test (make-ert-test :body (lambda () (skip-unless t)))))
diff --git a/test/lisp/emacs-lisp/gv-tests.el b/test/lisp/emacs-lisp/gv-tests.el
new file mode 100644
index 0000000..f19af02
--- /dev/null
+++ b/test/lisp/emacs-lisp/gv-tests.el
@@ -0,0 +1,147 @@
+;;; gv-tests.el --- tests for gv.el  -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017 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 <http://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+(eval-when-compile (require 'cl-lib))
+
+(cl-defmacro gv-tests--in-temp-dir ((elvar elcvar)
+                                    (&rest filebody)
+                                    &rest body)
+  (declare (indent 2))
+  `(let ((default-directory (make-temp-file "gv-test" t)))
+     (unwind-protect
+         (let ((,elvar "gv-test-deffoo.el")
+               (,elcvar "gv-test-deffoo.elc"))
+           (with-temp-file ,elvar
+             (insert ";; -*- lexical-binding: t; -*-\n")
+             (dolist (form ',filebody)
+               (pp form (current-buffer))))
+           ,@body)
+       (delete-directory default-directory t))))
+
+(ert-deftest gv-define-expander-in-file ()
+  (gv-tests--in-temp-dir (el elc)
+      ((gv-define-setter gv-test-foo (newval cons)
+         `(setcar ,cons ,newval))
+       (defvar gv-test-pair (cons 1 2))
+       (setf (gv-test-foo gv-test-pair) 99)
+       (message "%d" (car gv-test-pair)))
+    (with-temp-buffer
+      (call-process (concat invocation-directory invocation-name)
+                    nil '(t t) nil
+                    "-Q" "-batch" "--eval" (prin1-to-string 
`(byte-compile-file ,el))
+                    "-l" elc)
+      (should (equal (buffer-string) "99\n")))))
+
+(ert-deftest gv-define-expander-in-file-twice ()
+  (gv-tests--in-temp-dir (el elc)
+      ((gv-define-setter gv-test-foo (newval cons)
+         `(setcar ,cons ,newval))
+       (defvar gv-test-pair (cons 1 2))
+       (setf (gv-test-foo gv-test-pair) 99)
+       (gv-define-setter gv-test-foo (newval cons)
+         `(setcdr ,cons ,newval))
+       (setf (gv-test-foo gv-test-pair) 42)
+       (message "%S" gv-test-pair))
+    (with-temp-buffer
+      (call-process (concat invocation-directory invocation-name)
+                    nil '(t t) nil
+                    "-Q" "-batch" "--eval" (prin1-to-string 
`(byte-compile-file ,el))
+                    "-l" elc)
+      (should (equal (buffer-string) "(99 . 42)\n")))))
+
+(ert-deftest gv-dont-define-expander-in-file ()
+  ;; The expander is defined while we are compiling the file, even
+  ;; though it's inside (when nil ...) because the compiler won't
+  ;; analyze the conditional.
+  :expected-result :failed
+  (gv-tests--in-temp-dir (el elc)
+      ((when nil (gv-define-setter gv-test-foo (newval cons)
+                   `(setcar ,cons ,newval)))
+       (defvar gv-test-pair (cons 1 2))
+       (setf (gv-test-foo gv-test-pair) 99)
+       (message "%d" (car gv-test-pair)))
+    (with-temp-buffer
+      (call-process (concat invocation-directory invocation-name)
+                    nil '(t t) nil
+                    "-Q" "-batch" "--eval" (prin1-to-string 
`(byte-compile-file ,el))
+                    "-l" elc)
+      (should (equal (buffer-string)
+                     "Symbol's function definition is void: \\(setf\\ 
gv-test-foo\\)\n")))))
+
+(ert-deftest gv-define-expander-in-function ()
+  ;; The expander is not defined while we are compiling the file, the
+  ;; compiler won't handle gv definitions not at top-level.
+  :expected-result :failed
+  (gv-tests--in-temp-dir (el elc)
+      ((defun foo ()
+         (gv-define-setter gv-test-foo (newval cons)
+           `(setcar ,cons ,newval))
+         t)
+       (defvar gv-test-pair (cons 1 2))
+       (setf (gv-test-foo gv-test-pair) 99)
+       (message "%d" (car gv-test-pair)))
+    (with-temp-buffer
+      (call-process (concat invocation-directory invocation-name)
+                    nil '(t t) nil
+                    "-Q" "-batch" "--eval" (prin1-to-string 
`(byte-compile-file ,el))
+                    "-l" elc)
+      (should (equal (buffer-string) "99\n")))))
+
+(ert-deftest gv-define-expander-out-of-file ()
+  (gv-tests--in-temp-dir (el elc)
+      ((gv-define-setter gv-test-foo (newval cons)
+         `(setcar ,cons ,newval))
+       (defvar gv-test-pair (cons 1 2)))
+    (with-temp-buffer
+      (call-process (concat invocation-directory invocation-name)
+                    nil '(t t) nil
+                    "-Q" "-batch" "--eval" (prin1-to-string 
`(byte-compile-file ,el))
+                    "-l" elc
+                    "--eval"
+                    (prin1-to-string '(progn (setf (gv-test-foo gv-test-pair) 
99)
+                                             (message "%d" (car 
gv-test-pair)))))
+      (should (equal (buffer-string) "99\n")))))
+
+(ert-deftest gv-dont-define-expander-other-file ()
+  (gv-tests--in-temp-dir (el elc)
+      ((if nil (gv-define-setter gv-test-foo (newval cons)
+                 `(setcar ,cons ,newval)))
+       (defvar gv-test-pair (cons 1 2)))
+    (with-temp-buffer
+      (call-process (concat invocation-directory invocation-name)
+                    nil '(t t) nil
+                    "-Q" "-batch" "--eval" (prin1-to-string 
`(byte-compile-file ,el))
+                    "-l" elc
+                    "--eval"
+                    (prin1-to-string '(progn (setf (gv-test-foo gv-test-pair) 
99)
+                                             (message "%d" (car 
gv-test-pair)))))
+      (should (equal (buffer-string)
+                     "Symbol's function definition is void: \\(setf\\ 
gv-test-foo\\)\n")))))
+
+;; `ert-deftest' messes up macroexpansion when the test file itself is
+;; compiled (see Bug #24402).
+
+;; Local Variables:
+;; no-byte-compile: t
+;; End:
+
+;;; gv-tests.el ends here
diff --git a/test/lisp/emacs-lisp/testcover-resources/testcases.el 
b/test/lisp/emacs-lisp/testcover-resources/testcases.el
index 1eb791a..c9a5a6d 100644
--- a/test/lisp/emacs-lisp/testcover-resources/testcases.el
+++ b/test/lisp/emacs-lisp/testcover-resources/testcases.el
@@ -490,4 +490,14 @@ edebug spec, so testcover needs to cope with that."
 
 (should (eq (testcover-testcase-how-do-i-know-you "Liz") 'unknown))
 
+;; ==== circular-lists-bug-24402 ====
+"Testcover captures and ignores circular list errors."
+;; ====
+(defun testcover-testcase-cyc1 (a)
+  (let ((ls (make-list 10 a%%%)))
+    (nconc ls ls)
+    ls))
+(testcover-testcase-cyc1 1)
+(testcover-testcase-cyc1 1)
+
 ;; testcases.el ends here.