/[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.8 by pfdietz, Sun Jan 19 15:20:56 2003 UTC revision 1.9 by pfdietz, Sun Jul 27 15:30:39 2003 UTC
# Line 61  Line 61 
61                    (count nil))                    (count nil))
62    (assert (not (and test-p test-not-p)))    (assert (not (and test-p test-not-p)))
63    (my-remove-if    (my-remove-if
64     (cond (test-p #'(lambda (x) (funcall test element x)))     (cond (test-p
65           (test-not-p #'(lambda (x) (not (funcall test-not element x))))            (setf test (coerce test 'function))
66              #'(lambda (x) (funcall (the function test) element x)))
67             (test-not-p
68              (setf test-not (coerce test-not 'function))
69              #'(lambda (x) (not (funcall (the function test-not) element x))))
70           (t #'(lambda (x) (eql element x))))           (t #'(lambda (x) (eql element x))))
71     sequence :start start :end end :key key :from-end from-end :count count))     sequence :start start :end end :key key :from-end from-end :count count))
72        
# Line 85  Line 89 
89      (assert (integerp count))      (assert (integerp count))
90      (assert (or (symbolp predicate) (functionp predicate)))      (assert (or (symbolp predicate) (functionp predicate)))
91      (assert (or (symbolp key) (functionp key)))      (assert (or (symbolp key) (functionp key)))
92    
93        (setf predicate (coerce predicate 'function))
94        (setf key (coerce key 'function))
95            
96      ;; If FROM-END, reverse the sequence and flip      ;; If FROM-END, reverse the sequence and flip
97      ;; start, end      ;; start, end
# Line 101  Line 108 
108                 (if (and (> count 0)                 (if (and (> count 0)
109                          (>= pos start)                          (>= pos start)
110                          (< pos end)                          (< pos end)
111                          (funcall predicate (funcall key e)))                          (funcall (the function predicate)
112                                     (funcall (the function key) e)))
113                     (decf count)                     (decf count)
114                   (push e result))                   (push e result))
115                 (incf pos))                 (incf pos))
# Line 200  Line 208 
208  (defun random-test-remove (maxlen &key (tested-fn #'remove)  (defun random-test-remove (maxlen &key (tested-fn #'remove)
209                                    (check-fn #'my-remove)                                    (check-fn #'my-remove)
210                                    (pure t))                                    (pure t))
211      (setf tested-fn (coerce tested-fn 'function))
212      (setf check-fn (coerce check-fn 'function))
213    (multiple-value-bind (element seq arg-list)    (multiple-value-bind (element seq arg-list)
214        (random-test-remove-args maxlen)        (random-test-remove-args maxlen)
215      (let* ((seq1 (copy-seq seq))      (let* ((seq1 (copy-seq seq))
216             (seq2 (copy-seq seq))             (seq2 (copy-seq seq))
217             (seq1r (apply tested-fn element seq1 arg-list))             (seq1r (apply (the function tested-fn) element seq1 arg-list))
218             (seq2r (apply check-fn element seq2 arg-list)))             (seq2r (apply (the function check-fn) element seq2 arg-list)))
219        (setq *remove-fail-args* (list* element seq1 arg-list))        (setq *remove-fail-args* (list* element seq1 arg-list))
220        (cond        (cond
221         ((and pure (not (equalp seq seq1))) :fail1)         ((and pure (not (equalp seq seq1))) :fail1)
# Line 222  Line 232 
232        (remf arg-list :test)        (remf arg-list :test)
233        (remf arg-list :test-not)        (remf arg-list :test-not)
234        (unless test (setq test #'eql))        (unless test (setq test #'eql))
235          (setf test (coerce test 'function))
236        (if fn        (if fn
237            (case (random 3)            (case (random 3)
238              (0 (setf arg-list (list* :key 'identity arg-list)))              (0 (setf arg-list (list* :key 'identity arg-list)))
239              (1 (setf arg-list (list* :key #'identity arg-list)))              (1 (setf arg-list (list* :key #'identity arg-list)))
240              (t nil))              (t nil))
241          (setf fn (if (coin) 'identity          (setf fn (if (coin) 'identity
242                     #'(lambda (x) (funcall test element x)))))                     #'(lambda (x) (funcall (the function test)
243                                              element x)))))
244        (let* ((seq1 (copy-seq seq))        (let* ((seq1 (copy-seq seq))
245               (seq2 (copy-seq seq))               (seq2 (copy-seq seq))
246               (seq1r (apply (if negate #'remove-if-not #'remove-if)               (seq1r (apply (if negate #'remove-if-not #'remove-if)
# Line 254  Line 266 
266        (remf arg-list :test)        (remf arg-list :test)
267        (remf arg-list :test-not)        (remf arg-list :test-not)
268        (unless test (setq test #'eql))        (unless test (setq test #'eql))
269          (setf test (coerce test 'function))
270        (if fn        (if fn
271            (case (random 3)            (case (random 3)
272              (0 (setf arg-list (list* :key 'identity arg-list)))              (0 (setf arg-list (list* :key 'identity arg-list)))
273              (1 (setf arg-list (list* :key #'identity arg-list)))              (1 (setf arg-list (list* :key #'identity arg-list)))
274              (t nil))              (t nil))
275          (setf fn (if (coin) 'identity          (setf fn (if (coin) 'identity
276                     #'(lambda (x) (funcall test element x)))))                     #'(lambda (x) (funcall (the function test) element x)))))
277        (setq *remove-fail-args* (list* seq arg-list))        (setq *remove-fail-args* (list* seq arg-list))
278        (let* ((seq1 (copy-seq seq))        (let* ((seq1 (copy-seq seq))
279               (seq2 (copy-seq seq))               (seq2 (copy-seq seq))

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.9

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