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

Diff of /gcl/ansi-tests/remove-duplicates-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 02:00:27 2002 UTC
# Line 19  Line 19 
19      (assert (integerp start))      (assert (integerp start))
20      (assert (integerp end))      (assert (integerp end))
21      (assert (<= 0 start end len))      (assert (<= 0 start end len))
22      (format t "start = ~A, end = ~A, len = ~A~%" start end len)      ;; (format t "start = ~A, end = ~A, len = ~A~%" start end len)
23      (if from-end      (if from-end
24          (psetq start (- len end)          (psetq start (- len end)
25                 end (- len start)                 end (- len start)
26                 sequence (reverse sequence))                 sequence (reverse sequence))
27          (setq sequence (copy-seq sequence)))          (setq sequence (copy-seq sequence)))
28      (format t "start = ~A, end = ~A, len = ~A~%" start end len)      ;; (format t "start = ~A, end = ~A, len = ~A~%" start end len)
29      (assert (<= 0 start end len) (start end len))      (assert (<= 0 start end len) (start end len))
30      (let ((result nil))      (let ((result nil))
31        (loop for i from 0 below start        (loop for i from 0 below start
32              do (push (elt sequence i) result))              do (push (elt sequence i) result))
33        (loop for i from start below end        (loop for i from start below end
34              for x = (elt sequence i)              for x = (elt sequence i)
35              unless (position x              for kx = (if key (funcall key x) x)
36                unless (position kx
37                               sequence                               sequence
38                               :start (1+ i)                               :start (1+ i)
39                               :end end                               :end end
# Line 49  Line 50 
50                       :element-type (array-element-type orig-sequence)))                       :element-type (array-element-type orig-sequence)))
51          (t (assert nil))))))          (t (assert nil))))))
52    
53    (defun make-random-rdup-params (maxlen)
54      "Make random input parameters for REMOVE-DUPLICATES."
55      (multiple-value-bind (element-type type len start end from-end
56                                         count seq key test test-not)
57          (make-random-rd-params maxlen)
58        (declare (ignore count element-type))
59        (let ((arg-list
60               (reduce #'nconc
61                       (random-permute
62                        (list
63                         (when start (list :start start))
64                         (cond (end (list :end end))
65                               ((coin) (list :end nil)))
66                         (cond (from-end (list :from-end from-end))
67                               ((coin) (list :from-end nil)))
68                         (cond (key (list :key key))
69                               ;; ((coin) (list :key nil))
70                               )
71                         (when test (list :test test))
72                         (when test-not (list :test test-not)))))))
73          (values seq arg-list))))
74    
75    (defun random-test-remove-dups (maxlen &optional (pure t))
76      (multiple-value-bind (seq arg-list)
77          (make-random-rdup-params maxlen)
78        (let* ((seq1 (copy-seq seq))
79               (seq2 (copy-seq seq))
80               (seq1r (apply (if pure #'remove-duplicates
81                               #'delete-duplicates)
82                             seq1 arg-list))
83               (seq2r (apply #'my-remove-duplicates seq2 arg-list)))
84          (cond
85           ((and pure (not (equalp seq seq1))) :fail1)
86           ((and pure (not (equalp seq seq2))) :fail2)
87           ((not (equalp seq1r seq2r)) :fail3)
88           (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