Merge branch 'master' of git://factorcode.org/git/factor

basis/html/templates/chloe/compiler/compiler.factor

@@ -87,7 +87,7 @@ DEFER: compile-element
         { [ dup [ tag? ] [ xml? ] bi or ] [ compile-tag ] }
         { [ dup string? ] [ escape-string [write] ] }
         { [ dup comment? ] [ drop ] }
-        [ [ write-item ] [code-with] ]
+        [ [ write-xml-chunk ] [code-with] ]
     } cond ;
 
 : with-compiler ( quot -- quot' )

basis/syndication/syndication.factor

@@ -81,7 +81,7 @@ TUPLE: entry title url description date ;
         [
             { "content" "summary" } any-tag-named
             dup children>> [ string? not ] contains?
-            [ children>> [ write-chunk ] with-string-writer ]
+            [ children>> [ write-xml-chunk ] with-string-writer ]
             [ children>string ] if >>description
         ]
         [

basis/xml/data/data.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences sequences.private assocs arrays
 delegate.protocols delegate vectors accessors multiline
-macros words quotations combinators slots ;
+macros words quotations combinators slots fry ;
 IN: xml.data
 
 TUPLE: name space main url ;
@@ -34,8 +34,25 @@ C: <contained> contained
 TUPLE: comment text ;
 C: <comment> comment
 
-TUPLE: directive text ;
+TUPLE: directive ;
-C: <directive> directive
+
+TUPLE: element-decl < directive name content-spec ;
+C: <element-decl> element-decl
+
+TUPLE: attlist-decl < directive name att-defs ;
+C: <attlist-decl> attlist-decl
+
+TUPLE: entity-decl < directive name def ;
+C: <entity-decl> entity-decl
+
+TUPLE: system-id system-literal ;
+C: <system-id> system-id
+
+TUPLE: public-id pubid-literal system-literal ;
+C: <public-id> public-id
+
+TUPLE: doctype-decl < directive name external-id internal-subset ;
+C: <doctype-decl> doctype-decl
 
 TUPLE: instruction text ;
 C: <instruction> instruction
@@ -47,7 +64,7 @@ TUPLE: attrs alist ;
 C: <attrs> attrs
 
 : attr@ ( key alist -- index {key,value} )
-    >r assure-name r> alist>>
+    [ assure-name ] dip alist>>
     [ first names-match? ] with find ;
 
 M: attrs at*
@@ -56,7 +73,7 @@ M: attrs set-at
     2dup attr@ nip [
         2nip set-second
     ] [
-        >r assure-name swap 2array r>
+        [ assure-name swap 2array ] dip
         [ alist>> ?push ] keep (>>alist)
     ] if* ;
 
@@ -67,7 +84,7 @@ M: attrs >alist alist>> ;
 : >attrs ( assoc -- attrs )
     dup [
         V{ } assoc-clone-like
-        [ >r assure-name r> ] assoc-map
+        [ [ assure-name ] dip ] assoc-map
     ] when <attrs> ;
 M: attrs assoc-like
     drop dup attrs? [ >attrs ] unless ;
@@ -107,9 +124,9 @@ M: tag like
 MACRO: clone-slots ( class -- tuple )
     [
         "slots" word-prop
-        [ name>> reader-word 1quotation [ clone ] compose ] map
+        [ name>> reader-word '[ _ execute clone ] ] map
-        [ cleave ] curry
+        '[ _ cleave ]
-    ] [ [ boa ] curry ] bi compose ;
+    ] [ '[ _ boa ] ] bi compose ;
 
 M: tag clone
     tag clone-slots ;
@@ -129,7 +146,7 @@ CONSULT: name xml body>> ;
 
 <PRIVATE
 : tag>xml ( xml tag -- newxml )
-    >r [ prolog>> ] [ before>> ] [ after>> ] tri r>
+    [ [ prolog>> ] [ before>> ] [ after>> ] tri ] dip
     swap <xml> ;
 
 : seq>xml ( xml seq -- newxml )

basis/xml/entities/entities.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2006 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces make kernel assocs sequences ;
+USING: namespaces make kernel assocs sequences fry ;
 IN: xml.entities
 
 : entities-out
@@ -19,7 +19,7 @@ IN: xml.entities
 
 : escape-string-by ( str table -- escaped )
     #! Convert <, >, &, ' and " to HTML entities.
-    [ [ dupd at [ % ] [ , ] ?if ] curry each ] "" make ;
+    [ '[ dup _ at [ % ] [ , ] ?if ] each ] "" make ;
 
 : escape-string ( str -- newstr )
     entities-out escape-string-by ;

basis/xml/errors/errors-tests.factor

@@ -1,8 +1,9 @@
-USING: continuations xml xml.errors tools.test kernel arrays xml.data state-parser quotations ;
+USING: continuations xml xml.errors tools.test kernel arrays
+xml.data state-parser quotations fry ;
 IN: xml.errors.tests
 
 : xml-error-test ( expected-error xml-string -- )
-    [ string>xml ] curry swap [ = ] curry must-fail-with ;
+    '[ _ string>xml ] swap '[ _ = ] must-fail-with ;
 
 T{ no-entity f 1 10 "nbsp" } "<x>&nbsp;</x>" xml-error-test
 T{ mismatched f 1 8 T{ name f "" "x" "" } T{ name f "" "y" "" }
@@ -24,5 +25,3 @@ T{ pre/post-content f "x" t } "x<y/>" xml-error-test
 T{ versionless-prolog f 1 8 } "<?xml?><x/>" xml-error-test
 T{ bad-instruction f 1 11 T{ instruction f "xsl" }
 } "<x><?xsl?></x>" xml-error-test
-T{ bad-directive f 1 15 T{ directive f "DOCTYPE" }
-} "<x/><!DOCTYPE>" xml-error-test

basis/xml/errors/errors.factor

@@ -5,13 +5,13 @@ debugger sequences state-parser accessors summary
 namespaces io.streams.string xml.backend ;
 IN: xml.errors
 
-TUPLE: multitags ;
+ERROR: multitags ;
-C: <multitags> multitags
+
 M: multitags summary ( obj -- str )
     drop "XML document contains multiple main tags" ;
 
-TUPLE: pre/post-content string pre? ;
+ERROR: pre/post-content string pre? ;
-C: <pre/post-content> pre/post-content
+
 M: pre/post-content summary ( obj -- str )
     [
         "The text string:" print
@@ -22,8 +22,10 @@ M: pre/post-content summary ( obj -- str )
     ] with-string-writer ;
 
 TUPLE: no-entity < parsing-error thing ;
-: <no-entity> ( string -- error )
+
-    \ no-entity parsing-error swap >>thing ;
+: no-entity ( string -- * )
+    \ no-entity parsing-error swap >>thing throw ;
+
 M: no-entity summary ( obj -- str )
     [
         dup call-next-method write
@@ -31,8 +33,10 @@ M: no-entity summary ( obj -- str )
     ] with-string-writer ;
 
 TUPLE: xml-string-error < parsing-error string ; ! this should not exist
-: <xml-string-error> ( string -- xml-string-error )
+
-    \ xml-string-error parsing-error swap >>string ;
+: xml-string-error ( string -- * )
+    \ xml-string-error parsing-error swap >>string throw ;
+
 M: xml-string-error summary ( obj -- str )
     [
         dup call-next-method write
@@ -40,8 +44,10 @@ M: xml-string-error summary ( obj -- str )
     ] with-string-writer ;
 
 TUPLE: mismatched < parsing-error open close ;
-: <mismatched> ( open close -- error )
+
-    \ mismatched parsing-error swap >>close swap >>open ;
+: mismatched ( open close -- * )
+    \ mismatched parsing-error swap >>close swap >>open throw ;
+
 M: mismatched summary ( obj -- str )
     [
         dup call-next-method write
@@ -51,9 +57,12 @@ M: mismatched summary ( obj -- str )
     ] with-string-writer ;
 
 TUPLE: unclosed < parsing-error tags ;
-: <unclosed> ( -- unclosed )
+
-    unclosed parsing-error
+: unclosed ( -- * )
-        xml-stack get rest-slice [ first name>> ] map >>tags ;
+    \ unclosed parsing-error
+        xml-stack get rest-slice [ first name>> ] map >>tags
+    throw ;
+
 M: unclosed summary ( obj -- str )
     [
         dup call-next-method write
@@ -63,8 +72,10 @@ M: unclosed summary ( obj -- str )
     ] with-string-writer ;
 
 TUPLE: bad-uri < parsing-error string ;
-: <bad-uri> ( string -- bad-uri )
+
-    \ bad-uri parsing-error swap >>string ;
+: bad-uri ( string -- * )
+    \ bad-uri parsing-error swap >>string throw ;
+
 M: bad-uri summary ( obj -- str )
     [
         dup call-next-method write
@@ -72,8 +83,10 @@ M: bad-uri summary ( obj -- str )
     ] with-string-writer ;
 
 TUPLE: nonexist-ns < parsing-error name ;
-: <nonexist-ns> ( name-string -- nonexist-ns )
+
-    \ nonexist-ns parsing-error swap >>name ;
+: nonexist-ns ( name-string -- * )
+    \ nonexist-ns parsing-error swap >>name throw ;
+
 M: nonexist-ns summary ( obj -- str )
     [
         dup call-next-method write
@@ -81,8 +94,10 @@ M: nonexist-ns summary ( obj -- str )
     ] with-string-writer ;
 
 TUPLE: unopened < parsing-error ; ! this should give which tag was unopened
-: <unopened> ( -- unopened )
+
-    \ unopened parsing-error ;
+: unopened ( -- * )
+    \ unopened parsing-error throw ;
+
 M: unopened summary ( obj -- str )
     [
         call-next-method write
@@ -90,8 +105,10 @@ M: unopened summary ( obj -- str )
     ] with-string-writer ;
 
 TUPLE: not-yes/no < parsing-error text ;
-: <not-yes/no> ( text -- not-yes/no )
+
-    \ not-yes/no parsing-error swap >>text ;
+: not-yes/no ( text -- * )
+    \ not-yes/no parsing-error swap >>text throw ;
+
 M: not-yes/no summary ( obj -- str )
     [
         dup call-next-method write
@@ -101,8 +118,10 @@ M: not-yes/no summary ( obj -- str )
 
 ! this should actually print the names
 TUPLE: extra-attrs < parsing-error attrs ;
-: <extra-attrs> ( attrs -- extra-attrs )
+
-    \ extra-attrs parsing-error swap >>attrs ;
+: extra-attrs ( attrs -- * )
+    \ extra-attrs parsing-error swap >>attrs throw ;
+
 M: extra-attrs summary ( obj -- str )
     [
         dup call-next-method write
@@ -111,22 +130,26 @@ M: extra-attrs summary ( obj -- str )
     ] with-string-writer ;
 
 TUPLE: bad-version < parsing-error num ;
-: <bad-version> ( num -- error )
+
-    \ bad-version parsing-error swap >>num ;
+: bad-version ( num -- * )
+    \ bad-version parsing-error swap >>num throw ;
+
 M: bad-version summary ( obj -- str )
     [
         "XML version must be \"1.0\" or \"1.1\". Version here was " write
         num>> .
     ] with-string-writer ;
 
-TUPLE: notags ;
+ERROR: notags ;
-C: <notags> notags
+
 M: notags summary ( obj -- str )
     drop "XML document lacks a main tag" ;
 
 TUPLE: bad-prolog < parsing-error prolog ;
-: <bad-prolog> ( prolog -- bad-prolog )
+
-    \ bad-prolog parsing-error swap >>prolog ;
+: bad-prolog ( prolog -- * )
+    \ bad-prolog parsing-error swap >>prolog throw ;
+
 M: bad-prolog summary ( obj -- str )
     [
         dup call-next-method write
@@ -135,8 +158,10 @@ M: bad-prolog summary ( obj -- str )
     ] with-string-writer ;
 
 TUPLE: capitalized-prolog < parsing-error name ;
-: <capitalized-prolog> ( name -- capitalized-prolog )
+
-    \ capitalized-prolog parsing-error swap >>name ;
+: capitalized-prolog ( name -- capitalized-prolog )
+    \ capitalized-prolog parsing-error swap >>name throw ;
+
 M: capitalized-prolog summary ( obj -- str )
     [
         dup call-next-method write
@@ -146,8 +171,10 @@ M: capitalized-prolog summary ( obj -- str )
     ] with-string-writer ;
 
 TUPLE: versionless-prolog < parsing-error ;
-: <versionless-prolog> ( -- versionless-prolog )
+
-    \ versionless-prolog parsing-error ;
+: versionless-prolog ( -- * )
+    \ versionless-prolog parsing-error throw ;
+
 M: versionless-prolog summary ( obj -- str )
     [
         call-next-method write
@@ -155,23 +182,55 @@ M: versionless-prolog summary ( obj -- str )
     ] with-string-writer ;
 
 TUPLE: bad-instruction < parsing-error instruction ;
-: <bad-instruction> ( instruction -- bad-instruction )
+
-    \ bad-instruction parsing-error swap >>instruction ;
+: bad-instruction ( instruction -- * )
+    \ bad-instruction parsing-error swap >>instruction throw ;
+
 M: bad-instruction summary ( obj -- str )
     [
         dup call-next-method write
         "Misplaced processor instruction:" print
-        instruction>> write-item nl
+        instruction>> write-xml-chunk nl
     ] with-string-writer ;
 
 TUPLE: bad-directive < parsing-error dir ;
-: <bad-directive> ( directive -- bad-directive )
+
-    \ bad-directive parsing-error swap >>dir ;
+: bad-directive ( directive -- * )
+    \ bad-directive parsing-error swap >>dir throw ;
+
 M: bad-directive summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Unknown directive:" print
+        dir>> write
+    ] with-string-writer ;
+
+TUPLE: bad-doctype-decl < parsing-error ;
+
+: bad-doctype-decl ( -- * )
+    \ bad-doctype-decl parsing-error throw ;
+
+M: bad-doctype-decl summary ( obj -- str )
+    call-next-method "\nBad DOCTYPE" append ;
+
+TUPLE: bad-external-id < parsing-error ;
+
+: bad-external-id ( -- * )
+    \ bad-external-id parsing-error throw ;
+
+M: bad-external-id summary ( obj -- str )
+    call-next-method "\nBad external ID" append ;
+
+TUPLE: misplaced-directive < parsing-error dir ;
+
+: misplaced-directive ( directive -- * )
+    \ misplaced-directive parsing-error swap >>dir throw ;
+
+M: misplaced-directive summary ( obj -- str )
     [
         dup call-next-method write
         "Misplaced directive:" print
-        dir>> write-item nl
+        dir>> write-xml-chunk nl
     ] with-string-writer ;
 
 UNION: xml-parse-error multitags notags extra-attrs nonexist-ns

basis/xml/generator/generator-tests.factor

@@ -1,3 +1,3 @@
 USING: tools.test io.streams.string xml.generator xml.writer accessors ;
 [ "<html><body><a href=\"blah\"/></body></html>" ]
-[ "html" [ "body" [ "a" { { "href" "blah" } } contained*, ] tag, ] make-xml [ body>> write-item ] with-string-writer ] unit-test
+[ "html" [ "body" [ "a" { { "href" "blah" } } contained*, ] tag, ] make-xml [ body>> write-xml-chunk ] with-string-writer ] unit-test

basis/xml/generator/generator.factor

@@ -5,12 +5,11 @@ sequences ;
 IN: xml.generator
 
 : comment, ( string -- ) <comment> , ;
-: directive, ( string -- ) <directive> , ;
 : instruction, ( string -- ) <instruction> , ;
 : nl, ( -- ) "\n" , ;
 
 : (tag,) ( name attrs quot -- tag )
-    -rot >r >r V{ } make r> r> rot <tag> ; inline
+    -rot [ V{ } make ] 2dip rot <tag> ; inline
 : tag*, ( name attrs quot -- )
     (tag,) , ; inline
 

basis/xml/tests/arithmetic.factor

@@ -6,7 +6,7 @@ USING: xml io kernel math sequences strings xml.utilities tools.test math.parser
 PROCESS: calculate ( tag -- n )
 
 : calc-2children ( tag -- n n )
-    children-tags first2 >r calculate r> calculate ;
+    children-tags first2 [ calculate ] dip calculate ;
 
 TAG: number calculate
     children>string string>number ;

basis/xml/tests/funny-dtd.factor

@@ -0,0 +1,9 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: xml.tests
+USING: xml xml.writer io.files io.encodings.utf8 tools.test kernel ;
+
+[ t ] [
+    "resource:basis/xml/tests/funny-dtd.xml" utf8 file-contents string>xml
+    dup xml>string string>xml =
+] unit-test

basis/xml/tests/funny-dtd.xml

@@ -0,0 +1,2 @@
+<?xml version="1.0" standalone="yes" ?><!DOCTYPE SHOUTCASTSERVER [<!ELEMENT SHOUTCASTSERVER (CURRENTLISTENERS,PEAKLISTENERS,MAXLISTENERS,REPORTEDLISTENERS,AVERAGETIME,SERVERGENRE,SERVERURL,SERVERTITLE,SONGTITLE,SONGURL,IRC,ICQ,AIM,WEBHITS,STREAMHITS,STREAMSTATUS,BITRATE,CONTENT,VERSION,WEBDATA,LISTENERS,SONGHISTORY)><!ELEMENT CURRENTLISTENERS (#PCDATA)><!ELEMENT PEAKLISTENERS (#PCDATA)><!ELEMENT MAXLISTENERS (#PCDATA)><!ELEMENT REPORTEDLISTENERS (#PCDATA)><!ELEMENT AVERAGETIME (#PCDATA)><!ELEMENT SERVERGENRE (#PCDATA)><!ELEMENT SERVERURL (#PCDATA)><!ELEMENT SERVERTITLE (#PCDATA)><!ELEMENT SONGTITLE (#PCDATA)><!ELEMENT SONGURL (#PCDATA)><!ELEMENT IRC (#PCDATA)><!ELEMENT ICQ (#PCDATA)><!ELEMENT AIM (#PCDATA)><!ELEMENT WEBHITS (#PCDATA)><!ELEMENT STREAMHITS (#PCDATA)><!ELEMENT STREAMSTATUS (#PCDATA)><!ELEMENT BITRATE (#PCDATA)><!ELEMENT CONTENT (#PCDATA)><!ELEMENT VERSION (#PCDATA)><!ELEMENT WEBDATA (INDEX,LISTEN,PALM7,LOGIN,LOGINFAIL,PLAYED,COOKIE,ADMIN,UPDINFO,KICKSRC,KICKDST,UNBANDST,BANDST,VIEWBAN,UNRIPDST,RIPDST,VIEWRIP,VIEWXML,VIEWLOG,INVALID)><!ELEMENT INDEX (#PCDATA)><!ELEMENT LISTEN (#PCDATA)><!ELEMENT PALM7 (#PCDATA)><!ELEMENT LOGIN (#PCDATA)><!ELEMENT LOGINFAIL (#PCDATA)><!ELEMENT PLAYED (#PCDATA)><!ELEMENT COOKIE (#PCDATA)><!ELEMENT ADMIN (#PCDATA)><!ELEMENT UPDINFO (#PCDATA)><!ELEMENT KICKSRC (#PCDATA)><!ELEMENT KICKDST (#PCDATA)><!ELEMENT UNBANDST (#PCDATA)><!ELEMENT BANDST (#PCDATA)><!ELEMENT VIEWBAN (#PCDATA)><!ELEMENT UNRIPDST (#PCDATA)><!ELEMENT RIPDST (#PCDATA)><!ELEMENT VIEWRIP (#PCDATA)><!ELEMENT VIEWXML (#PCDATA)><!ELEMENT VIEWLOG (#PCDATA)><!ELEMENT INVALID (#PCDATA)><!ELEMENT LISTENERS (LISTENER*)><!ELEMENT LISTENER (HOSTNAME,USERAGENT,UNDERRUNS,CONNECTTIME, POINTER, UID)><!ELEMENT HOSTNAME (#PCDATA)><!ELEMENT USERAGENT (#PCDATA)><!ELEMENT UNDERRUNS (#PCDATA)><!ELEMENT CONNECTTIME (#PCDATA)><!ELEMENT POINTER (#PCDATA)><!ELEMENT UID (#PCDATA)><!ELEMENT SONGHISTORY (SONG*)><!ELEMENT SONG (PLAYEDAT, TITLE)><!ELEMENT PLAYEDAT (#PCDATA)><!ELEMENT TITLE (#PCDATA)>]><SHOUTCASTSERVER><CURRENTLISTENERS>0</CURRENTLISTENERS><PEAKLISTENERS>3</PEAKLISTENERS><MAXLISTENERS>500</MAXLISTENERS><REPORTEDLISTENERS>0</REPORTEDLISTENERS><AVERAGETIME>85</AVERAGETIME><SERVERGENRE>various</SERVERGENRE><SERVERURL>http://zomgwtfbbq.info</SERVERURL><SERVERTITLE>[zOMBradio][DJKyleL]</SERVERTITLE><SONGTITLE>Daft Punk - One More Time / Aerodynamic</SONGTITLE><SONGURL></SONGURL><IRC></IRC><ICQ></ICQ><AIM>arkz1372</AIM><WEBHITS>1645</WEBHITS><STREAMHITS>78</STREAMHITS><STREAMSTATUS>0</STREAMSTATUS><BITRATE>96</BITRATE><CONTENT>audio/aacp</CONTENT><VERSION>1.9.8</VERSION><WEBDATA><INDEX>61</INDEX><LISTEN>6</LISTEN><PALM7>0</PALM7><LOGIN>0</LOGIN><LOGINFAIL>30</LOGINFAIL><PLAYED>2</PLAYED><COOKIE>1</COOKIE><ADMIN>11</ADMIN><UPDINFO>1</UPDINFO><KICKSRC>0</KICKSRC><KICKDST>0</KICKDST><UNBANDST>0</UNBANDST><BANDST>0</BANDST><VIEWBAN>3</VIEWBAN><UNRIPDST>0</UNRIPDST><RIPDST>1</RIPDST><VIEWRIP>3</VIEWRIP><VIEWXML>1490</VIEWXML><VIEWLOG>3</VIEWLOG><INVALID>30</INVALID></WEBDATA><LISTENERS></LISTENERS><SONGHISTORY><SONG><PLAYEDAT>1227896017</PLAYEDAT><TITLE>Daft Punk - One More Time / Aerodynamic</TITLE></SONG></SONGHISTORY></SHOUTCASTSERVER>
+

basis/xml/tests/templating.factor

@@ -20,7 +20,7 @@ M: object (r-ref) drop ;
 
 ! Example
 
-: sample-doc
+: sample-doc ( -- string )
     {
         "<html xmlns:f='http://littledan.onigirihouse.com/namespaces/replace'>"
         "<body>"

basis/xml/tests/test.factor

@@ -4,7 +4,7 @@ IN: xml.tests
 USING: kernel xml tools.test io namespaces make sequences
 xml.errors xml.entities parser strings xml.data io.files
 xml.writer xml.utilities state-parser continuations assocs
-sequences.deep accessors ;
+sequences.deep accessors io.streams.string ;
 
 ! This is insufficient
 \ read-xml must-infer
@@ -44,10 +44,20 @@ SYMBOL: xml-file
     "c" get-id children>string
 ] unit-test
 [ "foo" ] [ "<x y='foo'/>" string>xml "y" over
-    at swap "z" >r tuck r> swap set-at
+    at swap "z" [ tuck ] dip swap set-at
     T{ name f "blah" "z" f } swap at ] unit-test
 [ "foo" ] [ "<boo><![CDATA[foo]]></boo>" string>xml children>string ] unit-test
 [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo>bar baz</foo>" ]
 [ "<foo>bar</foo>" string>xml [ " baz" append ] map xml>string ] unit-test
 [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<foo>\n  bar\n</foo>" ]
 [ "<foo>         bar            </foo>" string>xml pprint-xml>string ] unit-test
+[ "<!-- B+, B, or B--->" string>xml ] must-fail
+[ ] [ "<?xml version='1.0'?><!-- declarations for <head> & <body> --><foo/>" string>xml drop ] unit-test
+[ T{ element-decl f "br" "EMPTY" } ] [ "<!ELEMENT br EMPTY>" string>xml-chunk second ] unit-test
+[ T{ element-decl f "p" "(#PCDATA|emph)*" } ] [ "<!ELEMENT p (#PCDATA|emph)*>" string>xml-chunk second ] unit-test
+[ T{ element-decl f "%name.para;" "%content.para;" } ] [ "<!ELEMENT %name.para; %content.para;>" string>xml-chunk second ] unit-test
+[ T{ element-decl f "container" "ANY" } ] [ "<!ELEMENT container ANY>" string>xml-chunk second ] unit-test
+[ T{ doctype-decl f "foo" } ] [ "<!DOCTYPE foo>" string>xml-chunk second ] unit-test
+[ T{ doctype-decl f "foo" } ] [ "<!DOCTYPE foo >" string>xml-chunk second ] unit-test
+[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM 'blah.dtd'>" string>xml-chunk second ] unit-test
+[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo   SYSTEM \"blah.dtd\"   >" string>xml-chunk second ] unit-test

basis/xml/tests/xmode-dtd.factor

@@ -0,0 +1,9 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: xml io.encodings.utf8 io.files kernel tools.test ;
+IN: xml.tests
+
+[ ] [
+    "resource:basis/xmode/xmode.dtd" utf8 <file-reader>
+    read-xml-chunk drop
+] unit-test

basis/xml/tokenize/tokenize.factor

@@ -3,7 +3,7 @@
 USING: xml.errors xml.data xml.utilities xml.char-classes sets
 xml.entities kernel state-parser kernel namespaces make strings
 math math.parser sequences assocs arrays splitting combinators
-unicode.case accessors ;
+unicode.case accessors fry ascii ;
 IN: xml.tokenize
 
 ! XML namespace processing: ns = namespace
@@ -26,7 +26,7 @@ SYMBOL: ns-stack
 
 : add-ns ( name -- )
     dup space>> dup ns-stack get assoc-stack
-    [ nip ] [ <nonexist-ns> throw ] if* >>url drop ;
+    [ nip ] [ nonexist-ns ] if* >>url drop ;
 
 : push-ns ( hash -- )
     ns-stack get push ;
@@ -44,7 +44,7 @@ SYMBOL: ns-stack
 
 : tag-ns ( name attrs-alist -- name attrs )
     dup attrs>ns push-ns
-    >r dup add-ns r> dup [ drop add-ns ] assoc-each <attrs> ;
+    [ dup add-ns ] dip dup [ drop add-ns ] assoc-each <attrs> ;
 
 ! Parsing names
 
@@ -58,7 +58,7 @@ SYMBOL: ns-stack
     get-char name-start? [
         [ dup get-char name-char? not ] take-until nip
     ] [
-        "Malformed name" <xml-string-error> throw
+        "Malformed name" xml-string-error
     ] if ;
 
 : parse-name ( -- name )
@@ -70,9 +70,9 @@ SYMBOL: ns-stack
 : (parse-entity) ( string -- )
     dup entities at [ , ] [ 
         prolog-data get standalone>>
-        [ <no-entity> throw ] [
+        [ no-entity ] [
             dup extra-entities get at
-            [ , ] [ <no-entity> throw ] ?if
+            [ , ] [ no-entity ] ?if
         ] if
     ] ?if ;
 
@@ -95,7 +95,7 @@ SYMBOL: ns-stack
 
 : parse-quot ( ch -- string )
     parse-char get-char
-    [ "XML file ends in a quote" <xml-string-error> throw ] unless ;
+    [ "XML file ends in a quote" xml-string-error ] unless ;
 
 : parse-text ( -- string )
     CHAR: < parse-char ;
@@ -111,7 +111,7 @@ SYMBOL: ns-stack
     get-char dup "'\"" member? [
         next parse-quot
     ] [
-        "Attribute lacks quote" <xml-string-error> throw
+        "Attribute lacks quote" xml-string-error
     ] if ;
 
 : parse-attr ( -- )
@@ -141,8 +141,92 @@ SYMBOL: ns-stack
 : take-cdata ( -- string )
     "[CDATA[" expect-string "]]>" take-string ;
 
+: take-element-decl ( -- element-decl )
+    pass-blank " " take-string pass-blank ">" take-string <element-decl> ;
+
+: take-attlist-decl ( -- doctype-decl )
+    pass-blank " " take-string pass-blank ">" take-string <attlist-decl> ;
+
+: take-until-one-of ( seps -- str sep )
+    '[ get-char _ member? ] take-until get-char ;
+
+: only-blanks ( str -- )
+    [ blank? ] all? [ bad-doctype-decl ] unless ;
+
+: take-system-literal ( -- str )
+    pass-blank get-char next {
+        { CHAR: ' [ "'" take-string ] }
+        { CHAR: " [ "\"" take-string ] }
+    } case ;
+
+: take-system-id ( -- system-id )
+    take-system-literal <system-id>
+    ">" take-string only-blanks ;
+
+: take-public-id ( -- public-id )
+    take-system-literal
+    take-system-literal <public-id>
+    ">" take-string only-blanks ;
+
+DEFER: direct
+
+: (take-internal-subset) ( -- )
+    pass-blank get-char {
+        { CHAR: ] [ next ] }
+        [ drop "<!" expect-string direct , (take-internal-subset) ]
+    } case ;
+
+: take-internal-subset ( -- seq )
+    [ (take-internal-subset) ] { } make ;
+
+: (take-external-id) ( token -- external-id )
+    pass-blank {
+        { "SYSTEM" [ take-system-id ] }
+        { "PUBLIC" [ take-public-id ] }
+        [ bad-external-id ]
+    } case ;
+
+: take-external-id ( -- external-id )
+    " " take-string (take-external-id) ;
+
+: take-doctype-decl ( -- doctype-decl )
+    pass-blank " >" take-until-one-of {
+        { CHAR: \s [
+            pass-blank get-char CHAR: [ = [
+                next take-internal-subset f swap
+                ">" take-string only-blanks
+            ] [
+                " >" take-until-one-of {
+                    { CHAR: \s [ (take-external-id) ] }
+                    { CHAR: > [ only-blanks f ] }
+                } case f
+            ] if
+        ] }
+        { CHAR: > [ f f ] }
+    } case <doctype-decl> ;
+
+: take-entity-def ( -- entity-name entity-def )
+    " " take-string pass-blank get-char {
+        { CHAR: ' [ take-system-literal ] }
+        { CHAR: " [ take-system-literal ] }
+        [ drop take-external-id ]
+    } case ;
+
+: take-entity-decl ( -- entity-decl )
+    pass-blank get-char {
+        { CHAR: % [ next pass-blank take-entity-def ] }
+        [ drop take-entity-def ]
+    } case
+    ">" take-string only-blanks <entity-decl> ;
+
 : take-directive ( -- directive )
-    CHAR: > take-char <directive> next ;
+    " " take-string {
+        { "ELEMENT" [ take-element-decl ] }
+        { "ATTLIST" [ take-attlist-decl ] }
+        { "DOCTYPE" [ take-doctype-decl ] }
+        { "ENTITY" [ take-entity-decl ] }
+        [ bad-directive ]
+    } case ;
 
 : direct ( -- object )
     get-char {
@@ -155,7 +239,7 @@ SYMBOL: ns-stack
     {
         { "yes" [ t ] }
         { "no" [ f ] }
-        [ <not-yes/no> throw ]
+        [ not-yes/no ]
     } case ;
 
 : assure-no-extra ( seq -- )
@@ -164,14 +248,14 @@ SYMBOL: ns-stack
         T{ name f "" "encoding" f }
         T{ name f "" "standalone" f }
     } diff
-    [ <extra-attrs> throw ] unless-empty ; 
+    [ extra-attrs ] unless-empty ; 
 
 : good-version ( version -- version )
-    dup { "1.0" "1.1" } member? [ <bad-version> throw ] unless ;
+    dup { "1.0" "1.1" } member? [ bad-version ] unless ;
 
 : prolog-attrs ( alist -- prolog )
     [ T{ name f "" "version" f } swap at
-      [ good-version ] [ <versionless-prolog> throw ] if* ] keep
+      [ good-version ] [ versionless-prolog ] if* ] keep
     [ T{ name f "" "encoding" f } swap at
       "UTF-8" or ] keep
     T{ name f "" "standalone" f } swap at
@@ -187,7 +271,7 @@ SYMBOL: ns-stack
     (parse-name) dup "xml" =
     [ drop parse-prolog ] [
         dup >lower "xml" =
-        [ <capitalized-prolog> throw ]
+        [ capitalized-prolog ]
         [ "?>" take-string append <instruction> ] if
     ] if ;
 

basis/xml/utilities/utilities.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel namespaces sequences words io assocs
 quotations strings parser lexer arrays xml.data xml.writer debugger
-splitting vectors sequences.deep combinators ;
+splitting vectors sequences.deep combinators fry ;
 IN: xml.utilities
 
 ! * System for words specialized on tag names
@@ -16,30 +16,30 @@ M: process-missing error.
 
 : run-process ( tag word -- )
     2dup "xtable" word-prop
-    >r dup main>> r> at* [ 2nip call ] [
+    [ dup main>> ] dip at* [ 2nip call ] [
         drop \ process-missing boa throw
     ] if ;
 
 : PROCESS:
     CREATE
     dup H{ } clone "xtable" set-word-prop
-    dup [ run-process ] curry define ; parsing
+    dup '[ _ run-process ] define ; parsing
 
 : TAG:
     scan scan-word
     parse-definition
     swap "xtable" word-prop
-    rot "/" split [ >r 2dup r> swap set-at ] each 2drop ;
+    rot "/" split [ [ 2dup ] dip swap set-at ] each 2drop ;
     parsing
 
 
 ! * Common utility functions
 
 : build-tag* ( items name -- tag )
-    assure-name swap >r f r> <tag> ;
+    assure-name swap f swap <tag> ;
 
 : build-tag ( item name -- tag )
-    >r 1array r> build-tag* ;
+    [ 1array ] dip build-tag* ;
 
 : standard-prolog ( -- prolog )
     T{ prolog f "1.0" "UTF-8" f } ;
@@ -69,13 +69,13 @@ M: process-missing error.
     dup tag? [ names-match? ] [ 2drop f ] if ;
 
 : tags@ ( tag name -- children name )
-    >r { } like r> assure-name ;
+    [ { } like ] dip assure-name ;
 
 : deep-tag-named ( tag name/string -- matching-tag )
-    assure-name [ swap tag-named? ] curry deep-find ;
+    assure-name '[ _ swap tag-named? ] deep-find ;
 
 : deep-tags-named ( tag name/string -- tags-seq )
-    tags@ [ swap tag-named? ] curry deep-filter ;
+    tags@ '[ _ swap tag-named? ] deep-filter ;
 
 : tag-named ( tag name/string -- matching-tag )
     ! like get-name-tag but only looks at direct children,
@@ -89,22 +89,22 @@ M: process-missing error.
     rot dup tag? [ at = ] [ 3drop f ] if ;
 
 : tag-with-attr ( tag attr-value attr-name -- matching-tag )
-    assure-name [ tag-with-attr? ] 2curry find nip ;
+    assure-name '[ _ _ tag-with-attr? ] find nip ;
 
 : tags-with-attr ( tag attr-value attr-name -- tags-seq )
-    tags@ [ tag-with-attr? ] 2curry filter children>> ;
+    tags@ '[ _ _ tag-with-attr? ] filter children>> ;
 
 : deep-tag-with-attr ( tag attr-value attr-name -- matching-tag )
-    assure-name [ tag-with-attr? ] 2curry deep-find ;
+    assure-name '[ _ _ tag-with-attr? ] deep-find ;
 
 : deep-tags-with-attr ( tag attr-value attr-name -- tags-seq )
-    tags@ [ tag-with-attr? ] 2curry deep-filter ;
+    tags@ '[ _ _ tag-with-attr? ] deep-filter ;
 
 : get-id ( tag id -- elem ) ! elem=tag.getElementById(id)
     "id" deep-tag-with-attr ;
 
 : deep-tags-named-with-attr ( tag tag-name attr-value attr-name -- tags )
-    >r >r deep-tags-named r> r> tags-with-attr ;
+    [ deep-tags-named ] 2dip tags-with-attr ;
 
 : assert-tag ( name name -- )
     names-match? [ "Unexpected XML tag found" throw ] unless ;
@@ -114,4 +114,4 @@ M: process-missing error.
     [ swap V{ } like >>children drop ] if ;
 
 : insert-child ( child tag -- )
-    >r 1vector r> insert-children ;
+    [ 1vector ] dip insert-children ;

basis/xml/writer/writer.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: hashtables kernel math namespaces sequences strings
 assocs combinators io io.streams.string accessors
-xml.data wrap xml.entities unicode.categories ;
+xml.data wrap xml.entities unicode.categories fry ;
 IN: xml.writer
 
 SYMBOL: xml-pprint?
@@ -12,7 +12,7 @@ SYMBOL: indenter
 "  " indenter set-global
 
 : sensitive? ( tag -- ? )
-    sensitive-tags get swap [ names-match? ] curry contains? ;
+    sensitive-tags get swap '[ _ names-match? ] contains? ;
 
 : indent-string ( -- string )
     xml-pprint? get
@@ -52,9 +52,9 @@ SYMBOL: indenter
         "\"" write
     ] assoc-each ;
 
-GENERIC: write-item ( object -- )
+GENERIC: write-xml-chunk ( object -- )
 
-M: string write-item
+M: string write-xml-chunk
     escape-string dup empty? not xml-pprint? get and
     [ nl 80 indent-string indented-break ] when write ;
 
@@ -65,54 +65,89 @@ M: string write-item
 : write-start-tag ( tag -- )
     write-tag ">" write ;
 
-M: contained-tag write-item
+M: contained-tag write-xml-chunk
     write-tag "/>" write ;
 
 : write-children ( tag -- )
     indent children>> ?filter-children
-    [ write-item ] each unindent ;
+    [ write-xml-chunk ] each unindent ;
 
 : write-end-tag ( tag -- )
     ?indent "</" write print-name CHAR: > write1 ;
 
-M: open-tag write-item
+M: open-tag write-xml-chunk
-    xml-pprint? get >r
+    xml-pprint? get [
         {
             [ sensitive? not xml-pprint? get and xml-pprint? set ]
             [ write-start-tag ]
             [ write-children ]
             [ write-end-tag ]
         } cleave
-    r> xml-pprint? set ;
+    ] dip xml-pprint? set ;
 
-M: comment write-item
+M: comment write-xml-chunk
     "<!--" write text>> write "-->" write ;
 
-M: directive write-item
+M: element-decl write-xml-chunk
+    "<!ELEMENT " write
+    [ name>> write " " write ]
+    [ content-spec>> write ">" write ]
+    bi ;
+
+M: attlist-decl write-xml-chunk
+    "<!ATTLIST " write
+    [ name>> write " " write ]
+    [ att-defs>> write ">" write ]
+    bi ;
+
+M: entity-decl write-xml-chunk
+    "<!ENTITY " write
+    [ name>> write " " write ]
+    [ def>> write-xml-chunk ">" write ]
+    bi ;
+
+M: system-id write-xml-chunk
+    "SYSTEM '" write system-literal>> write "'" write ;
+
+M: public-id write-xml-chunk
+    "PUBLIC '" write
+    [ pubid-literal>> write "' '" write ]
+    [ system-literal>> write "'>" write ] bi ;
+
+M: doctype-decl write-xml-chunk
+    "<!DOCTYPE " write
+    [ name>> write " " write ]
+    [ external-id>> [ write-xml-chunk " " write ] when* ]
+    [
+        internal-subset>>
+        [ "[" write [ write-xml-chunk ] each "]" write ] when* ">" write
+    ] tri ;
+
+M: directive write-xml-chunk
     "<!" write text>> write CHAR: > write1 ;
 
-M: instruction write-item
+M: instruction write-xml-chunk
     "<?" write text>> write "?>" write ;
 
+M: sequence write-xml-chunk
+    [ write-xml-chunk ] each ;
+
 : write-prolog ( xml -- )
     "<?xml version=\"" write dup version>> write
     "\" encoding=\"" write dup encoding>> write
     standalone>> [ "\" standalone=\"yes" write ] when
     "\"?>" write ;
 
-: write-chunk ( seq -- )
-    [ write-item ] each ;
-
 : write-xml ( xml -- )
     {
         [ prolog>> write-prolog ]
-        [ before>> write-chunk ]
+        [ before>> write-xml-chunk ]
-        [ body>> write-item ]
+        [ body>> write-xml-chunk ]
-        [ after>> write-chunk ]
+        [ after>> write-xml-chunk ]
     } cleave ;
 
-M: xml write-item
+M: xml write-xml-chunk
-    body>> write-item ;
+    body>> write-xml-chunk ;
 
 : print-xml ( xml -- )
     write-xml nl ;

basis/xml/xml-docs.factor

@@ -173,10 +173,10 @@ HELP: names-match?
 { $example "USING: prettyprint xml.data ;" "T{ name f \"rpc\" \"methodCall\" f } T{ name f f \"methodCall\" \"http://www.xmlrpc.org/\" } names-match? ." "t" }
 { $see-also name } ;
 
-HELP: xml-chunk
+HELP: read-xml-chunk
 { $values { "stream" "an input stream" } { "seq" "a sequence of elements" } }
 { $description "rather than parse a document, as " { $link read-xml } " does, this word parses and returns a sequence of XML elements (tags, strings, etc), ie a document fragment. This is useful for pieces of XML which may have more than one main tag." }
-{ $see-also write-chunk read-xml } ;
+{ $see-also write-xml-chunk read-xml } ;
 
 HELP: get-id
 { $values { "tag" "an XML tag or document" } { "id" "a string" } { "elem" "an XML element or f" } }
@@ -239,15 +239,10 @@ HELP: pull-event
 { $description "gets the next XML event from the given XML pull parser. Returns f upon exhaustion." }
 { $see-also pull-xml <pull-xml> pull-elem } ;
 
-HELP: write-item
+HELP: write-xml-chunk
 { $values { "object" "an XML element" } }
 { $description "writes an XML element to " { $link output-stream } "." }
-{ $see-also write-chunk write-xml } ;
+{ $see-also write-xml-chunk write-xml } ;
-
-HELP: write-chunk
-{ $values { "seq" "an XML document fragment" } }
-{ $description "writes an XML document fragment, ie a sequence of XML elements, to " { $link output-stream } "." }
-{ $see-also write-item write-xml } ;
 
 HELP: deep-tag-named
 { $values { "tag" "an XML tag or document" } { "name/string" "an XML name or string representing a name" } { "matching-tag" tag } }
@@ -352,13 +347,13 @@ ARTICLE: { "xml" "reading" } "Reading XML"
     "The following words are used to read something into an XML document"
     { $subsection string>xml }
     { $subsection read-xml }
-    { $subsection xml-chunk }
+    { $subsection read-xml-chunk }
+    { $subsection string>xml-chunk }
     { $subsection file>xml } ;
 
 ARTICLE: { "xml" "writing" } "Writing XML"
     "These words are used in implementing prettyprint"
-    { $subsection write-item }
+    { $subsection write-xml-chunk }
-    { $subsection write-chunk }
     "These words are used to print XML normally"
     { $subsection xml>string }
     { $subsection write-xml }

basis/xml/xml.factor

@@ -24,17 +24,17 @@ M: object process add-child ;
 
 M: prolog process
     xml-stack get V{ { f V{ "" } } } =
-    [ <bad-prolog> throw ] unless drop ;
+    [ bad-prolog ] unless drop ;
 
 M: instruction process
     xml-stack get length 1 =
-    [ <bad-instruction> throw ] unless
+    [ bad-instruction ] unless
     add-child ;
 
 M: directive process
     xml-stack get dup length 1 =
     swap first second [ tag? ] contains? not and
-    [ <bad-directive> throw ] unless
+    [ misplaced-directive ] unless
     add-child ;
 
 M: contained process
@@ -44,13 +44,13 @@ M: contained process
 M: opener process push-xml ;
 
 : check-closer ( name opener -- name opener )
-    dup [ <unopened> throw ] unless
+    dup [ unopened ] unless
     2dup name>> =
-    [ name>> swap <mismatched> throw ] unless ;
+    [ name>> swap mismatched ] unless ;
 
 M: closer process
     name>> pop-xml first2
-    >r check-closer attrs>> r>
+    [ check-closer attrs>> ] dip
     <tag> add-child ;
 
 : init-xml-stack ( -- )
@@ -69,27 +69,25 @@ M: closer process
     swap [ string? ] filter
     [
         dup [ blank? ] all?
-        [ drop ] [ swap <pre/post-content> throw ] if
+        [ drop ] [ swap pre/post-content ] if
     ] each drop ;
 
 : no-pre/post ( pre post -- pre post/* )
     ! this does *not* affect the contents of the stack
-    >r dup t assert-blanks r>
+    [ dup t assert-blanks ] [ dup f assert-blanks ] bi* ;
-    dup f assert-blanks ;
 
 : no-post-tags ( post -- post/* )
     ! this does *not* affect the contents of the stack
-    dup [ tag? ] contains? [ <multitags> throw ] when ; 
+    dup [ tag? ] contains? [ multitags ] when ; 
 
 : assure-tags ( seq -- seq )
     ! this does *not* affect the contents of the stack
-    [ <notags> throw ] unless* ;
+    [ notags ] unless* ;
 
 : make-xml-doc ( prolog seq -- xml-doc )
     dup [ tag? ] find
-    >r assure-tags cut rest
+    [ assure-tags cut rest no-pre/post no-post-tags ] dip
-    no-pre/post no-post-tags
+    swap <xml> ;
-    r> swap <xml> ;
 
 ! * Views of XML
 
@@ -142,24 +140,27 @@ TUPLE: pull-xml scope ;
 : (read-xml) ( -- )
     [ process ] sax-loop ; inline
 
-: (xml-chunk) ( stream -- prolog seq )
+: (read-xml-chunk) ( stream -- prolog seq )
     [
         init-xml (read-xml)
-        done? [ <unclosed> throw ] unless
+        done? [ unclosed ] unless
         xml-stack get first second
         prolog-data get swap
     ] state-parse ;
 
 : read-xml ( stream -- xml )
     #! Produces a tree of XML nodes
-    (xml-chunk) make-xml-doc ;
+    (read-xml-chunk) make-xml-doc ;
 
-: xml-chunk ( stream -- seq )
+: read-xml-chunk ( stream -- seq )
-    (xml-chunk) nip ;
+    (read-xml-chunk) nip ;
 
 : string>xml ( string -- xml )
     <string-reader> read-xml ;
 
+: string>xml-chunk ( string -- xml )
+    <string-reader> read-xml-chunk ;
+
 : file>xml ( filename -- xml )
     ! Autodetect encoding!
     utf8 <file-reader> read-xml ;