From: Chris Hanson Date: Sun, 19 Feb 2017 08:49:55 +0000 (-0800) Subject: Huge wave of changes to rename remaining "ustring" to "string". X-Git-Tag: mit-scheme-pucked-9.2.12~220^2~68 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=46e66ca17f1c92a6f480366578e2ab68a610f2d5;p=mit-scheme.git Huge wave of changes to rename remaining "ustring" to "string". With single exception of make-ustring which needs some thought. --- diff --git a/src/etc/ucd-converter.scm b/src/etc/ucd-converter.scm index d12deca16..280495640 100644 --- a/src/etc/ucd-converter.scm +++ b/src/etc/ucd-converter.scm @@ -109,7 +109,7 @@ USA. (pathname-as-directory (merge-pathnames "ucd-raw-props" this-directory))) (define (raw-file-name name) - (merge-pathnames (ustring-append name ".scm") raw-directory)) + (merge-pathnames (string-append name ".scm") raw-directory)) (define (read-ucd-property-metadata) (let ((properties (read-file (raw-file-name "names")))) @@ -197,7 +197,7 @@ USA. (raw-file-name "version")) (define (prop-file-name prop-name) - (raw-file-name (ustring-append "prop-" prop-name))) + (raw-file-name (string-append "prop-" prop-name))) ;;;; UCD property extraction @@ -245,7 +245,7 @@ USA. (if (and (cprs-adjacent? (car p1) (car p2)) (if (cdr p1) (and (cdr p2) - (ustring=? (cdr p1) (cdr p2))) + (string=? (cdr p1) (cdr p2))) (not (cdr p2)))) (begin (set-car! alist @@ -281,7 +281,7 @@ USA. (xml-element-attributes elt)))) (and attr (let ((value (xml-attribute-value attr))) - (and (fix:> (ustring-length value) 0) + (and (fix:> (string-length value) 0) value))))) (define (cp-attribute elt) @@ -296,7 +296,7 @@ USA. (xml-element-content (xml-element-child 'description (xml-document-root document))))) (if (not (and (pair? content) - (ustring? (car content)) + (string? (car content)) (null? (cdr content)))) (error "Unexpected description content:" content)) (car content))) @@ -423,9 +423,9 @@ USA. (cdr exprs))))))) (define (prop-table-file-name prop-name) - (ustring-append (->namestring output-file-root) + (string-append (->namestring output-file-root) "-" - (ustring-downcase prop-name) + (string-downcase prop-name) ".scm")) (define (write-code-header port) @@ -555,7 +555,7 @@ USA. (value-manager "#" (let ((splitter (string-splitter #\space #f))) (lambda (value) - (if (ustring=? "" value) + (if (string=? "" value) '() (map string->cp (splitter value))))) (lambda (char-expr) `(list ,char-expr)) @@ -587,10 +587,10 @@ USA. (if value (let ((p (find (lambda (p) - (ustring=? value (car p))) + (string=? value (car p))) translations))) (if (not p) - (error (ustring-append "Illegal " name " value:") value)) + (error (string-append "Illegal " name " value:") value)) (cdr p)) (default-object))))) @@ -612,7 +612,7 @@ USA. (expand-cpr (car p)))) (remove (lambda (p) (and default-string - (ustring=? default-string (cdr p)))) + (string=? default-string (cdr p)))) prop-alist)))) (with-notification (lambda (port) @@ -710,7 +710,7 @@ USA. (let ((root-entry ((maker 'get-root-entry))) (table-entries ((maker 'get-table-entries)))) ((stats 'report) prop-name (length table-entries)) - (generate-top-level (ustring-downcase prop-name) + (generate-top-level (string-downcase prop-name) root-entry table-entries proc-name)))))) (define (generate-top-level prop-name root-entry table-entries proc-name) diff --git a/src/runtime/arith.scm b/src/runtime/arith.scm index 4f189cec5..5603e4933 100644 --- a/src/runtime/arith.scm +++ b/src/runtime/arith.scm @@ -468,9 +468,9 @@ USA. (cond ((not (int:integer? number)) (error:wrong-type-argument number #f 'NUMBER->STRING)) ((int:negative? number) - (list->ustring (cons #\- (n>0 (int:negate number))))) + (list->string (cons #\- (n>0 (int:negate number))))) (else - (list->ustring (n>0 number))))) + (list->string (n>0 number))))) (declare (integrate-operator rat:rational?)) (define (rat:rational? object) diff --git a/src/runtime/bytevector.scm b/src/runtime/bytevector.scm index f329d496c..5164ca1ec 100644 --- a/src/runtime/bytevector.scm +++ b/src/runtime/bytevector.scm @@ -257,7 +257,7 @@ USA. (define-integrable (string-encoder char-byte-length allocator encode-char! caller) (lambda (string #!optional start end) - (let* ((end (fix:end-index end (ustring-length string) caller)) + (let* ((end (fix:end-index end (string-length string) caller)) (start (fix:start-index start end caller))) (let ((bytes (allocator @@ -265,12 +265,12 @@ USA. (if (fix:< index end) (loop (fix:+ index 1) (fix:+ n-bytes - (char-byte-length (ustring-ref string index)))) + (char-byte-length (string-ref string index)))) n-bytes))))) (let loop ((from start) (to 0)) (if (fix:< from end) (loop (fix:+ from 1) - (encode-char! bytes to (ustring-ref string from))))) + (encode-char! bytes to (string-ref string from))))) bytes)))) ;; Make sure UTF-8 bytevectors have null termination. @@ -328,7 +328,7 @@ USA. (let loop ((from start) (to 0)) (if (fix:< from end) (let ((char (decode-char bytevector from))) - (ustring-set! string to char) + (string-set! string to char) (loop (fix:+ from (initial->length (getter bytevector from))) (fix:+ to 1))))) (or (ustring->legacy-string string) diff --git a/src/runtime/char.scm b/src/runtime/char.scm index b75fa47f4..14f72e133 100644 --- a/src/runtime/char.scm +++ b/src/runtime/char.scm @@ -228,20 +228,20 @@ USA. n)))) (lose (lambda () (error:bad-range-argument string 'NAME->CHAR)))) (receive (string bits) (match-bucky-bits-prefix string fold-case?) - (let ((end (ustring-length string))) + (let ((end (string-length string))) (if (fix:= 0 end) (lose)) (if (fix:= 1 end) - (let ((char (ustring-ref string 0))) + (let ((char (string-ref string 0))) (if (not (char-graphic? char)) (lose)) (make-char (char-code char) bits)) (make-char (or (match-named-code string fold-case?) ;; R7RS syntax (not sure if -ci is right) - (and (ustring-prefix-ci? "x" string) + (and (string-prefix-ci? "x" string) (parse-hex string 1)) ;; Non-standard syntax (Unicode style) - (and (ustring-prefix-ci? "u+" string) + (and (string-prefix-ci? "u+" string) (parse-hex string 2)) (lose)) bits)))))) @@ -259,7 +259,7 @@ USA. (string-append "x" (number->string code 16))))))) (define (match-bucky-bits-prefix string fold-case?) - (let ((match? (if fold-case? ustring-prefix-ci? ustring-prefix?))) + (let ((match? (if fold-case? string-prefix-ci? string-prefix?))) (let per-index ((index 0) (bits 0)) (let per-entry ((entries named-bits)) (if (pair? entries) @@ -269,11 +269,11 @@ USA. (match? prefix string index)) (cdr entry)))) (if prefix - (per-index (fix:+ index (ustring-length prefix)) + (per-index (fix:+ index (string-length prefix)) (fix:or bits (car entry))) (per-entry (cdr entries)))) (values (if (fix:> index 0) - (ustring-tail string index) + (string-tail string index) string) bits)))))) @@ -287,7 +287,7 @@ USA. (define-deferred bits-prefixes (list->vector (map (lambda (bits) - (apply ustring-append + (apply string-append (filter-map (lambda (entry) (if (fix:= 0 (fix:and (car entry) bits)) #f @@ -307,7 +307,7 @@ USA. (,char-bit:control "C-" "c-" "control-" "ctrl-"))) (define (match-named-code string fold-case?) - (let ((match? (if fold-case? ustring-ci=? ustring=?))) + (let ((match? (if fold-case? string-ci=? string=?))) (find-map (lambda (entry) (and (any (lambda (name) (match? name string)) diff --git a/src/runtime/chrset.scm b/src/runtime/chrset.scm index fc4293192..605172dc6 100644 --- a/src/runtime/chrset.scm +++ b/src/runtime/chrset.scm @@ -285,7 +285,7 @@ USA. (define (%cpl-element->ranges elt) (cond ((%range? elt) (list elt)) ((bitless-char? elt) (list (char->integer elt))) - ((ustring? elt) (map char->integer (ustring->list elt))) + ((string? elt) (map char->integer (string->list elt))) (else #f))) (define (%normalize-ranges ranges) @@ -337,7 +337,7 @@ USA. (define (cpl-element? object) (or (%range? object) (bitless-char? object) - (ustring? object) + (string? object) (char-set? object))) (define (%range? object) @@ -533,7 +533,7 @@ USA. ;; Returns ASCII string: (define (char-set->string char-set) - (list->ustring (char-set-members char-set))) + (list->string (char-set-members char-set))) ;; Returns only ASCII members: (define (char-set-members char-set) diff --git a/src/runtime/dosprm.scm b/src/runtime/dosprm.scm index 603467589..864271fd2 100644 --- a/src/runtime/dosprm.scm +++ b/src/runtime/dosprm.scm @@ -190,9 +190,9 @@ USA. (set! get-environment-variable (lambda (variable) - (if (not (ustring? variable)) + (if (not (string? variable)) (env-error 'GET-ENVIRONMENT-VARIABLE variable)) - (let ((variable (ustring-upcase variable))) + (let ((variable (string-upcase variable))) (cond ((assoc variable environment-variables) => cdr) (else @@ -201,9 +201,9 @@ USA. (set! set-environment-variable! (lambda (variable value) - (if (not (ustring? variable)) + (if (not (string? variable)) (env-error 'SET-ENVIRONMENT-VARIABLE! variable)) - (let ((variable (ustring-upcase variable))) + (let ((variable (string-upcase variable))) (cond ((assoc variable environment-variables) => (lambda (pair) (set-cdr! pair value))) (else @@ -213,7 +213,7 @@ USA. (set! delete-environment-variable! (lambda (variable) - (if (not (ustring? variable)) + (if (not (string? variable)) (env-error 'DELETE-ENVIRONMENT-VARIABLE! variable)) (set-environment-variable! variable *variable-deleted*))) @@ -225,9 +225,9 @@ USA. (set! set-environment-variable-default! (lambda (var val) - (if (not (ustring? var)) + (if (not (string? var)) (env-error 'SET-ENVIRONMENT-VARIABLE-DEFAULT! var)) - (let ((var (ustring-upcase var))) + (let ((var (string-upcase var))) (cond ((assoc var environment-defaults) => (lambda (pair) (set-cdr! pair val))) (else @@ -368,7 +368,7 @@ USA. (begin (if (not (and (pair? item) (init-file-specifier? (car item)) - (ustring? (cdr item)))) + (string? (cdr item)))) (error "Malformed init-file map item:" item)) (loop (cons item result))))))) diff --git a/src/runtime/dospth.scm b/src/runtime/dospth.scm index eb745dc6e..914e8f79a 100644 --- a/src/runtime/dospth.scm +++ b/src/runtime/dospth.scm @@ -67,7 +67,7 @@ USA. (call-with-values (lambda () (parse-device-and-path - (map ustring-downcase + (map string-downcase (expand-directory-prefixes (string-components string sub-directory-delimiters))))) (lambda (device components) @@ -79,11 +79,11 @@ USA. (let ((components (except-last-pair components))) (and (not (null? components)) (simplify-directory - (if (fix:= 0 (ustring-length (car components))) + (if (fix:= 0 (string-length (car components))) (cons 'ABSOLUTE (if (and (pair? (cdr components)) (fix:= 0 - (ustring-length + (string-length (cadr components)))) ;; Handle "\\foo\bar" notation here: ;; the "\\foo" isn't part of the @@ -108,20 +108,20 @@ USA. (let ((head (string-components string sub-directory-delimiters))) (append (if (and (pair? (cdr components)) (pair? (cdr head)) - (fix:= 0 (ustring-length (car (last-pair head))))) + (fix:= 0 (string-length (car (last-pair head))))) (except-last-pair head) head) (cdr components)))))) - (let ((end (ustring-length string))) + (let ((end (string-length string))) (if (or (fix:= 0 end) (not (*expand-directory-prefixes?*))) components - (case (ustring-ref string 0) + (case (string-ref string 0) ((#\$) (if (fix:= 1 end) components (let ((value - (get-environment-variable (usubstring string 1 end)))) + (get-environment-variable (substring string 1 end)))) (if (not value) components (replace-head value))))) @@ -131,7 +131,7 @@ USA. (lambda () (if (= 1 end) (current-home-directory) - (user-home-directory (usubstring string 1 end))))))) + (user-home-directory (substring string 1 end))))))) (if (condition? expansion) components (replace-head (->namestring expansion))))) @@ -139,10 +139,10 @@ USA. (define (parse-device-and-path components) (let ((string (car components))) - (if (and (fix:= 2 (ustring-length string)) - (char=? #\: (ustring-ref string 1)) - (char-alphabetic? (ustring-ref string 0))) - (values (ustring-head string 1) (cons "" (cdr components))) + (if (and (fix:= 2 (string-length string)) + (char=? #\: (string-ref string 1)) + (char-alphabetic? (string-ref string 0))) + (values (string-head string 1) (cons "" (cdr components))) (values #f components)))) (define (simplify-directory directory) @@ -152,35 +152,35 @@ USA. (define (parse-directory-components components) (if (any (lambda (component) - (fix:= 0 (ustring-length component))) + (fix:= 0 (string-length component))) components) (error "Directory contains null component:" components)) (map parse-directory-component components)) (define (parse-directory-component component) - (if (ustring=? ".." component) + (if (string=? ".." component) 'UP component)) (define (string-components string delimiters) - (substring-components string 0 (ustring-length string) delimiters)) + (substring-components string 0 (string-length string) delimiters)) (define (substring-components string start end delimiters) (let loop ((start start)) - (let ((index (ustring-find-first-char-in-set string delimiters start end))) + (let ((index (substring-find-next-char-in-set string start end delimiters))) (if index - (cons (usubstring string start index) (loop (fix:+ index 1))) - (list (usubstring string start end)))))) + (cons (substring string start index) (loop (fix:+ index 1))) + (list (substring string start end)))))) (define (parse-name string) - (let ((dot (ustring-find-last-char string #\.)) - (end (ustring-length string))) + (let ((dot (string-find-previous-char string #\.)) + (end (string-length string))) (if (or (not dot) (fix:= dot 0) (fix:= dot (fix:- end 1)) - (char=? #\. (ustring-ref string (fix:- dot 1)))) + (char=? #\. (string-ref string (fix:- dot 1)))) (values (cond ((fix:= end 0) #f) - ((ustring=? "*" string) 'WILD) + ((string=? "*" string) 'WILD) (else string)) #f) (values (extract string 0 dot) @@ -188,43 +188,43 @@ USA. (define (extract string start end) (if (and (fix:= 1 (fix:- end start)) - (char=? #\* (ustring-ref string start))) + (char=? #\* (string-ref string start))) 'WILD - (usubstring string start end))) + (substring string start end))) ;;;; Pathname Unparser (define (dos/pathname->namestring pathname) - (ustring-append (unparse-device (%pathname-device pathname)) - (unparse-directory (%pathname-directory pathname)) - (unparse-name (%pathname-name pathname) - (%pathname-type pathname)))) + (string-append (unparse-device (%pathname-device pathname)) + (unparse-directory (%pathname-directory pathname)) + (unparse-name (%pathname-name pathname) + (%pathname-type pathname)))) (define (unparse-device device) (if (or (not device) (eq? device 'UNSPECIFIC)) "" - (ustring-append device ":"))) + (string-append device ":"))) (define (unparse-directory directory) (cond ((or (not directory) (eq? directory 'UNSPECIFIC)) "") ((pair? directory) - (ustring-append + (string-append (if (eq? (car directory) 'ABSOLUTE) sub-directory-delimiter-string "") (let loop ((directory (cdr directory))) (if (null? directory) "" - (ustring-append (unparse-directory-component (car directory)) - sub-directory-delimiter-string - (loop (cdr directory))))))) + (string-append (unparse-directory-component (car directory)) + sub-directory-delimiter-string + (loop (cdr directory))))))) (else (error:illegal-pathname-component directory "directory")))) (define (unparse-directory-component component) (cond ((eq? component 'UP) "..") - ((ustring? component) component) + ((string? component) component) (else (error:illegal-pathname-component component "directory component")))) @@ -232,11 +232,11 @@ USA. (let ((name (or (unparse-component name) "")) (type (unparse-component type))) (if type - (ustring-append name "." type) + (string-append name "." type) name))) (define (unparse-component component) - (cond ((or (not component) (ustring? component)) component) + (cond ((or (not component) (string? component)) component) ((eq? component 'WILD) "*") (else (error:illegal-pathname-component component "component")))) @@ -245,7 +245,7 @@ USA. (define (dos/make-pathname host device directory name type version) (%%make-pathname host - (cond ((ustring? device) device) + (cond ((string? device) device) ((memq device '(#F UNSPECIFIC)) device) (else (error:illegal-pathname-component device "device"))) (cond ((or (not directory) (eq? directory 'UNSPECIFIC)) @@ -257,18 +257,18 @@ USA. (cddr directory) (cdr directory)) (lambda (element) - (if (ustring? element) - (not (fix:= 0 (ustring-length element))) + (if (string? element) + (not (fix:= 0 (string-length element))) (eq? element 'UP))))) (simplify-directory directory)) (else (error:illegal-pathname-component directory "directory"))) (if (or (memq name '(#F WILD)) - (and (ustring? name) (not (fix:= 0 (ustring-length name))))) + (and (string? name) (not (fix:= 0 (string-length name))))) name (error:illegal-pathname-component name "name")) (if (or (memq type '(#F WILD)) - (and (ustring? type) (not (fix:= 0 (ustring-length type))))) + (and (string? type) (not (fix:= 0 (string-length type))))) type (error:illegal-pathname-component type "type")) (if (memq version '(#F UNSPECIFIC WILD NEWEST)) @@ -292,8 +292,8 @@ USA. (and (pair? directory) (eq? (car directory) 'ABSOLUTE) (pair? (cdr directory)) - (ustring? (cadr directory)) - (fix:= 0 (ustring-length (cadr directory))))) + (string? (cadr directory)) + (fix:= 0 (string-length (cadr directory))))) (define (dos/directory-pathname? pathname) (and (not (%pathname-name pathname)) @@ -360,8 +360,8 @@ USA. (define (dos/pathname-wild? pathname) (let ((namestring (file-namestring pathname))) - (or (ustring-find-first-char namestring #\*) - (ustring-find-first-char namestring #\?)))) + (or (string-find-next-char namestring #\*) + (string-find-next-char namestring #\?)))) (define (dos/pathname->truename pathname) (if (file-exists-direct? pathname) diff --git a/src/runtime/dragon4.scm b/src/runtime/dragon4.scm index b033a894d..c09572add 100644 --- a/src/runtime/dragon4.scm +++ b/src/runtime/dragon4.scm @@ -80,7 +80,7 @@ not much different to numbers within a few orders of magnitude of 1. (dragon4 f e p radix cutoff-mode cutoff (lambda (u k generate) (let ((digits - (list->ustring + (list->string (let loop ((u u) (k k) (generate generate)) k ;ignore (if (negative? u) diff --git a/src/runtime/equals.scm b/src/runtime/equals.scm index e757e5d46..6a738d696 100644 --- a/src/runtime/equals.scm +++ b/src/runtime/equals.scm @@ -59,9 +59,9 @@ USA. ((bytevector? x) (and (bytevector? y) (bytevector=? x y))) - ((ustring? x) - (and (ustring? y) - (ustring=? x y))) + ((string? x) + (and (string? y) + (string=? x y))) ((cell? x) (and (cell? y) (equal? (cell-contents x) diff --git a/src/runtime/genio.scm b/src/runtime/genio.scm index 9cae75e49..c2074e1a8 100644 --- a/src/runtime/genio.scm +++ b/src/runtime/genio.scm @@ -244,7 +244,7 @@ USA. ((eof-object? char) (fix:- index start)) (else - (ustring-set! string index char) + (string-set! string index char) (loop (fix:+ index 1))))) (fix:- end start)))) @@ -277,7 +277,7 @@ USA. (let ((ob (port-output-buffer port))) (let loop ((index start)) (if (fix:< index end) - (let ((n (write-next-char ob (ustring-ref string index)))) + (let ((n (write-next-char ob (string-ref string index)))) (cond ((and n (fix:> n 0)) (loop (fix:+ index 1))) ((fix:< start index) (fix:- index start)) (else n))) diff --git a/src/runtime/hashtb.scm b/src/runtime/hashtb.scm index dd3b6642a..b25d63023 100644 --- a/src/runtime/hashtb.scm +++ b/src/runtime/hashtb.scm @@ -1032,9 +1032,9 @@ USA. ((%ratnum? key) (%ratnum->nonneg-int key)) ((flo:flonum? key) (%flonum->nonneg-int key)) ((%recnum? key) (%recnum->nonneg-int key)) - ((ustring? key) (ustring-hash key)) + ((string? key) (string-hash key)) ((bit-string? key) (bit-string->unsigned-integer key)) - ((pathname? key) (ustring-hash (->namestring key))) + ((pathname? key) (string-hash (->namestring key))) (else (eq-hash key)))) (define-integrable (%bignum? object) @@ -1234,7 +1234,7 @@ USA. (set! non-pointer-hash-table-type ;Open-coded (open-type! eq-hash-mod eq? #f hash-table-entry-type:strong)) (set! string-hash-table-type - (make ustring-hash ustring=? #t hash-table-entry-type:strong)) + (make string-hash string=? #t hash-table-entry-type:strong)) (set! strong-eq-hash-table-type ;Open-coded (open-type! eq-hash-mod eq? #t hash-table-entry-type:strong)) (set! strong-eqv-hash-table-type diff --git a/src/runtime/input.scm b/src/runtime/input.scm index 34f364f08..b78e538c2 100644 --- a/src/runtime/input.scm +++ b/src/runtime/input.scm @@ -45,7 +45,7 @@ USA. ((textual-port-operation/peek-char port) port)) (define (input-port/read-string! port string) - (input-port/read-substring! port string 0 (ustring-length string))) + (input-port/read-substring! port string 0 (string-length string))) (define (input-port/read-substring! port string start end) (if (< start end) @@ -188,7 +188,7 @@ USA. (let ((string (make-ustring k))) (let ((n (input-port/read-string! port string))) (cond ((not n) n) - ((fix:> n 0) (if (fix:< n k) (ustring-head string n) string)) + ((fix:> n 0) (if (fix:< n k) (string-head string n) string)) (else (eof-object))))) (make-ustring 0)))) @@ -215,10 +215,10 @@ USA. (let ((port (optional-input-port port 'read-string!)) (end (if (default-object? end) - (ustring-length string) + (string-length string) (begin (guarantee index-fixnum? end 'read-string!) - (if (not (fix:<= end (ustring-length string))) + (if (not (fix:<= end (string-length string))) (error:bad-range-argument end 'read-string!)) end)))) (let ((start diff --git a/src/runtime/io.scm b/src/runtime/io.scm index 243d27f0c..30520e9f4 100644 --- a/src/runtime/io.scm +++ b/src/runtime/io.scm @@ -729,7 +729,7 @@ USA. (define (dld-lookup-symbol handle name) (guarantee-dld-handle handle 'DLD-LOOKUP-SYMBOL) - (guarantee ustring? name 'DLD-LOOKUP-SYMBOL) + (guarantee string? name 'DLD-LOOKUP-SYMBOL) ((ucode-primitive dld-lookup-symbol 2) (dld-handle-address handle) (string-for-primitive name))) diff --git a/src/runtime/keyword.scm b/src/runtime/keyword.scm index 3307d6a70..185c3054e 100644 --- a/src/runtime/keyword.scm +++ b/src/runtime/keyword.scm @@ -38,15 +38,15 @@ USA. (define-integrable keyword-prefix "#[keyword]") (define (string->keyword string) - (guarantee ustring? string 'STRING->KEYWORD) - (string->symbol (ustring-append keyword-prefix string))) + (guarantee string? string 'STRING->KEYWORD) + (string->symbol (string-append keyword-prefix string))) (define (keyword? object) (and (interned-symbol? object) - (ustring-prefix? keyword-prefix (symbol->string object)))) + (string-prefix? keyword-prefix (symbol->string object)))) (define-guarantee keyword "keyword") (define (keyword->string keyword) (guarantee-keyword keyword 'KEYWORD->STRING) - (ustring-tail (symbol->string keyword) (ustring-length keyword-prefix))) \ No newline at end of file + (string-tail (symbol->string keyword) (string-length keyword-prefix))) \ No newline at end of file diff --git a/src/runtime/load.scm b/src/runtime/load.scm index 938e28cc5..8139679af 100644 --- a/src/runtime/load.scm +++ b/src/runtime/load.scm @@ -216,8 +216,8 @@ USA. (define (object-file? pathname) (and (let ((type (pathname-type pathname))) - (and (ustring? type) - (ustring=? type "so"))) + (and (string? type) + (string=? type "so"))) (file-regular? pathname))) (define (load/purification-root object) @@ -334,7 +334,7 @@ USA. (lambda () (let ((handle (dld-load-file (standard-uri->pathname uri)))) (let ((nonce* (liarc-object-file-nonce handle))) - (if (not (and nonce* (ustring=? nonce* nonce))) + (if (not (and nonce* (string=? nonce* nonce))) (begin (dld-unload-file handle) (error "Can't restore liarc object file:" uri)))) @@ -346,7 +346,7 @@ USA. (lambda () ((ucode-primitive address-to-string 1) (dld-lookup-symbol handle "dload_nonce")))))) - (and (ustring? nonce) + (and (string? nonce) nonce))) (define (initialize-object-file handle uri) @@ -375,8 +375,8 @@ USA. (if (and (equal? p '("" "software" "mit-scheme" "lib" "lib")) - (ustring-suffix? ".so" s)) - (list (ustring-head s (fix:- (ustring-length s) 3))) + (string-suffix? ".so" s)) + (list (string-head s (fix:- (string-length s) 3))) '()) (list "")))) #f @@ -414,7 +414,7 @@ USA. (reverse! (let ((rp (reverse (uri-path uri)))) (if (and (pair? rp) (fix:= 0 - (ustring-length (car rp)))) + (string-length (car rp)))) (cdr rp) rp)))))) (and (eq? (uri-scheme uri) (uri-scheme lib)) @@ -424,7 +424,7 @@ USA. (let loop ((pu (trim-path uri)) (pl (trim-path lib))) (if (pair? pl) (and (pair? pu) - (ustring=? (car pu) (car pl)) + (string=? (car pu) (car pl)) (loop (cdr pu) (cdr pl))) (make-pathname #f #f (cons 'RELATIVE pu) #f #f #f))))))) @@ -451,7 +451,7 @@ USA. (standard-library-directory-pathname)))) (define (system-uri #!optional rel-uri) - (if (ustring? system-base-uri) + (if (string? system-base-uri) (begin (set! system-base-uri (string->uri system-base-uri)) unspecific)) @@ -540,8 +540,8 @@ USA. (cddr entry)))) (define (option-keyword? argument) - (and (fix:> (ustring-length argument) 1) - (char=? #\- (ustring-ref argument 0)))) + (and (fix:> (string-length argument) 1) + (char=? #\- (string-ref argument 0)))) (define (load-init-file) (let ((pathname (init-file-pathname))) @@ -550,12 +550,12 @@ USA. unspecific) (define (set-command-line-parser! keyword proc #!optional description) - (guarantee ustring? keyword 'SET-COMMAND-LINE-PARSER!) + (guarantee string? keyword 'SET-COMMAND-LINE-PARSER!) (let ((keyword (strip-leading-hyphens keyword)) (desc (if (default-object? description) "" (begin - (guarantee ustring? description 'SET-COMMAND-LINE-PARSER!) + (guarantee string? description 'SET-COMMAND-LINE-PARSER!) description)))) (let ((place (assoc keyword *command-line-parsers*))) @@ -570,15 +570,15 @@ USA. unspecific))))) (define (strip-leading-hyphens keyword) - (let ((end (ustring-length keyword))) + (let ((end (string-length keyword))) (let loop ((start 0)) (cond ((and (fix:< start end) - (char=? #\- (ustring-ref keyword start))) + (char=? #\- (string-ref keyword start))) (loop (fix:+ start 1))) ((fix:= start 0) keyword) (else - (usubstring keyword start end)))))) + (substring keyword start end)))))) (define (command-line-option-description keyword-line description-lines caller) (if (pair? description-lines) @@ -587,19 +587,19 @@ USA. "" (begin (for-each (lambda (description-line) - (guarantee ustring? description-line caller)) + (guarantee string? description-line caller)) description-lines) (decorated-string-append "" "\n " "" (cons keyword-line description-lines)))) - (ustring-append keyword-line "\n (No description.)"))) + (string-append keyword-line "\n (No description.)"))) (define (simple-command-line-parser keyword thunk . description-lines) - (guarantee ustring? keyword 'SIMPLE-COMMAND-LINE-PARSER) + (guarantee string? keyword 'SIMPLE-COMMAND-LINE-PARSER) (set-command-line-parser! keyword (lambda (command-line) (values (cdr command-line) thunk)) (command-line-option-description - (ustring-append "--" keyword) + (string-append "--" keyword) description-lines 'SIMPLE-COMMAND-LINE-PARSER))) @@ -619,9 +619,9 @@ USA. (values '() (lambda () (warn "Missing argument to command-line option:" - (ustring-append "--" keyword))))))) + (string-append "--" keyword))))))) (command-line-option-description - (ustring-append "--" keyword " ARG" (if multiple? " ..." "")) + (string-append "--" keyword " ARG" (if multiple? " ..." "")) description-lines 'ARGUMENT-COMMAND-LINE-PARSER))) @@ -664,11 +664,11 @@ USA. ADDITIONAL OPTIONS supported by this band:\n") (do ((parsers (sort *command-line-parsers* - (lambda (a b) (ustringnumber string #!optional radix error? start end) (let* ((caller 'string->number) - (end (fix:end-index end (ustring-length string) caller)) + (end (fix:end-index end (string-length string) caller)) (start (fix:start-index start end caller)) (z (parse-number string start end @@ -51,10 +51,10 @@ USA. (error:bad-range-argument default-radix name)) (let loop ((start start) (exactness #f) (radix #f)) (and (fix:< start end) - (if (char=? #\# (ustring-ref string start)) + (if (char=? #\# (string-ref string start)) (let ((start (fix:+ start 1))) (and (fix:< start end) - (let ((char (ustring-ref string start)) + (let ((char (string-ref string start)) (start (fix:+ start 1))) (let ((do-radix (lambda (r) @@ -80,7 +80,7 @@ USA. (define (parse-top-level string start end exactness radix) (and (fix:< start end) - (let ((char (ustring-ref string start)) + (let ((char (string-ref string start)) (start (fix:+ start 1))) (cond ((sign? char) (find-leader string start end @@ -99,7 +99,7 @@ USA. (define (find-leader string start end exactness radix sign) ;; State: leading sign has been seen. (and (fix:< start end) - (let ((char (ustring-ref string start)) + (let ((char (string-ref string start)) (start (fix:+ start 1))) (cond ((char->digit char radix) => (lambda (digit) @@ -119,7 +119,7 @@ USA. (parse-digits string start end integer exactness radix (lambda (start integer exactness sharp?) (if (fix:< start end) - (let ((char (ustring-ref string start)) + (let ((char (string-ref string start)) (start+1 (fix:+ start 1))) (cond ((char=? #\/ char) (parse-denominator-1 string start+1 end @@ -148,7 +148,7 @@ USA. (define (parse-digits string start end integer exactness radix k) (let loop ((start start) (integer integer)) (if (fix:< start end) - (let ((char (ustring-ref string start))) + (let ((char (string-ref string start))) (cond ((char->digit char radix) => (lambda (digit) (loop (fix:+ start 1) @@ -157,7 +157,7 @@ USA. (do ((start (fix:+ start 1) (fix:+ start 1)) (integer (* integer radix) (* integer radix))) ((not (and (fix:< start end) - (char=? #\# (ustring-ref string start)))) + (char=? #\# (string-ref string start)))) (k start integer (or exactness 'IMPLICIT-INEXACT) #t)))) (else (k start integer exactness #f)))) @@ -179,7 +179,7 @@ USA. (define (parse-decimal-1 string start end exactness sign) ;; State: radix is 10, leading dot seen. (and (fix:< start end) - (let ((digit (char->digit (ustring-ref string start) 10)) + (let ((digit (char->digit (string-ref string start) 10)) (start (fix:+ start 1))) (and digit (parse-decimal-2 string start end digit -1 exactness sign))))) @@ -188,7 +188,7 @@ USA. ;; State: radix is 10, dot seen. (let loop ((start start) (integer integer) (exponent exponent)) (if (fix:< start end) - (let ((char (ustring-ref string start)) + (let ((char (string-ref string start)) (start+1 (fix:+ start 1))) (cond ((char->digit char 10) => (lambda (digit) @@ -207,7 +207,7 @@ USA. ;; State: radix is 10, dot and # seen. (let loop ((start start)) (if (fix:< start end) - (let ((char (ustring-ref string start)) + (let ((char (string-ref string start)) (start+1 (fix:+ start 1))) (if (char=? #\# char) (loop start+1) @@ -216,7 +216,7 @@ USA. (finish-real integer exponent exactness sign)))) (define (parse-decimal-4 string start end integer exponent exactness sign) - (if (exponent-marker? (ustring-ref string start)) + (if (exponent-marker? (string-ref string start)) (parse-exponent-1 string (fix:+ start 1) end integer exponent exactness sign) (parse-decimal-5 string start end integer exponent exactness sign))) @@ -225,12 +225,12 @@ USA. ;; State: radix is 10, exponent seen. (define (get-digits start esign) (and (fix:< start end) - (let ((digit (char->digit (ustring-ref string start) 10))) + (let ((digit (char->digit (string-ref string start) 10))) (and digit (let loop ((start (fix:+ start 1)) (eint digit)) (if (fix:< start end) (let ((digit - (char->digit (ustring-ref string start) 10))) + (char->digit (string-ref string start) 10))) (if digit (loop (fix:+ start 1) (+ (* eint 10) digit)) @@ -245,7 +245,7 @@ USA. integer exponent exactness sign)))) (and (fix:< start end) - (let ((esign (ustring-ref string start))) + (let ((esign (string-ref string start))) (if (sign? esign) (get-digits (fix:+ start 1) esign) (get-digits start #f))))) @@ -257,7 +257,7 @@ USA. (define (parse-complex string start end real exactness radix sign) (if (fix:< start end) - (let ((char (ustring-ref string start)) + (let ((char (string-ref string start)) (start+1 (fix:+ start 1)) (exactness (if (eq? 'IMPLICIT-INEXACT exactness) #f exactness))) (cond ((sign? char) diff --git a/src/runtime/output.scm b/src/runtime/output.scm index d6ba8286c..71fde7a74 100644 --- a/src/runtime/output.scm +++ b/src/runtime/output.scm @@ -35,7 +35,7 @@ USA. ((textual-port-operation/write-char port) port char)) (define (output-port/write-string port string) - (output-port/write-substring port string 0 (ustring-length string))) + (output-port/write-substring port string 0 (string-length string))) (define (output-port/write-substring port string start end) ((textual-port-operation/write-substring port) port string start end)) @@ -94,10 +94,10 @@ USA. (let ((port (optional-output-port port 'WRITE-STRING)) (end (if (default-object? end) - (ustring-length string) + (string-length string) (begin (guarantee index-fixnum? end 'write-string) - (if (not (fix:<= end (ustring-length string))) + (if (not (fix:<= end (string-length string))) (error:bad-range-argument end 'write-string)) end)))) (let ((start diff --git a/src/runtime/packag.scm b/src/runtime/packag.scm index 98efe5dfe..b155dc85d 100644 --- a/src/runtime/packag.scm +++ b/src/runtime/packag.scm @@ -183,13 +183,13 @@ USA. (let ((p (->pathname pathname))) (pathname-new-type (pathname-new-name p - (ustring-append + (string-append (or (pathname-name p) ;; Interpret dirname/ as dirname/dirname-OS.pkd. (let ((dir (pathname-directory p))) (if (pair? dir) (let ((name (last dir))) - (if (ustring? name) + (if (string? name) name "")) ""))) @@ -276,8 +276,8 @@ USA. (and (pair? clause) (or (eq? (car clause) 'ELSE) (vector-of-type? (car clause) symbol?)) - (vector-of-type? (cdr clause) ustring?))))) - (vector-of-type? file-case ustring?)))) + (vector-of-type? (cdr clause) string?))))) + (vector-of-type? file-case string?)))) (vector? (load-description/initializations object)) (vector? (load-description/finalizations object)))) diff --git a/src/runtime/parse.scm b/src/runtime/parse.scm index 69fa8c84e..0d44f4ef3 100644 --- a/src/runtime/parse.scm +++ b/src/runtime/parse.scm @@ -482,15 +482,15 @@ USA. (define (maybe-keyword db string) (cond ((and (eq? 'SUFFIX (db-keyword-style db)) - (ustring-suffix? ":" string) - (fix:> (ustring-length string) 1)) + (string-suffix? ":" string) + (fix:> (string-length string) 1)) (string->keyword - (ustring-head string - (fix:- (ustring-length string) 1)))) + (string-head string + (fix:- (string-length string) 1)))) ((and (eq? 'SUFFIX (db-keyword-style db)) - (ustring-prefix? ":" string) - (fix:> (ustring-length string) 1)) - (string->keyword (ustring-tail string 1))) + (string-prefix? ":" string) + (fix:> (string-length string) 1)) + (string->keyword (string-tail string 1))) (else #f))) (define (handler:number port db ctx char1 char2) @@ -746,7 +746,7 @@ USA. (define (ill-formed-hex chars) (error:illegal-string-escape - (list->ustring (cons* #\\ #\x (reverse chars))))) + (list->string (cons* #\\ #\x (reverse chars))))) (define (parse-octal-escape c1 d1) (let* ((c2 (%read-char/no-eof port db)) @@ -754,7 +754,7 @@ USA. (c3 (%read-char/no-eof port db)) (d3 (char->digit c3 8))) (if (not (and d2 d3)) - (error:illegal-string-escape (list->ustring (list #\\ c1 c2 c3)))) + (error:illegal-string-escape (list->string (list #\\ c1 c2 c3)))) (integer->char (fix:+ (fix:lsh (fix:+ (fix:lsh d1 3) d2) 3) d3)))) (loop)))) @@ -762,16 +762,16 @@ USA. (define (handler:false port db ctx char1 char2) ctx char1 (let ((string (parse-atom port db (list char2)))) - (if (not (or (ustring=? string "f") - (ustring=? string "false"))) + (if (not (or (string=? string "f") + (string=? string "false"))) (error:illegal-boolean string))) #f) (define (handler:true port db ctx char1 char2) ctx char1 (let ((string (parse-atom port db (list char2)))) - (if (not (or (ustring=? string "t") - (ustring=? string "true"))) + (if (not (or (string=? string "t") + (string=? string "true"))) (error:illegal-boolean string))) #t) @@ -819,20 +819,20 @@ USA. (define (handler:named-constant port db ctx char1 char2) ctx char1 char2 (let ((name (parse-atom port db '()))) - (cond ((ustring=? name "null") '()) - ((ustring=? name "false") #f) - ((ustring=? name "true") #t) - ((ustring=? name "optional") lambda-tag:optional) - ((ustring=? name "rest") lambda-tag:rest) - ((ustring=? name "key") lambda-tag:key) - ((ustring=? name "aux") lambda-tag:aux) - ((ustring=? name "eof") (eof-object)) - ((ustring=? name "default") (default-object)) - ((ustring=? name "unspecific") unspecific) - ((ustring=? name "fold-case") + (cond ((string=? name "null") '()) + ((string=? name "false") #f) + ((string=? name "true") #t) + ((string=? name "optional") lambda-tag:optional) + ((string=? name "rest") lambda-tag:rest) + ((string=? name "key") lambda-tag:key) + ((string=? name "aux") lambda-tag:aux) + ((string=? name "eof") (eof-object)) + ((string=? name "default") (default-object)) + ((string=? name "unspecific") unspecific) + ((string=? name "fold-case") (set-db-fold-case! db #t) continue-parsing) - ((ustring=? name "no-fold-case") + ((string=? name "no-fold-case") (set-db-fold-case! db #f) continue-parsing) (else diff --git a/src/runtime/parser-buffer.scm b/src/runtime/parser-buffer.scm index 743164472..0ddabf859 100644 --- a/src/runtime/parser-buffer.scm +++ b/src/runtime/parser-buffer.scm @@ -53,7 +53,7 @@ USA. (define (string->parser-buffer string #!optional start end) (let* ((caller 'string->parser-buffer) - (end (fix:end-index end (ustring-length string) caller)) + (end (fix:end-index end (string-length string) caller)) (start (fix:start-index start end caller))) (make-parser-buffer string start end 0 0 #f #t 0))) @@ -61,10 +61,10 @@ USA. (guarantee textual-input-port? port 'textual-input-port->parser-buffer) (if (or (default-object? prefix) (not prefix) - (and (ustring? prefix) - (fix:= 0 (ustring-length prefix)))) + (and (string? prefix) + (fix:= 0 (string-length prefix)))) (make-parser-buffer (make-ustring min-length) 0 0 0 0 port #f 0) - (let ((n (ustring-length prefix))) + (let ((n (string-length prefix))) (make-parser-buffer (%grow-buffer prefix n (fix:max min-length n)) 0 n 0 0 port #f 0)))) @@ -110,7 +110,7 @@ USA. (set-parser-buffer-line! buffer (parser-buffer-pointer-line p))) (define (get-parser-buffer-tail buffer p) - (call-with-parser-buffer-tail buffer p ustring-copy)) + (call-with-parser-buffer-tail buffer p string-copy)) (define (call-with-parser-buffer-tail buffer p procedure) ;; P must be a buffer pointer previously returned by @@ -156,8 +156,8 @@ USA. ;; characters available, return #F and leave the position unchanged. (and (guarantee-buffer-chars buffer 1) (let ((char - (ustring-ref (parser-buffer-string buffer) - (parser-buffer-index buffer)))) + (string-ref (parser-buffer-string buffer) + (parser-buffer-index buffer)))) (increment-buffer-index! buffer char) char))) @@ -166,15 +166,15 @@ USA. ;; current position. If there is a character available, return it, ;; otherwise return #F. The position is unaffected in either case. (and (guarantee-buffer-chars buffer 1) - (ustring-ref (parser-buffer-string buffer) - (parser-buffer-index buffer)))) + (string-ref (parser-buffer-string buffer) + (parser-buffer-index buffer)))) (define (parser-buffer-ref buffer index) (if (not (index-fixnum? index)) (error:wrong-type-argument index "index" 'PARSER-BUFFER-REF)) (and (guarantee-buffer-chars buffer (fix:+ index 1)) - (ustring-ref (parser-buffer-string buffer) - (fix:+ (parser-buffer-index buffer) index)))) + (string-ref (parser-buffer-string buffer) + (fix:+ (parser-buffer-index buffer) index)))) (define (match-parser-buffer-char buffer char) (match-char buffer char char=?)) @@ -218,8 +218,8 @@ USA. (define-integrable (match-char buffer reference compare) (and (guarantee-buffer-chars buffer 1) (let ((char - (ustring-ref (parser-buffer-string buffer) - (parser-buffer-index buffer)))) + (string-ref (parser-buffer-string buffer) + (parser-buffer-index buffer)))) (and (compare char reference) (begin (increment-buffer-index! buffer char) @@ -227,8 +227,8 @@ USA. (define-integrable (match-char-no-advance buffer reference compare) (and (guarantee-buffer-chars buffer 1) - (compare (ustring-ref (parser-buffer-string buffer) - (parser-buffer-index buffer)) + (compare (string-ref (parser-buffer-string buffer) + (parser-buffer-index buffer)) reference))) (define-integrable (match-char-not buffer reference compare) @@ -256,7 +256,7 @@ USA. (match-string buffer string match-substring-loop-na char-ci=?)) (define-integrable (match-string buffer string loop compare) - (loop buffer string 0 (ustring-length string) compare)) + (loop buffer string 0 (string-length string) compare)) (define (match-parser-buffer-substring buffer string start end) (match-substring buffer string start end match-substring-loop char=?)) @@ -271,7 +271,7 @@ USA. (match-substring buffer string start end match-substring-loop-na char-ci=?)) (define-integrable (match-substring buffer string start end loop compare) - (guarantee ustring? string) + (guarantee string? string) (loop buffer string start end compare)) (define-integrable (match-substring-loop buffer string start end compare) @@ -282,10 +282,10 @@ USA. (bi (parser-buffer-index buffer)) (bl (parser-buffer-line buffer))) (if (fix:< i end) - (and (compare (ustring-ref string i) (ustring-ref bs bi)) + (and (compare (string-ref string i) (string-ref bs bi)) (loop (fix:+ i 1) (fix:+ bi 1) - (if (char=? (ustring-ref bs bi) #\newline) + (if (char=? (string-ref bs bi) #\newline) (fix:+ bl 1) bl))) (begin @@ -298,7 +298,7 @@ USA. (let ((bs (parser-buffer-string buffer))) (let loop ((i start) (bi (parser-buffer-index buffer))) (if (fix:< i end) - (and (compare (ustring-ref string i) (ustring-ref bs bi)) + (and (compare (string-ref string i) (string-ref bs bi)) (loop (fix:+ i 1) (fix:+ bi 1))) #t))))) @@ -314,7 +314,7 @@ USA. (let loop ((i i) (n (parser-buffer-line buffer))) (if (fix:< i j) (loop (fix:+ i 1) - (if (char=? (ustring-ref s i) #\newline) + (if (char=? (string-ref s i) #\newline) (fix:+ n 1) n)) (set-parser-buffer-line! buffer n))) @@ -330,14 +330,14 @@ USA. (if (fix:> index 0) (let* ((end* (fix:- end index)) (string* - (let ((n (ustring-length string))) + (let ((n (string-length string))) (if (and (fix:> n min-length) (fix:<= end* (fix:quotient n 4))) (make-ustring (fix:quotient n 2)) string)))) (without-interruption (lambda () - (ustring-copy! string* 0 string index end) + (string-copy! string* 0 string index end) (set-parser-buffer-string! buffer string*) (set-parser-buffer-index! buffer 0) (set-parser-buffer-end! buffer end*) @@ -359,7 +359,7 @@ USA. (end (parser-buffer-end buffer))) ;; (assert (fix:> min-end end)) (let ((string (parser-buffer-string buffer))) - (if (fix:> min-end (ustring-length string)) + (if (fix:> min-end (string-length string)) (set-parser-buffer-string! buffer (%grow-buffer string end min-end)))) (let ((port (parser-buffer-port buffer)) @@ -383,9 +383,9 @@ USA. (define (%grow-buffer string end min-length) (let ((new-string (make-ustring - (let loop ((n (ustring-length string))) + (let loop ((n (string-length string))) (if (fix:<= min-length n) n (loop (fix:* n 2))))))) - (ustring-copy! new-string 0 string 0 end) + (string-copy! new-string 0 string 0 end) new-string)) \ No newline at end of file diff --git a/src/runtime/pathnm.scm b/src/runtime/pathnm.scm index a9ebb8c2f..6b6510f72 100644 --- a/src/runtime/pathnm.scm +++ b/src/runtime/pathnm.scm @@ -126,7 +126,7 @@ these rules: (define (pathname-arg object defaults operator) (cond ((pathname? object) object) - ((ustring? object) (parse-namestring object #f defaults)) + ((string? object) (parse-namestring object #f defaults)) (else (error:not-pathname object operator)))) (define (make-pathname host device directory name type version) @@ -335,7 +335,7 @@ these rules: (if (pair? path) (let ((d (cons keyword (except-last-pair path))) (s (car (last-pair path)))) - (if (fix:= 0 (ustring-length s)) + (if (fix:= 0 (string-length s)) (values d #f #f) (let ((pn (parse-namestring s))) (values d @@ -346,9 +346,9 @@ these rules: (let ((scheme (uri-scheme uri)) (path (map (lambda (x) - (cond ((ustring=? x "*") 'WILD) - ((ustring=? x "..") 'UP) - ((ustring=? x ".") 'HERE) + (cond ((string=? x "*") 'WILD) + ((string=? x "..") 'UP) + ((string=? x ".") 'HERE) (else x))) (uri-path uri))) (lose @@ -358,7 +358,7 @@ these rules: (case scheme ((file) (if (and (pair? path) - (fix:= 0 (ustring-length (car path)))) + (fix:= 0 (string-length (car path)))) (let ((path (cdr path))) (receive (device path) (let ((device (pathname-device defaults))) @@ -387,7 +387,7 @@ these rules: (if (and (not (default-object? defaults)) defaults) defaults (param:default-pathname-defaults)))))) - (cond ((ustring? namestring) + (cond ((string? namestring) ((host-type/operation/parse-namestring (host/type host)) namestring host)) ((pathname? namestring) @@ -400,8 +400,8 @@ these rules: (define (->namestring pathname) (let ((pathname (->pathname pathname))) - (ustring-append (host-namestring pathname) - (pathname->namestring pathname)))) + (string-append (host-namestring pathname) + (pathname->namestring pathname)))) (define (file-namestring pathname) (pathname->namestring (file-pathname pathname))) @@ -412,7 +412,7 @@ these rules: (define (host-namestring pathname) (let ((host (host/name (pathname-host pathname)))) (if host - (ustring-append host "::") + (string-append host "::") ""))) (define (enough-namestring pathname #!optional defaults) @@ -424,7 +424,7 @@ these rules: (let ((namestring (pathname->namestring pathname))) (if (host=? (%pathname-host pathname) (%pathname-host defaults)) namestring - (ustring-append (host-namestring pathname) namestring)))))) + (string-append (host-namestring pathname) namestring)))))) (define (pathname->namestring pathname) ((host-type/operation/pathname->namestring diff --git a/src/runtime/port.scm b/src/runtime/port.scm index a186d94e7..a48537aa1 100644 --- a/src/runtime/port.scm +++ b/src/runtime/port.scm @@ -229,7 +229,7 @@ USA. (cond ((not char) #f) ((eof-object? char) 0) (else - (ustring-set! string start char) + (string-set! string start char) (let loop ((index (+ start 1))) (if (and (< index end) (char-ready? port)) @@ -237,7 +237,7 @@ USA. (if (or (not char) (eof-object? char)) (- index start) (begin - (ustring-set! string index char) + (string-set! string index char) (loop (+ index 1))))) (- index start)))))))) @@ -267,7 +267,7 @@ USA. (let ((write-char (textual-port-operation/write-char port))) (let loop ((i start)) (if (< i end) - (let ((n (write-char port (ustring-ref string i)))) + (let ((n (write-char port (string-ref string i)))) (cond ((not n) (and (> i start) (- i start))) ((> n 0) (loop (+ i 1))) (else (- i start)))) @@ -343,7 +343,7 @@ USA. (if (and n (> n 0)) (let ((end (+ start n))) (set-textual-port-previous! port - (ustring-ref string (- end 1))) + (string-ref string (- end 1))) (transcribe-substring string start end port))) n)))) (flush-output diff --git a/src/runtime/pp.scm b/src/runtime/pp.scm index 592f3ab83..061b4d0a3 100644 --- a/src/runtime/pp.scm +++ b/src/runtime/pp.scm @@ -281,7 +281,7 @@ USA. (define (with-highlight-strings-printed pph thunk) (let ((print-string (lambda (s) - (if (ustring? s) + (if (string? s) (*unparse-string s) (s (output-port)))))) (print-string (pph/start-string pph)) @@ -290,14 +290,14 @@ USA. (define (pph/start-string-length pph) (let ((start (pph/start-string pph))) - (if (ustring? start) - (ustring-length start) + (if (string? start) + (string-length start) 0))) (define (pph/end-string-length pph) (let ((end (pph/end-string pph))) - (if (ustring? end) - (ustring-length end) + (if (string? end) + (string-length end) 0))) (define (pp-top-level expression port as-code? indentation list-depth) @@ -378,7 +378,7 @@ USA. ((prefix-node? node) (*unparse-string (prefix-node-prefix node)) (let ((new-column - (+ column (ustring-length (prefix-node-prefix node)))) + (+ column (string-length (prefix-node-prefix node)))) (subnode (prefix-node-subnode node))) (if (null? (dispatch-list)) (print-node subnode new-column depth) @@ -412,8 +412,8 @@ USA. (and (not (null? (cdr subnodes))) (let ((first (unhighlight (car subnodes)))) (and (symbol? first) - (assq (if (ustring-prefix? "define-" - (symbol->string first)) + (assq (if (string-prefix? "define-" + (symbol->string first)) 'define first) (dispatch-list))))))) @@ -981,7 +981,7 @@ USA. (update-queue (cdr half-pointer/queue) '(CDR))))) (if (eq? (car half-pointer/queue) (cdr pair)) (make-singleton-list-node - (ustring-append + (string-append ". " (circularity-string (cdr half-pointer/queue)))) (loop (cdr pair) list-breadth half-pointer/queue))) @@ -1207,19 +1207,19 @@ USA. (define (circularity-string queue) (let ((depth (queue-depth queue)) (cdrs (queue/past-cdrs queue))) - (ustring-append + (string-append (cond ((= depth 1) "#[circularity (current parenthetical level") ((= depth 2) "#[circularity (up 1 parenthetical level") (else - (ustring-append "#[circularity (up " - (number->string (-1+ depth)) - " parenthetical levels"))) + (string-append "#[circularity (up " + (number->string (-1+ depth)) + " parenthetical levels"))) (cond ((= cdrs 0) ")]") ((= cdrs 1) ", downstream 1 cdr.)]") (else - (ustring-append ", downstream " - (number->string cdrs) - " cdrs.)]")))))) + (string-append ", downstream " + (number->string cdrs) + " cdrs.)]")))))) ;;;; Node Model @@ -1231,7 +1231,7 @@ USA. ;;; be gained by keeping it around. (define (symbol-length symbol) - (ustring-length + (string-length (call-with-output-string (lambda (port) (write symbol port))))) @@ -1247,13 +1247,13 @@ USA. (subnode #f read-only #t)) (define (make-prefix-node prefix subnode) - (cond ((ustring? subnode) - (ustring-append prefix subnode)) + (cond ((string? subnode) + (string-append prefix subnode)) ((prefix-node? subnode) - (make-prefix-node (ustring-append prefix (prefix-node-prefix subnode)) + (make-prefix-node (string-append prefix (prefix-node-prefix subnode)) (prefix-node-subnode subnode))) (else - (%make-prefix-node (+ (ustring-length prefix) (node-size subnode)) + (%make-prefix-node (+ (string-length prefix) (node-size subnode)) prefix subnode)))) @@ -1281,7 +1281,7 @@ USA. ((prefix-node? node) (prefix-node-size node)) ((highlighted-node? node) (highlighted-node/size node)) - (else (ustring-length node)))) + (else (string-length node)))) (define-structure (highlighted-node (conc-name highlighted-node/) diff --git a/src/runtime/rgxcmp.scm b/src/runtime/rgxcmp.scm index 2f3ab92c5..30c69a05e 100644 --- a/src/runtime/rgxcmp.scm +++ b/src/runtime/rgxcmp.scm @@ -380,7 +380,7 @@ USA. (if (not (stack-empty? ctx)) (compilation-error ctx "Unmatched \\(")) (make-compiled-regexp - (list->ustring (map integer->char (cdr (output-head ctx)))) + (list->string (map integer->char (cdr (output-head ctx)))) case-fold?)) (begin (compile-pattern-char ctx) @@ -695,7 +695,7 @@ USA. (char->integer char))) (char-set-members (re-compile-char-set - (list->ustring (map integer->char (reverse! chars))) + (list->string (map integer->char (reverse! chars))) #f)))) (loop (cons char chars))))) (output-start! ctx (if invert? re-code:not-char-set re-code:char-set)) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 3e31bfa17..a684b7809 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -857,7 +857,6 @@ USA. subvector-uniform? vector vector->list - vector->string vector-append vector-binary-search vector-copy @@ -1050,216 +1049,139 @@ USA. guarantee-substring-end-index guarantee-substring-start-index lisp-string->camel-case - ;; list->string make-string reverse-string reverse-string! reverse-substring reverse-substring! set-string-length! - string - ;; string->list - ;; string->vector string-allocate - ;; string-append string-capitalize string-capitalize! string-capitalized? - ;; string-ci-hash - ;; string-ci<=? - ;; string-ci=? - ;; string-ci>? string-compare string-compare-ci - ;; string-copy - ;; string-copy! - ;; string-downcase string-downcase! - ;; string-fill! - string-find-next-char - string-find-next-char-ci - string-find-next-char-in-set - string-find-previous-char - string-find-previous-char-ci - string-find-previous-char-in-set - ;; string-for-each - ;; string-hash - ;; string-hash-mod - ;; string-head string-head! string-joiner string-joiner* - ;; string-length - ;; string-lower-case? - ;; string-map string-match-backward string-match-backward-ci string-match-forward string-match-forward-ci string-maximum-length - string-move! string-null? string-pad-left string-pad-right - ;; string-prefix-ci? - ;; string-prefix? - ;; string-ref string-replace string-replace! string-search-all string-search-backward string-search-forward - ;; string-set! string-splitter - ;; string-suffix-ci? - ;; string-suffix? - ;; string-tail string-trim string-trim-left string-trim-right - ;; string-upcase string-upcase! - ;; string-upper-case? - ;; string<=? - ;; string=? - ;; string>? - ;; string? - ;; substring - substring->list substring-capitalize! substring-capitalized? - substring-cilist string->list) + (substring-move-left! substring-move!) + (substring-move-right! substring-move!) + string-find-next-char + string-find-next-char-ci + string-find-next-char-in-set + string-find-previous-char + string-find-previous-char-ci + string-find-previous-char-in-set + string-move! + substring-cistring list->ustring) - (string->list ustring->list) - (string->vector ustring->vector) - (string-append ustring-append) - (string-ci-hash ustring-ci-hash) - (string-ci<=? ustring-ci<=?) - (string-ci=? ustring-ci>=?) - (string-ci>? ustring-ci>?) - (string-copy ustring-copy) - (string-copy! ustring-copy!) - (string-downcase ustring-downcase) - (string-fill! ustring-fill!) - (string-foldcase ustring-foldcase) - (string-for-each ustring-for-each) - (string-hash ustring-hash) - (string-hash-mod ustring-hash) - (string-head ustring-head) - (string-length ustring-length) - (string-lower-case? ustring-lower-case?) - (string-map ustring-map) - (string-prefix-ci? ustring-prefix-ci?) - (string-prefix? ustring-prefix?) - (string-ref ustring-ref) - (string-set! ustring-set!) - (string-suffix-ci? ustring-suffix-ci?) - (string-suffix? ustring-suffix?) - (string-tail ustring-tail) - (string-upcase ustring-upcase) - (string-upper-case? ustring-upper-case?) - (string<=? ustring<=?) - (string=? ustring>=?) - (string>? ustring>?) - (string? ustring?) - (substring ustring-copy) - (usubstring ustring-copy) - list->ustring + (substring string-copy) + list->string make-ustring + string + string* + string->list + string->vector + string-any + string-append + string-append* + string-ci-hash + string-ci<=? + string-ci=? + string-ci>? + string-copy + string-copy! + string-count + string-downcase + string-every + string-fill! + string-find-first-index + string-find-last-index + string-foldcase + string-for-each string-for-primitive ;export to (runtime) after 9.3 - ustring - ustring* - ustring->list - ustring->vector - ustring-any - ustring-append - ustring-append* - ustring-ci<=? - ustring-ci=? - ustring-ci>? - ustring-ci-hash - ustring-copy - ustring-copy! - ustring-downcase - ustring-every - ustring-fill! - ustring-find-first-char ;prefer ustring-find-first-index - ustring-find-first-char-in-set ;prefer ustring-find-first-index - ustring-find-first-index - ustring-find-last-char ;prefer ustring-find-last-index - ustring-find-last-char-in-set ;prefer ustring-find-last-index - ustring-find-last-index - ustring-foldcase - ustring-for-each - ustring-hash - ustring-head - ustring-lower-case? - ustring-length - ustring-map - ustring-prefix-ci? - ustring-prefix? - ustring-ref - ustring-set! - ustring-slice - ustring-suffix-ci? - ustring-suffix? - ustring-tail - ustring-upcase - ustring-upper-case? - ustring<=? - ustring=? - ustring>? - ustring? - vector->ustring) + string-hash + string-head + string-length + string-lower-case? + string-map + string-prefix-ci? + string-prefix? + string-ref + string-set! + string-slice + string-suffix-ci? + string-suffix? + string-tail + string-upcase + string-upper-case? + string<=? + string=? + string>? + string? + vector->string) (export (runtime bytevector) legacy-string-allocate legacy-string? @@ -1267,7 +1189,7 @@ USA. (export (runtime predicate-metadata) register-ustring-predicates!) (export (runtime symbol) - %ustring* + %string* legacy-string-downcase legacy-string?)) diff --git a/src/runtime/sfile.scm b/src/runtime/sfile.scm index 38413c58a..7b5f356f3 100644 --- a/src/runtime/sfile.scm +++ b/src/runtime/sfile.scm @@ -172,8 +172,8 @@ USA. (if name (loop (if (and (not include-dots?) - (or (ustring=? "." name) - (ustring=? ".." name))) + (or (string=? "." name) + (string=? ".." name))) result (cons name result))) (begin @@ -245,8 +245,8 @@ USA. (and (list? object) (for-all? object (lambda (object) - (and (ustring? object) - (not (fix:= 0 (ustring-length object)))))))) + (and (string? object) + (not (fix:= 0 (string-length object)))))))) (define (guarantee-init-file-directory pathname) (let ((directory (user-homedir-pathname))) @@ -273,7 +273,7 @@ USA. (pathname-type->mime-type (pathname-type pathname))) (define (pathname-type->mime-type type) - (and (ustring? type) + (and (string? type) (let ((mime-type (hash-table/get local-type-map type #f))) (if mime-type (and (mime-type? mime-type) @@ -283,12 +283,12 @@ USA. (string->mime-type string))))))) (define (associate-pathname-type-with-mime-type type mime-type) - (guarantee ustring? type 'ASSOCIATE-PATHNAME-TYPE-WITH-MIME-TYPE) + (guarantee string? type 'ASSOCIATE-PATHNAME-TYPE-WITH-MIME-TYPE) (guarantee-mime-type mime-type 'ASSOCIATE-PATHNAME-TYPE-WITH-MIME-TYPE) (hash-table/put! local-type-map type mime-type)) (define (disassociate-pathname-type-from-mime-type type) - (guarantee ustring? type 'DISASSOCIATE-PATHNAME-TYPE-FROM-MIME-TYPE) + (guarantee string? type 'DISASSOCIATE-PATHNAME-TYPE-FROM-MIME-TYPE) (hash-table/put! local-type-map type 'DISASSOCIATED)) (define-record-type @@ -365,7 +365,7 @@ USA. 0)) (define (mime-type-string? object) - (and (ustring? object) + (and (string? object) (string-is-mime-type? object))) (define (string-is-mime-type? string #!optional start end) @@ -376,7 +376,7 @@ USA. (string-is-mime-token? (symbol-name object)))) (define (mime-token-string? object) - (and (ustring? object) + (and (string? object) (string-is-mime-token? object))) (define (string-is-mime-token? string #!optional start end) diff --git a/src/runtime/string.scm b/src/runtime/string.scm index 83275c6d4..b769e2880 100644 --- a/src/runtime/string.scm +++ b/src/runtime/string.scm @@ -532,10 +532,10 @@ USA. (define (string-joiner* infix #!optional prefix suffix) (let ((prefix (if (default-object? prefix) "" prefix)) (suffix (if (default-object? suffix) "" suffix))) - (let ((infix (ustring-append suffix infix prefix))) + (let ((infix (string-append suffix infix prefix))) (lambda (strings) - (ustring-append* + (string-append* (if (pair? strings) (cons* prefix (car strings) @@ -555,14 +555,14 @@ USA. (allow-runs? (if (default-object? allow-runs?) #t allow-runs?))) (lambda (string #!optional start end) - (let* ((end (fix:end-index end (ustring-length string) 'string-splitter)) + (let* ((end (fix:end-index end (string-length string) 'string-splitter)) (start (fix:start-index start end 'string-splitter))) (define (find-start start) (if allow-runs? (let loop ((index start)) (if (fix:< index end) - (if (predicate (ustring-ref string index)) + (if (predicate (string-ref string index)) (loop (fix:+ index 1)) (find-end index (fix:+ index 1))) '())) @@ -571,11 +571,11 @@ USA. (define (find-end start index) (let loop ((index index)) (if (fix:< index end) - (if (predicate (ustring-ref string index)) - (cons (ustring-copy string start index) + (if (predicate (string-ref string index)) + (cons (string-copy string start index) (find-start (fix:+ index 1))) (loop (fix:+ index 1))) - (list (ustring-copy string start end))))) + (list (string-copy string start end))))) (find-start start))))) diff --git a/src/runtime/stringio.scm b/src/runtime/stringio.scm index 7f487bab4..a06ac45da 100644 --- a/src/runtime/stringio.scm +++ b/src/runtime/stringio.scm @@ -39,7 +39,7 @@ USA. (procedure (open-input-string string))) (define (open-input-string string #!optional start end) - (let* ((end (fix:end-index end (ustring-length string) 'open-input-string)) + (let* ((end (fix:end-index end (string-length string) 'open-input-string)) (start (fix:start-index start end 'open-input-string))) (make-textual-port string-input-type (make-istate string start end start)))) @@ -71,13 +71,13 @@ USA. (define (string-in/peek-char port) (let ((ss (textual-port-state port))) (if (fix:< (istate-next ss) (istate-end ss)) - (ustring-ref (istate-string ss) (istate-next ss)) + (string-ref (istate-string ss) (istate-next ss)) (make-eof-object port)))) (define (string-in/read-char port) (let ((ss (textual-port-state port))) (if (fix:< (istate-next ss) (istate-end ss)) - (let ((char (ustring-ref (istate-string ss) (istate-next ss)))) + (let ((char (string-ref (istate-string ss) (istate-next ss)))) (set-istate-next! ss (fix:+ (istate-next ss) 1)) char) (make-eof-object port)))) @@ -88,7 +88,7 @@ USA. (start* (istate-next ss)) (end* (istate-end ss))) (let ((n (fix:min (fix:- end start) (fix:- end* start*)))) - (ustring-copy! string* start* string start (fix:+ start n)) + (string-copy! string* start* string start (fix:+ start n)) (set-istate-next! ss (fix:+ start* n)) n)))) @@ -97,7 +97,7 @@ USA. (if (not (fix:< (istate-start ss) (istate-next ss))) (error "No char to unread:" port)) (let ((prev (fix:- (istate-next ss) 1))) - (if (not (char=? char (ustring-ref (istate-string ss) prev))) + (if (not (char=? char (string-ref (istate-string ss) prev))) (error "Unread char incorrect:" char)) (set-istate-next! ss prev)))) @@ -111,7 +111,7 @@ USA. (procedure (open-input-octets octets))) (define (open-input-octets octets #!optional start end) - (let* ((end (fix:end-index end (ustring-length octets) 'open-input-octets)) + (let* ((end (fix:end-index end (string-length octets) 'open-input-octets)) (start (fix:start-index start end 'open-input-octets)) (port (make-generic-i/o-port (make-octets-source octets start end) @@ -134,7 +134,7 @@ USA. (j start* (fix:+ j 1))) ((not (fix:< i limit)) (set! index i)) - (bytevector-u8-set! bv j (char->integer (ustring-ref string i))))) + (bytevector-u8-set! bv j (char->integer (string-ref string i))))) n))))) (define (make-octets-input-type) @@ -199,7 +199,7 @@ USA. (define (string-out/write-char port char) (let ((os (textual-port-state port))) (maybe-grow-buffer os 1) - (ustring-set! (ostate-buffer os) (ostate-index os) char) + (string-set! (ostate-buffer os) (ostate-index os) char) (set-ostate-index! os (fix:+ (ostate-index os) 1)) (set-ostate-column! os (new-column char (ostate-column os))) 1)) @@ -208,18 +208,18 @@ USA. (let ((os (textual-port-state port)) (n (fix:- end start))) (maybe-grow-buffer os n) - (ustring-copy! (ostate-buffer os) (ostate-index os) string start end) + (string-copy! (ostate-buffer os) (ostate-index os) string start end) (set-ostate-index! os (fix:+ (ostate-index os) n)) (update-column-for-substring! os n) n)) (define (string-out/extract-output port) (let ((os (textual-port-state port))) - (ustring-copy (ostate-buffer os) 0 (ostate-index os)))) + (string-copy (ostate-buffer os) 0 (ostate-index os)))) (define (string-out/extract-output! port) (let* ((os (textual-port-state port)) - (output (ustring-copy (ostate-buffer os) 0 (ostate-index os)))) + (output (string-copy (ostate-buffer os) 0 (ostate-index os)))) (reset-buffer! os) output)) @@ -236,7 +236,7 @@ USA. (define (maybe-grow-buffer os n) (let ((buffer (ostate-buffer os)) (n (fix:+ (ostate-index os) n))) - (let ((m (ustring-length buffer))) + (let ((m (string-length buffer))) (if (fix:< m n) (let ((buffer* (make-ustring @@ -244,7 +244,7 @@ USA. (if (fix:< m n) (loop (fix:+ m m)) m))))) - (ustring-copy! buffer* 0 buffer 0 (ostate-index os)) + (string-copy! buffer* 0 buffer 0 (ostate-index os)) (set-ostate-buffer! os buffer*)))))) (define (reset-buffer! os) @@ -267,7 +267,7 @@ USA. (lambda (i column) (if (fix:< i end) (loop (fix:+ i 1) - (new-column (ustring-ref string i) column)) + (new-column (string-ref string i) column)) (set-ostate-column! os column))))) (let ((nl (find-newline string start end))) (if nl @@ -275,7 +275,7 @@ USA. (loop start (ostate-column os)))))))) (define (find-newline string start end) - (ustring-find-first-char string #\newline start end)) + (substring-find-next-char string start end #\newline)) ;;;; Output as octets diff --git a/src/runtime/swank.scm b/src/runtime/swank.scm index d0a12989d..ef2f5876a 100644 --- a/src/runtime/swank.scm +++ b/src/runtime/swank.scm @@ -435,7 +435,7 @@ USA. (define (get-object-type-name obj) (cond ((boolean? obj) "boolean") - ((ustring? obj) "string") + ((string? obj) "string") ((char? obj) "char") ((fixnum? obj) "fixnum") ((integer? obj) "integer") diff --git a/src/runtime/symbol.scm b/src/runtime/symbol.scm index 6b8e5bc82..f8aab276f 100644 --- a/src/runtime/symbol.scm +++ b/src/runtime/symbol.scm @@ -61,13 +61,13 @@ USA. (else (error "Illegal symbol name:" name)))))) (define (string-head->symbol string end) - (string->symbol (ustring-copy string 0 end))) + (string->symbol (string-copy string 0 end))) (define (string-tail->symbol string start) - (string->symbol (ustring-copy string start))) + (string->symbol (string-copy string start))) (define (symbol . objects) - (string->symbol (%ustring* objects 'symbol))) + (string->symbol (%string* objects 'symbol))) (define (intern string) (string->symbol (cold-load-foldcase string))) @@ -79,7 +79,7 @@ USA. (if (ascii-string? string) ;; Needed during cold load. (legacy-string-downcase string) - (ustring-foldcase string))) + (string-foldcase string))) (define (symbol-name symbol) (if (not (symbol? symbol)) @@ -101,10 +101,10 @@ USA. #t))))) (define (symbol-hash symbol #!optional modulus) - (ustring-hash (symbol-name symbol) modulus)) + (string-hash (symbol-name symbol) modulus)) (define (symbol? x y) - (ustringstring type-code))))))) + (string-append "undefined-type:" (number->string type-code))))))) (define (rename-user-object-type type-name) (let ((entry (assq type-name renamed-user-object-types))) @@ -454,23 +454,23 @@ USA. (*unparse-char #\] context)))) (define (unparse-symbol-name s context) - (if (and (fix:> (ustring-length s) 0) - (not (ustring=? s ".")) - (not (ustring-prefix? "#" s)) - (char-in-set? (ustring-ref s 0) char-set:symbol-initial) - (ustring-every (symbol-name-no-quoting-predicate context) s) + (if (and (fix:> (string-length s) 0) + (not (string=? s ".")) + (not (string-prefix? "#" s)) + (char-in-set? (string-ref s 0) char-set:symbol-initial) + (string-every (symbol-name-no-quoting-predicate context) s) (not (case (get-param:parser-keyword-style (context-environment context)) - ((PREFIX) (ustring-prefix? ":" s)) - ((SUFFIX) (ustring-suffix? ":" s)) + ((PREFIX) (string-prefix? ":" s)) + ((SUFFIX) (string-suffix? ":" s)) (else #f))) (not (string->number s))) (*unparse-string s context) (begin (*unparse-char #\| context) - (ustring-for-each (lambda (char) - (unparse-string-char char context)) - s) + (string-for-each (lambda (char) + (unparse-string-char char context)) + s) (*unparse-char #\| context)))) (define (symbol-name-no-quoting-predicate context) @@ -494,7 +494,7 @@ USA. (define (unparse/string string context) (if (context-slashify? context) - (let* ((end (ustring-length string)) + (let* ((end (string-length string)) (end* (let ((limit (get-param:unparser-string-length-limit))) (if limit @@ -503,7 +503,7 @@ USA. (*unparse-char #\" context) (do ((index 0 (fix:+ index 1))) ((not (fix:< index end*))) - (unparse-string-char (ustring-ref string index) context)) + (unparse-string-char (string-ref string index) context)) (if (< end* end) (*unparse-string "..." context)) (*unparse-char #\" context)) @@ -618,7 +618,7 @@ USA. (*unparse-string "#u8()" context*)))))) (define (unparse/record record context) - (cond ((ustring? record) (unparse/string record context)) + (cond ((string? record) (unparse/string record context)) ((uri? record) (unparse/uri record context)) ((get-param:unparse-with-maximum-readability?) (*unparse-readable-hash record context)) diff --git a/src/runtime/unxprm.scm b/src/runtime/unxprm.scm index 2e0d684b6..5afaaa1dc 100644 --- a/src/runtime/unxprm.scm +++ b/src/runtime/unxprm.scm @@ -60,7 +60,7 @@ USA. (let loop ((ext 0)) (let ((pathname (transformer - (merge-pathnames (ustring-append root-string (number->string ext)) + (merge-pathnames (string-append root-string (number->string ext)) directory)))) (if (allocate-temporary-file pathname) (begin @@ -164,7 +164,7 @@ USA. (define environment-variables) (define (get-environment-variable name) - (guarantee ustring? name 'GET-ENVIRONMENT-VARIABLE) + (guarantee string? name 'GET-ENVIRONMENT-VARIABLE) (let ((value (hash-table/get environment-variables name 'NONE))) (if (eq? value 'NONE) (let ((value @@ -175,13 +175,13 @@ USA. value))) (define (set-environment-variable! name value) - (guarantee ustring? name 'SET-ENVIRONMENT-VARIABLE!) + (guarantee string? name 'SET-ENVIRONMENT-VARIABLE!) (if value - (guarantee ustring? value 'SET-ENVIRONMENT-VARIABLE!)) + (guarantee string? value 'SET-ENVIRONMENT-VARIABLE!)) (hash-table/put! environment-variables name value)) (define (delete-environment-variable! name) - (guarantee ustring? name 'DELETE-ENVIRONMENT-VARIABLE!) + (guarantee string? name 'DELETE-ENVIRONMENT-VARIABLE!) (hash-table/remove! environment-variables name)) (define (reset-environment-variables!) @@ -266,8 +266,8 @@ USA. entries))))))))) (define (parse-mime.types-line line) - (if (and (fix:> (ustring-length line) 0) - (char=? #\# (ustring-ref line 0))) + (if (and (fix:> (string-length line) 0) + (char=? #\# (string-ref line 0))) #f (let ((parts (burst-string line char-set:whitespace #t))) (and (pair? parts) @@ -412,7 +412,7 @@ USA. (define (init-file-specifier->pathname specifier) (guarantee-init-file-specifier specifier 'INIT-FILE-SPECIFIER->PATHNAME) - (merge-pathnames (apply ustring-append + (merge-pathnames (apply string-append (cons ".mit-scheme" (append-map (lambda (string) (list "/" string)) specifier))) @@ -470,13 +470,13 @@ USA. path))) (define (os/parse-path-string string) - (let ((end (ustring-length string)) + (let ((end (string-length string)) (extract (lambda (string start end) - (pathname-as-directory (usubstring string start end))))) + (pathname-as-directory (substring string start end))))) (let loop ((start 0)) (if (< start end) - (let ((index (ustring-find-first-char string #\: start end))) + (let ((index (substring-find-next-char string start end #\:))) (if index (cons (if (= index start) #f diff --git a/src/runtime/unxpth.scm b/src/runtime/unxpth.scm index 3bbecc447..5613efe52 100644 --- a/src/runtime/unxpth.scm +++ b/src/runtime/unxpth.scm @@ -52,7 +52,7 @@ USA. ;;;; Pathname Parser (define (unix/parse-namestring string host) - (let ((end (ustring-length string))) + (let ((end (string-length string))) (let ((components (expand-directory-prefixes (substring-components string 0 end #\/)))) @@ -64,7 +64,7 @@ USA. (and (pair? components) (simplify-directory (if (fix:= 0 - (ustring-length (car components))) + (string-length (car components))) (cons 'ABSOLUTE (parse-directory-components (cdr components))) @@ -81,16 +81,16 @@ USA. (lambda (string) (append (string-components string #\/) (cdr components))))) - (let ((end (ustring-length string))) + (let ((end (string-length string))) (if (or (fix:= 0 end) (not (*expand-directory-prefixes?*))) components - (case (ustring-ref string 0) + (case (string-ref string 0) ((#\$) (if (fix:= 1 end) components (let ((value - (get-environment-variable (usubstring string 1 end)))) + (get-environment-variable (substring string 1 end)))) (if (not value) components (replace-head value))))) @@ -100,7 +100,7 @@ USA. (lambda () (if (fix:= 1 end) (current-home-directory) - (user-home-directory (usubstring string 1 end))))))) + (user-home-directory (substring string 1 end))))))) (if (condition? expansion) components (replace-head (->namestring expansion))))) @@ -114,33 +114,33 @@ USA. (define (parse-directory-components components) (map parse-directory-component (remove (lambda (component) - (fix:= 0 (ustring-length component))) + (fix:= 0 (string-length component))) components))) (define (parse-directory-component component) - (cond ((ustring=? ".." component) 'UP) - ((ustring=? "." component) 'HERE) + (cond ((string=? ".." component) 'UP) + ((string=? "." component) 'HERE) (else component))) (define (string-components string delimiter) - (substring-components string 0 (ustring-length string) delimiter)) + (substring-components string 0 (string-length string) delimiter)) (define (substring-components string start end delimiter) (let loop ((start start)) - (let ((index (ustring-find-first-char string delimiter start end))) + (let ((index (substring-find-next-char string start end delimiter))) (if index - (cons (usubstring string start index) (loop (fix:+ index 1))) - (list (usubstring string start end)))))) + (cons (substring string start index) (loop (fix:+ index 1))) + (list (substring string start end)))))) (define (parse-name string receiver) - (let ((end (ustring-length string))) - (let ((dot (ustring-find-last-char string #\.))) + (let ((end (string-length string))) + (let ((dot (string-find-previous-char string #\.))) (if (or (not dot) (fix:= dot 0) (fix:= dot (fix:- end 1)) - (char=? #\. (ustring-ref string (fix:- dot 1)))) + (char=? #\. (string-ref string (fix:- dot 1)))) (receiver (cond ((fix:= end 0) #f) - ((ustring=? "*" string) 'WILD) + ((string=? "*" string) 'WILD) (else string)) #f) (receiver (extract string 0 dot) @@ -148,36 +148,36 @@ USA. (define (extract string start end) (if (and (fix:= 1 (fix:- end start)) - (char=? #\* (ustring-ref string start))) + (char=? #\* (string-ref string start))) 'WILD - (usubstring string start end))) + (substring string start end))) ;;;; Pathname Unparser (define (unix/pathname->namestring pathname) - (ustring-append (unparse-directory (%pathname-directory pathname)) - (unparse-name (%pathname-name pathname) - (%pathname-type pathname)))) + (string-append (unparse-directory (%pathname-directory pathname)) + (unparse-name (%pathname-name pathname) + (%pathname-type pathname)))) (define (unparse-directory directory) (cond ((not directory) "") ((pair? directory) - (ustring-append + (string-append (if (eq? (car directory) 'ABSOLUTE) "/" "") (let loop ((directory (cdr directory))) (if (not (pair? directory)) "" - (ustring-append (unparse-directory-component (car directory)) - "/" - (loop (cdr directory))))))) + (string-append (unparse-directory-component (car directory)) + "/" + (loop (cdr directory))))))) (else (error:illegal-pathname-component directory "directory")))) (define (unparse-directory-component component) (cond ((eq? component 'UP) "..") ((eq? component 'HERE) ".") - ((ustring? component) component) + ((string? component) component) (else (error:illegal-pathname-component component "directory component")))) @@ -185,11 +185,11 @@ USA. (let ((name (or (unparse-component name) "")) (type (unparse-component type))) (if type - (ustring-append name "." type) + (string-append name "." type) name))) (define (unparse-component component) - (cond ((or (not component) (ustring? component)) component) + (cond ((or (not component) (string? component)) component) ((eq? component 'WILD) "*") (else (error:illegal-pathname-component component "component")))) @@ -207,18 +207,18 @@ USA. (memq (car directory) '(RELATIVE ABSOLUTE)) (list-of-type? (cdr directory) (lambda (element) - (if (ustring? element) - (not (fix:= 0 (ustring-length element))) + (if (string? element) + (not (fix:= 0 (string-length element))) (memq element '(UP HERE)))))) (simplify-directory directory)) (else (error:illegal-pathname-component directory "directory"))) (if (or (memq name '(#F WILD)) - (and (ustring? name) (not (fix:= 0 (ustring-length name))))) + (and (string? name) (not (fix:= 0 (string-length name))))) name (error:illegal-pathname-component name "name")) (if (or (memq type '(#F WILD)) - (and (ustring? type) (not (fix:= 0 (ustring-length type))))) + (and (string? type) (not (fix:= 0 (string-length type))))) type (error:illegal-pathname-component type "type")) (if (memq version '(#F UNSPECIFIC WILD NEWEST)) diff --git a/src/runtime/url.scm b/src/runtime/url.scm index dea2b4212..5b0860706 100644 --- a/src/runtime/url.scm +++ b/src/runtime/url.scm @@ -46,8 +46,8 @@ USA. (if scheme (guarantee-uri-scheme scheme 'MAKE-URI)) (if authority (guarantee-uri-authority authority 'MAKE-URI)) (guarantee-uri-path path 'MAKE-URI) - (if query (guarantee ustring? query 'MAKE-URI)) - (if fragment (guarantee ustring? fragment 'MAKE-URI)) + (if query (guarantee string? query 'MAKE-URI)) + (if fragment (guarantee string? fragment 'MAKE-URI)) (if (and authority (pair? path) (path-relative? path)) (error:bad-range-argument path 'MAKE-URI)) (let* ((path (remove-dot-segments path)) @@ -91,7 +91,7 @@ USA. ;;; an empty segment. (define (uri-path? object) - (list-of-type? object ustring?)) + (list-of-type? object string?)) (define (uri-path-absolute? path) (guarantee-uri-path path 'URI-PATH-ABSOLUTE?) @@ -99,7 +99,7 @@ USA. (define (path-absolute? path) (and (pair? path) - (fix:= 0 (ustring-length (car path))))) + (fix:= 0 (string-length (car path))))) (define (uri-path-relative? path) (guarantee-uri-path path 'URI-PATH-RELATIVE?) @@ -136,10 +136,10 @@ USA. (define interned-uri-authorities) (define (uri-userinfo? object) - (ustring? object)) + (string? object)) (define (uri-host? object) - (ustring? object)) + (string? object)) (define (uri-port? object) (exact-nonnegative-integer? object)) @@ -184,10 +184,10 @@ USA. '())))) (define (uri-prefix prefix) - (guarantee ustring? prefix 'URI-PREFIX) + (guarantee string? prefix 'URI-PREFIX) (lambda (suffix) - (guarantee ustring? suffix 'URI-PREFIX) - (string->absolute-uri (ustring-append prefix suffix)))) + (guarantee string? suffix 'URI-PREFIX) + (string->absolute-uri (string-append prefix suffix)))) (define (remove-dot-segments path) ;; At all times, (APPEND INPUT (REVERSE OUTPUT)) must be well @@ -199,8 +199,8 @@ USA. (if (pair? input) (let ((segment (car input)) (input (cdr input))) - (if (or (ustring=? segment "..") - (ustring=? segment ".")) + (if (or (string=? segment "..") + (string=? segment ".")) ;; Rules A and D (no-output input) ;; Rule E @@ -211,10 +211,10 @@ USA. (if (pair? input) (let ((segment (car input)) (input (cdr input))) - (cond ((ustring=? segment ".") + (cond ((string=? segment ".") ;; Rule B (maybe-done input output)) - ((ustring=? segment "..") + ((string=? segment "..") ;; Rule C (maybe-done input (if (pair? (cdr output)) @@ -313,7 +313,7 @@ USA. (begin (if caller (error:bad-range-argument object caller)) #f))) - ((ustring? object) + ((string? object) (do-string object)) ((symbol? object) (do-string (symbol->string object))) @@ -331,7 +331,7 @@ USA. (%string->uri parse-relative-uri string start end 'STRING->RELATIVE-URI)) (define (%string->uri parser string start end caller) - (or (and (ustring? string) + (or (and (string? string) (default-object? start) (default-object? end) (hash-table/get interned-uris string #f)) @@ -423,7 +423,7 @@ USA. (define parser:hostport (*parser - (seq (map ustring-downcase + (seq (map string-downcase (alt (match matcher:ip-literal) ;; subsumed by MATCHER:REG-NAME ;;matcher:ipv4-address @@ -613,13 +613,13 @@ USA. (char-set char-set:uri-hex)))) (define (decode-component string) - (if (ustring-find-first-char string #\%) + (if (string-find-next-char string #\%) (call-with-output-string (lambda (port) - (let ((end (ustring-length string))) + (let ((end (string-length string))) (let loop ((i 0)) (if (fix:< i end) - (if (char=? #\% (ustring-ref string i)) + (if (char=? #\% (string-ref string i)) (begin (write-char (integer->char (string->number string @@ -630,24 +630,24 @@ USA. port) (loop (fix:+ i 3))) (begin - (write-char (ustring-ref string i) port) + (write-char (string-ref string i) port) (loop (fix:+ i 1))))))))) string)) (define (write-encoded string unescaped port) - (write-encoded-substring string 0 (ustring-length string) unescaped port)) + (write-encoded-substring string 0 (string-length string) unescaped port)) (define (write-encoded-substring string start end unescaped port) (do ((i start (fix:+ i 1))) ((not (fix:< i end))) - (let ((char (ustring-ref string i))) + (let ((char (string-ref string i))) (if (char-set-member? unescaped char) (write-char char port) (begin (write-char #\% port) (write-string (string-pad-left - (ustring-upcase (number->string (char->integer char) - 16)) + (string-upcase (number->string (char->integer char) + 16)) 2 #\0) port)))))) diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm index 3f2ada855..e2c118f22 100644 --- a/src/runtime/ustring.scm +++ b/src/runtime/ustring.scm @@ -27,17 +27,9 @@ USA. ;;;; Unicode strings ;;; package: (runtime ustring) -;;; This implementation supports all R7RS and some MIT/GNU string operations in -;;; which all the names have "string" replaced by "ustring". This is a -;;; transitional implementation to convert MIT/GNU Scheme to full Unicode string -;;; support. -;;; -;;; For simplicity, the implementation uses the UTF-32 encoding for non-8-bit +;;; For simplicity, the implementation uses a 24-bit encoding for non-8-bit ;;; strings. This is not a good long-term approach and should be revisited once ;;; the runtime system has been converted to this string abstraction. -;;; -;;; At some point in the future we'll eliminate legacy string support and rename -;;; everything to "string". (declare (usual-integrations)) @@ -106,7 +98,7 @@ USA. (define (make-full-string k #!optional char) (let ((string (full-string-allocate k))) (if (not (default-object? char)) - (ustring-fill! string char)) + (string-fill! string char)) string)) (define-integrable (full-string-length string) @@ -118,12 +110,20 @@ USA. (define-integrable (%full-string-set! string index char) (cp-vector-set! (%full-string-cp-vector string) index (char->integer char))) -(define-record-type - (make-slice string start length) - slice? - (string slice-string) - (start slice-start) - (length slice-length)) +(define (slice? object) + (and (%record? object) + (fix:= 4 (%record-length object)) + (eq? %slice-tag (%record-ref object 0)))) + +(define-integrable (make-slice string start length) + (%record %slice-tag string start length)) + +(define-integrable %slice-tag + '|#[(runtime ustring)slice]|) + +(define-integrable (slice-string slice) (%record-ref slice 1)) +(define-integrable (slice-start slice) (%record-ref slice 2)) +(define-integrable (slice-length slice) (%record-ref slice 3)) (define (slice-end slice) (fix:+ (slice-start slice) (slice-length slice))) @@ -136,15 +136,15 @@ USA. (values string start end))) (define (register-ustring-predicates!) - (register-predicate! ustring? 'string) - (register-predicate! legacy-string? 'legacy-string '<= ustring?) - (register-predicate! full-string? 'full-string '<= ustring?) - (register-predicate! slice? 'string-slice '<= ustring?) - (register-predicate! ->ustring-component? '->ustring-component)) + (register-predicate! string? 'string) + (register-predicate! legacy-string? 'legacy-string '<= string?) + (register-predicate! full-string? 'full-string '<= string?) + (register-predicate! slice? 'string-slice '<= string?) + (register-predicate! ->string-component? '->string-component)) ;;;; Strings -(define (ustring? object) +(define (string? object) (or (legacy-string? object) (full-string? object) (slice? object))) @@ -155,19 +155,19 @@ USA. (make-full-string k char) (legacy-string-allocate 0))) -(define (ustring-length string) +(define (string-length string) (cond ((legacy-string? string) (legacy-string-length string)) ((full-string? string) (full-string-length string)) ((slice? string) (slice-length string)) - (else (error:not-a ustring? string 'ustring-length)))) + (else (error:not-a string? string 'string-length)))) -(define (ustring-ref string index) - (guarantee index-fixnum? index 'ustring-ref) +(define (string-ref string index) + (guarantee index-fixnum? index 'string-ref) (cond ((legacy-string? string) (legacy-string-ref string index)) ((full-string? string) (if (not (fix:< index (full-string-length string))) - (error:bad-range-argument index 'ustring-ref)) + (error:bad-range-argument index 'string-ref)) (%full-string-ref string index)) ((slice? string) (let ((string* (slice-string string)) @@ -176,16 +176,16 @@ USA. (legacy-string-ref string* index*) (%full-string-ref string* index*)))) (else - (error:not-a ustring? string 'ustring-ref)))) + (error:not-a string? string 'string-ref)))) -(define (ustring-set! string index char) - (guarantee index-fixnum? index 'ustring-set!) - (guarantee bitless-char? char 'ustring-set!) +(define (string-set! string index char) + (guarantee index-fixnum? index 'string-set!) + (guarantee bitless-char? char 'string-set!) (cond ((legacy-string? string) (legacy-string-set! string index char)) ((full-string? string) (if (not (fix:< index (full-string-length string))) - (error:bad-range-argument index 'ustring-set!)) + (error:bad-range-argument index 'string-set!)) (%full-string-set! string index char)) ((slice? string) (let ((string* (slice-string string)) @@ -194,12 +194,12 @@ USA. (legacy-string-set! string* index* char) (%full-string-set! string* index* char)))) (else - (error:not-a ustring? string 'ustring-set!)))) + (error:not-a string? string 'string-set!)))) -(define (ustring-slice string #!optional start end) - (let* ((len (ustring-length string)) - (end (fix:end-index end len 'ustring-slice)) - (start (fix:start-index start end 'ustring-slice))) +(define (string-slice string #!optional start end) + (let* ((len (string-length string)) + (end (fix:end-index end len 'string-slice)) + (start (fix:start-index start end 'string-slice))) (cond ((and (fix:= start 0) (fix:= end len)) string) ((slice? string) @@ -211,12 +211,12 @@ USA. start (fix:- end start)))))) -(define (ustring-copy! to at from #!optional start end) - (let* ((end (fix:end-index end (ustring-length from) 'ustring-copy!)) - (start (fix:start-index start end 'ustring-copy!))) - (guarantee index-fixnum? at 'ustring-copy!) - (if (not (fix:<= (fix:+ at (fix:- end start)) (ustring-length to))) - (error:bad-range-argument to 'ustring-copy!)) +(define (string-copy! to at from #!optional start end) + (let* ((end (fix:end-index end (string-length from) 'string-copy!)) + (start (fix:start-index start end 'string-copy!))) + (guarantee index-fixnum? at 'string-copy!) + (if (not (fix:<= (fix:+ at (fix:- end start)) (string-length to))) + (error:bad-range-argument to 'string-copy!)) (receive (to at) (if (slice? to) (values (slice-string to) @@ -238,9 +238,9 @@ USA. (cp-vector-copy! (%full-string-cp-vector to) at (%full-string-cp-vector from) start end)) -(define (ustring-copy string #!optional start end) - (let* ((end (fix:end-index end (ustring-length string) 'ustring-copy)) - (start (fix:start-index start end 'ustring-copy))) +(define (string-copy string #!optional start end) + (let* ((end (fix:end-index end (string-length string) 'string-copy)) + (start (fix:start-index start end 'string-copy))) (receive (string start end) (translate-slice string start end) (cond ((legacy-string? string) (let ((to (legacy-string-allocate (fix:- end start)))) @@ -257,43 +257,43 @@ USA. (%full-string-copy! to 0 string start end) to)))))) -(define (ustring-head string end) - (ustring-copy string 0 end)) +(define (string-head string end) + (string-copy string 0 end)) -(define (ustring-tail string start) - (ustring-copy string start)) +(define (string-tail string start) + (string-copy string start)) ;; Non-Unicode implementation, acceptable to R7RS. (define-integrable (%string-comparison-maker c= c< f<) (lambda (string1 string2) - (let ((end1 (ustring-length string1)) - (end2 (ustring-length string2))) + (let ((end1 (string-length string1)) + (end2 (string-length string2))) (let ((end (fix:min end1 end2))) (let loop ((i 0)) (if (fix:< i end) - (let ((c1 (ustring-ref string1 i)) - (c2 (ustring-ref string2 i))) + (let ((c1 (string-ref string1 i)) + (c2 (string-ref string2 i))) (if (c= c1 c2) (loop (fix:+ i 1)) (c< c1 c2))) (f< end1 end2))))))) -(define %ustring? (%string-comparison-maker char=? char>? fix:>)) -(define %ustring>=? (%string-comparison-maker char=? char>=? fix:<=)) +(define %string? (%string-comparison-maker char=? char>? fix:>)) +(define %string>=? (%string-comparison-maker char=? char>=? fix:<=)) (define-integrable (%string-ci-comparison-maker string-compare) (lambda (string1 string2) - (string-compare (ustring-foldcase string1) - (ustring-foldcase string2)))) + (string-compare (string-foldcase string1) + (string-foldcase string2)))) -(define %ustring-ci? (%string-ci-comparison-maker %ustring>?)) -(define %ustring-ci>=? (%string-ci-comparison-maker %ustring>=?)) +(define %string-ci? (%string-ci-comparison-maker %string>?)) +(define %string-ci>=? (%string-ci-comparison-maker %string>=?)) (define-integrable (string-comparison-maker %compare) (lambda (string1 string2 . strings) @@ -303,59 +303,60 @@ USA. (loop string2 (car strings) (cdr strings))) (%compare string1 string2))))) -(define ustring=? (string-comparison-maker %ustring=?)) -(define ustring? (string-comparison-maker %ustring>?)) -(define ustring>=? (string-comparison-maker %ustring>=?)) - -(define ustring-ci=? (string-comparison-maker %ustring-ci=?)) -(define ustring-ci? (string-comparison-maker %ustring-ci>?)) -(define ustring-ci>=? (string-comparison-maker %ustring-ci>=?)) +(define string=? (string-comparison-maker %string=?)) +(define string? (string-comparison-maker %string>?)) +(define string>=? (string-comparison-maker %string>=?)) + +(define string-ci=? (string-comparison-maker %string-ci=?)) +(define string-ci? (string-comparison-maker %string-ci>?)) +(define string-ci>=? (string-comparison-maker %string-ci>=?)) (define-integrable (prefix-maker c= caller) (lambda (prefix string #!optional start end) - (let* ((end (fix:end-index end (ustring-length string) caller)) + (let* ((end (fix:end-index end (string-length string) caller)) (start (fix:start-index start end caller)) - (n (ustring-length prefix))) + (n (string-length prefix))) (and (fix:<= n (fix:- end start)) (let loop ((i 0) (j start)) (if (fix:< i n) - (and (c= (ustring-ref prefix i) (ustring-ref string j)) + (and (c= (string-ref prefix i) (string-ref string j)) (loop (fix:+ i 1) (fix:+ j 1))) #t)))))) (define-integrable (suffix-maker c= caller) (lambda (suffix string #!optional start end) - (let* ((end (fix:end-index end (ustring-length string) caller)) + (let* ((end (fix:end-index end (string-length string) caller)) (start (fix:start-index start end caller)) - (n (ustring-length suffix))) + (n (string-length suffix))) (and (fix:<= n (fix:- end start)) (let loop ((i 0) (j (fix:- end n))) (if (fix:< i n) - (and (c= (ustring-ref suffix i) (ustring-ref string j)) + (and (c= (string-ref suffix i) (string-ref string j)) (loop (fix:+ i 1) (fix:+ j 1))) #t)))))) -(define ustring-prefix? (prefix-maker eq? 'ustring-prefix?)) -(define ustring-suffix? (suffix-maker eq? 'ustring-suffix?)) +(define string-prefix? (prefix-maker eq? 'string-prefix?)) +(define string-suffix? (suffix-maker eq? 'string-suffix?)) -(define ustring-prefix-ci? (prefix-maker char-ci=? 'ustring-prefix-ci?)) -(define ustring-suffix-ci? (suffix-maker char-ci=? 'ustring-suffix-ci?)) +;;; Incorrect implementation: should do string-foldcase on both args. +(define string-prefix-ci? (prefix-maker char-ci=? 'string-prefix-ci?)) +(define string-suffix-ci? (suffix-maker char-ci=? 'string-suffix-ci?)) -(define (ustring-downcase string) +(define (string-downcase string) (case-transform char-downcase-full string)) -(define (ustring-foldcase string) +(define (string-foldcase string) (case-transform char-foldcase-full string)) -(define (ustring-upcase string) +(define (string-upcase string) (case-transform char-upcase-full string)) (define (case-transform transform string) - (let ((chars (append-map transform (ustring->list string)))) + (let ((chars (append-map transform (string->list string)))) (let ((n (length chars))) (let ((result (if (every char-8-bit? chars) @@ -364,37 +365,37 @@ USA. (do ((chars chars (cdr chars)) (i 0 (fix:+ i 1))) ((not (pair? chars))) - (ustring-set! result i (car chars))) + (string-set! result i (car chars))) result)))) -(define (ustring-lower-case? string) - (let* ((nfd (ustring->nfd string)) - (end (ustring-length nfd))) +(define (string-lower-case? string) + (let* ((nfd (string->nfd string)) + (end (string-length nfd))) (let loop ((i 0)) (if (fix:< i end) - (and (not (char-changes-when-lower-cased? (ustring-ref nfd i))) + (and (not (char-changes-when-lower-cased? (string-ref nfd i))) (loop (fix:+ i 1))) #t)))) -(define (ustring-upper-case? string) - (let* ((nfd (ustring->nfd string)) - (end (ustring-length nfd))) +(define (string-upper-case? string) + (let* ((nfd (string->nfd string)) + (end (string-length nfd))) (let loop ((i 0)) (if (fix:< i end) - (and (not (char-changes-when-upper-cased? (ustring-ref nfd i))) + (and (not (char-changes-when-upper-cased? (string-ref nfd i))) (loop (fix:+ i 1))) #t)))) -(define (ustring->nfd string) - (if (ustring-in-nfd? string) +(define (string->nfd string) + (if (string-in-nfd? string) string (canonical-ordering! (canonical-decomposition string)))) -(define (ustring-in-nfd? string) - (let ((n (ustring-length string))) +(define (string-in-nfd? string) + (let ((n (string-length string))) (let loop ((i 0) (last-ccc 0)) (if (fix:< i n) - (let* ((char (ustring-ref string i)) + (let* ((char (string-ref string i)) (ccc (ucd-ccc-value char))) (and (or (fix:= ccc 0) (fix:>= ccc last-ccc)) @@ -403,28 +404,28 @@ USA. #t)))) (define (canonical-decomposition string) - (let ((end (ustring-length string))) + (let ((end (string-length string))) (let ((result (make-ustring (do ((i 0 (fix:+ i 1)) - (j 0 (fix:+ j (length (ucd-dm-value (ustring-ref string i)))))) + (j 0 (fix:+ j (length (ucd-dm-value (string-ref string i)))))) ((not (fix:< i end)) j))))) (let loop ((i 0) (j 0)) (if (fix:< i end) (loop (fix:+ i 1) - (do ((chars (ucd-dm-value (ustring-ref string i)) + (do ((chars (ucd-dm-value (string-ref string i)) (cdr chars)) (j j (fix:+ j 1))) ((not (pair? chars)) j) - (ustring-set! result j (car chars)))))) + (string-set! result j (car chars)))))) result))) (define (canonical-ordering! string) - (let ((end (ustring-length string))) + (let ((end (string-length string))) (define (scan-for-non-starter i) (if (fix:< i end) - (let* ((char (ustring-ref string i)) + (let* ((char (string-ref string i)) (ccc (ucd-ccc-value char))) (if (fix:= 0 ccc) (scan-for-non-starter (fix:+ i 1)) @@ -433,15 +434,15 @@ USA. (define (maybe-twiddle char1 ccc1 i1) (let ((i2 (fix:+ i1 1))) (if (fix:< i2 end) - (let* ((char2 (ustring-ref string i2)) + (let* ((char2 (string-ref string i2)) (ccc2 (ucd-ccc-value char2))) (cond ((fix:= 0 ccc2) (scan-for-non-starter (fix:+ i2 1))) ((fix:<= ccc1 ccc2) (maybe-twiddle char2 ccc2 i2)) (else - (ustring-set! string i1 char2) - (ustring-set! string i2 char1) + (string-set! string i1 char2) + (string-set! string i2 char1) (maybe-twiddle char1 ccc1 i2))))))) (scan-for-non-starter 0)) @@ -449,10 +450,10 @@ USA. #| (define (quick-check string qc-value) - (let ((n (ustring-length string))) + (let ((n (string-length string))) (let loop ((i 0) (last-ccc 0) (result #t)) (if (fix:< i n) - (let* ((char (ustring-ref string i)) + (let* ((char (string-ref string i)) (ccc (ucd-ccc-value char))) (if (and (fix:> ccc 0) (fix:< ccc last-ccc)) @@ -465,7 +466,7 @@ USA. result)))) |# -(define (list->ustring chars) +(define (list->string chars) (if (every char-8-bit? chars) (let ((string (legacy-string-allocate (length chars)))) (do ((chars chars (cdr chars)) @@ -480,9 +481,9 @@ USA. (%full-string-set! string i (car chars))) string))) -(define (ustring->list string #!optional start end) - (let* ((end (fix:end-index end (ustring-length string) 'ustring->list)) - (start (fix:start-index start end 'ustring->list))) +(define (string->list string #!optional start end) + (let* ((end (fix:end-index end (string-length string) 'string->list)) + (start (fix:start-index start end 'string->list))) (receive (string start end) (translate-slice string start end) (if (legacy-string? string) (do ((i (fix:- end 1) (fix:- i 1)) @@ -492,22 +493,22 @@ USA. (chars '() (cons (%full-string-ref string i) chars))) ((not (fix:>= i start)) chars)))))) -(define (vector->ustring vector #!optional start end) - (let* ((end (fix:end-index end (vector-length string) 'vector->ustring)) - (start (fix:start-index start end 'vector->ustring)) +(define (vector->string vector #!optional start end) + (let* ((end (fix:end-index end (vector-length string) 'vector->string)) + (start (fix:start-index start end 'vector->string)) (to (if (do ((i start (fix:+ i 1)) (8-bit? #t (and 8-bit? (char-8-bit? (vector-ref vector i))))) ((not (fix:< start end)) 8-bit?)) (legacy-string-allocate (fix:- end start)) (full-string-allocate (fix:- end start))))) - (copy-loop ustring-set! to 0 + (copy-loop string-set! to 0 vector-ref vector start end) to)) -(define (ustring->vector string #!optional start end) - (let* ((end (fix:end-index end (ustring-length string) 'ustring->vector)) - (start (fix:start-index start end 'ustring->vector))) +(define (string->vector string #!optional start end) + (let* ((end (fix:end-index end (string-length string) 'string->vector)) + (start (fix:start-index start end 'string->vector))) (receive (string start end) (translate-slice string start end) (if (legacy-string? string) (let ((to (make-vector (fix:- end start)))) @@ -519,56 +520,62 @@ USA. %full-string-ref string start end) to))))) -(define (ustring-append . strings) - (%ustring-append* strings)) +(define (string-append . strings) + (%string-append* strings)) -(define (ustring-append* strings) - (guarantee list? strings 'ustring-append*) - (%ustring-append* strings)) +(define (string-append* strings) + (guarantee list? strings 'string-append*) + (%string-append* strings)) -(define (%ustring-append* strings) +(define (%string-append* strings) (let ((string (do ((strings strings (cdr strings)) - (n 0 (fix:+ n (ustring-length (car strings)))) - (8-bit? #t (and 8-bit? (ustring-8-bit? (car strings))))) + (n 0 (fix:+ n (string-length (car strings)))) + (8-bit? #t (and 8-bit? (string-8-bit? (car strings))))) ((not (pair? strings)) (if 8-bit? (legacy-string-allocate n) (full-string-allocate n)))))) (let loop ((strings strings) (i 0)) (if (pair? strings) - (let ((n (ustring-length (car strings)))) - (ustring-copy! string i (car strings) 0 n) + (let ((n (string-length (car strings)))) + (string-copy! string i (car strings) 0 n) (loop (cdr strings) (fix:+ i n))))) string)) -(define (ustring . objects) - (%ustring* objects 'ustring)) +(define (string . objects) + (%string* objects 'string)) -(define (ustring* objects) - (guarantee list? objects 'ustring*) - (%ustring* objects 'ustring*)) +(define (string* objects) + (guarantee list? objects 'string*) + (%string* objects 'string*)) -(define (%ustring* objects caller) - (%ustring-append* +(define (%string* objects caller) + (%string-append* (map (lambda (object) - (->ustring object caller)) + (->string object caller)) objects))) -(define (->ustring object caller) +(define (->string object caller) (cond ((not object) "") - ((bitless-char? object) (make-ustring 1 object)) - ((ustring? object) object) + ((bitless-char? object) + (let ((s + (if (char-8-bit? object) + (legacy-string-allocate 1) + (full-string-allocate 1)))) + (string-set! s 0 object) + s)) + ((string? object) object) ((symbol? object) (symbol->string object)) ((pathname? object) (->namestring object)) ((number? object) (number->string object)) ((uri? object) (uri->string object)) - (else (error:not-a ->ustring-component? object caller)))) + (else (error:not-a ->string-component? object caller)))) -(define (->ustring-component? object) +(define (->string-component? object) (cond (not object) (bitless-char? object) - (ustring? object) + (string? object) (symbol? object) (pathname? object) (number? object) @@ -576,25 +583,25 @@ USA. (define (mapper-values proc string strings) (cond ((null? strings) - (values (ustring-length string) + (values (string-length string) (lambda (i) - (proc (ustring-ref string i))))) + (proc (string-ref string i))))) ((null? (cdr strings)) (let* ((string2 (car strings)) - (n (fix:min (ustring-length string) - (ustring-length string2)))) + (n (fix:min (string-length string) + (string-length string2)))) (values n (lambda (i) - (proc (ustring-ref string i) - (ustring-ref string2 i)))))) + (proc (string-ref string i) + (string-ref string2 i)))))) (else - (let ((n (min-length ustring-length string strings))) + (let ((n (min-length string-length string strings))) (values n (lambda (i) (apply proc - (ustring-ref string i) + (string-ref string i) (map (lambda (string) - (ustring-ref string i)) + (string-ref string i)) strings)))))))) (define (min-length string-length string strings) @@ -603,13 +610,13 @@ USA. (fix:min n (string-length (car strings))))) ((null? strings) n))) -(define (ustring-for-each proc string . strings) +(define (string-for-each proc string . strings) (receive (n proc) (mapper-values proc string strings) (do ((i 0 (fix:+ i 1))) ((not (fix:< i n))) (proc i)))) -(define (ustring-map proc string . strings) +(define (string-map proc string . strings) (receive (n proc) (mapper-values proc string strings) (let ((result (full-string-allocate n))) (do ((i 0 (fix:+ i 1))) @@ -617,7 +624,7 @@ USA. (%full-string-set! result i (proc i))) result))) -(define (ustring-count proc string . strings) +(define (string-count proc string . strings) (receive (n proc) (mapper-values proc string strings) (let loop ((i 0) (count 0)) (if (fix:< i n) @@ -627,7 +634,7 @@ USA. count)) count)))) -(define (ustring-any proc string . strings) +(define (string-any proc string . strings) (receive (n proc) (mapper-values proc string strings) (let loop ((i 0)) (and (fix:< i n) @@ -635,7 +642,7 @@ USA. #t (loop (fix:+ i 1))))))) -(define (ustring-every proc string . strings) +(define (string-every proc string . strings) (receive (n proc) (mapper-values proc string strings) (let loop ((i 0)) (if (fix:< i n) @@ -643,7 +650,7 @@ USA. (loop (fix:+ i 1))) #t)))) -(define (ustring-find-first-index proc string . strings) +(define (string-find-first-index proc string . strings) (receive (n proc) (mapper-values proc string strings) (let loop ((i 0)) (and (fix:< i n) @@ -651,7 +658,7 @@ USA. i (loop (fix:+ i 1))))))) -(define (ustring-find-last-index proc string . strings) +(define (string-find-last-index proc string . strings) (receive (n proc) (mapper-values proc string strings) (let loop ((i (fix:- n 1))) (and (fix:>= i 0) @@ -659,41 +666,10 @@ USA. i (loop (fix:- i 1))))))) -(define (ustring-find-first-char string char #!optional start end) - (translate-index (let ((predicate (char=-predicate char))) - (lambda (string) - (ustring-find-first-index predicate string))) - string start end 'ustring-find-first-char)) - -(define (ustring-find-last-char string char #!optional start end) - (translate-index (let ((predicate (char=-predicate char))) - (lambda (string) - (ustring-find-last-index predicate string))) - string start end 'ustring-find-last-char)) - -(define (ustring-find-first-char-in-set string char-set #!optional start end) - (translate-index (let ((predicate (char-set-predicate char-set))) - (lambda (string) - (ustring-find-first-index predicate string))) - string start end 'ustring-find-first-char-in-set)) - -(define (ustring-find-last-char-in-set string char-set #!optional start end) - (translate-index (let ((predicate (char-set-predicate char-set))) - (lambda (string) - (ustring-find-last-index predicate string))) - string start end 'ustring-find-last-char-in-set)) - -(define (translate-index proc string start end caller) - (let* ((end (fix:end-index end (ustring-length string) caller)) - (start (fix:start-index start end caller)) - (index (proc (ustring-slice string start end)))) - (and index - (fix:+ start index)))) - -(define (ustring-fill! string char #!optional start end) - (guarantee bitless-char? char 'ustring-fill!) - (let* ((end (fix:end-index end (ustring-length string) 'ustring-fill!)) - (start (fix:start-index start end 'ustring-fill!))) +(define (string-fill! string char #!optional start end) + (guarantee bitless-char? char 'string-fill!) + (let* ((end (fix:end-index end (string-length string) 'string-fill!)) + (start (fix:start-index start end 'string-fill!))) (receive (string start end) (translate-slice string start end) (if (legacy-string? string) (do ((index start (fix:+ index 1))) @@ -705,23 +681,23 @@ USA. ((not (fix:< i end))) (cp-vector-set! bytes i cp))))))) -(define (ustring-hash string #!optional modulus) +(define (string-hash string #!optional modulus) (let ((string* (string-for-primitive string))) (if (default-object? modulus) ((ucode-primitive string-hash) string*) ((ucode-primitive string-hash-mod) string* modulus)))) -(define (ustring-ci-hash string #!optional modulus) - (ustring-hash (ustring-foldcase string) modulus)) - +(define (string-ci-hash string #!optional modulus) + (string-hash (string-foldcase string) modulus)) + (define (ustring->legacy-string string) (if (legacy-string? string) string - (and (ustring-8-bit? string) - (ustring-copy string)))) + (and (string-8-bit? string) + (string-copy string)))) -(define (ustring-8-bit? string) - (receive (string start end) (translate-slice string 0 (ustring-length string)) +(define (string-8-bit? string) + (receive (string start end) (translate-slice string 0 (string-length string)) (if (legacy-string? string) #t (%full-string-8-bit? string start end)))) @@ -744,7 +720,7 @@ USA. to) (string->utf8 string)))) (else - (error:not-a ustring? string 'ustring-ascii?)))) + (error:not-a string? string 'string-for-primitive)))) (define (legacy-string-downcase string) (let ((end (legacy-string-length string))) @@ -766,4 +742,94 @@ USA. (if (fix:< i end) (and (proc (ref string i)) (loop (fix:+ i 1))) - #t))) \ No newline at end of file + #t))) + +(define (string-find-next-char string char) + (string-find-first-index (char=-predicate char) string)) + +(define (string-find-next-char-ci string char) + (string-find-first-index (char-ci=-predicate char) string)) + +(define (string-find-next-char-in-set string char-set) + (string-find-first-index (char-set-predicate char-set) string)) + +(define (string-find-previous-char string char) + (string-find-last-index (char=-predicate char) string)) + +(define (string-find-previous-char-ci string char) + (string-find-last-index (char-ci=-predicate char) string)) + +(define (string-find-previous-char-in-set string char-set) + (string-find-last-index (char-set-predicate char-set) string)) + +(define-integrable (substring-find-maker string-find) + (lambda (string start end key) + (let* ((slice (string-slice string start end)) + (index (string-find slice key))) + (and index + (fix:+ start index))))) + +(define substring-find-next-char + (substring-find-maker string-find-next-char)) + +(define substring-find-next-char-ci + (substring-find-maker string-find-next-char-ci)) + +(define substring-find-next-char-in-set + (substring-find-maker string-find-next-char-in-set)) + +(define substring-find-previous-char + (substring-find-maker string-find-previous-char)) + +(define substring-find-previous-char-ci + (substring-find-maker string-find-previous-char-ci)) + +(define substring-find-previous-char-in-set + (substring-find-maker string-find-previous-char-in-set)) + +(define (string-move! string1 string2 start2) + (string-copy! string2 start2 string1)) + +(define (substring-move! string1 start1 end1 string2 start2) + (string-copy! string2 start2 string1 start1 end1)) + +(define (substring-ciCHAR-SYNTAX STRING->SYNTAX-ENTRY) - (STRING-ALLOCATE STRING-ALLOCATE) - (STRING-LENGTH STRING-LENGTH) - (STRING-REF STRING-REF) - (STRING-SET! STRING-SET!) - (STRING? STRING?) (SYSTEM-HUNK3-CXR0 SYSTEM-HUNK3-CXR0) (SYSTEM-HUNK3-CXR1 SYSTEM-HUNK3-CXR1) (SYSTEM-HUNK3-CXR2 SYSTEM-HUNK3-CXR2) @@ -214,8 +207,6 @@ USA. (SYSTEM-VECTOR? SYSTEM-VECTOR?) (UNSIGNED-INTEGER->BIT-STRING UNSIGNED-INTEGER->BIT-STRING) (VECTOR VECTOR) - (VECTOR-8B-REF VECTOR-8B-REF) - (VECTOR-8B-SET! VECTOR-8B-SET!) (VECTOR-LENGTH VECTOR-LENGTH) (VECTOR-REF VECTOR-REF) (VECTOR-SET! VECTOR-SET!) diff --git a/src/xml/parser-macro.scm b/src/xml/parser-macro.scm index ba201b9b9..c28d1d9e6 100644 --- a/src/xml/parser-macro.scm +++ b/src/xml/parser-macro.scm @@ -47,7 +47,7 @@ USA. ,v ,(if (string? description) (string-append "Malformed " description) - `(USTRING-APPEND "Malformed " ,description)))))))))) + `(STRING-APPEND "Malformed " ,description)))))))))) (define-*parser-macro (sbracket description open close . body) `(BRACKET ,description (NOISE (STRING ,open)) (NOISE (STRING ,close)) diff --git a/src/xml/rdf-struct.scm b/src/xml/rdf-struct.scm index 4bf1745e8..da4db7868 100644 --- a/src/xml/rdf-struct.scm +++ b/src/xml/rdf-struct.scm @@ -96,7 +96,7 @@ USA. (define (canonicalize-rdf-object object #!optional caller) (cond ((rdf-literal? object) object) - ((ustring? object) (make-rdf-literal object #f)) + ((string? object) (make-rdf-literal object #f)) (else (canonicalize-rdf-subject object caller)))) (define (canonicalize-rdf-uri uri #!optional caller) @@ -161,15 +161,15 @@ USA. (if (default-object? name) (%make-rdf-bnode) (begin - (guarantee ustring? name 'MAKE-RDF-BNODE) + (guarantee string? name 'MAKE-RDF-BNODE) (hash-table/intern! *rdf-bnode-registry* name %make-rdf-bnode)))) (define (rdf-bnode-name bnode) - (ustring-append "B" (number->string (hash bnode)))) + (string-append "B" (number->string (hash bnode)))) (define (%decode-bnode-uri uri) (let ((v - (cond ((ustring? uri) (*parse-string parse-bnode uri)) + (cond ((string? uri) (*parse-string parse-bnode uri)) ((symbol? uri) (*parse-symbol parse-bnode uri)) (else #f)))) (and v @@ -202,7 +202,7 @@ USA. (define-guarantee rdf-literal "RDF literal") (define (make-rdf-literal text type) - (guarantee ustring? text 'MAKE-RDF-LITERAL) + (guarantee string? text 'MAKE-RDF-LITERAL) (let ((type (if (or (not type) (language? type)) @@ -268,7 +268,7 @@ USA. (define (%register-rdf-prefix prefix expansion registry) (let ((p (assq prefix (registry-bindings registry)))) (if p - (if (not (ustring=? (cdr p) expansion)) + (if (not (string=? (cdr p) expansion)) (begin (warn "RDF prefix override:" prefix (cdr p) expansion) (set-cdr! p expansion))) @@ -291,7 +291,7 @@ USA. (let ((alist (registry-bindings (check-registry registry 'URI->RDF-PREFIX))) - (filter (lambda (p) (ustring-prefix? (cdr p) s)))) + (filter (lambda (p) (string-prefix? (cdr p) s)))) (or (find-matching-item alist (lambda (p) (and (not (eq? (car p) ':)) @@ -308,21 +308,21 @@ USA. (receive (prefix expansion) (uri->rdf-prefix uri registry error?) (and prefix (symbol prefix - (ustring-tail (uri->string uri) - (ustring-length expansion))))))) + (string-tail (uri->string uri) + (string-length expansion))))))) (define (rdf-qname->uri qname #!optional registry error?) (receive (prefix local) (split-rdf-qname qname) (let ((expansion (rdf-prefix-expansion prefix registry))) (if expansion - (->absolute-uri (ustring-append expansion local) 'RDF-QNAME->URI) + (->absolute-uri (string-append expansion local) 'RDF-QNAME->URI) (begin (if error? (error:bad-range-argument qname 'RDF-QNAME->URI)) #f))))) (define (make-rdf-qname prefix local) (guarantee-rdf-prefix prefix 'MAKE-RDF-QNAME) - (guarantee ustring? local 'MAKE-RDF-QNAME) + (guarantee string? local 'MAKE-RDF-QNAME) (if (not (*match-string match:name local)) (error:bad-range-argument local 'MAKE-RDF-QNAME)) (symbol prefix local)) @@ -330,19 +330,19 @@ USA. (define (rdf-qname-prefix qname) (guarantee-rdf-qname qname 'RDF-QNAME-PREFIX) (let ((s (symbol-name qname))) - (symbol (ustring-head s (fix:+ (ustring-find-first-char s #\:) 1))))) + (symbol (string-head s (fix:+ (string-find-next-char s #\:) 1))))) (define (rdf-qname-local qname) (guarantee-rdf-qname qname 'RDF-QNAME-LOCAL) (let ((s (symbol-name qname))) - (ustring-tail s (fix:+ (ustring-find-first-char s #\:) 1)))) + (string-tail s (fix:+ (string-find-next-char s #\:) 1)))) (define (split-rdf-qname qname) (guarantee-rdf-qname qname 'SPLIT-RDF-QNAME) (let ((s (symbol-name qname))) - (let ((i (fix:+ (ustring-find-first-char s #\:) 1))) - (values (symbol (ustring-head s i)) - (ustring-tail s i))))) + (let ((i (fix:+ (string-find-next-char s #\:) 1))) + (values (symbol (string-head s i)) + (string-tail s i))))) (define (rdf-qname? object) (and (interned-symbol? object) diff --git a/src/xml/turtle.scm b/src/xml/turtle.scm index 58bfcc79a..eadac3dab 100644 --- a/src/xml/turtle.scm +++ b/src/xml/turtle.scm @@ -211,15 +211,15 @@ USA. (*parser (map (lambda (s) (make-rdf-literal - (if (char=? (ustring-ref s 0) #\-) + (if (char=? (string-ref s 0) #\-) s - (let ((end (ustring-length s))) - (let loop ((i (if (char=? (ustring-ref s 0) #\+) 1 0))) - (if (and (fix:< i end) (char=? (ustring-ref s i) #\0)) + (let ((end (string-length s))) + (let loop ((i (if (char=? (string-ref s 0) #\+) 1 0))) + (if (and (fix:< i end) (char=? (string-ref s i) #\0)) (loop (fix:+ i 1)) (if (fix:= i 0) s - (ustring-tail s i)))))) + (string-tail s i)))))) xsd:integer)) (match (seq (? (alt "-" "+")) (+ (char-set char-set:turtle-digit))))))) @@ -360,7 +360,7 @@ USA. (parser-buffer-error p (emsg "Malformed string escape"))))) (define (emsg msg) - (ustring-append msg " in " name)) + (string-append msg " in " name)) (define (copy p) (call-with-parser-buffer-tail buffer p @@ -550,12 +550,12 @@ USA. (define (post-process-qname prefix local prefixes) (string->uri - (ustring-append (cdr - (or (find (lambda (p) - (ustring=? (car p) prefix)) - prefixes) - (error "Unknown prefix:" prefix))) - (or local "")))) + (string-append (cdr + (or (find (lambda (p) + (string=? (car p) prefix)) + prefixes) + (error "Unknown prefix:" prefix))) + (or local "")))) (define (post-process-collection resources prefixes base-uri) (if (pair? resources) @@ -614,9 +614,9 @@ USA. (lambda (a b) (let ((a (symbol-name (car a))) (b (symbol-name (car b)))) - (ustring (lambda (elt) - (ustring-append "(" elt ")"))) + (string-append "(" elt ")"))) (else #f)))) ((rdf-bnode? o) (and (not (inline-bnode o)) @@ -816,7 +816,7 @@ USA. (define (write-object o indentation inline-bnode port) (cond ((linear-object-string o inline-bnode port) => (lambda (s) - (maybe-break (ustring-length s) indentation port) + (maybe-break (string-length s) indentation port) (write-string s port))) ((rdf-graph? o) (space port) @@ -912,7 +912,7 @@ USA. (write-symbol lang port)))))))) (define (write-literal-text text port) - (if (ustring-find-first-char text #\newline) + (if (string-find-next-char text #\newline) (let ((tport (open-input-string text))) (write-string "\"\"\"" port) (let loop () @@ -932,10 +932,10 @@ USA. (define (write-uri uri registry port) (let* ((s (uri->string uri)) - (end (ustring-length s))) + (end (string-length s))) (receive (prefix expansion) (uri->rdf-prefix uri registry #f) (if prefix - (let ((start (ustring-length expansion))) + (let ((start (string-length expansion))) (if (*match-string match:name s start end) (begin (write-string (symbol-name prefix) port) @@ -977,10 +977,10 @@ USA. (reverse! groups)))) (define (uristring a) (uri->string b))) + (stringstring a) (uri->string b))) (define (rdf-bnodelist node inline-bnode) (let loop ((node node)) diff --git a/src/xml/xhtml-entities.scm b/src/xml/xhtml-entities.scm index 6e1b2b41f..1abaff9b4 100644 --- a/src/xml/xhtml-entities.scm +++ b/src/xml/xhtml-entities.scm @@ -283,9 +283,9 @@ USA. (map (lambda (b) (make-xml-!entity (car b) - (list (ustring-append "&#x" - (number->string (char->integer (cadr b)) 16) - ";")))) + (list (string-append "&#x" + (number->string (char->integer (cadr b)) 16) + ";")))) html-entity-alist)) (define html-char->name-map diff --git a/src/xml/xhtml.scm b/src/xml/xhtml.scm index fc86a84b5..96e01e42b 100644 --- a/src/xml/xhtml.scm +++ b/src/xml/xhtml.scm @@ -81,8 +81,8 @@ USA. "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd") (define (html-public-id? id) - (and (ustring? id) - (ustring-prefix? "-//W3C//DTD XHTML " id))) + (and (string? id) + (string-prefix? "-//W3C//DTD XHTML " id))) (define (html-external-id? object) (and (xml-external-id? object) @@ -263,7 +263,7 @@ USA. contents)) (define (html:id-ref tag . contents) - (apply html:href (ustring-append "#" tag) contents)) + (apply html:href (string-append "#" tag) contents)) (define (html:rel-link rel uri) (html:link 'rel rel @@ -282,10 +282,10 @@ USA. (guarantee-keyword-list keyword-list 'HTML:STYLE-ATTR) (if (pair? keyword-list) (let loop ((bindings keyword-list)) - (ustring-append (symbol-name (car bindings)) - ": " - (cadr bindings) - (if (pair? (cddr bindings)) - (ustring-append "; " (loop (cddr bindings))) - ";"))) + (string-append (symbol-name (car bindings)) + ": " + (cadr bindings) + (if (pair? (cddr bindings)) + (string-append "; " (loop (cddr bindings))) + ";"))) "")) \ No newline at end of file diff --git a/src/xml/xml-names.scm b/src/xml/xml-names.scm index 8c83137fe..5e57c9070 100644 --- a/src/xml/xml-names.scm +++ b/src/xml/xml-names.scm @@ -138,7 +138,7 @@ USA. (define (name-constructor string-predicate constructor) (lambda (object) - (if (ustring? object) + (if (string? object) (begin (if (not (string-predicate object)) (error:bad-range-argument object constructor)) @@ -231,9 +231,9 @@ USA. (define (%xml-qname-prefix qname) (let ((s (symbol-name qname))) - (let ((c (ustring-find-first-char s #\:))) + (let ((c (string-find-next-char s #\:))) (if c - (string->symbol (ustring-head s c)) + (string->symbol (string-head s c)) (null-xml-name-prefix))))) (define (xml-qname-local qname) @@ -242,7 +242,7 @@ USA. (define (%xml-qname-local qname) (let ((s (symbol-name qname))) - (let ((c (ustring-find-first-char s #\:))) + (let ((c (string-find-next-char s #\:))) (if c - (string->symbol (ustring-tail s (fix:+ c 1))) + (string->symbol (string-tail s (fix:+ c 1))) qname)))) \ No newline at end of file diff --git a/src/xml/xml-output.scm b/src/xml/xml-output.scm index 19b50f243..f1c0b1fbd 100644 --- a/src/xml/xml-output.scm +++ b/src/xml/xml-output.scm @@ -86,9 +86,9 @@ USA. (define (emit-string string ctx) (let ((port (ctx-port ctx))) - (ustring-for-each (lambda (char) - (write-char char port)) - string))) + (string-for-each (lambda (char) + (write-char char port)) + string))) (define (emit-newline ctx) (newline (ctx-port ctx))) @@ -161,10 +161,10 @@ USA. (emit-string " (ustring-length text) 0) + (if (fix:> (string-length text) 0) (begin (if (not (char-set-member? char-set:xml-whitespace - (ustring-ref text 0))) + (string-ref text 0))) (emit-string " " ctx)) (emit-string text ctx)))) (emit-string "?>" ctx)) @@ -196,7 +196,7 @@ USA. (emit-string " " ctx) (let ((type (xml-!element-content-type decl))) (cond ((symbol? type) - (emit-string (ustring-upcase (symbol-name type)) ctx)) + (emit-string (string-upcase (symbol-name type)) ctx)) ((and (pair? type) (eq? (car type) '|#PCDATA|)) (emit-string "(#PCDATA" ctx) (if (pair? (cdr type)) @@ -258,7 +258,7 @@ USA. (emit-string " " ctx) (let ((type (cadr definition))) (cond ((symbol? type) - (emit-string (ustring-upcase (symbol-name type)) ctx)) + (emit-string (string-upcase (symbol-name type)) ctx)) ((and (pair? type) (eq? (car type) '|NOTATION|)) (emit-string "NOTATION (" ctx) (if (pair? (cdr type)) @@ -409,23 +409,23 @@ USA. (define (xml-string-columns string) (let ((n 0)) - (ustring-for-each (lambda (char) - (set! n - (fix:+ n - (case char - ((#\") 6) - ((#\<) 4) - ((#\&) 5) - (else 1)))) - unspecific) - string) + (string-for-each (lambda (char) + (set! n + (fix:+ n + (case char + ((#\") 6) + ((#\<) 4) + ((#\&) 5) + (else 1)))) + unspecific) + string) n)) (define (write-xml-name name ctx) (emit-string (xml-name-string name) ctx)) (define (xml-name-columns name) - (ustring-length (xml-name-string name))) + (string-length (xml-name-string name))) (define (write-xml-nmtoken nmtoken ctx) (emit-string (symbol-name nmtoken) ctx)) @@ -437,7 +437,7 @@ USA. (emit-char #\" ctx) (for-each (lambda (item) - (if (ustring? item) + (if (string? item) (write-escaped-string item '((#\" . """) (#\& . "&") @@ -482,15 +482,15 @@ USA. (emit-char #\space ctx))) (define (write-escaped-string string escapes ctx) - (ustring-for-each (lambda (char) - (cond ((assq char escapes) - => (lambda (e) - (emit-string (cdr e) ctx))) - (((ctx-char-map ctx) char) - => (lambda (name) - (emit-char #\& ctx) - (emit-string (symbol-name name) ctx) - (emit-char #\; ctx))) - (else - (emit-char char ctx)))) - string)) \ No newline at end of file + (string-for-each (lambda (char) + (cond ((assq char escapes) + => (lambda (e) + (emit-string (cdr e) ctx))) + (((ctx-char-map ctx) char) + => (lambda (name) + (emit-char #\& ctx) + (emit-string (symbol-name name) ctx) + (emit-char #\; ctx))) + (else + (emit-char char ctx)))) + string)) \ No newline at end of file diff --git a/src/xml/xml-parser.scm b/src/xml/xml-parser.scm index ab2fb39ad..b92d92fec 100644 --- a/src/xml/xml-parser.scm +++ b/src/xml/xml-parser.scm @@ -36,19 +36,19 @@ USA. (define (perror ptr msg . irritants) (apply error - (ustring-append msg - (if ptr - (ustring-append - " at " - (parser-buffer-position-string - ;; **** This isn't quite right. **** - (if (pair? *entity-expansion-nesting*) - (cdar (last-pair *entity-expansion-nesting*)) - ptr))) - "") - (if (pair? irritants) - ":" - ".")) + (string-append msg + (if ptr + (string-append + " at " + (parser-buffer-position-string + ;; **** This isn't quite right. **** + (if (pair? *entity-expansion-nesting*) + (cdar (last-pair *entity-expansion-nesting*)) + ptr))) + "") + (if (pair? irritants) + ":" + ".")) irritants)) (define (coalesce-elements v) @@ -57,13 +57,13 @@ USA. (define (coalesce-strings! elements) (do ((elements elements (cdr elements))) ((not (pair? elements))) - (if (ustring? (car elements)) + (if (string? (car elements)) (do () ((not (and (pair? (cdr elements)) - (ustring? (cadr elements))))) + (string? (cadr elements))))) (set-car! elements - (ustring-append (car elements) - (cadr elements))) + (string-append (car elements) + (cadr elements))) (set-cdr! elements (cddr elements))))) elements) @@ -129,7 +129,7 @@ USA. (char->integer c)))) (prefix (lambda (n) - (ustring (integer->char n)))) + (string (integer->char n)))) (lose (lambda bytes (error "Illegal starting bytes:" bytes)))) @@ -293,7 +293,7 @@ USA. (if (and version (not (*match-string match-xml-version version))) (perror p "Malformed XML version" version)) - (if (and version (not (ustring=? version "1.0"))) + (if (and version (not (string=? version "1.0"))) (perror p "Unsupported XML version" version)) (if (not (if encoding (*match-string match-encoding encoding) @@ -354,7 +354,7 @@ USA. (vector (let ((name (vector-ref v 0))) (make-xml-element name (vector-ref v 1) - (if (ustring=? (vector-ref v 2) ">") + (if (string=? (vector-ref v 2) ">") (parse-element-content b p name) '())))))))))) @@ -447,7 +447,7 @@ USA. (let ((av (xml-attribute-value attr))) (if (and (pair? default) (eq? (car default) '|#FIXED|) - (not (ustring=? av (cdr default)))) + (not (string=? av (cdr default)))) (perror (cdar attr) "Incorrect attribute value" name)) (if (not (eq? type '|CDATA|)) (set-xml-attribute-value! attr (trim-attribute-whitespace av))) @@ -497,7 +497,7 @@ USA. "]]>"))) (*parser (transform (lambda (v) - (if (fix:= 0 (ustring-length (vector-ref v 0))) + (if (fix:= 0 (string-length (vector-ref v 0))) '#() v)) parse-body)))) @@ -533,7 +533,7 @@ USA. (match match:xml-name))))) (define (simple-name-parser type) - (let ((m (ustring-append "Malformed " type " name"))) + (let ((m (string-append "Malformed " type " name"))) (*parser (require-success m (map make-xml-name (match match:xml-name)))))) (define parse-entity-name (simple-name-parser "entity")) @@ -572,10 +572,10 @@ USA. (perror p "Illegal namespace prefix" name)) (string->uri value) ;signals error if not URI (if (if (xml-name=? name 'xmlns:xml) - (not (ustring=? value xml-uri-string)) - (or (fix:= 0 (ustring-length value)) - (ustring=? value xml-uri-string) - (ustring=? value xmlns-uri-string))) + (not (string=? value xml-uri-string)) + (or (fix:= 0 (string-length value)) + (string=? value xml-uri-string) + (string=? value xmlns-uri-string))) (forbidden-uri)) (cons (cons (xml-name-local name) value) tail)) (else tail))))) @@ -628,7 +628,7 @@ USA. (lambda (v) (let ((name (vector-ref v 0)) (text (vector-ref v 1))) - (if (ustring-ci=? (symbol-name name) "xml") + (if (string-ci=? (symbol-name name) "xml") (perror p "Reserved XML processor name" name)) (let ((entry (assq name *pi-handlers*))) (if entry @@ -809,7 +809,7 @@ USA. (*parser (map (lambda (elements) (if (not (and (pair? elements) - (ustring? (car elements)) + (string? (car elements)) (null? (cdr elements)))) (error "Uncoalesced attribute value:" elements)) (normalize-attribute-value (car elements))) @@ -852,13 +852,13 @@ USA. (loop)))))))))) (define (trim-attribute-whitespace string) - (let ((end (ustring-length string))) + (let ((end (string-length string))) (call-with-output-string (lambda (port) (define (skip-spaces start pending-space?) (if (fix:< start end) - (let ((char (ustring-ref string start))) + (let ((char (string-ref string start))) (if (char-in-set? char-set:whitespace) (skip-spaces (fix:+ start 1) pending-space?) (begin @@ -868,7 +868,7 @@ USA. (define (find-next-space start) (if (fix:< start end) - (let ((char (ustring-ref string start))) + (let ((char (string-ref string start))) (if (char-in-set? char-set:whitespace) (skip-spaces (fix:+ start 1) #t) (begin @@ -878,20 +878,20 @@ USA. (skip-spaces 0 #f))))) (define (normalize-line-endings string #!optional always-copy?) - (if (ustring-find-first-char string #\return) - (let ((end (ustring-length string))) + (if (string-find-next-char string #\return) + (let ((end (string-length string))) (let ((step-over-eol (lambda (index) (fix:+ index (if (and (fix:< (fix:+ index 1) end) - (char=? (ustring-ref string (fix:+ index 1)) + (char=? (string-ref string (fix:+ index 1)) #\linefeed)) 2 1))))) (let ((n (let loop ((start 0) (n 0)) (let ((index - (ustring-find-first-char string #\return start end))) + (substring-find-next-char string start end #\return))) (if index (loop (step-over-eol index) (fix:+ n (fix:+ (fix:- index start) 1))) @@ -899,17 +899,17 @@ USA. (let ((string* (make-ustring n))) (let loop ((start 0) (start* 0)) (let ((index - (ustring-find-first-char string #\return start end))) + (substring-find-next-char string start end #\return))) (if index (let ((start* - (ustring-copy! string* start* string start index))) - (ustring-set! string* start* #\newline) + (string-copy! string* start* string start index))) + (string-set! string* start* #\newline) (loop (step-over-eol index) (fix:+ start* 1))) - (ustring-copy! string* start* string start end)))) + (string-copy! string* start* string start end)))) string*)))) (if (if (default-object? always-copy?) #f always-copy?) - (ustring-copy string) + (string-copy string) string))) ;;;; Parameter entities @@ -942,7 +942,7 @@ USA. (and entity (xml-parameter-!entity-value entity)))))) (if (and (pair? value) - (ustring? (car value)) + (string? (car value)) (null? (cdr value))) (car value) (begin @@ -973,7 +973,7 @@ USA. (if (xml-external-id? value) (perror p "Reference to external entity" name)) (if (not (and (pair? value) - (ustring? (car value)) + (string? (car value)) (null? (cdr value)))) (perror p "Reference to partially-declared entity" name)) (if in-attribute? @@ -1066,8 +1066,8 @@ USA. (transform (lambda (v) (let ((value (vector-ref v 0))) - (if (ustring? value) - (reparse-text (vector (ustring-append " " value " ")) + (if (string? value) + (reparse-text (vector (string-append " " value " ")) parse-external-subset-decl "parameter-entity value" p) @@ -1111,7 +1111,7 @@ USA. (lambda (v) (if (fix:= (vector-length v) 1) (vector-ref v 0) - (list (ustring-ref (vector-ref v 1) 0) + (list (string-ref (vector-ref v 1) 0) (vector-ref v 0)))))) (*parser @@ -1318,13 +1318,13 @@ USA. (define (reparse-text v parser description ptr) (let ((v (coalesce-elements v))) (if (and (fix:= (vector-length v) 1) - (ustring? (vector-ref v 0))) + (string? (vector-ref v 0))) (let ((v* (fluid-let ((*external-expansion?* #t)) (*parse-string parser (vector-ref v 0))))) (if (not v*) (perror ptr - (ustring-append "Malformed " description) + (string-append "Malformed " description) (vector-ref v 0))) v*) v))) diff --git a/src/xml/xml-rpc.scm b/src/xml/xml-rpc.scm index a37a17c8d..eb6bc6dc8 100644 --- a/src/xml/xml-rpc.scm +++ b/src/xml/xml-rpc.scm @@ -89,8 +89,8 @@ USA. '())))))) (define (valid-method-name? string) - (and (fix:> 0 (ustring-length string)) - (ustring-every (char-set-predicate char-set:method-name) string))) + (and (fix:> 0 (string-length string)) + (string-every (char-set-predicate char-set:method-name) string))) (define char-set:method-name (char-set-union (ascii-range->char-set (char->integer #\a) @@ -117,7 +117,7 @@ USA. (let ((p1 (or (assq '|faultCode| alist) (lose))) (p2 (or (assq '|faultString| alist) (lose)))) (require (exact-integer? (cdr p1))) - (require (ustring? (cdr p2))) + (require (string? (cdr p2))) (error:xml-rpc-fault (cdr p1) (cdr p2))))) (else (lose))))))) @@ -217,7 +217,7 @@ USA. (define (decode-value elt) (let ((items (xml-element-contents elt))) (if (and (pair? items) - (ustring? (car items)) + (string? (car items)) (null? (cdr items))) (car items) (let ((object (decode-value-1 (single-child elt)))) @@ -229,8 +229,8 @@ USA. (case (xml-element-name elt) ((boolean) (let ((s (content-string elt))) - (cond ((ustring=? s "0") #f) - ((ustring=? s "1") #t) + (cond ((string=? s "0") #f) + ((string=? s "1") #t) (else (lose))))) ((nil) #!default) @@ -271,7 +271,7 @@ USA. (let ((items (xml-element-contents elt))) (require (and (pair? items) - (ustring? (car items)) + (string? (car items)) (null? (cdr items)))) (car items))) @@ -301,7 +301,7 @@ USA. (rpc-elt:boolean (if object "1" "0"))) ((default-object? object) (rpc-elt:nil)) - ((ustring? object) + ((string? object) (encode-string object)) ((symbol? object) (encode-string (symbol->string object))) @@ -332,7 +332,7 @@ USA. (call-with-output-string (lambda (port) (let ((context (encode-base64:initialize port #f))) - (encode-base64:update context string 0 (ustring-length string)) + (encode-base64:update context string 0 (string-length string)) (encode-base64:finalize context))))))) (define *xml-rpc:encode-value-handler* #f) diff --git a/src/xml/xml-struct.scm b/src/xml/xml-struct.scm index 44804db2e..816ed6dab 100644 --- a/src/xml/xml-struct.scm +++ b/src/xml/xml-struct.scm @@ -123,13 +123,13 @@ USA. (string-composed-of? object char-set:xml-whitespace)) (define (string-composed-of? string char-set) - (and (ustring? string) - (ustring-every (char-set-predicate char-set) string))) + (and (string? string) + (string-every (char-set-predicate char-set) string))) (define (substring-composed-of? string start end char-set) (let loop ((index start)) (or (fix:= index end) - (and (char-set-member? char-set (ustring-ref string index)) + (and (char-set-member? char-set (string-ref string index)) (loop (fix:+ index 1)))))) (define-xml-type declaration @@ -139,7 +139,7 @@ USA. (define (xml-version? object) (and (string-composed-of? object char-set:xml-version) - (fix:> (ustring-length object) 0))) + (fix:> (string-length object) 0))) (define char-set:xml-version (char-set-union char-set:alphanumeric @@ -147,10 +147,10 @@ USA. (define (xml-encoding? object) (or (not object) - (and (ustring? object) - (let ((end (ustring-length object))) + (and (string? object) + (let ((end (string-length object))) (and (fix:> end 0) - (char-alphabetic? (ustring-ref object 0)) + (char-alphabetic? (string-ref object 0)) (substring-composed-of? object 1 end char-set:xml-encoding)))))) @@ -164,16 +164,16 @@ USA. (define (xml-char-data? object) (or (xml-char? object) - (and (ustring? object) + (and (string? object) (string-of-xml-chars? object)))) (define (string-of-xml-chars? string) - (ustring-every xml-char? string)) + (string-every xml-char? string)) (define (canonicalize-char-data object) (cond ((xml-char? object) - (ustring object)) - ((ustring? object) + (string object)) + ((string? object) (if (not (string-of-xml-chars? object)) (error:wrong-type-datum object "well-formed XML char data")) object) @@ -228,7 +228,7 @@ USA. (let ((item (car items)) (items (cdr items))) (if (xml-char-data? item) - (join (ustring-append s (canonicalize-char-data item)) + (join (string-append s (canonicalize-char-data item)) items) (begin (check-item item) @@ -276,7 +276,7 @@ USA. (xml-attribute-value attr)))) (define (xml-name-arg arg caller) - (if (ustring? arg) + (if (string? arg) (make-xml-name arg) (begin (guarantee-xml-name arg caller) @@ -497,7 +497,7 @@ USA. (let ((attr (find (lambda (attr) (and (xml-attribute-namespace-decl? attr) - (ustring=? (xml-attribute-value attr) uri-string))) + (string=? (xml-attribute-value attr) uri-string))) (xml-element-attributes elt)))) (and attr (let ((name (xml-attribute-name attr))) @@ -509,13 +509,13 @@ USA. (define (xml-comment . strings) (make-xml-comment - (let* ((s (apply ustring-append (map canonicalize-char-data strings))) - (n (ustring-length s))) + (let* ((s (apply string-append (map canonicalize-char-data strings))) + (n (string-length s))) (if (fix:> n 0) - (ustring-append - (if (char-whitespace? (ustring-ref s 0)) "" " ") + (string-append + (if (char-whitespace? (string-ref s 0)) "" " ") s - (if (char-whitespace? (ustring-ref s (fix:- n 1))) "" " ")) + (if (char-whitespace? (string-ref s (fix:- n 1))) "" " ")) " ")))) (define (xml-stylesheet . items) @@ -563,10 +563,10 @@ USA. (let ((item (car items)) (items (cdr items))) (cond ((and (or (xml-name? item) - (ustring? item)) + (string? item)) (pair? items)) (let ((name - (if (ustring? item) + (if (string? item) (make-xml-name item) item)) (value (car items)) @@ -619,7 +619,7 @@ USA. (if (pair? nmtokens) (let ((nmtoken-length (lambda (nmtoken) - (ustring-length (symbol-name nmtoken))))) + (string-length (symbol-name nmtoken))))) (let ((s (make-ustring (let loop ((nmtokens nmtokens) (n 0)) @@ -628,10 +628,10 @@ USA. (loop (cdr nmtokens) (fix:+ n 1)) n)))))) (let loop ((nmtokens nmtokens) (index 0)) - (ustring-copy! s index (symbol-name (car nmtokens))) + (string-copy! s index (symbol-name (car nmtokens))) (if (pair? (cdr nmtokens)) (let ((index (fix:+ index (nmtoken-length (car nmtokens))))) - (ustring-set! s index #\space) + (string-set! s index #\space) (loop (cdr nmtokens) (fix:+ index 1))))) s)) (make-ustring 0))) \ No newline at end of file