/[gcl]/gcl/ansi-tests/ansi-aux.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/ansi-aux.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.14 by pfdietz, Sat Dec 14 04:54:00 2002 UTC revision 1.15 by pfdietz, Fri Dec 20 04:06:06 2002 UTC
# Line 8  Line 8 
8    
9  (declaim (optimize (safety 3)))  (declaim (optimize (safety 3)))
10    
11    ;;; Comparison functions that are like various builtins,
12    ;;; but are guaranteed to return T for true.
13    
14  (defun eqt (x y)  (defun eqt (x y)
15    "Like EQ, but guaranteed to return T for true."    "Like EQ, but guaranteed to return T for true."
16    (if (eq x y) t nil))    (if (eq x y) t nil))
# Line 28  Line 31 
31    "Like =, but guaranteed to return T for true."    "Like =, but guaranteed to return T for true."
32    (if (apply #'= x args) t nil))    (if (apply #'= x args) t nil))
33    
34    
35    ;;; A function for coercing truth values to BOOLEAN
36    
37  (defun notnot (x) (not (not x)))  (defun notnot (x) (not (not x)))
38    
39  (defun make-int-list (n)  (defun make-int-list (n)
# Line 38  Line 44 
44      (loop for i from 0 below n do (setf (aref a i) i))      (loop for i from 0 below n do (setf (aref a i) i))
45      a))      a))
46    
47    ;;; Return true if A1 and A2 are arrays with the same rank
48    ;;; and dimensions whose elements are EQUAL
49    
50  (defun equal-array (a1 a2)  (defun equal-array (a1 a2)
51    (and (typep a1 'array)    (and (typep a1 'array)
52         (typep a2 'array)         (typep a2 'array)
# Line 56  Line 65 
65                          always (equal (row-major-aref a1 i)                          always (equal (row-major-aref a1 i)
66                                        (row-major-aref a2 i))))))))))                                        (row-major-aref a2 i))))))))))
67    
68    ;;; *universe* is defined elsewhere -- it is a list of various
69    ;;; lisp objects used when stimulating things in various tests.
70  (declaim (special *universe*))  (declaim (special *universe*))
71    
72  (defun check-type-predicate (P TYPE)  (defun check-type-predicate (P TYPE)
73    "Check that a predicate P is the same as #'(lambda (x) (typep x TYPE))    "Check that a predicate P is the same as #'(lambda (x) (typep x TYPE))
74     by applying both to all elements of *UNIVERSE*.  Print message     by applying both to all elements of *UNIVERSE*.  Print message
75     when a mismatch is found, and return number of mistakes."     when a mismatch is found, and return number of mistakes."
     
76    (loop    (loop
77        for x in *universe* count        for x in *universe* count
78          (block failed          (block failed
# Line 193  the condition to go uncaught if it canno Line 203  the condition to go uncaught if it canno
203  (defun subtypep* (obj type)  (defun subtypep* (obj type)
204    (multiple-value-bind (result good)    (multiple-value-bind (result good)
205        (subtypep obj type)        (subtypep obj type)
206      (values (not (not result))      (values (notnot result)
207              (not (not good)))))              (notnot good))))
208    
209  ;;; (eval-when (load eval compile)  ;;; (eval-when (load eval compile)
210  ;;;   (unless (fboundp 'complement)  ;;;   (unless (fboundp 'complement)
# Line 206  the condition to go uncaught if it canno Line 216  the condition to go uncaught if it canno
216      #'(lambda (x) (loop for f in rfns do (setf x (funcall f x))) x)))      #'(lambda (x) (loop for f in rfns do (setf x (funcall f x))) x)))
217    
218  (defun evendigitp (c)  (defun evendigitp (c)
219    (not (not (find c "02468"))))    (notnot (find c "02468")))
220    
221  (defun odddigitp (c)  (defun odddigitp (c)
222    (not (not (find c "13579"))))    (notnot (find c "13579")))
223    
224  (defun nextdigit (c)  (defun nextdigit (c)
225    (cadr (member c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))))    (cadr (member c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))))
# Line 335  the condition to go uncaught if it canno Line 345  the condition to go uncaught if it canno
345    
346  (defun make-displaced-array (n displacement)  (defun make-displaced-array (n displacement)
347    (make-array n :displaced-to *displaced*    (make-array n :displaced-to *displaced*
348    
349                :displaced-index-offset displacement))                :displaced-index-offset displacement))
350    
351  ;;; used in fill.lsp  ;;; used in fill.lsp
# Line 366  the condition to go uncaught if it canno Line 377  the condition to go uncaught if it canno
377  (defun types-6-body ()  (defun types-6-body ()
378    (loop    (loop
379        for p in *subtype-table* count        for p in *subtype-table* count
380          (let ((tp (car p)))        (let ((tp (car p)))
381            (cond          (when (and (not (member tp '(sequence cons list t)))
382             ((and (not (member tp '(sequence cons list t)))                     (not (subtypep* tp 'atom)))
383                   (not (subtypep* tp 'atom)))            (format t "~%Problem!  Did not find to be an atomic type: ~S" tp)
384              (format t "~%Problem!  Did not find to be an atomic type: ~S" tp)            t))))
             t)))))  
385    
386  (defvar *type-list* nil)  (defvar *type-list* nil)
387  (defvar *supertype-table* nil)  (defvar *supertype-table* nil)
388  (declaim (special *subtype-table* *universe*))  (declaim (special *subtype-table*))
389    
390  (defun types-9-body ()  (defun types-9-body ()
391    (let ((tp-list (append '(keyword atom list)    (let ((tp-list (append '(keyword atom list)
# Line 428  the condition to go uncaught if it canno Line 438  the condition to go uncaught if it canno
438    
439  (defun types-9a-body ()  (defun types-9a-body ()
440    (cond    (cond
441       ((not (and *type-list* *supertype-table*))     ((not (and *type-list* *supertype-table*))
442        (format nil "Run test type-9 first~%")      (format nil "Run test type-9 first~%")
443        nil)      nil)
444       (t     (t
445        (loop      (loop
446            for tp in *type-list*       for tp in *type-list*
447            sum       sum
448              (let ((sups (gethash tp *supertype-table*)))       (let ((sups (gethash tp *supertype-table*)))
449                (loop         (loop
450                    for x in *universe*          for x in *universe*
451                    sum          sum
452                      (handler-case          (handler-case
453                      (cond           (cond
454                       ((not (typep x tp)) 0)            ((not (typep x tp)) 0)
455                       (t            (t
456                        (loop             (loop
457                            for tp2 in sups              for tp2 in sups
458                            count              count
459                              (handler-case              (handler-case
460                                  (and (not (typep x tp2))               (and (not (typep x tp2))
461                                       (progn                    (progn
462                                         (format t "Found element of ~S not in ~S: ~S~%"                      (format t "Found element of ~S not in ~S: ~S~%"
463                                                 tp tp2 x)                              tp tp2 x)
464                                         t))                      t))
465                                (condition (c) (format t "Error ~S occured: ~S~%"               (condition (c) (format t "Error ~S occured: ~S~%"
466                                                  c tp2)                                      c tp2)
467                                  t)))))                          t)))))
468                      (condition (c) (format t "Error ~S occured: ~S~%" c tp)           (condition (c) (format t "Error ~S occured: ~S~%" c tp)
469                        1))))))))                      1))))))))
470    
471  (defun even-size-p (a)  (defun even-size-p (a)
472    (some #'evenp (array-dimensions a)))    (some #'evenp (array-dimensions a)))
473    
474  (defun check-cons-copy (x y)  (defun check-cons-copy (x y)
475    "Check that the tree x is a copy of the tree y,    "Check that the tree x is a copy of the tree y,
476     returning t iff it is."     returning t if it is, nil if not."
477    (cond    (cond
478     ((consp x)     ((consp x)
479      (and (consp y)      (and (consp y)
# Line 602  the condition to go uncaught if it canno Line 612  the condition to go uncaught if it canno
612    (let* ((cal (min 2048 call-arguments-limit))    (let* ((cal (min 2048 call-arguments-limit))
613           (step (max 1 (floor (/ cal) 64))))           (step (max 1 (floor (/ cal) 64))))
614      (loop      (loop
615          for n from 0       for n from 0
616          below cal       below cal
617          by step       by step
618          count       count
619            (not       (not
620             (equal        (equal
621              (apply #'append (loop for i from 1 to n         (apply #'append (loop for i from 1 to n
622                                  collect '(a)))                               collect '(a)))
623              (make-list n :initial-element 'a))))))         (make-list n :initial-element 'a))))))
624    
625  (defun is-intersection (x y z)  (defun is-intersection (x y z)
626    "Check that z is the intersection of x and y."    "Check that z is the intersection of x and y."
627    (and    (and
628     (every #'(lambda (e)     (listp x)
629                (or (not (member e y))     (listp y)
630                    (member e z)))     (listp z)
631            x)     (loop for e in x
632     (every #'(lambda (e)           always (or (not (member e y))
633                (or (not (member e x))                      (member e z)))
634                    (member e z)))     (loop for e in y
635            y)           always (or (not (member e x))
636     (every #'(lambda (e)                      (member e z)))
637                (and (member e x) (member e y)))     (loop for e in z
638            z)           always (and (member e x) (member e y)))
639     t))     t))
640    
641  (defun shuffle (x)  (defun shuffle (x)
# Line 650  the condition to go uncaught if it canno Line 660  the condition to go uncaught if it canno
660    
661  (defun intersection-12-body (size niters &optional (maxelem (* 2 size)))  (defun intersection-12-body (size niters &optional (maxelem (* 2 size)))
662    (let ((state (make-random-state)))    (let ((state (make-random-state)))
663    (loop      (loop
664     for i from 1 to niters do       for i from 1 to niters do
665      (let ((x (shuffle (loop for j from 1 to size collect (random maxelem state))))       (let ((x (shuffle (loop for j from 1 to size
666            (y (shuffle (loop for j from 1 to size collect (random maxelem state)))))                               collect (random maxelem state))))
667        (let ((z (intersection x y)))             (y (shuffle (loop for j from 1 to size
668          (let ((is-good (is-intersection x y z)))                               collect (random maxelem state)))))
669            (unless is-good (return (values x y z)))))))         (let ((z (intersection x y)))
670    nil))           (let ((is-good (is-intersection x y z)))
671               (unless is-good (return (values x y z)))))))
672        nil))
673    
674  (defun nintersection-with-check (x y &key test)  (defun nintersection-with-check (x y &key test)
675    (let ((ycopy (make-scaffold-copy y)))    (let ((ycopy (make-scaffold-copy y)))
# Line 672  the condition to go uncaught if it canno Line 684  the condition to go uncaught if it canno
684    (let ((state (make-random-state t)))    (let ((state (make-random-state t)))
685      (loop      (loop
686       for i from 1 to niters do       for i from 1 to niters do
687       (let ((x (shuffle (loop for j from 1 to size collect (random maxelem state))))       (let ((x (shuffle (loop for j from 1 to size
688             (y (shuffle (loop for j from 1 to size collect (random maxelem state)))))                               collect (random maxelem state))))
689               (y (shuffle (loop for j from 1 to size
690                                 collect (random maxelem state)))))
691         (let ((z (nintersection-with-check (copy-list x) y)))         (let ((z (nintersection-with-check (copy-list x) y)))
692           (when (eqt z 'failed) (return (values x y z)))           (when (eqt z 'failed) (return (values x y z)))
693           (let ((is-good (is-intersection x y z)))           (let ((is-good (is-intersection x y z)))
# Line 688  the condition to go uncaught if it canno Line 702  the condition to go uncaught if it canno
702                     (test (union x y :test test))                     (test (union x y :test test))
703                     (test-not (union x y :test-not test-not))                     (test-not (union x y :test-not test-not))
704                     (t (union x y)))))                     (t (union x y)))))
705        (if        (if (and (check-scaffold-copy x xcopy)
           (and (check-scaffold-copy x xcopy)  
706                 (check-scaffold-copy y ycopy))                 (check-scaffold-copy y ycopy))
707            result            result
708          'failed))))          'failed))))
# Line 701  the condition to go uncaught if it canno Line 714  the condition to go uncaught if it canno
714                     (test (union x y :key key :test test))                     (test (union x y :key key :test test))
715                     (test-not (union x y :key key :test-not test-not))                     (test-not (union x y :key key :test-not test-not))
716                     (t (union x y :key key)))))                     (t (union x y :key key)))))
717        (if        (if (and (check-scaffold-copy x xcopy)
           (and (check-scaffold-copy x xcopy)  
718                 (check-scaffold-copy y ycopy))                 (check-scaffold-copy y ycopy))
719            result            result
720          'failed))))          'failed))))
# Line 711  the condition to go uncaught if it canno Line 723  the condition to go uncaught if it canno
723    (and (listp x)    (and (listp x)
724         (listp y)         (listp y)
725         (listp z)         (listp z)
726         (every #'(lambda (e) (or (member e x)         (loop for e in z always (or (member e x) (member e y)))
727                                  (member e y)))         (loop for e in x always (member e z))
728                z)         (loop for e in y always (member e z))
        (every #'(lambda (e) (member e z)) x)  
        (every #'(lambda (e) (member e z)) y)  
729         t))         t))
730    
731  (defun do-random-unions (size niters &optional (maxelem (* 2 size)))  (defun do-random-unions (size niters &optional (maxelem (* 2 size)))
# Line 781  the condition to go uncaught if it canno Line 791  the condition to go uncaught if it canno
791  (defun check-set-difference (x y z &key (key #'identity)  (defun check-set-difference (x y z &key (key #'identity)
792                                          (test #'eql))                                          (test #'eql))
793    (and    (and
794     (not (eqt 'failed z))     ;; (not (eqt 'failed z))
795     (every #'(lambda (e) (member e x :key key :test test)) z)     (listp x)
796     (every #'(lambda (e) (or (member e y :key key :test test)     (listp y)
797                              (member e z :key key :test test))) x)     (listp z)
798     (every #'(lambda (e) (not (member e z :key key :test test))) y)     (loop for e in z always (member e x :key key :test test))
799       (loop for e in x always (or (member e y :key key :test test)
800                                   (member e z :key key :test test)))
801       (loop for e in y never  (member e z :key key :test test))
802     t))     t))
803    
804  (defun do-random-set-differences (size niters &optional (maxelem (* 2 size)))  (defun do-random-set-differences (size niters &optional (maxelem (* 2 size)))
805    (let ((state (make-random-state)))    (let ((state (make-random-state)))
806      (loop      (loop
807         for i from 1 to niters do       for i from 1 to niters do
808            (let ((x (shuffle (loop for j from 1 to size collect       (let ((x (shuffle (loop for j from 1 to size collect
809                                    (random maxelem state))))                               (random maxelem state))))
810                  (y (shuffle (loop for j from 1 to size collect             (y (shuffle (loop for j from 1 to size collect
811                                    (random maxelem state)))))                               (random maxelem state)))))
812              (let ((z (set-difference-with-check x y)))         (let ((z (set-difference-with-check x y)))
813                (let ((is-good (check-set-difference x y z)))           (let ((is-good (check-set-difference x y z)))
814                  (unless is-good (return (values x y z)))))))             (unless is-good (return (values x y z)))))))
815      nil))      nil))
816  (defun nset-difference-with-check (x y &key (key 'no-key)  (defun nset-difference-with-check (x y &key (key 'no-key)
817                                             test test-not)                                       test test-not)
818    (setf x (copy-list x))    (setf x (copy-list x))
819    (setf y (copy-list y))    (setf y (copy-list y))
820    (apply #'nset-difference    (apply #'nset-difference
# Line 811  the condition to go uncaught if it canno Line 824  the condition to go uncaught if it canno
824               ,@(when test-not `(:test-not ,test-not)))))               ,@(when test-not `(:test-not ,test-not)))))
825    
826  (defun check-nset-difference (x y z &key (key #'identity)  (defun check-nset-difference (x y z &key (key #'identity)
827                                          (test #'eql))                                  (test #'eql))
828    (and    (and
829     (every #'(lambda (e) (member e x :key key :test test)) z)     (listp x)
830     (every #'(lambda (e) (or (member e y :key key :test test)     (listp y)
831                              (member e z :key key :test test))) x)     (listp z)
832     (every #'(lambda (e) (not (member e z :key key :test test))) y)     (loop for e in z always (member e x :key key :test test))
833       (loop for e in x always (or (member e y :key key :test test)
834                                   (member e z :key key :test test)))
835       (loop for e in y never  (member e z :key key :test test))
836     t))     t))
837    
838  (defun do-random-nset-differences (size niters &optional (maxelem (* 2 size)))  (defun do-random-nset-differences (size niters &optional (maxelem (* 2 size)))
839    (let ((state (make-random-state)))    (let ((state (make-random-state)))
840      (loop      (loop
841         for i from 1 to niters do       for i from 1 to niters do
842            (let ((x (shuffle (loop for j from 1 to size collect       (let ((x (shuffle (loop for j from 1 to size collect
843                                    (random maxelem state))))                               (random maxelem state))))
844                  (y (shuffle (loop for j from 1 to size collect             (y (shuffle (loop for j from 1 to size collect
845                                    (random maxelem state)))))                               (random maxelem state)))))
846              (let ((z (nset-difference-with-check x y)))         (let ((z (nset-difference-with-check x y)))
847                (let ((is-good (check-nset-difference x y z)))           (let ((is-good (check-nset-difference x y z)))
848                  (unless is-good (return (values x y z)))))))             (unless is-good (return (values x y z)))))))
849      nil))      nil))
850    
851  (defun set-exclusive-or-with-check (x y &key (key 'no-key)  (defun set-exclusive-or-with-check (x y &key (key 'no-key)
852                                             test test-not)                                        test test-not)
853    (setf x (copy-list x))    (setf x (copy-list x))
854    (setf y (copy-list y))    (setf y (copy-list y))
855    (let ((xcopy (make-scaffold-copy x))    (let ((xcopy (make-scaffold-copy x))
# Line 841  the condition to go uncaught if it canno Line 857  the condition to go uncaught if it canno
857      (let ((result (apply #'set-exclusive-or      (let ((result (apply #'set-exclusive-or
858                           x y                           x y
859                           `(,@(unless (eqt key 'no-key) `(:key ,key))                           `(,@(unless (eqt key 'no-key) `(:key ,key))
860                             ,@(when test `(:test ,test))                               ,@(when test `(:test ,test))
861                             ,@(when test-not `(:test-not ,test-not))))))                                 ,@(when test-not `(:test-not ,test-not))))))  
862        (cond        (cond
863         ((and (check-scaffold-copy x xcopy)         ((and (check-scaffold-copy x xcopy)
864               (check-scaffold-copy y ycopy))               (check-scaffold-copy y ycopy))
# Line 851  the condition to go uncaught if it canno Line 867  the condition to go uncaught if it canno
867          'failed)))))          'failed)))))
868    
869  (defun check-set-exclusive-or (x y z &key (key #'identity)  (defun check-set-exclusive-or (x y z &key (key #'identity)
870                                          (test #'eql))                                   (test #'eql))
871    (and    (and
872     (not (eqt 'failed z))     ;; (not (eqt 'failed z))
873     (every #'(lambda (e) (or (member e x :key key :test test)     (listp x)
874                              (member e y :key key :test test)))     (listp y)
875            z)     (listp z)
876     (every #'(lambda (e) (if (member e y :key key :test test)     (loop for e in z always (or (member e x :key key :test test)
877                              (not (member e z :key key :test test))                                 (member e y :key key :test test)))
878                            (member e z :key key :test test)))     (loop for e in x always (if (member e y :key key :test test)
879            x)                                 (not (member e z :key key :test test))
880     (every #'(lambda (e) (if (member e x :key key :test test)                               (member e z :key key :test test)))
881                              (not (member e z :key key :test test))     (loop for e in y always (if (member e x :key key :test test)
882                            (member e z :key key :test test)))                                 (not (member e z :key key :test test))
883            y)                               (member e z :key key :test test)))
884     t))     t))
885    
886  (defun do-random-set-exclusive-ors (size niters &optional (maxelem (* 2 size)))  (defun do-random-set-exclusive-ors (size niters &optional (maxelem (* 2 size)))
887    (let ((state (make-random-state)))    (let ((state (make-random-state)))
888      (loop      (loop
889         for i from 1 to niters do       for i from 1 to niters do
890            (let ((x (shuffle (loop for j from 1 to size collect       (let ((x (shuffle (loop for j from 1 to size collect
891                                    (random maxelem state))))                               (random maxelem state))))
892                  (y (shuffle (loop for j from 1 to size collect             (y (shuffle (loop for j from 1 to size collect
893                                    (random maxelem state)))))                               (random maxelem state)))))
894              (let ((z (set-exclusive-or-with-check x y)))         (let ((z (set-exclusive-or-with-check x y)))
895                (let ((is-good (check-set-exclusive-or x y z)))           (let ((is-good (check-set-exclusive-or x y z)))
896                  (unless is-good (return (values x y z)))))))             (unless is-good (return (values x y z)))))))
897      nil))      nil))
898    
899  (defun nset-exclusive-or-with-check (x y &key (key 'no-key)  (defun nset-exclusive-or-with-check (x y &key (key 'no-key)
900                                             test test-not)                                         test test-not)
901    (setf x (copy-list x))    (setf x (copy-list x))
902    (setf y (copy-list y))    (setf y (copy-list y))
903    (apply #'nset-exclusive-or    (apply #'nset-exclusive-or
# Line 893  the condition to go uncaught if it canno Line 909  the condition to go uncaught if it canno
909  (defun do-random-nset-exclusive-ors (size niters &optional (maxelem (* 2 size)))  (defun do-random-nset-exclusive-ors (size niters &optional (maxelem (* 2 size)))
910    (let ((state (make-random-state)))    (let ((state (make-random-state)))
911      (loop      (loop
912         for i from 1 to niters do       for i from 1 to niters do
913            (let ((x (shuffle (loop for j from 1 to size collect       (let ((x (shuffle (loop for j from 1 to size collect
914                                    (random maxelem state))))                               (random maxelem state))))
915                  (y (shuffle (loop for j from 1 to size collect             (y (shuffle (loop for j from 1 to size collect
916                                    (random maxelem state)))))                               (random maxelem state)))))
917              (let ((z (nset-exclusive-or-with-check x y)))         (let ((z (nset-exclusive-or-with-check x y)))
918                (let ((is-good (check-set-exclusive-or x y z)))           (let ((is-good (check-set-exclusive-or x y z)))
919                  (unless is-good (return (values x y z)))))))             (unless is-good (return (values x y z)))))))
920      nil))      nil))
921    
922  (defun subsetp-with-check (x y &key (key 'no-key) test test-not)  (defun subsetp-with-check (x y &key (key 'no-key) test test-not)
# Line 910  the condition to go uncaught if it canno Line 926  the condition to go uncaught if it canno
926             (apply #'subsetp x y             (apply #'subsetp x y
927                    `(,@(unless (eqt key 'no-key)                    `(,@(unless (eqt key 'no-key)
928                          `(:key ,key))                          `(:key ,key))
929                      ,@(when test `(:test ,test))                        ,@(when test `(:test ,test))
930                      ,@(when test-not `(:test-not ,test-not))))))                        ,@(when test-not `(:test-not ,test-not))))))
931        (cond        (cond
932         ((and (check-scaffold-copy x xcopy)         ((and (check-scaffold-copy x xcopy)
933               (check-scaffold-copy y ycopy))               (check-scaffold-copy y ycopy))
# Line 919  the condition to go uncaught if it canno Line 935  the condition to go uncaught if it canno
935         (t 'failed)))))         (t 'failed)))))
936    
937  (defun safe-elt (x n)  (defun safe-elt (x n)
   (classify-error* (elt x n)))  
938      (classify-error* (elt x n)))

Legend:
Removed from v.1.14  
changed lines
  Added in v.1.15

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26