source: trunk/source/tests/ansi-tests/remove-duplicates-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: 3.2 KB
RevLine 
[8991]1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Mon Sep 23 20:59:10 2002
4;;;; Contains: Aux. functions for testing REMOVE-DUPLICATES/DELETE-DUPLICATES
5
6(in-package :cl-test)
7
8(defun my-remove-duplicates (orig-sequence
9                             &key from-end test test-not (start 0) end key)
10  (assert (typep orig-sequence 'sequence))
11  (let* ((sequence orig-sequence)
12         (len (length sequence)))
13    (unless end (setq end len))
14    (unless key (setq key #'identity))
15    (setf key (coerce key 'function))
16    (cond
17      (test (setf test (coerce test 'function))
18            (assert (not test-not)))
19      (test-not (setf test-not (coerce test-not 'function))
20                (setq test #'(lambda (x y)
21                               (not (funcall (the function test) x y)))))
22      (t (setq test #'eql)))
23    (assert (integerp start))
24    (assert (integerp end))
25    (assert (<= 0 start end len))
26    ;; (format t "start = ~A, end = ~A, len = ~A~%" start end len)
27    (if from-end
28        (psetq start (- len end)
29               end (- len start)
30               sequence (reverse sequence))
31        (setq sequence (copy-seq sequence)))
32    ;; (format t "start = ~A, end = ~A, len = ~A~%" start end len)
33    (assert (<= 0 start end len) (start end len))
34    (let ((result nil))
35      (loop for i from 0 below start
36            do (push (elt sequence i) result))
37      (loop for i from start below end
38            for x = (elt sequence i)
39            for kx = (funcall (the function key) x)
40            unless (position kx
41                             sequence
42                             :start (1+ i)
43                             :end end
44                             :test (the function test)
45                             :key (the function key))
46            do (push x result))
47      (loop for i from end below len
48            do (push (elt sequence i) result))
49      (unless from-end (setq result (reverse result)))
50      (cond
51        ((listp orig-sequence) result)
52        ((arrayp orig-sequence)
53         (make-array (length result) :initial-contents result
54                     :element-type (array-element-type orig-sequence)))
55        (t (assert nil))))))
56
57(defun make-random-rdup-params (maxlen)
58  "Make random input parameters for REMOVE-DUPLICATES."
59  (multiple-value-bind (element-type type len start end from-end
60                                     count seq key test test-not)
61      (make-random-rd-params maxlen)
62    (declare (ignore count element-type len type))
63    (let ((arg-list
64           (reduce #'nconc
65                   (random-permute
66                    (list
67                     (when start (list :start start))
68                     (cond (end (list :end end))
69                           ((coin) (list :end nil)))
70                     (cond (from-end (list :from-end from-end))
71                           ((coin) (list :from-end nil)))
72                     (cond (key (list :key key))
73                           ;; ((coin) (list :key nil))
74                           )
75                     (when test (list :test test))
76                     (when test-not (list :test test-not)))))))
77      (values seq arg-list))))
78
79(defun random-test-remove-dups (maxlen &optional (pure t))
80  (multiple-value-bind (seq arg-list)
81      (make-random-rdup-params maxlen)
82    (let* ((seq1 (copy-seq seq))
83           (seq2 (copy-seq seq))
84           (seq1r (apply (if pure #'remove-duplicates
85                           #'delete-duplicates)
86                         seq1 arg-list))
87           (seq2r (apply #'my-remove-duplicates seq2 arg-list)))
88      (cond
89       ((and pure (not (equalp seq seq1))) (list :fail1 seq seq1r seq2r arg-list))
90       ((and pure (not (equalp seq seq2))) (list :fail2 seq seq1r seq2r arg-list))
91       ((not (equalp seq1r seq2r)) (list :fail3 seq seq1r seq2r arg-list))
92       (t t)))))
Note: See TracBrowser for help on using the repository browser.