I need this to be able to read the Unicode Character Database.
,v
,(if (string? description)
(string-append "Malformed " description)
- `(STRING-APPEND "Malformed " ,description))))))))))
+ `(USTRING-APPEND "Malformed " ,description))))))))))
(define-*parser-macro (sbracket description open close . body)
`(BRACKET ,description (NOISE (STRING ,open)) (NOISE (STRING ,close))
(integer->char
(call-with-parser-buffer-tail b p
(lambda (string start end)
- (substring->number string (+ start 2) end
- 16 #t)))))
+ (string->number string 16 #t (+ start 2)
+ end)))))
(else #f))))))
(if char
(begin
(define (canonicalize-rdf-object object #!optional caller)
(cond ((rdf-literal? object) object)
- ((string? object) (make-rdf-literal object #f))
+ ((ustring? 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-string name 'MAKE-RDF-BNODE)
+ (guarantee ustring? name 'MAKE-RDF-BNODE)
(hash-table/intern! *rdf-bnode-registry* name %make-rdf-bnode))))
(define (rdf-bnode-name bnode)
- (string-append "B" (number->string (hash bnode))))
+ (ustring-append "B" (number->string (hash bnode))))
(define (%decode-bnode-uri uri)
(let ((v
- (cond ((string? uri) (*parse-string parse-bnode uri))
+ (cond ((ustring? uri) (*parse-string parse-bnode uri))
((symbol? uri) (*parse-symbol parse-bnode uri))
(else #f))))
(and v
(define (%register-rdf-prefix prefix expansion registry)
(let ((p (assq prefix (registry-bindings registry))))
(if p
- (if (not (string=? (cdr p) expansion))
+ (if (not (ustring=? (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) (string-prefix? (cdr p) s))))
+ (filter (lambda (p) (ustring-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
- (string-tail (uri->string uri)
- (string-length expansion)))))))
+ (ustring-tail (uri->string uri)
+ (ustring-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 (string-append expansion local) 'RDF-QNAME->URI)
+ (->absolute-uri (ustring-append expansion local) 'RDF-QNAME->URI)
(begin
(if error? (error:bad-range-argument qname 'RDF-QNAME->URI))
#f)))))
(define (rdf-qname-prefix qname)
(guarantee-rdf-qname qname 'RDF-QNAME-PREFIX)
(let ((s (symbol-name qname)))
- (symbol (string-head s (fix:+ (string-find-next-char s #\:) 1)))))
+ (symbol (ustring-head s (fix:+ (ustring-find-first-char s #\:) 1)))))
(define (rdf-qname-local qname)
(guarantee-rdf-qname qname 'RDF-QNAME-LOCAL)
(let ((s (symbol-name qname)))
- (string-tail s (fix:+ (string-find-next-char s #\:) 1))))
+ (ustring-tail s (fix:+ (ustring-find-first-char s #\:) 1))))
(define (split-rdf-qname qname)
(guarantee-rdf-qname qname 'SPLIT-RDF-QNAME)
(let ((s (symbol-name qname)))
- (let ((i (fix:+ (string-find-next-char s #\:) 1)))
- (values (symbol (string-head s i))
- (string-tail s i)))))
+ (let ((i (fix:+ (ustring-find-first-char s #\:) 1)))
+ (values (symbol (ustring-head s i))
+ (ustring-tail s i)))))
\f
(define (rdf-qname? object)
(and (interned-symbol? object)
(*parser
(map (lambda (s)
(make-rdf-literal
- (if (char=? (string-ref s 0) #\-)
+ (if (char=? (ustring-ref s 0) #\-)
s
- (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))
+ (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))
(loop (fix:+ i 1))
(if (fix:= i 0)
s
- (string-tail s i))))))
+ (ustring-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)
- (string-append msg " in " name))
+ (ustring-append msg " in " name))
(define (copy p)
(call-with-parser-buffer-tail buffer p
(define (post-process-qname prefix local prefixes)
(string->uri
- (string-append (cdr
- (or (find (lambda (p)
- (string=? (car p) prefix))
- prefixes)
- (error "Unknown prefix:" prefix)))
- (or local ""))))
+ (ustring-append (cdr
+ (or (find (lambda (p)
+ (ustring=? (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))))
- (substring<? a 0 (fix:- (string-length a) 1)
- b 0 (fix:- (string-length b) 1))))))))
+ (ustring<?
+ (ustring-head a (fix:- (ustring-length a) 1))
+ (ustring-head b (fix:- (ustring-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)
- (string-append "(" elt ")")))
+ (ustring-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 (string-length s) indentation port)
+ (maybe-break (ustring-length s) indentation port)
(write-string s port)))
((rdf-graph? o)
(space port)
(write-symbol lang port))))))))
(define (write-literal-text text port)
- (if (string-find-next-char text #\newline)
+ (if (ustring-find-first-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 (string-length s)))
+ (end (ustring-length s)))
(receive (prefix expansion) (uri->rdf-prefix uri registry #f)
(if prefix
- (let ((start (string-length expansion)))
+ (let ((start (ustring-length expansion)))
(if (*match-string match:name s start end)
(begin
(write-string (symbol-name prefix) port)
(reverse! groups))))
(define (uri<? a b)
- (string<? (uri->string a) (uri->string b)))
+ (ustring<? (uri->string a) (uri->string b)))
(define (rdf-bnode<? a b)
- (string<? (rdf-bnode-name a) (rdf-bnode-name b)))
+ (ustring<? (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 (string-append "&#x"
- (number->string (char->integer (cadr b)) 16)
- ";"))))
+ (list (ustring-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 (string? id)
- (string-prefix? "-//W3C//DTD XHTML " id)))
+ (and (ustring? id)
+ (ustring-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 (string-append "#" tag) contents))
+ (apply html:href (ustring-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))
- (string-append (symbol-name (car bindings))
- ": "
- (cadr bindings)
- (if (pair? (cddr bindings))
- (string-append "; " (loop (cddr bindings)))
- ";")))
+ (ustring-append (symbol-name (car bindings))
+ ": "
+ (cadr bindings)
+ (if (pair? (cddr bindings))
+ (ustring-append "; " (loop (cddr bindings)))
+ ";")))
""))
\ No newline at end of file
(define (name-constructor string-predicate constructor)
(lambda (object)
- (if (string? object)
+ (if (ustring? 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 (string-find-next-char s #\:)))
+ (let ((c (ustring-find-first-char s #\:)))
(if c
- (string->symbol (string-head s c))
+ (string->symbol (ustring-head s c))
(null-xml-name-prefix)))))
(define (xml-qname-local qname)
(define (%xml-qname-local qname)
(let ((s (symbol-name qname)))
- (let ((c (string-find-next-char s #\:)))
+ (let ((c (ustring-find-first-char s #\:)))
(if c
- (string->symbol (string-tail s (fix:+ c 1)))
+ (string->symbol (ustring-tail s (fix:+ c 1)))
qname))))
\ No newline at end of file
(emit-string "<?" ctx)
(write-xml-name (xml-processing-instructions-name pi) ctx)
(let ((text (xml-processing-instructions-text pi)))
- (if (fix:> (string-length text) 0)
+ (if (fix:> (ustring-length text) 0)
(begin
(if (not (char-set-member? char-set:xml-whitespace
- (string-ref text 0)))
+ (ustring-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 (string-upcase (symbol-name type)) ctx))
+ (emit-string (ustring-upcase (symbol-name type)) ctx))
((and (pair? type) (eq? (car type) '|#PCDATA|))
(emit-string "(#PCDATA" ctx)
(if (pair? (cdr type))
(emit-char (car type) ctx))
(procedure type))))
(lose
- (lambda ()
+ (lambda ()
(error "Malformed !ELEMENT content type:" type))))
(write-children type)))))
(emit-string ">" ctx))
(emit-string " " ctx)
(let ((type (cadr definition)))
(cond ((symbol? type)
- (emit-string (string-upcase (symbol-name type)) ctx))
+ (emit-string (ustring-upcase (symbol-name type)) ctx))
((and (pair? type) (eq? (car type) '|NOTATION|))
(emit-string "NOTATION (" ctx)
(if (pair? (cdr type))
(emit-char #\" ctx)
(for-each
(lambda (item)
- (if (string? item)
+ (if (ustring? item)
(write-escaped-string item
'((#\" . """)
(#\& . "&")
(define (perror ptr msg . irritants)
(apply error
- (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)
- ":"
- "."))
+ (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)
+ ":"
+ "."))
irritants))
(define (coalesce-elements v)
(define (coalesce-strings! elements)
(do ((elements elements (cdr elements)))
((not (pair? elements)))
- (if (string? (car elements))
+ (if (ustring? (car elements))
(do ()
((not (and (pair? (cdr elements))
- (string? (cadr elements)))))
+ (ustring? (cadr elements)))))
(set-car! elements
- (string-append (car elements)
- (cadr elements)))
+ (ustring-append (car elements)
+ (cadr elements)))
(set-cdr! elements (cddr elements)))))
elements)
(define (string->xml string #!optional start end pi-handlers)
(parse-xml (string->parser-buffer string start end)
- (if (string? string)
- 'ISO-8859-1
- 'ANY)
+ 'ANY
(guarantee-pi-handlers pi-handlers 'STRING->XML)))
(define (guarantee-pi-handlers object caller)
(if (and version
(not (*match-string match-xml-version version)))
(perror p "Malformed XML version" version))
- (if (and version (not (string=? version "1.0")))
+ (if (and version (not (ustring=? 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 (string=? (vector-ref v 2) ">")
+ (if (ustring=? (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 (string=? av (cdr default))))
+ (not (ustring=? 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 (string-null? (vector-ref v 0))
+ (if (fix:= 0 (ustring-length (vector-ref v 0)))
'#()
v))
parse-body))))
(match match:xml-name)))))
(define (simple-name-parser type)
- (let ((m (string-append "Malformed " type " name")))
+ (let ((m (ustring-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 (string=? value xml-uri-string))
- (or (string-null? value)
- (string=? value xml-uri-string)
- (string=? value xmlns-uri-string)))
+ (not (ustring=? value xml-uri-string))
+ (or (fix:= 0 (ustring-length value))
+ (ustring=? value xml-uri-string)
+ (ustring=? 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 (string-ci=? (symbol-name name) "xml")
+ (if (ustring-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)
- (string? (car elements))
+ (ustring? (car elements))
(null? (cdr elements))))
(error "Uncoalesced attribute value:" elements))
(normalize-attribute-value (car elements)))
(loop))))))))))
(define (trim-attribute-whitespace string)
- (call-with-output-string
- (lambda (port)
- (let ((string (string-trim string)))
- (let ((end (string-length string)))
- (let loop ((start 0))
+ (let ((end (ustring-length string)))
+ (call-with-output-string
+ (lambda (port)
+
+ (define (skip-spaces start pending-space?)
+ (if (fix:< start end)
+ (let ((char (ustring-ref string start)))
+ (if (char-in-set? char-set:whitespace)
+ (skip-spaces (fix:+ start 1) pending-space?)
+ (begin
+ (if pending-space? (write-char #\space port))
+ (write-char char port)
+ (find-next-space (fix:+ start 1)))))))
+
+ (define (find-next-space start)
(if (fix:< start end)
- (let ((regs
- (re-substring-search-forward " +" string start end)))
- (if regs
+ (let ((char (ustring-ref string start)))
+ (if (char-in-set? char-set:whitespace)
+ (skip-spaces (fix:+ start 1) #t)
(begin
- (write-substring string
- start
- (re-match-start-index 0 regs)
- port)
- (write-char #\space port)
- (loop (re-match-end-index 0 regs)))
- (write-substring string start end port))))))))))
+ (write-char char port)
+ (find-next-space (fix:+ start 1)))))))
+
+ (skip-spaces 0 #f)))))
\f
(define (normalize-line-endings string #!optional always-copy?)
- (if (string-find-next-char string #\return)
- (let ((end (string-length string)))
+ (if (ustring-find-first-char string #\return)
+ (let ((end (ustring-length string)))
(let ((step-over-eol
(lambda (index)
(fix:+ index
(if (and (fix:< (fix:+ index 1) end)
- (char=? (string-ref string (fix:+ index 1))
+ (char=? (ustring-ref string (fix:+ index 1))
#\linefeed))
2
1)))))
(let ((n
(let loop ((start 0) (n 0))
(let ((index
- (substring-find-next-char string start end
- #\return)))
+ (ustring-find-first-char string #\return start end)))
(if index
(loop (step-over-eol index)
(fix:+ n (fix:+ (fix:- index start) 1)))
(fix:+ n (fix:- end start)))))))
- (let ((string* (make-string n)))
+ (let ((string* (make-ustring n)))
(let loop ((start 0) (start* 0))
(let ((index
- (substring-find-next-char string start end
- #\return)))
+ (ustring-find-first-char string #\return start end)))
(if index
(let ((start*
- (substring-move! string start index
- string* start*)))
- (string-set! string* start* #\newline)
+ (ustring-copy! string* start* string start index)))
+ (ustring-set! string* start* #\newline)
(loop (step-over-eol index)
(fix:+ start* 1)))
- (substring-move! string start end string* start*))))
+ (ustring-copy! string* start* string start end))))
string*))))
- (if (and (not (default-object? always-copy?))
- always-copy?)
- (string-copy string)
+ (if (if (default-object? always-copy?) #f always-copy?)
+ (ustring-copy string)
string)))
\f
;;;; Parameter entities
(and entity
(xml-parameter-!entity-value entity))))))
(if (and (pair? value)
- (string? (car value))
+ (ustring? (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)
- (string? (car value))
+ (ustring? (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 (string? value)
- (reparse-text (vector (string-append " " value " "))
+ (if (ustring? value)
+ (reparse-text (vector (ustring-append " " value " "))
parse-external-subset-decl
"parameter-entity value"
p)
(lambda (v)
(if (fix:= (vector-length v) 1)
(vector-ref v 0)
- (list (string-ref (vector-ref v 1) 0)
+ (list (ustring-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)
- (string? (vector-ref v 0)))
+ (ustring? (vector-ref v 0)))
(let ((v*
(fluid-let ((*external-expansion?* #t))
(*parse-string parser (vector-ref v 0)))))
(if (not v*)
(perror ptr
- (string-append "Malformed " description)
+ (ustring-append "Malformed " description)
(vector-ref v 0)))
v*)
v)))
(let ((elt (xml-document-root document)))
(require (xml-name=? (xml-element-name elt) '|methodCall|))
(values (let ((s (content-string (named-child '|methodName| elt))))
- (require (re-string-match "\\`[a-zA-Z0-9_.:/]+\\'" s))
+ (require (valid-method-name? s))
(string->symbol s))
(let ((elt (%named-child 'params elt)))
(if elt
(parse-params elt)
'()))))))
+(define (valid-method-name? string)
+ (and (fix:> 0 (ustring-length string))
+ (ustring-every (char-set-predicate char-set:method-name) string)))
+
+(define char-set:method-name
+ (char-set-union (ascii-range->char-set (char->integer #\a)
+ (fix:+ (char->integer #\z) 1))
+ (ascii-range->char-set (char->integer #\A)
+ (fix:+ (char->integer #\Z) 1))
+ (ascii-range->char-set (char->integer #\0)
+ (fix:+ (char->integer #\9) 1))
+ (char-set #\_ #\. #\: #\/)))
+
(define (xml-rpc:parse-response document)
(fluid-let ((*document* document)
(*caller* 'xml-rpc:parse-response))
(let ((p1 (or (assq '|faultCode| alist) (lose)))
(p2 (or (assq '|faultString| alist) (lose))))
(require (exact-integer? (cdr p1)))
- (require (string? (cdr p2)))
+ (require (ustring? (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)
- (string? (car items))
+ (ustring? (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 ((string=? s "0") #f)
- ((string=? s "1") #t)
+ (cond ((ustring=? s "0") #f)
+ ((ustring=? s "1") #t)
(else (lose)))))
((nil)
#!default)
(let ((items (xml-element-contents elt)))
(require
(and (pair? items)
- (string? (car items))
+ (ustring? (car items))
(null? (cdr items))))
(car items)))
(rpc-elt:boolean (if object "1" "0")))
((default-object? object)
(rpc-elt:nil))
- ((string? object)
+ ((ustring? 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 (string-length string))
+ (encode-base64:update context string 0 (ustring-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 (string? string)
- (substring-composed-of? string 0 (string-length string) char-set)))
+ (and (ustring? string)
+ (ustring-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 (string-ref string index))
+ (and (char-set-member? char-set (ustring-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:> (string-length object) 0)))
+ (fix:> (ustring-length object) 0)))
(define char-set:xml-version
(char-set-union char-set:alphanumeric
(define (xml-encoding? object)
(or (not object)
- (and (string? object)
- (let ((end (string-length object)))
+ (and (ustring? object)
+ (let ((end (ustring-length object)))
(and (fix:> end 0)
- (char-alphabetic? (string-ref object 0))
+ (char-alphabetic? (ustring-ref object 0))
(substring-composed-of? object 1 end
char-set:xml-encoding))))))
(define (canonicalize-char-data object)
(cond ((unicode-char? object)
- (call-with-output-string
- (lambda (port)
- (write-char object port))))
+ (if (not (char-in-set? object char-set:xml-char))
+ (error:wrong-type-datum object "well-formed XML char data"))
+ (ustring object))
((ustring? object)
(if (not (string-of-xml-chars? object))
(error:wrong-type-datum object "well-formed XML char data"))
(let ((item (car items))
(items (cdr items)))
(if (xml-char-data? item)
- (join (string-append s (canonicalize-char-data item))
+ (join (ustring-append s (canonicalize-char-data item))
items)
(begin
(check-item item)
(xml-attribute-value attr))))
(define (xml-name-arg arg caller)
- (if (string? arg)
+ (if (ustring? arg)
(make-xml-name arg)
(begin
(guarantee-xml-name arg caller)
(let ((attr
(find (lambda (attr)
(and (xml-attribute-namespace-decl? attr)
- (string=? (xml-attribute-value attr) uri-string)))
+ (ustring=? (xml-attribute-value attr) uri-string)))
(xml-element-attributes elt))))
(and attr
(let ((name (xml-attribute-name attr)))
(let ((item (car items))
(items (cdr items)))
(cond ((and (or (xml-name? item)
- (string? item))
+ (ustring? item))
(pair? items))
(let ((name
- (if (string? item)
+ (if (ustring? item)
(make-xml-name item)
item))
(value (car items))
(if (pair? nmtokens)
(let ((nmtoken-length
(lambda (nmtoken)
- (string-length (symbol-name nmtoken)))))
+ (ustring-length (symbol-name nmtoken)))))
(let ((s
- (make-string
+ (make-ustring
(let loop ((nmtokens nmtokens) (n 0))
(let ((n (fix:+ n (nmtoken-length (car nmtokens)))))
(if (pair? (cdr nmtokens))
(loop (cdr nmtokens) (fix:+ n 1))
n))))))
(let loop ((nmtokens nmtokens) (index 0))
- (string-move! (symbol-name (car nmtokens)) s index)
+ (ustring-copy! s index (symbol-name (car nmtokens)))
(if (pair? (cdr nmtokens))
(let ((index (fix:+ index (nmtoken-length (car nmtokens)))))
- (string-set! s index #\space)
+ (ustring-set! s index #\space)
(loop (cdr nmtokens) (fix:+ index 1)))))
s))
- (make-string 0)))
\ No newline at end of file
+ (make-ustring 0)))
\ No newline at end of file
projects / mit-scheme.git / commitdiff