← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to ansi-tests/string-aux.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
ansi-tests/string-aux.lsp
 
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
(defun my-string-compare (string1 string2 comparison
 
9
                                  &key (start1 0) end1 (start2 0) end2 case
 
10
                                  &aux
 
11
                                  (len1 (progn (assert (stringp string1))
 
12
                                               (length string1)))
 
13
                                  (len2 (progn (assert (stringp string2))
 
14
                                               (length string2)))
 
15
                                  (compare-fn
 
16
                                   (case comparison
 
17
                                     (< (if case #'char-lessp #'char<))
 
18
                                     (<= (if case #'char-not-greaterp
 
19
                                           #'char<=))
 
20
                                     (= (if case #'char-equal #'char=))
 
21
                                     (/= (if case #'char-not-equal #'char/=))
 
22
                                     (> (if case #'char-greaterp #'char>))
 
23
                                     (>= (if case #'char-not-lessp #'char>=))
 
24
                                     (t (error "Bad comparison arg: ~A~%"
 
25
                                               comparison))))
 
26
                                  (equal-fn (if case #'char-equal #'char=)))
 
27
 
 
28
  (assert (integerp start1))
 
29
  (assert (integerp start2))
 
30
  (unless end1 (setq end1 len1))
 
31
  (unless end2 (setq end2 len2))
 
32
  (assert (<= 0 start1 end1))
 
33
  (assert (<= 0 start2 end2))
 
34
  (loop
 
35
   for i1 from start1
 
36
   for i2 from start2
 
37
   do
 
38
   (cond
 
39
    ((= i1 end1)
 
40
     (return
 
41
      (cond
 
42
       ((= i2 end2)
 
43
        ;; Both ended -- equality case
 
44
        (if (member comparison '(= <= >=))
 
45
            end1
 
46
          nil))
 
47
       (t ;; string2 still extending
 
48
        (if (member comparison '(/= < <=))
 
49
            end1
 
50
          nil)))))
 
51
    ((= i2 end2)
 
52
     ;; string1 still extending
 
53
     (return
 
54
      (if (member comparison '(/= > >=))
 
55
          i1
 
56
        nil)))
 
57
    (t
 
58
     (let ((c1 (my-aref string1 i1))
 
59
           (c2 (my-aref string2 i2)))
 
60
       (cond
 
61
        ((funcall equal-fn c1 c2))
 
62
        (t ;; mismatch found -- what kind?
 
63
         (return
 
64
          (if (funcall compare-fn c1 c2)
 
65
              i1
 
66
            nil)))))))))
 
67
 
 
68
(defun make-random-string-compare-test (n)
 
69
  (let* ((len (random n))
 
70
         ;; Lengths of the two strings
 
71
         (len1 (if (or (coin) (= len 0)) len (+ len (random len))))
 
72
         (len2 (if (or (coin) (= len 0)) len (+ len (random len))))
 
73
         ;; Lengths of the parts of the strings to be matched
 
74
         (sublen1 (if (or (coin) (= len1 0)) (min len1 len2) (random len1)))
 
75
         (sublen2 (if (or (coin) (= len2 0)) (min len2 sublen1) (random len2)))
 
76
         ;; Start and end of the substring of the first string
 
77
         (start1 (if (coin 3) 0
 
78
                   (max 0 (min (1- len1) (random (- len1 sublen1 -1))))))
 
79
         (end1 (+ start1 sublen1))
 
80
         ;; Start and end of the substring of the second string
 
81
         (start2 (if (coin 3) 0
 
82
                   (max 0 (min (1- len2) (random (- len2 sublen2 -1))))))
 
83
         (end2 (+ start2 sublen2))
 
84
         ;; generate the strings
 
85
         (s1 (make-random-string len1))
 
86
         (s2 (make-random-string len2)))
 
87
    #|
 
88
    (format t "len = ~A, len1 = ~A, len2 = ~A, sublen1 = ~A, sublen2 = ~A~%"
 
89
            len len1 len2 sublen1 sublen2)
 
90
    (format t "start1 = ~A, end1 = ~A, start2 = ~A, end2 = ~A~%"
 
91
            start1 end1 start2 end2)
 
92
    (format t "s1 = ~S, s2 = ~S~%" s1 s2)
 
93
    |#
 
94
    ;; Sometimes we want them to have a common prefix
 
95
    (when (coin)
 
96
      (if (<= sublen1 sublen2)
 
97
          (setf (subseq s2 start2 (+ start2 sublen1))
 
98
                (subseq s1 start1 (+ start1 sublen1)))
 
99
        (setf (subseq s1 start1 (+ start1 sublen2))
 
100
              (subseq s2 start2 (+ start2 sublen2)))))
 
101
    (values
 
102
     s1
 
103
     s2
 
104
     (reduce #'nconc
 
105
             (random-permute
 
106
              (list
 
107
               (if (and (= start1 0) (coin))
 
108
                   nil
 
109
                 (list :start1 start1))
 
110
               (if (and (= end1 len1) (coin))
 
111
                   nil
 
112
                 (list :end1 end1))
 
113
               (if (and (= start2 0) (coin))
 
114
                   nil
 
115
                 (list :start2 start2))
 
116
               (if (and (= end2 len2) (coin))
 
117
                   nil
 
118
                 (list :end2 end2))))))))
 
119
 
 
120
(defun random-string-compare-test (n comparison case &optional (iterations 1))
 
121
  (loop for i from 1 to iterations
 
122
        count
 
123
        (multiple-value-bind (s1 s2 args)
 
124
            (make-random-string-compare-test n)
 
125
          ;; (format t "Args = ~S~%" args)
 
126
          (let ((x (apply (case comparison
 
127
                            (< (if case #'string-lessp #'string<))
 
128
                            (<= (if case #'string-not-greaterp
 
129
                                  #'string<=))
 
130
                            (= (if case #'string-equal #'string=))
 
131
                            (/= (if case #'string-not-equal #'string/=))
 
132
                            (> (if case #'string-greaterp #'string>))
 
133
                            (>= (if case #'string-not-lessp #'string>=))
 
134
                            (t (error "Bad comparison arg: ~A~%" comparison)))
 
135
                          s1 s2 args))
 
136
                (y (apply #'my-string-compare s1 s2 comparison :case case args)))
 
137
            (not
 
138
             (or (eql x y)
 
139
                 (and x y (eqt comparison '=))))))))
 
140
 
 
141
(defparameter *use-random-byte* t)
 
142
 
 
143
(defun make-random-string (n)
 
144
  (let ((s (random-case
 
145
            (make-string n)
 
146
            (make-array n :element-type 'character
 
147
                        :initial-element #\a)
 
148
            (make-array n :element-type 'standard-char
 
149
                        :initial-element #\a)
 
150
            (make-array n :element-type 'base-char
 
151
                        :initial-element #\a))))
 
152
    (if (coin)
 
153
        (dotimes (i n)
 
154
          (setf (char s i) (elt #(#\a #\b #\A #\B) (random 4))))
 
155
      (dotimes (i n)
 
156
        (dotimes (i n)
 
157
          (setf (char s i)
 
158
                (or (and *use-random-byte* (code-char (random 256)))
 
159
                    (elt "abcdefghijklmnopqrstuvwyxzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
 
160
                         (random 62)))))))
 
161
    s))
 
162
 
 
163
(defun string-all-the-same (s)
 
164
  (let ((len (length s)))
 
165
    (or (= len 0)
 
166
        (let ((c (my-aref s 0)))
 
167
          (loop for i below len
 
168
                for d = (my-aref s i)
 
169
                always (eql c d))))))