1 | ;-*- Mode: Lisp -*- |
---|
2 | ;;;; Author: Paul Dietz |
---|
3 | ;;;; Created: Sat Mar 28 07:34:08 1998 |
---|
4 | ;;;; Contains: Testing of CL Features related to "CONS", part 5 |
---|
5 | |
---|
6 | (in-package :cl-test) |
---|
7 | |
---|
8 | (compile-and-load "cons-aux.lsp") |
---|
9 | |
---|
10 | (defparameter *cons-accessors* |
---|
11 | '(first second third fourth fifth sixth seventh eighth ninth tenth |
---|
12 | car cdr caar cadr cdar cddr |
---|
13 | caaar caadr cadar caddr cdaar cdadr cddar cdddr |
---|
14 | caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr |
---|
15 | cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)) |
---|
16 | |
---|
17 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
18 | ;;; first, ..., tenth |
---|
19 | |
---|
20 | (deftest first-etc-1 |
---|
21 | (let ((x (loop for i from 1 to 20 collect i))) |
---|
22 | (list (first x) |
---|
23 | (second x) |
---|
24 | (third x) |
---|
25 | (fourth x) |
---|
26 | (fifth x) |
---|
27 | (sixth x) |
---|
28 | (seventh x) |
---|
29 | (eighth x) |
---|
30 | (ninth x) |
---|
31 | (tenth x))) |
---|
32 | (1 2 3 4 5 6 7 8 9 10)) |
---|
33 | |
---|
34 | (deftest first-etc-2 |
---|
35 | (let ((x (make-list 15 :initial-element 'a))) |
---|
36 | (and |
---|
37 | (eql (setf (first x) 1) 1) |
---|
38 | (eql (setf (second x) 2) 2) |
---|
39 | (eql (setf (third x) 3) 3) |
---|
40 | (eql (setf (fourth x) 4) 4) |
---|
41 | (eql (setf (fifth x) 5) 5) |
---|
42 | (eql (setf (sixth x) 6) 6) |
---|
43 | (eql (setf (seventh x) 7) 7) |
---|
44 | (eql (setf (eighth x) 8) 8) |
---|
45 | (eql (setf (ninth x) 9) 9) |
---|
46 | (eql (setf (tenth x) 10) 10) |
---|
47 | x)) |
---|
48 | (1 2 3 4 5 6 7 8 9 10 a a a a a)) |
---|
49 | |
---|
50 | (deftest rest-set-1 |
---|
51 | (let ((x (list 'a 'b 'c))) |
---|
52 | (and |
---|
53 | (eqt (setf (rest x) 'd) 'd) |
---|
54 | x)) |
---|
55 | (a . d)) |
---|
56 | |
---|
57 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
58 | ;;; setting of C*R accessors |
---|
59 | |
---|
60 | (loop |
---|
61 | for fn in '(car cdr caar cadr cdar cddr |
---|
62 | caaar caadr cadar caddr cdaar cdadr cddar cdddr |
---|
63 | caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr |
---|
64 | cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr) |
---|
65 | do |
---|
66 | (let ((level (- (length (symbol-name fn)) 2))) |
---|
67 | (eval `(deftest ,(intern |
---|
68 | (concatenate 'string |
---|
69 | (symbol-name fn) |
---|
70 | "-SET") |
---|
71 | :cl-test) |
---|
72 | (let ((x (create-c*r-test ,level)) |
---|
73 | (y (list (create-c*r-test ,level))) |
---|
74 | (i 0)) |
---|
75 | (and |
---|
76 | (setf (,fn (progn (incf i) x)) 'a) |
---|
77 | (eqlt (,fn x) 'a) |
---|
78 | (eqlt i 1) |
---|
79 | (setf (,fn x) 'none) |
---|
80 | (equalt x (create-c*r-test ,level)) |
---|
81 | (setf (,fn (progn (incf i) (car y))) 'a) |
---|
82 | (eqlt (,fn (car y)) 'a) |
---|
83 | (eqlt i 2) |
---|
84 | (setf (,fn (car y)) 'none) |
---|
85 | (null (cdr y)) |
---|
86 | (equalt (car y) (create-c*r-test ,level)) |
---|
87 | )) |
---|
88 | t)))) |
---|
89 | |
---|
90 | (loop |
---|
91 | for (fn len) in '((first 1) (second 2) (third 3) (fourth 4) |
---|
92 | (fifth 5) (sixth 6) (seventh 7) (eighth 8) |
---|
93 | (ninth 9) (tenth 10)) |
---|
94 | do |
---|
95 | (eval |
---|
96 | `(deftest ,(intern |
---|
97 | (concatenate 'string |
---|
98 | (symbol-name fn) |
---|
99 | "-SET") |
---|
100 | :cl-test) |
---|
101 | (let* ((x (make-list 20 :initial-element nil)) |
---|
102 | (y (list (copy-list x))) |
---|
103 | (cnt 0)) |
---|
104 | (and |
---|
105 | (setf (,fn (progn (incf cnt) x)) 'a) |
---|
106 | (eqlt cnt 1) |
---|
107 | (loop |
---|
108 | for i from 1 to 20 |
---|
109 | do (when (and (not (eql i ,len)) |
---|
110 | (nth (1- i) x)) |
---|
111 | (return nil)) |
---|
112 | finally (return t)) |
---|
113 | (setf (,fn (car y)) 'a) |
---|
114 | (loop |
---|
115 | for i from 1 to 20 |
---|
116 | do (when (and (not (eql i ,len)) |
---|
117 | (nth (1- i) (car y))) |
---|
118 | (return nil)) |
---|
119 | finally (return t)) |
---|
120 | (eqlt (,fn x) 'a) |
---|
121 | (eqlt (nth ,(1- len) x) 'a) |
---|
122 | (eqlt (,fn (car y)) 'a) |
---|
123 | (nth ,(1- len) (car y)))) |
---|
124 | a))) |
---|
125 | |
---|
126 | ;; set up program-error tests |
---|
127 | |
---|
128 | (loop for name in *cons-accessors* |
---|
129 | do (eval |
---|
130 | `(deftest ,(intern (concatenate 'string (symbol-name name) |
---|
131 | ".ERROR.NO-ARGS") |
---|
132 | :cl-test) |
---|
133 | (signals-error (,name) program-error) |
---|
134 | t)) |
---|
135 | do (eval |
---|
136 | `(deftest ,(intern (concatenate 'string (symbol-name name) |
---|
137 | ".ERROR.EXCESS-ARGS") |
---|
138 | :cl-test) |
---|
139 | (signals-error (,name nil nil) program-error) |
---|
140 | t))) |
---|