consequence of conforming to the specification.
#| -*-Scheme-*-
-$Id: xml-chars.scm,v 1.9 2007/01/05 21:19:29 cph Exp $
+$Id: xml-chars.scm,v 1.10 2007/07/23 04:12:43 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
alphabet:xml-extender
(string->alphabet ".-_:")))
+(define alphabet:ncname-initial
+ (alphabet- alphabet:name-initial
+ (string->alphabet ":")))
+
+(define alphabet:ncname-subsequent
+ (alphabet- alphabet:name-subsequent
+ (string->alphabet ":")))
+
(define char-set:xml-whitespace
(char-set #\space #\tab #\return #\linefeed))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: xml-names.scm,v 1.17 2007/07/23 02:46:07 cph Exp $
+$Id: xml-names.scm,v 1.18 2007/07/23 04:12:44 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(if (string-null? uri-string)
qname
(begin
- (if (not (let ((s (symbol-name qname)))
- (let ((c (find-prefix-separator s)))
- (case c
- ((#f) #t)
- ((ILLEGAL) #f)
- (else
- (case (utf8-string->symbol (string-head s c))
- ((xml) (string=? uri-string xml-uri-string))
- ((xmlns) (string=? uri-string xmlns-uri-string))
- (else #t)))))))
+ (if (not (case (xml-qname-prefix qname)
+ ((xml) (string=? uri-string xml-uri-string))
+ ((xmlns) (string=? uri-string xmlns-uri-string))
+ (else #t)))
(error:bad-range-argument uri-string 'MAKE-XML-NAME))
(%make-xml-name qname uri-string)))))
(or (xml-qname? object)
(combo-name? object)))
-(define (guarantee-xml-name object caller)
- (if (not (xml-name? object))
- (error:not-xml-name object caller)))
-
-(define (error:not-xml-name object caller)
- (error:wrong-type-argument object "an XML Name" caller))
+(define-guarantee xml-name "an XML Name")
(define (null-xml-namespace-uri? object)
(and (uri? object)
(and (symbol? object)
(string-is-xml-nmtoken? (symbol-name object))))
-(define (guarantee-xml-nmtoken object caller)
- (if (not (xml-nmtoken? object))
- (error:not-xml-nmtoken object caller)))
-
-(define (error:not-xml-nmtoken object caller)
- (error:wrong-type-argument object "an XML name token" caller))
+(define-guarantee xml-nmtoken "an XML name token")
(define (xml-nmtoken-string nmtoken)
(guarantee-xml-nmtoken nmtoken 'XML-NMTOKEN-STRING)
(symbol-name nmtoken))
-(define (string-is-xml-name? string)
- (eq? (string-is-xml-nmtoken? string) 'NAME))
+(define (string-is-xml-qname? string)
+ (let ((end (string-length string)))
+ (let ((c (substring-find-next-char string 0 end #\:)))
+ (if c
+ (and (not (substring-find-next-char string (fix:+ c 1) end #\:))
+ (string-is-xml-name? string 0 c)
+ (string-is-xml-name? string (fix:+ c 1) end))
+ (string-is-xml-name? string 0 end)))))
-(define (string-is-xml-nmtoken? string)
- (let ((buffer (utf8-string->parser-buffer string)))
+(define (string-is-xml-name? string #!optional start end)
+ (eq? (string-is-xml-nmtoken? string start end) 'NAME))
+
+(define (string-is-xml-nmtoken? string #!optional start end)
+ (let ((buffer (utf8-string->parser-buffer string start end)))
(letrec
((match-tail
(lambda ()
(define (make-xml-qname object)
(if (string? object)
(begin
- (if (not (string-is-xml-name? object))
+ (if (not (string-is-xml-qname? object))
(error:bad-range-argument object 'MAKE-XML-QNAME))
(utf8-string->symbol object))
(begin
(define (xml-qname? object)
(and (interned-symbol? object)
- (string-is-xml-name? (symbol-name object))))
-
-(define (guarantee-xml-qname object caller)
- (if (not (xml-qname? object))
- (error:not-xml-qname object caller)))
+ (string-is-xml-qname? (symbol-name object))))
-(define (error:not-xml-qname object caller)
- (error:wrong-type-argument object "an XML QName" caller))
+(define-guarantee xml-qname "an XML QName")
(define (xml-qname-string qname)
(guarantee-xml-qname qname 'XML-QNAME-STRING)
(symbol->utf8-string qname))
(define (xml-qname-local qname)
+ (guarantee-xml-qname qname 'XML-QNAME-LOCAL)
(let ((s (symbol-name qname)))
- (let ((c (find-prefix-separator s)))
- (if (or (not c) (eq? c 'ILLEGAL))
- qname
- (utf8-string->symbol (string-tail s (fix:+ c 1)))))))
+ (let ((c (string-find-next-char s #\:)))
+ (if c
+ (utf8-string->symbol (string-tail s (fix:+ c 1)))
+ qname))))
(define (xml-qname-prefix qname)
+ (guarantee-xml-qname qname 'XML-QNAME-PREFIX)
(let ((s (symbol-name qname)))
- (let ((c (find-prefix-separator s)))
- (if (or (not c) (eq? c 'ILLEGAL))
- (null-xml-name-prefix)
- (utf8-string->symbol (string-head s c))))))
-
-(define (find-prefix-separator s)
- (let ((c (string-find-next-char s #\:)))
- (if (or (not c)
- (let ((i (fix:+ c 1))
- (e (string-length s)))
- (and (let ((char
- (let ((port (open-input-string s i e)))
- (port/set-coding port 'UTF-8)
- (read-char port))))
- (and (not (eof-object? char))
- (not (char=? char #\:))
- (char-in-alphabet? char alphabet:name-initial)))
- (not (substring-find-next-char s i e #\:)))))
- c
- 'ILLEGAL)))
+ (let ((c (string-find-next-char s #\:)))
+ (if c
+ (utf8-string->symbol (string-head s c))
+ (null-xml-name-prefix)))))
(define-record-type <combo-name>
(make-combo-name qname expanded)
#| -*-Scheme-*-
-$Id: xml-parser.scm,v 1.76 2007/07/23 02:46:09 cph Exp $
+$Id: xml-parser.scm,v 1.77 2007/07/23 04:12:45 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(if (there-exists? (cdr attrs)
(lambda (attr)
(xml-name=? (xml-attribute-name attr) name)))
- (perror p "Attributes with same name"
- (xml-name-qname name)))))))
+ (perror p "Attributes with same name" (xml-name-qname name)))))))
(define (parse-element-content b p name)
(let ((vc (parse-content b)))
(*parser
(with-pointer p
(map (lambda (s) (cons (make-xml-qname s) p))
- (match match-name)))))
+ (match match-qname)))))
(define (simple-name-parser type)
(let ((m (string-append "Malformed " type " name")))
- (*parser (require-success m (map make-xml-qname (match match-name))))))
+ (*parser (require-success m (map make-xml-qname (match match-ncname))))))
(define parse-entity-name (simple-name-parser "entity"))
(define parse-pi-name (simple-name-parser "processing-instructions"))
(define parse-notation-name (simple-name-parser "notation"))
-(define (match-name buffer)
- (and (match-parser-buffer-char-in-alphabet buffer alphabet:name-initial)
+(define match-qname
+ (*matcher
+ (seq match-ncname
+ (? (seq ":" match-ncname)))))
+
+(define (match-ncname buffer)
+ (and (match-parser-buffer-char-in-alphabet buffer alphabet:ncname-initial)
(let loop ()
(if (match-parser-buffer-char-in-alphabet buffer
- alphabet:name-subsequent)
+ alphabet:ncname-subsequent)
(loop)
#t))))
(let ((forbidden-uri
(lambda ()
(perror p "Forbidden namespace URI" value))))
- (let ((guarantee-legal-uri
- (lambda ()
- (if (or (string=? value xml-uri-string)
- (string=? value xmlns-uri-string))
- (forbidden-uri)))))
- (cond ((xml-name=? qname 'xmlns)
- (string->uri value) ;signals error if not URI
- (guarantee-legal-uri)
- (cons (cons (null-xml-name-prefix) value) tail))
- ((xml-name-prefix=? qname 'xmlns)
- (if (xml-name=? qname 'xmlns:xmlns)
- (perror p "Illegal namespace prefix" qname))
- (string->uri value) ;signals error if not URI
- (if (xml-name=? qname 'xmlns:xml)
- (if (not (string=? value xml-uri-string))
- (forbidden-uri))
- (guarantee-legal-uri))
- (cons (cons (xml-name-local qname) value) tail))
- (else tail))))))
+ (cond ((xml-name=? qname 'xmlns)
+ (string->uri value) ;signals error if not URI
+ (if (or (string=? value xml-uri-string)
+ (string=? value xmlns-uri-string))
+ (forbidden-uri))
+ (cons (cons (null-xml-name-prefix) value) tail))
+ ((xml-name-prefix=? qname 'xmlns)
+ (if (xml-name=? qname 'xmlns:xmlns)
+ (perror p "Illegal namespace prefix" qname))
+ (string->uri value) ;signals error if not URI
+ (if (if (xml-name=? qname 'xmlns:xml)
+ (not (string=? value xml-uri-string))
+ (or (string-null? value)
+ (string=? value xml-uri-string)
+ (string=? value xmlns-uri-string)))
+ (forbidden-uri))
+ (cons (cons (xml-name-local qname) value) tail))
+ (else tail)))))
*prefix-bindings*)))
unspecific)
(alt (seq "#"
(alt match-decimal
(seq "x" match-hexadecimal)))
- match-name)
+ match-qname)
";"))))
(define parse-entity-reference-name ;[68]
parse-entity-name)))
(define parse-entity-reference-deferred
- (*parser (match (seq "&" match-name ";"))))
+ (*parser (match (seq "&" match-qname ";"))))
(define parse-parameter-entity-reference-name ;[69]
(*parser
(lambda (a) (car a))))
(define parse-declaration-attributes
- (attribute-list-parser (*parser (map make-xml-qname (match match-name)))
+ (attribute-list-parser (*parser (map make-xml-qname (match match-qname)))
(lambda (a) a)))
\f
(define (attribute-value-parser alphabet parse-reference)
#| -*-Scheme-*-
-$Id: xml.pkg,v 1.92 2007/07/23 02:46:07 cph Exp $
+$Id: xml.pkg,v 1.93 2007/07/23 04:12:41 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(export (runtime xml)
alphabet:name-initial
alphabet:name-subsequent
+ alphabet:ncname-initial
+ alphabet:ncname-subsequent
coding-requires-bom?
normalize-coding))
projects / mit-scheme.git / commitdiff