Mercurial > hg > xemacs-beta

comparison tests/automated/lisp-tests.el @ 5470:0af042a0c116

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge with trunk.
author Mats Lidell <matsl@xemacs.org>
date Mon, 07 Feb 2011 21:22:17 +0100
parents a9094f28f9a9 38e24b8be4ea
children 00e79bbbe48f
comparison
equal deleted inserted replaced
5469:2a8a04f73c15 5470:0af042a0c116
789 ((test-fun 789 ((test-fun
790 (fun) 790 (fun)
791 `(progn 791 `(progn
792 (Check-Error wrong-number-of-arguments (,fun)) 792 (Check-Error wrong-number-of-arguments (,fun))
793 (Check-Error wrong-number-of-arguments (,fun nil)) 793 (Check-Error wrong-number-of-arguments (,fun nil))
794 (Check-Error malformed-list (,fun nil 1)) 794 (Check-Error (malformed-list wrong-type-argument) (,fun nil 1))
795 ,@(loop for n in '(1 2 2000) 795 ,@(loop for n in '(1 2 2000)
796 collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n)))))) 796 collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n))))))
797 (test-funs (&rest funs) `(progn ,@(loop for fun in funs collect `(test-fun ,fun))))) 797 (test-funs (&rest funs) `(progn ,@(loop for fun in funs collect `(test-fun ,fun)))))
798 798
799 (test-funs member* member old-member 799 (test-funs member* member memq
800 memq old-memq 800 assoc* assoc assq
801 assoc* assoc old-assoc 801 rassoc* rassoc rassq
802 rassoc* rassoc old-rassoc 802 delete* delete delq
803 rassq old-rassq 803 remove* remove remq
804 delete* delete old-delete 804 old-member old-memq
805 delq old-delq 805 old-assoc old-assq
806 remassoc remassq remrassoc remrassq)) 806 old-rassoc old-rassq
807 old-delete old-delq
808 remassoc remassq remrassoc remrassq))
807 809
808 (let ((x '((1 . 2) 3 (4 . 5)))) 810 (let ((x '((1 . 2) 3 (4 . 5))))
809 (Assert (eq (assoc 1 x) (car x))) 811 (Assert (eq (assoc 1 x) (car x)))
810 (Assert (eq (assq 1 x) (car x))) 812 (Assert (eq (assq 1 x) (car x)))
811 (Assert (eq (rassoc 1 x) nil)) 813 (Assert (eq (rassoc 1 x) nil))
2676 (vector (make-vector vector-length 'make-vector)) 2678 (vector (make-vector vector-length 'make-vector))
2677 (bit-vector (make-bit-vector vector-length 1)) 2679 (bit-vector (make-bit-vector vector-length 1))
2678 (string (make-string string-length 2680 (string (make-string string-length
2679 (or (decode-char 'ucs #x20ac) ?\xFF))) 2681 (or (decode-char 'ucs #x20ac) ?\xFF)))
2680 (item 'cons)) 2682 (item 'cons))
2681 (dolist (function '(count position find delete* remove* reduce)) 2683 (macrolet
2682 (Check-Error args-out-of-range 2684 ((construct-item-sequence-checks (&rest functions)
2683 (funcall function item list 2685 (cons
2684 :start (1+ list-length) :end (1+ list-length))) 2686 'progn
2685 (Check-Error wrong-type-argument 2687 (mapcan
2686 (funcall function item list 2688 #'(lambda (function)
2687 :start -1 :end list-length)) 2689 `((Check-Error args-out-of-range
2688 (Check-Error args-out-of-range 2690 (,function item list
2689 (funcall function item list :end (* 2 list-length))) 2691 :start (1+ list-length)
2690 (Check-Error args-out-of-range 2692 :end (1+ list-length)))
2691 (funcall function item vector 2693 (Check-Error wrong-type-argument
2692 :start (1+ vector-length) :end (1+ vector-length))) 2694 (,function item list :start -1
2693 (Check-Error wrong-type-argument 2695 :end list-length))
2694 (funcall function item vector :start -1)) 2696 (Check-Error args-out-of-range
2695 (Check-Error args-out-of-range 2697 (,function item list :end (* 2 list-length)))
2696 (funcall function item vector :end (* 2 vector-length))) 2698 (Check-Error args-out-of-range
2697 (Check-Error args-out-of-range 2699 (,function item vector
2698 (funcall function item bit-vector 2700 :start (1+ vector-length)
2699 :start (1+ vector-length) :end (1+ vector-length))) 2701 :end (1+ vector-length)))
2700 (Check-Error wrong-type-argument 2702 (Check-Error wrong-type-argument
2701 (funcall function item bit-vector :start -1)) 2703 (,function item vector :start -1))
2702 (Check-Error args-out-of-range 2704 (Check-Error args-out-of-range
2703 (funcall function item bit-vector :end (* 2 vector-length))) 2705 (,function item vector
2704 (Check-Error args-out-of-range 2706 :end (* 2 vector-length)))
2705 (funcall function item string 2707 (Check-Error args-out-of-range
2706 :start (1+ string-length) :end (1+ string-length))) 2708 (,function item bit-vector
2707 (Check-Error wrong-type-argument 2709 :start (1+ vector-length)
2708 (funcall function item string :start -1)) 2710 :end (1+ vector-length)))
2709 (Check-Error args-out-of-range 2711 (Check-Error wrong-type-argument
2710 (funcall function item string :end (* 2 string-length)))) 2712 (,function item bit-vector :start -1))
2711 (dolist (function '(delete-duplicates remove-duplicates)) 2713 (Check-Error args-out-of-range
2712 (Check-Error args-out-of-range 2714 (,function item bit-vector
2713 (funcall function (copy-sequence list) 2715 :end (* 2 vector-length)))
2714 :start (1+ list-length) :end (1+ list-length))) 2716 (Check-Error args-out-of-range
2715 (Check-Error wrong-type-argument 2717 (,function item string
2716 (funcall function (copy-sequence list) 2718 :start (1+ string-length)
2717 :start -1 :end list-length)) 2719 :end (1+ string-length)))
2718 (Check-Error args-out-of-range 2720 (Check-Error wrong-type-argument
2719 (funcall function (copy-sequence list) 2721 (,function item string :start -1))
2720 :end (* 2 list-length))) 2722 (Check-Error args-out-of-range
2721 (Check-Error args-out-of-range 2723 (,function item string
2722 (funcall function (copy-sequence vector) 2724 :end (* 2 string-length)))))
2723 :start (1+ vector-length) :end (1+ vector-length))) 2725 functions)))
2724 (Check-Error wrong-type-argument 2726 (construct-one-sequence-checks (&rest functions)
2725 (funcall function (copy-sequence vector) :start -1)) 2727 (cons
2726 (Check-Error args-out-of-range 2728 'progn
2727 (funcall function (copy-sequence vector) 2729 (mapcan
2728 :end (* 2 vector-length))) 2730 #'(lambda (function)
2729 (Check-Error args-out-of-range 2731 `((Check-Error args-out-of-range
2730 (funcall function (copy-sequence bit-vector) 2732 (,function (copy-sequence list)
2731 :start (1+ vector-length) :end (1+ vector-length))) 2733 :start (1+ list-length)
2732 (Check-Error wrong-type-argument 2734 :end (1+ list-length)))
2733 (funcall function (copy-sequence bit-vector) :start -1)) 2735 (Check-Error wrong-type-argument
2734 (Check-Error args-out-of-range 2736 (,function (copy-sequence list)
2735 (funcall function (copy-sequence bit-vector) 2737 :start -1 :end list-length))
2736 :end (* 2 vector-length))) 2738 (Check-Error args-out-of-range
2737 (Check-Error args-out-of-range 2739 (,function (copy-sequence list)
2738 (funcall function (copy-sequence string) 2740 :end (* 2 list-length)))
2739 :start (1+ string-length) :end (1+ string-length))) 2741 (Check-Error args-out-of-range
2740 (Check-Error wrong-type-argument 2742 (,function (copy-sequence vector)
2741 (funcall function (copy-sequence string) :start -1)) 2743 :start (1+ vector-length)
2742 (Check-Error args-out-of-range 2744 :end (1+ vector-length)))
2743 (funcall function (copy-sequence string) 2745 (Check-Error wrong-type-argument
2744 :end (* 2 string-length)))) 2746 (,function (copy-sequence vector) :start -1))
2745 (dolist (function '(replace mismatch search)) 2747 (Check-Error args-out-of-range
2746 (Check-Error args-out-of-range 2748 (,function (copy-sequence vector)
2747 (funcall function (copy-sequence list) (copy-sequence list) 2749 :end (* 2 vector-length)))
2748 :start1 (1+ list-length) :end1 (1+ list-length))) 2750 (Check-Error args-out-of-range
2749 (Check-Error wrong-type-argument 2751 (,function (copy-sequence bit-vector)
2750 (funcall function (copy-sequence list) (copy-sequence list) 2752 :start (1+ vector-length)
2751 :start1 -1 :end1 list-length)) 2753 :end (1+ vector-length)))
2752 (Check-Error args-out-of-range 2754 (Check-Error wrong-type-argument
2753 (funcall function (copy-sequence list) (copy-sequence list) 2755 (,function (copy-sequence bit-vector)
2754 :end1 (* 2 list-length))) 2756 :start -1))
2755 (Check-Error args-out-of-range 2757 (Check-Error args-out-of-range
2756 (funcall function (copy-sequence vector) 2758 (,function (copy-sequence bit-vector)
2757 (copy-sequence vector) :start1 (1+ vector-length) 2759 :end (* 2 vector-length)))
2758 :end1 (1+ vector-length))) 2760 (Check-Error args-out-of-range
2759 (Check-Error wrong-type-argument 2761 (,function (copy-sequence string)
2760 (funcall function (copy-sequence vector) 2762 :start (1+ string-length)
2761 (copy-sequence vector) :start1 -1)) 2763 :end (1+ string-length)))
2762 (Check-Error args-out-of-range 2764 (Check-Error wrong-type-argument
2763 (funcall function (copy-sequence vector) 2765 (,function (copy-sequence string) :start -1))
2764 (copy-sequence vector) 2766 (Check-Error args-out-of-range
2765 :end1 (* 2 vector-length))) 2767 (,function (copy-sequence string)
2766 (Check-Error args-out-of-range 2768 :end (* 2 string-length)))))
2767 (funcall function (copy-sequence bit-vector) 2769 functions)))
2768 (copy-sequence bit-vector) 2770 (construct-two-sequence-checks (&rest functions)
2769 :start1 (1+ vector-length) 2771 (cons
2770 :end1 (1+ vector-length))) 2772 'progn
2771 (Check-Error wrong-type-argument 2773 (mapcan
2772 (funcall function (copy-sequence bit-vector) 2774 #'(lambda (function)
2773 (copy-sequence bit-vector) :start1 -1)) 2775 `((Check-Error args-out-of-range
2774 (Check-Error args-out-of-range 2776 (,function (copy-sequence list)
2775 (funcall function (copy-sequence bit-vector) 2777 (copy-sequence list)
2776 (copy-sequence bit-vector) 2778 :start1 (1+ list-length)
2777 :end1 (* 2 vector-length))) 2779 :end1 (1+ list-length)))
2778 (Check-Error args-out-of-range 2780 (Check-Error wrong-type-argument
2779 (funcall function (copy-sequence string) 2781 (,function (copy-sequence list)
2780 (copy-sequence string) 2782 (copy-sequence list)
2781 :start1 (1+ string-length) 2783 :start1 -1 :end1 list-length))
2782 :end1 (1+ string-length))) 2784 (Check-Error args-out-of-range
2783 (Check-Error wrong-type-argument 2785 (,function (copy-sequence list)
2784 (funcall function (copy-sequence string) 2786 (copy-sequence list)
2785 (copy-sequence string) :start1 -1)) 2787 :end1 (* 2 list-length)))
2786 (Check-Error args-out-of-range 2788 (Check-Error args-out-of-range
2787 (funcall function (copy-sequence string) 2789 (,function (copy-sequence vector)
2788 (copy-sequence string) 2790 (copy-sequence vector)
2789 :end1 (* 2 string-length)))))) 2791 :start1 (1+ vector-length)
2792 :end1 (1+ vector-length)))
2793 (Check-Error wrong-type-argument
2794 (,function
2795 (copy-sequence vector)
2796 (copy-sequence vector) :start1 -1))
2797 (Check-Error args-out-of-range
2798 (,function (copy-sequence vector)
2799 (copy-sequence vector)
2800 :end1 (* 2 vector-length)))
2801 (Check-Error args-out-of-range
2802 (,function (copy-sequence bit-vector)
2803 (copy-sequence bit-vector)
2804 :start1 (1+ vector-length)
2805 :end1 (1+ vector-length)))
2806 (Check-Error wrong-type-argument
2807 (,function (copy-sequence bit-vector)
2808 (copy-sequence bit-vector)
2809 :start1 -1))
2810 (Check-Error args-out-of-range
2811 (,function (copy-sequence bit-vector)
2812 (copy-sequence bit-vector)
2813 :end1 (* 2 vector-length)))
2814 (Check-Error args-out-of-range
2815 (,function (copy-sequence string)
2816 (copy-sequence string)
2817 :start1 (1+ string-length)
2818 :end1 (1+ string-length)))
2819 (Check-Error wrong-type-argument
2820 (,function (copy-sequence string)
2821 (copy-sequence string) :start1 -1))
2822 (Check-Error args-out-of-range
2823 (,function (copy-sequence string)
2824 (copy-sequence string)
2825 :end1 (* 2 string-length)))))
2826 functions))))
2827 (construct-item-sequence-checks count position find delete* remove*
2828 reduce)
2829 (construct-one-sequence-checks delete-duplicates remove-duplicates)
2830 (construct-two-sequence-checks replace mismatch search))))
2790 2831
2791 (let* ((list (list 1 2 3 4 5 6 7 120 'hi-there '#:everyone)) 2832 (let* ((list (list 1 2 3 4 5 6 7 120 'hi-there '#:everyone))
2792 (vector (map 'vector #'identity list)) 2833 (vector (map 'vector #'identity list))
2793 (bit-vector (map 'bit-vector 2834 (bit-vector (map 'bit-vector
2794 #'(lambda (object) (if (fixnump object) 1 0)) list)) 2835 #'(lambda (object) (if (fixnump object) 1 0)) list))
2826 (append (subseq bit-vector 4) nil)))) 2867 (append (subseq bit-vector 4) nil))))
2827 (Assert (equal bit-vector (concatenate `(vector bit ,(length bit-vector)) 2868 (Assert (equal bit-vector (concatenate `(vector bit ,(length bit-vector))
2828 (subseq bit-vector 0 4) 2869 (subseq bit-vector 0 4)
2829 (append (subseq bit-vector 4) nil))))) 2870 (append (subseq bit-vector 4) nil)))))
2830 2871
2872 ;;-----------------------------------------------------
2873 ;; Test `block', `return-from'
2874 ;;-----------------------------------------------------
2875 (Assert (eql 1 (block outer
2876 (flet ((outtahere (n) (return-from outer n)))
2877 (block outer (outtahere 1)))
2878 2))
2879 "checking `block' and `return-from' are lexically scoped correctly")
2880
2881 ;; Other tests are available in Paul Dietz' test suite, and pass. The above,
2882 ;; which we used to fail, is based on a test in the Hyperspec. We still
2883 ;; behave incorrectly when compiled for the contorted-example function of
2884 ;; CLTL2, whence the following test:
2885
2886 (flet ((needs-lexical-context (first second third)
2887 (if (eql 0 first)
2888 (funcall second)
2889 (block awkward
2890 (+ 5 (needs-lexical-context
2891 (1- first)
2892 third
2893 #'(lambda () (return-from awkward 0)))
2894 first)))))
2895 (if (compiled-function-p (symbol-function 'needs-lexical-context))
2896 (Known-Bug-Expect-Failure
2897 (Assert (eql 0 (needs-lexical-context 2 nil nil))
2898 "the function special operator doesn't create a lexical context."))
2899 (Assert (eql 0 (needs-lexical-context 2 nil nil)))))
2900
2831 ;;; end of lisp-tests.el 2901 ;;; end of lisp-tests.el