Make ISO-8859-1 changes to string code, which involved rewriting all

of the case-aware procedures.  Many of these were inherited from
primitives, so it was necessary to write Scheme versions of the
primitives.

diff --git a/v7/src/runtime/char.scm b/v7/src/runtime/char.scm
index 8174acf969980e22116b86c5f60285b3c5d31dc6..0ee70d8a613c5091d8a04cd5960e2e9b6e5b5815 100644 (file)
--- a/v7/src/runtime/char.scm
+++ b/v7/src/runtime/char.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: char.scm,v 14.11 2001/09/24 03:44:56 cph Exp $
+$Id: char.scm,v 14.12 2001/09/24 05:24:55 cph Exp $
 
 Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
 
@@ -134,20 +134,32 @@ USA.
 
 (define (char-ci>=? x y)
   (fix:>= (char-ci->integer x) (char-ci->integer y)))
-
+\f
 (define (char-downcase char)
   (guarantee-char char 'CHAR-DOWNCASE)
-  (let ((n (%char-code char)))
-    (if (fix:< n 256)
-       (%make-char (vector-8b-ref downcase-table n) (%char-bits char))
-       char)))
+  (%char-downcase char))
+
+(define (%char-downcase char)
+  (if (fix:< (%char-code char) 256)
+      (%%char-downcase char)
+      char))
+
+(define-integrable (%%char-downcase char)
+  (%make-char (vector-8b-ref downcase-table (%char-code char))
+             (%char-bits char)))
 
 (define (char-upcase char)
   (guarantee-char char 'CHAR-UPCASE)
-  (let ((n (%char-code char)))
-    (if (fix:< n 256)
-       (%make-char (vector-8b-ref upcase-table n) (%char-bits char))
-       char)))
+  (%char-upcase char))
+
+(define (%char-upcase char)
+  (if (fix:< (%char-code char) 256)
+      (%%char-upcase char)
+      char))
+
+(define-integrable (%%char-upcase char)
+  (%make-char (vector-8b-ref upcase-table (%char-code char))
+             (%char-bits char)))
 
 (define downcase-table)
 (define upcase-table)

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 88bc3bb84fb4790d4b2fa3b36ec83c970b9c011e..3943cf7d771026df2b9aa4dc603efb474f921d6c 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.374 2001/08/17 12:50:52 cph Exp $
+$Id: runtime.pkg,v 14.375 2001/09/24 05:24:45 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -305,6 +305,9 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
          integer->char
          make-char
          name->char)
+  (export (runtime string)
+         %%char-downcase
+         %%char-upcase)
   (initialization (initialize-package!)))
 
 (define-package (runtime character-set)

diff --git a/v7/src/runtime/string.scm b/v7/src/runtime/string.scm
index f9f32d9c50160d7e0a2e6ee68cd87c4c3d5c2674..6cb367ea403e5be149ea72a50aff2a96ec43c0d0 100644 (file)
--- a/v7/src/runtime/string.scm
+++ b/v7/src/runtime/string.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: string.scm,v 14.43 2001/06/15 20:38:46 cph Exp $
+$Id: string.scm,v 14.44 2001/09/24 05:24:31 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -43,44 +43,28 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
   string-allocate string? string-ref string-set!
   string-length set-string-length!
   string-maximum-length set-string-maximum-length!
-  substring=? substring-ci=? substring<?
+  substring=? substring<?
   substring-move-right! substring-move-left!
   substring-match-forward substring-match-backward
-  substring-match-forward-ci substring-match-backward-ci
-  substring-upcase! substring-downcase! string-hash string-hash-mod
-
-  vector-8b-ref vector-8b-set! vector-8b-fill!
-  vector-8b-find-next-char vector-8b-find-previous-char
-  vector-8b-find-next-char-ci vector-8b-find-previous-char-ci)
+  string-hash string-hash-mod
+  vector-8b-ref vector-8b-set! vector-8b-fill!)
 
 ;;; Character Covers
 
 (define-integrable (substring-fill! string start end char)
   (vector-8b-fill! string start end (char->ascii char)))
 
-(define-integrable (substring-find-next-char string start end char)
-  (vector-8b-find-next-char string start end (char->ascii char)))
-
-(define-integrable (substring-find-previous-char string start end char)
-  (vector-8b-find-previous-char string start end (char->ascii char)))
-
-(define-integrable (substring-find-next-char-ci string start end char)
-  (vector-8b-find-next-char-ci string start end (char->ascii char)))
+(define-integrable (vector-8b-find-next-char string start end ascii)
+  (substring-find-next-char string start end (ascii->char ascii)))
 
-(define-integrable (substring-find-previous-char-ci string start end char)
-  (vector-8b-find-previous-char-ci string start end (char->ascii char)))
+(define-integrable (vector-8b-find-previous-char string start end ascii)
+  (substring-find-previous-char string start end (ascii->char ascii)))
 
-;;; Special, not implemented in microcode.
+(define-integrable (vector-8b-find-next-char-ci string start end ascii)
+  (substring-find-next-char-ci string start end (ascii->char ascii)))
 
-(define (substring-ci<? string1 start1 end1 string2 start2 end2)
-  (let ((match (substring-match-forward-ci string1 start1 end1
-                                          string2 start2 end2))
-       (len1 (fix:- end1 start1))
-       (len2 (fix:- end2 start2)))
-    (and (not (fix:= match len2))
-        (or (fix:= match len1)
-            (char-ci<? (string-ref string1 (fix:+ match start1))
-                       (string-ref string2 (fix:+ match start2)))))))
+(define-integrable (vector-8b-find-previous-char-ci string start end ascii)
+  (substring-find-previous-char-ci string start end (ascii->char ascii)))
 \f
 ;;; Substring Covers
 
