source: trunk/source/tests/ansi-tests/remove-aux.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 12 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 9.3 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sun Sep 15 07:42:36 2002
4;;;; Contains: Auxiliary functions for testing REMOVE and related functions
5
6(in-package :cl-test)
7
8(defun make-random-element (type)
9  (cond
10   ((subtypep* 'fixnum type)
11    (random most-positive-fixnum))
12   ((and (listp type)
13         (eql (car type) 'integer)
14         (integerp (cadr type))
15         (integerp (caddr type))
16         (null (cdddr type)))
17    (+ (cadr type) (random (- (1+ (caddr type)) (cadr type)))))
18   ((subtypep* '(integer 0 255) type)
19    (random 255))
20   ((subtypep* '(integer 0 7) type)
21    (random 8))
22   ((subtypep* 'bit type)
23    (random 2))
24   ((subtypep* 'symbol type)
25    (elt '(a b c d e f g h) (random 8)))
26   ((subtypep* '(member #\a #\b #\c #\d #\e #\f #\g #\h) type)
27    (elt "abcdefgh" (random 8)))
28   (t (error "Can't get random element of type ~A~%." type))))
29
30(defun make-random-remove-input (len type element-type)
31
32  "Randomly generate a test case for REMOVE.  Given a length
33   a sequence type, and an element type, produce a random
34   sequence of length LEN of sequence type TYPE, and either
35   generate a random member of the sequence or a random
36   element of the element type to delete from the sequence."
37 
38  (let* ((seq (if (subtypep* type 'list)
39                  (loop for i from 1 to len collect
40                        (make-random-element element-type))
41                (let ((seq (if (and (subtypep type 'vector)
42                                    (coin 3))
43                               (make-array
44                                (list (+ len (random (1+ len))))
45                                :initial-element (make-random-element element-type)
46                                :fill-pointer len
47                                :element-type element-type)
48                               (make-sequence type len))))
49                  (dotimes (i len)
50                    (setf (elt seq i) (make-random-element element-type)))
51                  seq)))
52         (e (if (and (> len 0) (coin))
53                (elt seq (random len))
54              (make-random-element element-type)))
55         )
56    (values len seq e)))
57
58(defun my-remove (element
59                  sequence
60                  &key
61                  (start 0)
62                  (end nil)
63                  (test #'eql test-p)
64                  (test-not nil test-not-p)
65                  (key nil)
66                  (from-end nil)
67                  (count nil))
68  (assert (not (and test-p test-not-p)))
69  (my-remove-if
70   (cond (test-p
71          (setf test (coerce test 'function))
72          #'(lambda (x) (funcall (the function test) element x)))
73         (test-not-p
74          (setf test-not (coerce test-not 'function))
75          #'(lambda (x) (not (funcall (the function test-not) element x))))
76         (t #'(lambda (x) (eql element x))))
77   sequence :start start :end end :key key :from-end from-end :count count))
78 
79(defun my-remove-if (predicate
80                     original-sequence
81                     &key (from-end nil)
82                     (start 0)
83                     (end nil)
84                     (count nil)
85                     (key #'identity))
86  (let ((len (length original-sequence))
87        (sequence (copy-seq original-sequence)))
88    (unless end (setq end len))
89    (unless key (setq key #'identity))
90    (unless count (setq count len))
91   
92    ;; Check that everything's kosher
93    (assert (<= 0 start end len))
94    (assert (typep sequence 'sequence))
95    (assert (integerp count))
96    (assert (or (symbolp predicate) (functionp predicate)))
97    (assert (or (symbolp key) (functionp key)))
98
99    (setf predicate (coerce predicate 'function))
100    (setf key (coerce key 'function))
101   
102    ;; If FROM-END, reverse the sequence and flip
103    ;; start, end
104    (when from-end
105      (psetq sequence (nreverse sequence)
106             start (- len end)
107             end (- len start)))
108
109    ;; Accumulate a list of elements for the result
110    (let ((pos 0)
111          (result nil)) ;; accumulate in reverse order
112      (map nil
113           #'(lambda (e)
114               (if (and (> count 0)
115                        (>= pos start)
116                        (< pos end)
117                        (funcall (the function predicate)
118                                 (funcall (the function key) e)))
119                   (decf count)
120                 (push e result))
121               (incf pos))
122           sequence)
123      (unless from-end
124        (setq result (nreverse result)))
125      ;; Convert to the correct type
126      (if (listp sequence)
127          result
128        (let ((element-type (array-element-type original-sequence)))
129          (make-array (length result) :element-type element-type
130                      :initial-contents result))))))
131
132(defun my-remove-if-not (pred &rest args)
133  (when (symbolp pred)
134    (setq pred (coerce pred 'function)))
135  (assert (typep pred 'function))
136  (apply #'my-remove-if (complement pred) args))
137
138(defun make-random-rd-params (maxlen)
139  "Generate random paramaters for remove/delete/etc. functions."
140  (let* ((element-type
141          (rcase
142           (2 t)
143           (1 'bit)
144           (1 '(integer 0 2))
145           (1 'symbol)))
146         (type-select (random 7))
147         (type
148          (case type-select
149            (0 'list)
150            (1 'vector)
151            (2 (setq element-type 'character) 'string)
152            (3 (setq element-type 'bit) 'bit-vector)
153            (4 'simple-vector)
154            (5 (setq element-type '(integer 0 255))
155               '(vector (integer 0 255)))
156            (6 (setq element-type 'fixnum) '(vector fixnum))
157            (t (error "Can't happen?!~%"))))
158         (len (random maxlen))
159         (start (and (coin) (> len 0)
160                     (random len)))
161         (end (and (coin)
162                   (if start (+ start (random (- len start)))
163                     (random (1+ len)))))
164         (from-end (coin))
165         (count (case (random 5)
166                  ((0 1) nil)
167                  ((2 3) (random (1+ len)))
168                  (t (if (coin) -1 -10000000000000))))
169         (seq (multiple-value-bind (x y z) (make-random-remove-input len type element-type)
170                (declare (ignore x z))
171                y))
172         (key (and (coin)
173                   (case type-select
174                     (2 (random-case
175                         #'char-upcase 'char-upcase
176                         #'char-downcase 'char-downcase))
177                     (3 #'(lambda (x) (- 1 x)))
178                     ((5 6) (random-case #'1+ '1+ #'1- '1-))
179                     (t (random-case 'identity #'identity)))))
180         (test (and (eql (random 3) 0)
181                    (random-case 'eq 'eql 'equal
182                                 #'eq #'eql #'equal)))
183         (test-not (and (not test)
184                        (coin)
185                        (random-case 'eq 'eql 'equal
186                                     #'eq #'eql #'equal)))
187         )
188    ;; Return parameters
189    (values
190     element-type type len start end from-end count seq key test test-not)))
191
192(defun random-test-remove-args (maxlen)
193  (multiple-value-bind (element-type type len start end from-end count seq key test test-not)
194      (make-random-rd-params maxlen)
195    (declare (ignore type))
196    (let ((element (if (and (coin) (> len 0))
197                       (random-from-seq seq)
198                     (make-random-element element-type)))
199          (arg-list
200           (reduce #'nconc
201                   (random-permute
202                    (list
203                     (when start (list :start start))
204                     (cond (end (list :end end))
205                           ((coin) (list :end nil)))
206                     (cond (from-end (list :from-end from-end))
207                           ((coin) (list :from-end nil)))
208                     (cond (count (list :count count))
209                           ((coin) (list :count nil)))
210                     (cond (key (list :key key))
211                           ;; ((coin) (list :key nil))
212                           )
213                     (when test (list :test test))
214                     (when test-not (list :test test-not)))))))
215      (values element seq arg-list))))
216
217(defparameter *remove-fail-args* nil)
218
219(defun random-test-remove (maxlen &key (tested-fn #'remove)
220                                  (check-fn #'my-remove)
221                                  (pure t))
222  (setf tested-fn (coerce tested-fn 'function))
223  (setf check-fn (coerce check-fn 'function))
224  (multiple-value-bind (element seq arg-list)
225      (random-test-remove-args maxlen)
226    (let* ((seq1 (copy-seq seq))
227           (seq2 (copy-seq seq))
228           (seq1r (apply (the function tested-fn) element seq1 arg-list))
229           (seq2r (apply (the function check-fn) element seq2 arg-list)))
230      (setq *remove-fail-args* (list* element seq arg-list))
231      (cond
232       ((and pure (not (equalp seq seq1))) :fail1)
233       ((and pure (not (equalp seq seq2))) :fail2)
234       ((not (equalp seq1r seq2r)) :fail3)
235       (t t)))))
236
237(defun random-test-remove-if (maxlen &optional (negate nil))
238  (multiple-value-bind (element seq arg-list)
239      (random-test-remove-args maxlen)
240    (let ((fn (getf arg-list :key))
241          (test (getf arg-list :test)))
242      (remf arg-list :key)
243      (remf arg-list :test)
244      (remf arg-list :test-not)
245      (unless test (setq test #'eql))
246      (setf test (coerce test 'function))
247      (if fn
248          (case (random 3)
249            (0 (setf arg-list (list* :key 'identity arg-list)))
250            (1 (setf arg-list (list* :key #'identity arg-list)))
251            (t nil))
252        (setf fn (if (coin) 'identity
253                   #'(lambda (x) (funcall (the function test)
254                                          element x)))))
255      (let* ((seq1 (copy-seq seq))
256             (seq2 (copy-seq seq))
257             (seq1r (apply (if negate #'remove-if-not #'remove-if)
258                           fn seq1 arg-list))
259             (seq2r (apply (if negate #'my-remove-if-not #'my-remove-if)
260                           fn seq2 arg-list)))
261        (setq *remove-fail-args* (cons seq1 arg-list))
262        (cond
263         ((not (equalp seq seq1)) :fail1)
264         ((not (equalp seq seq2)) :fail2)
265         ((not (equalp seq1r seq2r)) :fail3)
266         (t t))))))
267
268(defun random-test-delete (maxlen)
269  (random-test-remove maxlen :tested-fn #'delete :pure nil))
270
271(defun random-test-delete-if (maxlen &optional (negate nil))
272  (multiple-value-bind (element seq arg-list)
273      (random-test-remove-args maxlen)
274    (let ((fn (getf arg-list :key))
275          (test (getf arg-list :test)))
276      (remf arg-list :key)
277      (remf arg-list :test)
278      (remf arg-list :test-not)
279      (unless test (setq test #'eql))
280      (setf test (coerce test 'function))
281      (if fn
282          (case (random 3)
283            (0 (setf arg-list (list* :key 'identity arg-list)))
284            (1 (setf arg-list (list* :key #'identity arg-list)))
285            (t nil))
286        (setf fn (if (coin) 'identity
287                   #'(lambda (x) (funcall (the function test) element x)))))
288      (setq *remove-fail-args* (list* seq arg-list))
289      (let* ((seq1 (copy-seq seq))
290             (seq2 (copy-seq seq))
291             (seq1r (apply (if negate #'delete-if-not #'delete-if)
292                           fn seq1 arg-list))
293             (seq2r (apply (if negate #'my-remove-if-not #'my-remove-if)
294                           fn seq2 arg-list)))
295        (cond
296         ((not (equalp seq1r seq2r)) :fail3)
297         (t t))))))
Note: See TracBrowser for help on using the repository browser.