diff --git a/basis/documents/documents-tests.factor b/basis/documents/documents-tests.factor index e09afebfc2..88e471cce1 100644 --- a/basis/documents/documents-tests.factor +++ b/basis/documents/documents-tests.factor @@ -1,8 +1,37 @@ IN: documents.tests -USING: documents namespaces tools.test ; +USING: documents namespaces tools.test make arrays kernel fry ; ! Tests +[ { } ] [ + [ + { 1 10 } + { 1 10 } [ , "HI" , ] each-line + ] { } make +] unit-test + +[ { 1 "HI" } ] [ + [ + { 1 10 } + { 1 11 } [ , "HI" , ] each-line + ] { } make +] unit-test + +[ { 1 "HI" 2 "HI" } ] [ + [ + { 1 10 } + { 2 11 } [ , "HI" , ] each-line + ] { } make +] unit-test + +[ { { t f 1 } { t f 2 } } ] [ + [ + { 1 10 } { 2 11 } + t f + '[ [ _ _ ] dip 3array , ] each-line + ] { } make +] unit-test + [ { 10 4 } ] [ { "a" } { 10 3 } text+loc ] unit-test [ { 10 4 } ] [ { "a" } { 10 3 } text+loc ] unit-test diff --git a/basis/documents/documents.factor b/basis/documents/documents.factor index a82437ba40..6993bcb65b 100644 --- a/basis/documents/documents.factor +++ b/basis/documents/documents.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2006, 2007 Slava Pestov +! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays io kernel math models namespaces make sequences strings splitting combinators unicode.categories -math.order ; +math.order math.ranges ; IN: documents : +col ( loc n -- newloc ) [ first2 ] dip + 2array ; @@ -47,7 +47,7 @@ TUPLE: document < model locs ; 2over = [ 3drop ] [ - [ [ first ] bi@ 1+ dup ] dip each + [ [ first ] bi@ [a,b] ] dip each ] if ; inline : start/end-on-line ( from to line# -- n1 n2 ) diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor index 4f2eaafe26..ac784f8c2a 100644 --- a/basis/html/templates/chloe/compiler/compiler.factor +++ b/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' ) diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index de95a3a583..05bab8c654 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -104,7 +104,8 @@ M: unix statvfs>file-system-info drop ; : file-system-calculations ( file-system-info -- file-system-info' ) { - [ dup [ blocks-available>> ] [ block-size>> ] bi * >>free-space drop ] + [ dup [ blocks-available>> ] [ block-size>> ] bi * >>available-space drop ] + [ dup [ blocks-free>> ] [ block-size>> ] bi * >>free-space drop ] [ dup [ blocks>> ] [ block-size>> ] bi * >>total-space drop ] [ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ] [ ] diff --git a/basis/io/unix/files/linux/linux.factor b/basis/io/unix/files/linux/linux.factor index dd9abcbd1e..3e4e1c043a 100644 --- a/basis/io/unix/files/linux/linux.factor +++ b/basis/io/unix/files/linux/linux.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types alien.syntax combinators csv -io.encodings.utf8 io.files io.streams.string io.unix.files -kernel namespaces sequences system unix unix.statfs.linux -unix.statvfs.linux ; +io.backend io.encodings.utf8 io.files io.streams.string +io.unix.files kernel math.order namespaces sequences sorting +system unix unix.statfs.linux unix.statvfs.linux ; IN: io.unix.files.linux TUPLE: linux-file-system-info < unix-file-system-info -namelen spare ; +namelen ; M: linux new-file-system-info linux-file-system-info new ; @@ -26,7 +26,7 @@ M: linux statfs>file-system-info ( struct -- statfs ) [ statfs64-f_fsid >>id ] [ statfs64-f_namelen >>namelen ] [ statfs64-f_frsize >>preferred-block-size ] - [ statfs64-f_spare >>spare ] + ! [ statfs64-f_spare >>spare ] } cleave ; M: linux file-system-statvfs ( path -- byte-array ) @@ -68,3 +68,22 @@ M: linux file-systems [ type>> >>type ] } cleave ] map ; + +ERROR: file-system-not-found ; + +M: linux file-system-info ( path -- ) + normalize-path + [ + [ new-file-system-info ] dip + [ file-system-statfs statfs>file-system-info ] + [ file-system-statvfs statvfs>file-system-info ] bi + file-system-calculations + ] keep + + parse-mtab [ [ mount-point>> ] bi@ <=> invert-comparison ] sort + [ mount-point>> head? ] with find nip [ file-system-not-found ] unless* + { + [ file-system-name>> >>device-name drop ] + [ mount-point>> >>mount-point drop ] + [ type>> >>type ] + } 2cleave ; diff --git a/basis/syndication/syndication.factor b/basis/syndication/syndication.factor index aca09b939c..a6eaff4492 100644 --- a/basis/syndication/syndication.factor +++ b/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 ] [ diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index e262ac7fea..72d5900c28 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -235,10 +235,11 @@ M: editor ungraft* editor get selection-color>> gl-color editor get selection-start/end over first [ - 2dup [ + 2dup '[ + [ _ _ ] dip draw-selected-line 1 translate-lines - ] with with each-line + ] each-line ] with-editor-translation ; M: editor draw-gadget* diff --git a/basis/xml/data/data.factor b/basis/xml/data/data.factor index 0af2ec4700..bf4e2047a7 100644 --- a/basis/xml/data/data.factor +++ b/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 TUPLE: comment text ; C: comment -TUPLE: directive text ; -C: directive +TUPLE: directive ; + +TUPLE: element-decl < directive name content-spec ; +C: element-decl + +TUPLE: attlist-decl < directive name att-defs ; +C: attlist-decl + +TUPLE: entity-decl < directive name def ; +C: entity-decl + +TUPLE: system-id system-literal ; +C: system-id + +TUPLE: public-id pubid-literal system-literal ; +C: public-id + +TUPLE: doctype-decl < directive name external-id internal-subset ; +C: doctype-decl TUPLE: instruction text ; C: instruction @@ -47,7 +64,7 @@ TUPLE: attrs alist ; C: 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 ; 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 - [ cleave ] curry - ] [ [ boa ] curry ] bi compose ; + [ name>> reader-word '[ _ execute clone ] ] map + '[ _ cleave ] + ] [ '[ _ boa ] ] bi compose ; M: tag clone tag clone-slots ; @@ -129,7 +146,7 @@ CONSULT: name xml body>> ; xml ( xml tag -- newxml ) - >r [ prolog>> ] [ before>> ] [ after>> ] tri r> + [ [ prolog>> ] [ before>> ] [ after>> ] tri ] dip swap ; : seq>xml ( xml seq -- newxml ) diff --git a/basis/xml/entities/entities.factor b/basis/xml/entities/entities.factor index d3eca30685..03de0f78d1 100644 --- a/basis/xml/entities/entities.factor +++ b/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 ; diff --git a/basis/xml/errors/errors-tests.factor b/basis/xml/errors/errors-tests.factor index ab061530fe..e72e465f0d 100644 --- a/basis/xml/errors/errors-tests.factor +++ b/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" } " " 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" xml-error-test T{ versionless-prolog f 1 8 } "" xml-error-test T{ bad-instruction f 1 11 T{ instruction f "xsl" } } "" xml-error-test -T{ bad-directive f 1 15 T{ directive f "DOCTYPE" } -} "" xml-error-test diff --git a/basis/xml/errors/errors.factor b/basis/xml/errors/errors.factor index bafa325e89..0c039d526c 100644 --- a/basis/xml/errors/errors.factor +++ b/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 ; -C: multitags +ERROR: multitags ; + M: multitags summary ( obj -- str ) drop "XML document contains multiple main tags" ; -TUPLE: pre/post-content string pre? ; -C: 
 pre/post-content
+ERROR: pre/post-content string pre? ;
+
 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 ;
-:  ( 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
-:  ( 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 ;
-:  ( 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 parsing-error
-        xml-stack get rest-slice [ first name>> ] map >>tags ;
+
+: unclosed ( -- * )
+    \ 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 ;
-:  ( 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 ;
-:  ( 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 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 ;
-:  ( 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 ;
-:  ( 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 ;
-:  ( 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 ;
-C:  notags
+ERROR: notags ;
+
 M: notags summary ( obj -- str )
     drop "XML document lacks a main tag" ;
 
 TUPLE: bad-prolog < parsing-error 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 ;
-:  ( 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 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 ;
-:  ( 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 ;
-:  ( 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
diff --git a/basis/xml/generator/generator-tests.factor b/basis/xml/generator/generator-tests.factor
index 052e5eab7f..17f7cab509 100644
--- a/basis/xml/generator/generator-tests.factor
+++ b/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" } } 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
diff --git a/basis/xml/generator/generator.factor b/basis/xml/generator/generator.factor
index 24da501265..ac7b14b89e 100644
--- a/basis/xml/generator/generator.factor
+++ b/basis/xml/generator/generator.factor
@@ -5,12 +5,11 @@ sequences ;
 IN: xml.generator
 
 : comment, ( string -- )  , ;
-: directive, ( string -- )  , ;
 : instruction, ( string -- )  , ;
 : nl, ( -- ) "\n" , ;
 
 : (tag,) ( name attrs quot -- tag )
-    -rot >r >r V{ } make r> r> rot  ; inline
+    -rot [ V{ } make ] 2dip rot  ; inline
 : tag*, ( name attrs quot -- )
     (tag,) , ; inline
 
diff --git a/basis/xml/tests/arithmetic.factor b/basis/xml/tests/arithmetic.factor
index 577ef5718c..98facfcac2 100644
--- a/basis/xml/tests/arithmetic.factor
+++ b/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 ;
diff --git a/basis/xml/tests/funny-dtd.factor b/basis/xml/tests/funny-dtd.factor
new file mode 100644
index 0000000000..1160af62bc
--- /dev/null
+++ b/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
diff --git a/basis/xml/tests/funny-dtd.xml b/basis/xml/tests/funny-dtd.xml
new file mode 100644
index 0000000000..90f221ee01
--- /dev/null
+++ b/basis/xml/tests/funny-dtd.xml
@@ -0,0 +1,2 @@
+]>03500085varioushttp://zomgwtfbbq.info[zOMBradio][DJKyleL]Daft Punk - One More Time / Aerodynamicarkz1372164578096audio/aacp1.9.86160030211110000301314903301227896017Daft Punk - One More Time / Aerodynamic
+
diff --git a/basis/xml/tests/templating.factor b/basis/xml/tests/templating.factor
index e95dad6618..f0af650e4f 100644
--- a/basis/xml/tests/templating.factor
+++ b/basis/xml/tests/templating.factor
@@ -20,7 +20,7 @@ M: object (r-ref) drop ;
 
 ! Example
 
-: sample-doc
+: sample-doc ( -- string )
     {
         ""
         ""
diff --git a/basis/xml/tests/test.factor b/basis/xml/tests/test.factor
index 623663ebe1..01987a98ab 100644
--- a/basis/xml/tests/test.factor
+++ b/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" ] [ "" 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" ] [ "" string>xml children>string ] unit-test
 [ "bar baz" ]
 [ "bar" string>xml [ " baz" append ] map xml>string ] unit-test
 [ "\n\n  bar\n" ]
 [ "         bar            " string>xml pprint-xml>string ] unit-test
+[ "" string>xml ] must-fail
+[ ] [ "" string>xml drop ] unit-test
+[ T{ element-decl f "br" "EMPTY" } ] [ "" string>xml-chunk second ] unit-test
+[ T{ element-decl f "p" "(#PCDATA|emph)*" } ] [ "" string>xml-chunk second ] unit-test
+[ T{ element-decl f "%name.para;" "%content.para;" } ] [ "" string>xml-chunk second ] unit-test
+[ T{ element-decl f "container" "ANY" } ] [ "" string>xml-chunk second ] unit-test
+[ T{ doctype-decl f "foo" } ] [ "" string>xml-chunk second ] unit-test
+[ T{ doctype-decl f "foo" } ] [ "" string>xml-chunk second ] unit-test
+[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "" string>xml-chunk second ] unit-test
+[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "" string>xml-chunk second ] unit-test
diff --git a/basis/xml/tests/xmode-dtd.factor b/basis/xml/tests/xmode-dtd.factor
new file mode 100644
index 0000000000..c15d3a462e
--- /dev/null
+++ b/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 
+    read-xml-chunk drop
+] unit-test
diff --git a/basis/xml/tokenize/tokenize.factor b/basis/xml/tokenize/tokenize.factor
index b7314c5b25..0c475c108d 100644
--- a/basis/xml/tokenize/tokenize.factor
+++ b/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 ] [  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  ;
+    [ dup add-ns ] dip dup [ drop add-ns ] assoc-each  ;
 
 ! Parsing names
 
@@ -58,7 +58,7 @@ SYMBOL: ns-stack
     get-char name-start? [
         [ dup get-char name-char? not ] take-until nip
     ] [
-        "Malformed name"  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>>
-        [  throw ] [
+        [ no-entity ] [
             dup extra-entities get at
-            [ , ] [  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"  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"  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  ;
+
+: take-attlist-decl ( -- doctype-decl )
+    pass-blank " " take-string pass-blank ">" take-string  ;
+
+: 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 
+    ">" take-string only-blanks ;
+
+: take-public-id ( -- public-id )
+    take-system-literal
+    take-system-literal 
+    ">" take-string only-blanks ;
+
+DEFER: direct
+
+: (take-internal-subset) ( -- )
+    pass-blank get-char {
+        { CHAR: ] [ next ] }
+        [ drop "" 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  ;
+
+: 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  ;
+
 : take-directive ( -- directive )
-    CHAR: > take-char  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 ] }
-        [  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
-    [  throw ] unless-empty ; 
+    [ extra-attrs ] unless-empty ; 
 
 : good-version ( version -- version )
-    dup { "1.0" "1.1" } member? [  throw ] unless ;
+    dup { "1.0" "1.1" } member? [ bad-version ] unless ;
 
 : prolog-attrs ( alist -- prolog )
     [ T{ name f "" "version" f } swap at
-      [ good-version ] [  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" =
-        [  throw ]
+        [ capitalized-prolog ]
         [ "?>" take-string append  ] if
     ] if ;
 
diff --git a/basis/xml/utilities/utilities.factor b/basis/xml/utilities/utilities.factor
index 2acb353bb6..e104142a76 100644
--- a/basis/xml/utilities/utilities.factor
+++ b/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>  ;
+    assure-name swap f swap  ;
 
 : 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 ;
diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor
index ae6fddacc3..12601953f6 100644
--- a/basis/xml/writer/writer.factor
+++ b/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 " write1 ;
 
-M: open-tag write-item
-    xml-pprint? get >r
-    {
-        [ sensitive? not xml-pprint? get and xml-pprint? set ]
-        [ write-start-tag ]
-        [ write-children ]
-        [ write-end-tag ]
-    } cleave
-    r> xml-pprint? set ;
+M: open-tag write-xml-chunk
+    xml-pprint? get [
+        {
+            [ sensitive? not xml-pprint? get and xml-pprint? set ]
+            [ write-start-tag ]
+            [ write-children ]
+            [ write-end-tag ]
+        } cleave
+    ] dip xml-pprint? set ;
 
-M: comment write-item
+M: comment write-xml-chunk
     "" write ;
 
-M: directive write-item
+M: element-decl write-xml-chunk
+    "> write " " write ]
+    [ content-spec>> write ">" write ]
+    bi ;
+
+M: attlist-decl write-xml-chunk
+    "> write " " write ]
+    [ att-defs>> write ">" write ]
+    bi ;
+
+M: entity-decl write-xml-chunk
+    "> 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
+    "> 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 CHAR: > write1 ;
 
-M: instruction write-item
+M: instruction write-xml-chunk
     "> write "?>" write ;
 
+M: sequence write-xml-chunk
+    [ write-xml-chunk ] each ;
+
 : write-prolog ( xml -- )
     "> 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 ]
-        [ body>> write-item ]
-        [ after>> write-chunk ]
+        [ before>> write-xml-chunk ]
+        [ body>> write-xml-chunk ]
+        [ after>> write-xml-chunk ]
     } cleave ;
 
-M: xml write-item
-    body>> write-item ;
+M: xml write-xml-chunk
+    body>> write-xml-chunk ;
 
 : print-xml ( xml -- )
     write-xml nl ;
diff --git a/basis/xml/xml-docs.factor b/basis/xml/xml-docs.factor
index 248a43ed63..05dd85251d 100644
--- a/basis/xml/xml-docs.factor
+++ b/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-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 } ;
-
-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 } ;
+{ $see-also write-xml-chunk 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-chunk }
+    { $subsection write-xml-chunk }
     "These words are used to print XML normally"
     { $subsection xml>string }
     { $subsection write-xml }
diff --git a/basis/xml/xml.factor b/basis/xml/xml.factor
index 67168bfb49..8afcf7a33b 100644
--- a/basis/xml/xml.factor
+++ b/basis/xml/xml.factor
@@ -24,17 +24,17 @@ M: object process add-child ;
 
 M: prolog process
     xml-stack get V{ { f V{ "" } } } =
-    [  throw ] unless drop ;
+    [ bad-prolog ] unless drop ;
 
 M: instruction process
     xml-stack get length 1 =
-    [  throw ] unless
+    [ bad-instruction ] unless
     add-child ;
 
 M: directive process
     xml-stack get dup length 1 =
     swap first second [ tag? ] contains? not and
-    [  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 [  throw ] unless
+    dup [ unopened ] unless
     2dup name>> =
-    [ name>> swap  throw ] unless ;
+    [ name>> swap mismatched ] unless ;
 
 M: closer process
     name>> pop-xml first2
-    >r check-closer attrs>> r>
+    [ check-closer attrs>> ] dip
      add-child ;
 
 : init-xml-stack ( -- )
@@ -69,27 +69,25 @@ M: closer process
     swap [ string? ] filter
     [
         dup [ blank? ] all?
-        [ drop ] [ swap 
 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 f assert-blanks ;
+    [ dup t assert-blanks ] [ dup f assert-blanks ] bi* ;
 
 : no-post-tags ( post -- post/* )
     ! this does *not* affect the contents of the stack
-    dup [ tag? ] contains? [  throw ] when ; 
+    dup [ tag? ] contains? [ multitags ] when ; 
 
 : assure-tags ( seq -- seq )
     ! this does *not* affect the contents of the stack
-    [  throw ] unless* ;
+    [ notags ] unless* ;
 
 : make-xml-doc ( prolog seq -- xml-doc )
     dup [ tag? ] find
-    >r assure-tags cut rest
-    no-pre/post no-post-tags
-    r> swap  ;
+    [ assure-tags cut rest no-pre/post no-post-tags ] dip
+    swap  ;
 
 ! * 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? [  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 )
-    (xml-chunk) nip ;
+: read-xml-chunk ( stream -- seq )
+    (read-xml-chunk) nip ;
 
 : string>xml ( string -- xml )
      read-xml ;
 
+: string>xml-chunk ( string -- xml )
+     read-xml-chunk ;
+
 : file>xml ( filename -- xml )
     ! Autodetect encoding!
     utf8  read-xml ;