0.7.7.38:
[sbcl.git] / tests / seq.impure.lisp
1 ;;;; tests related to sequences
2
3 ;;;; This file is impure because we want to be able to use DEFUN.
4
5 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; more information.
7 ;;;;
8 ;;;; While most of SBCL is derived from the CMU CL system, the test
9 ;;;; files (like this one) were written from scratch after the fork
10 ;;;; from CMU CL.
11 ;;;; 
12 ;;;; This software is in the public domain and is provided with
13 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
14 ;;;; more information.
15
16 (in-package :cl-user)
17
18 ;;; helper functions for exercising SEQUENCE code on data of many
19 ;;; specialized types, and in many different optimization scenarios
20 (defun for-every-seq-1 (base-seq snippet)
21   (dolist (seq-type '(list
22                       (simple-array t 1)
23                       (vector t)
24                       (simple-array character 1)
25                       (vector character)
26                       (simple-array (signed-byte 4) 1)
27                       (vector (signed-byte 4))))
28     (flet ((entirely (eltype)
29              (every (lambda (el) (typep el eltype)) base-seq)))
30       (dolist (declaredness '(nil t))
31         (dolist (optimization '(((speed 3) (space 0))
32                                 ((speed 2) (space 2))
33                                 ((speed 1) (space 2))
34                                 ((speed 0) (space 1))))
35           (let* ((seq (if (eq seq-type 'list)
36                           (coerce base-seq 'list)
37                           (destructuring-bind (type-first &rest type-rest)
38                               seq-type
39                             (ecase type-first
40                               (simple-array
41                                (destructuring-bind (eltype one) type-rest
42                                  (assert (= one 1))
43                                  (if (entirely eltype)
44                                      (coerce base-seq seq-type)
45                                      (return))))
46                               (vector
47                                (destructuring-bind (eltype) type-rest
48                                  (if (entirely eltype)
49                                      (let ((initial-element
50                                             (cond ((subtypep eltype 'character)
51                                                    #\!)
52                                                   ((subtypep eltype 'number)
53                                                    0)
54                                                   (t #'error))))
55                                        (replace (make-array
56                                                  (+ (length base-seq)
57                                                     (random 3))
58                                                  :element-type eltype
59                                                  :fill-pointer
60                                                  (length base-seq)
61                                                  :initial-element
62                                                  initial-element)
63                                                 base-seq))
64                                      (return))))))))
65                  (lambda-expr `(lambda (seq)
66                                  ,@(when declaredness
67                                      `((declare (type ,seq-type seq))))
68                                  (declare (optimize ,@optimization))
69                                  ,snippet)))
70             (format t "~&~S~%" lambda-expr)
71             (multiple-value-bind (fun warnings-p failure-p)
72                 (compile nil lambda-expr)
73               (when (or warnings-p failure-p)
74                 (error "~@<failed compilation:~2I ~_LAMBDA-EXPR=~S ~_WARNINGS-P=~S ~_FAILURE-P=~S~:@>"
75                        lambda-expr warnings-p failure-p))
76               (format t "~&~S ~S ~S ~S ~S~%"
77                       base-seq snippet seq-type declaredness optimization)
78               (format t "~&(TYPEP SEQ 'SIMPLE-ARRAY)=~S~%"
79                       (typep seq 'simple-array))
80               (unless (funcall fun seq)
81                 (error "~@<failed test:~2I ~_BASE-SEQ=~S ~_SNIPPET=~S ~_SEQ-TYPE=~S ~_DECLAREDNESS=~S ~_OPTIMIZATION=~S~:@>"
82                        base-seq
83                        snippet
84                        seq-type
85                        declaredness
86                        optimization)))))))))
87 (defun for-every-seq (base-seq snippets)
88   (dolist (snippet snippets)
89     (for-every-seq-1 base-seq snippet)))
90
91 ;;; a wrapper to hide declared type information from the compiler, so
92 ;;; we don't get stopped by compiler warnings about e.g. compiling
93 ;;; (POSITION 1 #() :KEY #'ABS) when #() has been coerced to a string.
94 (defun indiscriminate (fun)
95   (lambda (&rest rest) (apply fun rest)))
96   
97 ;;; asymmetric test arg order example from ANSI FIND definition page
98 (assert (eql #\space ; original example, depends on ASCII character ordering
99              (find #\d "here are some letters that can be looked at"
100                    :test #'char>)))
101 (assert (eql #\e ; modified example, depends only on standard a-z ordering
102              (find #\f "herearesomeletters" :test #'char>)))
103 (assert (eql 4 ; modified more, avoids charset technicalities completely
104              (find 5 '(6 4) :test '>)))
105
106 ;;; tests of FIND, POSITION, FIND-IF, and POSITION-IF (and a few for
107 ;;; deprecated FIND-IF-NOT and POSITION-IF-NOT too)
108 (for-every-seq #()
109   '((null (find 1 seq))
110     (null (find 1 seq :from-end t))
111     (null (position 1 seq :key (indiscriminate #'abs)))
112     (null (position nil seq :test (constantly t)))
113     (null (position nil seq :test nil))
114     (null (position nil seq :test-not nil))
115     (null (find-if #'1+ seq :key (indiscriminate #'log)))
116     (null (position-if #'identity seq :from-end t))
117     (null (find-if-not #'packagep seq))
118     (null (position-if-not #'packagep seq :key nil))))
119 (for-every-seq #(1)
120   '((null (find 2 seq))
121     ;; Get the argument ordering for asymmetric tests like #'> right.
122     ;; (bug reported and fixed by Alexey Dejneka sbcl-devel 2001-10-17)
123     (eql 1 (find 2 seq :test #'>))
124     (find 2 seq :key #'1+)
125     (find 1 seq :from-end t)
126     (null (find 1 seq :from-end t :start 1))
127     (null (find 0 seq :from-end t))
128     (eql 0 (position 1 seq :key #'abs))
129     (null (position nil seq :test 'equal))
130     (eql 1 (find-if #'1- seq :key #'log))
131     (eql 0 (position-if #'identity seq :from-end t))
132     (null (find-if-not #'sin seq))
133     (eql 0 (position-if-not #'packagep seq :key 'identity))))
134 (for-every-seq #(1 2 3 2 1)
135   '((find 3 seq)
136     (find 3 seq :from-end 'yes)
137     (eql 1 (position 1.5 seq :test #'<))
138     (eql 0 (position 0 seq :key '1-))
139     (eql 4 (position 0 seq :key '1- :from-end t))
140     (eql 2 (position 4 seq :key '1+))
141     (eql 2 (position 4 seq :key '1+ :from-end t))
142     (eql 1 (position 2 seq))
143     (eql 1 (position 2 seq :start 1))
144     (null (find 2 seq :start 1 :end 1))
145     (eql 3 (position 2 seq :start 2))
146     (eql 3 (position 2 seq :key nil :from-end t))
147     (eql 2 (position 3 seq :test '=))
148     (eql 0 (position 3 seq :test-not 'equalp))
149     (eql 2 (position 3 seq :test 'equal :from-end t))
150     (null (position 4 seq :test #'eql))
151     (null (find-if #'packagep seq))
152     (eql 1 (find-if #'plusp seq))
153     (eql 3 (position-if #'plusp seq :key #'1- :from-end t))
154     (eql 1 (position-if #'evenp seq))
155     (eql 3 (position-if #'evenp seq :from-end t))
156     (eql 2 (position-if #'plusp seq :from-end nil :key '1- :start 2))
157     (eql 3 (position-if #'plusp seq :from-end t :key '1- :start 2))
158     (null (position-if #'plusp seq :from-end t :key '1- :start 2 :end 2))
159     (null (find-if-not #'plusp seq))
160     (eql 0 (position-if-not #'evenp seq))))
161 (for-every-seq "string test"
162   '((null (find 0 seq))
163     (null (find #\D seq :key #'char-upcase))
164     (find #\E seq :key #'char-upcase)
165     (null (find #\e seq :key #'char-upcase))
166     (eql 3 (position #\i seq))
167     (eql 0 (position #\s seq :key #'char-downcase))
168     (eql 1 (position #\s seq :key #'char-downcase :test #'char/=))
169     (eql 9 (position #\s seq :from-end t :test #'char=))
170     (eql 10 (position #\s seq :from-end t :test #'char/=))
171     (eql 4 (position #\N seq :from-end t :key 'char-upcase :test #'char-equal))
172     (eql 5 (position-if (lambda (c) (equal #\g c)) seq))
173     (eql 5 (position-if (lambda (c) (equal #\g c)) seq :from-end t))
174     (find-if #'characterp seq)
175     (find-if (lambda (c) (typep c 'base-char)) seq :from-end t)
176     (null (find-if 'upper-case-p seq))))
177          
178 ;;; SUBSEQ
179 (let ((avec (make-array 10
180                         :fill-pointer 4
181                         :initial-contents '(0 1 2 3 iv v vi vii iix ix))))
182   ;; These first five always worked AFAIK.
183   (assert (equalp (subseq avec 0 3) #(0 1 2)))
184   (assert (equalp (subseq avec 3 3) #()))
185   (assert (equalp (subseq avec 1 3) #(1 2)))
186   (assert (equalp (subseq avec 1) #(1 2 3)))
187   (assert (equalp (subseq avec 1 4) #(1 2 3)))
188   ;; SBCL bug found ca. 2002-05-01 by OpenMCL's correct handling of
189   ;; SUBSEQ, CSR's driving portable cross-compilation far enough to
190   ;; reach the SUBSEQ calls in assem.lisp, and WHN's sleazy
191   ;; translation of old CMU CL new-assem.lisp into sufficiently grotty
192   ;; portable Lisp that it passed suitable illegal values to SUBSEQ to
193   ;; exercise the bug:-|
194   ;;
195   ;; SUBSEQ should check its END value against logical LENGTH, not
196   ;; physical ARRAY-DIMENSION 0.
197   ;;
198   ;; fixed in sbcl-0.7.4.22 by WHN
199   (assert (null (ignore-errors (aref (subseq avec 1 5) 0)))))
200
201 ;;; FILL
202 (defun test-fill-typecheck (x)
203   (declare (optimize (safety 3) (space 2) (speed 1)))
204   (fill (make-string 10) x))
205
206 (assert (string= (test-fill-typecheck #\@) "@@@@@@@@@@"))
207 ;;; BUG 186, fixed in sbcl-0.7.5.5
208 (assert (null (ignore-errors (test-fill-typecheck 4097))))
209
210 ;;; MAKE-SEQUENCE, COERCE, CONCATENATE, MERGE, MAP and requested
211 ;;; result type (BUGs 46a, 46b, 66)
212 (macrolet ((assert-type-error (form)
213              `(assert (typep (nth-value 1 (ignore-errors ,form)) 
214                              'type-error))))
215   (dolist (type-stub '((simple-vector) 
216                        (vector *) 
217                        (vector (signed-byte 8))
218                        (vector (unsigned-byte 16))
219                        (vector (signed-byte 32))
220                        (simple-bit-vector)))
221     (declare (optimize safety))
222     (format t "~&~S~%" type-stub)
223     ;; MAKE-SEQUENCE
224     (assert (= (length (make-sequence `(,@type-stub) 10)) 10))
225     (assert (= (length (make-sequence `(,@type-stub 10) 10)) 10))
226     (assert-type-error (make-sequence `(,@type-stub 10) 11))
227     ;; COERCE
228     (assert (= (length (coerce '(0 0 0) `(,@type-stub))) 3))
229     (assert (= (length (coerce #(0 0 0) `(,@type-stub 3))) 3))
230     (assert-type-error (coerce #*111 `(,@type-stub 4)))
231     ;; CONCATENATE
232     (assert (= (length (concatenate `(,@type-stub) #(0 0 0) #*111)) 6))
233     (assert (equalp (concatenate `(,@type-stub) #(0 0 0) #*111)
234                    (coerce #(0 0 0 1 1 1) `(,@type-stub))))
235     (assert (= (length (concatenate `(,@type-stub 6) #(0 0 0) #*111)) 6))
236     (assert (equalp (concatenate `(,@type-stub 6) #(0 0 0) #*111)
237                    (coerce #(0 0 0 1 1 1) `(,@type-stub 6))))
238     (assert-type-error (concatenate `(,@type-stub 5) #(0 0 0) #*111))
239     ;; MERGE
240     (assert (= (length (merge `(,@type-stub) #(0 1 0) #*111 #'>)) 6))
241     (assert (equalp (merge `(,@type-stub) #(0 1 0) #*111 #'>)
242                    (coerce #(1 1 1 0 1 0) `(,@type-stub))))
243     (assert (= (length (merge `(,@type-stub 6) #(0 1 0) #*111 #'>)) 6))
244     (assert (equalp (merge `(,@type-stub 6) #(0 1 0) #*111 #'>)
245                    (coerce #(1 1 1 0 1 0) `(,@type-stub 6))))
246     (assert-type-error (merge `(,@type-stub 4) #(0 1 0) #*111 #'>))
247     ;; MAP
248     (assert (= (length (map `(,@type-stub) #'logxor #(0 0 1 1) '(0 1 0 1))) 4))
249     (assert (equalp (map `(,@type-stub) #'logxor #(0 0 1 1) '(0 1 0 1))
250                    (coerce #(0 1 1 0) `(,@type-stub))))
251     (assert (= (length (map `(,@type-stub 4) #'logxor #(0 0 1 1) '(0 1 0 1))) 
252                4))
253     (assert (equalp (map `(,@type-stub 4) #'logxor #(0 0 1 1) '(0 1 0 1))
254                    (coerce #(0 1 1 0) `(,@type-stub 4))))
255     (assert-type-error (map `(,@type-stub 5) #'logxor #(0 0 1 1) '(0 1 0 1))))
256   ;; some more CONCATENATE tests for strings
257   (locally 
258       (declare (optimize safety))
259     (assert (string= (concatenate 'string "foo" " " "bar") "foo bar"))
260     (assert (string= (concatenate '(string 7) "foo" " " "bar") "foo bar"))
261     (assert-type-error (concatenate '(string 6) "foo" " " "bar"))
262     (assert (string= (concatenate '(string 6) "foo" #(#\b #\a #\r)) "foobar"))
263     (assert-type-error (concatenate '(string 7) "foo" #(#\b #\a #\r)))))
264 \f
265 ;;; success
266 (quit :unix-status 104)