From: Christophe Rhodes Date: Wed, 2 Jul 2003 08:36:56 +0000 (+0000) Subject: 0.8.1.14: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=58084279740fc96c6ffcd14e86dca73b71b7c288;p=sbcl.git 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 --- 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 --- 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 --- 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 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 --- 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 --- 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<)) ;;;; converting N-arg comparisons ;;;; diff --git a/src/compiler/x86/char.lisp b/src/compiler/x86/char.lisp index f5ca821..2def9d4 100644 --- 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 :a :na)) diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp index 97b7cec..b298f78 100644 --- a/tests/seq.impure.lisp +++ b/tests/seq.impure.lisp @@ -76,7 +76,7 @@ (when (or warnings-p failure-p) (error "~@" 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 --- 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"