scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Changes from V200-alpha3 of PLT.

This commit is contained in:
mainzelm 2001-12-14 14:09:35 +00:00
parent 29161884e9
commit 75633864c3
6 changed files with 292 additions and 176 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

131
scheme/xml/doc.txt
View File

@ -32,6 +32,11 @@ Functions
XML documents contain exactly one element. It throws an xml-read:error XML documents contain exactly one element. It throws an xml-read:error
if there isn't any element or if there are more than one element. if there isn't any element or if there are more than one element.
Malformed xml is reported with source locations in
the form `l.c/o', where l is the line number, c is
the column number and o is the number of characters
from the beginning of the file.
> write-xml : Document [Output-port] -> Void > write-xml : Document [Output-port] -> Void
writes a document to the given or current output port, currently writes a document to the given or current output port, currently
ignoring everything except the document's root element. ignoring everything except the document's root element.
@ -131,50 +136,148 @@ Note: Users of the XML collection don't need to know most of these definitions.
Note: Xexpr is the only important one to understand. Even then, Note: Xexpr is the only important one to understand. Even then,
Processing-instructions may be ignored. Processing-instructions may be ignored.
> Xexpr ::= String > Xexpr = String
| (list* Symbol (listof (list Symbol String)) (list Xexpr)) | (list* Symbol (listof (list Symbol String)) (list Xexpr))
| (cons Symbol (listof Xexpr)) ;; an element with no attributes | (cons Symbol (listof Xexpr)) ;; an element with no attributes
| Symbol ;; symbolic entities such as   | Symbol ;; symbolic entities such as  
| Number ;; numeric entities like  | Number ;; numeric entities like 
| Misc | Misc
> Document ::= (make-document Prolog Element (listof Processing-instruction)) > Document = (make-document Prolog Element (listof Processing-instruction))
(define-struct document (prolog element misc)) (define-struct document (prolog element misc))
> Prolog ::= (make-prolog (listof Misc) #f) > Prolog = (make-prolog (listof Misc) Document-type [Misc ...])
(define-struct prolog (misc dtd)) (define-struct prolog (misc dtd misc2))
The last field is a (listof Misc), but the maker accepts optional
arguments instead for backwards compatibility.
> Element ::= (make-element Location Location > Document-type = #f | (make-document-type Symbol External-dtd #f)
(define-struct document-type (name external inlined))
> External-dtd = (make-external-dtd/public str str)
| (make-external-dtd/system str)
| #f
(define-struct external-dtd (system))
(define-struct (external-dtd/public external-dtd) (public))
(define-struct (external-dtd/system external-dtd) ())
> Element = (make-element Location Location
Symbol Symbol
(listof Attribute) (listof Attribute)
(listof Content)) (listof Content))
(define-struct (element struct:source) (name attributes content)) (define-struct (element struct:source) (name attributes content))
> Attribute ::= (make-attribute Location Location Symbol String) > Attribute = (make-attribute Location Location Symbol String)
(define-struct (attribute struct:source) (name value)) (define-struct (attribute struct:source) (name value))
> Content ::= Pcdata > Content = Pcdata
| Element | Element
| Entity | Entity
| Misc | Misc
Misc ::= Comment Misc = Comment
| Processing-instruction | Processing-instruction
> Pcdata ::= (make-pcdata Location Location String) > Pcdata = (make-pcdata Location Location String)
(define-struct (pcdata struct:source) (string)) (define-struct (pcdata struct:source) (string))
> Entity ::= (make-entity (U Nat Symbol)) > Entity = (make-entity (U Nat Symbol))
(define-struct entity (text)) (define-struct entity (text))
> Processing-instruction ::= (make-pi Location Location String (list String)) > Processing-instruction = (make-pi Location Location String (list String))
(define-struct (pi struct:source) (target-name instruction)) (define-struct (pi struct:source) (target-name instruction))
> Comment ::= (make-comment String) > Comment = (make-comment String)
(define-struct comment (text)) (define-struct comment (text))
Source ::= (make-source Location Location) Source = (make-source Location Location)
(define-struct source (start stop)) (define-struct source (start stop))
Location ::= Nat Location = Nat
| Symbol | Symbol
The PList Library
=================
Files: plist.ss
The PList library provides the ability to read and write xml documents which
conform to the "plist" DTD, used to store 'dictionaries' of string - value
associations.
To Load
=======
(require (lib "plist.ss" "xml"))
Functions
=========
> read-plist : Port -> PLDict
reads a plist from a port, and produces a 'dict' x-expression
> write-plist : PLDict Port -> Void
writes a plist to the given port. May raise the exn:application:type
exception if the plist is badly formed.
Datatypes
=========
NB: all of these are subtypes of x-expression:
> PLDict = (list 'dict Assoc-pair ...)
> PLAssoc-pair = (list 'assoc-pair String PLValue)
> PLValue = String
| (list 'true)
| (list 'false)
| (list 'integer Integer)
| (list 'real Real)
| PLDict
| PLArray
> PLArray = (list 'array PLValue ...)
In fact, the PList DTD also defines Data and Date types, but we're ignoring
these for the moment.
Examples
========
Here's a sample PLDict:
(define my-dict
`(dict (assoc-pair "first-key"
"just a string
with some whitespace in it")
(assoc-pair "second-key"
(false))
(assoc-pair "third-key"
(dict ))
(assoc-pair "fourth-key"
(dict (assoc-pair "inner-key"
(real 3.432))))
(assoc-pair "fifth-key"
(array (integer 14)
"another string"
(true)))
(assoc-pair "sixth-key"
(array))))
Let's write it to disk:
(call-with-output-file "/Users/clements/tmp.plist"
(lambda (port)
(write-plist my-dict port))
'truncate)
Let's read it back from the disk:
(define new-dict
(call-with-input-file "/Users/clements/tmp.plist"
(lambda (port)
(read-plist port))))

7
scheme/xml/plt.scm
View File

@ -106,9 +106,12 @@
;;; HACK! ;;; HACK!
(define (make-parameter val) (define (make-parameter val . maybe-guard)
(if (null? maybe-guard)
(lambda () (lambda ()
val)) val)
(lambda ()
((car maybe-guard) val))))
(define (list* . args) (define (list* . args)
(if (null? (cdr args)) (if (null? (cdr args))

183
scheme/xml/reader.scm
View File

@ -1,118 +1,3 @@
; Taken directly from the SRFI document.
(define-syntax let-values
(syntax-rules ()
((let-values (?binding ...) ?body0 ?body1 ...)
(let-values "bind" (?binding ...) () (begin ?body0 ?body1 ...)))
((let-values "bind" () ?tmps ?body)
(let ?tmps ?body))
((let-values "bind" ((?b0 ?e0) ?binding ...) ?tmps ?body)
(let-values "mktmp" ?b0 ?e0 () (?binding ...) ?tmps ?body))
((let-values "mktmp" () ?e0 ?args ?bindings ?tmps ?body)
(call-with-values
(lambda () ?e0)
(lambda ?args
(let-values "bind" ?bindings ?tmps ?body))))
((let-values "mktmp" (?a . ?b) ?e0 (?arg ...) ?bindings (?tmp ...) ?body)
(let-values "mktmp" ?b ?e0 (?arg ... x) ?bindings (?tmp ... (?a x)) ?body))
((let-values "mktmp" ?a ?e0 (?arg ...) ?bindings (?tmp ...) ?body)
(call-with-values
(lambda () ?e0)
(lambda (?arg ... . x)
(let-values "bind" ?bindings (?tmp ... (?a x)) ?body))))))
(define-syntax let*-values
(syntax-rules ()
((let*-values () ?body0 ?body1 ...)
(begin ?body0 ?body1 ...))
((let*-values (?binding0 ?binding1 ...) ?body0 ?body1 ...)
(let-values (?binding0)
(let*-values (?binding1 ...) ?body0 ?body1 ...)))))
(define (add1 x) (+ x 1))
(define-syntax when
(syntax-rules
()
((when test expr ...)
(if test (begin expr ...)))))
(define-syntax unless
(syntax-rules
()
((unless test expr ...)
(if (not test) (begin expr ...)))))
(define (sub1 x)
(- x 1))
(define (void . a)
(if #f #f))
(define-syntax begin0
(syntax-rules
()
((begin0 expr1 expr ...)
(let ((r expr1))
(begin expr ...)
r))))
(define andmap
(lambda (f list0 . lists)
(if (null? list0)
(and)
(let loop ((lists (cons list0 lists)))
(if (null? (cdr (car lists)))
(apply f (map car lists))
(and (apply f (map car lists))
(loop (map cdr lists))))))))
(define null '())
; stolen from mzlib/functior.ss
(define (quicksort l less-than)
(let* ((v (list->vector l))
(count (vector-length v)))
(let loop ((min 0)(max count))
(if (< min (sub1 max))
(let ((pval (vector-ref v min)))
(let pivot-loop ((pivot min)
(pos (add1 min)))
(if (< pos max)
(let ((cval (vector-ref v pos)))
(if (less-than cval pval)
(begin
(vector-set! v pos (vector-ref v pivot))
(vector-set! v pivot cval)
(pivot-loop (add1 pivot) (add1 pos)))
(pivot-loop pivot (add1 pos))))
(if (= min pivot)
(loop (add1 pivot) max)
(begin
(loop min pivot)
(loop pivot max))))))))
(vector->list v)))
;;; HACK!
(define call/ec call-with-current-continuation)
(define-syntax let/ec
(syntax-rules
()
((let/ec k expr ...)
(call-with-current-continuation (lambda (k) expr ...)))))
;;; HACK!
(define (make-parameter val)
(lambda ()
val))
;;;;;;;;;;;
;; Token ::= Contents | Start-tag | End-tag | Eof ;; Token ::= Contents | Start-tag | End-tag | Eof
(define read-comments (make-parameter #f)) (define read-comments (make-parameter #f))
@ -137,7 +22,7 @@
(error 'read-xml "extra stuff at end of document ~a" end-of-file)) (error 'read-xml "extra stuff at end of document ~a" end-of-file))
misc1)))) misc1))))
;; read-misc : Input-port (-> Nat) -> (listof Misc) Token ;; read-misc : Input-port (-> Location) -> (listof Misc) Token
(define (read-misc in pos) (define (read-misc in pos)
(let read-more () (let read-more ()
(let ((x (lex in pos))) (let ((x (lex in pos)))
@ -149,7 +34,7 @@
(read-more)) (read-more))
(else (values null x)))))) (else (values null x))))))
;; read-element : Start-tag Input-port (-> Nat) -> Element ;; read-element : Start-tag Input-port (-> Location) -> Element
(define (read-element start in pos) (define (read-element start in pos)
(let ((name (start-tag-name start)) (let ((name (start-tag-name start))
(a (source-start start)) (a (source-start start))
@ -160,12 +45,19 @@
(let ((x (lex in pos))) (let ((x (lex in pos)))
(cond (cond
((eof-object? x) ((eof-object? x)
(error 'read-xml "unclosed ~a tag at [~a ~a]" name a b)) (error 'read-xml "unclosed ~a tag at [~a ~a]" name
(format-source a)
(format-source b)))
((start-tag? x) (cons (read-element x in pos) (read-content))) ((start-tag? x) (cons (read-element x in pos) (read-content)))
((end-tag? x) ((end-tag? x)
(unless (eq? name (end-tag-name x)) (unless (eq? name (end-tag-name x))
(error 'read-xml "start tag ~a at [~a ~a] doesn't match end tag ~a at [~a ~a]" (error 'read-xml "start tag ~a at [~a ~a] doesn't match end tag ~a at [~a ~a]"
name a b (end-tag-name x) (source-start x) (source-stop x))) name
(format-source a)
(format-source b)
(end-tag-name x)
(format-source (source-start x))
(format-source (source-stop x))))
null) null)
((entity? x) (cons (expand-entity x) (read-content))) ((entity? x) (cons (expand-entity x) (read-content)))
((comment? x) (if (read-comments) ((comment? x) (if (read-comments)
@ -191,7 +83,7 @@
((apos) "'") ((apos) "'")
(else #f))) (else #f)))
;; lex : Input-port (-> Nat) -> Token ;; lex : Input-port (-> Location) -> Token
(define (lex in pos) (define (lex in pos)
(let ((c (peek-char in))) (let ((c (peek-char in)))
(cond (cond
@ -200,7 +92,7 @@
((eq? c #\<) (lex-tag-cdata-pi-comment in pos)) ((eq? c #\<) (lex-tag-cdata-pi-comment in pos))
(else (lex-pcdata in pos))))) (else (lex-pcdata in pos)))))
;; lex-entity : Input-port (-> Nat) -> Entity ;; lex-entity : Input-port (-> Location) -> Entity
(define (lex-entity in pos) (define (lex-entity in pos)
(let ((start (pos))) (let ((start (pos)))
(read-char in) (read-char in)
@ -221,7 +113,7 @@
(lex-error in pos "expected ; at the end of an entity"))))))) (lex-error in pos "expected ; at the end of an entity")))))))
(make-entity start (pos) data)))) (make-entity start (pos) data))))
;; lex-tag-cdata-pi-comment : Input-port (-> Nat) -> Start-tag | Element | End-tag | Pcdata | Pi | Comment ;; lex-tag-cdata-pi-comment : Input-port (-> Location) -> Start-tag | Element | End-tag | Pcdata | Pi | Comment
(define (lex-tag-cdata-pi-comment in pos) (define (lex-tag-cdata-pi-comment in pos)
(let ((start (pos))) (let ((start (pos)))
(read-char in) (read-char in)
@ -268,9 +160,9 @@
(lex-error in pos "expected > to close empty element ~a" name)) (lex-error in pos "expected > to close empty element ~a" name))
(make-element start (pos) name attrs null)) (make-element start (pos) name attrs null))
((#\>) (make-start-tag start (pos) name attrs)) ((#\>) (make-start-tag start (pos) name attrs))
(else (lex-error in pos "expected / or > to close tag ~a" name)))))))) (else (lex-error in pos "expected / or > to close tag `~a'" name))))))))
;; lex-attributes : Input-port (-> Nat) -> (listof Attribute) ;; lex-attributes : Input-port (-> Location) -> (listof Attribute)
(define (lex-attributes in pos) (define (lex-attributes in pos)
(quicksort (let loop () (quicksort (let loop ()
(skip-space in) (skip-space in)
@ -285,7 +177,7 @@
((eq? na nb) (lex-error in pos "duplicated attribute name ~a" na)) ((eq? na nb) (lex-error in pos "duplicated attribute name ~a" na))
(else (string<? (symbol->string na) (symbol->string nb)))))))) (else (string<? (symbol->string na) (symbol->string nb))))))))
;; lex-attribute : Input-port (-> Nat) -> Attribute ;; lex-attribute : Input-port (-> Location) -> Attribute
(define (lex-attribute in pos) (define (lex-attribute in pos)
(let ((start (pos)) (let ((start (pos))
(name (lex-name in pos))) (name (lex-name in pos)))
@ -321,7 +213,7 @@
(read-char in) (read-char in)
(loop))))) (loop)))))
;; lex-pcdata : Input-port (-> Nat) -> Pcdata ;; lex-pcdata : Input-port (-> Location) -> Pcdata
;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec ;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec
(define (lex-pcdata in pos) (define (lex-pcdata in pos)
(let ((start (pos)) (let ((start (pos))
@ -338,7 +230,7 @@
(pos) (pos)
(list->string data)))) (list->string data))))
;; lex-name : Input-port (-> Nat) -> Symbol ;; lex-name : Input-port (-> Location) -> Symbol
(define (lex-name in pos) (define (lex-name in pos)
(let ((c (read-char in))) (let ((c (read-char in)))
(unless (name-start? c) (unless (name-start? c)
@ -351,7 +243,7 @@
(cons (read-char in) (lex-rest))) (cons (read-char in) (lex-rest)))
(else null)))))))) (else null))))))))
;; skip-dtd : Input-port (-> Nat) -> Void ;; skip-dtd : Input-port (-> Location) -> Void
(define (skip-dtd in pos) (define (skip-dtd in pos)
(let skip () (let skip ()
(case (non-eof read-char in pos) (case (non-eof read-char in pos)
@ -380,7 +272,7 @@
(eq? ch #\.) (eq? ch #\.)
(eq? ch #\-))) (eq? ch #\-)))
;; read-until : Char Input-port (-> Nat) -> String ;; read-until : Char Input-port (-> Location) -> String
;; discards the stop character, too ;; discards the stop character, too
(define (read-until char in pos) (define (read-until char in pos)
(list->string (list->string
@ -390,14 +282,14 @@
((eq? c char) null) ((eq? c char) null)
(else (cons c (read-more)))))))) (else (cons c (read-more))))))))
;; non-eof : (Input-port -> (U Char Eof)) Input-port (-> Nat) -> Char ;; non-eof : (Input-port -> (U Char Eof)) Input-port (-> Location) -> Char
(define (non-eof f in pos) (define (non-eof f in pos)
(let ((c (f in))) (let ((c (f in)))
(cond (cond
((eof-object? c) (lex-error in pos "unexpected eof")) ((eof-object? c) (lex-error in pos "unexpected eof"))
(else c)))) (else c))))
;; gen-read-until-string : String -> Input-port (-> Nat) -> String ;; gen-read-until-string : String -> Input-port (-> Location) -> String
;; uses Knuth-Morris-Pratt from ;; uses Knuth-Morris-Pratt from
;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876 ;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876
;; discards stop from input ;; discards stop from input
@ -436,13 +328,15 @@
(define lex-pi-data (gen-read-until-string "?>")) (define lex-pi-data (gen-read-until-string "?>"))
(define lex-cdata-contents (gen-read-until-string "]]>")) (define lex-cdata-contents (gen-read-until-string "]]>"))
;; positionify : Input-port -> Input-port (-> Nat) ;; positionify : Input-port -> Input-port (-> Location)
;; Well, this really depends on scsh-0.6 ;; Well, this really depends on scsh-0.6
;; For S48 you probably need to do something completely different ;; For S48 you probably need to do something completely different
(define (positionify in) (define (positionify in)
(let ((n 0); port-limit as absolute value (let ((line 1)
(char 0)
(offset 0)
(old-handler (port-handler in))) (old-handler (port-handler in)))
(let ((handler (make-buffered-input-port-handler (let ((handler (make-buffered-input-port-handler
(port-handler-discloser old-handler) (port-handler-discloser old-handler)
@ -452,17 +346,32 @@
((port-handler-buffer-proc old-handler) ((port-handler-buffer-proc old-handler)
data buffer start needed))) data buffer start needed)))
(if (number? res) (if (number? res)
(set! n (+ n res))) (begin
(set! char (add1 char))
(set! offset (add1 offset))
(let ((c (peek-char in)))
(when (equal? c #\newline)
(set! line (+ line 1))
(set! char 0))
c)))
res)) res))
(port-handler-ready? old-handler) (port-handler-ready? old-handler)
(port-handler-steal old-handler)))) (port-handler-steal old-handler))))
(set-port-handler! in handler) (set-port-handler! in handler)
(values in (values in
(lambda () (lambda ()
(- n (- (port-limit in) (port-index in)))))))) (make-location line char offset))))))
; (- n (- (port-limit in) (port-index in))))))))
;; lex-error : Input-port String (-> Nat) TST* -> alpha ;; lex-error : Input-port String (-> Location) TST* -> alpha
(define (lex-error in pos str . rest) (define (lex-error in pos str . rest)
(error 'lex-error " at positon:" (pos) str rest)) (error 'lex-error " at position:" (format-source (pos)) str rest))
;; format-source : Location -> string
;; to format the source location for an error message
(define (format-source loc)
(if (location? loc)
(format #f "~a.~a/~a" (location-line loc) (location-char loc) (location-offset loc))
(format #f "~a" loc)))

79
scheme/xml/structures.scm
View File

@ -1,8 +1,15 @@
;; Location ::= Nat | Symbol ; Location = (make-location Nat Nat) | Symbol
(define-record-type location :location
(make-location line char offset)
location?
(line location-line)
(char location-char)
(offset location-offset))
;; Source ::= (make-source Location Location) ;; Source ::= (make-source Location Location)
(define-record-type source :source (define-record-type source :source
(make-source start stop) (make-source start stop)
source? really-source?
(start really-source-start) (start really-source-start)
(stop really-source-stop)) (stop really-source-stop))
@ -26,6 +33,16 @@
((end-tag? obj) (end-tag-stop obj)) ((end-tag? obj) (end-tag-stop obj))
(else (really-source-stop obj)))) (else (really-source-stop obj))))
(define (does-any-satisfy? preds obj)
(if (null? preds)
#f
(or ((car preds) obj) (does-any-satisfy? (cdr preds) obj))))
(define (source? obj)
(does-any-satisfy? (list really-source? element? attribute? pcdata?
entity? pi? start-tag? end-tag?)
obj))
;; Document ::= (make-document Prolog Element (listof Misc)) ;; Document ::= (make-document Prolog Element (listof Misc))
(define-record-type document :document (define-record-type document :document
(make-document prolog element misc) (make-document prolog element misc)
@ -34,12 +51,64 @@
(element document-element) (element document-element)
(misc document-misc)) (misc document-misc))
;; Prolog ::= (make-prolog (listof Misc) #f) ; Prolog = (make-prolog (listof Misc) Document-type [Misc ...])
; The Misc items after the Document-type are optional arguments to maintain
; backward compatability with older versions of the XML library.
;(define-struct prolog (misc dtd misc2))
(define-record-type prolog :prolog (define-record-type prolog :prolog
(make-prolog misc dtd) (really-make-prolog misc dtd misc2)
prolog? prolog?
(misc prolog-misc) (misc prolog-misc)
(dtd prolog-dtd)) (dtd prolog-dtd)
(misc2 prolog-misc2))
(define (make-prolog misc dtd misc2)
(really-make-prolog misc dtd misc2))
;;; Document-type = (make-document-type sym External-dtd #f)
;;; | #f
(define-record-type document-type :document-type
(make-document-type name external inlined)
really-document-type?
(name document-type-name)
(external document-type-external)
(inlined document-type-inlined))
;;; External-dtd = (make-external-dtd/public str str)
;;; | (make-external-dtd/system str)
;;; | #f
(define-record-type external-dtd :external-dtd
(make-external-dtd system)
really-external-dtd?
(system really-external-dtd-system))
(define (external-dtd-system external-dtd)
(cond ((really-external-dtd? external-dtd)
(really-external-dtd-system external-dtd))
((external-dtd/public? external-dtd)
(external-dtd/public-system external-dtd))
((external-dtd/system? external-dtd)
(external-dtd/system-system external-dtd))
(else (error "bottom of external-dtd-system" external-dtd))))
(define (external-dtd? obj)
(does-any-satisfy? (list really-external-dtd? external-dtd/public?
external-dtd/system?)
obj))
(define-record-type external-dtd/public :external-dtd/public
(make-external-dtd/public system public)
external-dtd/public?
(system external-dtd/public-system)
(public external-dtd/public-public))
(define-record-type external-dtd/system :external-dtd/system
(make-external-dtd/system system)
external-dtd/system?
(system external-dtd/system-system))
;; Element ::= (make-element Location Location Symbol (listof Attribute) (listof Content)) ;; Element ::= (make-element Location Location Symbol (listof Attribute) (listof Content))
(define-record-type element :element (define-record-type element :element

34
scheme/xml/writer.scm
View File

@ -3,7 +3,12 @@
;;(define empty-tag-shorthand (make-parameter void)) ;;(define empty-tag-shorthand (make-parameter void))
;; (empty-tag-shorthand) : (U 'always 'never (listof Symbol)) ;; (empty-tag-shorthand) : (U 'always 'never (listof Symbol))
(define empty-tag-shorthand (make-parameter 'always)) (define empty-tag-shorthand
(make-parameter 'always
(lambda (x)
(if (or (eq? x 'always) (eq? x 'never) (and (list? x) (andmap symbol? x)))
x
(error 'empty-tag-shorthand "expected 'always, 'never, or a list of symbols: received ~a" x)))))
(define html-empty-tags '(param meta link isindex input img hr frame col br basefont base area)) (define html-empty-tags '(param meta link isindex input img hr frame col br basefont base area))
@ -16,7 +21,8 @@
;; gen-write/display-xml/content : (Nat Output-port -> Void) -> Content [Output-Port]-> Void ;; gen-write/display-xml/content : (Nat Output-port -> Void) -> Content [Output-Port]-> Void
(define (gen-write/display-xml/content dent) (define (gen-write/display-xml/content dent)
(var-argify (lambda (c out) (write-xml-content c 0 dent out)))) (var-argify (lambda (c out)
(write-xml-content c 0 dent out))))
;; indent : Nat Output-port -> Void ;; indent : Nat Output-port -> Void
(define (indent n out) (define (indent n out)
@ -35,10 +41,29 @@
;; gen-write/display-xml : (Content [Output-port] -> Void) -> Document [Output-port] -> Void ;; gen-write/display-xml : (Content [Output-port] -> Void) -> Document [Output-port] -> Void
(define (gen-write/display-xml output-content) (define (gen-write/display-xml output-content)
(var-argify (lambda (doc out) (var-argify (lambda (doc out)
(display-outside-misc (prolog-misc (document-prolog doc)) out) (let ((prolog (document-prolog doc)))
(display-outside-misc (prolog-misc prolog) out)
(display-dtd (prolog-dtd prolog) out)
(display-outside-misc (prolog-misc2 prolog) out))
(output-content (document-element doc) out) (output-content (document-element doc) out)
(display-outside-misc (document-misc doc) out)))) (display-outside-misc (document-misc doc) out))))
; display-dtd : document-type oport -> void
(define (display-dtd dtd out)
(when dtd
(fprintf out "<!DOCTYPE ~a" (document-type-name dtd))
(let ((external (document-type-external dtd)))
(cond
((external-dtd/public? external)
(fprintf out " PUBLIC \"~a\" \"~a\""
(external-dtd/public-public external)
(external-dtd-system external)))
((external-dtd/system? external)
(fprintf out " SYSTEM \"~a\"" (external-dtd-system external)))
((not external) (void))))
(display ">" out)
(newline out)))
;; write-xml : Document [Output-port] -> Void ;; write-xml : Document [Output-port] -> Void
(define write-xml (gen-write/display-xml write-xml/content)) (define write-xml (gen-write/display-xml write-xml/content))
@ -50,7 +75,8 @@
(for-each (lambda (x) (for-each (lambda (x)
((cond ((cond
((comment? x) write-xml-comment) ((comment? x) write-xml-comment)
((pi? x) write-xml-pi)) x 0 void out) ((pi? x) write-xml-pi)
(else (error "bottom " x))) x 0 void out)
(newline out)) (newline out))
misc)) misc))

8
scheme/xml/xml-packages.scm
View File

@ -1,8 +1,13 @@
(define-interface xml-structures-interface (define-interface xml-structures-interface
(export source-start (export source-start
source-stop source-stop
make-location location? location-line location-char location-offset
make-document document? document-prolog document-element document-misc make-document document? document-prolog document-element document-misc
make-prolog prolog? prolog-misc prolog-dtd make-prolog prolog? prolog-misc prolog-dtd prolog-misc2
make-document-type document-type-name document-type-external
external-dtd-system external-dtd/system?
make-external-dtd/public external-dtd/public? external-dtd/public-public
make-external-dtd/system
make-element element? element-name element-attributes element-content make-element element? element-name element-attributes element-content
make-attribute attribute? attribute-name attribute-value make-attribute attribute? attribute-name attribute-value
make-pcdata pcdata? pcdata-string make-pcdata pcdata? pcdata-string
@ -15,6 +20,7 @@
(define-structure xml-structures xml-structures-interface (define-structure xml-structures xml-structures-interface
(open scheme (open scheme
signals
extended-ports extended-ports
define-record-types) define-record-types)
(files structures)) (files structures))