0.8.1.14:

	Fix OPTIMIZATIONS #1b on x86, at Gilbert Baumann's request (on
	#lisp IRC 2003-07-01)
	... new VOPs for base-char comparisons with constant second
		argument;
	... new transforms for CHAR< and CHAR> to ensure that any constant
		argument is second;
	... don't fall into the trap of assuming that the world is ASCII;
		instead, define SB!XC:CODE-CHAR and SB!XC:CHAR-CODE that
		deal with converting STANDARD-CHARs to and from ASCII codes;
	... in the interest of the sanity of those with slow machines, refactor
		tests/seq.impure.lisp slightly so that it takes somewhat less
		time than the cosmological epoch to run

diff --git a/NEWS b/NEWS
index db3425d..501d33d 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1903,6 +1903,8 @@ changes in sbcl-0.8.2 relative to sbcl-0.8.1:
   * bug fix: CERROR accepts a function as its first argument.
   * bug fix: NTH an NTHCDR accept a bignum as index
     arguments. (reported by Adam Warner)
+  * optimization: character compare routines now optimize comparing
+    against a constant character. (reported by Gilbert Baumann)
   * fixed some bugs revealed by Paul Dietz' test suite:
     ** LAST and [N]BUTLAST should accept a bignum.
 

diff --git a/OPTIMIZATIONS b/OPTIMIZATIONS
index a53233a..fd575d6 100644 (file)
--- a/OPTIMIZATIONS
+++ b/OPTIMIZATIONS
@@ -11,9 +11,6 @@
 
 * On X86 I is represented as a tagged integer.
 
-* EQL uses "CMP reg,reg" instead of "CMP reg,im". This causes
-  allocation of an extra register and an extra move.
-
 * Unnecessary move:
   3: SLOT S!11[EDX] {SB-C::VECTOR-LENGTH 1 7} => t23[EAX]
   4: MOVE t23[EAX] => t24[EBX]

diff --git a/build-order.lisp-expr b/build-order.lisp-expr
index 4b8fbb7..043e449 100644 (file)
--- a/build-order.lisp-expr
+++ b/build-order.lisp-expr
@@ -73,6 +73,7 @@
  ;;; supplied by basic machinery
 
  ("src/code/cross-misc"  :not-target)
+ ("src/code/cross-char"  :not-target)
  ("src/code/cross-byte"  :not-target)
  ("src/code/cross-float" :not-target)
  ("src/code/cross-io"    :not-target)

