+ (eval backtrace-tests--uncompiled-functions t))

+;;; -*- lexical-binding: t -*-

+(defalias 'foo #'ignore

+ "None of this should be considered too wide.

+

+; this should be treated as 60 characters - no warning

+\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]

+

+; 64 * 'x' does not warn

+\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'

+

+; keymaps are just ignored

+\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>

+

+\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}

+

+bar baz foo bar baz foo bar baz foo bar baz foo bar baz foo bar

+")

+

+ (cond)

+ (mapcar (lambda (x) (cond ((= x 0)))) '(0 1))

+

+ ;; These expressions give different results in lexbind and dynbind modes,

+ ;; but in each the compiler and interpreter should agree!

+ ;; (They look much the same but come in pairs exercising both the

+ ;; `let' and `let*' paths.)

+ (let ((f (lambda (x)

+ (lambda ()

+ (let ((g (lambda () x)))

+ (let ((x 'a))

+ (list x (funcall g))))))))

+ (funcall (funcall f 'b)))

+ (let ((f (lambda (x)

+ (lambda ()

+ (let ((g (lambda () x)))

+ (let* ((x 'a))

+ (list x (funcall g))))))))

+ (funcall (funcall f 'b)))

+ (let ((f (lambda (x)

+ (lambda ()

+ (let ((g (lambda () x)))

+ (setq x (list x x))

+ (let ((x 'a))

+ (list x (funcall g))))))))

+ (funcall (funcall f 'b)))

+ (let ((f (lambda (x)

+ (lambda ()

+ (let ((g (lambda () x)))

+ (setq x (list x x))

+ (let* ((x 'a))

+ (list x (funcall g))))))))

+ (funcall (funcall f 'b)))

+ (let ((f (lambda (x)

+ (let ((g (lambda () x))

+ (h (lambda () (setq x (list x x)))))

+ (let ((x 'a))

+ (list x (funcall g) (funcall h)))))))

+ (funcall (funcall f 'b)))

+ (let ((f (lambda (x)

+ (let ((g (lambda () x))

+ (h (lambda () (setq x (list x x)))))

+ (let* ((x 'a))

+ (list x (funcall g) (funcall h)))))))

+ (funcall (funcall f 'b)))

+

+ ;; Test constant-propagation of access to captured variables.

+ (let* ((x 2)

+ (f (lambda ()

+ (let ((y x)) (list y 3 y)))))

+ (funcall f))

+ (ert-with-temp-file elfile

+ :suffix ".el"

+ (ert-with-temp-file elcfile

+ :suffix ".elc"

+ (with-temp-buffer

+ (dolist (form forms)

+ (print form (current-buffer)))

+ (write-region (point-min) (point-max) elfile nil 'silent))

+ (if compile

+ (let ((byte-compile-dest-file-function

+ (lambda (e) elcfile)))

+ (byte-compile-file elfile)))

+ (load elfile nil 'nomessage))))

+ (re-search-forward ,re-warning nil t))))))

+ "Warning: docstring wider than .* characters")

+ "warn-wide-docstring-ignore-substitutions.el"

+ "defvar .foo-bar. docstring wider than .* characters" 'reverse)

+

+(bytecomp--define-warning-file-test

+ `(ert-with-temp-file ,file-name-var

+ (ert-with-temp-directory directory

+ (let* ((input-file (expand-file-name "test.el" directory))

+ (output-file (expand-file-name "test.elc" directory))

+ (byte-compile-dest-file-function

+ (lambda (_) output-file))

+ (byte-compile-error-on-warn t))

+ (unwind-protect

+ (progn

+ (write-region "" nil input-file nil nil nil 'excl)

+ (write-region "" nil output-file nil nil nil 'excl)

+ (set-file-modes input-file #o400)

+ (set-file-modes output-file #o200)

+ (set-file-modes directory #o500)

+ (should (byte-compile-file input-file))

+ (should (file-regular-p output-file))

+ (should (cl-plusp (file-attribute-size

+ (file-attributes output-file)))))

+ ;; Allow the directory to be deleted.

+ (set-file-modes directory #o777)))))

+ (ert-with-temp-directory directory

+ (let* ((input-file (expand-file-name "test.el" directory))

+ (output-file (expand-file-name "test.elc" directory))

+ (unquoted-file (file-name-unquote output-file))

+ (byte-compile-dest-file-function

+ (lambda (_) output-file))

+ (byte-compile-error-on-warn t))

+ (should-not (file-remote-p input-file))

+ (should-not (file-remote-p output-file))

+ (write-region "" nil input-file nil nil nil 'excl)

+ (write-region "" nil output-file nil nil nil 'excl)

+ (unwind-protect

+ (progn

+ (set-file-modes input-file #o400)

+ (set-file-modes output-file #o200)

+ (set-file-modes directory #o500)

+ (with-temp-buffer

+ (let ((status (call-process

+ bwrap nil t nil

+ "--ro-bind" "/" "/"

+ "--bind" unquoted-file unquoted-file

+ emacs "--quick" "--batch" "--load=bytecomp"

+ (format "--eval=%S"

+ `(setq byte-compile-dest-file-function

+ (lambda (_) ,output-file)

+ byte-compile-error-on-warn t))

+ "--funcall=batch-byte-compile" input-file)))

+ (unless (eql status 0)

+ (ert-fail `((status . ,status)

+ (output . ,(buffer-string)))))))

+ (should (file-regular-p output-file))

+ (should (cl-plusp (file-attribute-size

+ (file-attributes output-file)))))

+ ;; Allow the directory to be deleted.

+ (set-file-modes directory #o777))))))

+ (ert-with-temp-directory directory

+ (let* ((default-directory directory)

+ (byte-compile-dest-file-function (lambda (_) "test.elc"))

+ (byte-compile-error-on-warn t))

+ (write-region "" nil "test.el" nil nil nil 'excl)

+ (should (byte-compile-file "test.el"))

+ (should (file-regular-p "test.elc"))

+ (should (cl-plusp (file-attribute-size

+ (file-attributes "test.elc")))))))

+(require 'generator)

+ (should (string-match "\\`cl-function documentation$" (documentation fun)))

+(defun cconv-tests--intern-all (x)

+ "Intern all symbols in X."

+ (cond ((symbolp x) (intern (symbol-name x)))

+ ((consp x) (cons (cconv-tests--intern-all (car x))

+ (cconv-tests--intern-all (cdr x))))

+ ;; Assume we don't need to deal with vectors etc.

+ (t x)))

+

+(ert-deftest cconv-closure-convert-remap-var ()

+ ;; Verify that we correctly remap shadowed lambda-lifted variables.

+

+ ;; We intern all symbols for ease of comparison; this works because

+ ;; the `cconv-closure-convert' result should contain no pair of

+ ;; distinct symbols having the same name.

+

+ ;; Sanity check: captured variable, no lambda-lifting or shadowing:

+ (should (equal (cconv-tests--intern-all

+ (cconv-closure-convert

+ '#'(lambda (x)

+ #'(lambda () x))))

+ '#'(lambda (x)

+ (internal-make-closure

+ nil (x) nil

+ (internal-get-closed-var 0)))))

+

+ ;; Basic case:

+ (should (equal (cconv-tests--intern-all

+ (cconv-closure-convert

+ '#'(lambda (x)

+ (let ((f #'(lambda () x)))

+ (let ((x 'b))

+ (list x (funcall f)))))))

+ '#'(lambda (x)

+ (let ((f #'(lambda (x) x)))

+ (let ((x 'b)

+ (closed-x x))

+ (list x (funcall f closed-x)))))))

+ (should (equal (cconv-tests--intern-all

+ (cconv-closure-convert

+ '#'(lambda (x)

+ (let ((f #'(lambda () x)))

+ (let* ((x 'b))

+ (list x (funcall f)))))))

+ '#'(lambda (x)

+ (let ((f #'(lambda (x) x)))

+ (let* ((closed-x x)

+ (x 'b))

+ (list x (funcall f closed-x)))))))

+

+ ;; With the lambda-lifted shadowed variable also being captured:

+ (should (equal

+ (cconv-tests--intern-all

+ (cconv-closure-convert

+ '#'(lambda (x)

+ #'(lambda ()

+ (let ((f #'(lambda () x)))

+ (let ((x 'a))

+ (list x (funcall f))))))))

+ '#'(lambda (x)

+ (internal-make-closure

+ nil (x) nil

+ (let ((f #'(lambda (x) x)))

+ (let ((x 'a)

+ (closed-x (internal-get-closed-var 0)))

+ (list x (funcall f closed-x))))))))

+ (should (equal

+ (cconv-tests--intern-all

+ (cconv-closure-convert

+ '#'(lambda (x)

+ #'(lambda ()

+ (let ((f #'(lambda () x)))

+ (let* ((x 'a))

+ (list x (funcall f))))))))

+ '#'(lambda (x)

+ (internal-make-closure

+ nil (x) nil

+ (let ((f #'(lambda (x) x)))

+ (let* ((closed-x (internal-get-closed-var 0))

+ (x 'a))

+ (list x (funcall f closed-x))))))))

+ ;; With lambda-lifted shadowed variable also being mutably captured:

+ (should (equal

+ (cconv-tests--intern-all

+ (cconv-closure-convert

+ '#'(lambda (x)

+ #'(lambda ()

+ (let ((f #'(lambda () x)))

+ (setq x x)

+ (let ((x 'a))

+ (list x (funcall f))))))))

+ '#'(lambda (x)

+ (let ((x (list x)))

+ (internal-make-closure

+ nil (x) nil

+ (let ((f #'(lambda (x) (car-safe x))))

+ (setcar (internal-get-closed-var 0)

+ (car-safe (internal-get-closed-var 0)))

+ (let ((x 'a)

+ (closed-x (internal-get-closed-var 0)))

+ (list x (funcall f closed-x)))))))))

+ (should (equal

+ (cconv-tests--intern-all

+ (cconv-closure-convert

+ '#'(lambda (x)

+ #'(lambda ()

+ (let ((f #'(lambda () x)))

+ (setq x x)

+ (let* ((x 'a))

+ (list x (funcall f))))))))

+ '#'(lambda (x)

+ (let ((x (list x)))

+ (internal-make-closure

+ nil (x) nil

+ (let ((f #'(lambda (x) (car-safe x))))

+ (setcar (internal-get-closed-var 0)

+ (car-safe (internal-get-closed-var 0)))

+ (let* ((closed-x (internal-get-closed-var 0))

+ (x 'a))

+ (list x (funcall f closed-x)))))))))

+ ;; Lambda-lifted variable that isn't actually captured where it is shadowed:

+ (should (equal

+ (cconv-tests--intern-all

+ (cconv-closure-convert

+ '#'(lambda (x)

+ (let ((g #'(lambda () x))

+ (h #'(lambda () (setq x x))))

+ (let ((x 'b))

+ (list x (funcall g) (funcall h)))))))

+ '#'(lambda (x)

+ (let ((x (list x)))

+ (let ((g #'(lambda (x) (car-safe x)))

+ (h #'(lambda (x) (setcar x (car-safe x)))))

+ (let ((x 'b)

+ (closed-x x))

+ (list x (funcall g closed-x) (funcall h closed-x))))))))

+ (should (equal

+ (cconv-tests--intern-all

+ (cconv-closure-convert

+ '#'(lambda (x)

+ (let ((g #'(lambda () x))

+ (h #'(lambda () (setq x x))))

+ (let* ((x 'b))

+ (list x (funcall g) (funcall h)))))))

+ '#'(lambda (x)

+ (let ((x (list x)))

+ (let ((g #'(lambda (x) (car-safe x)))

+ (h #'(lambda (x) (setcar x (car-safe x)))))

+ (let* ((closed-x x)

+ (x 'b))

+ (list x (funcall g closed-x) (funcall h closed-x))))))))

+ )

+

+(require 'ert-x)

+ (ert-with-temp-file file

+ (with-temp-file file

+ (insert

+ (string-join

+ '(";; foo comment"

+ "(declare-function ring-insert \"ring\" (ring item))"

+ "(let ((foo 'code)) foo)")

+ "\n")))

+ (let ((res (check-declare-scan file)))

+ (should (= (length res) 1))

+ (pcase-let ((`((,fnfile ,fn ,arglist ,fileonly)) res))

+ (should (string-match-p "ring" fnfile))

+ (should (equal "ring-insert" fn))

+ (should (equal '(ring item) arglist))

+ (should-not fileonly)))))

+ (ert-with-temp-file file

+ (with-temp-file file

+ (insert

+ (string-join

+ '(";; foo comment"

+ "(defun foo-fun ())"

+ "(defun ring-insert (ring item)"

+ "\"Insert onto ring RING the item ITEM.\""

+ "nil)")

+ "\n")))

+ (should-not

+ (check-declare-verify

+ file '(("foo.el" "ring-insert" (ring item)))))))

+ (ert-with-temp-file file

+ (with-temp-file file

+ (insert

+ (string-join

+ '(";; foo comment"

+ "(defun foo-fun ())"

+ "(defun ring-insert (ring)"

+ "\"Insert onto ring RING the item ITEM.\""

+ "nil)")

+ "\n")))

+ (should

+ (equal

+ (check-declare-verify

+ file '(("foo.el" "ring-insert" (ring item))))

+ '(("foo.el" "ring-insert" "arglist mismatch"))))))

+ (list x y

+ (with-suppressed-warnings ((obsolete cl-next-method-p))

+ (cl-next-method-p))))

+ (cl-list* "quatre"

+ (with-suppressed-warnings ((obsolete cl-next-method-p))

+ (cl-next-method-p))

+ (cl-call-next-method)))

+(ert-deftest cl-constantly ()

+ (should (equal (mapcar (cl-constantly 3) '(a b c d))

+ '(3 3 3 3))))

+

+

+ (eval '(let ((l (list 1))) (cl-symbol-macrolet ((x 1)) (setq (car l) 0))) t))

+ n))

+

+ ;; Tail calls in `cond'.

+ (len4 (xs n)

+ (cond (xs (cond (nil 'nevertrue)

+ ((len4 (cdr xs) (1+ n)))))

+ (t n))))

+ (should (equal (len4 nil 0) 0))

+ (should (equal (len4 list-42 0) 42))

+ (should (equal (len3 list-42k 0) 42000))

+ (should (equal (len4 list-42k 0) 42000))))

+ (`(function (lambda (,_ ,_) . ,_)) t)))

+

+ ;; Verify that there is no tail position inside dynamic variable bindings.

+ (defvar dyn-var)

+ (let ((dyn-var 'a))

+ (cl-labels ((f (x) (if x

+ dyn-var

+ (let ((dyn-var 'b))

+ (f dyn-var)))))

+ (should (equal (f nil) 'b))))

+

+ ;; Control: same as above but with lexical binding.

+ (let ((lex-var 'a))

+ (cl-labels ((f (x) (if x

+ lex-var

+ (let ((lex-var 'b))

+ (f lex-var)))))

+ (should (equal (f nil) 'a)))))

+ (defvar cl-macs--test)

+ (defvar cl-macs--test1)

+ (defvar cl-macs--test2)

+ (should (= (cl-progv '(cl-macs--test cl-macs--test) '(1 2) cl-macs--test) 2))

+ (should (equal (cl-progv '(cl-macs--test1 cl-macs--test2) '(1 2)

+ (list cl-macs--test1 cl-macs--test2))

+ (insert (format "AFP=%s " (let ((x "D")) x (funcall f)))))

+ (insert (format "AFC=%s " (let ((x "D")) x (funcall f)))))

+(defvar-keymap edebug-tests-keymap

+ :doc "Keys used by the keyboard macros in Edebug's tests."

+ "@" 'edebug-tests-call-instrumented-func

+ "C-u" 'universal-argument

+ "C-p" 'previous-line

+ "C-n" 'next-line

+ "C-b" 'backward-char

+ "C-a" 'move-beginning-of-line

+ "C-e" 'move-end-of-line

+ "C-k" 'kill-line

+ "M-x" 'execute-extended-command

+ "C-M-x" 'eval-defun

+ "C-x X b" 'edebug-set-breakpoint

+ "C-x X w" 'edebug-where)

+ (ert-with-temp-file edebug-tests-temp-file

+ :suffix ".el"

+ (let ((edebug-tests-failure-in-post-command nil)

+ (find-file-suppress-same-file-warnings t))

+ (edebug-tests-setup-code-file edebug-tests-temp-file)

+ (ert-with-message-capture

+ edebug-tests-messages

+ (unwind-protect

+ (with-current-buffer (find-file edebug-tests-temp-file)

+ (read-only-mode)

+ (setq lexical-binding t)

+ (eval-buffer)

+ ,@body

+ (when edebug-tests-failure-in-post-command

+ (signal (car edebug-tests-failure-in-post-command)

+ (cdr edebug-tests-failure-in-post-command))))

+ (unload-feature 'edebug-test-code)

+ (with-current-buffer (find-file-noselect edebug-tests-temp-file)

+ (set-buffer-modified-p nil))

+ (ignore-errors (kill-buffer (find-file-noselect

+ edebug-tests-temp-file)))))))))

+ (with-suppressed-warnings ((obsolete edebug-eval-defun))

+ (edebug-eval-defun nil))

+ (with-suppressed-warnings ((obsolete edebug-eval-defun))

+ (edebug-eval-defun t))))

+ (with-suppressed-warnings ((obsolete edebug-eval-defun))

+ (should-error (edebug-eval-defun t)))))

+(require 'eieio-compat)

+(with-suppressed-warnings ((obsolete defmethod)

+ (obsolete defgeneric)

+ (obsolete call-next-method)

+ (obsolete next-method-p))

+ (defmethod eitest-F :BEFORE ((_p eitest-B-base1))

+ (eieio-test-method-store :BEFORE 'eitest-B-base1))

+ (defmethod eitest-F :BEFORE ((_p eitest-B-base2))

+ (eieio-test-method-store :BEFORE 'eitest-B-base2))

+ (defmethod eitest-F :BEFORE ((_p eitest-B))

+ (eieio-test-method-store :BEFORE 'eitest-B))

+ (defmethod eitest-F ((_p eitest-B))

+ (eieio-test-method-store :PRIMARY 'eitest-B)

+ (call-next-method))

+ (defmethod eitest-F ((_p eitest-B-base1))

+ (eieio-test-method-store :PRIMARY 'eitest-B-base1)

+ (defmethod eitest-F ((_p eitest-B-base2))

+ (eieio-test-method-store :PRIMARY 'eitest-B-base2)

+ (when (next-method-p)

+ (call-next-method)))

+ (defmethod eitest-F :AFTER ((_p eitest-B-base1))

+ (eieio-test-method-store :AFTER 'eitest-B-base1))

+ (defmethod eitest-F :AFTER ((_p eitest-B-base2))

+ (eieio-test-method-store :AFTER 'eitest-B-base2))

+

+ (defmethod eitest-F :AFTER ((_p eitest-B))

+ (eieio-test-method-store :AFTER 'eitest-B)))

+(with-suppressed-warnings ((obsolete defmethod)

+ (obsolete defgeneric))

+ (defmethod eitest-H :STATIC ((_class eitest-A))

+ "No need to do work in here."

+ 'moose))

+(with-suppressed-warnings ((obsolete defmethod)

+ (obsolete defgeneric))

+ (defmethod eitest-I :BEFORE ((_a eitest-A))

+ (eieio-test-method-store :BEFORE 'eitest-A)

+ ":before")

+ (defmethod eitest-I :PRIMARY ((_a eitest-A))

+ (eieio-test-method-store :PRIMARY 'eitest-A)

+ ":primary")

+ (defmethod eitest-I :AFTER ((_a eitest-A))

+ (eieio-test-method-store :AFTER 'eitest-A)

+ ":after"))

+(with-suppressed-warnings ((obsolete defmethod)

+ (obsolete defgeneric)

+ (obsolete next-method-p)

+ (obsolete call-next-method))

+ ;; Just use the obsolete name once, to make sure it also works.

+ (defmethod constructor :STATIC ((_p C-base1) &rest _args)

+ (eieio-test-method-store :STATIC 'C-base1)

+ (if (next-method-p) (call-next-method)))

+ (defmethod make-instance :STATIC ((_p C-base2) &rest _args)

+ (eieio-test-method-store :STATIC 'C-base2)

+ (if (next-method-p) (call-next-method))))

+(with-suppressed-warnings ((obsolete defmethod)

+ (obsolete defgeneric)

+ (obsolete call-next-method)

+ (obsolete next-method-p))

+ (defmethod eitest-F ((_p D))

+ "D"

+ (eieio-test-method-store :PRIMARY 'D)

+ (call-next-method))

+ (defmethod eitest-F ((_p D-base0))

+ "D-base0"

+ (eieio-test-method-store :PRIMARY 'D-base0)

+ ;; This should have no next

+ ;; (when (next-method-p) (call-next-method))

+ )

+ (defmethod eitest-F ((_p D-base1))

+ "D-base1"

+ (eieio-test-method-store :PRIMARY 'D-base1)

+

+ (defmethod eitest-F ((_p D-base2))

+ "D-base2"

+ (eieio-test-method-store :PRIMARY 'D-base2)

+ (when (next-method-p)

+ (call-next-method))))

+(with-suppressed-warnings ((obsolete defmethod)

+ (obsolete defgeneric)

+ (obsolete next-method-p)

+ (obsolete call-next-method))

+ (defmethod eitest-F ((_p E))

+ (eieio-test-method-store :PRIMARY 'E)

+ (call-next-method))

+ (defmethod eitest-F ((_p E-base0))

+ (eieio-test-method-store :PRIMARY 'E-base0)

+ ;; This should have no next

+ ;; (when (next-method-p) (call-next-method))

+ )

+ (defmethod eitest-F ((_p E-base1))

+ (eieio-test-method-store :PRIMARY 'E-base1)

+

+ (defmethod eitest-F ((_p E-base2))

+ (eieio-test-method-store :PRIMARY 'E-base2)

+ (when (next-method-p)

+ (call-next-method))))

+(with-suppressed-warnings ((obsolete defmethod)

+ (obsolete defgeneric)

+ (obsolete next-method-p)

+ (obsolete call-next-method))

+ (defmethod initialize-instance :after ((_this eitest-Ja) &rest _slots)

+ ;;(message "+Ja")

+ ;; FIXME: Using next-method-p in an after-method is invalid!

+ (when (next-method-p)

+ (call-next-method))

+ ;;(message "-Ja")

+ ))

+(with-suppressed-warnings ((obsolete defmethod)

+ (obsolete defgeneric)

+ (obsolete next-method-p)

+ (obsolete call-next-method))

+ (defmethod initialize-instance :after ((_this eitest-Jb) &rest _slots)

+ ;;(message "+Jb")

+ ;; FIXME: Using next-method-p in an after-method is invalid!

+ (when (next-method-p)

+ (call-next-method))

+ ;;(message "-Jb")

+ ))

+(with-suppressed-warnings ((obsolete defmethod)

+ (obsolete defgeneric)

+ (obsolete next-method-p)

+ (obsolete call-next-method))

+ (defmethod initialize-instance ((_this eitest-Jd) &rest _slots)

+ ;;(message "+Jd")

+ (when (next-method-p)

+ (call-next-method))

+ ;;(message "-Jd")

+ ))

+(with-suppressed-warnings ((obsolete defmethod)

+ (obsolete defgeneric)

+ (obsolete next-method-p)

+ (obsolete call-next-method))

+ (defmethod CNM-M ((this CNM-0) args)

+ (push (cons 'CNM-0 (copy-sequence args))

+ eieio-test-call-next-method-arguments)

+ (when (next-method-p)

+ (call-next-method

+ this (cons 'CNM-0 args))))

+

+ (defmethod CNM-M ((this CNM-1-1) args)

+ (push (cons 'CNM-1-1 (copy-sequence args))

+ eieio-test-call-next-method-arguments)

+ (when (next-method-p)

+ (call-next-method

+ this (cons 'CNM-1-1 args))))

+

+ (defmethod CNM-M ((_this CNM-1-2) args)

+ (push (cons 'CNM-1-2 (copy-sequence args))

+ eieio-test-call-next-method-arguments)

+ (when (next-method-p)

+ (call-next-method)))

+

+ (defmethod CNM-M ((this CNM-2) args)

+ (push (cons 'CNM-2 (copy-sequence args))

+ eieio-test-call-next-method-arguments)

+ (when (next-method-p)

+ (call-next-method

+ this (cons 'CNM-2 args)))))

+ :initform 'moose)

+(require 'eieio-compat)

+;; Silence byte-compiler.

+(eval-when-compile

+ (dolist (slot '(:a :b ooga-booga :derived-value missing-slot))

+ (cl-pushnew slot eieio--known-slot-names)))

+

+ :initform 'h20

+ (classslot :initform 'penguin

+;; Silence compiler warning about `water' not being a class-allocated slot.

+(defclass eieio-tests--dummy () ((water :allocation :class)))

+

+(with-no-warnings ; FIXME: Make more specific.

+ (defclass class-c ()

+ ((slot-1 :initarg :moose

+ :initform 'moose

+ :type symbol

+ :allocation :instance

+ :documentation "First slot testing slot arguments."

+ :custom symbol

+ :label "Wild Animal"

+ :group borg

+ :protection :public)

+ (slot-2 :initarg :penguin

+ :initform "penguin"

+ :type string

+ :allocation :instance

+ :documentation "Second slot testing slot arguments."

+ :custom string

+ :label "Wild bird"

+ :group vorlon

+ :accessor get-slot-2

+ :protection :private)

+ (slot-3 :initarg :emu

+ :initform 'emu

+ :type symbol

+ :allocation :class

+ :documentation "Third slot test class allocated accessor"

+ :custom symbol

+ :label "Fuzz"

+ :group tokra

+ :accessor get-slot-3

+ :protection :private)

+ )

+ (:custom-groups (foo))

+ "A class for testing slot arguments."

+ ))

+;; Silence byte-compiler.

+(declare-function eitest-subordinate--eieio-childp nil)

+(declare-function class-alloc-initarg--eieio-childp nil)

+ (skip-unless (and (message "foo") (string= "foo" (current-message))))

+ ;; Defining this class should generate a warning(!) message that

+ ;; you should not mix :initarg with class allocated slots.

+ (with-no-warnings ; FIXME: Make more specific.

+ :allocation :class))

+ "Throw a warning mixing allocation class and an initarg."))

+ ;; Check that message is there

+ (should (current-message))

+ (should (string-match "Class allocated slots do not need :initarg"

+ (current-message))))

+(with-suppressed-warnings ((obsolete defgeneric))

+ (defgeneric generic1 () "First generic function."))

+ (with-suppressed-warnings ((obsolete defmethod)

+ (obsolete defgeneric))

+ (defun anormalfunction () "A plain function for error testing." nil)

+ (should-error

+ (progn

+ (defgeneric anormalfunction ()

+ "Attempt to turn it into a generic.")))

+

+ ;; Check that generic-p works

+ (should (generic-p 'generic1))

+

+ (defmethod generic1 ((_c class-a))

+ "Method on generic1."

+ 'monkey)

+

+ (defmethod generic1 (not-an-object)

+ "Method generic1 that can take a non-object."

+ not-an-object)

+

+ (let ((ans-obj (generic1 (class-a)))

+ (ans-num (generic1 666)))

+ (should (eq ans-obj 'monkey))

+ (should (eq ans-num 666)))))

+(with-suppressed-warnings ((obsolete defmethod)

+ (obsolete defgeneric))

+ (defmethod static-method-class-method :STATIC ((c static-method-class) value)

+ "Test static methods.

+ (if (eieio-object-p c) (setq c (eieio-object-class c)))

+ (oset-default c some-slot value)))

+;; Silence byte-compiler.

+(declare-function static-method-class-2 nil)

+(declare-function static-method-class-2--eieio-childp nil)

+ (with-suppressed-warnings ((obsolete defmethod)

+ (obsolete defgeneric))

+ (defmethod static-method-class-method :STATIC ((c static-method-class-2) value)

+ "Test static methods.

+ (if (eieio-object-p c) (setq c (eieio-object-class c)))

+ (oset-default c some-slot (intern (concat "moose-" (symbol-name value))))))

+(with-suppressed-warnings ((obsolete defmethod)

+ (obsolete defgeneric))

+ (defmethod class-cn ((_a class-a))

+ "Try calling `call-next-method' when there isn't one.

+ (with-suppressed-warnings ((obsolete call-next-method))

+ (call-next-method)))

+ (defmethod no-next-method ((_a class-a) &rest _args)

+ "Override signal throwing for variable `class-a'.

+ 'moose))

+(with-suppressed-warnings ((obsolete defmethod)

+ (obsolete defgeneric))

+ (defmethod no-applicable-method ((_b class-b) _method &rest _args)

+ "No need.

+ 'moose))

+(with-suppressed-warnings ((obsolete defmethod)

+ (obsolete defgeneric))

+ (defmethod class-fun ((_a class-a))

+ "Fun with class A."

+ 'moose)

+ (defmethod class-fun ((_b class-b))

+ "Fun with class B."

+ (error "Class B fun should not be called"))

+ (defmethod class-fun-foo ((_b class-b))

+ "Foo Fun with class B."

+ 'moose)

+ (defmethod class-fun2 ((_a class-a))

+ "More fun with class A."

+ 'moose)

+ (defmethod class-fun2 ((_b class-b))

+ "More fun with class B."

+ (error "Class B fun2 should not be called"))

+ (defmethod class-fun2 ((_ab class-ab))

+ "More fun with class AB."

+ (with-suppressed-warnings ((obsolete call-next-method))

+ (call-next-method)))

+ ;; How about if B is the only slot?

+ (defmethod class-fun3 ((_b class-b))

+ "Even More fun with class B."

+ 'moose)

+ (defmethod class-fun3 ((_ab class-ab))

+ "Even More fun with class AB."

+ (with-suppressed-warnings ((obsolete call-next-method))

+ (call-next-method))))

+(with-suppressed-warnings ((obsolete defmethod)

+ (obsolete defgeneric))

+ (defmethod class-fun-value :BEFORE ((_a class-a))

+ "Return `before', and push `before' in `class-fun-value-seq'."

+ (push 'before class-fun-value-seq)

+ 'before)

+

+ (defmethod class-fun-value :PRIMARY ((_a class-a))

+ "Return `primary', and push `primary' in `class-fun-value-seq'."

+ (push 'primary class-fun-value-seq)

+ 'primary)

+

+ (defmethod class-fun-value :AFTER ((_a class-a))

+ "Return `after', and push `after' in `class-fun-value-seq'."

+ (push 'after class-fun-value-seq)

+ 'after))

+ (with-suppressed-warnings ((obsolete defmethod)

+ (obsolete defgeneric)

+ (obsolete call-next-method))

+ (defmethod initialize-instance ((a class-a) &rest _slots)

+ "Initialize the slots of class-a."

+ (call-next-method)

+ (if (/= (oref a test-tag) 1)

+ (error "shared-initialize test failed."))

+ (oset a test-tag 2))

+

+ (defmethod shared-initialize ((a class-a) &rest _slots)

+ "Shared initialize method for class-a."

+ (call-next-method)

+ (oset a test-tag 1))

+

+ (let ((ca (class-a)))

+ (should (= (oref ca test-tag) 2)))))

+ (with-suppressed-warnings ((obsolete defmethod)

+ (obsolete defgeneric))

+ (defmethod slot-missing ((_ab class-ab) &rest _foo)

+ "If a slot in AB is unbound, return something cool. FOO."

+ 'moose))

+(with-suppressed-warnings ((obsolete defmethod)

+ (obsolete defgeneric))

+ (defmethod slot-missing ((vsc virtual-slot-class)

+ slot-name operation &optional new-value)

+ "Simulate virtual slot derived-value."

+ (cond

+ ((or (eq slot-name :derived-value)

+ (eq slot-name 'derived-value))

+ (with-slots (base-value) vsc

+ (if (eq operation 'oref)

+ (+ base-value 1)

+ (setq base-value (- new-value 1)))))

+ (t (with-suppressed-warnings ((obsolete call-next-method))

+ (call-next-method))))))

+ (with-suppressed-warnings ((obsolete defmethod)

+ (obsolete defgeneric))

+ (defmethod slot-unbound ((_a class-a) &rest _foo)

+ "If a slot in A is unbound, ignore FOO."

+ 'moose)

+

+ (should (eq (oref eitest-a water) 'moose))

+

+ ;; Check if oset of unbound works

+ (oset eitest-a water 'moose)

+ (should (eq (oref eitest-a water) 'moose))

+

+ ;; oref/oref-default comparison

+ (should-not (eq (oref eitest-a water) (oref-default eitest-a water)))

+

+ ;; oset-default -> oref/oref-default comparison

+ (oset-default (eieio-object-class eitest-a) water 'moose)

+ (should (eq (oref eitest-a water) (oref-default eitest-a water)))

+

+ ;; After setting 'water to 'moose, make sure a new object has

+ ;; the right stuff.

+ (oset-default (eieio-object-class eitest-a) water 'penguin)

+ (should (eq (oref (class-a) water) 'penguin))

+

+ ;; Revert the above

+ (defmethod slot-unbound ((_a class-a) &rest _foo)

+ "If a slot in A is unbound, ignore FOO."

+ ;; Disable the old slot-unbound so we can run this test

+ ;; more than once

+ (with-suppressed-warnings ((obsolete call-next-method))

+ (call-next-method)))))

+ (symval :initform 'eieio-test-permuting-value)

+;; Silence byte-compiler.

+(declare-function eitest-superior nil)

+(declare-function eitest-superior--eieio-childp nil)

+ ((sub :initform (funcall #'eitest-subordinate)

+;; Silence byte-compiler.

+(declare-function eieio-tests-initform-not-evaluated-when-initarg-is-present nil)

+(declare-function eieio-tests-initform-not-evaluated-when-initarg-is-present--eieio-childp nil)

+(with-suppressed-warnings ((obsolete defmethod)

+ (obsolete defgeneric))

+ (defmethod prot0-slot-2 ((s2 prot-0))

+ "Try to access slot-2 from this class which doesn't have it.

+ (oref s2 slot-2)))

+(with-suppressed-warnings ((obsolete defmethod)

+ (obsolete defgeneric))

+ (defmethod prot1-slot-2 ((s2 prot-1))

+ "Try to access slot-2 in S2."

+ (oref s2 slot-2))

+ (defmethod prot1-slot-2 ((s2 prot-2))

+ "Try to access slot-2 in S2."

+ (oref s2 slot-2))

+ (defmethod prot1-slot-3-only ((s2 prot-1))

+ "Try to access slot-3 in S2.

+ (oref s2 slot-3))

+ (defmethod prot1-slot-3 ((s2 prot-1))

+ "Try to access slot-3 in S2."

+ (oref s2 slot-3))

+ (defmethod prot1-slot-3 ((s2 prot-2))

+ "Try to access slot-3 in S2."

+ (oref s2 slot-3)))

+ ((initform :initform 'init)

+ ((initform :initform 'no-init)

+(with-no-warnings ; FIXME: Make more specific.

+ (defclass slotattr-class-base ()

+ ((initform :allocation :class

+ :initform 'init)

+ (type :allocation :class

+ :type list)

+ (initarg :allocation :class

+ :initarg :initarg)

+ (protection :allocation :class

+ :protection :private)

+ (custom :allocation :class

+ :custom (repeat string)

+ :label "Custom Strings"

+ :group moose)

+ (docstring :allocation :class

+ :documentation

+ "Replace the doc-string for this property.")

+ )

+ "Baseclass we will attempt to subclass.

+Subclasses to override slot attributes."))

+ ((initform :initform 'no-init)

+ ((tracking-symbol :initform 'IT-list)

+(with-suppressed-warnings ((obsolete defmethod)

+ (obsolete defgeneric))

+ (defmethod constructor :static ((_x eieio--testing) newname &rest _args)

+ (list newname 2)))

+ ;; Disable byte-compiler "Warning: Obsolete name arg "toto" to

+ ;; constructor eieio--testing". This could be made more specific

+ ;; with changes to `with-suppressed-warnings', but it's not worth

+ ;; the hassle for just this one test.

+ (with-no-warnings

+ (should (equal (eieio--testing "toto") '("toto" 2)))))

+;;;; Interaction with defstruct

+

+(cl-defstruct eieio-test--struct a b (c nil :read-only t))

+

+(ert-deftest eieio-test-defstruct-slot-value ()

+ (let ((x (make-eieio-test--struct :a 'A :b 'B :c 'C)))

+ (should (eq (eieio-test--struct-a x)

+ (slot-value x 'a)))

+ (should (eq (eieio-test--struct-b x)

+ (slot-value x 'b)))

+ (should (eq (eieio-test--struct-c x)

+ (slot-value x 'c)))

+ (setf (slot-value x 'a) 1)

+ (should (eq (eieio-test--struct-a x) 1))

+ (should-error (setf (slot-value x 'c) 3) :type 'eieio-read-only)))

+ (let ((ert--test-body-was-run nil)

+ (ert--output-buffer-name " *ert self-tests*"))

+ (let ((stats (ert-run-tests-interactively "^ert-")))

+(ert-deftest ert-test-select-undefined ()

+ (let* ((symbol (make-symbol "ert-not-a-test"))

+ (data (should-error (ert-select-tests symbol t)

+ :type 'ert-test-unbound)))

+ (should (eq (cadr data) symbol))))

+

+ (cl-letf* ((buffer-name (generate-new-buffer-name

+ " *ert-test-run-tests*"))

+ (ert--output-buffer-name buffer-name)

+ (messages nil)

+ ((symbol-function 'message)

+ (lambda (format-string &rest args)

+ (push (apply #'format format-string args) messages))))

+ `(member ,passing-test ,failing-test, skipped-test))

+(ert-deftest ert-test-run-tests-batch ()

+ (let* ((complex-list '((:1 (:2 (:3 (:4 (:5 (:6 "abc"))))))))

+ (long-list (make-list 11 1))

+ (failing-test-1

+ (make-ert-test :name 'failing-test-1

+ :body (lambda () (should (equal complex-list 1)))))

+ (failing-test-2

+ (make-ert-test :name 'failing-test-2

+ :body (lambda () (should (equal long-list 1))))))

+ (let ((ert-debug-on-error nil)

+ messages)

+ (cl-letf* (((symbol-function 'message)

+ (lambda (format-string &rest args)

+ (push (apply #'format format-string args) messages))))

+ (save-window-excursion

+ (unwind-protect

+ (let ((case-fold-search nil)

+ (ert-batch-backtrace-right-margin nil)

+ (ert-batch-print-level 10)

+ (ert-batch-print-length 11))

+ (ert-run-tests-batch

+ `(member ,failing-test-1 ,failing-test-2))))))

+ (let ((long-text "(different-types[ \t\n]+(1 1 1 1 1 1 1 1 1 1 1)[ \t\n]+1)))[ \t\n]*$")

+ (complex-text "(different-types[ \t\n]+((:1[ \t\n]+(:2[ \t\n]+(:3[ \t\n]+(:4[ \t\n]+(:5[ \t\n]+(:6[ \t\n]+\"abc\")))))))[ \t\n]+1)))[ \t\n]*$")

+ found-long

+ found-complex)

+ (cl-loop for msg in (reverse messages)

+ do

+ (unless found-long

+ (setq found-long (string-match long-text msg)))

+ (unless found-complex

+ (setq found-complex (string-match complex-text msg))))

+ (should found-long)

+ (should found-complex)))))

+

+(ert-deftest ert-test-run-tests-batch-expensive ()

+ (let* ((complex-list '((:1 (:2 (:3 (:4 (:5 (:6 "abc"))))))))

+ (failing-test-1

+ (make-ert-test :name 'failing-test-1

+ :body (lambda () (should (equal complex-list 1))))))

+ (let ((ert-debug-on-error nil)

+ messages)

+ (cl-letf* (((symbol-function 'message)

+ (lambda (format-string &rest args)

+ (push (apply #'format format-string args) messages))))

+ (save-window-excursion

+ (unwind-protect

+ (let ((case-fold-search nil)

+ (ert-batch-backtrace-right-margin nil)

+ (ert-batch-backtrace-line-length nil)

+ (ert-batch-print-level 6)

+ (ert-batch-print-length 11))

+ (ert-run-tests-batch

+ `(member ,failing-test-1))))))

+ (let ((frame "ert-fail(((should (equal complex-list 1)) :form (equal ((:1 (:2 (:3 (:4 (:5 (:6 \"abc\"))))))) 1) :value nil :explanation (different-types ((:1 (:2 (:3 (:4 (:5 (:6 \"abc\"))))))) 1)))")

+ found-frame)

+ (cl-loop for msg in (reverse messages)

+ do

+ (unless found-frame

+ (setq found-frame (cl-search frame msg :test 'equal))))

+ (should found-frame)))))

+

+ (should-not (ert--explain-equal-including-properties-rec "foo" "foo"))

+ (should-not (ert--explain-equal-including-properties-rec

+ #("foo" 0 3 (a b))

+ (propertize "foo" 'a 'b)))

+ (should-not (ert--explain-equal-including-properties-rec

+ #("foo" 0 3 (a b c d))

+ (propertize "foo" 'a 'b 'c 'd)))

+ (should-not (ert--explain-equal-including-properties-rec

+ #("foo" 0 3 (a (t)))

+ (propertize "foo" 'a (list t))))

+

+ (should (equal (ert--explain-equal-including-properties-rec

+ #("foo" 0 3 (a b c e))

+ (propertize "foo" 'a 'b 'c 'd))

+ '(char 0 "f" (different-properties-for-key c (different-atoms e d))

+ context-before ""

+ context-after "oo")))

+ (should (equal (ert--explain-equal-including-properties-rec

+ #("foo" 0 1 (a b))

+ "foo")

+ '(char 0 "f"

+ (different-properties-for-key a (different-atoms b nil))

+ context-before ""

+ context-after "oo")))

+ (should (equal (ert--explain-equal-including-properties-rec

+ (should (equal (ert--explain-equal-including-properties-rec

+ #("foo" 0 1 (a b c d) 1 3 (a b))

+ #("foo" 0 1 (c d a b) 1 2 (a foo)))

+ '(char 1 "o" (different-properties-for-key a (different-atoms b foo))

+ context-before "f" context-after "o"))))

+ (should (equal-including-properties

+ (should (equal-including-properties

+ (cl-letf* ((passing-test (make-ert-test

+ :name 'passing-test

+ :body (lambda () (ert-pass))))

+ (failing-test (make-ert-test

+ :name 'failing-test

+ :body (lambda ()

+ (ert-info ((propertize "foo\nbar"

+ 'a 'b))

+ (ert-fail

+ "failure message")))))

+ (skipped-test (make-ert-test

+ :name 'skipped-test

+ :body (lambda () (ert-skip

+ "skip message"))))

+ (ert-debug-on-error nil)

+ (messages nil)

+ (buffer-name (generate-new-buffer-name "*ert-test-run-tests*"))

+ ((symbol-function 'message)

+ (lambda (format-string &rest args)

+ (push (apply #'format format-string args) messages)))

+ (ert--output-buffer-name buffer-name))

+ nil "\n (ert-test-failed \"failure message\")\n\n\n")))

+ `(member ,passing-test ,failing-test ,skipped-test))

+ (should (equal-including-properties

+ (should (equal-including-properties

+(ert-deftest ert-x-tests--with-temp-file-generate-suffix ()

+ (should (equal (ert--with-temp-file-generate-suffix "foo.el") "-foo"))

+ (should (equal (ert--with-temp-file-generate-suffix "foo-test.el") "-foo"))

+ (should (equal (ert--with-temp-file-generate-suffix "foo-tests.el") "-foo"))

+ (should (equal (ert--with-temp-file-generate-suffix "foo-bar-baz.el")

+ "-foo-bar-baz"))

+ (should (equal (ert--with-temp-file-generate-suffix "/foo/bar/baz.el")

+ "-baz")))

+

+(ert-deftest ert-x-tests-with-temp-file ()

+ (let (saved)

+ (ert-with-temp-file fil

+ (setq saved fil)

+ (should (file-exists-p fil))

+ (should (file-regular-p fil)))

+ (should-not (file-exists-p saved))))

+

+(ert-deftest ert-x-tests-with-temp-file/handle-error ()

+ (let (saved)

+ (ignore-errors

+ (ert-with-temp-file fil

+ (setq saved fil)

+ (error "foo")))

+ (should-not (file-exists-p saved))))

+

+(ert-deftest ert-x-tests-with-temp-file/prefix-and-suffix-kwarg ()

+ (ert-with-temp-file fil

+ :prefix "foo"

+ :suffix "bar"

+ (should (string-match "foo.*bar" fil))))

+

+(ert-deftest ert-x-tests-with-temp-file/text-kwarg ()

+ (ert-with-temp-file fil

+ :text "foobar3"

+ (let ((buf (find-file-noselect fil)))

+ (unwind-protect

+ (with-current-buffer buf

+ (should (equal (buffer-string) "foobar3")))

+ (kill-buffer buf)))))

+

+(ert-deftest ert-x-tests-with-temp-file/unknown-kwarg-signals-error ()

+ (should-error

+ (ert-with-temp-file fil :foo "foo" nil)))

+

+(ert-deftest ert-x-tests-with-temp-directory ()

+ (let (saved)

+ (ert-with-temp-directory dir

+ (setq saved dir)

+ (should (file-exists-p dir))

+ (should (file-directory-p dir))

+ (should (equal dir (file-name-as-directory dir))))

+ (should-not (file-exists-p saved))))

+

+(ert-deftest ert-x-tests-with-temp-directory/text-signals-error ()

+ (should-error

+ (ert-with-temp-directory dir :text "foo" nil)))

+(cps-testcase cps-function (progn #'message))

+(cps-testcase cps-let*-shadow-empty (let* ((i 10)) i (let ((i nil)) i)))

+(cps-testcase cps-let-shadow-empty (let ((i 10)) i (let ((i nil)) i)))

+ (let* ((a 5) (b 6)) a (let* ((a b) (b a)) (list a b))))

+(ert-deftest cps-loop-2 ()

+(defun generator-tests-edebug ()) ; silence byte-compiler

+(require 'ert-x)

+ `(ert-with-temp-directory default-directory

+ (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)))

+ (should (= 1 (eval (let-alist--list-to-sexp '(a b c d) ''((d (c (b (a . 1)))))) t)))

+(defvar c-e-x)

+ (should (eq 3 (eval ``,,'(+ 1 2) t))))

+ (insert (eval contents t))

+;; This file is part of GNU Emacs.

+

+;; GNU Emacs is free software: you can redistribute it and/or modify

+;; GNU Emacs is distributed in the hope that it will be useful,

+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.

+;; This file is part of GNU Emacs.

+

+;; GNU Emacs is free software: you can redistribute it and/or modify

+;; GNU Emacs is distributed in the hope that it will be useful,

+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.

+;;; vk.el --- test code for macroexp-tests -*- lexical-binding: t -*-

+

+;; Copyright (C) 2021 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 <https://www.gnu.org/licenses/>.

+

+;;; Code:

+

+(require 'macroexp)

+

+(defmacro vk-variable-kind (var)

+ (if (macroexp--dynamic-variable-p var) ''dyn ''lex))

+

+(defvar vk-a 1)

+(defconst vk-b 2)

+(defvar vk-c)

+

+(defun vk-f1 (x)

+ (defvar vk-u1)

+ (let ((vk-a 10)

+ (vk-b 20)

+ (vk-c 30)

+ (vk-u1 40)

+ (y 50))

+ (ignore vk-a vk-b vk-c vk-u1 x y)

+ (list

+ (vk-variable-kind vk-a) ; dyn

+ (vk-variable-kind vk-b) ; dyn

+ (vk-variable-kind vk-c) ; dyn

+ (vk-variable-kind vk-u1) ; dyn

+ (vk-variable-kind x) ; lex

+ (vk-variable-kind y)))) ; lex

+

+(eval-and-compile

+ (defvar vk-u2)

+ (defun vk-f2 (x)

+ (defvar vk-v2)

+ (let ((vk-u2 11)

+ (vk-v2 12)

+ (y 13))

+ (ignore vk-u2 vk-v2 x y)

+ (list

+ (vk-variable-kind vk-u2) ; dyn

+ (vk-variable-kind vk-v2) ; dyn

+ (vk-variable-kind x) ; lex

+ (vk-variable-kind y))))) ; lex

+

+(eval-when-compile

+ (defvar vk-u3)

+ (defun vk-f3 (x)

+ (defvar vk-v3)

+ (let ((vk-a 23)

+ (vk-b 24)

+ (vk-u3 25)

+ (vk-v3 26)

+ (y 27))

+ (ignore vk-a vk-b vk-u3 vk-v3 x y)

+ (list

+ (vk-variable-kind vk-a) ; dyn

+ (vk-variable-kind vk-b) ; dyn

+ (vk-variable-kind vk-u3) ; dyn

+ (vk-variable-kind vk-v3) ; dyn

+ (vk-variable-kind x) ; lex

+ (vk-variable-kind y))))) ; lex

+

+(defconst vk-val3 (eval-when-compile (vk-f3 0)))

+

+(defconst vk-f4 '(lambda (x)

+ (defvar vk-v4)

+ (let ((vk-v4 31)

+ (y 32))

+ (ignore vk-v4 x y)

+ (list

+ (vk-variable-kind vk-a) ; dyn

+ (vk-variable-kind vk-b) ; dyn

+ (vk-variable-kind vk-v4) ; dyn

+ (vk-variable-kind x) ; dyn

+ (vk-variable-kind y))))) ; dyn

+

+(defconst vk-f5 '(closure (t) (x)

+ (defvar vk-v5)

+ (let ((vk-v5 41)

+ (y 42))

+ (ignore vk-v5 x y)

+ (list

+ (vk-variable-kind vk-a) ; dyn

+ (vk-variable-kind vk-b) ; dyn

+ (vk-variable-kind vk-v5) ; dyn

+ (vk-variable-kind x) ; lex

+ (vk-variable-kind y))))) ; lex

+

+(defun vk-f6 ()

+ (eval '(progn

+ (defvar vk-v6)

+ (let ((vk-v6 51)

+ (y 52))

+ (ignore vk-v6 y)

+ (list

+ (vk-variable-kind vk-a) ; dyn

+ (vk-variable-kind vk-b) ; dyn

+ (vk-variable-kind vk-v6) ; dyn

+ (vk-variable-kind vk-y)))))) ; dyn

+

+(defun vk-f7 ()

+ (eval '(progn

+ (defvar vk-v7)

+ (let ((vk-v7 51)

+ (y 52))

+ (ignore vk-v7 y)

+ (list

+ (vk-variable-kind vk-a) ; dyn

+ (vk-variable-kind vk-b) ; dyn

+ (vk-variable-kind vk-v7) ; dyn

+ (vk-variable-kind vk-y)))) ; lex

+ t))

+

+(provide 'vk)

+;; This file is part of GNU Emacs.

+

+;; GNU Emacs is free software: you can redistribute it and/or modify

+;; GNU Emacs is distributed in the hope that it will be useful,

+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.

+(require 'macroexp)

+(require 'ert-x)

+

+(defun macroexp-tests--run-emacs (&rest args)

+ "Run Emacs in batch mode with ARGS, return output."

+ (let ((emacs (expand-file-name invocation-name invocation-directory)))

+ (with-temp-buffer

+ (let ((res (apply #'call-process emacs nil t nil

+ "-Q" "--batch" args))

+ (output (buffer-string)))

+ (unless (equal res 0)

+ (message "%s" output)

+ (error "Inferior Emacs exited with status %S" res))

+ output))))

+

+(defun macroexp-tests--eval-in-subprocess (file expr)

+ (let ((output (macroexp-tests--run-emacs

+ "-l" file (format "--eval=(print %S)" expr))))

+ (car (read-from-string output))))

+

+(defun macroexp-tests--byte-compile-in-subprocess (file)

+ "Byte-compile FILE using a subprocess to avoid contaminating the lisp state."

+ (let ((output (macroexp-tests--run-emacs "-f" "batch-byte-compile" file)))

+ (when output

+ (message "%s" output))))

+

+(ert-deftest macroexp--tests-dynamic-variable-p ()

+ "Test `macroexp--dynamic-variable-p'."

+ (let* ((vk-el (ert-resource-file "vk.el"))

+ (vk-elc (concat vk-el "c"))

+ (expr '(list (vk-f1 0)

+ (vk-f2 0)

+ vk-val3

+ (funcall vk-f4 0)

+ (funcall vk-f5 0)

+ (vk-f6)

+ (vk-f7))))

+ ;; We compile and run the test in separate processes for complete

+ ;; isolation between test cases.

+ (should (equal (macroexp-tests--eval-in-subprocess vk-el expr)

+ '((dyn dyn dyn dyn lex lex)

+ (dyn dyn lex lex)

+ (dyn dyn dyn dyn lex lex)

+ (dyn dyn dyn dyn dyn)

+ (dyn dyn dyn lex lex)

+ (dyn dyn dyn dyn)

+ (dyn dyn dyn lex))))

+ (macroexp-tests--byte-compile-in-subprocess vk-el)

+ (should (equal (macroexp-tests--eval-in-subprocess vk-elc expr)

+ '((dyn dyn dyn dyn lex lex)

+ (dyn dyn lex lex)

+ (dyn dyn dyn dyn lex lex)

+ (dyn dyn dyn dyn dyn)

+ (dyn dyn dyn lex lex)

+ (dyn dyn dyn dyn)

+ (dyn dyn dyn lex))))))

+;;; multisession-tests.el --- Tests for multisession.el -*- lexical-binding: t; -*-

+

+;; Copyright (C) 2021 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 <https://www.gnu.org/licenses/>.

+

+;;; Commentary:

+

+;;; Code:

+

+(require 'multisession)

+(require 'ert)

+(require 'ert-x)

+(require 'cl-lib)

+

+(declare-function sqlite-close "sqlite.c")

+

+(ert-deftest multi-test-sqlite-simple ()

+ (skip-unless (sqlite-available-p))

+ (ert-with-temp-file dir

+ :directory t

+ (let ((user-init-file "/tmp/foo.el")

+ (multisession-storage 'sqlite)

+ (multisession-directory dir))

+ (unwind-protect

+ (progn

+ (define-multisession-variable multisession--foo 0

+ ""

+ :synchronized t)

+ (should (= (multisession-value multisession--foo) 0))

+ (cl-incf (multisession-value multisession--foo))

+ (should (= (multisession-value multisession--foo) 1))

+ (call-process

+ (concat invocation-directory invocation-name)

+ nil t nil

+ "-Q" "-batch"

+ "--eval" (prin1-to-string

+ `(progn

+ (require 'multisession)

+ (let ((multisession-directory ,dir)

+ (multisession-storage 'sqlite)

+ (user-init-file "/tmp/foo.el"))

+ (define-multisession-variable multisession--foo 0

+ ""

+ :synchronized t)

+ (cl-incf (multisession-value multisession--foo))))))

+ (should (= (multisession-value multisession--foo) 2)))

+ (sqlite-close multisession--db)

+ (setq multisession--db nil)))))

+

+(ert-deftest multi-test-sqlite-busy ()

+ (skip-unless (sqlite-available-p))

+ (ert-with-temp-file dir

+ :directory t

+ (let ((user-init-file "/tmp/foo.el")

+ (multisession-directory dir)

+ (multisession-storage 'sqlite)

+ proc)

+ (unwind-protect

+ (progn

+ (define-multisession-variable multisession--bar 0

+ ""

+ :synchronized t)

+ (should (= (multisession-value multisession--bar) 0))

+ (cl-incf (multisession-value multisession--bar))

+ (should (= (multisession-value multisession--bar) 1))

+ (setq proc

+ (start-process

+ "other-emacs"

+ nil

+ (concat invocation-directory invocation-name)

+ "-Q" "-batch"

+ "--eval" (prin1-to-string

+ `(progn

+ (require 'multisession)

+ (let ((multisession-directory ,dir)

+ (multisession-storage 'sqlite)

+ (user-init-file "/tmp/bar.el"))

+ (define-multisession-variable multisession--bar 0

+ "" :synchronized t)

+ (dotimes (i 100)

+ (cl-incf (multisession-value multisession--bar))))))))

+ (while (process-live-p proc)

+ (ignore-error 'sqlite-locked-error

+ (message "multisession--bar %s" (multisession-value multisession--bar))

+ ;;(cl-incf (multisession-value multisession--bar))

+ )

+ (sleep-for 0.1))

+ (message "multisession--bar ends up as %s" (multisession-value multisession--bar))

+ (should (< (multisession-value multisession--bar) 1003)))

+ (sqlite-close multisession--db)

+ (setq multisession--db nil)))))

+

+(ert-deftest multi-test-files-simple ()

+ (ert-with-temp-file dir

+ :directory t

+ (let ((user-init-file "/tmp/sfoo.el")

+ (multisession-storage 'files)

+ (multisession-directory dir))

+ (define-multisession-variable multisession--sfoo 0

+ ""

+ :synchronized t)

+ (should (= (multisession-value multisession--sfoo) 0))

+ (cl-incf (multisession-value multisession--sfoo))

+ (should (= (multisession-value multisession--sfoo) 1))

+ ;; On Windows and Haiku, we don't have sub-second resolution, so

+ ;; let some time pass to make the "later" logic work.

+ (when (memq system-type '(windows-nt haiku))

+ (sleep-for 0.6))

+ (call-process

+ (concat invocation-directory invocation-name)

+ nil t nil

+ "-Q" "-batch"

+ "--eval" (prin1-to-string

+ `(progn

+ (require 'multisession)

+ (let ((multisession-directory ,dir)

+ (multisession-storage 'files)

+ (user-init-file "/tmp/sfoo.el"))

+ (define-multisession-variable multisession--sfoo 0

+ ""

+ :synchronized t)

+ (cl-incf (multisession-value multisession--sfoo))))))

+ (should (= (multisession-value multisession--sfoo) 2)))))

+

+(ert-deftest multi-test-files-busy ()

+ (skip-unless (sqlite-available-p))

+ (ert-with-temp-file dir

+ :directory t

+ (let ((user-init-file "/tmp/foo.el")

+ (multisession-storage 'files)

+ (multisession-directory dir)

+ proc)

+ (define-multisession-variable multisession--sbar 0

+ ""

+ :synchronized t)

+ (should (= (multisession-value multisession--sbar) 0))

+ (cl-incf (multisession-value multisession--sbar))

+ (should (= (multisession-value multisession--sbar) 1))

+ (setq proc

+ (start-process

+ "other-emacs"

+ nil

+ (concat invocation-directory invocation-name)

+ "-Q" "-batch"

+ "--eval" (prin1-to-string

+ `(progn

+ (require 'multisession)

+ (let ((multisession-directory ,dir)

+ (multisession-storage 'files)

+ (user-init-file "/tmp/sbar.el"))

+ (define-multisession-variable multisession--sbar 0

+ "" :synchronized t)

+ (dotimes (i 100)

+ (cl-incf (multisession-value multisession--sbar))))))))

+ (while (process-live-p proc)

+ (message "multisession--sbar %s" (multisession-value multisession--sbar))

+ ;;(cl-incf (multisession-value multisession--sbar))

+ (sleep-for 0.1))

+ (message "multisession--sbar ends up as %s" (multisession-value multisession--sbar))

+ (should (< (multisession-value multisession--sbar) 200)))))

+

+(ert-deftest multi-test-files-some-values ()

+ (ert-with-temp-file dir

+ :directory t

+ (let ((user-init-file "/tmp/sfoo.el")

+ (multisession-storage 'files)

+ (multisession-directory dir))

+ (define-multisession-variable multisession--foo1 nil)

+ (should (eq (multisession-value multisession--foo1) nil))

+ (setf (multisession-value multisession--foo1) nil)

+ (should (eq (multisession-value multisession--foo1) nil))

+ (setf (multisession-value multisession--foo1) t)

+ (should (eq (multisession-value multisession--foo1) t))

+

+ (define-multisession-variable multisession--foo2 t)

+ (setf (multisession-value multisession--foo2) nil)

+ (should (eq (multisession-value multisession--foo2) nil))

+ (setf (multisession-value multisession--foo2) t)

+ (should (eq (multisession-value multisession--foo2) t))

+

+ (define-multisession-variable multisession--foo3 t)

+ (should-error (setf (multisession-value multisession--foo3) (make-marker)))

+

+ (let ((string (with-temp-buffer

+ (set-buffer-multibyte nil)

+ (insert 0 1 2)

+ (buffer-string))))

+ (should-not (multibyte-string-p string))

+ (define-multisession-variable multisession--foo4 nil)

+ (setf (multisession-value multisession--foo4) string)

+ (should (equal (multisession-value multisession--foo4) string))))))

+

+;;; multisession-tests.el ends here

+;;; macro-builtin-aux.el --- laksd -*- lexical-binding: t; -*-

+

+;; Author: Artur Malabarba <emacs@endlessparentheses.com>

+

+;;; Code:

+

+(defun macro-builtin-aux-1 ( &rest forms)

+ "Description"

+ `(progn ,@forms))

+

+(provide 'macro-builtin-aux)

+;;; macro-builtin-aux.el ends here

+;;; macro-builtin.el --- laksd -*- lexical-binding: t; -*-

+

+;; Author: Artur Malabarba <emacs@endlessparentheses.com>

+;; Keywords: tools

+;; Version: 1.0

+

+;;; Code:

+

+(require 'macro-builtin-aux)

+

+(defmacro macro-builtin-1 ( &rest forms)

+ "Description"

+ `(progn ,@forms))

+

+(defun macro-builtin-func ()

+ ""

+ (macro-builtin-1 'a 'b)

+ (macro-builtin-aux-1 'a 'b))

+

+(provide 'macro-builtin)

+;;; macro-builtin.el ends here

+;;; macro-builtin-aux.el --- laksd -*- lexical-binding: t; -*-

+

+;; Author: Artur Malabarba <emacs@endlessparentheses.com>

+

+;;; Code:

+

+(defmacro macro-builtin-aux-1 ( &rest forms)

+ "Description"

+ `(progn ,@forms))

+

+(defmacro macro-builtin-aux-3 ( &rest _)

+ "Description"

+ 90)

+

+(provide 'macro-builtin-aux)

+;;; macro-builtin-aux.el ends here

+;;; macro-builtin.el --- laksd -*- lexical-binding: t; -*-

+

+;; Author: Artur Malabarba <emacs@endlessparentheses.com>

+;; Keywords: tools

+;; Version: 2.0

+

+;;; Code:

+

+(require 'macro-builtin-aux)

+

+(defmacro macro-builtin-1 ( &rest forms)

+ "Description"

+ `(progn ,(cadr (car forms))))

+

+

+(defun macro-builtin-func ()

+ ""

+ (list (macro-builtin-1 '1 'b)

+ (macro-builtin-aux-1 'a 'b)))

+

+(defmacro macro-builtin-3 (&rest _)

+ "Description"

+ 10)

+

+(defun macro-builtin-10-and-90 ()

+ ""

+ (list (macro-builtin-3 haha) (macro-builtin-aux-3 hehe)))

+

+(provide 'macro-builtin)

+;;; macro-builtin.el ends here

+ `(ert-with-temp-directory package-test-user-dir

+ (let* ((process-environment (cons (format "HOME=%s" package-test-user-dir)

+ process-environment))

+ (package-user-dir package-test-user-dir)

+ (package-gnupghome-dir (expand-file-name "gnupg" package-user-dir))

+ (package-archives `(("gnu" . ,(or ,location package-test-data-dir))))

+ (default-directory package-test-file-dir)

+ abbreviated-home-dir

+ package--initialized

+ package-alist

+ ,@(if update-news

+ '(package-update-news-on-upload t)

+ (list (cl-gensym)))

+ ,@(if upload-base

+ '((package-test-archive-upload-base (make-temp-file "pkg-archive-base-" t))

+ (package-archive-upload-base package-test-archive-upload-base))

+ (list (cl-gensym)))) ;; Dummy value so `let' doesn't try to bind nil

+ (let ((buf (get-buffer "*Packages*")))

+ (when (buffer-live-p buf)

+ (kill-buffer buf)))

+ (unwind-protect

+ (progn

+ ,(if basedir `(cd ,basedir))

+ (unless (file-directory-p package-user-dir)

+ (mkdir package-user-dir))

+ (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) t))

+ ((symbol-function 'y-or-n-p) (lambda (&rest _) t)))

+ ,@(when install

+ `((package-initialize)

+ (package-refresh-contents)

+ (mapc 'package-install ,install)))

+ (with-temp-buffer

+ ,(if file

+ `(insert-file-contents ,file))

+ ,@body)))

+

+ (when ,upload-base

+ (dolist (f '("archive-contents"

+ "simple-single-1.3.el"

+ "simple-single-1.4.el"

+ "simple-single-readme.txt"))

+ (ignore-errors

+ (delete-file

+ (expand-file-name f package-test-archive-upload-base))))

+ (delete-directory package-test-archive-upload-base))

+

+ (when (and (boundp 'package-test-archive-upload-base)

+ (file-directory-p package-test-archive-upload-base))

+ (delete-directory package-test-archive-upload-base t))))))

+(declare-function macro-builtin-func "macro-builtin" ())

+(declare-function macro-builtin-10-and-90 "macro-builtin" ())

+ "\"Activation has to be done before compilation, so that if we're

+ upgrading and macros have changed we load the new definitions

+ before compiling.\" -- package.el"

+(ert-deftest package-test-macro-compilation-gz ()

+ "Built-in's can be superseded as well."

+ (with-package-test (:basedir (ert-resource-directory))

+ (let ((dir (expand-file-name "macro-builtin-package-1.0")))

+ (unwind-protect

+ (let ((load-path load-path))

+ (add-to-list 'load-path (directory-file-name dir))

+ (byte-recompile-directory dir 0 t)

+ (mapc (lambda (f) (call-process "gzip" nil nil nil f))

+ (directory-files-recursively dir "\\`[^\\.].*\\.el\\'"))

+ (require 'macro-builtin)

+ (should (member (expand-file-name "macro-builtin-aux.elc" dir)

+ (mapcar #'car load-history)))

+ ;; `macro-builtin-func' uses a macro from `macro-aux'.

+ (should (equal (macro-builtin-func) '(progn a b)))

+ (package-install-file (expand-file-name "macro-builtin-package-2.0/"))

+ ;; After upgrading, `macro-builtin-func' depends on a new version

+ ;; of the macro from `macro-builtin-aux'.

+ (should (equal (macro-builtin-func) '(1 b)))

+ ;; `macro-builtin-10-and-90' depends on an entirely new macro from `macro-aux'.

+ (should (equal (macro-builtin-10-and-90) '(10 90))))

+ (mapc #'delete-file

+ (directory-files-recursively dir "\\`[^\\.].*\\.elc\\'"))

+ (mapc (lambda (f) (call-process "gunzip" nil nil nil f))

+ (directory-files-recursively dir "\\`[^\\.].*\\.el\\.gz\\'"))))))

+

+ (skip-unless (ert-with-temp-directory homedir

+ (let ((process-environment

+ (cons (concat "HOME=" homedir)

+ process-environment)))

+ (require 'epg-config)

+ (defvar epg-config--program-alist)

+ (epg-find-configuration

+ 'OpenPGP nil

+ ;; By default we require gpg2 2.1+ due to some

+ ;; practical problems with pinentry. But this

+ ;; test works fine with 2.0 as well.

+ (let ((prog-alist (copy-tree epg-config--program-alist)))

+ (setf (alist-get "gpg2"

+ (alist-get 'OpenPGP prog-alist)

+ nil nil #'equal)

+ "2.0")

+ prog-alist)))))

+ (should-error

+ ;; Avoid error at compile time due to compiler macro.

+ (eval '(pcase 1

+ ((cl-type notatype) 'integer))

+ t)))

+Code:

+ (lambda ()

+ (emacs-lisp-mode)

+ (let ((code (read (current-buffer))))

+ (erase-buffer)

+ (pp-emacs-lisp-code code)

+ (untabify (point-min) (point-max))))

+

+Name: code-formats1

+

+=-=

+(defun foo (bar)

+ "Yes."

+ (let ((a 1)

+ (b 2))

+ (zot 1 2 (funcall bar 2))))

+=-=-=

+

+

+Name: code-formats2

+

+=-=

+(defun pp-emacs-lisp-code (sexp)

+ "Insert SEXP into the current buffer, formatted as Emacs Lisp code."

+ (require 'edebug)

+ (let ((start (point))

+ (standard-output (current-buffer)))

+ (pp--insert-lisp sexp)

+ (insert "\n")

+ (goto-char start)

+ (indent-sexp)))

+=-=-=

+

+

+Name: code-formats3

+

+=-=

+(defun foo (bar)

+ "Yes."

+ (let ((a 1)

+ (b 2))

+ (zot-zot-zot-zot-zot-zot 1 2 (funcall

+ bar-bar-bar-bar-bar-bar-bar-bar-bar-bar

+ 2))))

+=-=-=

+

+

+Name: code-formats4

+

+=-=

+(defun foo (bar)

+ "Yes."

+ (let ((a 1)

+ (b 2)

+ foo bar zotfoo bar zotfoo bar zotfoo bar zotfoo bar zotfoo bar zotfoo

+ bar zot)

+ (zot 1 2 (funcall bar 2))))

+=-=-=

+

+

+Name: code-formats5

+

+=-=

+(defgroup pp ()

+ "Pretty printer for Emacs Lisp."

+ :prefix "pp-"

+ :group 'lisp)

+=-=-=

+

+Name: code-formats6

+

+=-=

+(defcustom pp-escape-newlines t

+ "Value of `print-escape-newlines' used by pp-* functions."

+ :type 'boolean

+ :group 'pp)

+=-=-=

+

+Name: code-formats7

+

+=-=

+(defun pp (object &optional stream)

+ (princ (pp-to-string object) (or stream standard-output)))

+=-=-=

+

+

+Name: code-formats8

+

+=-=

+(defun pp-eval-expression (expression)

+ "Evaluate EXPRESSION and pretty-print its value.

+Also add the value to the front of the list in the variable `values'."

+ (interactive (list (read--expression "Eval: ")))

+ (message "Evaluating...")

+ (let ((result (eval expression lexical-binding)))

+ (values--store-value result)

+ (pp-display-expression result "*Pp Eval Output*")))

+=-=-=

+

+Name: code-formats9

+

+=-=

+(lambda ()

+ (interactive)

+ 1)

+=-=-=

+

+

+Name: code-formats10

+

+=-=

+(funcall foo (concat "zot" (if (length> site 0) site

+ "bar")

+ "+"

+ (string-replace " " "+" query)))

+=-=-=

+

+

+Name: code-formats11

+

+=-=

+(lambda ()

+ [(foo bar) (foo bar)])

+=-=-=

+(require 'ert-x)

+(ert-deftest test-indentation ()

+ (ert-test-erts-file (ert-resource-file "code-formats.erts")))

+

+(ert-deftest ring-tests-insert-2 ()

+(require 'cl-lib)

+(ert-deftest test-rmc--add-key-description ()

+ (cl-letf (((symbol-function 'display-supports-face-attributes-p) (lambda (_ _) t)))

+ (should (equal (rmc--add-key-description '(?y "yes"))

+ '(?y . "yes")))

+ (should (equal (rmc--add-key-description '(?n "foo"))

+ '(?n . "n foo")))

+ (should (equal (rmc--add-key-description '(?\s "foo bar"))

+ `(?\s . "SPC foo bar")))))

+

+(ert-deftest test-rmc--add-key-description/with-attributes ()

+ (cl-letf (((symbol-function 'display-supports-face-attributes-p) (lambda (_ _) t)))

+ (should (equal-including-properties

+ (rmc--add-key-description '(?y "yes"))

+ `(?y . ,(concat (propertize "y" 'face 'read-multiple-choice-face) "es"))))

+ (should (equal-including-properties

+ (rmc--add-key-description '(?n "foo"))

+ `(?n . ,(concat (propertize "n" 'face 'read-multiple-choice-face) " foo"))))

+ (should (equal-including-properties

+ (rmc--add-key-description '(?\s "foo bar"))

+ `(?\s . ,(concat (propertize "SPC" 'face 'read-multiple-choice-face) " foo bar"))))))

+

+(ert-deftest test-rmc--add-key-description/non-graphical-display ()

+ (cl-letf (((symbol-function 'display-supports-face-attributes-p) (lambda (_ _) nil)))

+ (should (equal-including-properties

+ (rmc--add-key-description '(?y "yes"))

+ '(?y . "[Y]es")))

+ (should (equal-including-properties

+ (rmc--add-key-description '(?n "foo"))

+ `(?n . ,(concat (propertize "n" 'face 'help-key-binding) " foo"))))))

+ (with-suppressed-warnings ((obsolete seq-contains))

+ (with-test-sequences (seq '(3 4 5 6))

+ (should (seq-contains seq 3))

+ (should-not (seq-contains seq 7)))

+ (with-test-sequences (seq '())

+ (should-not (seq-contains seq 3))

+ (should-not (seq-contains seq nil)))))

+ (with-suppressed-warnings ((obsolete seq-contains))

+ (with-test-sequences (seq '(3 4 5 6))

+ (should (= 5 (seq-contains seq 5))))))

+ (let ((seq nil))

+ (let ((seq nil) a b c)

+ (let ((z nil))

+ (let ((d nil))

+ (let ((a-called nil) (b-called nil) c-called)

+ (let ((a-called nil) (b-called nil) c-called)

+ (let ((a-called nil) (b-called nil) c-called)

+ (b (setq b-called t))

+ (c nil)

+ (d (setq c-called t)))

+ (let ((z nil))

+ (let ((d nil))

+ (let ((a-called nil) (b-called nil) (c-called nil))

+ (let ((a-called nil) (b-called nil) (c-called nil))

+ (let ((a-called nil) (b-called nil) (c-called nil))

+(ert-deftest subr-ensure-empty-lines ()

+ (should

+ (equal

+ (with-temp-buffer

+ (insert "foo")

+ (goto-char (point-min))

+ (ensure-empty-lines 2)

+ (buffer-string))

+ "\n\nfoo"))

+ (should

+ (equal

+ (with-temp-buffer

+ (insert "foo")

+ (ensure-empty-lines 2)

+ (buffer-string))

+ "foo\n\n\n"))

+ (should

+ (equal

+ (with-temp-buffer

+ (insert "foo\n")

+ (ensure-empty-lines 2)

+ (buffer-string))

+ "foo\n\n\n"))

+ (should

+ (equal

+ (with-temp-buffer

+ (insert "foo\n\n\n\n\n")

+ (ensure-empty-lines 2)

+ (buffer-string))

+ "foo\n\n\n"))

+ (should

+ (equal

+ (with-temp-buffer

+ (insert "foo\n\n\n")

+ (ensure-empty-lines 0)

+ (buffer-string))

+ "foo\n")))

+

+(ert-deftest subr-x-test-add-display-text-property ()

+ (with-temp-buffer

+ (insert "Foo bar zot gazonk")

+ (add-display-text-property 4 8 'height 2.0)

+ (add-display-text-property 2 12 'raise 0.5)

+ (should (equal (get-text-property 2 'display) '(raise 0.5)))

+ (should (equal (get-text-property 5 'display)

+ '((raise 0.5) (height 2.0))))

+ (should (equal (get-text-property 9 'display) '(raise 0.5))))

+ (with-temp-buffer

+ (insert "Foo bar zot gazonk")

+ (put-text-property 4 8 'display [(height 2.0)])

+ (add-display-text-property 2 12 'raise 0.5)

+ (should (equal (get-text-property 2 'display) '(raise 0.5)))

+ (should (equal (get-text-property 5 'display)

+ [(raise 0.5) (height 2.0)]))

+ (should (equal (get-text-property 9 'display) '(raise 0.5)))))

+

+(ert-deftest subr-x-named-let ()

+ (let ((funs ()))

+ (named-let loop

+ ((rest '(1 42 3))

+ (sum 0))

+ (when rest

+ ;; Here, we make sure that the variables are distinct in every

+ ;; iteration, since a naive tail-call optimization would tend to end up

+ ;; with a single `sum' variable being shared by all the closures.

+ (push (lambda () sum) funs)

+ ;; Here we add a dummy `sum' variable which shadows the `sum' iteration

+ ;; variable since a naive tail-call optimization could also trip here

+ ;; thinking it can `(setq sum ...)' to set the iteration

+ ;; variable's value.

+ (let ((sum sum))

+ (loop (cdr rest) (+ sum (car rest))))))

+ (should (equal (mapcar #'funcall funs) '(43 1 0)))))

+

+ `(eval (aref ,vec%%% ,arg%%%) t)%%%)

+ (ert-with-temp-file tempfile

+ :suffix ".el"

+ (let ((find-file-suppress-same-file-warnings t)

+ (code (buffer-substring beg end))

+ (marked-up-code))

+ (unwind-protect

+ (progn

+ (with-temp-file tempfile

+ (insert code))

+ (save-current-buffer

+ (let ((buf (find-file-noselect tempfile)))

+ (set-buffer buf)

+ (apply 'testcover-start (cons tempfile optargs))

+ (testcover-mark-all buf)

+ (dolist (overlay (overlays-in (point-min) (point-max)))

+ (let ((ov-face (overlay-get overlay 'face)))

+ (goto-char (overlay-end overlay))

+ (cond

+ ((eq ov-face 'testcover-nohits) (insert "!!!"))

+ ((eq ov-face 'testcover-1value) (insert "%%%"))

+ (t nil))))

+ (setq marked-up-code (buffer-string)))

+ (set-buffer-modified-p nil)))

+ (ignore-errors (kill-buffer (find-file-noselect tempfile))))

+

+ ;; Now replace the original code with the marked up code.

+ (delete-region beg end)

+ (insert marked-up-code)))))

+ (ert-with-temp-file tempfile

+ :suffix ".el"

+ (let ((find-file-suppress-same-file-warnings t))

+ (unwind-protect

+ (progn

+ (with-temp-file tempfile

+ (insert marked-up-code))

+ ;; Remove the marks and mark the code up again. The original

+ ;; and recreated versions should match.

+ (save-current-buffer

+ (set-buffer (find-file-noselect tempfile))

+ ;; Fail the test if the debugger tries to become active,

+ ;; which can happen if Testcover fails to attach itself

+ ;; correctly. Note that this will prevent debugging

+ ;; these tests using Edebug.

+ (cl-letf (((symbol-function #'edebug-default-enter)

+ (lambda (&rest _args)

+ (ert-fail "Debugger invoked during test run"))))

+ (dolist (byte-compile '(t nil))

+ (testcover-tests-unmarkup-region (point-min) (point-max))

+ (unwind-protect

+ (testcover-tests-markup-region (point-min) (point-max) byte-compile)

+ (set-buffer-modified-p nil))

+ (should (string= marked-up-code

+ (buffer-string)))))))

+ (ignore-errors (kill-buffer (find-file-noselect tempfile))))))))

+ (when (fboundp 'debug-timer-check) ; silence byte-compiler

+ (should (debug-timer-check))))