Commit bec5b602 authored by Noam Postavsky's avatar Noam Postavsky
Browse files

; Merge: Fixes for macroexpansion and compilation

parents e6fa0836 79a74568
......@@ -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
......
......@@ -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)
......
......@@ -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)))
......
......@@ -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)
......
......@@ -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)
......
......@@ -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;
......
......@@ -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."
......
......@@ -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:
......
......@@ -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))
......
......@@ -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)))))
......
;;; 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
......@@ -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.
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment