Export "guarantee" procedures for string indices.

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 6bf11dd781e23d9fcbd0ddfb4f6007863b0096af..1a1ce374dc9bf92a19d8b46ccbaa496cc1bb7667 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.427 2003/02/14 18:28:33 cph Exp $
+$Id: runtime.pkg,v 14.428 2003/02/24 20:48:38 cph Exp $
 
 Copyright (c) 1988,1989,1990,1991,1992 Massachusetts Institute of Technology
 Copyright (c) 1993,1994,1995,1996,1997 Massachusetts Institute of Technology
@@ -697,8 +697,12 @@ USA.
          decorated-string-append
          external-string-length
          external-string?
+         guarantee-char-set
          guarantee-string
+         guarantee-string-index
          guarantee-substring
+         guarantee-substring-end-index
+         guarantee-substring-start-index
          list->string
          make-string
          reverse-string

diff --git a/v7/src/runtime/string.scm b/v7/src/runtime/string.scm
index a3160a95cab2f849d3df651f499b8cc8e914aee9..da8856005f8604e3abcc33797f197571781ce24c 100644 (file)
--- a/v7/src/runtime/string.scm
+++ b/v7/src/runtime/string.scm
@@ -1,8 +1,10 @@
 #| -*-Scheme-*-
 
-$Id: string.scm,v 14.49 2003/02/14 18:28:34 cph Exp $
+$Id: string.scm,v 14.50 2003/02/24 20:47:14 cph Exp $
 
-Copyright (c) 1988-2002 Massachusetts Institute of Technology
+Copyright 1986,1987,1988,1992,1993,1994 Massachusetts Institute of Technology
+Copyright 1995,1997,1999,2000,2001,2002 Massachusetts Institute of Technology
+Copyright 2003 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -91,7 +93,7 @@ USA.
 ;;;; Basic Operations
 
 (define (make-string length #!optional char)
-  (guarantee-index/string length 'MAKE-STRING)
+  (guarantee-string-index length 'MAKE-STRING)
   (if (default-object? char)
       (string-allocate length)
       (begin
@@ -134,12 +136,12 @@ USA.
 
 (define (string-head string end)
   (guarantee-string string 'STRING-HEAD)
-  (guarantee-index/string end 'STRING-HEAD)
+  (guarantee-string-index end 'STRING-HEAD)
   (%substring string 0 end))
 
 (define (string-tail string start)
   (guarantee-string string 'STRING-TAIL)
-  (guarantee-index/string start 'STRING-TAIL)
+  (guarantee-string-index start 'STRING-TAIL)
   (%substring string start (string-length string)))
 
 (define (list->string chars)
@@ -188,7 +190,7 @@ USA.
 (define (string-move! string1 string2 start2)
   (guarantee-string string1 'STRING-MOVE!)
   (guarantee-string string2 'STRING-MOVE!)
-  (guarantee-index/string start2 'STRING-MOVE!)
+  (guarantee-string-index start2 'STRING-MOVE!)
   (let ((end1 (string-length string1)))
     (if (not (fix:<= (fix:+ start2 end1) (string-length string2)))
        (error:bad-range-argument start2 'STRING-MOVE!))
@@ -197,7 +199,7 @@ USA.
 (define (substring-move! string1 start1 end1 string2 start2)
   (guarantee-substring string1 start1 end1 'SUBSTRING-MOVE!)
   (guarantee-string string2 'SUBSTRING-MOVE!)
-  (guarantee-index/string start2 'SUBSTRING-MOVE!)
+  (guarantee-string-index start2 'SUBSTRING-MOVE!)
   (if (not (fix:<= (fix:+ start2 (fix:- end1 start1)) (string-length string2)))
       (error:bad-range-argument start2 'SUBSTRING-MOVE!))
   (%substring-move! string1 start1 end1 string2 start2))
@@ -977,7 +979,7 @@ USA.
 
 (define (string-pad-right string n #!optional char)
   (guarantee-string string 'STRING-PAD-RIGHT)
-  (guarantee-index/string n 'STRING-PAD-RIGHT)
+  (guarantee-string-index n 'STRING-PAD-RIGHT)
   (let ((length (string-length string)))
     (if (fix:= length n)
        string
@@ -996,7 +998,7 @@ USA.
 
 (define (string-pad-left string n #!optional char)
   (guarantee-string string 'STRING-PAD-LEFT)
-  (guarantee-index/string n 'STRING-PAD-LEFT)
+  (guarantee-string-index n 'STRING-PAD-LEFT)
   (let ((length (string-length string)))
     (if (fix:= length n)
        string
@@ -1400,21 +1402,34 @@ USA.
        ((not (string? object2))
         (error:wrong-type-argument object2 "string" procedure))))
 
-(define-integrable (guarantee-index/string object procedure)
+(define-integrable (guarantee-string-index object caller)
   (if (not (index-fixnum? object))
-      (guarantee-index/string/fail object procedure)))
+      (error:wrong-type-argument object "string index" caller)))
 
-(define (guarantee-index/string/fail object procedure)
-  (error:wrong-type-argument object "valid string index"
-                            procedure))
-
-(define-integrable (guarantee-substring string start end procedure)
+(define-integrable (guarantee-substring string start end caller)
   (if (not (and (string? string)
                (index-fixnum? start)
                (index-fixnum? end)
                (fix:<= start end)
                (fix:<= end (string-length string))))
-      (guarantee-substring/fail string start end procedure)))
+      (guarantee-substring/fail string start end caller)))
+
+(define (guarantee-substring/fail string start end caller)
+  (guarantee-string string caller)
+  (guarantee-substring-end-index string end caller)
+  (guarantee-substring-start-index string start end caller))
+
+(define-integrable (guarantee-substring-end-index string end caller)
+  (guarantee-string-index end caller)
+  (if (not (fix:<= end (string-length string)))
+      (error:bad-range-argument end caller))
+  start)
+
+(define-integrable (guarantee-substring-start-index string start end caller)
+  (guarantee-string-index start caller)
+  (if (not (fix:<= start end))
+      (error:bad-range-argument start caller))
+  end)
 
 (define-integrable (guarantee-2-substrings string1 start1 end1
                                           string2 start2 end2
@@ -1422,15 +1437,6 @@ USA.
   (guarantee-substring string1 start1 end1 procedure)
   (guarantee-substring string2 start2 end2 procedure))
 
-(define (guarantee-substring/fail string start end procedure)
-  (guarantee-string string procedure)
-  (guarantee-index/string start procedure)
-  (guarantee-index/string end procedure)
-  (if (not (fix:<= end (string-length string)))
-      (error:bad-range-argument end procedure))
-  (if (not (fix:<= start end))
-      (error:bad-range-argument start procedure)))
-
 (define-integrable (guarantee-char-set object procedure)
   (if (not (char-set? object))
       (error:wrong-type-argument object "character set" procedure)))
\ No newline at end of file