diff --git a/src/code/cross-char.lisp b/src/code/cross-char.lisp
new file mode 100644 (file)
index 0000000..5f11943
--- /dev/null
+++ b/src/code/cross-char.lisp
@@ -0,0 +1,26 @@
+;;;; cross-compile-time-only replacements for unportable character
+;;;; stuff
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(let ((ascii-standard-chars " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~"))
+  (defun sb!xc:code-char (x)
+    (declare (type (or (integer 10 10) (integer 32 126)) x))
+    (if (= x 10)
+       #\Newline
+       (char ascii-standard-chars (- x 32))))
+  (defun sb!xc:char-code (character)
+    (declare (type standard-char character))
+    ;; FIXME: MacOS X?
+    (if (char= character #\Newline)
+       10
+       (+ (position character ascii-standard-chars) 32))))

diff --git a/src/cold/defun-load-or-cload-xcompiler.lisp b/src/cold/defun-load-or-cload-xcompiler.lisp
index 916b026..67c9707 100644 (file)
--- a/src/cold/defun-load-or-cload-xcompiler.lisp
+++ b/src/cold/defun-load-or-cload-xcompiler.lisp
@@ -92,7 +92,9 @@
                     ;; existence in xc and target
                    "BUILT-IN-CLASS"
                    "BYTE" "BYTE-POSITION" "BYTE-SIZE"
+                   "CHAR-CODE"
                    "CLASS" "CLASS-NAME" "CLASS-OF"
+                   "CODE-CHAR"
                    "COMPILE-FILE"
                    "COMPILE-FILE-PATHNAME"
                    "*COMPILE-FILE-PATHNAME*"

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 4b70251..f0df2a0 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -2956,6 +2956,24 @@
 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (deftransform > ((x y) (float float) *)
   (ir1-transform-< y x x y '<))
+
+(defun ir1-transform-char< (x y first second inverse)
+  (cond
+    ((same-leaf-ref-p x y) nil)
+    ;; If we had interval representation of character types, as we
+    ;; might eventually have to to support 2^21 characters, then here
+    ;; we could do some compile-time computation as in IR1-TRANSFORM-<
+    ;; above.  -- CSR, 2003-07-01
+    ((and (constant-continuation-p first)
+         (not (constant-continuation-p second)))
+     `(,inverse y x))
+    (t (give-up-ir1-transform))))
+
+(deftransform char< ((x y) (character character) *)
+  (ir1-transform-char< x y x y 'char>))
+
+(deftransform char> ((x y) (character character) *)
+  (ir1-transform-char< y x x y 'char<))
 \f
 ;;;; converting N-arg comparisons
 ;;;;

diff --git a/src/compiler/x86/char.lisp b/src/compiler/x86/char.lisp
index f5ca821..2def9d4 100644 (file)
--- a/src/compiler/x86/char.lisp
+++ b/src/compiler/x86/char.lisp
@@ -138,3 +138,27 @@
 (define-vop (fast-char>/base-char base-char-compare)
   (:translate char>)
   (:variant :a :na))
+
+(define-vop (base-char-compare/c)
+  (:args (x :scs (base-char-reg base-char-stack)))
+  (:arg-types base-char (:constant base-char))
+  (:conditional)
+  (:info target not-p y)
+  (:policy :fast-safe)
+  (:note "inline constant comparison")
+  (:variant-vars condition not-condition)
+  (:generator 2
+    (inst cmp x (sb!xc:char-code y))
+    (inst jmp (if not-p not-condition condition) target)))
+
+(define-vop (fast-char=/base-char/c base-char-compare/c)
+  (:translate char=)
+  (:variant :e :ne))
+
+(define-vop (fast-char</base-char/c base-char-compare/c)
+  (:translate char<)
+  (:variant :b :nb))
+
+(define-vop (fast-char>/base-char/c base-char-compare/c)
+  (:translate char>)
+  (:variant :a :na))

diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp
index 97b7cec..b298f78 100644 (file)
--- a/tests/seq.impure.lisp
+++ b/tests/seq.impure.lisp
@@ -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))
@@ -357,20 +357,21 @@
               (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"))))
 
@@ -380,7 +381,7 @@
  (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))
@@ -388,7 +389,7 @@
  (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?
@@ -398,7 +399,7 @@
  (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?
@@ -410,7 +411,7 @@
  (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))))
 
@@ -420,7 +421,7 @@
  (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))
@@ -428,7 +429,7 @@
  (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?
@@ -438,7 +439,7 @@
  (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?
@@ -450,7 +451,7 @@
  (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))))
 
@@ -463,7 +464,7 @@
  (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))))
 
@@ -482,7 +483,7 @@
                                          :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)))
@@ -496,7 +497,7 @@
  (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))
@@ -504,7 +505,7 @@
  (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?
@@ -514,7 +515,7 @@
  (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?
@@ -527,7 +528,7 @@
  (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))))
 
@@ -540,7 +541,7 @@
  (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))))
 
@@ -551,7 +552,7 @@
  (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) ""))
@@ -559,7 +560,7 @@
  (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?
@@ -571,11 +572,12 @@
  (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)
@@ -583,7 +585,7 @@
  (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)
@@ -597,7 +599,7 @@
          (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)))
@@ -615,7 +617,7 @@
          (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)))
@@ -629,7 +631,7 @@
  (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"))
@@ -638,7 +640,7 @@
  (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)
@@ -652,7 +654,7 @@
                           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))))
 
@@ -662,58 +664,61 @@
  (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
@@ -723,7 +728,7 @@
  (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
@@ -735,7 +740,7 @@
  (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
@@ -749,11 +754,12 @@
  (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)
@@ -762,7 +768,7 @@
  (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)
@@ -780,7 +786,7 @@
                                        :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)))
@@ -800,7 +806,7 @@
                                            :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)))
@@ -815,7 +821,7 @@
  (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*
@@ -825,7 +831,7 @@
  (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*
@@ -842,7 +848,7 @@
          (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)

diff --git a/version.lisp-expr b/version.lisp-expr
index 7fd05c3..1e781f4 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.1.13"
+"0.8.1.14"