0.8.1.14:
[sbcl.git] / tests / seq.impure.lisp
index 97b7cec..b298f78 100644 (file)
@@ -76,7 +76,7 @@
              (when (or warnings-p failure-p)
                (error "~@<failed compilation:~2I ~_LAMBDA-EXPR=~S ~_WARNINGS-P=~S ~_FAILURE-P=~S~:@>"
                       lambda-expr warnings-p failure-p))
-             (format t "~&~S ~S ~S ~S ~S~%"
+             (format t "~&~S ~S~%~S~%~S ~S~%"
                      base-seq snippet seq-type declaredness optimization)
              (format t "~&(TYPEP SEQ 'SIMPLE-ARRAY)=~S~%"
                      (typep seq 'simple-array))
               (setf (fill-pointer string) 5)))
        (declare (ignorable #'reset))
        ,@body))))
-
+(declaim (notinline opaque-identity))
+(defun opaque-identity (x) x)
 ;;; Accessor SUBSEQ
 (sequence-bounding-indices-test
  (format t "~&/Accessor SUBSEQ~%")
  (assert (string= (subseq string 0 5) "aaaaa"))
  (assert (raises-error? (subseq string 0 6)))
- (assert (raises-error? (subseq string -1 5)))
+ (assert (raises-error? (subseq string (opaque-identity -1) 5)))
  (assert (raises-error? (subseq string 4 2)))
  (assert (raises-error? (subseq string 6)))
  (assert (string= (setf (subseq string 0 5) "abcde") "abcde"))
  (assert (string= (subseq string 0 5) "abcde"))
  (reset)
  (assert (raises-error? (setf (subseq string 0 6) "abcdef")))
- (assert (raises-error? (setf (subseq string -1 5) "abcdef")))
+ (assert (raises-error? (setf (subseq string (opaque-identity -1) 5) "abcdef")))
  (assert (raises-error? (setf (subseq string 4 2) "")))
  (assert (raises-error? (setf (subseq string 6) "ghij"))))
 
  (assert (= (count #\a string :start 0 :end nil) 5))
  (assert (= (count #\a string :start 0 :end 5) 5))
  (assert (raises-error? (count #\a string :start 0 :end 6)))
- (assert (raises-error? (count #\a string :start -1 :end 5)))
+ (assert (raises-error? (count #\a string :start (opaque-identity -1) :end 5)))
  (assert (raises-error? (count #\a string :start 4 :end 2)))
  (assert (raises-error? (count #\a string :start 6 :end 9)))
  (assert (= (count-if #'alpha-char-p string :start 0 :end nil) 5))
  (assert (raises-error?
          (count-if #'alpha-char-p string :start 0 :end 6)))
  (assert (raises-error?
-         (count-if #'alpha-char-p string :start -1 :end 5)))
+         (count-if #'alpha-char-p string :start (opaque-identity -1) :end 5)))
  (assert (raises-error?
          (count-if #'alpha-char-p string :start 4 :end 2)))
  (assert (raises-error?
  (assert (raises-error?
          (count-if-not #'alpha-char-p string :start 0 :end 6)))
  (assert (raises-error?
-         (count-if-not #'alpha-char-p string :start -1 :end 5)))
+         (count-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)))
  (assert (raises-error?
          (count-if-not #'alpha-char-p string :start 4 :end 2)))
  (assert (raises-error?
  (assert (string= (fill string #\b :start 0 :end 5) "bbbbb"))
  (assert (string= (fill string #\c :start 0 :end nil) "ccccc"))
  (assert (raises-error? (fill string #\d :start 0 :end 6)))
- (assert (raises-error? (fill string #\d :start -1 :end 5)))
+ (assert (raises-error? (fill string #\d :start (opaque-identity -1) :end 5)))
  (assert (raises-error? (fill string #\d :start 4 :end 2)))
  (assert (raises-error? (fill string #\d :start 6 :end 9))))
 
  (assert (char= (find #\a string :start 0 :end nil) #\a))
  (assert (char= (find #\a string :start 0 :end 5) #\a))
  (assert (raises-error? (find #\a string :start 0 :end 6)))
- (assert (raises-error? (find #\a string :start -1 :end 5)))
+ (assert (raises-error? (find #\a string :start (opaque-identity -1) :end 5)))
  (assert (raises-error? (find #\a string :start 4 :end 2)))
  (assert (raises-error? (find #\a string :start 6 :end 9)))
  (assert (char= (find-if #'alpha-char-p string :start 0 :end nil) #\a))
  (assert (raises-error?
          (find-if #'alpha-char-p string :start 0 :end 6)))
  (assert (raises-error?
-         (find-if #'alpha-char-p string :start -1 :end 5)))
+         (find-if #'alpha-char-p string :start (opaque-identity -1) :end 5)))
  (assert (raises-error?
          (find-if #'alpha-char-p string :start 4 :end 2)))
  (assert (raises-error?
  (assert (raises-error?
          (find-if-not #'alpha-char-p string :start 0 :end 6)))
  (assert (raises-error?
-         (find-if-not #'alpha-char-p string :start -1 :end 5)))
+         (find-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)))
  (assert (raises-error?
          (find-if-not #'alpha-char-p string :start 4 :end 2)))
  (assert (raises-error?
  (assert (null (mismatch string "aaaaa" :start1 0 :end1 nil)))
  (assert (= (mismatch "aaab" string :start2 0 :end2 4) 3))
  (assert (raises-error? (mismatch "aaaaaa" string :start2 0 :end2 6)))
- (assert (raises-error? (mismatch string "aaaaaa" :start1 -1 :end1 5)))
+ (assert (raises-error? (mismatch string "aaaaaa" :start1 (opaque-identity -1) :end1 5)))
  (assert (raises-error? (mismatch string "" :start1 4 :end1 2)))
  (assert (raises-error? (mismatch "aaaa" string :start2 6 :end2 9))))
 
  (assert (= (parse-integer string :start 0 :end 5) 12345))
  (assert (= (parse-integer string :start 0 :end nil) 12345))
  (assert (raises-error? (parse-integer string :start 0 :end 6)))
- (assert (raises-error? (parse-integer string :start -1 :end 5)))
+ (assert (raises-error? (parse-integer string :start (opaque-identity -1) :end 5)))
  (assert (raises-error? (parse-integer string :start 4 :end 2)))
  (assert (raises-error? (parse-integer string :start 6 :end 9))))
 
                                          :start 0 :end 6)))
  (assert (raises-error? (parse-namestring string nil
                                          *default-pathname-defaults*
-                                         :start -1 :end 5)))
+                                         :start (opaque-identity -1) :end 5)))
  (assert (raises-error? (parse-namestring string nil
                                          *default-pathname-defaults*
                                          :start 4 :end 2)))
  (assert (= (position #\a string :start 0 :end nil) 0))
  (assert (= (position #\a string :start 0 :end 5) 0))
  (assert (raises-error? (position #\a string :start 0 :end 6)))
- (assert (raises-error? (position #\a string :start -1 :end 5)))
+ (assert (raises-error? (position #\a string :start (opaque-identity -1) :end 5)))
  (assert (raises-error? (position #\a string :start 4 :end 2)))
  (assert (raises-error? (position #\a string :start 6 :end 9)))
  (assert (= (position-if #'alpha-char-p string :start 0 :end nil) 0))
  (assert (raises-error?
          (position-if #'alpha-char-p string :start 0 :end 6)))
  (assert (raises-error?
-         (position-if #'alpha-char-p string :start -1 :end 5)))
+         (position-if #'alpha-char-p string :start (opaque-identity -1) :end 5)))
  (assert (raises-error?
          (position-if #'alpha-char-p string :start 4 :end 2)))
  (assert (raises-error?
  (assert (raises-error?
          (position-if-not #'alpha-char-p string :start 0 :end 6)))
  (assert (raises-error?
-         (position-if-not #'alpha-char-p string :start -1 :end 5)))
+         (position-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)))
  (assert (raises-error?
          (position-if-not #'alpha-char-p string :start 4 :end 2)))
  (assert (raises-error?
  (assert (equal (read-from-string string nil nil :start 0 :end 5) '(a b)))
  (assert (equal (read-from-string string nil nil :start 0 :end nil) '(a b)))
  (assert (raises-error? (read-from-string string nil nil :start 0 :end 6)))
- (assert (raises-error? (read-from-string string nil nil :start -1 :end 5)))
+ (assert (raises-error? (read-from-string string nil nil :start (opaque-identity -1) :end 5)))
  (assert (raises-error? (read-from-string string nil nil :start 4 :end 2)))
  (assert (raises-error? (read-from-string string nil nil :start 6 :end 9))))
 
  (assert (equal (reduce #'list* string :from-end t :start 0 :end 5)
                '(#\a #\b #\c #\d . #\e)))
  (assert (raises-error? (reduce #'list* string :start 0 :end 6)))
- (assert (raises-error? (reduce #'list* string :start -1 :end 5)))
+ (assert (raises-error? (reduce #'list* string :start (opaque-identity -1) :end 5)))
  (assert (raises-error? (reduce #'list* string :start 4 :end 2)))
  (assert (raises-error? (reduce #'list* string :start 6 :end 9))))
 
  (assert (equal (remove #\a string :start 0 :end nil) ""))
  (assert (equal (remove #\a string :start 0 :end 5) ""))
  (assert (raises-error? (remove #\a string :start 0 :end 6)))
- (assert (raises-error? (remove #\a string :start -1 :end 5)))
+ (assert (raises-error? (remove #\a string :start (opaque-identity -1) :end 5)))
  (assert (raises-error? (remove #\a string :start 4 :end 2)))
  (assert (raises-error? (remove #\a string :start 6 :end 9)))
  (assert (equal (remove-if #'alpha-char-p string :start 0 :end nil) ""))
  (assert (raises-error?
          (remove-if #'alpha-char-p string :start 0 :end 6)))
  (assert (raises-error?
-         (remove-if #'alpha-char-p string :start -1 :end 5)))
+         (remove-if #'alpha-char-p string :start (opaque-identity -1) :end 5)))
  (assert (raises-error?
          (remove-if #'alpha-char-p string :start 4 :end 2)))
  (assert (raises-error?
  (assert (raises-error?
          (remove-if-not #'alpha-char-p string :start 0 :end 6)))
  (assert (raises-error?
-         (remove-if-not #'alpha-char-p string :start -1 :end 5)))
+         (remove-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)))
  (assert (raises-error?
          (remove-if-not #'alpha-char-p string :start 4 :end 2)))
  (assert (raises-error?
-         (remove-if-not #'alpha-char-p string :start 6 :end 9)))
+         (remove-if-not #'alpha-char-p string :start 6 :end 9))))
+(sequence-bounding-indices-test
  (format t "~&/... DELETE, DELETE-IF, DELETE-IF-NOT")
  (assert (equal (delete #\a string :start 0 :end nil) ""))
  (reset)
  (reset)
  (assert (raises-error? (delete #\a string :start 0 :end 6)))
  (reset)
- (assert (raises-error? (delete #\a string :start -1 :end 5)))
+ (assert (raises-error? (delete #\a string :start (opaque-identity -1) :end 5)))
  (reset)
  (assert (raises-error? (delete #\a string :start 4 :end 2)))
  (reset)
          (delete-if #'alpha-char-p string :start 0 :end 6)))
  (reset)
  (assert (raises-error?
-         (delete-if #'alpha-char-p string :start -1 :end 5)))
+         (delete-if #'alpha-char-p string :start (opaque-identity -1) :end 5)))
  (reset)
  (assert (raises-error?
          (delete-if #'alpha-char-p string :start 4 :end 2)))
          (delete-if-not #'alpha-char-p string :start 0 :end 6)))
  (reset)
  (assert (raises-error?
-         (delete-if-not #'alpha-char-p string :start -1 :end 5)))
+         (delete-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)))
  (reset)
  (assert (raises-error?
          (delete-if-not #'alpha-char-p string :start 4 :end 2)))
  (assert (string= (remove-duplicates string :start 0 :end 5) "a"))
  (assert (string= (remove-duplicates string :start 0 :end nil) "a"))
  (assert (raises-error? (remove-duplicates string :start 0 :end 6)))
- (assert (raises-error? (remove-duplicates string :start -1 :end 5)))
+ (assert (raises-error? (remove-duplicates string :start (opaque-identity -1) :end 5)))
  (assert (raises-error? (remove-duplicates string :start 4 :end 2)))
  (assert (raises-error? (remove-duplicates string :start 6 :end 9)))
  (assert (string= (delete-duplicates string :start 0 :end 5) "a"))
  (reset)
  (assert (raises-error? (delete-duplicates string :start 0 :end 6)))
  (reset)
- (assert (raises-error? (delete-duplicates string :start -1 :end 5)))
+ (assert (raises-error? (delete-duplicates string :start (opaque-identity -1) :end 5)))
  (reset)
  (assert (raises-error? (delete-duplicates string :start 4 :end 2)))
  (reset)
                           string
                           :start2 0 :end2 nil) "bbbbb"))
  (assert (raises-error? (replace string "ccccc" :start1 0 :end1 6)))
- (assert (raises-error? (replace string "ccccc" :start2 -1 :end2 5)))
+ (assert (raises-error? (replace string "ccccc" :start2 (opaque-identity -1) :end2 5)))
  (assert (raises-error? (replace string "ccccc" :start1 4 :end1 2)))
  (assert (raises-error? (replace string "ccccc" :start1 6 :end1 9))))
 
  (assert (= (search "aa" string :start2 0 :end2 5) 0))
  (assert (null (search string "aa" :start1 0 :end2 nil)))
  (assert (raises-error? (search "aa" string :start2 0 :end2 6)))
- (assert (raises-error? (search "aa" string :start2 -1 :end2 5)))
+ (assert (raises-error? (search "aa" string :start2 (opaque-identity -1) :end2 5)))
  (assert (raises-error? (search "aa" string :start2 4 :end2 2)))
  (assert (raises-error? (search "aa" string :start2 6 :end2 9))))
 
 ;;; Function STRING-UPCASE, STRING-DOWNCASE, STRING-CAPITALIZE,
 ;;; NSTRING-UPCASE, NSTRING-DOWNCASE, NSTRING-CAPITALIZE
+(defmacro string-case-frob (fn)
+  `(progn
+    (assert (raises-error? (,fn string :start 0 :end 6)))
+    (assert (raises-error? (,fn string :start (opaque-identity -1) :end 5)))
+    (assert (raises-error? (,fn string :start 4 :end 2)))
+    (assert (raises-error? (,fn string :start 6 :end 9)))))
+  
 (sequence-bounding-indices-test
- (macrolet ((frob (fn)
-             `(progn
-               (assert (raises-error? (,fn string :start 0 :end 6)))
-               (assert (raises-error? (,fn string :start -1 :end 5)))
-               (assert (raises-error? (,fn string :start 4 :end 2)))
-               (assert (raises-error? (,fn string :start 6 :end 9))))))
-   (format t "~&/Function STRING-UPCASE, STRING-DOWNCASE, STRING-CAPITALIZE, ...~%")
-   (frob string-upcase)
-   (frob string-downcase)
-   (frob string-capitalize)
-   (format t "~&/... NSTRING-UPCASE, NSTRING-DOWNCASE, NSTRING-CAPITALIZE~%")
-   (frob nstring-upcase)
-   (frob nstring-downcase)
-   (frob nstring-capitalize)))
+ (format t "~&/Function STRING-UPCASE, STRING-DOWNCASE, STRING-CAPITALIZE, ...~%")
+ (string-case-frob string-upcase)
+ (string-case-frob string-downcase)
+ (string-case-frob string-capitalize)
+ (format t "~&/... NSTRING-UPCASE, NSTRING-DOWNCASE, NSTRING-CAPITALIZE~%")
+ (string-case-frob nstring-upcase)
+ (string-case-frob nstring-downcase)
+ (string-case-frob nstring-capitalize))
  
 ;;; Function STRING=, STRING/=, STRING<, STRING>, STRING<=, STRING>=,
 ;;; STRING-EQUAL, STRING-NOT-EQUAL, STRING-LESSP, STRING-GREATERP,
 ;;; STRING-NOT-GREATERP, STRING-NOT-LESSP
+(defmacro string-predicate-frob (fn)
+  `(progn
+    (,fn string "abcde" :start1 0 :end1 5)
+    (,fn "fghij" string :start2 0 :end2 nil)
+    (assert (raises-error? (,fn string "klmno"
+                               :start1 0 :end1 6)))
+    (assert (raises-error? (,fn "pqrst" string
+                               :start2 (opaque-identity -1) :end2 5)))
+    (assert (raises-error? (,fn "uvwxy" string
+                               :start1 4 :end1 2)))
+    (assert (raises-error? (,fn string "z" :start2 6 :end2 9)))))
 (sequence-bounding-indices-test
- (macrolet ((frob (fn)
-             `(progn
-               (,fn string "abcde" :start1 0 :end1 5)
-               (,fn "fghij" string :start2 0 :end2 nil)
-               (assert (raises-error? (,fn string "klmno"
-                                           :start1 0 :end1 6)))
-               (assert (raises-error? (,fn "pqrst" string
-                                           :start2 -1 :end2 5)))
-               (assert (raises-error? (,fn "uvwxy" string
-                                           :start1 4 :end1 2)))
-               (assert (raises-error? (,fn string "z" :start2 6 :end2 9))))))
-   (format t "~&/Function STRING=, STRING/=, STRING<, STRING>, STRING<=, STRING>=, ...")
-   (frob string=)
-   (frob string/=)
-   (frob string<)
-   (frob string>)
-   (frob string<=)
-   (frob string>=)
-   (format t "~&/... STRING-EQUAL, STRING-NOT-EQUAL, STRING-LESSP, ...~%")
-   (frob string-equal)
-   (frob string-not-equal)
-   (frob string-lessp)
-   (format t "~&/... STRING-GREATERP, STRING-NOT-GREATERP, STRING-NOT-LESSP~%")
-   (frob string-greaterp)
-   (frob string-not-greaterp)
-   (frob string-not-lessp)))
+ (format t "~&/Function STRING=, STRING/=, STRING<, STRING>, STRING<=, STRING>=, ...")
+ (string-predicate-frob string=)
+ (string-predicate-frob string/=)
+ (string-predicate-frob string<)
+ (string-predicate-frob string>)
+ (string-predicate-frob string<=)
+ (string-predicate-frob string>=))
+(sequence-bounding-indices-test
+ (format t "~&/... STRING-EQUAL, STRING-NOT-EQUAL, STRING-LESSP, ...~%")
+ (string-predicate-frob string-equal)
+ (string-predicate-frob string-not-equal)
+ (string-predicate-frob string-lessp))
+(sequence-bounding-indices-test
+ (format t "~&/... STRING-GREATERP, STRING-NOT-GREATERP, STRING-NOT-LESSP~%")
+ (string-predicate-frob string-greaterp)
+ (string-predicate-frob string-not-greaterp)
+ (string-predicate-frob string-not-lessp))
 
 ;;; Function SUBSTITUTE, SUBSTITUTE-IF, SUBSTITUTE-IF-NOT,
 ;;; NSUBSTITUTE, NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT
  (assert (string= (substitute #\c #\a string :start 0 :end nil)
                  "ccccc"))
  (assert (raises-error? (substitute #\b #\a string :start 0 :end 6)))
- (assert (raises-error? (substitute #\b #\a string :start -1 :end 5)))
+ (assert (raises-error? (substitute #\b #\a string :start (opaque-identity -1) :end 5)))
  (assert (raises-error? (substitute #\b #\a string :start 4 :end 2)))
  (assert (raises-error? (substitute #\b #\a string :start 6 :end 9)))
  (assert (string= (substitute-if #\b #'alpha-char-p string
  (assert (raises-error? (substitute-if #\b #'alpha-char-p string
                                       :start 0 :end 6)))
  (assert (raises-error? (substitute-if #\b #'alpha-char-p string
-                                      :start -1 :end 5)))
+                                      :start (opaque-identity -1) :end 5)))
  (assert (raises-error? (substitute-if #\b #'alpha-char-p string
                                       :start 4 :end 2)))
  (assert (raises-error? (substitute-if #\b #'alpha-char-p string
  (assert (raises-error? (substitute-if-not #\b #'alpha-char-p string
                                           :start 0 :end 6)))
  (assert (raises-error? (substitute-if-not #\b #'alpha-char-p string
-                                          :start -1 :end 5)))
+                                          :start (opaque-identity -1) :end 5)))
  (assert (raises-error? (substitute-if-not #\b #'alpha-char-p string
                                           :start 4 :end 2)))
  (assert (raises-error? (substitute-if-not #\b #'alpha-char-p string
-                                          :start 6 :end 9)))
+                                          :start 6 :end 9))))
+(sequence-bounding-indices-test
  (format t "~&/... NSUBSTITUTE, NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT~%")
  (assert (string= (nsubstitute #\b #\a string :start 0 :end 5) "bbbbb"))
  (reset)
  (reset)
  (assert (raises-error? (nsubstitute #\b #\a string :start 0 :end 6)))
  (reset)
- (assert (raises-error? (nsubstitute #\b #\a string :start -1 :end 5)))
+ (assert (raises-error? (nsubstitute #\b #\a string :start (opaque-identity -1) :end 5)))
  (reset)
  (assert (raises-error? (nsubstitute #\b #\a string :start 4 :end 2)))
  (reset)
                                        :start 0 :end 6)))
  (reset)
  (assert (raises-error? (nsubstitute-if #\b #'alpha-char-p string
-                                       :start -1 :end 5)))
+                                       :start (opaque-identity -1) :end 5)))
  (reset)
  (assert (raises-error? (nsubstitute-if #\b #'alpha-char-p string
                                        :start 4 :end 2)))
                                            :start 0 :end 6)))
  (reset)
  (assert (raises-error? (nsubstitute-if-not #\b #'alpha-char-p string
-                                           :start -1 :end 5)))
+                                           :start (opaque-identity -1) :end 5)))
  (reset)
  (assert (raises-error? (nsubstitute-if-not #\b #'alpha-char-p string
                                            :start 4 :end 2)))
  (assert (raises-error? (write-string string *standard-output*
                                      :start 0 :end 6)))
  (assert (raises-error? (write-string string *standard-output*
-                                     :start -1 :end 5)))
+                                     :start (opaque-identity -1) :end 5)))
  (assert (raises-error? (write-string string *standard-output*
                                      :start 4 :end 2)))
  (assert (raises-error? (write-string string *standard-output*
  (assert (raises-error? (write-line string *standard-output*
                                      :start 0 :end 6)))
  (assert (raises-error? (write-line string *standard-output*
-                                     :start -1 :end 5)))
+                                     :start (opaque-identity -1) :end 5)))
  (assert (raises-error? (write-line string *standard-output*
                                      :start 4 :end 2)))
  (assert (raises-error? (write-line string *standard-output*
          (with-input-from-string (s string :start 0 :end 6)
            (read-char s))))
  (assert (raises-error?
-         (with-input-from-string (s string :start -1 :end 5)
+         (with-input-from-string (s string :start (opaque-identity -1) :end 5)
            (read-char s))))
  (assert (raises-error?
          (with-input-from-string (s string :start 4 :end 2)