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

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

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

revision 1.6 by pfdietz, Mon Jan 13 14:11:49 2003 UTC revision 1.7 by pfdietz, Sat Feb 8 06:23:02 2003 UTC
# Line 19  Line 19 
19  ;;; first, ..., tenth  ;;; first, ..., tenth
20    
21  (deftest first-etc-1  (deftest first-etc-1
22      (let ((x (loop for i from 1 to 20 collect i)))    (let ((x (loop for i from 1 to 20 collect i)))
23        (list (first x)      (list (first x)
24              (second x)            (second x)
25              (third x)            (third x)
26              (fourth x)            (fourth x)
27              (fifth x)            (fifth x)
28              (sixth x)            (sixth x)
29              (seventh x)            (seventh x)
30              (eighth x)            (eighth x)
31              (ninth x)            (ninth x)
32              (tenth x)))            (tenth x)))
33    (1 2 3 4 5 6 7 8 9 10))    (1 2 3 4 5 6 7 8 9 10))
34    
35  (deftest first-etc-2  (deftest first-etc-2
36      (let ((x (make-list 15 :initial-element 'a)))    (let ((x (make-list 15 :initial-element 'a)))
37        (and      (and
38         (eql (setf (first x) 1) 1)       (eql (setf (first x) 1) 1)
39         (eql (setf (second x) 2) 2)       (eql (setf (second x) 2) 2)
40         (eql (setf (third x) 3) 3)       (eql (setf (third x) 3) 3)
41         (eql (setf (fourth x) 4) 4)       (eql (setf (fourth x) 4) 4)
42         (eql (setf (fifth x) 5) 5)       (eql (setf (fifth x) 5) 5)
43         (eql (setf (sixth x) 6) 6)       (eql (setf (sixth x) 6) 6)
44         (eql (setf (seventh x) 7) 7)       (eql (setf (seventh x) 7) 7)
45         (eql (setf (eighth x) 8) 8)       (eql (setf (eighth x) 8) 8)
46         (eql (setf (ninth x) 9) 9)       (eql (setf (ninth x) 9) 9)
47         (eql (setf (tenth x) 10) 10)       (eql (setf (tenth x) 10) 10)
48         x))       x))
49    (1 2 3 4 5 6 7 8 9 10 a a a a a))    (1 2 3 4 5 6 7 8 9 10 a a a a a))
50    
51  (deftest rest-set-1  (deftest rest-set-1
52      (let ((x (list 'a 'b 'c)))    (let ((x (list 'a 'b 'c)))
53        (and      (and
54         (eqt (setf (rest x) 'd) 'd)       (eqt (setf (rest x) 'd) 'd)
55         x))       x))
56    (a . d))    (a . d))
57    
58  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
59  ;;; setting of C*R accessors  ;;; setting of C*R accessors
60    
61  (loop  (loop
62      for fn in '(car cdr caar cadr cdar cddr   for fn in '(car cdr caar cadr cdar cddr
63                  caaar caadr cadar caddr cdaar cdadr cddar cdddr                   caaar caadr cadar caddr cdaar cdadr cddar cdddr
64                  caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr                   caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
65                  cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)                   cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)
66      do   do
67        (let ((level (- (length (symbol-name fn)) 2)))   (let ((level (- (length (symbol-name fn)) 2)))
68          (eval `(deftest ,(intern     (eval `(deftest ,(intern
69                            (concatenate 'string                       (concatenate 'string
70                              (symbol-name fn)                                    (symbol-name fn)
71                              "-SET")                                    "-SET")
72                            :cl-test)                       :cl-test)
73                     (let ((x (create-c*r-test ,level))              (let ((x (create-c*r-test ,level))
74                           (y (list (create-c*r-test ,level)))                    (y (list (create-c*r-test ,level)))
75                           (i 0))                    (i 0))
                      (and  
                       (setf (,fn (progn (incf i) x)) 'a)  
                       (eqlt (,fn x) 'a)  
                       (eqlt i 1)  
                       (setf (,fn x) 'none)  
                       (equalt x (create-c*r-test ,level))  
                       (setf (,fn (progn (incf i) (car y))) 'a)  
                       (eqlt (,fn (car y)) 'a)  
                       (eqlt i 2)  
                       (setf (,fn (car y)) 'none)  
                       (null (cdr y))  
                       (equalt (car y) (create-c*r-test ,level))  
                       ))  
                  t))))  
   
 (loop  
     for (fn len) in '((first 1) (second 2) (third 3) (fourth 4)  
                       (fifth 5) (sixth 6) (seventh 7) (eighth 8)  
                       (ninth 9) (tenth 10))  
     do  
       (eval  
        `(deftest ,(intern  
                    (concatenate 'string  
                      (symbol-name fn)  
                      "-SET")  
                    :cl-test)  
             (let* ((x (make-list 20 :initial-element nil))  
                    (y (list (copy-list x)))  
                    (cnt 0))  
76                (and                (and
77                 (setf (,fn (progn (incf cnt) x)) 'a)                 (setf (,fn (progn (incf i) x)) 'a)
                (eqlt cnt 1)  
                (loop  
                    for i from 1 to 20  
                    do (when (and (not (eql i ,len))  
                                  (nth (1- i) x))  
                         (return nil))  
                    finally (return t))  
                (setf (,fn (car y)) 'a)  
                (loop  
                    for i from 1 to 20  
                    do (when (and (not (eql i ,len))  
                                  (nth (1- i) (car y)))  
                         (return nil))  
                    finally (return t))  
78                 (eqlt (,fn x) 'a)                 (eqlt (,fn x) 'a)
79                 (eqlt (nth ,(1- len) x) 'a)                 (eqlt i 1)
80                   (setf (,fn x) 'none)
81                   (equalt x (create-c*r-test ,level))
82                   (setf (,fn (progn (incf i) (car y))) 'a)
83                 (eqlt (,fn (car y)) 'a)                 (eqlt (,fn (car y)) 'a)
84                 (nth ,(1- len) (car y))))                 (eqlt i 2)
85              a)))                 (setf (,fn (car y)) 'none)
86                   (null (cdr y))
87                   (equalt (car y) (create-c*r-test ,level))
88                   ))
89                t))))
90    
91    (loop
92     for (fn len) in '((first 1) (second 2) (third 3) (fourth 4)
93                       (fifth 5) (sixth 6) (seventh 7) (eighth 8)
94                       (ninth 9) (tenth 10))
95     do
96     (eval
97      `(deftest ,(intern
98                  (concatenate 'string
99                               (symbol-name fn)
100                               "-SET")
101                  :cl-test)
102         (let* ((x (make-list 20 :initial-element nil))
103                (y (list (copy-list x)))
104                (cnt 0))
105           (and
106            (setf (,fn (progn (incf cnt) x)) 'a)
107            (eqlt cnt 1)
108            (loop
109             for i from 1 to 20
110             do (when (and (not (eql i ,len))
111                           (nth (1- i) x))
112                  (return nil))
113             finally (return t))
114            (setf (,fn (car y)) 'a)
115            (loop
116             for i from 1 to 20
117             do (when (and (not (eql i ,len))
118                           (nth (1- i) (car y)))
119                  (return nil))
120             finally (return t))
121            (eqlt (,fn x) 'a)
122            (eqlt (nth ,(1- len) x) 'a)
123            (eqlt (,fn (car y)) 'a)
124            (nth ,(1- len) (car y))))
125         a)))
126    
127  ;; set up program error tests  ;; set up program error tests
128    
129  (loop for name in *cons-accessors*  (loop for name in *cons-accessors*
130        do (eval        do (eval
131            `(deftest ,(intern (concatenate 'string (symbol-name name)            `(deftest ,(intern (concatenate 'string (symbol-name name)
132                                              ".ERROR.NO-ARGS")                                            ".ERROR.NO-ARGS")
133                                 :cl-test)                               :cl-test)
134               (classify-error (,name))               (classify-error (,name))
135               program-error))               program-error))
136        do (eval        do (eval
137            `(deftest ,(intern (concatenate 'string (symbol-name name)            `(deftest ,(intern (concatenate 'string (symbol-name name)
138                                              ".ERROR.EXCESS-ARGS")                                            ".ERROR.EXCESS-ARGS")
139                                 :cl-test)                               :cl-test)
140               (classify-error (,name nil nil))               (classify-error (,name nil nil))
141               program-error)))                   program-error)))    
142    
143  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
144  ;;; nth  ;;; nth
145    
146  (deftest nth-1  (deftest nth.1
147    (nth-1-body (loop for i from 1 to 2000 collect (* 4 i)))    (nth-1-body (loop for i from 1 to 2000 collect (* 4 i)))
148    0)    0)
149    
150  (deftest nth-2  (deftest nth.2
151    (let ((x (loop for i from 1 to 2000 collect i)))    (let ((x (loop for i from 1 to 2000 collect i)))
152      (loop      (loop
153       for i from 0 to 1999 do       for i from 0 to 1999 do
# Line 156  Line 156 
156    t)    t)
157    
158  ;;; Test side effects, evaluation order in assignment to NTH  ;;; Test side effects, evaluation order in assignment to NTH
159  (deftest nth-3  (deftest nth.3
160    (let ((i 0)    (let ((i 0)
161          (x (list 'a 'b 'c 'd))          (x (list 'a 'b 'c 'd))
162          y z)          y z)
# Line 168  Line 168 
168       x))       x))
169    (a z c d))    (a z c d))
170    
171    (deftest nth.4
172      (let ((i 0) x y (z '(a b c d e)))
173        (values
174         (nth (progn (setf x (incf i)) 1)
175              (progn (setf y (incf i)) z))
176         i x y))
177      b 2 1 2)
178    
179  (deftest nth.error.1  (deftest nth.error.1
180    (classify-error (nth))    (classify-error (nth))
181    program-error)    program-error)

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.7

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