/[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.5 by pfdietz, Sun Nov 10 22:34:33 2002 UTC revision 1.6 by pfdietz, Mon Nov 11 00:25:26 2002 UTC
# Line 32  Line 32 
32    (let* ((seq (if (subtypep* type 'list)    (let* ((seq (if (subtypep* type 'list)
33                    (loop for i from 1 to len collect                    (loop for i from 1 to len collect
34                          (make-random-element element-type))                          (make-random-element element-type))
35                  (let ((seq (make-sequence type len)))                  (let ((seq (if (and (subtypep type 'vector)
36                                        (coin 3))
37                                   (make-array
38                                    (list (+ len (random len)))
39                                    :initial-element (make-random-element element-type)
40                                    :fill-pointer len
41                                    :element-type element-type)
42                                   (make-sequence type len))))
43                    (dotimes (i len)                    (dotimes (i len)
44                      (setf (elt seq i) (make-random-element element-type)))                      (setf (elt seq i) (make-random-element element-type)))
45                    seq)))                    seq)))
46           (e (if (and (> len 0) (eql (random 2) 0))           (e (if (and (> len 0) (coin))
47                  (elt seq (random len))                  (elt seq (random len))
48                (make-random-element element-type)))                (make-random-element element-type)))
49           )           )
# Line 186  Line 193 
193                       (when test-not (list :test test-not)))))))                       (when test-not (list :test test-not)))))))
194        (values element seq arg-list))))        (values element seq arg-list))))
195    
196    (defparameter *remove-fail-args* nil)
197    
198  (defun random-test-remove (maxlen &key (tested-fn #'remove)  (defun random-test-remove (maxlen &key (tested-fn #'remove)
199                                    (check-fn #'my-remove)                                    (check-fn #'my-remove)
200                                    (pure t))                                    (pure t))
# Line 195  Line 204 
204             (seq2 (copy-seq seq))             (seq2 (copy-seq seq))
205             (seq1r (apply tested-fn element seq1 arg-list))             (seq1r (apply tested-fn element seq1 arg-list))
206             (seq2r (apply check-fn element seq2 arg-list)))             (seq2r (apply check-fn element seq2 arg-list)))
207          (setq *remove-fail-args* (list* element seq1 arg-list))
208        (cond        (cond
209         ((and pure (not (equalp seq seq1))) :fail1)         ((and pure (not (equalp seq seq1))) :fail1)
210         ((and pure (not (equalp seq seq2))) :fail2)         ((and pure (not (equalp seq seq2))) :fail2)
211         ((not (equalp seq1r seq2r)) :fail3)         ((not (equalp seq1r seq2r)) :fail3)
212         (t t)))))         (t t)))))
213    
 (defparameter *remove-fail-args* nil)  
   
214  (defun random-test-remove-if (maxlen &optional (negate nil))  (defun random-test-remove-if (maxlen &optional (negate nil))
215    (multiple-value-bind (element seq arg-list)    (multiple-value-bind (element seq arg-list)
216        (random-test-remove-args maxlen)        (random-test-remove-args maxlen)
# Line 251  Line 259 
259              (t nil))              (t nil))
260          (setf fn (if (coin) 'identity          (setf fn (if (coin) 'identity
261                     #'(lambda (x) (funcall test element x)))))                     #'(lambda (x) (funcall test element x)))))
262          (setq *remove-fail-args* (list* seq arg-list))
263        (let* ((seq1 (copy-seq seq))        (let* ((seq1 (copy-seq seq))
264               (seq2 (copy-seq seq))               (seq2 (copy-seq seq))
265               (seq1r (apply (if negate #'delete-if-not #'delete-if)               (seq1r (apply (if negate #'delete-if-not #'delete-if)

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

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