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

basis/alien/c-types/c-types-tests.factor

@@ -8,10 +8,6 @@ sequences system libc alien.strings io.encodings.utf8 ;
 
 [ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
 
-: foo ( -- n ) &: fdafd [ 123 ] unless* ;
-
-[ 123 ] [ foo ] unit-test
-
 [ -1 ] [ -1 <char> *char ] unit-test
 [ -1 ] [ -1 <short> *short ] unit-test
 [ -1 ] [ -1 <int> *int ] unit-test

basis/alien/remote-control/remote-control.factor

@@ -15,7 +15,7 @@ IN: alien.remote-control
     "void" { "long" } "cdecl" [ sleep ] alien-callback ;
 
 : ?callback ( word -- alien )
-    dup compiled>> [ execute ] [ drop f ] if ; inline
+    dup optimized>> [ execute ] [ drop f ] if ; inline
 
 : init-remote-control ( -- )
     \ eval-callback ?callback 16 setenv

basis/alien/syntax/syntax.factor

@@ -4,7 +4,7 @@ USING: accessors arrays alien alien.c-types alien.structs
 alien.arrays alien.strings kernel math namespaces parser
 sequences words quotations math.parser splitting grouping
 effects assocs combinators lexer strings.parser alien.parser 
-fry vocabs.parser ;
+fry vocabs.parser words.constant ;
 IN: alien.syntax
 
 : DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
@@ -31,10 +31,11 @@ IN: alien.syntax
 
 : C-ENUM:
     ";" parse-tokens
-    dup length
+    [ [ create-in ] dip define-constant ] each-index ;
-    [ [ create-in ] dip 1quotation define ] 2each ;
     parsing
 
+: address-of ( name library -- value )
+    load-library dlsym [ "No such symbol" throw ] unless* ;
+
 : &:
-    scan "c-library" get
+    scan "c-library" get '[ _ _ address-of ] over push-all ; parsing
-    '[ _ _ load-library dlsym ] over push-all ; parsing

basis/bootstrap/compiler/compiler.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors compiler cpu.architecture vocabs.loader system
 sequences namespaces parser kernel kernel.private classes
@@ -25,8 +25,8 @@ IN: bootstrap.compiler
 
 enable-compiler
 
-: compile-uncompiled ( words -- )
+: compile-unoptimized ( words -- )
-    [ compiled>> not ] filter compile ;
+    [ optimized>> not ] filter compile ;
 
 nl
 "Compiling..." write flush
@@ -48,70 +48,70 @@ nl
     wrap probe
 
     namestack*
-} compile-uncompiled
+} compile-unoptimized
 
 "." write flush
 
 {
     bitand bitor bitxor bitnot
-} compile-uncompiled
+} compile-unoptimized
 
 "." write flush
 
 {
     + 1+ 1- 2/ < <= > >= shift
-} compile-uncompiled
+} compile-unoptimized
 
 "." write flush
 
 {
     new-sequence nth push pop peek flip
-} compile-uncompiled
+} compile-unoptimized
 
 "." write flush
 
 {
     hashcode* = get set
-} compile-uncompiled
+} compile-unoptimized
 
 "." write flush
 
 {
     memq? split harvest sift cut cut-slice start index clone
     set-at reverse push-all class number>string string>number
-} compile-uncompiled
+} compile-unoptimized
 
 "." write flush
 
 {
     lines prefix suffix unclip new-assoc update
     word-prop set-word-prop 1array 2array 3array ?nth
-} compile-uncompiled
+} compile-unoptimized
 
 "." write flush
 
 {
     malloc calloc free memcpy
-} compile-uncompiled
+} compile-unoptimized
 
 "." write flush
 
-{ build-tree } compile-uncompiled
+{ build-tree } compile-unoptimized
 
 "." write flush
 
-{ optimize-tree } compile-uncompiled
+{ optimize-tree } compile-unoptimized
 
 "." write flush
 
-{ optimize-cfg } compile-uncompiled
+{ optimize-cfg } compile-unoptimized
 
 "." write flush
 
-{ (compile) } compile-uncompiled
+{ (compile) } compile-unoptimized
 
 "." write flush
 
-vocabs [ words compile-uncompiled "." write flush ] each
+vocabs [ words compile-unoptimized "." write flush ] each
 
 " done" print flush

basis/bootstrap/image/image.factor

@@ -433,7 +433,7 @@ M: quotation '
         array>> '
         quotation type-number object tag-number [
             emit ! array
-            f ' emit ! compiled>>
+            f ' emit ! compiled
             0 emit ! xt
             0 emit ! code
         ] emit-object

basis/bootstrap/stage2.factor

@@ -42,7 +42,7 @@ SYMBOL: bootstrap-time
     "Core bootstrap completed in " write core-bootstrap-time get print-time
     "Bootstrap completed in "      write bootstrap-time      get print-time
 
-    [ compiled>> ] count-words " compiled words" print
+    [ optimized>> ] count-words " compiled words" print
     [ symbol? ] count-words " symbol words" print
     [ ] count-words " words total" print
 

basis/compiler/compiler.factor

@@ -24,7 +24,7 @@ SYMBOL: compiled
     } cond drop ;
 
 : maybe-compile ( word -- )
-    dup compiled>> [ drop ] [ queue-compile ] if ;
+    dup optimized>> [ drop ] [ queue-compile ] if ;
 
 SYMBOL: +failed+
 

basis/compiler/tests/codegen.factor

@@ -211,7 +211,7 @@ TUPLE: my-tuple ;
     { tuple vector } 3 slot { word } declare
     dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
 
-[ t ] [ \ dispatch-alignment-regression compiled>> ] unit-test
+[ t ] [ \ dispatch-alignment-regression optimized>> ] unit-test
 
 [ vector ] [ dispatch-alignment-regression ] unit-test
 

basis/compiler/tests/optimizer.factor

@@ -9,7 +9,7 @@ IN: optimizer.tests
 GENERIC: xyz ( obj -- obj )
 M: array xyz xyz ;
 
-[ t ] [ \ xyz compiled>> ] unit-test
+[ t ] [ \ xyz optimized>> ] unit-test
 
 ! Test predicate inlining
 : pred-test-1
@@ -94,7 +94,7 @@ TUPLE: pred-test ;
 ! regression
 GENERIC: void-generic ( obj -- * )
 : breakage ( -- * ) "hi" void-generic ;
-[ t ] [ \ breakage compiled>> ] unit-test
+[ t ] [ \ breakage optimized>> ] unit-test
 [ breakage ] must-fail
 
 ! regression
@@ -119,7 +119,7 @@ GENERIC: void-generic ( obj -- * )
 ! compiling <tuple> with a non-literal class failed
 : <tuple>-regression ( class -- tuple ) <tuple> ;
 
-[ t ] [ \ <tuple>-regression compiled>> ] unit-test
+[ t ] [ \ <tuple>-regression optimized>> ] unit-test
 
 GENERIC: foozul ( a -- b )
 M: reversed foozul ;
@@ -228,7 +228,7 @@ USE: binary-search.private
 : node-successor-f-bug ( x -- * )
     [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
 
-[ t ] [ \ node-successor-f-bug compiled>> ] unit-test
+[ t ] [ \ node-successor-f-bug optimized>> ] unit-test
 
 [ ] [ [ new ] build-tree optimize-tree drop ] unit-test
 
@@ -242,7 +242,7 @@ USE: binary-search.private
         ] if
     ] if ;
 
