From 17a894be8995a7a09f4a31611a5fd415ed9bc4d2 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 23 Jul 2008 11:10:56 +0000 Subject: [PATCH] Broaden definitions of XSTRING?, XSTRING-LENGTH, XSTRING-REF, and XSTRING-SET! to also handle wide strings. Other xstring operations aren't updated by this change, but will be soon. --- v7/src/runtime/string.scm | 95 ++++++++++++++++++++------------------- 1 file changed, 48 insertions(+), 47 deletions(-) diff --git a/v7/src/runtime/string.scm b/v7/src/runtime/string.scm index 568333810..e8e866aab 100644 --- a/v7/src/runtime/string.scm +++ b/v7/src/runtime/string.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: string.scm,v 14.68 2008/02/10 06:14:16 cph Exp $ +$Id: string.scm,v 14.69 2008/07/23 11:10:56 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -1451,37 +1451,44 @@ USA. ((ucode-primitive allocate-external-string) n-bytes) n-bytes))))) +(define (external-string-ref string index) + (ascii->char + ((ucode-primitive read-byte-from-memory) + (+ (external-string-descriptor string) index)))) + +(define (external-string-set! string index char) + ((ucode-primitive write-byte-to-memory) + (char->ascii char) + (+ (external-string-descriptor string) index))) + +(define-integrable (external-substring-fill! string start end char) + ((ucode-primitive VECTOR-8B-FILL!) (external-string-descriptor string) + start + end + (char->ascii char))) + (define (xstring? object) (or (string? object) + (wide-string? object) (external-string? object))) -(define (xstring-length xstring) - (cond ((string? xstring) - (string-length xstring)) - ((external-string? xstring) - (external-string-length xstring)) - (else - (error:wrong-type-argument xstring "xstring" 'XSTRING-LENGTH)))) - -(define (xstring-ref xstring index) - (cond ((external-string? xstring) - (ascii->char - ((ucode-primitive read-byte-from-memory) - (+ (external-string-descriptor xstring) index)))) - ((string? xstring) - (string-ref xstring index)) - (else - (error:wrong-type-argument xstring "xstring" 'XSTRING-REF)))) - -(define (xstring-set! xstring index char) - (cond ((external-string? xstring) - ((ucode-primitive write-byte-to-memory) - (char->ascii char) - (+ (external-string-descriptor xstring) index))) - ((string? xstring) - (string-set! xstring index char)) - (else - (error:wrong-type-argument xstring "xstring" 'XSTRING-SET!)))) +(define (xstring-length string) + (cond ((string? string) (string-length string)) + ((wide-string? string) (wide-string-length string)) + ((external-string? string) (external-string-length string)) + (else (error:not-xstring string 'XSTRING-LENGTH)))) + +(define (xstring-ref string index) + (cond ((string? string) (string-ref string index)) + ((wide-string? string) (wide-string-ref string index)) + ((external-string? string) (external-string-ref string index)) + (else (error:not-xstring string 'XSTRING-REF)))) + +(define (xstring-set! string index char) + (cond ((string? string) (string-set! string index char)) + ((wide-string? string) (wide-string-set! string index char)) + ((external-string? string) (external-string-set! string index char)) + (else (error:not-xstring string 'XSTRING-SET!)))) (define (xstring-move! xstring1 xstring2 start2) (xsubstring-move! xstring1 0 (xstring-length xstring1) xstring2 start2)) @@ -1506,38 +1513,32 @@ USA. string)) (define (xstring-fill! xstring char) - (cond ((external-string? xstring) - (external-substring-fill! (external-string-descriptor xstring) + (cond ((string? xstring) + (string-fill! xstring char)) + ((external-string? xstring) + (external-substring-fill! xstring 0 (external-string-length xstring) char)) - ((string? xstring) - (string-fill! xstring char)) (else - (error:wrong-type-argument xstring "xstring" 'XSTRING-FILL!)))) + (error:not-xstring xstring 'XSTRING-FILL!)))) (define (xsubstring-fill! xstring start end char) - (cond ((external-string? xstring) - (external-substring-fill! (external-string-descriptor xstring) - start - end - char)) - ((string? xstring) + (cond ((string? xstring) (substring-fill! xstring start end char)) + ((external-string? xstring) + (external-substring-fill! xstring start end char)) (else - (error:wrong-type-argument xstring "xstring" 'XSTRING-FILL!)))) - -(define-integrable (external-substring-fill! descriptor start end char) - ((ucode-primitive VECTOR-8B-FILL!) descriptor start end (char->ascii char))) + (error:not-xstring xstring 'XSTRING-FILL!)))) (define-integrable (xsubstring-find-char xstring start end datum finder caller) (guarantee-xsubstring xstring start end caller) - (cond ((external-string? xstring) - (finder (external-string-descriptor xstring) start end datum)) - ((string? xstring) + (cond ((string? xstring) (finder xstring start end datum)) + ((external-string? xstring) + (finder (external-string-descriptor xstring) start end datum)) (else - (error:wrong-type-argument xstring "xstring" caller)))) + (error:not-xstring xstring caller)))) (define (xsubstring-find-next-char xstring start end char) (guarantee-char char 'XSUBSTRING-FIND-NEXT-CHAR) -- 2.25.1