@@ -100,7 +84,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
               string2 0 (string-length string2)))
 
 (define (string-ci<? string1 string2)
-  (guarantee-2-strings string1 string2 'STRING-ci<?)
+  (guarantee-2-strings string1 string2 'STRING-CI<?)
   (substring-ci<? string1 0 (string-length string1)
                  string2 0 (string-length string2)))
 
@@ -508,12 +492,21 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (define (string-upcase string)
   (let ((string (string-copy string)))
-    (substring-upcase! string 0 (string-length string))
+    (%substring-upcase! string 0 (string-length string))
     string))
 
 (define (string-upcase! string)
   (guarantee-string string 'STRING-UPCASE!)
-  (substring-upcase! string 0 (string-length string)))
+  (%substring-upcase! string 0 (string-length string)))
+
+(define (substring-upcase! string start end)
+  (guarantee-substring string start end 'SUBSTRING-UPCASE!)
+  (%substring-upcase! string start end))
+
+(define (%substring-upcase! string start end)
+  (do ((i start (fix:+ i 1)))
+      ((fix:= i end))
+    (string-set! string i (%%char-upcase (string-ref string i)))))
 
 (define (string-lower-case? string)
   (guarantee-string string 'STRING-LOWER-CASE?)
@@ -543,6 +536,15 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 (define (string-downcase! string)
   (guarantee-string string 'STRING-DOWNCASE!)
   (substring-downcase! string 0 (string-length string)))
+
+(define (substring-downcase! string start end)
+  (guarantee-substring string start end 'SUBSTRING-DOWNCASE!)
+  (%substring-downcase! string start end))
+
+(define (%substring-downcase! string start end)
+  (do ((i start (fix:+ i 1)))
+      ((fix:= i end))
+    (string-set! string i (%%char-downcase (string-ref string i)))))
 \f
 (define (string-capitalized? string)
   (guarantee-string string 'STRING-CAPITALIZED?)
@@ -733,6 +735,52 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
                                             string2 start2 end2)
                length))))
 \f
+(define (substring-ci=? string1 start1 end1 string2 start2 end2)
+  (guarantee-2-substrings string1 start1 end1
+                         string2 start2 end2
+                         'SUBSTRING-CI=?)
+  (and (fix:= (fix:- end1 start1) (fix:- end2 start2))
+       (let loop ((i1 start1) (i2 start2))
+        (or (fix:= i1 end1)
+            (and (char-ci=? (string-ref string1 i1) (string-ref string2 i2))
+                 (loop (fix:+ i1 1) (fix:+ i2 1)))))))
+
+(define (substring-ci<? string1 start1 end1 string2 start2 end2)
+  (guarantee-2-substrings string1 start1 end1
+                         string2 start2 end2
+                         'SUBSTRING-CI<?)
+  (let loop ((i1 start1) (i2 start2))
+    (and (not (fix:= i2 end2))
+        (or (fix:= i1 end1)
+            (let ((c1 (string-ref string1 i1))
+                  (c2 (string-ref string2 i2)))
+              (or (char-ci<? c1 c2)
+                  (and (char-ci=? c1 c2)
+                       (loop (fix:+ i1 1) (fix:+ i2 1)))))))))
+
+(define (substring-match-forward-ci string1 start1 end1 string2 start2 end2)
+  (guarantee-2-substrings string1 start1 end1
+                         string2 start2 end2
+                         'SUBSTRING-MATCH-FORWARD-CI)
+  (let loop ((i1 start1) (i2 start2))
+    (if (or (fix:= i1 end1)
+           (fix:= i2 end2)
+           (not (char-ci=? (string-ref string1 i1) (string-ref string2 i2))))
+       (fix:- i1 start1)
+       (loop (fix:+ i1 1) (fix:+ i2 1)))))
+
+(define (substring-match-backward-ci string1 start1 end1 string2 start2 end2)
+  (guarantee-2-substrings string1 start1 end1
+                         string2 start2 end2
+                         'SUBSTRING-MATCH-BACKWARD-CI)
+  (let loop ((i1 end1) (i2 end2))
+    (if (or (fix:= i1 start1)
+           (fix:= i2 start2)
+           (not (char-ci=? (string-ref string1 (fix:- i1 1))
+                           (string-ref string2 (fix:- i2 1)))))
+       (fix:- end1 i1)
+       (loop (fix:- i1 1) (fix:- i2 1)))))
+\f
 ;;;; Trim/Pad
 
 (define (string-trim-left string #!optional char-set)
@@ -798,6 +846,52 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
                (%substring-move! string 0 length result i)))
          result))))
 \f
+;;;; Char Search
+
+(define (substring-find-next-char string start end char)
+  (guarantee-substring string start end 'SUBSTRING-FIND-NEXT-CHAR)
+  (%substring-find-next-char string start end char))
+
+(define (%substring-find-next-char string start end char)
+  (let loop ((i start))
+    (cond ((fix:= i end) #f)
+         ((char=? (string-ref string i) char) i)
+         (else (loop (fix:+ i 1))))))
+
+(define (substring-find-previous-char string start end char)
+  (guarantee-substring string start end 'SUBSTRING-FIND-PREVIOUS-CHAR)
+  (%substring-find-previous-char string start end char))
+
+(define (%substring-find-previous-char string start end char)
+  (if (fix:= start end)
+      #f
+      (let loop ((i (fix:- end 1)))
+       (cond ((char=? (string-ref string i) char) i)
+             ((fix:= start i) #f)
+             (else (loop (fix:- i 1)))))))
+
+(define (substring-find-next-char-ci string start end char)
+  (guarantee-substring string start end 'SUBSTRING-FIND-NEXT-CHAR-CI)
+  (%substring-find-next-char-ci string start end char))
+
+(define (%substring-find-next-char-ci string start end char)
+  (let loop ((i start))
+    (cond ((fix:= i end) #f)
+         ((char-ci=? (string-ref string i) char) i)
+         (else (loop (fix:+ i 1))))))
+
+(define (substring-find-previous-char-ci string start end char)
+  (guarantee-substring string start end 'SUBSTRING-FIND-PREVIOUS-CHAR-CI)
+  (%substring-find-previous-char-ci string start end char))
+
+(define (%substring-find-previous-char-ci string start end char)
+  (if (fix:= start end)
+      #f
+      (let loop ((i (fix:- end 1)))
+       (cond ((char-ci=? (string-ref string i) char) i)
+             ((fix:= start i) #f)
+             (else (loop (fix:- i 1)))))))
+\f
 ;;;; String Search
 
 (define (substring? pattern text)