From: Chris Hanson Date: Mon, 24 Feb 2003 20:48:38 +0000 (+0000) Subject: Export "guarantee" procedures for string indices. X-Git-Tag: 20090517-FFI~2023 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5d98dcc610a646d0c5d10896089c12124dfc5171;p=mit-scheme.git Export "guarantee" procedures for string indices. --- diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 6bf11dd78..1a1ce374d 100644 --- 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 a3160a95c..da8856005 100644 --- 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