From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 1 Aug 2003 19:31:02 +0000 (+0000)
Subject: Change DTD structures to use symbol names that are more closely
X-Git-Tag: 20090517-FFI~1833
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5368238b36f754cd16a6f92611262fd74b080dfb;p=mit-scheme.git
Change DTD structures to use symbol names that are more closely
related to the tokens appearing in the XML document.
---
diff --git a/v7/src/xml/xml-output.scm b/v7/src/xml/xml-output.scm
index 14ff41237..fd4adb8a2 100644
--- a/v7/src/xml/xml-output.scm
+++ b/v7/src/xml/xml-output.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: xml-output.scm,v 1.22 2003/07/30 19:43:59 cph Exp $
+$Id: xml-output.scm,v 1.23 2003/08/01 19:31:02 cph Exp $
Copyright 2001,2002,2003 Massachusetts Institute of Technology
@@ -172,7 +172,7 @@ USA.
(let ((type (xml-!element-content-type decl)))
(cond ((symbol? type)
(emit-string (string-upcase (symbol-name type)) ctx))
- ((and (pair? type) (eq? (car type) 'MIX))
+ ((and (pair? type) (eq? (car type) '|#PCDATA|))
(emit-string "(#PCDATA" ctx)
(if (pair? (cdr type))
(begin
@@ -194,7 +194,7 @@ USA.
(emit-string "(" ctx)
(write-cp (cadr type))
(for-each
- (let ((sep (if (eq? (car type) 'ALT) "|" ",")))
+ (let ((sep (if (eq? (car type) 'alt) "|" ",")))
(lambda (type)
(emit-string sep ctx)
(write-cp type)))
@@ -234,7 +234,7 @@ USA.
(let ((type (cadr definition)))
(cond ((symbol? type)
(emit-string (string-upcase (symbol-name type)) ctx))
- ((and (pair? type) (eq? (car type) 'NOTATION))
+ ((and (pair? type) (eq? (car type) '|NOTATION|))
(emit-string "NOTATION (" ctx)
(if (pair? (cdr type))
(begin
@@ -244,7 +244,7 @@ USA.
(write-xml-name name ctx))
(cddr type))))
(emit-string ")" ctx))
- ((and (pair? type) (eq? (car type) 'ENUMERATED))
+ ((and (pair? type) (eq? (car type) 'enumerated))
(emit-string "(" ctx)
(if (pair? (cdr type))
(begin
@@ -258,15 +258,14 @@ USA.
(error "Malformed !ATTLIST type:" type))))
(emit-string " " ctx)
(let ((default (caddr definition)))
- (cond ((eq? default 'REQUIRED)
- (emit-string "#REQUIRED" ctx))
- ((eq? default 'IMPLIED)
- (emit-string "#IMPLIED" ctx))
- ((and (pair? default) (eq? (car default) 'FIXED))
- (emit-string "#FIXED" ctx)
+ (cond ((or (eq? default '|#REQUIRED|)
+ (eq? default '|#IMPLIED|))
+ (emit-string (symbol-name default) ctx))
+ ((and (pair? default) (eq? (car default) '|#FIXED|))
+ (emit-string (symbol-name (car default)) ctx)
(emit-string " " ctx)
(write-xml-attribute-value (cdr default) ctx))
- ((and (pair? default) (eq? (car default) 'DEFAULT))
+ ((and (pair? default) (eq? (car default) 'default))
(write-xml-attribute-value (cdr default) ctx))
(else
(error "Malformed !ATTLIST default:" default)))))))
diff --git a/v7/src/xml/xml-parser.scm b/v7/src/xml/xml-parser.scm
index 0fae4bcd4..0ba4af702 100644
--- a/v7/src/xml/xml-parser.scm
+++ b/v7/src/xml/xml-parser.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: xml-parser.scm,v 1.30 2003/08/01 03:50:16 cph Exp $
+$Id: xml-parser.scm,v 1.31 2003/08/01 19:30:55 cph Exp $
Copyright 2001,2002,2003 Massachusetts Institute of Technology
@@ -974,10 +974,10 @@ USA.
(encapsulate encapsulate-suffix
(seq (sbracket "!ELEMENT type" "(" ")"
S?
- (alt (encapsulate (lambda (v) (cons 'ALT (vector->list v)))
+ (alt (encapsulate (lambda (v) (cons 'alt (vector->list v)))
(seq parse-cp
(+ (seq S? "|" S? parse-cp))))
- (encapsulate (lambda (v) (cons 'SEQ (vector->list v)))
+ (encapsulate (lambda (v) (cons 'seq (vector->list v)))
(seq parse-cp
(* (seq S? "," S? parse-cp)))))
S?)
@@ -1005,14 +1005,14 @@ USA.
parse-required-element-name
S
;;[46]
- (alt (map intern (match (string "EMPTY")))
- (map intern (match (string "ANY")))
+ (alt (map xml-intern (match "EMPTY"))
+ (map xml-intern (match "ANY"))
;;[51]
- (encapsulate (lambda (v) (cons 'MIX (vector->list v)))
+ (encapsulate vector->list
(with-pointer p
(seq "("
S?
- "#PCDATA"
+ (map string->symbol (match "#PCDATA"))
(alt (seq S? ")")
(seq (* (seq S? "|" S?
parse-required-element-name))
@@ -1042,7 +1042,7 @@ USA.
(type (vector-ref v 1))
(default (vector-ref v 2)))
(list name type
- (if (and (not (eq? type 'CDATA))
+ (if (and (not (eq? type '|CDATA|))
(pair? default))
(list (car default)
(trim-attribute-whitespace (cadr default)))
@@ -1057,27 +1057,23 @@ USA.
(define parse-!attlist-type ;[54,57]
(*parser
- (alt (map intern
+ (alt (map xml-intern
;;[55,56]
- (alt (match (string "CDATA"))
- (match (string "IDREFS"))
- (match (string "IDREF"))
- (match (string "ID"))
- (match (string "ENTITY"))
- (match (string "ENTITIES"))
- (match (string "NMTOKENS"))
- (match (string "NMTOKEN"))))
+ (match (alt "CDATA" "IDREFS" "IDREF" "ID"
+ "ENTITY" "ENTITIES" "NMTOKENS" "NMTOKEN")))
;;[58]
- (encapsulate (lambda (v) (cons 'NOTATION (vector->list v)))
+ (encapsulate vector->list
(bracket "notation type"
- (noise (seq (string "NOTATION") S (string "(")))
+ (seq (map xml-intern (match "NOTATION"))
+ S
+ "(")
")"
S?
parse-notation-name
(* (seq S? "|" S? parse-notation-name))
S?))
;;[59]
- (encapsulate (lambda (v) (cons 'ENUMERATED (vector->list v)))
+ (encapsulate (lambda (v) (cons 'enumerated (vector->list v)))
(sbracket "enumerated type" "(" ")"
S?
parse-required-name-token
@@ -1086,16 +1082,12 @@ USA.
(define parse-!attlist-default ;[60]
(*parser
- (alt (seq "#"
- (map intern
- (alt (match (string "REQUIRED"))
- (match (string "IMPLIED")))))
+ (alt (map string->symbol (match (alt "#REQUIRED" "#IMPLIED")))
(encapsulate (lambda (v) (cons (vector-ref v 0) (vector-ref v 1)))
- (seq "#"
- (map intern (match (string "FIXED")))
+ (seq (map string->symbol (match "#FIXED"))
S
parse-attribute-value))
- (encapsulate (lambda (v) (cons 'DEFAULT (vector-ref v 0)))
+ (encapsulate (lambda (v) (cons 'default (vector-ref v 0)))
parse-attribute-value))))
(define parse-!entity ;[70,71,72,73,74,76]
@@ -1203,7 +1195,7 @@ USA.
(seq (char #\") (* (alphabet a2)) (char #\"))
(seq (char #\') (* (alphabet a3)) (char #\'))))
parse-parameter-entity-reference))
- (match (string ">")))))))))))
+ (match ">"))))))))))
(define (reparse-text v parser description ptr)
(let ((v (coalesce-elements v)))
@@ -1297,7 +1289,7 @@ USA.
S?
parse-parameter-entity-reference
S?
- (match (string "[")))
+ (match "["))
(match (string conditional-end))
(match (* match-!ignore-contents)))))))