/[gcl]/gcl/ansi-tests/remove-aux.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/remove-aux.lsp

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

revision 1.1 by pfdietz, Thu Sep 26 16:53:38 2002 UTC revision 1.2 by pfdietz, Mon Sep 30 01:12:10 2002 UTC
# Line 205  Line 205 
205                       (when test-not (list :test test-not)))))))                       (when test-not (list :test test-not)))))))
206        (values element seq arg-list))))        (values element seq arg-list))))
207    
208  (defun random-test-remove (maxlen)  (defun random-test-remove (maxlen &key (tested-fn #'remove)
209                                      (check-fn #'my-remove)
210                                      (pure t))
211    (multiple-value-bind (element seq arg-list)    (multiple-value-bind (element seq arg-list)
212        (random-test-remove-args maxlen)        (random-test-remove-args maxlen)
213      (let* ((seq1 (copy-seq seq))      (let* ((seq1 (copy-seq seq))
214             (seq2 (copy-seq seq))             (seq2 (copy-seq seq))
215             (seq1r (apply #'remove element seq1 arg-list))             (seq1r (apply tested-fn element seq1 arg-list))
216             (seq2r (apply #'my-remove element seq1 arg-list)))             (seq2r (apply check-fn element seq2 arg-list)))
217        (cond        (cond
218         ((not (equalp seq seq1)) :fail1)         ((and pure (not (equalp seq seq1))) :fail1)
219         ((not (equalp seq seq2)) :fail2)         ((and pure (not (equalp seq seq2))) :fail2)
220         ((not (equalp seq1r seq2r)) :fail3)         ((not (equalp seq1r seq2r)) :fail3)
221         (t t)))))         (t t)))))
222    
223    (defun random-test-remove-if (maxlen &optional (negate nil))
224      (multiple-value-bind (element seq arg-list)
225          (random-test-remove-args maxlen)
226        (let ((fn (getf arg-list :key))
227              (test (getf arg-list :test)))
228          (remf arg-list :key)
229          (remf arg-list :test)
230          (remf arg-list :test-not)
231          (unless test (setq test #'eql))
232          (if fn
233              (case (random 3)
234                (0 (setf arg-list (list* :key 'identity arg-list)))
235                (1 (setf arg-list (list* :key #'identity arg-list)))
236                (t nil))
237            (setf fn (if (coin) 'identity
238                       #'(lambda (x) (funcall test element x)))))
239          (let* ((seq1 (copy-seq seq))
240                 (seq2 (copy-seq seq))
241                 (seq1r (apply (if negate #'remove-if-not #'remove-if)
242                               fn seq1 arg-list))
243                 (seq2r (apply (if negate #'my-remove-if-not #'my-remove-if)
244                               fn seq2 arg-list)))
245            (cond
246             ((not (equalp seq seq1)) :fail1)
247             ((not (equalp seq seq2)) :fail2)
248             ((not (equalp seq1r seq2r)) :fail3)
249             (t t))))))
250    
251    (defun random-test-delete (maxlen)
252      (random-test-remove maxlen :tested-fn #'delete :pure nil))
253    
254    (defun random-test-delete-if (maxlen &optional (negate nil))
255      (multiple-value-bind (element seq arg-list)
256          (random-test-remove-args maxlen)
257        (let ((fn (getf arg-list :key))
258              (test (getf arg-list :test)))
259          (remf arg-list :key)
260          (remf arg-list :test)
261          (remf arg-list :test-not)
262          (unless test (setq test #'eql))
263          (if fn
264              (case (random 3)
265                (0 (setf arg-list (list* :key 'identity arg-list)))
266                (1 (setf arg-list (list* :key #'identity arg-list)))
267                (t nil))
268            (setf fn (if (coin) 'identity
269                       #'(lambda (x) (funcall test element x)))))
270          (let* ((seq1 (copy-seq seq))
271                 (seq2 (copy-seq seq))
272                 (seq1r (apply (if negate #'delete-if-not #'delete-if)
273                               fn seq1 arg-list))
274                 (seq2r (apply (if negate #'my-remove-if-not #'my-remove-if)
275                               fn seq2 arg-list)))
276            (cond
277             ((not (equalp seq1r seq2r)) :fail3)
278             (t t))))))

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

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