-[ t ] [ \ lift-throw-tail-regression compiled>> ] unit-test
+[ t ] [ \ lift-throw-tail-regression optimized>> ] unit-test
 [ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
 [ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
 
@@ -271,7 +271,7 @@ HINTS: recursive-inline-hang array ;
 : recursive-inline-hang-1 ( -- a )
     { } recursive-inline-hang ;
 
-[ t ] [ \ recursive-inline-hang-1 compiled>> ] unit-test
+[ t ] [ \ recursive-inline-hang-1 optimized>> ] unit-test
 
 DEFER: recursive-inline-hang-3
 

basis/compiler/tests/peg-regression.factor

@@ -22,5 +22,5 @@ pipeline = "hello" => [[ ast>pipeline-expr ]]
 
 USE: tools.test
 
-[ t ] [ \ expr compiled>> ] unit-test
+[ t ] [ \ expr optimized>> ] unit-test
-[ t ] [ \ ast>pipeline-expr compiled>> ] unit-test
+[ t ] [ \ ast>pipeline-expr optimized>> ] unit-test

basis/compiler/tests/redefine1.factor

@@ -23,36 +23,36 @@ M: integer method-redefine-test 3 + ;
 : hey ( -- ) ;
 : there ( -- ) hey ;
 
-[ t ] [ \ hey compiled>> ] unit-test
+[ t ] [ \ hey optimized>> ] unit-test
-[ t ] [ \ there compiled>> ] unit-test
+[ t ] [ \ there optimized>> ] unit-test
 [ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test
-[ f ] [ \ hey compiled>> ] unit-test
+[ f ] [ \ hey optimized>> ] unit-test
-[ f ] [ \ there compiled>> ] unit-test
+[ f ] [ \ there optimized>> ] unit-test
 [ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test
-[ t ] [ \ there compiled>> ] unit-test
+[ t ] [ \ there optimized>> ] unit-test
 
 : good ( -- ) ;
 : bad ( -- ) good ;
 : ugly ( -- ) bad ;
 
-[ t ] [ \ good compiled>> ] unit-test
+[ t ] [ \ good optimized>> ] unit-test
-[ t ] [ \ bad compiled>> ] unit-test
+[ t ] [ \ bad optimized>> ] unit-test
-[ t ] [ \ ugly compiled>> ] unit-test
+[ t ] [ \ ugly optimized>> ] unit-test
 
 [ f ] [ \ good compiled-usage assoc-empty? ] unit-test
 
 [ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test
 
-[ f ] [ \ good compiled>> ] unit-test
+[ f ] [ \ good optimized>> ] unit-test
-[ f ] [ \ bad compiled>> ] unit-test
+[ f ] [ \ bad optimized>> ] unit-test
-[ f ] [ \ ugly compiled>> ] unit-test
+[ f ] [ \ ugly optimized>> ] unit-test
 
 [ t ] [ \ good compiled-usage assoc-empty? ] unit-test
 
 [ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test
 
-[ t ] [ \ good compiled>> ] unit-test
+[ t ] [ \ good optimized>> ] unit-test
-[ t ] [ \ bad compiled>> ] unit-test
+[ t ] [ \ bad optimized>> ] unit-test
-[ t ] [ \ ugly compiled>> ] unit-test
+[ t ] [ \ ugly optimized>> ] unit-test
 
 [ f ] [ \ good compiled-usage assoc-empty? ] unit-test

basis/compiler/tests/redefine3.factor

@@ -14,7 +14,7 @@ M: empty-mixin sheeple drop "wake up" ;
 : sheeple-test ( -- string ) { } sheeple ;
 
 [ "sheeple" ] [ sheeple-test ] unit-test
-[ t ] [ \ sheeple-test compiled>> ] unit-test
+[ t ] [ \ sheeple-test optimized>> ] unit-test
 [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
 [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
 
@@ -27,6 +27,6 @@ M: empty-mixin sheeple drop "wake up" ;
 [ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
 
 [ "sheeple" ] [ sheeple-test ] unit-test
-[ t ] [ \ sheeple-test compiled>> ] unit-test
+[ t ] [ \ sheeple-test optimized>> ] unit-test
 [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
 [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test

basis/compiler/tests/simple.factor

@@ -237,6 +237,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
 10 [
     [ "compiler.tests.foo" forget-vocab ] with-compilation-unit
     [ t ] [
-        "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) compiled>>" eval
+        "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval
     ] unit-test
 ] times

basis/compiler/tests/spilling.factor

@@ -47,7 +47,7 @@ IN: compiler.tests
 [ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
 [ 1.0 float-spill-bug ] unit-test
 
-[ t ] [ \ float-spill-bug compiled>> ] unit-test
+[ t ] [ \ float-spill-bug optimized>> ] unit-test
 
 : float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
     {
@@ -132,7 +132,7 @@ IN: compiler.tests
 [ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
 [ 1.0 float-fixnum-spill-bug ] unit-test
 
-[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test
+[ t ] [ \ float-fixnum-spill-bug optimized>> ] unit-test
 
 : resolve-spill-bug ( a b -- c )
     [ 1 fixnum+fast ] bi@ dup 10 fixnum< [
@@ -159,7 +159,7 @@ IN: compiler.tests
         16 narray
     ] if ;
 
-[ t ] [ \ resolve-spill-bug compiled>> ] unit-test
+[ t ] [ \ resolve-spill-bug optimized>> ] unit-test
 
 [ 4 ] [ 1 1 resolve-spill-bug ] unit-test
 

basis/cpu/ppc/assembler/assembler.factor

@@ -97,10 +97,10 @@ X: XOR 0 316 31
 X: XOR. 1 316 31
 X1: EXTSB 0 954 31
 X1: EXTSB. 1 954 31
-: FMR ( a s -- ) 0 -rot 72 0 63 x-insn ;
+: FMR ( a s -- ) [ 0 ] 2dip 72 0 63 x-insn ;
-: FMR. ( a s -- ) 0 -rot 72 1 63 x-insn ;
+: FMR. ( a s -- ) [ 0 ] 2dip 72 1 63 x-insn ;
-: FCTIWZ ( a s -- ) 0 -rot 0 15 63 x-insn ;
+: FCTIWZ ( a s -- ) [ 0 ] 2dip 0 15 63 x-insn ;
-: FCTIWZ. ( a s -- ) 0 -rot 1 15 63 x-insn ;
+: FCTIWZ. ( a s -- ) [ 0 ] 2dip 1 15 63 x-insn ;
 
 ! XO-form
 XO: ADD 0 0 266 31

basis/cpu/ppc/assembler/backend/backend.factor

@@ -74,8 +74,8 @@ IN: cpu.ppc.assembler.backend
 
 GENERIC# (B) 2 ( dest aa lk -- )
 M: integer (B) 18 i-insn ;
-M: word (B) 0 -rot (B) rc-relative-ppc-3 rel-word ;
+M: word (B) [ 0 ] 2dip (B) rc-relative-ppc-3 rel-word ;
-M: label (B) 0 -rot (B) rc-relative-ppc-3 label-fixup ;
+M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
 
 GENERIC: BC ( a b c -- )
 M: integer BC 0 0 16 b-insn ;

basis/db/postgresql/postgresql.factor

@@ -55,8 +55,10 @@ M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- object )
     [ swap slot-name>> rot set-slot-named ] [ <low-level-binding> ] bi ;
 
 M: postgresql-statement bind-tuple ( tuple statement -- )
-    tuck in-params>>
+    [ nip ] [
-    [ postgresql-bind-conversion ] with map
+        in-params>>
+        [ postgresql-bind-conversion ] with map
+    ] 2bi
     >>bind-params drop ;
 
 M: postgresql-result-set #rows ( result-set -- n )

basis/db/tuples/tuples.factor

@@ -73,9 +73,10 @@ PRIVATE>
 ! High level
 ERROR: no-slots-named class seq ;
 : check-columns ( class columns -- )
-    tuck
+    [ nip ] [
-    [ [ first ] map ]
+        [ [ first ] map ]
-    [ all-slots [ name>> ] map ] bi* diff
+        [ all-slots [ name>> ] map ] bi* diff
+    ] 2bi
     [ drop ] [ no-slots-named ] if-empty ;
 
 : define-persistent ( class table columns -- )

basis/db/types/types.factor

@@ -42,10 +42,10 @@ ERROR: no-slot ;
     slot-named dup [ no-slot ] unless offset>> ;
 
 : get-slot-named ( name tuple -- value )
-    tuck offset-of-slot slot ;
+    [ nip ] [ offset-of-slot ] 2bi slot ;
 
 : set-slot-named ( value name obj -- )
-    tuck offset-of-slot set-slot ;
+    [ nip ] [ offset-of-slot ] 2bi set-slot ;
 
 ERROR: not-persistent class ;
 

basis/furnace/utilities/utilities.factor

@@ -96,11 +96,7 @@ M: object modify-form drop ;
     dup method>> {
         { "GET" [ url>> query>> ] }
         { "HEAD" [ url>> query>> ] }
-        { "POST" [
+        { "POST" [ post-data>> params>> ] }
-            post-data>>
-            dup content-type>> "application/x-www-form-urlencoded" =
-            [ content>> ] [ drop f ] if
-        ] }
     } case ;
 
 : referrer ( -- referrer/f )

basis/heaps/heaps-tests.factor

@@ -32,10 +32,8 @@ IN: heaps.tests
 
 : random-alist ( n -- alist )
     [
-        [
+        drop 32 random-bits dup number>string
-            32 random-bits dup number>string swap set
+    ] H{ } map>assoc ;
-        ] times
-    ] H{ } make-assoc ;
 
 : test-heap-sort ( n -- ? )
     random-alist dup >alist sort-keys swap heap-sort = ;

basis/help/handbook/handbook.factor

@@ -162,7 +162,8 @@ ARTICLE: "encodings-introduction" "An introduction to encodings"
 { $code "\"file.txt\" utf16 file-contents" }
 "Encoding descriptors are also used by " { $link "io.streams.byte-array" } " and taken by combinators like " { $link with-file-writer } " and " { $link with-byte-reader } " which deal with streams. It is " { $emphasis "not" } " used with " { $link "io.streams.string" } " because these deal with abstract text."
 $nl
-"When the " { $link binary } " encoding is used, a " { $link byte-array } " is expected for writing and returned for reading, since the stream deals with bytes. All other encodings deal with strings, since they are used to represent text." ;
+"When the " { $link binary } " encoding is used, a " { $link byte-array } " is expected for writing and returned for reading, since the stream deals with bytes. All other encodings deal with strings, since they are used to represent text."
+{ $see-also "stream-elements" } ;
 
 ARTICLE: "io" "Input and output"
 { $heading "Streams" }

basis/help/help-docs.factor

@@ -36,6 +36,7 @@ ARTICLE: "block-elements" "Block elements"
 "Elements used in " { $link $values } " forms:"
 { $subsection $instance }
 { $subsection $maybe }
+{ $subsection $or }
 { $subsection $quotation }
 "Boilerplate paragraphs:"
 { $subsection $low-level-note }
@@ -88,6 +89,12 @@ $nl
     { "an array of markup elements," }
     { "or an array of the form " { $snippet "{ $directive content... }" } ", where " { $snippet "$directive" } " is a markup word whose name starts with " { $snippet "$" } ", and " { $snippet "content..." } " is a series of markup elements" }
 }
+"Here is a more formal schema for the help markup language:"
+{ $code
+"<element> ::== <string> | <simple-element> | <fancy-element>"
+"<simple-element> ::== { <element>* }"
+"<fancy-element> ::== { <type> <element> }"
+}
 { $subsection "element-types" }
 { $subsection "printing-elements" }
 "Related words can be cross-referenced:"
@@ -119,7 +126,7 @@ ARTICLE: "help" "Help system"
 "The help system maintains documentation written in a simple markup language, along with cross-referencing and search. Documentation can either exist as free-standing " { $emphasis "articles" } " or be associated with words."
 { $subsection "browsing-help" }
 { $subsection "writing-help" }
-{ $vocab-subsection "Help lint tool" "help.lint" }
+{ $subsection "help.lint" }
 { $subsection "help-impl" } ;
 
 IN: help

basis/help/markup/markup-tests.factor

@@ -1,5 +1,6 @@
 USING: definitions help help.markup kernel sequences tools.test
-words parser namespaces assocs generic io.streams.string accessors ;
+words parser namespaces assocs generic io.streams.string accessors
+strings math ;
 IN: help.markup.tests
 
 TUPLE: blahblah quux ;
@@ -15,3 +16,12 @@ TUPLE: blahblah quux ;
 [ ] [ \ fooey print-topic ] unit-test
 
 [ ] [ gensym print-topic ] unit-test
+
+[ "a string" ]
+[ [ { $or string } print-element ] with-string-writer ] unit-test
+
+[ "a string or an integer" ]
+[ [ { $or string integer } print-element ] with-string-writer ] unit-test
+
+[ "a string, a fixnum, or an integer" ]
+[ [ { $or string fixnum integer } print-element ] with-string-writer ] unit-test

basis/help/markup/markup.factor

@@ -1,19 +1,12 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays definitions generic io kernel assocs
 hashtables namespaces make parser prettyprint sequences strings
 io.styles vectors words math sorting splitting classes slots
-vocabs help.stylesheet help.topics vocabs.loader quotations ;
+vocabs help.stylesheet help.topics vocabs.loader quotations
+combinators ;
 IN: help.markup
 
-! Simple markup language.
-
-! <element> ::== <string> | <simple-element> | <fancy-element>
-! <simple-element> ::== { <element>* }
-! <fancy-element> ::== { <type> <element> }
-
-! Element types are words whose name begins with $.
-
 PREDICATE: simple-element < array
     [ t ] [ first word? not ] if-empty ;
 
@@ -250,8 +243,21 @@ M: f ($instance)
 
 : $instance ( element -- ) first ($instance) ;
 
+: $or ( element -- )
+    dup length {
+        { 1 [ first ($instance) ] }
+        { 2 [ first2 [ ($instance) " or " print-element ] [ ($instance) ] bi* ] }
+        [
+            drop
+            unclip-last
+            [ [ ($instance) ", " print-element ] each ]
+            [ "or " print-element ($instance) ]
+            bi*
+        ]
+    } case ;
+
 : $maybe ( element -- )
-    $instance " or " print-element { f } $instance ;
+    f suffix $or ;
 
 : $quotation ( element -- )
     { "a " { $link quotation } " with stack effect " } print-element

basis/http/client/client-docs.factor

@@ -1,6 +1,6 @@
 USING: http help.markup help.syntax io.pathnames io.streams.string
 io.encodings.8-bit io.encodings.binary kernel strings urls
-urls.encoding byte-arrays strings assocs sequences ;
+urls.encoding byte-arrays strings assocs sequences destructors ;
 IN: http.client
 
 HELP: download-failed
@@ -36,7 +36,12 @@ HELP: http-get
 
 HELP: http-post
 { $values { "post-data" object } { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } }
-{ $description "Submits a form at a URL." }
+{ $description "Submits an HTTP POST request." }
+{ $errors "Throws an error if the HTTP request fails." } ;
+
+HELP: http-put
+{ $values { "post-data" object } { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } }
+{ $description "Submits an HTTP PUT request." }
 { $errors "Throws an error if the HTTP request fails." } ;
 
 HELP: with-http-get
@@ -67,17 +72,36 @@ ARTICLE: "http.client.get" "GET requests with the HTTP client"
 { $subsection with-http-get }
 { $subsection with-http-request } ;
 
-ARTICLE: "http.client.post" "POST requests with the HTTP client"
+ARTICLE: "http.client.post-data" "HTTP client submission data"
-"As with GET requests, there is a high-level word which takes a " { $link url } " and a lower-level word which constructs an HTTP request object which can be passed to " { $link http-request } ":"
+"HTTP POST and PUT request words take a post data parameter, which can be one of the following:"
-{ $subsection http-post }
-{ $subsection <post-request> }
-"Both words take a post data parameter, which can be one of the following:"
 { $list
-    { "a " { $link byte-array } " or " { $link string } " is sent the server without further encoding" }
+    { "a " { $link byte-array } ": the data is sent the server without further encoding" }
-    { "an " { $link assoc } " is interpreted as a series of form parameters, which are encoded with " { $link assoc>query } }
+    { "a " { $link string } ": the data is encoded and then sent as a series of bytes" }
+    { "an " { $link assoc } ": the assoc is interpreted as a series of form parameters, which are encoded with " { $link assoc>query } }
+    { "an input stream: the contents of the input stream are transmitted to the server without being read entirely into memory - this is useful for large requests" }
     { { $link f } " denotes that there is no post data" }
+    { "a " { $link post-data } " tuple, for additional control" }
+}
+"When passing a stream, you must ensure the stream is closed afterwards. The best way is to use " { $link with-disposal } " or " { $link "destructors" } ". For example,"
+{ $code
+  "\"my-large-post-request.txt\" ascii <file-reader>"
+  "[ URL\" http://www.my-company.com/web-service\" http-post ] with-disposal"
 } ;
 
+ARTICLE: "http.client.post" "POST requests with the HTTP client"
+"Basic usage involves passing post data and a " { $link url } ", and getting a " { $link response } " and data back:"
+{ $subsection http-post }
+"Advanced usage involves constructing a " { $link request } ", which allows " { $link "http.cookies" } " and " { $link "http.headers" } " to be set:"
+{ $subsection <post-request> }
+"Both words take a post data parameter; see " { $link "http.client.post-data" } "." ;
+
+ARTICLE: "http.client.put" "PUT requests with the HTTP client"
+"Basic usage involves passing post data and a " { $link url } ", and getting a " { $link response } " and data back:"
+{ $subsection http-post }
+"Advanced usage involves constructing a " { $link request } ", which allows " { $link "http.cookies" } " and " { $link "http.headers" } " to be set:"
+{ $subsection <post-request> }
+"Both words take a post data parameter; see " { $link "http.client.post-data" } "." ;
+
 ARTICLE: "http.client.encoding" "Character encodings and the HTTP client"
 "The " { $link http-request } ", " { $link http-get } " and " { $link http-post } " words output a sequence containing data that was sent by the server."
 $nl
@@ -95,11 +119,14 @@ ARTICLE: "http.client.errors" "HTTP client errors"
 ARTICLE: "http.client" "HTTP client"
 "The " { $vocab-link "http.client" } " vocabulary implements an HTTP and HTTPS client on top of " { $link "http" } "."
 $nl
-"For HTTPS support, you must load the " { $vocab-link "urls.secure" } " vocab first. If you don't load it, HTTPS will not load and images generated by " { $vocab-link "tools.deploy" } " will be smaller as a result."
+"For HTTPS support, you must load the " { $vocab-link "urls.secure" } " vocab first. If you don't need HTTPS support, don't load " { $vocab-link "urls.secure" } "; this will reduce the size of images generated by " { $vocab-link "tools.deploy" } "."
 $nl
 "There are two primary usage patterns, data retrieval with GET requests and form submission with POST requests:"
 { $subsection "http.client.get" }
 { $subsection "http.client.post" }
+{ $subsection "http.client.put" }
+"Submission data for POST and PUT requests:"
+{ $subsection "http.client.post-data" }
 "More esoteric use-cases, for example HTTP methods other than the above, are accomodated by constructing an empty request object with " { $link <request> } " and filling everything in by hand."
 { $subsection "http.client.encoding" }
 { $subsection "http.client.errors" }

basis/http/client/client.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs kernel math math.parser namespaces make
 sequences strings splitting calendar continuations accessors vectors
@@ -7,9 +7,15 @@ io io.sockets io.streams.string io.files io.timeouts
 io.pathnames io.encodings io.encodings.string io.encodings.ascii
 io.encodings.utf8 io.encodings.8-bit io.encodings.binary
 io.streams.duplex fry ascii urls urls.encoding present
-http http.parsers ;
+http http.parsers http.client.post-data ;
 IN: http.client
 
+ERROR: too-many-redirects ;
+
+CONSTANT: max-redirects 10
+
+<PRIVATE
+
 : write-request-line ( request -- request )
     dup
     [ method>> write bl ]
@@ -21,35 +27,19 @@ IN: http.client
     [ host>> ] [ port>> ] bi dup "http" protocol-port =
     [ drop ] [ ":" swap number>string 3append ] if ;
 
+: set-host-header ( request header -- request header )
+    over url>> url-host "host" pick set-at ;
+
+: set-cookie-header ( header cookies -- header )
+    unparse-cookie "cookie" pick set-at ;
+
 : write-request-header ( request -- request )
     dup header>> >hashtable
-    over url>> host>> [ over url>> url-host "host" pick set-at ] when
+    over url>> host>> [ set-host-header ] when
-    over post-data>> [
+    over post-data>> [ set-post-data-headers ] when*
-        [ raw>> length "content-length" pick set-at ]
+    over cookies>> [ set-cookie-header ] unless-empty
-        [ content-type>> "content-type" pick set-at ]
-        bi
-    ] when*
-    over cookies>> [ unparse-cookie "cookie" pick set-at ] unless-empty
     write-header ;
 
-GENERIC: >post-data ( object -- post-data )
-
-M: post-data >post-data ;
-
-M: string >post-data utf8 encode "application/octet-stream" <post-data> ;
-
-M: byte-array >post-data "application/octet-stream" <post-data> ;
-
-M: assoc >post-data assoc>query ascii encode "application/x-www-form-urlencoded" <post-data> ;
-
-M: f >post-data ;
-
-: unparse-post-data ( request -- request )
-    [ >post-data ] change-post-data ;
-
-: write-post-data ( request -- request )
-    dup method>> [ "POST" = ] [ "PUT" = ] bi or [ dup post-data>> raw>> write ] when ; 
-
 : write-request ( request -- )
     unparse-post-data
     write-request-line
@@ -77,12 +67,6 @@ M: f >post-data ;
     read-response-line
     read-response-header ;
 
-: max-redirects 10 ;
-
-ERROR: too-many-redirects ;
-
-<PRIVATE
-
 DEFER: (with-http-request)
 
 SYMBOL: redirects
@@ -112,15 +96,10 @@ SYMBOL: redirects
         read-crlf B{ } assert= read-chunked
     ] if ; inline recursive
 
-: read-unchunked ( quot: ( chunk -- ) -- )
-    8192 read-partial dup [
-        [ swap call ] [ drop read-unchunked ] 2bi
-    ] [ 2drop ] if ; inline recursive
-
 : read-response-body ( quot response -- )
     binary decode-input
     "transfer-encoding" header "chunked" =
-    [ read-chunked ] [ read-unchunked ] if ; inline
+    [ read-chunked ] [ each-block ] if ; inline
 
 : <request-socket> ( -- stream )
     request get url>> url-addr ascii <client> drop
@@ -148,6 +127,11 @@ SYMBOL: redirects
         [ do-redirect ] [ nip ] if
     ] with-variable ; inline recursive
 
+: <client-request> ( url method -- request )
+    <request>
+        swap >>method
+        swap >url ensure-port >>url ; inline
+
 PRIVATE>
 
 : success? ( code -- ? ) 200 299 between? ;
@@ -158,16 +142,14 @@ ERROR: download-failed response ;
     dup code>> success? [ download-failed ] unless ;
 
 : with-http-request ( request quot -- response )
-    (with-http-request) check-response ; inline
+    [ (with-http-request) check-response ] with-destructors ; inline
 
 : http-request ( request -- response data )
     [ [ % ] with-http-request ] B{ } make
     over content-charset>> decode ;
 
 : <get-request> ( url -- request )
-    <request>
+    "GET" <client-request> ;
-        "GET" >>method
-        swap >url ensure-port >>url ;
 
 : http-get ( url -- response data )
     <get-request> http-request ;
@@ -185,14 +167,19 @@ ERROR: download-failed response ;
     dup download-name download-to ;
 
 : <post-request> ( post-data url -- request )
-    <request>
+    "POST" <client-request>
-        "POST" >>method
-        swap >url ensure-port >>url
         swap >>post-data ;
 
 : http-post ( post-data url -- response data )
     <post-request> http-request ;
 
+: <put-request> ( post-data url -- request )
+    "PUT" <client-request>
+        swap >>post-data ;
+
+: http-put ( post-data url -- response data )
+    <put-request> http-request ;
+
 USING: vocabs vocabs.loader ;
 
 "debugger" vocab [ "http.client.debugger" require ] when

basis/http/client/post-data/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/http/client/post-data/post-data-tests.factor

@@ -0,0 +1,4 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test http.client.post-data ;
+IN: http.client.post-data.tests

basis/http/client/post-data/post-data.factor

@@ -0,0 +1,91 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs destructors http io io.encodings.ascii
+io.encodings.binary io.encodings.string io.encodings.utf8
+io.files io.files.info io.pathnames kernel math.parser
+namespaces sequences strings urls.encoding ;
+IN: http.client.post-data
+
+TUPLE: measured-stream stream size ;
+
+C: <measured-stream> measured-stream
+
+<PRIVATE
+
+GENERIC: (set-post-data-headers) ( header data -- header )
+
+M: sequence (set-post-data-headers)
+    length "content-length" pick set-at ;
+
+M: measured-stream (set-post-data-headers)
+    size>> "content-length" pick set-at ;
+
+M: object (set-post-data-headers)
+    drop "chunked" "transfer-encoding" pick set-at ;
+
+PRIVATE>
+
+: set-post-data-headers ( header post-data -- header )
+    [ data>> (set-post-data-headers) ]
+    [ content-type>> "content-type" pick set-at ] bi ;
+
+<PRIVATE
+
+GENERIC: (write-post-data) ( data -- )
+
+M: sequence (write-post-data) write ;
+
+M: measured-stream (write-post-data)
+    stream>> [ [ write ] each-block ] with-input-stream ;
+
+: write-chunk ( chunk -- )
+    [ length >hex ";\r\n" append ascii encode write ] [ write ] bi ;
+
+M: object (write-post-data)
+    [ [ write-chunk ] each-block ] with-input-stream
+    "0;\r\n" ascii encode write ;
+
+GENERIC: >post-data ( object -- post-data )
+
+M: f >post-data ;
+
+M: post-data >post-data ;
+
+M: string >post-data
+    utf8 encode
+    "application/octet-stream" <post-data>
+        swap >>data ;
+
+M: assoc >post-data
+    "application/x-www-form-urlencoded" <post-data>
+        swap >>params ;
+
+M: object >post-data
+    "application/octet-stream" <post-data>
+        swap >>data ;
+
+: pathname>measured-stream ( pathname -- stream )
+    string>>
+    [ binary <file-reader> &dispose ]
+    [ file-info size>> ] bi
+    <measured-stream> ;
+
+: normalize-post-data ( request -- request )
+    dup post-data>> [
+        dup params>> [
+            assoc>query ascii encode >>data
+        ] when*
+        dup data>> pathname? [
+            [ pathname>measured-stream ] change-data
+        ] when
+        drop
+    ] when* ;
+
+PRIVATE>
+
+: unparse-post-data ( request -- request )
+    [ >post-data ] change-post-data
+    normalize-post-data ;
+
+: write-post-data ( request -- request )
+    dup post-data>> [ data>> (write-post-data) ] when* ;

basis/http/http-docs.factor

@@ -90,7 +90,7 @@ HELP: put-cookie
 { $side-effects "request/response" } ;
 
 HELP: <post-data>
-{ $values { "raw" byte-array } { "content-type" "a MIME type string" } { "post-data" post-data } }
+{ $values { "content-type" "a MIME type string" } { "post-data" post-data } }
 { $description "Creates a new " { $link post-data } "." } ;
 
 HELP: header

basis/http/http-tests.factor

@@ -1,4 +1,4 @@
-USING: http http.server http.client tools.test multiline
+USING: http http.server http.client http.client.private tools.test multiline
 io.streams.string io.encodings.utf8 io.encodings.8-bit
 io.encodings.binary io.encodings.string kernel arrays splitting
 sequences assocs io.sockets db db.sqlite continuations urls
@@ -35,7 +35,7 @@ blah
         { method "POST" }
         { version "1.1" }
         { header H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } }
-        { post-data T{ post-data { content "blah" } { raw "blah" } { content-type "application/octet-stream" } } }
+        { post-data T{ post-data { data "blah" } { content-type "application/octet-stream" } } }
         { cookies V{ } }
     }
 ] [

basis/http/http.factor

@@ -213,12 +213,11 @@ body ;
     raw-response new
         "1.1" >>version ;
 
-TUPLE: post-data raw content content-type ;
+TUPLE: post-data data params content-type content-encoding ;
 
-: <post-data> ( raw content-type -- post-data )
+: <post-data> ( content-type -- post-data )
     post-data new
-        swap >>content-type
+        swap >>content-type ;
-        swap >>raw ;
 
 : parse-content-type-attributes ( string -- attributes )
     " " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ;

basis/http/server/cgi/cgi.factor

@@ -34,7 +34,7 @@ IN: http.server.cgi
         request get "accept" header "HTTP_ACCEPT" set
 
         post-request? [
-            request get post-data>> raw>>
+            request get post-data>> data>>
             [ "CONTENT_TYPE" set ]
             [ length number>string "CONTENT_LENGTH" set ]
             bi
@@ -54,8 +54,8 @@ IN: http.server.cgi
     swap '[
         binary encode-output
         _ output-stream get swap <cgi-process> binary <process-stream> [
-            post-request? [ request get post-data>> raw>> write flush ] when
+            post-request? [ request get post-data>> data>> write flush ] when
-            input-stream get swap (stream-copy)
+            '[ _ write ] each-block
         ] with-stream
     ] >>body ;
 

basis/http/server/server.factor

@@ -15,6 +15,8 @@ io.streams.limited
 io.servers.connection
 io.timeouts
 fry logging logging.insomniac calendar urls urls.encoding
+mime.multipart
+unicode.categories
 http
 http.parsers
 http.server.responses
@@ -24,8 +26,6 @@ html.elements
 html.streams ;
 IN: http.server
 
-\ parse-cookie DEBUG add-input-logging
-
 : check-absolute ( url -- url )
     dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline
 
@@ -36,17 +36,34 @@ IN: http.server
 : read-request-header ( request -- request )
     read-header >>header ;
 
-: parse-post-data ( post-data -- post-data )
+ERROR: no-boundary ;
-    [ ] [ raw>> ] [ content-type>> ] tri
+
-    "application/x-www-form-urlencoded" = [ query>assoc ] when
+: parse-multipart-form-data ( string -- separator )
-    >>content ;
+    ";" split1 nip
+    "=" split1 nip [ no-boundary ] unless* ;
+
+: read-multipart-data ( request -- form-variables uploaded-files )
+    [ "content-type" header ]
+    [ "content-length" header string>number ] bi
+    unlimit-input
+    stream-eofs limit-input
+    binary decode-input
+    parse-multipart-form-data parse-multipart ;
+
+: read-content ( request -- bytes )
+    "content-length" header string>number read ;
+
+: parse-content ( request content-type -- post-data )
+    [ <post-data> swap ] keep {
+        { "multipart/form-data" [ read-multipart-data assoc-union >>params ] }
+        { "application/x-www-form-urlencoded" [ read-content query>assoc >>params ] }
+        [ drop read-content >>data ]
+    } case ;
 
 : read-post-data ( request -- request )
     dup method>> "POST" = [
-        [ ]
+        dup dup "content-type" header
-        [ "content-length" header string>number read ]
+        ";" split1 drop parse-content >>post-data
-        [ "content-type" header ] tri
-        <post-data> parse-post-data >>post-data
     ] when ;
 
 : extract-host ( request -- request )
@@ -80,7 +97,7 @@ GENERIC: write-full-response ( request response -- )
     [ content-type>> "application/octet-stream" or ]
     [ content-charset>> encoding>name ]
     bi
-    [ "; charset=" swap 3append ] when* ;
+    [ "; charset=" glue ] when* ;
 
 : ensure-domain ( cookie -- cookie )
     [
@@ -179,8 +196,8 @@ LOG: httpd-hit NOTICE
 
 LOG: httpd-header NOTICE
 
-: log-header ( headers name -- )
+: log-header ( request name -- )
-    tuck header 2array httpd-header ;
+    [ nip ] [ header ] 2bi 2array httpd-header ;
 
 : log-request ( request -- )
     [ [ method>> ] [ url>> ] bi 2array httpd-hit ]
@@ -236,7 +253,7 @@ TUPLE: http-server < threaded-server ;
 M: http-server handle-client*
     drop
     [
-        64 1024 * limit-input
+        64 1024 * stream-throws limit-input
         ?refresh-all
         [ read-request ] ?benchmark
         [ do-request ] ?benchmark

basis/interval-maps/interval-maps.factor

@@ -31,7 +31,8 @@ PRIVATE>
 
 : interval-at* ( key map -- value ? )
     [ drop ] [ array>> find-interval ] 2bi
-    tuck interval-contains? [ third t ] [ drop f f ] if ;
+    [ nip ] [ interval-contains? ] 2bi
+    [ third t ] [ drop f f ] if ;
 
 : interval-at ( key map -- value ) interval-at* drop ;
 

basis/io/directories/directories-docs.factor

@@ -166,6 +166,7 @@ ARTICLE: "io.directories" "Directory manipulation"
 { $subsection "current-directory" }
 { $subsection "io.directories.listing" }
 { $subsection "io.directories.create" }
-{ $subsection "delete-move-copy" } ;
+{ $subsection "delete-move-copy" }
+{ $subsection "io.directories.hierarchy" } ;
 
 ABOUT: "io.directories"

basis/io/directories/windows/windows.factor

@@ -33,13 +33,13 @@ M: windows delete-directory ( path -- )
     RemoveDirectory win32-error=0/f ;
 
 : find-first-file ( path -- WIN32_FIND_DATA handle )
-    "WIN32_FIND_DATA" <c-object> tuck
+    "WIN32_FIND_DATA" <c-object>
-    FindFirstFile
+    [ nip ] [ FindFirstFile ] 2bi
     [ INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ] keep ;
 
 : find-next-file ( path -- WIN32_FIND_DATA/f )
-    "WIN32_FIND_DATA" <c-object> tuck
+    "WIN32_FIND_DATA" <c-object>
-    FindNextFile 0 = [
+    [ nip ] [ FindNextFile ] 2bi 0 = [
         GetLastError ERROR_NO_MORE_FILES = [
             win32-error
         ] unless drop f

basis/io/encodings/ascii/ascii.factor

@@ -9,7 +9,8 @@ IN: io.encodings.ascii
 
 : decode-if< ( stream encoding max -- character )
     nip swap stream-read1 dup
-    [ tuck > [ >fixnum ] [ drop replacement-char ] if ] [ 2drop f ] if ; inline
+    [ [ nip ] [ > ] 2bi [ >fixnum ] [ drop replacement-char ] if ]
+    [ 2drop f ] if ; inline
 PRIVATE>
 
 SINGLETON: ascii

basis/io/files/info/unix/freebsd/freebsd.factor

@@ -13,7 +13,7 @@ version io-size owner syncreads syncwrites asyncreads asyncwrites ;
 M: freebsd new-file-system-info freebsd-file-system-info new ;
 
 M: freebsd file-system-statfs ( path -- byte-array )
-    "statfs" <c-object> tuck statfs io-error ;
+    "statfs" <c-object> [ statfs io-error ] keep ;
 
 M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-info )
     {
@@ -40,7 +40,7 @@ M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-inf
     } cleave ;
 
 M: freebsd file-system-statvfs ( path -- byte-array )
-    "statvfs" <c-object> tuck statvfs io-error ;
+    "statvfs" <c-object> [ statvfs io-error ] keep ;
 
 M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info )
     {

basis/io/files/info/unix/linux/linux.factor

@@ -14,7 +14,7 @@ namelen ;
 M: linux new-file-system-info linux-file-system-info new ;
 
 M: linux file-system-statfs ( path -- byte-array )
-    "statfs64" <c-object> tuck statfs64 io-error ;
+    "statfs64" <c-object> [ statfs64 io-error ] keep ;
 
 M: linux statfs>file-system-info ( struct -- statfs )
     {
@@ -32,7 +32,7 @@ M: linux statfs>file-system-info ( struct -- statfs )
     } cleave ;
 
 M: linux file-system-statvfs ( path -- byte-array )
-    "statvfs64" <c-object> tuck statvfs64 io-error ;
+    "statvfs64" <c-object> [ statvfs64 io-error ] keep ;
 
 M: linux statvfs>file-system-info ( struct -- statfs )
     {

basis/io/files/info/unix/macosx/macosx.factor

@@ -20,10 +20,10 @@ M: macosx file-systems ( -- array )
 M: macosx new-file-system-info macosx-file-system-info new ;
 
 M: macosx file-system-statfs ( normalized-path -- statfs )
-    "statfs64" <c-object> tuck statfs64 io-error ;
+    "statfs64" <c-object> [ statfs64 io-error ] keep ;
 
 M: macosx file-system-statvfs ( normalized-path -- statvfs )
-    "statvfs" <c-object> tuck statvfs io-error ;
+    "statvfs" <c-object> [ statvfs io-error ] keep ;
 
 M: macosx statfs>file-system-info ( file-system-info byte-array -- file-system-info' )
     {

basis/io/files/info/unix/netbsd/netbsd.factor

@@ -16,7 +16,7 @@ idx mount-from ;
 M: netbsd new-file-system-info netbsd-file-system-info new ;
 
 M: netbsd file-system-statvfs
-    "statvfs" <c-object> tuck statvfs io-error ;
+    "statvfs" <c-object> [ statvfs io-error ] keep ;
 
 M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
     {

basis/io/files/info/unix/openbsd/openbsd.factor

@@ -14,7 +14,7 @@ owner ;
 M: openbsd new-file-system-info freebsd-file-system-info new ;
 
 M: openbsd file-system-statfs
-    "statfs" <c-object> tuck statfs io-error ;
+    "statfs" <c-object> [ statfs io-error ] keep ;
 
 M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info' )
     {
@@ -41,7 +41,7 @@ M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info
     } cleave ;
 
 M: openbsd file-system-statvfs ( normalized-path -- statvfs )
-    "statvfs" <c-object> tuck statvfs io-error ;
+    "statvfs" <c-object> [ statvfs io-error ] keep ;
 
 M: openbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
     {

basis/io/ports/ports.factor

@@ -99,7 +99,7 @@ TUPLE: output-port < buffered-port ;
     output-port <buffered-port> ;
 
 : wait-to-write ( len port -- )
-    tuck buffer>> buffer-capacity <=
+    [ nip ] [ buffer>> buffer-capacity <= ] 2bi
     [ drop ] [ stream-flush ] if ; inline
 
 M: output-port stream-write1

basis/io/sockets/windows/nt/nt.factor

@@ -6,7 +6,7 @@ libc math sequences threads system combinators accessors ;
 IN: io.sockets.windows.nt
 
 : malloc-int ( object -- object )
-    "int" heap-size malloc tuck 0 set-alien-signed-4 ; inline
+    "int" heap-size malloc [ nip ] [ 0 set-alien-signed-4 ] 2bi ; inline
 
 M: winnt WSASocket-flags ( -- DWORD )
     WSA_FLAG_OVERLAPPED ;

basis/io/streams/limited/limited-docs.factor

@@ -0,0 +1,90 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel math io ;
+IN: io.streams.limited
+
+HELP: <limited-stream>
+{ $values
+     { "stream" "an input stream" } { "limit" integer } { "mode" "a " { $link limited-stream } " mode singleton" }
+     { "stream'" "an input stream" }
+}
+{ $description "Constructs a new " { $link limited-stream } " from an existing stream. User code should use " { $link limit } " or " { $link limit-input } "." } ;
+
+HELP: limit
+{ $values
+     { "stream" "an input stream" } { "limit" integer } { "mode" "a " { $link limited-stream } " mode singleton" }
+     { "stream'" "a stream" }
+}
+{ $description "Changes a decoder's stream to be a limited stream, or wraps " { $snippet "stream" } " in a " { $link limited-stream } "." }
+{ $examples "Throwing an exception:"
+    { $example
+        "USING: continuations io io.streams.limited io.streams.string"
+        "kernel prettyprint ;"
+        "["
+        "    \"123456\" <string-reader> 3 stream-throws limit"
+        "    100 swap stream-read ."
+        "] [ ] recover ."
+        "T{ limit-exceeded }"
+    }
+    "Returning " { $link f } " on exhaustion:"
+    { $example
+        "USING: accessors continuations io io.streams.limited"
+        "io.streams.string kernel prettyprint ;"
+        "\"123456\" <string-reader> 3 stream-eofs limit"
+        "100 swap stream-read ."
+        "\"123\""
+    }
+} ;
+
+HELP: unlimit
+{ $values
+     { "stream" "an input stream" }
+     { "stream'" "a stream" }
+}
+{ $description "Returns the underlying stream of a limited stream." } ;
+
+HELP: limited-stream
+{ $values
+    { "value" "a limited-stream class" }
+}
+{ $description "Limited streams wrap other streams, changing their behavior to throw an exception or return " { $link f } " upon exhaustion." } ;
+
+HELP: limit-input
+{ $values
+     { "limit" integer } { "mode" "a " { $link limited-stream } " mode singleton" }
+}
+{ $description "Wraps the current " { $link input-stream } " in a " { $link limited-stream } "." } ;
+
+HELP: unlimit-input
+{ $description "Returns the underlying stream of the limited-stream stored in " { $link input-stream } "." } ;
+
+HELP: stream-eofs
+{ $values
+    { "value" "a " { $link limited-stream } " mode singleton" }
+}
+{ $description "If the " { $slot "mode" } " of a limited stream is set to this singleton, the stream will return " { $link f } " upon exhaustion." } ;
+
+HELP: stream-throws
+{ $values
+    { "value" "a " { $link limited-stream } " mode singleton" }
+}
+{ $description "If the " { $slot "mode" } " of a limited stream is set to this singleton, the stream will throw " { $link limit-exceeded } " upon exhaustion." } ;
+
+{ stream-eofs stream-throws } related-words
+
+ARTICLE: "io.streams.limited" "Limited input streams"
+"The " { $vocab-link "io.streams.limited" } " vocabulary wraps a stream to behave as if it had only a limited number of bytes, either throwing an error or returning " { $link f } " upon reaching the end." $nl
+"Wrap a stream in a limited stream:"
+{ $subsection limit }
+"Wrap the current " { $link input-stream } " in a limited stream:"
+{ $subsection limit-input }
+"Unlimits a limited stream:"
+{ $subsection unlimit }
+"Unlimits the current " { $link input-stream } ":"
+{ $subsection limit-input }
+"Make a limited stream throw an exception on exhaustion:"
+{ $subsection stream-throws }
+"Make a limited stream return " { $link f } " on exhaustion:"
+{ $subsection stream-eofs } ;
+
+ABOUT: "io.streams.limited"

basis/io/streams/limited/limited-tests.factor

@@ -1,14 +1,14 @@
-IN: io.streams.limited.tests
 USING: io io.streams.limited io.encodings io.encodings.string
 io.encodings.ascii io.encodings.binary io.streams.byte-array
-namespaces tools.test strings kernel ;
+namespaces tools.test strings kernel io.streams.string accessors ;
+IN: io.streams.limited.tests
 
 [ ] [
     "hello world\nhow are you today\nthis is a very long line indeed"
     ascii encode binary <byte-reader> "data" set
 ] unit-test
 
-[ ] [ "data" get 24 <limited-stream> "limited" set ] unit-test
+[ ] [ "data" get 24 stream-throws <limited-stream> "limited" set ] unit-test
 
 [ CHAR: h ] [ "limited" get stream-read1 ] unit-test
 
@@ -25,7 +25,7 @@ namespaces tools.test strings kernel ;
     ascii encode binary <byte-reader> "data" set
 ] unit-test
 
-[ ] [ "data" get 7 <limited-stream> "limited" set ] unit-test
+[ ] [ "data" get 7 stream-throws <limited-stream> "limited" set ] unit-test
 
 [ "abc" CHAR: \n ] [ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test
 
@@ -34,7 +34,28 @@ namespaces tools.test strings kernel ;
 [ "he" CHAR: l ] [
     B{ CHAR: h CHAR: e CHAR: l CHAR: l CHAR: o }
     ascii <byte-reader> [
-        5 limit-input
+        5 stream-throws limit-input
         "l" read-until
     ] with-input-stream
 ] unit-test
+
+[ CHAR: a ]
+[ "a" <string-reader> 1 stream-eofs <limited-stream> stream-read1 ] unit-test
+
+[ "abc" ]
+[
+    "abc" <string-reader> 3 stream-eofs <limited-stream>
+    4 swap stream-read
+] unit-test
+
+[ f ]
+[
+    "abc" <string-reader> 3 stream-eofs <limited-stream>
+    4 over stream-read drop 10 swap stream-read
+] unit-test
+
+[ t ]
+[
+    "abc" <string-reader> 3 stream-eofs limit unlimit
+    "abc" <string-reader> =
+] unit-test

basis/io/streams/limited/limited.factor

@@ -1,45 +1,80 @@
-! Copyright (C) 2008 Slava Pestov
+! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math io io.encodings destructors accessors
-sequences namespaces byte-vectors ;
+sequences namespaces byte-vectors fry combinators ;
 IN: io.streams.limited
 
-TUPLE: limited-stream stream count limit ;
+TUPLE: limited-stream stream count limit mode ;
 
-: <limited-stream> ( stream limit -- stream' )
+SINGLETONS: stream-throws stream-eofs ;
+
+: <limited-stream> ( stream limit mode -- stream' )
     limited-stream new
+        swap >>mode
         swap >>limit
         swap >>stream
         0 >>count ;
 
-GENERIC# limit 1 ( stream limit -- stream' )
+GENERIC# limit 2 ( stream limit mode -- stream' )
 
-M: decoder limit [ clone ] dip [ limit ] curry change-stream ;
+M: decoder limit ( stream limit mode -- stream' )
+    [ clone ] 2dip '[ _ _ limit ] change-stream ;
 
-M: object limit <limited-stream> ;
+M: object limit ( stream limit mode -- stream' )
+    <limited-stream> ;
 
-: limit-input ( limit -- ) input-stream [ swap limit ] change ;
+: unlimit ( stream -- stream' )
+    [ stream>> ] change-stream ;
+
+: limit-input ( limit mode -- ) input-stream [ -rot limit ] change ;
+
+: unlimit-input ( -- ) input-stream [ unlimit ] change ;
 
 ERROR: limit-exceeded ;
 
-: check-limit ( n stream -- )
+ERROR: bad-stream-mode mode ;
-    [ + ] change-count
+
-    [ count>> ] [ limit>> ] bi >=
+<PRIVATE
-    [ limit-exceeded ] when ; inline
+
+: adjust-limit ( n stream -- n' stream )
+    2dup [ + ] change-count
+    [ count>> ] [ limit>> ] bi >
+    [
+        dup mode>> {
+            { stream-throws [ limit-exceeded ] }
+            { stream-eofs [ 
+                dup [ count>> ] [ limit>> ] bi -
+                '[ _ - ] dip
+            ] }
+            [ bad-stream-mode ]
+        } case
+    ] when ; inline
+
+: maybe-read ( n limited-stream quot: ( n stream -- seq/f ) -- seq/f )
+    [ adjust-limit ] dip
+    pick 0 <= [ 3drop f ] [ [ stream>> ] dip call ] if ; inline
+
+PRIVATE>
 
 M: limited-stream stream-read1
-    1 over check-limit stream>> stream-read1 ;
+    1 swap 
+    [ nip stream-read1 ] maybe-read ;
 
 M: limited-stream stream-read
-    2dup check-limit stream>> stream-read ;
+    [ stream-read ] maybe-read ;
 
 M: limited-stream stream-read-partial
-    2dup check-limit stream>> stream-read-partial ;
+    [ stream-read-partial ] maybe-read ;
+
+<PRIVATE
 
 : (read-until) ( stream seps buf -- stream seps buf sep/f )
     3dup [ [ stream-read1 dup ] dip memq? ] dip
     swap [ drop ] [ push (read-until) ] if ;
 
+PRIVATE>
+
 M: limited-stream stream-read-until
     swap BV{ } clone (read-until) [ 2nip B{ } like ] dip ;
 

basis/match/match.factor

@@ -80,7 +80,7 @@ MACRO: match-cond ( assoc -- )
     (match-first) drop ;
 
 : (match-all) ( seq pattern-seq -- )
-    tuck (match-first) swap 
+    [ nip ] [ (match-first) swap ] 2bi
     [ 
         , [ swap (match-all) ] [ drop ] if* 
     ] [ 2drop ] if* ;

basis/math/functions/functions.factor

@@ -122,11 +122,9 @@ PRIVATE>
     [ * ] 2keep gcd nip /i ; foldable
 
 : mod-inv ( x n -- y )
-    tuck gcd 1 = [
+    [ nip ] [ gcd 1 = ] 2bi
-        dup 0 < [ + ] [ nip ] if
+    [ dup 0 < [ + ] [ nip ] if ]
-    ] [
+    [ "Non-trivial divisor found" throw ] if ; foldable
-        "Non-trivial divisor found" throw
-    ] if ; foldable
 
 : ^mod ( x y n -- z )
     over 0 < [

basis/math/polynomials/polynomials.factor

@@ -68,7 +68,8 @@ PRIVATE>
     dup V{ 0 } clone p= [
         drop nip
     ] [
-        tuck p/mod [ pick p* swap [ swapd p- ] dip ] dip (pgcd)
+        [ nip ] [ p/mod ] 2bi
+        [ pick p* swap [ swapd p- ] dip ] dip (pgcd)
     ] if ;
 
 PRIVATE>

basis/math/ratios/ratios.factor

@@ -24,7 +24,7 @@ M: integer /
         "Division by zero" throw
     ] [
         dup 0 < [ [ neg ] bi@ ] when
-        2dup gcd nip tuck /i [ /i ] dip fraction>
+        2dup gcd nip tuck [ /i ] 2bi@ fraction>
     ] if ;
 
 M: ratio hashcode*

basis/mime/multipart/multipart.factor

@@ -1,105 +1,162 @@
-! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators io kernel locals math multiline
+USING: multiline kernel sequences io splitting fry namespaces
-sequences splitting prettyprint namespaces http.parsers
+http.parsers hashtables assocs combinators ascii io.files.unique
-ascii assocs unicode.case io.files.unique io.files io.encodings.binary
+accessors io.encodings.binary io.files byte-arrays math
-byte-arrays io.encodings make fry ;
+io.streams.string combinators.short-circuit strings ;
 IN: mime.multipart
 
-TUPLE: multipart-stream stream n leftover separator ;
+CONSTANT: buffer-size 65536
+CONSTANT: separator-prefix "\r\n--"
 
-: <multipart-stream> ( stream separator -- multipart-stream )
+TUPLE: multipart
-    multipart-stream new
+end-of-stream?
-        swap >>separator
+current-separator mime-separator
-        swap >>stream
+header
-        16 2^ >>n ;
+content-disposition bytes
+filename temp-file
+name name-content
+uploaded-files
+form-variables ;
 
-<PRIVATE
+TUPLE: mime-file headers filename temporary-path ;
+TUPLE: mime-variable headers key value ;
 
-: ?append ( seq1 seq2 -- newseq/seq2 )
+: <multipart> ( mime-separator -- multipart )
-    over [ append ] [ nip ] if ;
+    multipart new
+        swap >>mime-separator
+        H{ } clone >>uploaded-files
+        H{ } clone >>form-variables ;
 
-: ?cut* ( seq n -- before after )
+ERROR: bad-header bytes ;
-    over length over <= [ drop f swap ] [ cut* ] if ;
-    
-: read-n ( stream -- bytes end-stream? )
-    [ f ] change-leftover
-    [ n>> ] [ stream>> ] bi stream-read [ ?append ] keep not ;
 
-: multipart-split ( bytes separator -- before after seq=? )
+: mime-write ( sequence -- )
-    2dup sequence= [ 2drop f f t ] [ split1 f ] if ;
+    >byte-array write ;
 
-:: multipart-step-found ( bytes stream quot: ( bytes -- ) -- ? )
+: parse-headers ( string -- hashtable )
-    bytes [ quot unless-empty ]
+    string-lines harvest [ parse-header-line ] map >hashtable ;
-    [ stream (>>leftover) quot unless-empty ] if-empty f ; inline
 
-:: multipart-step-not-found ( bytes stream end-stream? separator quot: ( bytes -- ) -- ? )
+ERROR: end-of-stream multipart ;
-    bytes end-stream? [
+
-        quot unless-empty f
+: fill-bytes ( multipart -- multipart )
+    buffer-size read
+    [ '[ _ append ] change-bytes ]
+    [ t >>end-of-stream? ] if* ;
+
+: maybe-fill-bytes ( multipart -- multipart )
+    dup bytes>> [ fill-bytes ] unless  ;
+
+: split-bytes ( bytes separator -- leftover-bytes safe-to-dump )
+    2dup [ length ] [ length 1- ] bi* < [
+        drop f
     ] [
-        separator length 1- ?cut* stream (>>leftover)
+        length 1- cut-slice swap
-        quot unless-empty t
-    ] if ; inline
-
-:: multipart-step ( stream bytes end-stream? separator quot: ( bytes -- ) -- ? end-stream? )
-    #! return t to loop again
-    bytes separator multipart-split
-    [ 2drop f ]
-    [
-        [ stream quot multipart-step-found ]
-        [ stream end-stream? separator quot multipart-step-not-found ] if*
-    ] if stream leftover>> end-stream? not or >boolean ;
-
-
-:: multipart-step-loop ( stream quot1: ( bytes -- ) -- ? )
-    stream dup [ read-n ] [ separator>> ] bi quot1 multipart-step
-    swap [ drop stream quot1 multipart-step-loop ] when ; inline recursive
-
-SYMBOL: header
-SYMBOL: parsed-header
-SYMBOL: magic-separator
-
-: trim-blanks ( str -- str' ) [ blank? ] trim ;
-
-: trim-quotes ( str -- str' )
-    [ [ CHAR: " = ] [ CHAR: ' = ] bi or ] trim ;
-
-: parse-content-disposition ( str -- content-disposition hash )
-    ";" split [ first ] [ rest-slice ] bi [ "=" split ] map
-    [ [ trim-blanks ] [ trim-quotes ] bi* ] H{ } assoc-map-as ;
-
-: parse-multipart-header ( string -- headers )
-    "\r\n" split harvest
-    [ parse-header-line first2 ] H{ } map>assoc ;
-
-ERROR: expected-file ;
-
-TUPLE: uploaded-file path filename name ;
-
-: (parse-multipart) ( stream -- ? )
-    "\r\n\r\n" >>separator
-    header off
-    dup [ header [ prepend ] change ] multipart-step-loop drop
-    header get dup magic-separator get [ length ] bi@ < [
-        2drop f
-    ] [
-        parse-multipart-header
-        parsed-header set
-        "\r\n" magic-separator get append >>separator
-        "factor-upload" "httpd" make-unique-file tuck
-        binary [ [ write ] multipart-step-loop ] with-file-writer swap
-        "content-disposition" parsed-header get at parse-content-disposition
-        nip [ "filename" swap at ] [ "name" swap at ] bi
-        uploaded-file boa ,
     ] if ;
 
-PRIVATE>
+: dump-until-separator ( multipart -- multipart )
+    dup
+    [ current-separator>> ] [ bytes>> ] bi
+    [ nip ] [ start ] 2bi [
+        cut-slice
+        [ mime-write ]
+        [ over current-separator>> length tail-slice >>bytes ] bi*
+    ] [
+        drop
+        dup [ bytes>> ] [ current-separator>> ] bi split-bytes
+        [ mime-write ] when*
+        >>bytes fill-bytes dup end-of-stream?>> [ dump-until-separator ] unless
+    ] if* ;
 
-: parse-multipart ( stream -- array )
+: dump-string ( multipart separator -- multipart string )
-    [
+    >>current-separator
-        "\r\n" <multipart-stream>
+    [ dump-until-separator ] with-string-writer ;
-        magic-separator off
+
-        dup [ magic-separator [ prepend ] change ]
+: read-header ( multipart -- multipart )
-            multipart-step-loop drop
+    "\r\n\r\n" dump-string dup "--\r" = [
-        '[ [ _ (parse-multipart) ] loop ] { } make
+        drop
-    ] with-scope ;
+    ] [
+        parse-headers >>header
+    ] if ;
+
+: empty-name? ( string -- ? )
+    { "''" "\"\"" "" f } member? ;
+
+: save-uploaded-file ( multipart -- )
+    dup filename>> empty-name? [
+        drop
+    ] [
+        [ [ header>> ] [ filename>> ] [ temp-file>> ] tri mime-file boa ]
+        [ filename>> ]
+        [ uploaded-files>> set-at ] tri
+    ] if ;
+
+: save-form-variable ( multipart -- )
+    dup name>> empty-name? [
+        drop
+    ] [
+        [ [ header>> ] [ name>> ] [ name-content>> ] tri mime-variable boa ]
+        [ name>> ]
+        [ form-variables>> set-at ] tri
+    ] if ;
+
+: dump-mime-file ( multipart filename -- multipart )
+    binary <file-writer> [
+        dup mime-separator>> >>current-separator dump-until-separator
+    ] with-output-stream ;
+
+: dump-file ( multipart -- multipart )
+    "factor-" "-upload" make-unique-file
+    [ >>temp-file ] [ dump-mime-file ] bi ;
+
+: parse-content-disposition-form-data ( string -- hashtable )
+    ";" split
+    [ "=" split1 [ [ blank? ] trim ] bi@ ] H{ } map>assoc ;
+
+: lookup-disposition ( multipart string -- multipart value/f )
+    over content-disposition>> at ;
+
+ERROR: unknown-content-disposition multipart ;
+
+: parse-form-data ( multipart -- multipart )
+    "filename" lookup-disposition [
+        >>filename
+        [ dump-file ] [ save-uploaded-file ] bi
+    ] [
+        "name" lookup-disposition [
+            [ dup mime-separator>> dump-string >>name-content ] dip
+            >>name dup save-form-variable
+        ] [
+             unknown-content-disposition
+        ] if*
+    ] if* ;
+
+ERROR: no-content-disposition multipart ;
+
+: process-header ( multipart -- multipart )
+    "content-disposition" over header>> at ";" split1 swap {
+        { "form-data" [
+            parse-content-disposition-form-data >>content-disposition
+            parse-form-data
+        ] }
+        [ no-content-disposition ]
+    } case ;
+
+: assert-sequence= ( a b -- )
+    2dup sequence= [ 2drop ] [ assert ] if ;
+
+: read-assert-sequence= ( sequence -- )
+    [ length read ] keep assert-sequence= ;
+
+: parse-beginning ( multipart -- multipart )
+    "--" read-assert-sequence=
+    dup mime-separator>>
+    [ read-assert-sequence= ]
+    [ separator-prefix prepend >>mime-separator ] bi ;
+
+: parse-multipart-loop ( multipart -- multipart )
+    read-header
+    dup end-of-stream?>> [ process-header parse-multipart-loop ] unless ;
+
+: parse-multipart ( separator -- form-variables uploaded-files )
+    <multipart> parse-beginning parse-multipart-loop
+    [ form-variables>> ] [ uploaded-files>> ] bi ;

basis/multiline/multiline-tests.factor

@@ -14,3 +14,8 @@ bar
 
 [ "hello\nworld" ] [ <" hello
 world"> ] unit-test
+
+[ "hello" "world" ] [ <" hello"> <" world"> ] unit-test
+
+[ "\nhi" ] [ <"
+hi"> ] unit-test

basis/multiline/multiline.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces make parser lexer kernel sequences words
-quotations math accessors ;
+quotations math accessors locals ;
 IN: multiline
 
 <PRIVATE
@@ -26,22 +26,38 @@ PRIVATE>
     (( -- string )) define-inline ; parsing
 
 <PRIVATE
-: (parse-multiline-string) ( start-index end-text -- end-index )
+
-    lexer get line-text>> [
+:: (parse-multiline-string) ( i end -- j )
-        2dup start
+    lexer get line-text>> :> text
-        [ rot dupd [ swap subseq % ] 2dip length + ] [
+    text [
-            rot tail % "\n" % 0
+        end text i start* [| j |
-            lexer get next-line swap (parse-multiline-string)
+            i j text subseq % j end length +
+        ] [
+            text i short tail % CHAR: \n ,
+            lexer get next-line
+            0 end (parse-multiline-string)
         ] if*
-    ] [ nip unexpected-eof ] if* ;
+    ] [ end unexpected-eof ] if ;
+        
 PRIVATE>
 
 : parse-multiline-string ( end-text -- str )
     [
-        lexer get [ swap (parse-multiline-string) ] change-column drop
+        lexer get
-    ] "" make rest ;
+        [ 1+ swap (parse-multiline-string) ]
+        change-column drop
+    ] "" make ;
 
 : <"
     "\">" parse-multiline-string parsed ; parsing
 
+: <'
+    "'>" parse-multiline-string parsed ; parsing
+
+: {'
+    "'}" parse-multiline-string parsed ; parsing
+
+: {"
+    "\"}" parse-multiline-string parsed ; parsing
+
 : /* "*/" parse-multiline-string drop ; parsing

basis/peg/peg-tests.factor

@@ -2,9 +2,11 @@
 ! See http://factorcode.org/license.txt for BSD license.
 !
 USING: kernel tools.test strings namespaces make arrays sequences 
-       peg peg.private accessors words math accessors ;
+       peg peg.private peg.parsers accessors words math accessors ;
 IN: peg.tests
 
+[ ] [ reset-pegs ] unit-test
+
 [
   "endbegin" "begin" token parse
 ] must-fail
@@ -193,4 +195,16 @@ IN: peg.tests
   "B" [ drop t ] satisfy [ 66 >= ] semantic parse
 ] unit-test
 
-{ f } [ \ + T{ parser f f f } equal? ] unit-test
+{ f } [ \ + T{ parser f f f } equal? ] unit-test
+
+USE: compiler
+
+[ ] [ disable-compiler ] unit-test
+
+[ ] [ "" epsilon parse drop ] unit-test
+
+[ ] [ enable-compiler ] unit-test
+
+[ [ ] ] [ "" epsilon [ drop [ [ ] ] call ] action parse ] unit-test
+  
+[ [ ] ] [ "" epsilon [ drop [ [ ] ] ] action [ call ] action parse ] unit-test

basis/persistent/hashtables/nodes/leaf/leaf.factor

@@ -6,7 +6,8 @@ persistent.hashtables.nodes ;
 IN: persistent.hashtables.nodes.leaf
 
 : matching-key? ( key hashcode leaf-node -- ? )
-    tuck hashcode>> eq? [ key>> = ] [ 2drop f ] if ; inline
+    [ nip ] [ hashcode>> eq? ] 2bi
+    [ key>> = ] [ 2drop f ] if ; inline
 
 M: leaf-node (entry-at) [ matching-key? ] keep and ;
 

basis/prettyprint/prettyprint.factor

@@ -248,7 +248,8 @@ GENERIC: declarations. ( obj -- )
 M: object declarations. drop ;
 
 : declaration. ( word prop -- )
-    tuck name>> word-prop [ pprint-word ] [ drop ] if ;
+    [ nip ] [ name>> word-prop ] 2bi
+    [ pprint-word ] [ drop ] if ;
 
 M: word declarations.
     {

basis/refs/refs-docs.factor

@@ -14,7 +14,7 @@ ARTICLE: "refs" "References to assoc entries"
 "References to values:"
 { $subsection value-ref }
 { $subsection <value-ref> }
-"References are used by the inspector." ;
+"References are used by the UI inspector." ;
 
 ABOUT: "refs"
 

basis/regexp/dfa/dfa.factor

@@ -72,7 +72,7 @@ IN: regexp.dfa
     dup
     [ nfa-traversal-flags>> ]
     [ dfa-table>> transitions>> keys ] bi
-    [ tuck [ swap at ] with map concat ] with H{ } map>assoc
+    [ [ nip ] [ [ swap at ] with map concat ] 2bi ] with H{ } map>assoc
     >>dfa-traversal-flags drop ;
 
 : construct-dfa ( regexp -- )

basis/regexp/nfa/nfa.factor

@@ -9,6 +9,8 @@ regexp.transition-tables words sets regexp.classes unicode.case.private ;
 ! before processing starts
 IN: regexp.nfa
 
+ERROR: feature-is-broken feature ;
+
 SYMBOL: negation-mode
 : negated? ( -- ? ) negation-mode get 0 or odd? ; 
 
@@ -181,6 +183,7 @@ M: character-class-range nfa-node ( node -- )
     ] if ;
 
 M: capture-group nfa-node ( node -- )
+    "capture-groups" feature-is-broken
     eps literal-transition add-simple-entry
     capture-group-on add-traversal-flag
     term>> nfa-node
@@ -201,6 +204,7 @@ M: negation nfa-node ( node -- )
     negation-mode dec ;
 
 M: lookahead nfa-node ( node -- )
+    "lookahead" feature-is-broken
     eps literal-transition add-simple-entry
     lookahead-on add-traversal-flag
     term>> nfa-node
@@ -209,6 +213,7 @@ M: lookahead nfa-node ( node -- )
     2 [ concatenate-nodes ] times ;
 
 M: lookbehind nfa-node ( node -- )
+    "lookbehind" feature-is-broken
     eps literal-transition add-simple-entry
     lookbehind-on add-traversal-flag
     term>> nfa-node

basis/regexp/parser/parser.factor

@@ -63,7 +63,7 @@ left-parenthesis pipe caret dash ;
 : cut-out ( vector n -- vector' vector ) cut rest ;
 ERROR: cut-stack-error ;
 : cut-stack ( obj vector -- vector' vector )
-    tuck last-index [ cut-stack-error ] unless* cut-out swap ;
+    [ nip ] [ last-index ] 2bi [ cut-stack-error ] unless* cut-out swap ;
 
 : <possessive-kleene-star> ( obj -- kleene ) possessive-kleene-star boa ;
 : <reluctant-kleene-star> ( obj -- kleene ) reluctant-kleene-star boa ;

basis/regexp/regexp-tests.factor

@@ -1,5 +1,5 @@
 USING: regexp tools.test kernel sequences regexp.parser
-regexp.traversal eval strings ;
+regexp.traversal eval strings multiline ;
 IN: regexp-tests
 
 \ <regexp> must-infer
@@ -76,6 +76,8 @@ IN: regexp-tests
 [ t ] [ "bar" "foo|bar" <regexp> matches? ] unit-test
 [ f ] [ "foobar" "foo|bar" <regexp> matches? ] unit-test
 
+/*
+! FIXME
 [ f ] [ "" "(a)" <regexp> matches? ] unit-test
 [ t ] [ "a" "(a)" <regexp> matches? ] unit-test
 [ f ] [ "aa" "(a)" <regexp> matches? ] unit-test
@@ -83,6 +85,7 @@ IN: regexp-tests
 
 [ f ] [ "aababaaabbac" "(a|b)+" <regexp> matches? ] unit-test
 [ t ] [ "ababaaabba" "(a|b)+" <regexp> matches? ] unit-test
+*/
 
 [ f ] [ "" "a{1}" <regexp> matches? ] unit-test
 [ t ] [ "a" "a{1}" <regexp> matches? ] unit-test
@@ -165,9 +168,12 @@ IN: regexp-tests
 [ f ] [ "0" "[^\\d]" <regexp> matches? ] unit-test
 [ t ] [ "a" "[^\\d]" <regexp> matches? ] unit-test
 
+/*
+! FIXME
 [ t ] [ "a" "[a-z]{1,}|[A-Z]{2,4}|b*|c|(f|g)*" <regexp> matches? ] unit-test
 [ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}|b*|c|(f|g)*" <regexp> matches? ] unit-test
 [ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}" <regexp> matches? ] unit-test
+*/
 
 [ t ] [ "1000" "\\d{4,6}" <regexp> matches? ] unit-test
 [ t ] [ "1000" "[0-9]{4,6}" <regexp> matches? ] unit-test
@@ -238,7 +244,7 @@ IN: regexp-tests
 
 [ t ] [ "abc" <reversed> R/ abc/r matches? ] unit-test
 [ t ] [ "abc" <reversed> R/ a[bB][cC]/r matches? ] unit-test
-[ t ] [ "adcbe" R/ a(?r)(bcd)(?-r)e/ matches? ] unit-test
+! [ t ] [ "adcbe" R/ a(?r)(bcd)(?-r)e/ matches? ] unit-test ! FIXME
 
 [ t ] [ "s@f" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
 [ f ] [ "a" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
@@ -247,6 +253,8 @@ IN: regexp-tests
 [ t ] [ "abc*" "[^\\*]*\\*" <regexp> matches? ] unit-test
 [ t ] [ "bca" "[^a]*a" <regexp> matches? ] unit-test
 
+/*
+! FIXME
 [ ] [
     "(0[lL]?|[1-9]\\d{0,9}(\\d{0,9}[lL])?|0[xX]\\p{XDigit}{1,8}(\\p{XDigit}{0,8}[lL])?|0[0-7]{1,11}([0-7]{0,11}[lL])?|([0-9]+\\.[0-9]*|\\.[0-9]+)([eE][+-]?[0-9]+)?[fFdD]?|[0-9]+([eE][+-]?[0-9]+[fFdD]?|([eE][+-]?[0-9]+)?[fFdD]))"
     <regexp> drop
@@ -270,6 +278,7 @@ IN: regexp-tests
 [ "abc" ] [ "abc" "(ab|a)(bc)?" <regexp> first-match >string ] unit-test
 
 [ "b" ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match >string ] unit-test
+*/
 
 ! [ t ] [ "a:b" ".+:?" <regexp> matches? ] unit-test
 
@@ -293,6 +302,8 @@ IN: regexp-tests
 [ "1.2.3.4" ]
 [ "1ABC2DEF3GHI4JK" R/ [A-Z]+/ "." re-replace ] unit-test
 
+/*
+! FIXME
 [ f ] [ "ab" "a(?!b)" <regexp> first-match ] unit-test
 [ "a" ] [ "ac" "a(?!b)" <regexp> first-match >string ] unit-test
 ! [ t ] [ "fxxbar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
@@ -303,6 +314,7 @@ IN: regexp-tests
 
 [ 3 ] [ "foobar" "foo(?=bar)" <regexp> match-head ] unit-test
 [ f ] [ "foobxr" "foo(?=bar)" <regexp> match-head ] unit-test
+*/
 
 ! Bug in parsing word
 [ t ] [ "a" R' a' matches?  ] unit-test

basis/regexp/transition-tables/transition-tables.factor

@@ -35,7 +35,7 @@ TUPLE: transition-table transitions start-state final-states ;
         H{ } clone >>final-states ;
 
 : maybe-initialize-key ( key hashtable -- )
-    2dup key? [ 2drop ] [ H{ } clone -rot set-at ] if ;
+    2dup key? [ 2drop ] [ [ H{ } clone ] 2dip set-at ] if ;
 
 : set-transition ( transition hash -- )
     #! set the state as a key

basis/serialize/serialize.factor

@@ -221,8 +221,7 @@ SYMBOL: deserialized
     (deserialize) (deserialize) 2dup lookup
     dup [ 2nip ] [
         drop
-        "Unknown word: " -rot
+        2array unparse "Unknown word: " prepend throw
-        2array unparse append throw
     ] if ;
 
 : deserialize-gensym ( -- word )

basis/state-parser/state-parser-docs.factor

@@ -1,72 +0,0 @@
-USING: help.markup help.syntax ;
-IN: state-parser
-
-ABOUT: { "state-parser" "main" }
-
-ARTICLE: { "state-parser" "main" } "State-based parsing"
-    "This module defines a state-based parsing mechanism. It was originally created for libs/xml, but is also used in libs/csv and can be easily used in new libraries or applications."
-    { $subsection spot }
-    { $subsection skip-until }
-    { $subsection take-until }
-    { $subsection take-char }
-    { $subsection take-string }
-    { $subsection next }
-    { $subsection state-parse }
-    { $subsection get-char }
-    { $subsection take-rest }
-    { $subsection string-parse }
-    { $subsection expect }
-    { $subsection expect-string }
-    { $subsection parsing-error } ;
-
-HELP: get-char
-{ $values { "char" "the current character" } }
-{ $description "Accesses the current character of the stream that is being parsed" } ;
-
-HELP: take-rest
-{ $values { "string" "the rest of the parser input" } }
-{ $description "Exausts the stream of the parser input and returns a string representing the rest of the input" } ;
-
-HELP: string-parse
-{ $values { "input" "a string" } { "quot" "a quotation ( -- )" } }
-{ $description "Calls the given quotation using the given string as parser input" }
-{ $see-also state-parse } ;
-
-HELP: expect
-{ $values { "ch" "a number representing a character" } }
-{ $description "Asserts that the current character is the given ch, and moves to the next spot" }
-{ $see-also expect-string } ;
-
-HELP: expect-string
-{ $values { "string" "a string" } }
-{ $description "Asserts that the current parsing spot is followed by the given string, and skips the parser past that string" }
-{ $see-also expect } ;
-
-HELP: spot
-{ $var-description "This variable represents the location in the program. It is a tuple T{ spot f char column line next } where char is the current character, line is the line number, column is the column number, and line-str is the full contents of the line, as a string. The contents shouldn't be accessed directly but rather with the proxy words get-char set-char get-line etc." } ;
-
-HELP: skip-until
-{ $values { "quot" "a quotation ( -- ? )" } }
-{ $description "executes " { $link next } " until the quotation yields false. Usually, the quotation will call " { $link get-char } " in its test, but not always." }
-{ $see-also take-until } ;
-
-HELP: take-until
-{ $values { "quot" "a quotation ( -- ? )" } { "string" "a string" } }
-{ $description "like " { $link skip-until } " but records what it passes over and outputs the string." }
-{ $see-also skip-until take-char take-string } ;
-
-HELP: take-char
-{ $values { "ch" "a character" } { "string" "a string" } }
-{ $description "records the document from the current spot to the first instance of the given character. Outputs the content between those two points." }
-{ $see-also take-until take-string } ;
-
-HELP: take-string
-{ $values { "match" "a string to match" } { "string" "the portion of the XML document" } }
-{ $description "records the document from the current spot to the first instance of the given character. Outputs the content between those two points." }
-{ $notes "match may not contain a newline" } ;
-
-HELP: next
-{ $description "originally written as " { $code "spot inc" } ", code that would no longer run, this word moves the state of the XML parser to the next place in the source file, keeping track of appropriate debugging information." } ;
-
-HELP: parsing-error
-{ $class-description "class from which parsing errors inherit, containing information about which line and column the error occured on, and what the line was. Contains three slots, line, an integer, column, another integer, and line-str, a string" } ;

basis/state-parser/state-parser.factor

@@ -1,158 +0,0 @@
-! Copyright (C) 2005, 2006 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: io io.streams.string kernel math namespaces sequences
-strings circular prettyprint debugger ascii sbufs fry summary
-accessors ;
-IN: state-parser
-
-! * Basic underlying words
-! Code stored in stdio
-! Spot is composite so it won't be lost in sub-scopes
-TUPLE: spot char line column next ;
-
-C: <spot> spot
-
-: get-char ( -- char ) spot get char>> ;
-: set-char ( char -- ) spot get swap >>char drop ;
-: get-line ( -- line ) spot get line>> ;
-: set-line ( line -- ) spot get swap >>line drop ;
-: get-column ( -- column ) spot get column>> ;
-: set-column ( column -- ) spot get swap >>column drop ;
-: get-next ( -- char ) spot get next>> ;
-: set-next ( char -- ) spot get swap >>next drop ;
-
-! * Errors
-TUPLE: parsing-error line column ;
-
-: parsing-error ( class -- obj )
-    new
-        get-line >>line
-        get-column >>column ;
-M: parsing-error summary ( obj -- str )
-    [
-        "Parsing error" print
-        "Line: " write dup line>> .
-        "Column: " write column>> .
-    ] with-string-writer ;
-
-TUPLE: expected < parsing-error should-be was ;
-: expected ( should-be was -- * )
-    \ expected parsing-error
-        swap >>was
-        swap >>should-be throw ;
-M: expected summary ( obj -- str )
-    [
-        dup call-next-method write
-        "Token expected: " write dup should-be>> print
-        "Token present: " write was>> print
-    ] with-string-writer ;
-
-TUPLE: unexpected-end < parsing-error ;
-: unexpected-end ( -- * ) \ unexpected-end parsing-error throw ;
-M: unexpected-end summary ( obj -- str )
-    [
-        call-next-method write
-        "File unexpectedly ended." print
-    ] with-string-writer ;
-
-TUPLE: missing-close < parsing-error ;
-: missing-close ( -- * ) \ missing-close parsing-error throw ;
-M: missing-close summary ( obj -- str )
-    [
-        call-next-method write
-        "Missing closing token." print
-    ] with-string-writer ;
-
-SYMBOL: prolog-data
-
-! * Basic utility words
-
-: record ( char -- )
-    CHAR: \n =
-    [ 0 get-line 1+ set-line ] [ get-column 1+ ] if
-    set-column ;
-
-! (next) normalizes \r\n and \r
-: (next) ( -- char )
-    get-next read1
-    2dup swap CHAR: \r = [
-        CHAR: \n =
-        [ nip read1 ] [ nip CHAR: \n swap ] if
-    ] [ drop ] if
-    set-next dup set-char ;
-
-: next ( -- )
-    #! Increment spot.
-    get-char [ unexpected-end ] unless (next) record ;
-
-: next* ( -- )
-    get-char [ (next) record ] when ;
-
-: skip-until ( quot: ( -- ? ) -- )
-    get-char [
-        [ call ] keep swap [ drop ] [
-            next skip-until
-        ] if
-    ] [ drop ] if ; inline recursive
-
-: take-until ( quot -- string )
-    #! Take the substring of a string starting at spot
-    #! from code until the quotation given is true and
-    #! advance spot to after the substring.
-    10 <sbuf> [
-        '[ @ [ t ] [ get-char _ push f ] if ] skip-until
-    ] keep >string ; inline
-
-: take-rest ( -- string )
-    [ f ] take-until ;
-
-: take-char ( ch -- string )
-    [ dup get-char = ] take-until nip ;
-
-TUPLE: not-enough-characters < parsing-error ;
-: not-enough-characters ( -- * )
-    \ not-enough-characters parsing-error throw ;
-M: not-enough-characters summary ( obj -- str )
-    [
-        call-next-method write
-        "Not enough characters" print
-    ] with-string-writer ;
-
-: take ( n -- string )
-    [ 1- ] [ <sbuf> ] bi [
-        '[ drop get-char [ next _ push f ] [ t ] if* ] contains? drop
-    ] keep get-char [ over push ] when* >string ;
-
-: pass-blank ( -- )
-    #! Advance code past any whitespace, including newlines
-    [ get-char blank? not ] skip-until ;
-
-: string-matches? ( string circular -- ? )
-    get-char over push-circular
-    sequence= ;
-
-: take-string ( match -- string )
-    dup length <circular-string>
-    [ 2dup string-matches? ] take-until nip
-    dup length rot length 1- - head
-    get-char [ missing-close ] unless next ;
-
-: expect ( ch -- )
-    get-char 2dup = [ 2drop ] [
-        [ 1string ] bi@ expected
-    ] if next ;
-
-: expect-string ( string -- )
-    dup [ get-char next ] replicate 2dup =
-    [ 2drop ] [ expected ] if ;
-
-: init-parser ( -- )
-    0 1 0 f <spot> spot set
-    read1 set-next next ;
-
-: state-parse ( stream quot -- )
-    ! with-input-stream implicitly creates a new scope which we use
-    swap [ init-parser call ] with-input-stream ; inline
-
-: string-parse ( input quot -- )
-    [ <string-reader> ] dip state-parse ; inline

basis/state-parser/summary.txt

@@ -1 +0,0 @@
-State-machined based text parsing framework

basis/syndication/syndication.factor

@@ -9,7 +9,7 @@ USING: xml.utilities kernel assocs xml.generator math.order
 IN: syndication
 
 : any-tag-named ( tag names -- tag-inside )
-    f -rot [ tag-named nip dup ] with find 2drop ;
+    [ f ] 2dip [ tag-named nip dup ] with find 2drop ;
 
 TUPLE: feed title url entries ;
 

basis/ui/gadgets/editors/editors.factor

@@ -350,7 +350,7 @@ M: editor gadget-text* editor-string % ;
     dupd editor-select-next mark>caret ;
 
 : editor-select ( from to editor -- )
-    tuck caret>> set-model mark>> set-model ;
+    tuck [ mark>> set-model ] [ caret>> set-model ] 2bi* ;
 
 : select-elt ( editor elt -- )
     [ [ [ editor-caret* ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi

basis/ui/gadgets/gadgets.factor

@@ -165,7 +165,9 @@ M: gadget dim-changed
     in-layout? get [ invalidate ] [ invalidate* ] if ;
 
 M: gadget (>>dim) ( dim gadget -- )
-    2dup dim>> = [ 2drop ] [ tuck call-next-method dim-changed ] if ;
+    2dup dim>> =
+    [ 2drop ]
+    [ [ nip ] [ call-next-method ] 2bi dim-changed ] if ;
 
 GENERIC: pref-dim* ( gadget -- dim )
 
@@ -250,7 +252,7 @@ M: gadget ungraft* drop ;
     f >>parent drop ;
 
 : unfocus-gadget ( child gadget -- )
-    tuck focus>> eq? [ f >>focus ] when drop ;
+    [ nip ] [ focus>> eq? ] 2bi [ f >>focus ] when drop ;
 
 SYMBOL: in-layout?
 
@@ -286,10 +288,7 @@ SYMBOL: in-layout?
     dup unparent
     over >>parent
     tuck ((add-gadget))
-    tuck graft-state>> second
+    tuck graft-state>> second [ graft ] [ drop  ] if ;
-        [ graft ]
-        [ drop  ]
-    if ;
 
 : add-gadget ( parent child -- parent )
     not-in-layout
@@ -316,7 +315,7 @@ SYMBOL: in-layout?
 : (screen-rect) ( gadget -- loc ext )
     dup parent>> [
         [ rect-extent ] dip (screen-rect)
-        [ tuck v+ ] dip vmin [ v+ ] dip
+        [ [ nip ] [ v+ ] 2bi ] dip [ vmin ] [ v+ ] 2bi*
     ] [
         rect-extent
     ] if* ;

basis/ui/gadgets/incremental/incremental.factor

@@ -23,7 +23,7 @@ M: incremental pref-dim*
     ] keep orientation>> set-axis ;
 
 : update-cursor ( gadget incremental -- )
-    tuck next-cursor >>cursor drop ;
+    [ nip ] [ next-cursor ] 2bi >>cursor drop ;
 
 : incremental-loc ( gadget incremental -- )
     [ cursor>> ] [ orientation>> ] bi v*

basis/unicode/breaks/breaks.factor

@@ -96,7 +96,7 @@ PRIVATE>
 
 : first-grapheme ( str -- i )
     unclip-slice grapheme-class over
-    [ grapheme-class tuck grapheme-break? ] find drop
+    [ grapheme-class [ nip ] [ grapheme-break? ] 2bi ] find drop
     nip swap length or 1+ ;
 
 <PRIVATE

basis/unicode/case/case.factor

@@ -8,8 +8,6 @@ QUALIFIED: ascii
 IN: unicode.case
 
 <PRIVATE
-: at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ; inline
-
 : ch>lower ( ch -- lower ) simple-lower at-default ; inline
 : ch>upper ( ch -- upper ) simple-upper at-default ; inline
 : ch>title ( ch -- title ) simple-title at-default ; inline

basis/unicode/collation/collation.factor

@@ -125,7 +125,7 @@ PRIVATE>
 
 : filter-ignorable ( weights -- weights' )
     f swap [
-        tuck primary>> zero? and
+        [ nip ] [ primary>> zero? and ] 2bi
         [ swap ignorable?>> or ]
         [ swap completely-ignorable? or not ] 2bi
     ] filter nip ;

basis/unix/unix.factor

@@ -155,8 +155,8 @@ FUNCTION: int utime ( char* path, utimebuf* buf ) ;
 
 : change-file-times ( filename access modification -- )
     "utimebuf" <c-object>
-    tuck set-utimbuf-modtime
+    [ set-utimbuf-modtime ] keep
-    tuck set-utimbuf-actime
+    [ set-utimbuf-actime ] keep
     [ utime ] unix-system-call drop ;
 
 FUNCTION: int pclose ( void* file ) ;

basis/validators/validators.factor

@@ -65,7 +65,7 @@ IN: validators
     v-regexp ;
 
 : v-url ( str -- str )
-    "URL" R' (ftp|http|https)://\S+' v-regexp ;
+    "URL" R' (?:ftp|http|https)://\S+' v-regexp ;
 
 : v-captcha ( str -- str )
     dup empty? [ "must remain blank" throw ] unless ;

basis/x11/clipboard/clipboard.factor

@@ -41,7 +41,7 @@ TUPLE: x-clipboard atom contents ;
     ] if ;
 
 : own-selection ( prop win -- )
-    dpy get -rot CurrentTime XSetSelectionOwner drop
+    [ dpy get ] 2dip CurrentTime XSetSelectionOwner drop
     flush-dpy ;
 
 : set-targets-prop ( evt -- )

basis/x11/windows/windows.factor

@@ -37,7 +37,7 @@ IN: x11.windows
 : set-size-hints ( window -- )
     "XSizeHints" <c-object>
     USPosition over set-XSizeHints-flags
-    dpy get -rot XSetWMNormalHints ;
+    [ dpy get ] 2dip XSetWMNormalHints ;
 
 : auto-position ( window loc -- )
     { 0 0 } = [ drop ] [ set-size-hints ] if ;

basis/xml/autoencoding/autoencoding.factor

@@ -0,0 +1,64 @@
+! Copyright (C) 2005, 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces xml.name io.encodings.utf8 xml.elements
+io.encodings.utf16 xml.tokenize xml.state math ascii sequences
+io.encodings.string io.encodings combinators ;
+IN: xml.autoencoding
+
+: continue-make-tag ( str -- tag )
+    parse-name-starting middle-tag end-tag ;
+
+: start-utf16le ( -- tag )
+    utf16le decode-input-if
+    CHAR: ? expect
+    0 expect check instruct ;
+
+: 10xxxxxx? ( ch -- ? )
+    -6 shift 3 bitand 2 = ;
+          
+: start<name ( ch -- tag )
+    ascii?
+    [ utf8 decode-input-if next make-tag ] [
+        next
+        [ get-next 10xxxxxx? not ] take-until
+        get-char suffix utf8 decode
+        utf8 decode-input-if next
+        continue-make-tag
+    ] if ;
+          
+: start< ( -- tag )
+    get-next {
+        { 0 [ next next start-utf16le ] }
+        { CHAR: ? [ check next next instruct ] } ! XML prolog parsing sets the encoding
+        { CHAR: ! [ check utf8 decode-input next next direct ] }
+        [ check start<name ]
+    } case ;
+
+: skip-utf8-bom ( -- tag )
+    "\u0000bb\u0000bf" expect utf8 decode-input
+    CHAR: < expect check make-tag ;
+
+: decode-expecting ( encoding string -- tag )
+    [ decode-input-if next ] [ expect-string ] bi* check make-tag ;
+
+: start-utf16be ( -- tag )
+    utf16be "<" decode-expecting ;
+
+: skip-utf16le-bom ( -- tag )
+    utf16le "\u0000fe<" decode-expecting ;
+
+: skip-utf16be-bom ( -- tag )
+    utf16be "\u0000ff<" decode-expecting ;
+
+: start-document ( -- tag )
+    get-char {
+        { CHAR: < [ start< ] }
+        { 0 [ start-utf16be ] }
+        { HEX: EF [ skip-utf8-bom ] }
+        { HEX: FF [ skip-utf16le-bom ] }
+        { HEX: FE [ skip-utf16be-bom ] }
+        { f [ "" ] }
+        [ drop utf8 decode-input-if f ]
+        ! Same problem as with <e`>, in the case of XML chunks?
+    } case check ;
+

basis/xml/autoencoding/summary.txt

@@ -0,0 +1 @@
+Implements the automatic detection of encodings of XML documents

basis/xml/backend/backend.factor

@@ -1,6 +0,0 @@
-! Copyright (C) 2008 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-IN: xml.backend
-
-! A stack of { tag children } pairs
-SYMBOL: xml-stack

basis/xml/char-classes/char-classes.factor

@@ -1,21 +1,33 @@
 ! Copyright (C) 2005, 2007 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences unicode.syntax math math.order ;
+USING: kernel sequences unicode.syntax math math.order combinators ;
 IN: xml.char-classes
 
-CATEGORY: 1.0name-start* Ll Lu Lo Lt Nl \u000559\u0006E5\u0006E6_ ;
+CATEGORY: 1.0name-start* Ll Lu Lo Lt Nl \u000559\u0006E5\u0006E6_: ;
 : 1.0name-start? ( char -- ? )
     dup 1.0name-start*? [ drop t ] 
     [ HEX: 2BB HEX: 2C1 between? ] if ;
 
-CATEGORY: 1.0name-char Ll Lu Lo Lt Nl Mc Me Mn Lm Nd _-.\u000387 ;
+CATEGORY: 1.0name-char Ll Lu Lo Lt Nl Mc Me Mn Lm Nd _-.\u000387: ;
 
-CATEGORY: 1.1name-start Ll Lu Lo Lm Ln Nl _ ;
+CATEGORY: 1.1name-start Ll Lu Lo Lm Ln Nl _: ;
 
-CATEGORY: 1.1name-char Ll Lu Lo Lm Ln Nl Mc Mn Nd Pc Cf _-.\u0000b7 ;
+CATEGORY: 1.1name-char Ll Lu Lo Lm Ln Nl Mc Mn Nd Pc Cf _-.\u0000b7: ;
 
 : name-start? ( 1.0? char -- ? )
     swap [ 1.0name-start? ] [ 1.1name-start? ] if ;
 
 : name-char? ( 1.0? char -- ? )
     swap [ 1.0name-char? ] [ 1.1name-char? ] if ;
+
+: text? ( 1.0? char -- ? )
+    ! 1.0:
+    ! #x9 | #xA | #xD | [#x20-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF]
+    ! 1.1:
+    ! [#x1-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF]
+    {
+        { [ dup HEX: 20 < ] [ "\t\r\n" member? and ] }
+        { [ nip dup HEX: D800 < ] [ drop t ] }
+        { [ dup HEX: E000 < ] [ drop f ] }
+        [ { HEX: FFFE HEX: FFFF } member? not ]
+    } cond ;

basis/xml/char-classes/summary.txt

@@ -0,0 +1 @@
+XML-related character classes

basis/xml/data/data-docs.factor

@@ -0,0 +1,152 @@
+USING: help.markup help.syntax sequences strings ;
+IN: xml.data
+
+ABOUT: "xml.data"
+
+ARTICLE: "xml.data" "XML data types"
+{ $vocab-link "xml.data" } " defines a simple document object model for XML. Everything is simply a tuple and can be manipulated as such."
+{ $subsection { "xml.data" "classes" } }
+{ $subsection { "xml.data" "constructors" } }
+"Simple words for manipulating names:"
+    { $subsection names-match? }
+    { $subsection assure-name }
+"For high-level tools for manipulating XML, see " { $vocab-link "xml.utilities" } ;
+
+ARTICLE: { "xml.data" "classes" } "XML data classes"
+    "Data types that XML documents are made of:"
+    { $subsection name }
+    { $subsection tag }
+    { $subsection contained-tag }
+    { $subsection open-tag }
+    { $subsection xml }
+    { $subsection prolog }
+    { $subsection comment }
+    { $subsection instruction }
+    { $subsection element-decl }
+    { $subsection attlist-decl }
+    { $subsection entity-decl }
+    { $subsection system-id }
+    { $subsection public-id }
+    { $subsection doctype-decl }
+    { $subsection notation-decl } ;
+
+ARTICLE: { "xml.data" "constructors" } "XML data constructors"
+    "These data types are constructed with:"
+    { $subsection <name> }
+    { $subsection <tag> }
+    { $subsection <contained-tag> }
+    { $subsection <xml> }
+    { $subsection <prolog> }
+    { $subsection <comment> }
+    { $subsection <instruction> }
+    { $subsection <simple-name> }
+    { $subsection <element-decl> }
+    { $subsection <attlist-decl> }
+    { $subsection <entity-decl> }
+    { $subsection <system-id> }
+    { $subsection <public-id> }
+    { $subsection <doctype-decl> }
+    { $subsection <notation-decl> } ;
+
+HELP: tag
+{ $class-description "tuple representing an XML tag, delegating to a " { $link
+name } ", containing the slots attrs (an alist of names to strings) and children (a sequence). Tags implement the sequence protocol by acting like a sequence of its chidren, and the assoc protocol by acting like its attributes." }
+{ $see-also <tag> name contained-tag xml } ;
+
+HELP: <tag>
+{ $values { "name" "an XML tag name" }
+    { "attrs" "an alist of names to strings" }
+    { "children" sequence }
+    { "tag" tag } }
+{ $description "constructs an XML " { $link tag } " with the name (not a string) and tag attributes specified in attrs and children specified" }
+{ $see-also tag <contained-tag> } ;
+
+HELP: name
+{ $class-description "represents an XML name, with the fields space (a string representing the namespace, as written in the document, tag (a string of the actual name of the tag) and url (a string of the URL that the namespace points to)" }
+{ $see-also <name> tag } ;
+
+HELP: <name>
+{ $values { "space" "a string" } { "main" "a string" } { "url" "a string" }
+    { "name" "an XML tag name" } }
+{ $description "creates a name tuple with the name-space space and the tag-name tag and the tag-url url." }
+{ $see-also name <tag> } ;
+
+HELP: contained-tag
+{ $class-description "delegates to tag representing a tag like <a/> with no contents. The tag attributes are accessed with tag-attrs" }
+{ $see-also tag <contained-tag> } ;
+
+HELP: <contained-tag>
+{ $values { "name" "an XML tag name" }
+    { "attrs" "an alist from names to strings" }
+    { "tag" tag } }
+{ $description "creates an empty tag (like <a/>) with the specified name and tag attributes. This delegates to tag" }
+{ $see-also contained-tag <tag> } ;
+
+HELP: xml
+{ $class-description "tuple representing an XML document, delegating to the main tag, containing the fields prolog (the header <?xml...?>), before (whatever comes between the prolog and the main tag) and after (whatever comes after the main tag)" }
+{ $see-also <xml> tag prolog } ;
+
+HELP: <xml>
+{ $values { "prolog" "an XML prolog" } { "before" "a sequence of XML elements" }
+{ "body" tag } { "after" "a sequence of XML elements" } { "xml" "an XML document" } }
+{ $description "creates an XML document, delegating to the main tag, with the specified prolog, before, and after" }
+{ $see-also xml <tag> } ;
+
+HELP: prolog
+{ $class-description "represents an XML prolog, with the tuple fields version (containing \"1.0\" or \"1.1\"), encoding (a string representing the encoding type), and standalone (t or f, whether the document is standalone without external entities)" }
+{ $see-also <prolog> xml } ;
+
+HELP: <prolog>
+{ $values { "version" "a string, 1.0 or 1.1" }
+{ "encoding" "a string" } { "standalone" "a boolean" } { "prolog" "an XML prolog" } }
+{ $description "creates an XML prolog tuple" }
+{ $see-also prolog <xml> } ;
+
+HELP: comment
+{ $class-description "represents a comment in XML. Has one slot, text, which contains the string of the comment" }
+{ $see-also <comment> } ;
+
+HELP: <comment>
+{ $values { "text" "a string" } { "comment" "a comment" } }
+{ $description "creates an XML comment tuple" }
+{ $see-also comment } ;
+
+HELP: instruction
+{ $class-description "represents an XML instruction, such as <?xsl stylesheet='foo.xml'?>. Contains one slot, text, which contains the string between the question marks." }
+{ $see-also <instruction> } ;
+
+HELP: <instruction>
+{ $values { "text" "a string" } { "instruction" "an XML instruction" } }
+{ $description "creates an XML parsing instruction, such as <?xsl stylesheet='foo.xml'?>." }
+{ $see-also instruction } ;
+
+HELP: opener
+{ $class-description "describes an opening tag, like <a>. Contains two slots, name and attrs containing, respectively, the name of the tag and its attributes. Usually, the name-url will be f." }
+{ $see-also closer contained } ;
+
+HELP: closer
+{ $class-description "describes a closing tag, like </a>. Contains one slot, name, containing the tag's name. Usually, the name-url will be f." }
+{ $see-also opener contained } ;
+
+HELP: contained
+{ $class-description "represents a self-closing tag, like <a/>. Contains two slots, name and attrs containing, respectively, the name of the tag and its attributes. Usually, the name-url will be f." }
+{ $see-also opener closer } ;
+
+HELP: open-tag
+{ $class-description "represents a tag that does have children, ie is not a contained tag" }
+{ $notes "the constructor used for this class is simply " { $link <tag> } "." }
+{ $see-also tag contained-tag } ;
+
+HELP: names-match?
+{ $values { "name1" "a name" } { "name2" "a name" } { "?" "t or f" } }
+{ $description "checks to see if the two names match, that is, if all fields are equal, ignoring fields whose value is f in either name." }
+{ $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: assure-name
+{ $values { "string/name" "a string or a name" } { "name" "a name" } }
+{ $description "Converts a string into an XML name, if it is not already a name." } ;
+
+HELP: <simple-name>
+{ $values { "string" string } { "name" name } }
+{ $description "Converts a string into an XML name with an empty prefix and URL." } ;

basis/xml/data/data.factor

@@ -1,11 +1,16 @@
-! Copyright (C) 2005, 2006 Daniel Ehrenberg
+! Copyright (C) 2005, 2009 Daniel Ehrenberg
 ! 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 fry ;
+macros words quotations combinators slots fry strings ;
 IN: xml.data
 
-TUPLE: name space main url ;
+UNION: nullable-string string POSTPONE: f ;
+
+TUPLE: name
+    { space nullable-string }
+    { main string }
+    { url nullable-string } ;
 C: <name> name
 
 : ?= ( object/f object/f -- ? )
@@ -17,50 +22,15 @@ C: <name> name
     [ [ main>> ] bi@ ?= ] 2tri and and ;
 
 : <simple-name> ( string -- name )
+    "" swap f <name> ;
+
+: <null-name> ( string -- name )
     f swap f <name> ;
 
 : assure-name ( string/name -- name )
-    dup name? [ <simple-name> ] unless ;
+    dup name? [ <null-name> ] unless ;
 
-TUPLE: opener name attrs ;
+TUPLE: attrs { alist sequence } ;
-C: <opener> opener
-
-TUPLE: closer name ;
-C: <closer> closer
-
-TUPLE: contained name attrs ;
-C: <contained> contained
-
-TUPLE: comment text ;
-C: <comment> comment
-
-TUPLE: 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
-
-TUPLE: prolog version encoding standalone ;
-C: <prolog> prolog
-
-TUPLE: attrs alist ;
 C: <attrs> attrs
 
 : attr@ ( key alist -- index {key,value} )
@@ -92,14 +62,74 @@ M: attrs assoc-like
 M: attrs clear-assoc
     f >>alist drop ;
 M: attrs delete-at
-    tuck attr@ drop [ swap alist>> delete-nth ] [ drop ] if* ;
+    [ nip ] [ attr@ drop ] 2bi
+    [ swap alist>> delete-nth ] [ drop ] if* ;
 
 M: attrs clone
     alist>> clone <attrs> ;
 
 INSTANCE: attrs assoc
 
-TUPLE: tag name attrs children ;
+TUPLE: opener { name name } { attrs attrs } ;
+C: <opener> opener
+
+TUPLE: closer { name name } ;
+C: <closer> closer
+
+TUPLE: contained { name name } { attrs attrs } ;
+C: <contained> contained
+
+TUPLE: comment { text string } ;
+C: <comment> comment
+
+TUPLE: directive ;
+
+TUPLE: element-decl < directive
+    { name string } { content-spec string } ;
+C: <element-decl> element-decl
+
+TUPLE: attlist-decl < directive
+    { name string } { att-defs string } ;
+C: <attlist-decl> attlist-decl
+
+UNION: boolean t POSTPONE: f ;
+
+TUPLE: entity-decl < directive
+    { name string }
+    { def string }
+    { pe? boolean } ;
+C: <entity-decl> entity-decl
+
+TUPLE: system-id { system-literal string } ;
+C: <system-id> system-id
+
+TUPLE: public-id { pubid-literal string } { system-literal string } ;
+C: <public-id> public-id
+
+UNION: id system-id public-id POSTPONE: f ;
+
+TUPLE: doctype-decl < directive
+    { name string }
+    { external-id id }
+    { internal-subset sequence } ;
+C: <doctype-decl> doctype-decl
+
+TUPLE: notation-decl < directive name id ;
+C: <notation-decl> notation-decl
+
+TUPLE: instruction { text string } ;
+C: <instruction> instruction
+
+TUPLE: prolog
+    { version string }
+    { encoding string }
+    { standalone boolean } ;
+C: <prolog> prolog
+
+TUPLE: tag
+    { name name }
+    { attrs attrs }
+    { children sequence } ;
 
 : <tag> ( name attrs children -- tag )
     [ assure-name ] [ T{ attrs } assoc-like ] [ ] tri*
@@ -131,7 +161,11 @@ MACRO: clone-slots ( class -- tuple )
 M: tag clone
     tag clone-slots ;
 
-TUPLE: xml prolog before body after ;
+TUPLE: xml
+    { prolog prolog }
+    { before sequence }
+    { body tag }
+    { after sequence } ;
 C: <xml> xml
 
 CONSULT: sequence-protocol xml body>> ;

basis/xml/data/summary.txt

@@ -0,0 +1 @@
+Contains XML data types and basic tools for manipulation

basis/xml/dtd/authors.txt

@@ -0,0 +1 @@
+Daniel Ehrenberg

basis/xml/dtd/dtd.factor

@@ -0,0 +1,69 @@
+! Copyright (C) 2005, 2009 Daniel Ehrenberg, Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: xml.tokenize xml.data xml.state kernel sequences ascii
+fry xml.errors combinators hashtables namespaces xml.entities
+strings ;
+IN: xml.dtd
+
+: take-word ( -- string )
+    [ get-char blank? ] take-until ;
+
+: take-decl-contents ( -- first second )
+    pass-blank take-word pass-blank ">" take-string ;
+
+: take-element-decl ( -- element-decl )
+    take-decl-contents <element-decl> ;
+
+: take-attlist-decl ( -- attlist-decl )
+    take-decl-contents <attlist-decl> ;
+
+: take-notation-decl ( -- notation-decl )
+    take-decl-contents <notation-decl> ; 
+
+: take-until-one-of ( seps -- str sep )
+    '[ get-char _ member? ] take-until get-char ;
+
+: take-system-id ( -- system-id )
+    parse-quote <system-id> close ;
+
+: take-public-id ( -- public-id )
+    parse-quote parse-quote <public-id> close ;
+
+UNION: dtd-acceptable
+    directive comment instruction ;
+
+: (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-word (take-external-id) ;
+
+: only-blanks ( str -- )
+    [ blank? ] all? [ bad-decl ] unless ;
+: take-entity-def ( var -- entity-name entity-def )
+    [
+        take-word pass-blank get-char {
+            { CHAR: ' [ parse-quote ] }
+            { CHAR: " [ parse-quote ] }
+            [ drop take-external-id ]
+        } case
+   ] dip '[ swap _ [ ?set-at ] change ] 2keep ;
+
+: take-entity-decl ( -- entity-decl )
+    pass-blank get-char {
+        { CHAR: % [ next pass-blank pe-table take-entity-def t ] }
+        [ drop extra-entities take-entity-def f ]
+    } case close <entity-decl> ;
+
+: take-inner-directive ( string -- directive )
+    {
+        { "ELEMENT" [ take-element-decl ] }
+        { "ATTLIST" [ take-attlist-decl ] }
+        { "ENTITY" [ take-entity-decl ] }
+        { "NOTATION" [ take-notation-decl ] }
+        [ bad-directive ]
+    } case ;

basis/xml/dtd/summary.txt

@@ -0,0 +1 @@
+Implements the parsing of directives in DTDs

basis/xml/elements/authors.txt

@@ -0,0 +1 @@
+Daniel Ehrenberg

basis/xml/elements/elements.factor

@@ -0,0 +1,162 @@
+! Copyright (C) 2005, 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces xml.tokenize xml.state xml.name
+xml.data accessors arrays make xml.char-classes fry assocs sequences
+math xml.errors sets combinators io.encodings io.encodings.iana
+unicode.case xml.dtd strings ;
+IN: xml.elements
+
+: parse-attr ( -- )
+    parse-name pass-blank CHAR: = expect pass-blank
+    t parse-quote* 2array , ;
+
+: start-tag ( -- name ? )
+    #! Outputs the name and whether this is a closing tag
+    get-char CHAR: / = dup [ next ] when
+    parse-name swap ;
+
+: (middle-tag) ( -- )
+    pass-blank version=1.0? get-char name-start?
+    [ parse-attr (middle-tag) ] when ;
+
+: assure-no-duplicates ( attrs-alist -- attrs-alist )
+    H{ } clone 2dup '[ swap _ push-at ] assoc-each
+    [ nip length 2 >= ] assoc-filter >alist
+    [ first first2 duplicate-attr ] unless-empty ;
+
+: middle-tag ( -- attrs-alist )
+    ! f make will make a vector if it has any elements
+    [ (middle-tag) ] f make pass-blank
+    assure-no-duplicates ;
+
+: end-tag ( name attrs-alist -- tag )
+    tag-ns pass-blank get-char CHAR: / =
+    [ pop-ns <contained> next CHAR: > expect ]
+    [ depth inc <opener> close ] if ;
+
+: take-comment ( -- comment )
+    "--" expect-string
+    "--" take-string
+    <comment>
+    CHAR: > expect ;
+
+: assure-no-extra ( seq -- )
+    [ first ] map {
+        T{ name f "" "version" f }
+        T{ name f "" "encoding" f }
+        T{ name f "" "standalone" f }
+    } diff
+    [ extra-attrs ] unless-empty ; 
+
+: good-version ( version -- version )
+    dup { "1.0" "1.1" } member? [ bad-version ] unless ;
+
+: prolog-version ( alist -- version )
+    T{ name f "" "version" f } swap at
+    [ good-version ] [ versionless-prolog ] if* ;
+
+: prolog-encoding ( alist -- encoding )
+    T{ name f "" "encoding" f } swap at "UTF-8" or ;
+
+: yes/no>bool ( string -- t/f )
+    {
+        { "yes" [ t ] }
+        { "no" [ f ] }
+        [ not-yes/no ]
+    } case ;
+
+: prolog-standalone ( alist -- version )
+    T{ name f "" "standalone" f } swap at
+    [ yes/no>bool ] [ f ] if* ;
+
+: prolog-attrs ( alist -- prolog )
+    [ prolog-version ]
+    [ prolog-encoding ]
+    [ prolog-standalone ]
+    tri <prolog> ;
+
+SYMBOL: string-input?
+: decode-input-if ( encoding -- )
+    string-input? get [ drop ] [ decode-input ] if ;
+
+: parse-prolog ( -- prolog )
+    pass-blank middle-tag "?>" expect-string
+    dup assure-no-extra prolog-attrs
+    dup encoding>> dup "UTF-16" =
+    [ drop ] [ name>encoding [ decode-input-if ] when* ] if
+    dup prolog-data set ;
+
+: instruct ( -- instruction )
+    take-name {
+        { [ dup "xml" = ] [ drop parse-prolog ] }
+        { [ dup >lower "xml" = ] [ capitalized-prolog ] }
+        { [ dup valid-name? not ] [ bad-name ] }
+        [ "?>" take-string append <instruction> ]
+    } cond ;
+
+: take-cdata ( -- string )
+    depth get zero? [ bad-cdata ] when
+    "[CDATA[" expect-string "]]>" take-string ;
+
+DEFER: make-tag ! Is this unavoidable?
+
+: expand-pe ( -- ) ; ! Make this run the contents of the pe within a DOCTYPE
+
+: (take-internal-subset) ( -- )
+    pass-blank get-char {
+        { CHAR: ] [ next ] }
+        { CHAR: % [ expand-pe ] }
+        { CHAR: < [
+            next make-tag dup dtd-acceptable?
+            [ bad-doctype ] unless , (take-internal-subset)
+        ] }
+        [ 1string bad-doctype ]
+    } case ;
+
+: take-internal-subset ( -- seq )
+    [
+        H{ } pe-table set
+        t in-dtd? set
+        (take-internal-subset)
+    ] { } make ;
+
+: nontrivial-doctype ( -- external-id internal-subset )
+    pass-blank get-char CHAR: [ = [
+        next take-internal-subset f swap close
+    ] [
+        " >" take-until-one-of {
+            { CHAR: \s [ (take-external-id) ] }
+            { CHAR: > [ only-blanks f ] }
+        } case f
+    ] if ;
+
+: take-doctype-decl ( -- doctype-decl )
+    pass-blank " >" take-until-one-of {
+        { CHAR: \s [ nontrivial-doctype ] }
+        { CHAR: > [ f f ] }
+    } case <doctype-decl> ;
+
+: take-directive ( -- doctype )
+    take-name dup "DOCTYPE" =
+    [ drop take-doctype-decl ] [
+        in-dtd? get
+        [ take-inner-directive ]
+        [ misplaced-directive ] if
+    ] if ;
+
+: direct ( -- object )
+    get-char {
+        { CHAR: - [ take-comment ] }
+        { CHAR: [ [ take-cdata ] }
+        [ drop take-directive ]
+    } case ;
+
+: make-tag ( -- tag )
+    {
+        { [ get-char dup CHAR: ! = ] [ drop next direct ] }
+        { [ CHAR: ? = ] [ next instruct ] }
+        [
+            start-tag [ dup add-ns pop-ns <closer> depth dec close ]
+            [ middle-tag end-tag ] if
+        ]
+    } cond ;

basis/xml/elements/summary.txt

@@ -0,0 +1 @@
+Implements the parsing of XML tags

basis/xml/entities/entities-docs.factor

@@ -0,0 +1,22 @@
+! Copyright (C) 2005, 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: xml.entities
+
+ABOUT: "xml.entities"
+
+ARTICLE: "xml.entities" "XML entities"
+    "When XML is parsed, entities like &foo; are replaced with the characters they represent. A few entities like & and < are defined by default, but more are available, and the set of entities can be customized. Below are some words involved in XML entities, defined in the vocabulary 'entities':"
+    { $subsection entities }
+    { $subsection with-entities }
+"For entities used in HTML/XHTML, see " { $vocab-link "xml.entities.html" } ;
+
+HELP: entities
+{ $description "a hash table from default XML entity names (like & and <) to the characters they represent. This is automatically included when parsing any XML document." }
+{ $see-also with-entities } ;
+
+HELP: with-entities
+{ $values { "entities" "a hash table of strings to chars" }
+    { "quot" "a quotation ( -- )" } }
+{ $description "calls the quotation using the given table of entity values (symbolizing, eg, that &foo; represents CHAR: a) on top of the default XML entities" } ;
+

basis/xml/entities/html/html-docs.factor

@@ -0,0 +1,18 @@
+! Copyright (C) 2005, 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax xml.entities ;
+IN: xml.entities.html
+
+ARTICLE: "xml.entities.html" "HTML entities"
+{ $vocab-link "xml.entities.html" } " defines words for using entities defined in HTML/XHTML."
+    { $subsection html-entities }
+    { $subsection with-html-entities } ;
+
+HELP: html-entities
+{ $description "a hash table from HTML entity names to their character values" }
+{ $see-also entities with-html-entities } ;
+
+HELP: with-html-entities
+{ $values { "quot" "a quotation ( -- )" } }
+{ $description "calls the given quotation using HTML entity values" }
+{ $see-also html-entities with-entities } ;

basis/xml/entities/html/html.factor

@@ -7,8 +7,7 @@ IN: xml.entities.html
 VALUE: html-entities
 
 : read-entities-file ( file -- table )
-    f swap binary <file-reader>
+    file>dtd nip ;
-    [ 2drop extra-entities get ] sax ;
 
 : get-html ( -- table )
     { "lat1" "special" "symbol" } [

basis/xml/entities/summary.txt

@@ -0,0 +1 @@
+Contains built-in XML entities