Mercurial > hg > xemacs-beta

comparison tests/automated/lisp-tests.el @ 5576:071b810ceb18

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Declare labels as line where appropriate; use #'labels, not #'flet, tests. lisp/ChangeLog addition: 2011-10-03 Aidan Kehoe <kehoea@parhasard.net> * simple.el (handle-pre-motion-command-current-command-is-motion): Implement #'keysyms-equal with #'labels + (declare (inline ...)), instead of abusing macrolet to the same end. * specifier.el (let-specifier): * mule/mule-cmds.el (describe-language-environment): * mule/mule-cmds.el (set-language-environment-coding-systems): * mule/mule-x-init.el (x-use-halfwidth-roman-font): * faces.el (Face-frob-property): * keymap.el (key-sequence-list-description): * lisp-mode.el (construct-lisp-mode-menu): * loadhist.el (unload-feature): * mouse.el (default-mouse-track-check-for-activation): Declare various labels inline in dumped files when that reduces the size of the dumped image. Declaring labels inline is normally only worthwhile for inner loops and so on, but it's reasonable exercise of the related code to have these changes in core. tests/ChangeLog addition: 2011-10-03 Aidan Kehoe <kehoea@parhasard.net> * automated/case-tests.el (uni-mappings): * automated/database-tests.el (delete-database-files): * automated/hash-table-tests.el (iterations): * automated/lisp-tests.el (test1): * automated/lisp-tests.el (a): * automated/lisp-tests.el (cl-floor): * automated/lisp-tests.el (foo): * automated/lisp-tests.el (list-nreverse): * automated/lisp-tests.el (needs-lexical-context): * automated/mule-tests.el (featurep): * automated/os-tests.el (original-string): * automated/os-tests.el (with): * automated/symbol-tests.el (check-weak-list-unique): Replace #'flet with #'labels where appropriate in these tests, following my own advice on style in the docstrings of those functions.
author Aidan Kehoe <kehoea@parhasard.net>
date Mon, 03 Oct 2011 20:16:14 +0100
parents d4f334808463
children 391d809fa4e9
comparison
equal deleted inserted replaced
5575:89cb6a66a61f 5576:071b810ceb18
568 (Check-Error wrong-number-of-arguments (mod 1 2 3)) 568 (Check-Error wrong-number-of-arguments (mod 1 2 3))
569 569
570 (Check-Error wrong-type-argument (% 10.0 2)) 570 (Check-Error wrong-type-argument (% 10.0 2))
571 (Check-Error wrong-type-argument (% 10 2.0)) 571 (Check-Error wrong-type-argument (% 10 2.0))
572 572
573 (flet ((test1 (x) (Assert (eql x (+ (% x 17) (* (/ x 17) 17))) x)) 573 (labels ((test1 (x) (Assert (eql x (+ (% x 17) (* (/ x 17) 17))) x))
574 (test2 (x) (Assert (eql (- x) (+ (% (- x) 17) (* (/ (- x) 17) 17))) x)) 574 (test2 (x) (Assert (eql (- x) (+ (% (- x) 17) (* (/ (- x) 17) 17))) x))
575 (test3 (x) (Assert (eql x (+ (% (- x) 17) (* (/ (- x) 17) 17))) x)) 575 (test3 (x) (Assert (eql x (+ (% (- x) 17) (* (/ (- x) 17) 17))) x))
576 (test4 (x) (Assert (eql (% x -17) (- (% (- x) 17))) x)) 576 (test4 (x) (Assert (eql (% x -17) (- (% (- x) 17))) x))
577 (test5 (x) (Assert (eql (% x -17) (% (- x) 17))) x)) 577 (test5 (x) (Assert (eql (% x -17) (% (- x) 17))) x))
578 (test1 most-negative-fixnum) 578 (test1 most-negative-fixnum)
579 (if (featurep 'bignum) 579 (if (featurep 'bignum)
580 (progn 580 (progn
581 (test2 most-negative-fixnum) 581 (test2 most-negative-fixnum)
582 (test4 most-negative-fixnum)) 582 (test4 most-negative-fixnum))
857 (Assert (eq (assoc "6" x) nil)) 857 (Assert (eq (assoc "6" x) nil))
858 (Assert (eq (assq "6" x) nil)) 858 (Assert (eq (assq "6" x) nil))
859 (Assert (eq (rassoc "6" x) nil)) 859 (Assert (eq (rassoc "6" x) nil))
860 (Assert (eq (rassq "6" x) nil))) 860 (Assert (eq (rassq "6" x) nil)))
861 861
862 (flet ((a () (list '(1 . 2) 3 '(4 . 5)))) 862 (labels ((a () (list '(1 . 2) 3 '(4 . 5))))
863 (Assert (let* ((x (a)) (y (remassoc 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) 863 (Assert (let* ((x (a)) (y (remassoc 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
864 (Assert (let* ((x (a)) (y (remassq 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) 864 (Assert (let* ((x (a)) (y (remassq 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
865 (Assert (let* ((x (a)) (y (remrassoc 1 x))) (and (eq x y) (equal y (a))))) 865 (Assert (let* ((x (a)) (y (remrassoc 1 x))) (and (eq x y) (equal y (a)))))
866 (Assert (let* ((x (a)) (y (remrassq 1 x))) (and (eq x y) (equal y (a))))) 866 (Assert (let* ((x (a)) (y (remrassq 1 x))) (and (eq x y) (equal y (a)))))
867 867
897 (Assert (let* ((x (a)) (y (old-delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) 897 (Assert (let* ((x (a)) (y (old-delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
898 (Assert (let* ((x (a)) (y (old-delq '(1 . 2) x))) (and (eq x y) (equal y (a))))) 898 (Assert (let* ((x (a)) (y (old-delq '(1 . 2) x))) (and (eq x y) (equal y (a)))))
899 (Assert (let* ((x (a)) (y (old-delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) 899 (Assert (let* ((x (a)) (y (old-delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
900 (Assert (let* ((x (a)) (y (old-delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))))) 900 (Assert (let* ((x (a)) (y (old-delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))))
901 901
902 (flet ((a () (list '("1" . "2") "3" '("4" . "5")))) 902 (labels ((a () (list '("1" . "2") "3" '("4" . "5"))))
903 (Assert (let* ((x (a)) (y (remassoc "1" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5")))))) 903 (Assert (let* ((x (a)) (y (remassoc "1" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5"))))))
904 (Assert (let* ((x (a)) (y (remassq "1" x))) (and (eq x y) (equal y (a))))) 904 (Assert (let* ((x (a)) (y (remassq "1" x))) (and (eq x y) (equal y (a)))))
905 (Assert (let* ((x (a)) (y (remrassoc "1" x))) (and (eq x y) (equal y (a))))) 905 (Assert (let* ((x (a)) (y (remrassoc "1" x))) (and (eq x y) (equal y (a)))))
906 (Assert (let* ((x (a)) (y (remrassq "1" x))) (and (eq x y) (equal y (a))))) 906 (Assert (let* ((x (a)) (y (remrassq "1" x))) (and (eq x y) (equal y (a)))))
907 907
1526 (set-buffer-modified-p nil) 1526 (set-buffer-modified-p nil)
1527 (kill-buffer nil) 1527 (kill-buffer nil)
1528 (load test-file-name nil t nil) 1528 (load test-file-name nil t nil)
1529 (delete-file test-file-name)) 1529 (delete-file test-file-name))
1530 1530
1531 (flet ((cl-floor (x &optional y) 1531 (labels ((cl-floor (x &optional y)
1532 (let ((q (floor x y))) 1532 (let ((q (floor x y)))
1533 (list q (- x (if y (* y q) q))))) 1533 (list q (- x (if y (* y q) q)))))
1534 (cl-ceiling (x &optional y) 1534 (cl-ceiling (x &optional y)
1535 (let ((res (cl-floor x y))) 1535 (let ((res (cl-floor x y)))
1536 (if (= (car (cdr res)) 0) res 1536 (if (= (car (cdr res)) 0) res
1537 (list (1+ (car res)) (- (car (cdr res)) (or y 1)))))) 1537 (list (1+ (car res)) (- (car (cdr res)) (or y 1))))))
1538 (cl-truncate (x &optional y) 1538 (cl-truncate (x &optional y)
1539 (if (eq (>= x 0) (or (null y) (>= y 0))) 1539 (if (eq (>= x 0) (or (null y) (>= y 0)))
1540 (cl-floor x y) (cl-ceiling x y))) 1540 (cl-floor x y) (cl-ceiling x y)))
1541 (cl-round (x &optional y) 1541 (cl-round (x &optional y)
1542 (if y 1542 (if y
1543 (if (and (integerp x) (integerp y)) 1543 (if (and (integerp x) (integerp y))
1544 (let* ((hy (/ y 2)) 1544 (let* ((hy (/ y 2))
1545 (res (cl-floor (+ x hy) y))) 1545 (res (cl-floor (+ x hy) y)))
1546 (if (and (= (car (cdr res)) 0) 1546 (if (and (= (car (cdr res)) 0)
1547 (= (+ hy hy) y) 1547 (= (+ hy hy) y)
1548 (/= (% (car res) 2) 0)) 1548 (/= (% (car res) 2) 0))
1549 (list (1- (car res)) hy) 1549 (list (1- (car res)) hy)
1550 (list (car res) (- (car (cdr res)) hy)))) 1550 (list (car res) (- (car (cdr res)) hy))))
1551 (let ((q (round (/ x y)))) 1551 (let ((q (round (/ x y))))
1552 (list q (- x (* q y))))) 1552 (list q (- x (* q y)))))
1553 (if (integerp x) (list x 0) 1553 (if (integerp x) (list x 0)
1554 (let ((q (round x))) 1554 (let ((q (round x)))
1555 (list q (- x q)))))) 1555 (list q (- x q))))))
1556 (Assert-rounding (first second &key 1556 (Assert-rounding (first second &key
1557 one-floor-result two-floor-result 1557 one-floor-result two-floor-result
1558 one-ffloor-result two-ffloor-result 1558 one-ffloor-result two-ffloor-result
1559 one-ceiling-result two-ceiling-result 1559 one-ceiling-result two-ceiling-result
1560 one-fceiling-result two-fceiling-result 1560 one-fceiling-result two-fceiling-result
2097 (princ " :two-ftruncate-result ") 2097 (princ " :two-ftruncate-result ")
2098 (princ (list 'quote (multiple-value-list (ftruncate first second)))))) 2098 (princ (list 'quote (multiple-value-list (ftruncate first second))))))
2099 2099
2100 ;; Multiple value tests. 2100 ;; Multiple value tests.
2101 2101
2102 (flet ((foo (x y) 2102 (labels ((foo (x y)
2103 (floor (+ x y) y)) 2103 (floor (+ x y) y))
2104 (foo-zero (x y) 2104 (foo-zero (x y)
2105 (values (floor (+ x y) y))) 2105 (values (floor (+ x y) y)))
2106 (multiple-value-function-returning-t () 2106 (multiple-value-function-returning-t ()
2107 (values t pi e degrees-to-radians radians-to-degrees)) 2107 (values t pi e degrees-to-radians radians-to-degrees))
2108 (multiple-value-function-returning-nil () 2108 (multiple-value-function-returning-nil ()
2109 (values nil pi e radians-to-degrees degrees-to-radians)) 2109 (values nil pi e radians-to-degrees degrees-to-radians))
2110 (function-throwing-multiple-values () 2110 (function-throwing-multiple-values ()
2111 (let* ((listing '(0 3 4 nil "string" symbol)) 2111 (let* ((listing '(0 3 4 nil "string" symbol))
2112 (tail listing) 2112 (tail listing)
2113 elt) 2113 elt)
2114 (while t 2114 (while t
2115 (setq tail (cdr listing) 2115 (setq tail (cdr listing)
2116 elt (car listing) 2116 elt (car listing)
2117 listing tail) 2117 listing tail)
2118 (when (null elt) 2118 (when (null elt)
2119 (throw 'VoN61Lo4Y (multiple-value-function-returning-t))))))) 2119 (throw 'VoN61Lo4Y (multiple-value-function-returning-t)))))))
2120 (Assert 2120 (Assert
2121 (= (+ (floor 5 3) (floor 19 4)) (+ 1 4) 5) 2121 (= (+ (floor 5 3) (floor 19 4)) (+ 1 4) 5)
2122 "Checking that multiple values are discarded correctly as func args") 2122 "Checking that multiple values are discarded correctly as func args")
2123 (Assert 2123 (Assert
2124 (= 2 (length (multiple-value-list (foo 400 (1+ most-positive-fixnum))))) 2124 (= 2 (length (multiple-value-list (foo 400 (1+ most-positive-fixnum)))))
2507 (list (map-into (make-list 2048 nil) #'(lambda () (decf count)))) 2507 (list (map-into (make-list 2048 nil) #'(lambda () (decf count))))
2508 (expected (append list '(1)))) 2508 (expected (append list '(1))))
2509 (Assert (equal expected (merge 'list list '(1) #'<)) 2509 (Assert (equal expected (merge 'list list '(1) #'<))
2510 "checking merge's circularity checks are sane")) 2510 "checking merge's circularity checks are sane"))
2511 2511
2512 (flet ((list-nreverse (list) 2512 (labels ((list-nreverse (list)
2513 (do ((list1 list (cdr list1)) 2513 (do ((list1 list (cdr list1))
2514 (list2 nil (prog1 list1 (setcdr list1 list2)))) 2514 (list2 nil (prog1 list1 (setcdr list1 list2))))
2515 ((atom list1) list2)))) 2515 ((atom list1) list2))))
2516 (let* ((integers (loop for i from 0 to 6000 collect i)) 2516 (let* ((integers (loop for i from 0 to 6000 collect i))
2517 (characters (mapcan #'(lambda (integer) 2517 (characters (mapcan #'(lambda (integer)
2518 (if (char-int-p integer) 2518 (if (char-int-p integer)
2519 (list (int-char integer)))) integers)) 2519 (list (int-char integer)))) integers))
2520 (fourth-bit #'(lambda (integer) (ash (logand #x10 integer) -4))) 2520 (fourth-bit #'(lambda (integer) (ash (logand #x10 integer) -4)))
2896 ;; Other tests are available in Paul Dietz' test suite, and pass. The above, 2896 ;; Other tests are available in Paul Dietz' test suite, and pass. The above,
2897 ;; which we used to fail, is based on a test in the Hyperspec. We still 2897 ;; which we used to fail, is based on a test in the Hyperspec. We still
2898 ;; behave incorrectly when compiled for the contorted-example function of 2898 ;; behave incorrectly when compiled for the contorted-example function of
2899 ;; CLTL2, whence the following test: 2899 ;; CLTL2, whence the following test:
2900 2900
2901 (flet ((needs-lexical-context (first second third) 2901 (labels ((needs-lexical-context (first second third)
2902 (if (eql 0 first) 2902 (if (eql 0 first)
2903 (funcall second) 2903 (funcall second)
2904 (block awkward 2904 (block awkward
2905 (+ 5 (needs-lexical-context 2905 (+ 5 (needs-lexical-context
2906 (1- first) 2906 (1- first)
2907 third 2907 third
2908 #'(lambda () (return-from awkward 0))) 2908 #'(lambda () (return-from awkward 0)))
2909 first))))) 2909 first)))))
2910 (if (compiled-function-p (symbol-function 'needs-lexical-context)) 2910 (if (compiled-function-p
2911 (ignore-errors (indirect-function #'needs-lexical-context)))
2911 (Known-Bug-Expect-Failure 2912 (Known-Bug-Expect-Failure
2912 (Assert (eql 0 (needs-lexical-context 2 nil nil)) 2913 (Assert (eql 0 (needs-lexical-context 2 nil nil))
2913 "the function special operator doesn't create a lexical context.")) 2914 "the function special operator doesn't create a lexical context."))
2914 (Assert (eql 0 (needs-lexical-context 2 nil nil))))) 2915 (Assert (eql 0 (needs-lexical-context 2 nil nil)))))
2915 2916