With single exception of make-ustring which needs some thought.
(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"))))
(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)))
\f
;;;; UCD property extraction
(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
(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)
(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)))
(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)
(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))
(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)))))
(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)
(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))))))
\f
(define (generate-top-level prop-name root-entry table-entries proc-name)
(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)))))
\f
(declare (integrate-operator rat:rational?))
(define (rat:rational? object)
(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
(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.
(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)
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))))))
(string-append "x" (number->string code 16)))))))
\f
(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)
(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))))))
(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
(,char-bit:control "C-" "c-" "control-" "ctrl-")))
\f
(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))
(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)
(define (cpl-element? object)
(or (%range? object)
(bitless-char? object)
- (ustring? object)
+ (string? object)
(char-set? object)))
(define (%range? object)
;; 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)
(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
(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
(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*)))
(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
(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)))))))
(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)
(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
(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)))))
(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)))))
\f
(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)
(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)
(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)))
\f
;;;; 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"))))
(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"))))
\f
(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))
(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))
(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)))))
\f
(define (dos/directory-pathname? pathname)
(and (not (%pathname-name pathname))
(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)
(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)
((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)
((eof-object? char)
(fix:- index start))
(else
- (ustring-set! string index char)
+ (string-set! string index char)
(loop (fix:+ index 1)))))
(fix:- end start))))
(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)))
((%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))))
\f
(define-integrable (%bignum? object)
(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
((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)
(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))))
\f
(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
(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)))
(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
(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)
(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))))
(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)
(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
(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))
(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)))))))
(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))
(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)))
unspecific)
\f
(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*)))
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)
""
(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)))
(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)))
ADDITIONAL OPTIONS supported by this band:\n")
(do ((parsers (sort *command-line-parsers*
- (lambda (a b) (ustring<? (car a) (car b))))
+ (lambda (a b) (string<? (car a) (car b))))
(cdr parsers)))
((null? parsers))
(let ((description (cadar parsers)))
- (if (not (fix:= 0 (ustring-length description)))
+ (if (not (fix:= 0 (string-length description)))
(begin
(newline)
(write-string description)
("queue" . (RUNTIME SIMPLE-QUEUE))
("equals" . (RUNTIME EQUALITY))
("list" . (RUNTIME LIST))
+ ("ustring" . (RUNTIME USTRING))
("symbol" . (RUNTIME SYMBOL))
("uproc" . (RUNTIME PROCEDURE))
("fixart" . (RUNTIME FIXNUM-ARITHMETIC))
\f
(define (string->number 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
(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)
(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
(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)
(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
(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)
(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))))
(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)))))
;; 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)
;; 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)
(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)))
;; 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))
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)))))
\f
(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)
((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))
(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
(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
""))
"")))
(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))))
\f
(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)
(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))
(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))))
(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)
(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
(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)))
(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))))
(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
;; 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)))
;; 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=?))
(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)
(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)
(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=?))
(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))
\f
(define-integrable (match-substring-loop buffer string start end compare)
(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
(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)))))
(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)))
(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*)
(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))
(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
(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)
(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
(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
(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)))
(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)
(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)))
(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)
(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
(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))
(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))))))))
(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))))
(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
(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))
(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)
((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)
(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)))))))
(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)))
(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.)]"))))))
\f
;;;; Node Model
;;; be gained by keeping it around.
(define (symbol-length symbol)
- (ustring-length
+ (string-length
(call-with-output-string
(lambda (port)
(write symbol port)))))
(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))))
((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/)
(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)
(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))
subvector-uniform?
vector
vector->list
- vector->string
vector-append
vector-binary-search
vector-copy
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-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>=?
- ;; string>?
- ;; string?
- ;; substring
- substring->list
substring-capitalize!
substring-capitalized?
- substring-ci<?
- substring-ci=?
substring-downcase!
- substring-fill!
- substring-find-next-char
- substring-find-next-char-ci
- substring-find-next-char-in-set
- substring-find-previous-char
- substring-find-previous-char-ci
- substring-find-previous-char-in-set
- substring-lower-case?
substring-match-backward
substring-match-backward-ci
substring-match-forward
substring-match-forward-ci
- substring-move!
- substring-move-left!
- substring-move-right!
- substring-prefix-ci?
- substring-prefix?
substring-replace
substring-replace!
substring-search-all
substring-search-backward
substring-search-forward
- substring-suffix-ci?
- substring-suffix?
substring-upcase!
- substring-upper-case?
- substring<?
- substring=?
substring?)
(initialization (initialize-package!)))
(define-package (runtime ustring)
(files "ustring")
(parent (runtime))
+ (export () ;export-deprecated
+ (string-hash-mod string-hash)
+ (substring->list 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-ci<?
+ substring-ci=?
+ substring-fill!
+ substring-find-next-char
+ substring-find-next-char-ci
+ substring-find-next-char-in-set
+ substring-find-previous-char
+ substring-find-previous-char-ci
+ substring-find-previous-char-in-set
+ substring-lower-case?
+ substring-move!
+ substring-prefix-ci?
+ substring-prefix?
+ substring-suffix-ci?
+ substring-suffix?
+ substring-upper-case?
+ substring<?
+ substring=?)
(export ()
- (list->string 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-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>=?)
- (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-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>=?
- 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>=?
- 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>=?
+ string>?
+ string?
+ vector->string)
(export (runtime bytevector)
legacy-string-allocate
legacy-string?
(export (runtime predicate-metadata)
register-ustring-predicates!)
(export (runtime symbol)
- %ustring*
+ %string*
legacy-string-downcase
legacy-string?))
(if name
(loop
(if (and (not include-dots?)
- (or (ustring=? "." name)
- (ustring=? ".." name)))
+ (or (string=? "." name)
+ (string=? ".." name)))
result
(cons name result)))
(begin
(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)))
(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)
(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 <mime-type>
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)
(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)
(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)
(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)))
'()))
(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)))))
(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))))
(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))))
(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))))
(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))))
(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)
(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)
(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))
(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))
(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
(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)
(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
(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))
\f
;;;; Output as octets
(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")
(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)))
(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))
#t)))))
(define (symbol-hash symbol #!optional modulus)
- (ustring-hash (symbol-name symbol) modulus))
+ (string-hash (symbol-name symbol) modulus))
(define (symbol<? x y)
- (ustring<? (symbol-name x) (symbol-name y)))
+ (string<? (symbol-name x) (symbol-name y)))
(define (symbol>? x y)
- (ustring<? (symbol-name y) (symbol-name x)))
\ No newline at end of file
+ (string<? (symbol-name y) (symbol-name x)))
\ No newline at end of file
(begin
(*unparse-string "#[" context)
(let ((context* (context-in-brackets context)))
- (if (ustring? name)
+ (if (string? name)
(*unparse-string name context*)
(*unparse-object name context*))
(if object
(if type-name
(rename-user-object-type type-name)
(intern
- (ustring-append "undefined-type:" (number->string 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)))
(*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)
(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
(*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))
(*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))
(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
(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
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!)
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)
(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)))
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
;;;; 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 #\/))))
(and (pair? components)
(simplify-directory
(if (fix:= 0
- (ustring-length (car components)))
+ (string-length (car components)))
(cons 'ABSOLUTE
(parse-directory-components
(cdr components)))
(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)))))
(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)))))
(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)
(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)))
\f
;;;; 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"))))
(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"))))
\f
(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))
(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))
;;; 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?)
(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?)
(define interned-uri-authorities)
\f
(define (uri-userinfo? object)
- (ustring? object))
+ (string? object))
(define (uri-host? object)
- (ustring? object))
+ (string? object))
(define (uri-port? object)
(exact-nonnegative-integer? object))
'()))))
(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))))
\f
(define (remove-dot-segments path)
;; At all times, (APPEND INPUT (REVERSE OUTPUT)) must be well
(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
(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))
(begin
(if caller (error:bad-range-argument object caller))
#f)))
- ((ustring? object)
+ ((string? object)
(do-string object))
((symbol? object)
(do-string (symbol->string object)))
(%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))
\f
(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
(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
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))))))
;;;; 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))
\f
(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)
(define-integrable (%full-string-set! string index char)
(cp-vector-set! (%full-string-cp-vector string) index (char->integer char)))
-(define-record-type <slice>
- (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)))
(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))
\f
;;;; Strings
-(define (ustring? object)
+(define (string? object)
(or (legacy-string? object)
(full-string? object)
(slice? object)))
(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))
(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))
(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)
start
(fix:- end start))))))
\f
-(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)
(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))))
(%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))
\f
;; 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 %ustring=? (%string-comparison-maker char=? char=? fix:=))
-(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 %string=? (%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 %ustring-ci=? (%string-ci-comparison-maker %ustring=?))
-(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 %string-ci=? (%string-ci-comparison-maker %string=?))
+(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)
(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>? (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 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>? (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 string-ci>? (string-comparison-maker %string-ci>?))
+(define string-ci>=? (string-comparison-maker %string-ci>=?))
\f
(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)
(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))))
\f
-(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))
#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))
(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))
#|
(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))
result))))
|#
\f
-(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))
(%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))
(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))))
%full-string-ref string start end)
to)))))
\f
-(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)
\f
(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)
(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)))
(%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)
count))
count))))
\f
-(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)
#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)
(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)
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)
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))))
-\f
-(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)))
((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))
+\f
(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))))
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)))
(if (fix:< i end)
(and (proc (ref string i))
(loop (fix:+ i 1)))
- #t)))
\ No newline at end of file
+ #t)))
+\f
+(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))
+\f
+(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-ci<? string1 start1 end1 string2 start2 end2)
+ (string-ci<? (string-slice string1 start1 end1)
+ (string-slice string2 start2 end2)))
+
+(define (substring-ci=? string1 start1 end1 string2 start2 end2)
+ (string-ci=? (string-slice string1 start1 end1)
+ (string-slice string2 start2 end2)))
+
+(define (substring<? string1 start1 end1 string2 start2 end2)
+ (string<? (string-slice string1 start1 end1)
+ (string-slice string2 start2 end2)))
+
+(define (substring=? string1 start1 end1 string2 start2 end2)
+ (string=? (string-slice string1 start1 end1)
+ (string-slice string2 start2 end2)))
+
+(define (substring-prefix? string1 start1 end1 string2 start2 end2)
+ (string-prefix? (string-slice string1 start1 end1)
+ (string-slice string2 start2 end2)))
+
+(define (substring-prefix-ci? string1 start1 end1 string2 start2 end2)
+ (string-prefix-ci? (string-slice string1 start1 end1)
+ (string-slice string2 start2 end2)))
+
+(define (substring-suffix? string1 start1 end1 string2 start2 end2)
+ (string-suffix? (string-slice string1 start1 end1)
+ (string-slice string2 start2 end2)))
+
+(define (substring-suffix-ci? string1 start1 end1 string2 start2 end2)
+ (string-suffix-ci? (string-slice string1 start1 end1)
+ (string-slice string2 start2 end2)))
+
+(define (substring-fill! string start end char)
+ (string-fill! string char start end))
+
+(define (substring-lower-case? string start end)
+ (string-lower-case? (string-slice string start end)))
+
+(define (substring-upper-case? string start end)
+ (string-upper-case? (string-slice string start end)))
\ No newline at end of file
(SET-CDR! SET-CDR!)
(SET-CELL-CONTENTS! SET-CELL-CONTENTS!)
(SET-INTERRUPT-ENABLES! SET-INTERRUPT-ENABLES!)
- (SET-STRING-LENGTH! SET-STRING-LENGTH!)
(STACK-ADDRESS-OFFSET STACK-ADDRESS-OFFSET)
- (STRING->CHAR-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)
(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!)
,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))
(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)
(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
(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))
(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)))
(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) ':))
(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))
(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)))))
\f
(define (rdf-qname? object)
(and (interned-symbol? object)
(*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)))))))
(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
(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)
(lambda (a b)
(let ((a (symbol-name (car a)))
(b (symbol-name (car b))))
- (ustring<?
- (ustring-head a (fix:- (ustring-length a) 1))
- (ustring-head b (fix:- (ustring-length b) 1)))))))))
+ (string<?
+ (string-head a (fix:- (string-length a) 1))
+ (string-head b (fix:- (string-length b) 1)))))))))
(define (write-rdf/turtle-prefix prefix expansion #!optional port)
(let ((port (if (default-object? port) (current-output-port) port)))
inline-bnode
port))
=> (lambda (elt)
- (ustring-append "(" elt ")")))
+ (string-append "(" elt ")")))
(else #f))))
((rdf-bnode? o)
(and (not (inline-bnode o))
(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)
(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 ()
(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)
(reverse! groups))))
(define (uri<? a b)
- (ustring<? (uri->string a) (uri->string b)))
+ (string<? (uri->string a) (uri->string b)))
(define (rdf-bnode<? a b)
- (ustring<? (rdf-bnode-name a) (rdf-bnode-name b)))
+ (string<? (rdf-bnode-name a) (rdf-bnode-name b)))
(define (rdf-list->list node inline-bnode)
(let loop ((node node))
(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
"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)
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
(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
(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))
(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)
(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
(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)))
(emit-string "<?" ctx)
(write-xml-name (xml-processing-instructions-name pi) ctx)
(let ((text (xml-processing-instructions-text pi)))
- (if (fix:> (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))
(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))
(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))
(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))
\f
(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))
(emit-char #\" ctx)
(for-each
(lambda (item)
- (if (ustring? item)
+ (if (string? item)
(write-escaped-string item
'((#\" . """)
(#\& . "&")
(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
(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)
(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)
(char->integer c))))
(prefix
(lambda (n)
- (ustring (integer->char n))))
+ (string (integer->char n))))
(lose
(lambda bytes
(error "Illegal starting bytes:" bytes))))
(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)
(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)
'()))))))))))
(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)))
"]]>")))
(*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))))
(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"))
(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)))))
(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
(*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)))
(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
(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
(skip-spaces 0 #f)))))
\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)))
(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)))
\f
;;;; Parameter entities
(and entity
(xml-parameter-!entity-value entity))))))
(if (and (pair? value)
- (ustring? (car value))
+ (string? (car value))
(null? (cdr value)))
(car value)
(begin
(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?
(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)
(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
(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)))
'()))))))
(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)
(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)))))))
(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))))
(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)
(let ((items (xml-element-contents elt)))
(require
(and (pair? items)
- (ustring? (car items))
+ (string? (car items))
(null? (cdr items))))
(car items)))
(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)))
(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)
(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
(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
(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))))))
(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)
(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)
(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)
(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)))
(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)
(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))
(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))
(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
projects / mit-scheme.git / commitdiff