source: trunk/source/tests/ansi-tests/string-aux.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 4.6 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Fri Oct  4 06:51:32 2002
4;;;; Contains: Auxiliary functions for string testing
5
6(in-package :cl-test)
7
8(eval-when (:compile-toplevel :load-toplevel :execute)
9  (compile-and-load "random-aux.lsp"))
10
11(defun my-string-compare (string1 string2 comparison
12                                  &key (start1 0) end1 (start2 0) end2 case
13                                  &aux
14                                  (len1 (progn (assert (stringp string1))
15                                               (length string1)))
16                                  (len2 (progn (assert (stringp string2))
17                                               (length string2)))
18                                  (compare-fn
19                                   (case comparison
20                                     (< (if case #'char-lessp #'char<))
21                                     (<= (if case #'char-not-greaterp
22                                           #'char<=))
23                                     (= (if case #'char-equal #'char=))
24                                     (/= (if case #'char-not-equal #'char/=))
25                                     (> (if case #'char-greaterp #'char>))
26                                     (>= (if case #'char-not-lessp #'char>=))
27                                     (t (error "Bad comparison arg: ~A~%"
28                                               comparison))))
29                                  (equal-fn (if case #'char-equal #'char=)))
30
31  (assert (integerp start1))
32  (assert (integerp start2))
33  (unless end1 (setq end1 len1))
34  (unless end2 (setq end2 len2))
35  (assert (<= 0 start1 end1))
36  (assert (<= 0 start2 end2))
37  (loop
38   for i1 from start1
39   for i2 from start2
40   do
41   (cond
42    ((= i1 end1)
43     (return
44      (cond
45       ((= i2 end2)
46        ;; Both ended -- equality case
47        (if (member comparison '(= <= >=))
48            end1
49          nil))
50       (t ;; string2 still extending
51        (if (member comparison '(/= < <=))
52            end1
53          nil)))))
54    ((= i2 end2)
55     ;; string1 still extending
56     (return
57      (if (member comparison '(/= > >=))
58          i1
59        nil)))
60    (t
61     (let ((c1 (my-aref string1 i1))
62           (c2 (my-aref string2 i2)))
63       (cond
64        ((funcall equal-fn c1 c2))
65        (t ;; mismatch found -- what kind?
66         (return
67          (if (funcall compare-fn c1 c2)
68              i1
69            nil)))))))))
70
71(defun make-random-string-compare-test (n)
72  (let* ((len (random n))
73         ;; Maximum lengths of the two strings
74         (len1 (if (or (coin) (= len 0)) len (+ len (random len))))
75         (len2 (if (or (coin) (= len 0)) len (+ len (random len))))
76         (s1 (make-random-string len1))
77         (s2 (make-random-string len2))
78         ;; Actual lengths of the strings
79         (len1 (length s1))
80         (len2 (length s2))
81         ;; Lengths of the parts of the strings to be matched
82         (sublen1 (if (or (coin) (= len1 0)) (min len1 len2) (random len1)))
83         (sublen2 (if (or (coin) (= len2 0)) (min len2 sublen1) (random len2)))
84         ;; Start and end of the substring of the first string
85         (start1 (if (coin 3) 0
86                   (max 0 (min (1- len1) (random (- len1 sublen1 -1))))))
87         (end1 (+ start1 sublen1))
88         ;; Start and end of the substring of the second string
89         (start2 (if (coin 3) 0
90                   (max 0 (min (1- len2) (random (- len2 sublen2 -1))))))
91         (end2 (+ start2 sublen2))
92         )
93    #|
94    (format t "len = ~A, len1 = ~A, len2 = ~A, sublen1 = ~A, sublen2 = ~A~%"
95            len len1 len2 sublen1 sublen2)
96    (format t "start1 = ~A, end1 = ~A, start2 = ~A, end2 = ~A~%"
97            start1 end1 start2 end2)
98    (format t "s1 = ~S, s2 = ~S~%" s1 s2)
99    |#
100    ;; Sometimes we want them to have a common prefix
101    (when (and (coin)
102               (equal (array-element-type s1)
103                      (array-element-type s2)))
104      (if (<= sublen1 sublen2)
105          (setf (subseq s2 start2 (+ start2 sublen1))
106                (subseq s1 start1 (+ start1 sublen1)))
107        (setf (subseq s1 start1 (+ start1 sublen2))
108              (subseq s2 start2 (+ start2 sublen2)))))
109    (values
110     s1
111     s2
112     (reduce #'nconc
113             (random-permute
114              (list
115               (if (and (= start1 0) (coin))
116                   nil
117                 (list :start1 start1))
118               (if (and (= end1 len1) (coin))
119                   nil
120                 (list :end1 end1))
121               (if (and (= start2 0) (coin))
122                   nil
123                 (list :start2 start2))
124               (if (and (= end2 len2) (coin))
125                   nil
126                 (list :end2 end2))))))))
127
128(defun random-string-compare-test (n comparison case &optional (iterations 1))
129  (loop for i from 1 to iterations
130        count
131        (multiple-value-bind (s1 s2 args)
132            (make-random-string-compare-test n)
133          ;; (format t "Strings: ~s ~s - Args = ~S~%" s1 s2 args)
134          (let ((x (apply (case comparison
135                            (< (if case #'string-lessp #'string<))
136                            (<= (if case #'string-not-greaterp
137                                  #'string<=))
138                            (= (if case #'string-equal #'string=))
139                            (/= (if case #'string-not-equal #'string/=))
140                            (> (if case #'string-greaterp #'string>))
141                            (>= (if case #'string-not-lessp #'string>=))
142                            (t (error "Bad comparison arg: ~A~%" comparison)))
143                          s1 s2 args))
144                (y (apply #'my-string-compare s1 s2 comparison :case case args)))
145            (not
146             (or (eql x y)
147                 (and x y (eqt comparison '=))))))))
148
149(defun string-all-the-same (s)
150  (let ((len (length s)))
151    (or (= len 0)
152        (let ((c (my-aref s 0)))
153          (loop for i below len
154                for d = (my-aref s i)
155                always (eql c d))))))
Note: See TracBrowser for help on using the repository browser.