mirror of
https://github.com/masscollaborationlabs/emacs.git
synced 2025-07-09 05:30:50 +00:00
ecf08f0621
dc4e6b1329; Update copyright years in more files64b3777631; Run set-copyright from admin.el8e1c56ae46; Add 2024 to copyright years # Conflicts: # doc/misc/modus-themes.org # doc/misc/texinfo.tex # etc/NEWS # etc/refcards/ru-refcard.tex # etc/themes/modus-operandi-theme.el # etc/themes/modus-themes.el # etc/themes/modus-vivendi-theme.el # lib/alloca.in.h # lib/binary-io.h # lib/c-ctype.h # lib/c-strcasecmp.c # lib/c-strncasecmp.c # lib/careadlinkat.c # lib/cloexec.c # lib/close-stream.c # lib/diffseq.h # lib/dup2.c # lib/filemode.h # lib/fpending.c # lib/fpending.h # lib/fsusage.c # lib/getgroups.c # lib/getloadavg.c # lib/gettext.h # lib/gettime.c # lib/gettimeofday.c # lib/group-member.c # lib/malloc.c # lib/md5-stream.c # lib/md5.c # lib/md5.h # lib/memmem.c # lib/memrchr.c # lib/nanosleep.c # lib/save-cwd.h # lib/sha1.c # lib/sig2str.c # lib/stdlib.in.h # lib/strtoimax.c # lib/strtol.c # lib/strtoll.c # lib/time_r.c # lib/xalloc-oversized.h # lisp/auth-source-pass.el # lisp/emacs-lisp/lisp-mnt.el # lisp/emacs-lisp/timer.el # lisp/info-look.el # lisp/jit-lock.el # lisp/loadhist.el # lisp/mail/rmail.el # lisp/net/ntlm.el # lisp/net/webjump.el # lisp/progmodes/asm-mode.el # lisp/progmodes/project.el # lisp/progmodes/sh-script.el # lisp/textmodes/flyspell.el # lisp/textmodes/reftex-toc.el # lisp/textmodes/reftex.el # lisp/textmodes/tex-mode.el # lisp/url/url-gw.el # m4/alloca.m4 # m4/clock_time.m4 # m4/d-type.m4 # m4/dirent_h.m4 # m4/dup2.m4 # m4/euidaccess.m4 # m4/fchmodat.m4 # m4/filemode.m4 # m4/fsusage.m4 # m4/getgroups.m4 # m4/getloadavg.m4 # m4/getrandom.m4 # m4/gettime.m4 # m4/gettimeofday.m4 # m4/gnulib-common.m4 # m4/group-member.m4 # m4/inttypes.m4 # m4/malloc.m4 # m4/manywarnings.m4 # m4/mempcpy.m4 # m4/memrchr.m4 # m4/mkostemp.m4 # m4/mktime.m4 # m4/nproc.m4 # m4/nstrftime.m4 # m4/pathmax.m4 # m4/pipe2.m4 # m4/pselect.m4 # m4/pthread_sigmask.m4 # m4/readlink.m4 # m4/realloc.m4 # m4/sig2str.m4 # m4/ssize_t.m4 # m4/stat-time.m4 # m4/stddef_h.m4 # m4/stdint.m4 # m4/stdio_h.m4 # m4/stdlib_h.m4 # m4/stpcpy.m4 # m4/strnlen.m4 # m4/strtoimax.m4 # m4/strtoll.m4 # m4/time_h.m4 # m4/timegm.m4 # m4/timer_time.m4 # m4/timespec.m4 # m4/unistd_h.m4 # m4/warnings.m4 # nt/configure.bat # nt/preprep.c # test/lisp/register-tests.el
393 lines
16 KiB
EmacsLisp
393 lines
16 KiB
EmacsLisp
;;; cconv-tests.el --- Tests for cconv.el -*- lexical-binding: t -*-
|
|
|
|
;; Copyright (C) 2018-2024 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 'ert)
|
|
(require 'cl-lib)
|
|
(require 'generator)
|
|
(require 'bytecomp)
|
|
|
|
(ert-deftest cconv-tests-lambda-:documentation ()
|
|
"Docstring for lambda can be specified with :documentation."
|
|
(let ((fun (lambda ()
|
|
(:documentation (concat "lambda" " documentation"))
|
|
'lambda-result)))
|
|
(should (string= (documentation fun) "lambda documentation"))
|
|
(should (eq (funcall fun) 'lambda-result))))
|
|
|
|
(ert-deftest cconv-tests-pcase-lambda-:documentation ()
|
|
"Docstring for pcase-lambda can be specified with :documentation."
|
|
(let ((fun (pcase-lambda (`(,a ,b))
|
|
(:documentation (concat "pcase-lambda" " documentation"))
|
|
(list b a))))
|
|
(should (string= (documentation fun) "pcase-lambda documentation"))
|
|
(should (equal '(2 1) (funcall fun '(1 2))))))
|
|
|
|
(defun cconv-tests-defun ()
|
|
(:documentation (concat "defun" " documentation"))
|
|
'defun-result)
|
|
(ert-deftest cconv-tests-defun-:documentation ()
|
|
"Docstring for defun can be specified with :documentation."
|
|
(should (string= (documentation 'cconv-tests-defun)
|
|
"defun documentation"))
|
|
(should (eq (cconv-tests-defun) 'defun-result)))
|
|
|
|
(cl-defun cconv-tests-cl-defun ()
|
|
(:documentation (concat "cl-defun" " documentation"))
|
|
'cl-defun-result)
|
|
(ert-deftest cconv-tests-cl-defun-:documentation ()
|
|
"Docstring for cl-defun can be specified with :documentation."
|
|
(should (string= (documentation 'cconv-tests-cl-defun)
|
|
"cl-defun documentation"))
|
|
(should (eq (cconv-tests-cl-defun) 'cl-defun-result)))
|
|
|
|
;; FIXME: The byte-compiler croaks on this. See Bug#28557.
|
|
;; (defmacro cconv-tests-defmacro ()
|
|
;; (:documentation (concat "defmacro" " documentation"))
|
|
;; '(quote defmacro-result))
|
|
;; (ert-deftest cconv-tests-defmacro-:documentation ()
|
|
;; "Docstring for defmacro can be specified with :documentation."
|
|
;; (should (string= (documentation 'cconv-tests-defmacro)
|
|
;; "defmacro documentation"))
|
|
;; (should (eq (cconv-tests-defmacro) 'defmacro-result)))
|
|
|
|
;; FIXME: The byte-compiler croaks on this. See Bug#28557.
|
|
;; (cl-defmacro cconv-tests-cl-defmacro ()
|
|
;; (:documentation (concat "cl-defmacro" " documentation"))
|
|
;; '(quote cl-defmacro-result))
|
|
;; (ert-deftest cconv-tests-cl-defmacro-:documentation ()
|
|
;; "Docstring for cl-defmacro can be specified with :documentation."
|
|
;; (should (string= (documentation 'cconv-tests-cl-defmacro)
|
|
;; "cl-defmacro documentation"))
|
|
;; (should (eq (cconv-tests-cl-defmacro) 'cl-defmacro-result)))
|
|
|
|
(cl-iter-defun cconv-tests-cl-iter-defun ()
|
|
(:documentation (concat "cl-iter-defun" " documentation"))
|
|
(iter-yield 'cl-iter-defun-result))
|
|
(ert-deftest cconv-tests-cl-iter-defun-:documentation ()
|
|
"Docstring for cl-iter-defun can be specified with :documentation."
|
|
(should (string= (documentation 'cconv-tests-cl-iter-defun)
|
|
"cl-iter-defun documentation"))
|
|
(should (eq (iter-next (cconv-tests-cl-iter-defun))
|
|
'cl-iter-defun-result)))
|
|
|
|
(iter-defun cconv-tests-iter-defun ()
|
|
(:documentation (concat "iter-defun" " documentation"))
|
|
(iter-yield 'iter-defun-result))
|
|
(ert-deftest cconv-tests-iter-defun-:documentation ()
|
|
"Docstring for iter-defun can be specified with :documentation."
|
|
(should (string= (documentation 'cconv-tests-iter-defun)
|
|
"iter-defun documentation"))
|
|
(should (eq (iter-next (cconv-tests-iter-defun)) 'iter-defun-result)))
|
|
|
|
(ert-deftest cconv-tests-iter-lambda-:documentation ()
|
|
"Docstring for iter-lambda can be specified with :documentation."
|
|
(let ((iter-fun
|
|
(iter-lambda ()
|
|
(:documentation (concat "iter-lambda" " documentation"))
|
|
(iter-yield 'iter-lambda-result))))
|
|
(should (string= (documentation iter-fun) "iter-lambda documentation"))
|
|
(should (eq (iter-next (funcall iter-fun)) 'iter-lambda-result))))
|
|
|
|
(ert-deftest cconv-tests-cl-function-:documentation ()
|
|
"Docstring for cl-function can be specified with :documentation."
|
|
(let ((fun (cl-function (lambda (&key arg)
|
|
(:documentation (concat "cl-function"
|
|
" documentation"))
|
|
(list arg 'cl-function-result)))))
|
|
(should (string-match "\\`cl-function documentation$" (documentation fun)))
|
|
(should (equal (funcall fun :arg t) '(t cl-function-result)))))
|
|
|
|
(ert-deftest cconv-tests-function-:documentation ()
|
|
"Docstring for lambda inside function can be specified with :documentation."
|
|
(let ((fun #'(lambda (arg)
|
|
(:documentation (concat "function" " documentation"))
|
|
(list arg 'function-result))))
|
|
(should (string= (documentation fun) "function documentation"))
|
|
(should (equal (funcall fun t) '(t function-result)))))
|
|
|
|
(fmakunbound 'cconv-tests-cl-defgeneric)
|
|
(setplist 'cconv-tests-cl-defgeneric nil)
|
|
(cl-defgeneric cconv-tests-cl-defgeneric (n)
|
|
(:documentation (concat "cl-defgeneric" " documentation")))
|
|
(cl-defmethod cconv-tests-cl-defgeneric ((n integer))
|
|
(:documentation (concat "cl-defmethod" " documentation"))
|
|
(+ 1 n))
|
|
(ert-deftest cconv-tests-cl-defgeneric-:documentation ()
|
|
"Docstring for cl-defgeneric can be specified with :documentation."
|
|
(let ((descr (describe-function 'cconv-tests-cl-defgeneric)))
|
|
(set-text-properties 0 (length descr) nil descr)
|
|
(should (string-match-p "cl-defgeneric documentation" descr))
|
|
(should (string-match-p "cl-defmethod documentation" descr)))
|
|
(should (= 11 (cconv-tests-cl-defgeneric 10))))
|
|
|
|
(fmakunbound 'cconv-tests-cl-defgeneric-literal)
|
|
(setplist 'cconv-tests-cl-defgeneric-literal nil)
|
|
(cl-defgeneric cconv-tests-cl-defgeneric-literal (n)
|
|
(:documentation "cl-defgeneric-literal documentation"))
|
|
(cl-defmethod cconv-tests-cl-defgeneric-literal ((n integer))
|
|
(:documentation "cl-defmethod-literal documentation")
|
|
(+ 1 n))
|
|
(ert-deftest cconv-tests-cl-defgeneric-literal-:documentation ()
|
|
"Docstring for cl-defgeneric can be specified with :documentation."
|
|
(let ((descr (describe-function 'cconv-tests-cl-defgeneric-literal)))
|
|
(set-text-properties 0 (length descr) nil descr)
|
|
(should (string-match-p "cl-defgeneric-literal documentation" descr))
|
|
(should (string-match-p "cl-defmethod-literal documentation" descr)))
|
|
(should (= 11 (cconv-tests-cl-defgeneric-literal 10))))
|
|
|
|
(defsubst cconv-tests-defsubst ()
|
|
(:documentation (concat "defsubst" " documentation"))
|
|
'defsubst-result)
|
|
(ert-deftest cconv-tests-defsubst-:documentation ()
|
|
"Docstring for defsubst can be specified with :documentation."
|
|
(should (string= (documentation 'cconv-tests-defsubst)
|
|
"defsubst documentation"))
|
|
(should (eq (cconv-tests-defsubst) 'defsubst-result)))
|
|
|
|
(cl-defsubst cconv-tests-cl-defsubst ()
|
|
(:documentation (concat "cl-defsubst" " documentation"))
|
|
'cl-defsubst-result)
|
|
(ert-deftest cconv-tests-cl-defsubst-:documentation ()
|
|
"Docstring for cl-defsubst can be specified with :documentation."
|
|
(should (string= (documentation 'cconv-tests-cl-defsubst)
|
|
"cl-defsubst documentation"))
|
|
(should (eq (cconv-tests-cl-defsubst) 'cl-defsubst-result)))
|
|
|
|
(ert-deftest cconv-convert-lambda-lifted ()
|
|
;; Verify that lambda-lifting is actually performed at all.
|
|
(should (equal (cconv-closure-convert
|
|
'#'(lambda (x) (let ((f #'(lambda () (+ x 1))))
|
|
(funcall f))))
|
|
'#'(lambda (x) (let ((f #'(lambda (x) (+ x 1))))
|
|
(funcall f x)))))
|
|
|
|
;; Bug#30872.
|
|
(should
|
|
(equal (funcall
|
|
(byte-compile
|
|
'#'(lambda (handle-fun arg)
|
|
(let* ((subfun
|
|
#'(lambda (params)
|
|
(ignore handle-fun)
|
|
(funcall #'(lambda () (setq params 42)))
|
|
params)))
|
|
(funcall subfun arg))))
|
|
nil 99)
|
|
42)))
|
|
|
|
(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))))))))
|
|
)
|
|
|
|
(ert-deftest cconv-tests-interactive-closure-bug51695 ()
|
|
(let ((f (let ((d 51695))
|
|
(lambda (data)
|
|
(interactive (progn (setq d (1+ d)) (list d)))
|
|
(list (called-interactively-p 'any) data))))
|
|
(f-interp
|
|
(eval '(let ((d 51695))
|
|
(lambda (data)
|
|
(interactive (progn (setq d (1+ d)) (list d)))
|
|
(list (called-interactively-p 'any) data)))
|
|
t)))
|
|
(dolist (f (list f f-interp))
|
|
(should (equal (list (call-interactively f)
|
|
(funcall f 51695)
|
|
(call-interactively f))
|
|
'((t 51696) (nil 51695) (t 51697)))))))
|
|
|
|
(ert-deftest cconv-safe-for-space ()
|
|
(let* ((magic-string "This-is-a-magic-string")
|
|
(safe-p (lambda (x) (not (string-match magic-string (format "%S" x))))))
|
|
(should (funcall safe-p (lambda (x) (+ x 1))))
|
|
(should (funcall safe-p (eval '(lambda (x) (+ x 1))
|
|
`((y . ,magic-string)))))
|
|
(should (funcall safe-p (eval '(lambda (x) :closure-dont-trim-context)
|
|
`((y . ,magic-string)))))
|
|
(should-not (funcall safe-p
|
|
(eval '(lambda (x) :closure-dont-trim-context (+ x 1))
|
|
`((y . ,magic-string)))))))
|
|
|
|
(ert-deftest cconv-tests-interactive-form-modify-bug60974 ()
|
|
(let* ((f '(function (lambda (&optional arg)
|
|
(interactive
|
|
(list (if current-prefix-arg
|
|
(prefix-numeric-value current-prefix-arg)
|
|
'toggle)))
|
|
(ignore arg))))
|
|
(if (cadr (nth 2 (cadr f))))
|
|
(if2))
|
|
(cconv-closure-convert f)
|
|
(setq if2 (cadr (nth 2 (cadr f))))
|
|
(should (eq if if2))))
|
|
|
|
(provide 'cconv-tests)
|
|
;;; cconv-tests.el ends here
|