/[gcl]/gcl/ansi-tests/cons-test-01.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/cons-test-01.lsp

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

revision 1.11 by pfdietz, Sun Feb 23 17:11:13 2003 UTC revision 1.12 by pfdietz, Sun Apr 20 13:17:45 2003 UTC
# Line 123  Line 123 
123  (deftest no-cons-fns-are-macros  (deftest no-cons-fns-are-macros
124    (some #'macro-function *cons-fns*)    (some #'macro-function *cons-fns*)
125    nil)    nil)
   
 ;; Various easy tests of cons  
 (deftest cons-of-symbols  
   (cons 'a 'b)  
   (a . b))  
   
 (deftest cons-with-nil  
   (cons 'a nil)  
   (a))  
   
 ;; successive calls to cons produces results that are equal, but not eq  
 (deftest cons-eq-equal  
   (let ((x (cons 'a 'b))  
         (y (cons 'a 'b)))  
     (and (not (eqt x y))  
          (equalt x y)))  
   t)  
   
 ;; list can be expressed as a bunch of conses (with nil)  
 (deftest cons-equal-list  
   (equalt (cons 'a (cons 'b (cons 'c nil)))  
           (list 'a 'b 'c))  
   t)  
   
 ;;; Order of evaluation of cons arguments  
 (deftest cons.order.1  
   (let ((i 0)) (values (cons (incf i) (incf i)) i))  
   (1 . 2) 2)  
   
 ;; Lists satisfy consp  
 (deftest consp-list  
   (notnot-mv (consp '(a)))  
   t)  
   
 ;; cons satisfies consp  
 (deftest consp-cons  
   (notnot-mv (consp (cons nil nil)))  
   t)  
   
 ;; nil is not a consp  
 (deftest consp-nil  
   (consp nil)  
   nil)  
   
 ;; The empty list is not a cons  
 (deftest consp-empty-list  
   (consp (list))  
   nil)  
   
 ;; A single element list is a cons  
 (deftest consp-single-element-list  
   (notnot-mv (consp (list 'a)))  
   t)  
   
 ;; For everything in *universe*, it is either an atom, or satisfies  
 ;; consp, but not both  
 (deftest consp-xor-atom-universe  
   (notnot-mv  
    (every #'(lambda (x) (or (and (consp x) (not (atom x)))  
                             (and (not (consp x)) (atom x))))  
           *universe*))  
   t)  
   
 ;; Everything in type cons satisfies consp, and vice versa  
 (deftest consp-cons-universe  
   (check-type-predicate 'consp 'cons)  
   0)  
   
 (deftest consp.order.1  
   (let ((i 0))  
     (values (consp (incf i)) i))  
   nil 1)  
   
 (deftest consp.error.1  
   (classify-error (consp))  
   program-error)  
   
 (deftest consp.error.2  
   (classify-error (consp 'a 'b))  
   program-error)  
   
 (deftest atom.order.1  
   (let ((i 0))  
     (values (atom (progn (incf i) '(a b))) i))  
   nil 1)  
   
 (deftest atom.error.1  
   (classify-error (atom))  
   program-error)  
   
 (deftest atom.error.2  
   (classify-error (atom 'a 'b))  
   program-error)  
   
 ;; Tests of car, cdr and compound forms  
 (deftest cons.23  
   (car '(a))  
   a)  
   
 (deftest cons.24  
   (cdr '(a . b))  
   b)  
   
 (deftest cons.25  
   (caar '((a)))  
   a)  
   
 (deftest cons.26  
   (cdar '((a . b)))  
   b)  
   
 (deftest cons.27  
   (cadr '(a b))  
   b)  
   
 (deftest cons.28  
   (cddr '(a b . c))  
   c)  
   
 (deftest cons.29  
   (caaar '(((a))))  
   a)  
   
 (deftest cons.30  
   (cdaar '(((a . b))))  
   b)  
   
 (deftest cons.31  
   (cadar (cons (cons 'a (cons 'b 'c)) 'd))  
   b)  
   
 (deftest cons.32  
   (cddar (cons (cons 'a (cons 'b 'c)) 'd))  
   c)  
   
 (deftest cons.33  
   (caadr (cons 'a (cons (cons 'b 'c) 'd)))  
   b)  
   
 (deftest cons.34  
   (caddr (cons 'a (cons 'b (cons 'c 'd))))  
   c)  
   
 (deftest cons.36  
   (cdadr (cons 'a (cons (cons 'b 'c) 'd)))  
   c)  
   
 (deftest cons.37  
   (cdddr (cons 'a (cons 'b (cons 'c 'd))))  
   d)  
   
 (defvar *cons-test-4*  
   (cons (cons (cons (cons 'a 'b)  
                     (cons 'c 'd))  
               (cons (cons 'e 'f)  
                     (cons 'g 'h)))  
         (cons (cons (cons 'i 'j)  
                     (cons 'k 'l))  
               (cons (cons 'm 'n)  
                     (cons 'o 'p)))))  
   
   
 (deftest cons.38  
   (caaaar *cons-test-4*)  
   a)  
   
 (deftest cons.39  
   (cdaaar *cons-test-4*)  
   b)  
   
 (deftest cons.40  
   (cadaar *cons-test-4*)  
   c)  
   
 (deftest cons.41  
   (cddaar *cons-test-4*)  
   d)  
   
 (deftest cons.42  
   (caadar *cons-test-4*)  
   e)  
   
 (deftest cons.43  
   (cdadar *cons-test-4*)  
   f)  
   
 (deftest cons.44  
   (caddar *cons-test-4*)  
   g)  
   
 (deftest cons.45  
   (cdddar *cons-test-4*)  
   h)  
   
 ;;;  
   
 (deftest cons.46  
   (caaadr *cons-test-4*)  
   i)  
   
 (deftest cons.47  
   (cdaadr *cons-test-4*)  
   j)  
   
 (deftest cons.48  
   (cadadr *cons-test-4*)  
   k)  
   
 (deftest cons.49  
   (cddadr *cons-test-4*)  
   l)  
   
 (deftest cons.50  
   (caaddr *cons-test-4*)  
   m)  
   
 (deftest cons.51  
   (cdaddr *cons-test-4*)  
   n)  
   
 (deftest cons.52  
   (cadddr *cons-test-4*)  
   o)  
   
 (deftest cons.53  
   (cddddr *cons-test-4*)  
   p)  
   
 (deftest cons.error.1  
   (classify-error (cons))  
   program-error)  
   
 (deftest cons.error.2  
   (classify-error (cons 'a))  
   program-error)  
   
 (deftest cons.error.3  
   (classify-error (cons 'a 'b 'c))  
   program-error)  
   
 ;; Test rplaca, rplacd  
   
 (deftest rplaca.1  
   (let ((x (cons 'a 'b)))  
     (let ((y x))  
       (and (eqt (rplaca x 'c) y)  
            (eqt x y)  
            (eqt (car x) 'c)  
            (eqt (cdr x) 'b))))  
   t)  
   
 (deftest rplaca.order.1  
   (let ((x (cons 'a 'b))  
         (i 0) a b)  
     (values  
      (rplaca (progn (setf a (incf i)) x)  
              (progn (setf b (incf i)) 'c))  
      i a b))  
   (c . b) 2 1 2)  
   
 (deftest rplacd.1  
   (let ((x (cons 'a 'b)))  
     (let ((y x))  
       (and (eqt (rplacd x 'd) y)  
            (eqt x y)  
            (eqt (car x) 'a)  
            (eqt (cdr x) 'd))))  
   t)  
   
 (deftest rplacd.order.1  
   (let ((x (cons 'a 'b))  
         (i 0) a b)  
     (values  
      (rplacd (progn (setf a (incf i)) x)  
              (progn (setf b (incf i)) 'c))  
      i a b))  
   (a . c) 2 1 2)  
   
 ;; rplaca on a fixnum is a type error  
 (deftest rplaca.error.1  
   (loop for x in *universe*  
         thereis (and (not (consp x))  
                      (not (eq (catch-type-error (rplaca x 1)) 'type-error))))  
   nil)  
   
 (deftest rplaca.error.2  
   (classify-error (rplaca))  
   program-error)  
   
 (deftest rplaca.error.3  
   (classify-error (rplaca (cons 'a 'b)))  
   program-error)  
   
 (deftest rplaca.error.4  
   (classify-error (rplaca (cons 'a 'b) (cons 'c 'd) 'garbage))  
   program-error)  
   
 (deftest rplaca.error.5  
   (classify-error (rplaca 'a 1))  
   type-error)  
   
 (deftest rplaca.error.6  
   (classify-error (locally (rplaca 'a 1) t))  
   type-error)  
   
 ;; rplacd on a fixnum is a type error  
 (deftest rplacd.error.1  
   (loop for x in *universe*  
         thereis (and (not (consp x))  
                      (not (eq (catch-type-error (rplacd x 1)) 'type-error))))  
   nil)  
   
 (deftest rplacd.error.2  
   (classify-error (rplacd))  
   program-error)  
   
 (deftest rplacd.error.3  
   (classify-error (rplacd (cons 'a 'b)))  
   program-error)  
   
 (deftest rplacd.error.4  
   (classify-error (rplacd (cons 'a 'b) (cons 'c 'd) 'garbage))  
   program-error)  
   
 (deftest rplacd.error.5  
   (classify-error (rplacd 'a 1))  
   type-error)  
   
 (deftest rplacd.error.6  
   (classify-error (locally (rplacd 'a 1) t))  
   type-error)  

Legend:
Removed from v.1.11  
changed lines
  Added in v.1.12

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