/[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.2 by pfdietz, Thu Oct 17 13:16:56 2002 UTC revision 1.3 by pfdietz, Fri Oct 18 11:58:46 2002 UTC
# Line 177  Line 177 
177  ;; For everything in *universe*, it is either an atom, or satisfies  ;; For everything in *universe*, it is either an atom, or satisfies
178  ;; consp, but not both  ;; consp, but not both
179  (deftest consp-xor-atom-universe  (deftest consp-xor-atom-universe
180      (not (not    (notnot
181            (every #'(lambda (x) (or (and (consp x) (not (atom x)))     (every #'(lambda (x) (or (and (consp x) (not (atom x)))
182                                     (and (not (consp x)) (atom x))))                              (and (not (consp x)) (atom x))))
183                   *universe*)))            *universe*))
184    t)    t)
185    
186  ;; Everything in type cons satisfies consp, and vice versa  ;; Everything in type cons satisfies consp, and vice versa
# Line 190  Line 190 
190    
191  ;; Tests of car, cdr and compound forms  ;; Tests of car, cdr and compound forms
192  (deftest cons-23  (deftest cons-23
193      (car '(a))    (car '(a))
194    a)    a)
195    
196  (deftest cons-24  (deftest cons-24
197      (cdr '(a . b))    (cdr '(a . b))
198    b)    b)
199    
200  (deftest cons-25  (deftest cons-25
201      (caar '((a)))    (caar '((a)))
202    a)    a)
203    
204  (deftest cons-26  (deftest cons-26
205      (cdar '((a . b)))    (cdar '((a . b)))
206    b)    b)
207    
208  (deftest cons-27  (deftest cons-27
209      (cadr '(a b))    (cadr '(a b))
210    b)    b)
211    
212  (deftest cons-28  (deftest cons-28
213      (cddr '(a b . c))    (cddr '(a b . c))
214    c)    c)
215    
216  (deftest cons-29  (deftest cons-29
217      (caaar '(((a))))    (caaar '(((a))))
218    a)    a)
219    
220  (deftest cons-30  (deftest cons-30
221      (cdaar '(((a . b))))    (cdaar '(((a . b))))
222    b)    b)
223    
224  (deftest cons-31  (deftest cons-31
225      (cadar (cons (cons 'a (cons 'b 'c)) 'd))    (cadar (cons (cons 'a (cons 'b 'c)) 'd))
226    b)    b)
227    
228  (deftest cons-32  (deftest cons-32
229      (cddar (cons (cons 'a (cons 'b 'c)) 'd))    (cddar (cons (cons 'a (cons 'b 'c)) 'd))
230    c)    c)
231    
232  (deftest cons-33  (deftest cons-33
233      (caadr (cons 'a (cons (cons 'b 'c) 'd)))    (caadr (cons 'a (cons (cons 'b 'c) 'd)))
234    b)    b)
235    
236  (deftest cons-34  (deftest cons-34
237      (caddr (cons 'a (cons 'b (cons 'c 'd))))    (caddr (cons 'a (cons 'b (cons 'c 'd))))
238    c)    c)
239    
240  (deftest cons-36  (deftest cons-36
241      (cdadr (cons 'a (cons (cons 'b 'c) 'd)))    (cdadr (cons 'a (cons (cons 'b 'c) 'd)))
242    c)    c)
243    
244  (deftest cons-37  (deftest cons-37
245      (cdddr (cons 'a (cons 'b (cons 'c 'd))))    (cdddr (cons 'a (cons 'b (cons 'c 'd))))
246    d)    d)
247    
248  (defvar *cons-test-4*  (defvar *cons-test-4*
249      (cons (cons (cons (cons 'a 'b)    (cons (cons (cons (cons 'a 'b)
250                        (cons 'c 'd))                      (cons 'c 'd))
251                  (cons (cons 'e 'f)                (cons (cons 'e 'f)
252                        (cons 'g 'h)))                      (cons 'g 'h)))
253            (cons (cons (cons 'i 'j)          (cons (cons (cons 'i 'j)
254                        (cons 'k 'l))                      (cons 'k 'l))
255                  (cons (cons 'm 'n)                (cons (cons 'm 'n)
256                        (cons 'o 'p)))))                      (cons 'o 'p)))))
257                    
258    
259  (deftest cons-38  (deftest cons-38
260      (caaaar *cons-test-4*)    (caaaar *cons-test-4*)
261    a)    a)
262    
263  (deftest cons-39  (deftest cons-39
264      (cdaaar *cons-test-4*)    (cdaaar *cons-test-4*)
265    b)    b)
266    
267  (deftest cons-40  (deftest cons-40
268      (cadaar *cons-test-4*)    (cadaar *cons-test-4*)
269    c)    c)
270    
271  (deftest cons-41  (deftest cons-41
272      (cddaar *cons-test-4*)    (cddaar *cons-test-4*)
273    d)    d)
274    
275  (deftest cons-42  (deftest cons-42
276      (caadar *cons-test-4*)    (caadar *cons-test-4*)
277    e)    e)
278    
279  (deftest cons-43  (deftest cons-43
280      (cdadar *cons-test-4*)    (cdadar *cons-test-4*)
281    f)    f)
282    
283  (deftest cons-44  (deftest cons-44
284      (caddar *cons-test-4*)    (caddar *cons-test-4*)
285    g)    g)
286    
287  (deftest cons-45  (deftest cons-45
288      (cdddar *cons-test-4*)    (cdddar *cons-test-4*)
289    h)    h)
290    
291  ;;;  ;;;
292    
293  (deftest cons-46  (deftest cons-46
294      (caaadr *cons-test-4*)    (caaadr *cons-test-4*)
295    i)    i)
296    
297  (deftest cons-47  (deftest cons-47
298      (cdaadr *cons-test-4*)    (cdaadr *cons-test-4*)
299    j)    j)
300    
301  (deftest cons-48  (deftest cons-48
302      (cadadr *cons-test-4*)    (cadadr *cons-test-4*)
303    k)    k)
304    
305  (deftest cons-49  (deftest cons-49
306      (cddadr *cons-test-4*)    (cddadr *cons-test-4*)
307    l)    l)
308    
309  (deftest cons-50  (deftest cons-50
310      (caaddr *cons-test-4*)    (caaddr *cons-test-4*)
311    m)    m)
312    
313  (deftest cons-51  (deftest cons-51
314      (cdaddr *cons-test-4*)    (cdaddr *cons-test-4*)
315    n)    n)
316    
317  (deftest cons-52  (deftest cons-52
318      (cadddr *cons-test-4*)    (cadddr *cons-test-4*)
319    o)    o)
320    
321  (deftest cons-53  (deftest cons-53
322      (cddddr *cons-test-4*)    (cddddr *cons-test-4*)
323    p)    p)
324    
325    
326  ;; Test rplaca, rplacd  ;; Test rplaca, rplacd
327    
328  (deftest rplaca-1  (deftest rplaca-1
329      (let ((x (cons 'a 'b)))    (let ((x (cons 'a 'b)))
330        (let ((y x))      (let ((y x))
331          (and (eqt (rplaca x 'c) y)        (and (eqt (rplaca x 'c) y)
332               (eqt x y)             (eqt x y)
333               (eqt (car x) 'c)             (eqt (car x) 'c)
334               (eqt (cdr x) 'b)             (eqt (cdr x) 'b))))
              t)))  
335    t)    t)
336    
337  (deftest rplacd-1  (deftest rplacd-1
338      (let ((x (cons 'a 'b)))    (let ((x (cons 'a 'b)))
339        (let ((y x))      (let ((y x))
340          (and (eqt (rplacd x 'd) y)        (and (eqt (rplacd x 'd) y)
341               (eqt x y)             (eqt x y)
342               (eqt (car x) 'a)             (eqt (car x) 'a)
343               (eqt (cdr x) 'd)             (eqt (cdr x) 'd))))
              t)))  
344    t)    t)
345    
346  ;; rplaca on a fixnum is a type error  ;; rplaca on a fixnum is a type error
347  (deftest rplaca-error-1  (deftest rplaca-error-1
348      (let ((x 12340131))    (loop for x in *universe*
349        (catch-type-error (rplaca x 1)))          thereis (and (not (consp x))
350    type-error)                       (not (eq (catch-type-error (rplaca x 1)) 'type-error))))
351      nil)
352    
353  ;; rplacd on a fixnum is a type error  ;; rplacd on a fixnum is a type error
354  (deftest rplacd-error-1  (deftest rplacd-error-1
355      (let ((x 12340132))    (loop for x in *universe*
356        (catch-type-error (rplacd x 1)))          thereis (and (not (consp x))
357    type-error)                       (not (eq (catch-type-error (rplacd x 1)) 'type-error))))
358      nil)
 ;; To do: add tests for other invalid arguments  

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

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