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

Makefile

@@ -25,23 +25,25 @@ ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
 DLL_OBJS = $(PLAF_DLL_OBJS) \
 	vm/alien.o \
 	vm/bignum.o \
+	vm/callstack.o \
+	vm/code_block.o \
+	vm/code_gc.o \
 	vm/code_heap.o \
+	vm/data_gc.o \
+	vm/data_heap.o \
 	vm/debug.o \
+	vm/errors.o \
 	vm/factor.o \
 	vm/ffi_test.o \
 	vm/image.o \
 	vm/io.o \
 	vm/math.o \
-	vm/data_gc.o \
-	vm/code_gc.o \
 	vm/primitives.o \
-	vm/run.o \
+	vm/profiler.o \
-	vm/callstack.o \
-	vm/types.o \
 	vm/quotations.o \
-	vm/utilities.o \
+	vm/run.o \
-	vm/errors.o \
+	vm/types.o \
-	vm/profiler.o
+	vm/utilities.o
 
 EXE_OBJS = $(PLAF_EXE_OBJS)
 

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/ascii/ascii-docs.factor

@@ -57,8 +57,10 @@ HELP: >upper
 { $values { "str" "a string" } { "upper" "a string" } }
 { $description "Converts an ASCII string to upper case." } ;
 
-ARTICLE: "ascii" "ASCII character classes"
+ARTICLE: "ascii" "ASCII"
-"The " { $vocab-link "ascii" } " vocabulary implements traditional ASCII character classes:"
+"The " { $vocab-link "ascii" } " vocabulary implements support for the legacy ASCII character set. Most applications should use " { $link "unicode" } " instead."
+$nl
+"ASCII character classes:"
 { $subsection blank? }
 { $subsection letter? }
 { $subsection LETTER? }
@@ -67,11 +69,10 @@ ARTICLE: "ascii" "ASCII character classes"
 { $subsection control? }
 { $subsection quotable? }
 { $subsection ascii? }
-"ASCII case conversion is also implemented:"
+"ASCII case conversion:"
 { $subsection ch>lower }
 { $subsection ch>upper }
 { $subsection >lower }
-{ $subsection >upper }
+{ $subsection >upper } ;
-"Modern applications should use Unicode 5.1 instead (" { $vocab-link "unicode.categories" } ")." ;
 
 ABOUT: "ascii"

basis/ascii/ascii.factor

@@ -1,41 +1,23 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.order sequences
+USING: kernel math math.order sequences strings
-combinators.short-circuit ;
+combinators.short-circuit hints ;
 IN: ascii
 
 : ascii? ( ch -- ? ) 0 127 between? ; inline
-
 : blank? ( ch -- ? ) " \t\n\r" member? ; inline
-
 : letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline
-
 : LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline
-
 : digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline
-
 : printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline
+: control? ( ch -- ? ) "\0\e\r\n\t\u000008\u00007f" member? ; inline
+: quotable? ( ch -- ? ) { [ printable? ] [ "\"\\" member? not ] } 1&& ; inline
+: Letter? ( ch -- ? ) { [ letter? ] [ LETTER? ] } 1|| ; inline
+: alpha? ( ch -- ? ) { [ Letter? ] [ digit? ] } 1|| ; inline
+: ch>lower ( ch -- lower ) dup LETTER? [ HEX: 20 + ] when ; inline
+: >lower ( str -- lower ) [ ch>lower ] map ;
+: ch>upper ( ch -- upper ) dup letter? [ HEX: 20 - ] when ; inline
+: >upper ( str -- upper ) [ ch>upper ] map ;
 
-: control? ( ch -- ? )
+HINTS: >lower string ;
-    "\0\e\r\n\t\u000008\u00007f" member? ; inline
+HINTS: >upper string ;
-
-: quotable? ( ch -- ? )
-    dup printable? [ "\"\\" member? not ] [ drop f ] if ; inline
-
-: Letter? ( ch -- ? )
-    [ [ letter? ] [ LETTER? ] ] 1|| ;
-
-: alpha? ( ch -- ? )
-    [ [ Letter? ] [ digit? ] ] 1|| ;
-
-: ch>lower ( ch -- lower )
-   dup CHAR: A CHAR: Z between? [ HEX: 20 + ] when ;
-
-: >lower ( str -- lower )
-   [ ch>lower ] map ;
-
-: ch>upper ( ch -- upper )
-    dup CHAR: a CHAR: z between? [ HEX: 20 - ] when ;
-
-: >upper ( str -- upper )
-    [ ch>upper ] map ;

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

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien arrays byte-arrays generic assocs hashtables assocs
 hashtables.private io io.binary io.files io.encodings.binary
@@ -10,7 +10,7 @@ classes.tuple.private words.private vocabs
 vocabs.loader source-files definitions debugger
 quotations.private sequences.private combinators
 math.order math.private accessors
-slots.private compiler.units ;
+slots.private compiler.units fry ;
 IN: bootstrap.image
 
 : arch ( os cpu -- arch )
@@ -73,7 +73,7 @@ SYMBOL: objects
 : put-object ( n obj -- ) (objects) set-at ;
 
 : cache-object ( obj quot -- value )
-    [ (objects) ] dip [ obj>> ] prepose cache ; inline
+    [ (objects) ] dip '[ obj>> @ ] cache ; inline
 
 ! Constants
 
@@ -95,7 +95,7 @@ SYMBOL: objects
 SYMBOL: sub-primitives
 
 : make-jit ( quot rc rt offset -- quad )
-    { [ { } make ] [ ] [ ] [ ] } spread 4array ; inline
+    [ { } make ] 3dip 4array ; inline
 
 : jit-define ( quot rc rt offset name -- )
     [ make-jit ] dip set ; inline
@@ -344,25 +344,37 @@ M: wrapper '
     [ emit ] emit-object ;
 
 ! Strings
+: native> ( object -- object )
+    big-endian get [ [ be> ] map ] [ [ le> ] map ] if ;
+
 : emit-bytes ( seq -- )
-    bootstrap-cell <groups>
+    bootstrap-cell <groups> native> emit-seq ;
-    big-endian get [ [ be> ] map ] [ [ le> ] map ] if
-    emit-seq ;
 
 : pad-bytes ( seq -- newseq )
     dup length bootstrap-cell align 0 pad-right ;
 
-: check-string ( string -- )
+: extended-part ( str -- str' )
-    [ 127 > ] contains?
+    dup [ 128 < ] all? [ drop f ] [
-    [ "Bootstrap cannot emit non-ASCII strings" throw ] when ;
+        [ -7 shift 1 bitxor ] { } map-as
+        big-endian get
+        [ [ 2 >be ] { } map-as ]
+        [ [ 2 >le ] { } map-as ] if
+        B{ } join
+    ] if ;
+
+: ascii-part ( str -- str' )
+    [
+        [ 128 mod ] [ 128 >= ] bi
+        [ 128 bitor ] when
+    ] B{ } map-as ;
 
 : emit-string ( string -- ptr )
-    dup check-string
+    [ length ] [ extended-part ' ] [ ] tri
     string type-number object tag-number [
-        dup length emit-fixnum
+        [ emit-fixnum ]
-        f ' emit
+        [ emit ]
-        f ' emit
+        [ f ' emit ascii-part pad-bytes emit-bytes ]
-        pad-bytes emit-bytes
+        tri*
     ] emit-object ;
 
 M: string '
@@ -433,7 +445,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
@@ -524,11 +536,9 @@ M: quotation '
 ! Image output
 
 : (write-image) ( image -- )
-    bootstrap-cell big-endian get [
+    bootstrap-cell big-endian get
-        [ >be write ] curry each
+    [ '[ _ >be write ] each ]
-    ] [
+    [ '[ _ >le write ] each ] if ;
-        [ >le write ] curry each
-    ] if ;
 
 : write-image ( image -- )
     "Writing image to " write

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/bootstrap/unicode/unicode.factor

@@ -0,0 +1 @@
+USE: unicode

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+
 
@@ -110,7 +110,7 @@ t compile-dependencies? set-global
     [ (compile) yield-hook get call ] slurp-deque ;
 
 : decompile ( word -- )
-    f 2array 1array t modify-code-heap ;
+    f 2array 1array modify-code-heap ;
 
 : optimized-recompile-hook ( words -- alist )
     [

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/concurrency/messaging/messaging-docs.factor

@@ -53,7 +53,8 @@ ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends"
 { $subsection reply-synchronous }
 "An example:"
 { $example
-    "USING: concurrency.messaging kernel threads ;"
+    "USING: concurrency.messaging kernel prettyprint threads ;"
+    "IN: scratchpad"
     ": pong-server ( -- )"
     "    receive [ \"pong\" ] dip reply-synchronous ;"
     "[ pong-server t ] \"pong-server\" spawn-server"

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 ] [
+        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 ]
         [ 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/deques/deques.factor

@@ -1,6 +1,6 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences math ;
+USING: kernel sequences math fry ;
 IN: deques
 
 GENERIC: push-front* ( obj deque -- node )
@@ -34,7 +34,8 @@ GENERIC: deque-empty? ( deque -- ? )
     [ peek-back ] [ pop-back* ] bi ;
 
 : slurp-deque ( deque quot -- )
-    [ drop [ deque-empty? not ] curry ]
+    [ drop '[ _ deque-empty? not ] ]
-    [ [ pop-back ] prepose curry ] 2bi [ ] while ; inline
+    [ '[ _ pop-back @ ] ]
+    2bi [ ] while ; inline
 
 MIXIN: deque

basis/dlists/dlists.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman,
+! Copyright (C) 2007, 2009 Mackenzie Straight, Doug Coleman,
 ! Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: combinators kernel math sequences accessors deques
-search-deques summary hashtables ;
+search-deques summary hashtables fry ;
 IN: dlists
 
 <PRIVATE
@@ -64,7 +64,7 @@ M: dlist-node node-value obj>> ;
     [ front>> ] dip (dlist-find-node) ; inline
 
 : dlist-each-node ( dlist quot -- )
-    [ f ] compose dlist-find-node 2drop ; inline
+    '[ @ f ] dlist-find-node 2drop ; inline
 
 : unlink-node ( dlist-node -- )
     dup prev>> over next>> set-prev-when
@@ -115,8 +115,7 @@ M: dlist pop-back* ( dlist -- )
     normalize-front ;
 
 : dlist-find ( dlist quot -- obj/f ? )
-    [ obj>> ] prepose
+    '[ obj>> @ ] dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
-    dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
 
 : dlist-contains? ( dlist quot -- ? )
     dlist-find nip ; inline
@@ -143,7 +142,7 @@ M: dlist delete-node ( dlist-node dlist -- )
     ] if ; inline
 
 : delete-node-if ( dlist quot -- obj/f )
-    [ obj>> ] prepose delete-node-if* drop ; inline
+    '[ obj>> @ ] delete-node-if* drop ; inline
 
 M: dlist clear-deque ( dlist -- )
     f >>front
@@ -151,7 +150,7 @@ M: dlist clear-deque ( dlist -- )
     drop ;
 
 : dlist-each ( dlist quot -- )
-    [ obj>> ] prepose dlist-each-node ; inline
+    '[ obj>> @ ] dlist-each-node ; inline
 
 : dlist>seq ( dlist -- seq )
     [ ] accumulator [ dlist-each ] dip ;
@@ -159,8 +158,6 @@ M: dlist clear-deque ( dlist -- )
 : 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
 
 M: dlist clone
-    <dlist> [
+    <dlist> [ '[ _ push-back ] dlist-each ] keep ;
-        [ push-back ] curry dlist-each
-    ] keep ;
 
 INSTANCE: dlist deque

basis/eval/eval-docs.factor

@@ -11,7 +11,7 @@ HELP: eval>string
 { $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string." } ;
 
 ARTICLE: "eval" "Evaluating strings at runtime"
-"Evaluating strings at runtime:"
+"The " { $vocab-link "eval" } " vocabulary implements support for evaluating strings at runtime."
 { $subsection eval }
 { $subsection eval>string } ;
 

basis/eval/eval-tests.factor

@@ -0,0 +1,4 @@
+IN: eval.tests
+USING: eval tools.test ;
+
+[ "4\n" ] [ "USING: math prettyprint ; 2 2 + ." eval>string ] unit-test

basis/eval/eval.factor

@@ -1,14 +1,24 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: splitting parser compiler.units kernel namespaces
-debugger io.streams.string ;
+debugger io.streams.string fry ;
 IN: eval
 
+: parse-string ( str -- )
+    [ string-lines parse-lines ] with-compilation-unit ;
+
+: (eval) ( str -- )
+    parse-string call ;
+
 : eval ( str -- )
-    [ string-lines parse-fresh ] with-compilation-unit call ;
+    [ (eval) ] with-file-vocabs ;
+
+: (eval>string) ( str -- output )
+    [
+        "quiet" on
+        parser-notes off
+        '[ _ (eval) ] try
+    ] with-string-writer ;
 
 : eval>string ( str -- output )
-    [
+    [ (eval>string) ] with-file-vocabs ;
-        parser-notes off
-        [ [ eval ] keep ] try drop
-    ] with-string-writer ;

basis/farkup/farkup-docs.factor

@@ -14,8 +14,8 @@ HELP: parse-farkup ( string -- farkup )
 { $description "Parses Farkup and outputs a tree of " { $link "farkup-ast" } "." } ;
 
 HELP: (write-farkup)
-{ $values { "farkup" "a Farkup syntax tree node" } }
+{ $values { "farkup" "a Farkup syntax tree node" } { "xml" "an XML chunk" } }
-{ $description "Writes a Farkup syntax tree as HTML on " { $link output-stream } "." } ;
+{ $description "Converts a Farkup syntax tree node to XML." } ;
 
 ARTICLE: "farkup-ast" "Farkup syntax tree nodes"
 "The " { $link parse-farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "."

basis/farkup/farkup-tests.factor

@@ -92,22 +92,22 @@ link-no-follow? off
 [ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test
 [ "<h1>foo</h1><p>=</p>" ] [ "=foo==" convert-farkup ] unit-test
 
-[ "<pre><span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span>\n</pre>" ]
+[ "<pre><span class=\"KEYWORD3\">int</span> <span class=\"FUNCTION\">main</span><span class=\"OPERATOR\">(</span><span class=\"OPERATOR\">)</span></pre>" ]
 [ "[c{int main()}]" convert-farkup ] unit-test
 
-[ "<p><img src='lol.jpg'/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
+[ "<p><img src=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
-[ "<p><img src='lol.jpg' alt='teh lol'/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
+[ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
-[ "<p><a href='http://lol.com'>http://lol.com</a></p>" ] [ "[[http://lol.com]]" convert-farkup ] unit-test
+[ "<p><a href=\"http://lol.com\">http://lol.com</a></p>" ] [ "[[http://lol.com]]" convert-farkup ] unit-test
-[ "<p><a href='http://lol.com'>haha</a></p>" ] [ "[[http://lol.com|haha]]" convert-farkup ] unit-test
+[ "<p><a href=\"http://lol.com\">haha</a></p>" ] [ "[[http://lol.com|haha]]" convert-farkup ] unit-test
-[ "<p><a href='Foo/Bar'>Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
+[ "<p><a href=\"Foo/Bar\">Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
 
 "/wiki/view/" relative-link-prefix [
-    [ "<p><a href='/wiki/view/Foo/Bar'>Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
+    [ "<p><a href=\"/wiki/view/Foo/Bar\">Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
 ] with-variable
 
 [ ] [ "[{}]" convert-farkup drop ] unit-test
 
-[ "<pre>hello\n</pre>" ] [ "[{hello}]" convert-farkup ] unit-test
+[ "<pre>hello</pre>" ] [ "[{hello}]" convert-farkup ] unit-test
 
 [
     "<p>Feature comparison:\n<table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table></p>"
@@ -118,15 +118,15 @@ link-no-follow? off
 ] [ "Feature comparison:\n\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
 
 [
-    "<p>This wiki is written in <a href='Factor'>Factor</a> and is hosted on a <a href='http://linode.com'>http://linode.com</a> virtual server.</p>"
+    "<p>This wiki is written in <a href=\"Factor\">Factor</a> and is hosted on a <a href=\"http://linode.com\">http://linode.com</a> virtual server.</p>"
 ] [
     "This wiki is written in [[Factor]] and is hosted on a [[http://linode.com|http://linode.com]] virtual server."
     convert-farkup
 ] unit-test
 
-[ "<p><a href='a'>a</a> <a href='b'>c</a></p>" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test
+[ "<p><a href=\"a\">a</a> <a href=\"b\">c</a></p>" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test
 
-[ "<p><a href='C%2b%2b'>C++</a></p>" ] [ "[[C++]]" convert-farkup ] unit-test
+[ "<p><a href=\"C%2b%2b\">C++</a></p>" ] [ "[[C++]]" convert-farkup ] unit-test
 
 [ "<p>&lt;foo&gt;</p>" ] [ "<foo>" convert-farkup ] unit-test
 
@@ -138,10 +138,10 @@ link-no-follow? off
 [ "<hr/>" ] [ "___" convert-farkup ] unit-test
 [ "<hr/>\n" ] [ "___\n" convert-farkup ] unit-test
 
-[ "<p>before:\n<pre><span class='OPERATOR'>{</span> <span class='DIGIT'>1</span> <span class='DIGIT'>2</span> <span class='DIGIT'>3</span> <span class='OPERATOR'>}</span> <span class='DIGIT'>1</span> tail\n</pre></p>" ] 
+[ "<p>before:\n<pre><span class=\"OPERATOR\">{</span> <span class=\"DIGIT\">1</span> <span class=\"DIGIT\">2</span> <span class=\"DIGIT\">3</span> <span class=\"OPERATOR\">}</span> <span class=\"DIGIT\">1</span> tail</pre></p>" ] 
 [ "before:\n[factor{{ 1 2 3 } 1 tail}]" convert-farkup ] unit-test
  
-[ "<p><a href='Factor'>Factor</a>-rific!</p>" ]
+[ "<p><a href=\"Factor\">Factor</a>-rific!</p>" ]
 [ "[[Factor]]-rific!" convert-farkup ] unit-test
 
 [ "<p>[ factor { 1 2 3 }]</p>" ]
@@ -163,7 +163,7 @@ link-no-follow? off
     convert-farkup string>xml-chunk
     "a" deep-tag-named "href" swap at url-decode ;
 
-[ "Trader Joe's" ] [ "[[Trader Joe's]]" check-link-escaping ] unit-test
+[ "Trader Joe\"s" ] [ "[[Trader Joe\"s]]" check-link-escaping ] unit-test
 [ "<foo>" ] [ "[[<foo>]]" check-link-escaping ] unit-test
 [ "&blah;" ] [ "[[&blah;]]" check-link-escaping ] unit-test
 [ "C++" ] [ "[[C++]]" check-link-escaping ] unit-test

basis/farkup/farkup.factor

@@ -2,8 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays combinators html.elements io
 io.streams.string kernel math namespaces peg peg.ebnf
-sequences sequences.deep strings xml.entities
+sequences sequences.deep strings xml.entities xml.interpolate
-vectors splitting xmode.code2html urls.encoding ;
+vectors splitting xmode.code2html urls.encoding xml.data
+xml.writer ;
 IN: farkup
 
 SYMBOL: relative-link-prefix
@@ -74,6 +75,7 @@ inline-code   = "%" (!("%" | nl).)+ "%"
     => [[ second >string inline-code boa ]]
 
 link-content     = (!("|"|"]").)+
+                    => [[ >string ]]
 
 image-link       = "[[image:" link-content  "|" link-content "]]"
                     => [[ [ second >string ] [ fourth >string ] bi image boa ]]
@@ -146,7 +148,7 @@ named-code
 
 simple-code
            = "[{" (!("}]").)+ "}]"
-    => [[ second f swap code boa ]]
+    => [[ second >string f swap code boa ]]
 
 code = named-code | simple-code
 
@@ -163,66 +165,78 @@ stand-alone
         { [ dup [ 127 > ] contains? ] [ drop invalid-url ] }
         { [ dup first "/\\" member? ] [ drop invalid-url ] }
         { [ CHAR: : over member? ] [ dup absolute-url? [ drop invalid-url ] unless ] }
-        [ relative-link-prefix get prepend ]
+        [ relative-link-prefix get prepend "" like ]
-    } cond ;
+    } cond url-encode ;
 
-: escape-link ( href text -- href-esc text-esc )
+: write-link ( href text -- xml )
-    [ check-url ] dip escape-string ;
+    [ check-url link-no-follow? get "true" and ] dip
+    [XML <a href=<-> nofollow=<->><-></a> XML] ;
 
-: write-link ( href text -- )
+: write-image-link ( href text -- xml )
-    escape-link
-    [ <a url-encode =href link-no-follow? get [ "true" =nofollow ] when a> ]
-    [ write </a> ]
-    bi* ;
-
-: write-image-link ( href text -- )
     disable-images? get [
         2drop
-        <strong> "Images are not allowed" write </strong>
+        [XML <strong>Images are not allowed</strong> XML]
     ] [
-        escape-link
+        [ check-url ] [ f like ] bi*
-        [ <img url-encode =src ] [ [ =alt ] unless-empty img/> ] bi*
+        [XML <img src=<-> alt=<->/> XML]
     ] if ;
 
-: render-code ( string mode -- string' )
+: render-code ( string mode -- xml )
-    [ string-lines ] dip
+    [ string-lines ] dip htmlize-lines
-    [
+    [XML <pre><-></pre> XML] ;
-        <pre>
-            htmlize-lines
-        </pre>
-    ] with-string-writer write ;
 
-GENERIC: (write-farkup) ( farkup -- )
+GENERIC: (write-farkup) ( farkup -- xml )
-: <foo.> ( string -- ) <foo> write ;
-: </foo.> ( string -- ) </foo> write ;
-: in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; inline
-M: heading1 (write-farkup) [ child>> (write-farkup) ] "h1" in-tag. ;
-M: heading2 (write-farkup) [ child>> (write-farkup) ] "h2" in-tag. ;
-M: heading3 (write-farkup) [ child>> (write-farkup) ] "h3" in-tag. ;
-M: heading4 (write-farkup) [ child>> (write-farkup) ] "h4" in-tag. ;
-M: strong (write-farkup) [ child>> (write-farkup) ] "strong" in-tag. ;
-M: emphasis (write-farkup) [ child>> (write-farkup) ] "em" in-tag. ;
-M: superscript (write-farkup) [ child>> (write-farkup) ] "sup" in-tag. ;
-M: subscript (write-farkup) [ child>> (write-farkup) ] "sub" in-tag. ;
-M: inline-code (write-farkup) [ child>> (write-farkup) ] "code" in-tag. ;
-M: list-item (write-farkup) [ child>> (write-farkup) ] "li" in-tag. ;
-M: unordered-list (write-farkup) [ child>> (write-farkup) ] "ul" in-tag. ;
-M: ordered-list (write-farkup) [ child>> (write-farkup) ] "ol" in-tag. ;
-M: paragraph (write-farkup) [ child>> (write-farkup) ] "p" in-tag. ;
-M: link (write-farkup) [ href>> ] [ text>> ] bi write-link ;
-M: image (write-farkup) [ href>> ] [ text>> ] bi write-image-link ;
-M: code (write-farkup) [ string>> ] [ mode>> ] bi render-code ;
-M: line (write-farkup) drop <hr/> ;
-M: line-break (write-farkup) drop <br/> nl ;
-M: table-row (write-farkup) ( obj -- )
-    child>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ;
-M: table (write-farkup) [ child>> (write-farkup) ] "table" in-tag. ;
-M: string (write-farkup) escape-string write ;
-M: vector (write-farkup) [ (write-farkup) ] each ;
-M: f (write-farkup) drop ;
 
-: write-farkup ( string -- )
+: farkup-inside ( farkup name -- xml )
+    <simple-name> swap T{ attrs } swap
+    child>> (write-farkup) 1array <tag> ;
+
+M: heading1 (write-farkup) "h1" farkup-inside ;
+M: heading2 (write-farkup) "h2" farkup-inside ;
+M: heading3 (write-farkup) "h3" farkup-inside ;
+M: heading4 (write-farkup) "h4" farkup-inside ;
+M: strong (write-farkup) "strong" farkup-inside ;
+M: emphasis (write-farkup) "em" farkup-inside ;
+M: superscript (write-farkup) "sup" farkup-inside ;
+M: subscript (write-farkup) "sub" farkup-inside ;
+M: inline-code (write-farkup) "code" farkup-inside ;
+M: list-item (write-farkup) "li" farkup-inside ;
+M: unordered-list (write-farkup) "ul" farkup-inside ;
+M: ordered-list (write-farkup) "ol" farkup-inside ;
+M: paragraph (write-farkup) "p" farkup-inside ;
+M: table (write-farkup) "table" farkup-inside ;
+
+M: link (write-farkup)
+    [ href>> ] [ text>> ] bi write-link ;
+
+M: image (write-farkup)
+    [ href>> ] [ text>> ] bi write-image-link ;
+
+M: code (write-farkup)
+    [ string>> ] [ mode>> ] bi render-code ;
+
+M: line (write-farkup)
+    drop [XML <hr/> XML] ;
+
+M: line-break (write-farkup)
+    drop [XML <br/> XML] ;
+
+M: table-row (write-farkup)
+    child>>
+    [ (write-farkup) [XML <td><-></td> XML] ] map
+    [XML <tr><-></tr> XML] ;
+
+M: string (write-farkup) ;
+
+M: vector (write-farkup) [ (write-farkup) ] map ;
+
+M: f (write-farkup) ;
+
+: farkup>xml ( string -- xml )
     parse-farkup (write-farkup) ;
 
+: write-farkup ( string -- )
+    farkup>xml write-xml-chunk ;
+
 : convert-farkup ( string -- string' )
-    parse-farkup [ (write-farkup) ] with-string-writer ;
+    [ write-farkup ] with-string-writer ;

basis/formatting/formatting-docs.factor

@@ -7,7 +7,7 @@ HELP: printf
 { $values { "format-string" string } }
 { $description 
     "Writes the arguments (specified on the stack) formatted according to the format string.\n" 
-    "\n"
+    $nl
     "Several format specifications exist for handling arguments of different types, and "
     "specifying attributes for the result string, including such things as maximum width, "
     "padding, and decimals.\n"
@@ -24,10 +24,10 @@ HELP: printf
         { "%+Px"    "Hexadecimal"                "hex" }
         { "%+PX"    "Hexadecimal uppercase"      "hex" }
     }
-    "\n"
+    $nl
     "A plus sign ('+') is used to optionally specify that the number should be "
     "formatted with a '+' preceeding it if positive.\n"
-    "\n"
+    $nl
     "Padding ('P') is used to optionally specify the minimum width of the result "
     "string, the padding character, and the alignment.  By default, the padding "
     "character defaults to a space and the alignment defaults to right-aligned. "
@@ -38,7 +38,7 @@ HELP: printf
         "\"%'#5f\" formats a float padding with '#' up to 3 characters wide."
         "\"%-10d\" formats an integer to 10 characters wide and left-aligns." 
     }
-    "\n"
+    $nl
     "Digits ('D') is used to optionally specify the maximum digits in the result "
     "string. For example:\n"
     { $list 
@@ -83,7 +83,7 @@ HELP: strftime
 { $values { "format-string" string } }
 { $description 
     "Writes the timestamp (specified on the stack) formatted according to the format string.\n"
-    "\n"
+    $nl
     "Different attributes of the timestamp can be retrieved using format specifications.\n"
     { $table
         { "%a"     "Abbreviated weekday name." }
@@ -118,7 +118,7 @@ HELP: strftime
 } ;
 
 ARTICLE: "formatting" "Formatted printing"
-"The " { $vocab-link "formatting" } " vocabulary is used for formatted printing.\n"
+"The " { $vocab-link "formatting" } " vocabulary is used for formatted printing."
 { $subsection printf }
 { $subsection sprintf }
 { $subsection strftime }

basis/fry/fry-docs.factor

@@ -69,18 +69,18 @@ ARTICLE: "fry.philosophy" "Fried quotation philosophy"
     "'[ [ _ key? ] all? ] filter"
     "[ [ key? ] curry all? ] curry filter"
 }
-"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a ``let'' form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"
+"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a “let” form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"
 { $code
     "'[ 3 _ + 4 _ / ]"
     "[let | a [ ] b [ ] | [ 3 a + 4 b / ] ]"
 } ;
 
 ARTICLE: "fry" "Fried quotations"
-"The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with ``holes'' (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack."
+"The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with “holes” (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack."
 $nl
 "Fried quotations are started by a special parsing word:"
 { $subsection POSTPONE: '[ }
-"There are two types of fry specifiers; the first can hold a value, and the second ``splices'' a quotation, as if it were inserted without surrounding brackets:"
+"There are two types of fry specifiers; the first can hold a value, and the second “splices” a quotation, as if it were inserted without surrounding brackets:"
 { $subsection _ }
 { $subsection @ }
 "The holes are filled in with the top of stack going in the rightmost hole, the second item on the stack going in the second hole from the right, and so on."

basis/furnace/auth/auth-docs.factor

@@ -148,7 +148,7 @@ ARTICLE: "furnace.auth.users" "User profiles"
 "User profile variables have the same restrictions on their values as session variables; see " { $link "furnace.sessions.serialize" } " for a discussion." ;
 
 ARTICLE: "furnace.auth.example" "Furnace authentication example"
-"The " { $vocab-link "webapps.todo" } " vocabulary wraps all of its responders in a protected responder. The " { $slot "description" } " slot is set so that the login page contains the message ``You must log in to view your todo list'':"
+"The " { $vocab-link "webapps.todo" } " vocabulary wraps all of its responders in a protected responder. The " { $slot "description" } " slot is set so that the login page contains the message “You must log in to view your todo list”:"
 { $code
     <" <protected>
     "view your todo list" >>description">

basis/furnace/auth/features/recover-password/recover-password.factor

@@ -27,7 +27,7 @@ SYMBOL: lost-password-from
         over email>> 1array >>to
         [
             "This e-mail was sent by the application server on " % current-host % "\n" %
-            "because somebody, maybe you, clicked on a ``recover password'' link in the\n" %
+            "because somebody, maybe you, clicked on a “recover password” link in the\n" %
             "login form, and requested a new password for the user named ``" %
             over username>> % "''.\n" %
             "\n" %

basis/furnace/syndication/syndication-docs.factor

@@ -29,7 +29,7 @@ HELP: feed-entry-date
 HELP: feed-entry-description
 { $values
      { "object" object }
-     { "description" null }
+     { "description" string }
 }
 { $contract "Outputs a feed entry description." } ;
 

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/grouping/grouping.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.order strings arrays vectors sequences
-sequences.private accessors ;
+sequences.private accessors fry ;
 IN: grouping
 
 <PRIVATE
@@ -94,7 +94,7 @@ INSTANCE: sliced-clumps slice-chunking
             [ first2-unsafe ] dip call
         ] [
             [ 2 <sliced-clumps> ] dip
-            [ first2-unsafe ] prepose all?
+            '[ first2-unsafe @ ] all?
         ] if
     ] if ; inline
 

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/lint/lint.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry accessors sequences parser kernel help help.markup
 help.topics words strings classes tools.vocabs namespaces make
@@ -6,21 +6,24 @@ io io.streams.string prettyprint definitions arrays vectors
 combinators combinators.short-circuit splitting debugger
 hashtables sorting effects vocabs vocabs.loader assocs editors
 continuations classes.predicate macros math sets eval
-vocabs.parser words.symbol values ;
+vocabs.parser words.symbol values grouping unicode.categories
+sequences.deep ;
 IN: help.lint
 
+SYMBOL: vocabs-quot
+
 : check-example ( element -- )
+    [
         rest [
             but-last "\n" join 1vector
-        [
+            [ (eval>string) ] with-datastack
-            use [ clone ] change
+            peek "\n" ?tail drop
-            [ eval>string ] with-datastack
-        ] with-scope peek "\n" ?tail drop
         ] keep
-    peek assert= ;
+        peek assert=
+    ] vocabs-quot get call ;
 
-: check-examples ( word element -- )
+: check-examples ( element -- )
-    nip \ $example swap elements [ check-example ] each ;
+    \ $example swap elements [ check-example ] each ;
 
 : extract-values ( element -- seq )
     \ $values swap elements dup empty? [
@@ -64,8 +67,13 @@ IN: help.lint
         ]
     } 2|| [ "$values don't match stack effect" throw ] unless ;
 
-: check-see-also ( word element -- )
+: check-nulls ( element -- )
-    nip \ $see-also swap elements [
+    \ $values swap elements
+    null swap deep-member?
+    [ "$values should not contain null" throw ] when ;
+
+: check-see-also ( element -- )
+    \ $see-also swap elements [
         rest dup prune [ length ] bi@ assert=
     ] each ;
 
@@ -79,43 +87,78 @@ IN: help.lint
     ] each ;
 
 : check-rendering ( element -- )
-    [ print-topic ] with-string-writer drop ;
+    [ print-content ] with-string-writer drop ;
+
+: check-strings ( str -- )
+    [
+        "\n\t" intersects?
+        [ "Paragraph text should not contain \\n or \\t" throw ] when
+    ] [
+        "  " swap subseq?
+        [ "Paragraph text should not contain double spaces" throw ] when
+    ] bi ;
+
+: check-whitespace ( str1 str2 -- )
+    [ " " tail? ] [ " " head? ] bi* or
+    [ "Missing whitespace between strings" throw ] unless ;
+
+: check-bogus-nl ( element -- )
+    { { $nl } { { $nl } } } [ head? ] with contains?
+    [ "Simple element should not begin with a paragraph break" throw ] when ;
+
+: check-elements ( element -- )
+    {
+        [ check-bogus-nl ]
+        [ [ string? ] filter [ check-strings ] each ]
+        [ [ simple-element? ] filter [ check-elements ] each ]
+        [ 2 <clumps> [ [ string? ] all? ] filter [ first2 check-whitespace ] each ]
+    } cleave ;
+
+: check-markup ( element -- )
+    {
+        [ check-elements ]
+        [ check-rendering ]
+        [ check-examples ]
+        [ check-modules ]
+    } cleave ;
 
 : all-word-help ( words -- seq )
     [ word-help ] filter ;
 
-TUPLE: help-error topic error ;
+TUPLE: help-error error topic ;
 
 C: <help-error> help-error
 
 M: help-error error.
-    "In " write dup topic>> pprint nl
+    [ "In " write topic>> pprint nl ]
-    error>> error. ;
+    [ error>> error. ]
+    bi ;
 
 : check-something ( obj quot -- )
-    flush [ <help-error> , ] recover ; inline
+    flush '[ _ assert-depth ] swap '[ _ <help-error> , ] recover ; inline
 
 : check-word ( word -- )
+    [ with-file-vocabs ] vocabs-quot set
     dup word-help [
-        [
+        dup '[
-            dup word-help '[
+            _ dup word-help
-                _ _ {
-                    [ check-examples ]
             [ check-values ]
-                    [ check-see-also ]
+            [ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] 2bi
-                    [ [ check-rendering ] [ check-modules ] bi* ]
-                } 2cleave
-            ] assert-depth
         ] check-something
     ] [ drop ] if ;
 
 : check-words ( words -- ) [ check-word ] each ;
 
+: check-article-title ( article -- )
+    article-title first LETTER?
+    [ "Article title must begin with a capital letter" throw ] unless ;
+
 : check-article ( article -- )
-    [
+    [ with-interactive-vocabs ] vocabs-quot set
-        dup article-content
+    dup '[
-        '[ _ check-rendering _ check-modules ]
+        _
-        assert-depth
+        [ check-article-title ]
+        [ article-content check-markup ] bi
     ] check-something ;
 
 : files>vocabs ( -- assoc )
@@ -135,7 +178,7 @@ M: help-error error.
     ] keep ;
 
 : check-about ( vocab -- )
-    [ vocab-help [ article drop ] when* ] check-something ;
+    dup '[ _ vocab-help [ article drop ] when* ] check-something ;
 
 : check-vocab ( vocab -- seq )
     "Checking " write dup write "..." print

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/help/tutorial/tutorial.factor

@@ -94,7 +94,7 @@ $nl
 "For example, we'd like it to identify the following as a palindrome:"
 { $code "\"A man, a plan, a canal: Panama.\"" }
 "However, right now, the simplistic algorithm we use says this is not a palindrome:"
-{ $example "\"A man, a plan, a canal: Panama.\" palindrome?" "f" }
+{ $unchecked-example "\"A man, a plan, a canal: Panama.\" palindrome?" "f" }
 "We would like it to output " { $link t } " there. We can encode this requirement with a unit test that we add to " { $snippet "palindrome-tests.factor" } ":"
 { $code "[ t ] [ \"A man, a plan, a canal: Panama.\" palindrome? ] unit-test" }
 "If you now run unit tests, you will see a unit test failure:"
@@ -106,12 +106,12 @@ $nl
 "Start by pushing a character on the stack; notice that characters are really just integers:"
 { $code "CHAR: a" }
 "Now, use the " { $link Letter? } " word to test if it is an alphabetical character, upper or lower case:"
-{ $example "Letter? ." "t" }
+{ $unchecked-example "Letter? ." "t" }
 "This gives the expected result."
 $nl
 "Now try with a non-alphabetical character:"
 { $code "CHAR: #" }
-{ $example "Letter? ." "f" }
+{ $unchecked-example "Letter? ." "f" }
 "What we want to do is given a string, remove all characters which do not match the " { $link Letter? } " predicate. Let's push a string on the stack:"
 { $code "\"A man, a plan, a canal: Panama.\"" }
 "Now, place a quotation containing " { $link Letter? } " on the stack; quoting code places it on the stack instead of executing it immediately:"

basis/html/components/components-docs.factor

@@ -70,8 +70,8 @@ HELP: render
 { $description "Renders an HTML component to the " { $link output-stream } "." } ;
 
 HELP: render*
-{ $values { "value" "a value" } { "name" "a value name" } { "renderer" "a component renderer" } }
+{ $values { "value" "a value" } { "name" "a value name" } { "renderer" "a component renderer" } { "xml" "an XML chunk" } }
-{ $contract "Renders an HTML component to the " { $link output-stream } "." } ;
+{ $contract "Renders an HTML component, outputting an XHTML snippet." } ;
 
 ARTICLE: "html.components" "HTML components"
 "The " { $vocab-link "html.components" } " vocabulary provides various HTML form components."

basis/html/components/components-tests.factor

@@ -31,7 +31,7 @@ TUPLE: color red green blue ;
     ] with-string-writer
 ] unit-test
 
-[ "<input type='hidden' name='red' value='<jimmy>'/>" ] [
+[ "<input value=\"&lt;jimmy>\" name=\"red\" type=\"hidden\"/>" ] [
     [
         "red" hidden render
     ] with-string-writer
@@ -39,13 +39,13 @@ TUPLE: color red green blue ;
 
 [ ] [ "'jimmy'" "red" set-value ] unit-test
 
-[ "<input type='text' size='5' name='red' value='&apos;jimmy&apos;'/>" ] [
+[ "<input value=\"&apos;jimmy&apos;\" name=\"red\" size=\"5\" type=\"text\"/>" ] [
     [
         "red" <field> 5 >>size render
     ] with-string-writer
 ] unit-test
 
-[ "<input type='password' size='5' name='red' value=''/>" ] [
+[ "<input value=\"\" name=\"red\" size=\"5\" type=\"password\"/>" ] [
     [
         "red" <password> 5 >>size render
     ] with-string-writer
@@ -105,7 +105,7 @@ TUPLE: color red green blue ;
 
 [ ] [ t "delivery" set-value ] unit-test
 
-[ "<input type='checkbox' name='delivery' checked='true'>Delivery</input>" ] [
+[ "<input type=\"checkbox\" checked=\"true\" name=\"delivery\">Delivery</input>" ] [
     [
         "delivery"
         <checkbox>
@@ -116,7 +116,7 @@ TUPLE: color red green blue ;
 
 [ ] [ f "delivery" set-value ] unit-test
 
-[ "<input type='checkbox' name='delivery'>Delivery</input>" ] [
+[ "<input type=\"checkbox\" name=\"delivery\">Delivery</input>" ] [
     [
         "delivery"
         <checkbox>
@@ -133,7 +133,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
 
 [ ] [ link-test "link" set-value ] unit-test
 
-[ "<a href='http://www.apple.com/foo&amp;bar'>&lt;Link Title&gt;</a>" ] [
+[ "<a href=\"http://www.apple.com/foo&amp;bar\">&lt;Link Title&gt;</a>" ] [
     [ "link" link new render ] with-string-writer
 ] unit-test
 
@@ -149,7 +149,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
 
 [ ] [ "java" "mode" set-value ] unit-test
 
-[ "<span class='KEYWORD3'>int</span> x <span class='OPERATOR'>=</span> <span class='DIGIT'>4</span>;\n" ] [
+[ "<span class=\"KEYWORD3\">int</span> x <span class=\"OPERATOR\">=</span> <span class=\"DIGIT\">4</span>;" ] [
     [ "code" <code> "mode" >>mode render ] with-string-writer
 ] unit-test
 
@@ -163,6 +163,8 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
 
 [ t ] [
     [ "object" inspector render ] with-string-writer
+    USING: splitting sequences ;
+    "\"" split "'" join ! replace " with ' for now
     [ "object" value [ describe ] with-html-writer ] with-string-writer
     =
 ] unit-test

basis/html/components/components.factor

@@ -3,13 +3,13 @@
 USING: accessors kernel namespaces io math.parser assocs classes
 classes.tuple words arrays sequences splitting mirrors
 hashtables combinators continuations math strings inspector
-fry locals calendar calendar.format xml.entities
+fry locals calendar calendar.format xml.entities xml.data
-validators urls present
+validators urls present xml.writer xml.interpolate xml
-xmode.code2html lcs.diff2html farkup
+xmode.code2html lcs.diff2html farkup io.streams.string
 html.elements html.streams html.forms ;
 IN: html.components
 
-GENERIC: render* ( value name renderer -- )
+GENERIC: render* ( value name renderer -- xml )
 
 : render ( name renderer -- )
     prepare-value
@@ -19,38 +19,36 @@ GENERIC: render* ( value name renderer -- )
         [ f swap ]
         if
     ] 2dip
-    render*
+    render* write-xml-chunk
     [ render-error ] when* ;
 
 <PRIVATE
 
-: render-input ( value name type -- )
+: render-input ( value name type -- xml )
-    <input =type =name present =value input/> ;
+    [XML <input value=<-> name=<-> type=<->/> XML] ;
 
 PRIVATE>
 
 SINGLETON: label
 
-M: label render* 2drop present escape-string write ;
+M: label render*
+    2drop present ;
 
 SINGLETON: hidden
 
-M: hidden render* drop "hidden" render-input ;
+M: hidden render*
+    drop "hidden" render-input ;
 
-: render-field ( value name size type -- )
+: render-field ( value name size type -- xml )
-    <input
+    [XML <input value=<-> name=<-> size=<-> type=<->/> XML] ;
-        =type
-        [ present =size ] when*
-        =name
-        present =value
-    input/> ;
 
 TUPLE: field size ;
 
 : <field> ( -- field )
     field new ;
 
-M: field render* size>> "text" render-field ;
+M: field render*
+    size>> "text" render-field ;
 
 TUPLE: password size ;
 
@@ -67,14 +65,15 @@ TUPLE: textarea rows cols ;
 : <textarea> ( -- renderer )
     textarea new ;
 
-M: textarea render*
+M:: textarea render* ( value name area -- xml )
+    area rows>> :> rows
+    area cols>> :> cols
+    [XML
          <textarea
-        [ rows>> [ present =rows ] when* ]
+            name=<-name->
-        [ cols>> [ present =cols ] when* ] bi
+            rows=<-rows->
-        =name
+            cols=<-cols->><-value-></textarea>
-    textarea>
+    XML] ;
-        present escape-string write
-    </textarea> ;
 
 ! Choice
 TUPLE: choice size multiple choices ;
@@ -82,24 +81,23 @@ TUPLE: choice size multiple choices ;
 : <choice> ( -- choice )
     choice new ;
 
-: render-option ( text selected? -- )
+: render-option ( text selected? -- xml )
-    <option [ "selected" =selected ] when option>
+    "selected" and swap
-        present escape-string write
+    [XML <option selected=<->><-></option> XML] ;
-    </option> ;
 
-: render-options ( options selected -- )
+: render-options ( value choice -- xml )
-    '[ dup _ member? render-option ] each ;
-
-M: choice render*
-    <select
-        swap =name
-        dup size>> [ present =size ] when*
-        dup multiple>> [ "true" =multiple ] when
-    select>
     [ choices>> value ] [ multiple>> ] bi
     [ swap ] [ swap 1array ] if
-        render-options
+    '[ dup _ member? render-option ] map ;
-    </select> ;
+
+M:: choice render* ( value name choice -- xml )
+    choice size>> :> size
+    choice multiple>> "true" and :> multiple
+    value choice render-options :> contents
+    [XML <select
+        name=<-name->
+        size=<-size->
+        multiple=<-multiple->><-contents-></select> XML] ;
 
 ! Checkboxes
 TUPLE: checkbox label ;
@@ -108,13 +106,10 @@ TUPLE: checkbox label ;
     checkbox new ;
 
 M: checkbox render*
-    <input
+    [ "true" and ] [ ] [ label>> ] tri*
-        "checkbox" =type
+    [XML <input
-        swap =name
+        type="checkbox"
-        swap [ "true" =checked ] when
+        checked=<-> name=<->><-></input> XML] ;
-    input>
-        label>> escape-string write
-    </input> ;
 
 ! Link components
 GENERIC: link-title ( obj -- string )
@@ -129,10 +124,9 @@ M: url link-href ;
 TUPLE: link target ;
 
 M: link render*
-    nip
+    nip swap
-    <a target>> [ =target ] when* dup link-href =href a>
+    [ target>> ] [ [ link-href ] [ link-title ] bi ] bi*
-        link-title present escape-string write
+    [XML <a target=<-> href=<->><-></a> XML] ;
-    </a> ;
 
 ! XMode code component
 TUPLE: code mode ;
@@ -161,7 +155,7 @@ M: farkup render*
         nip
         [ no-follow>> [ string>boolean link-no-follow? set ] when* ]
         [ disable-images>> [ string>boolean disable-images? set ] when* ]
-        [ parsed>> string>boolean [ (write-farkup) ] [ write-farkup ] if ]
+        [ parsed>> string>boolean [ (write-farkup) ] [ farkup>xml ] if ]
         tri
     ] with-scope ;
 
@@ -169,7 +163,9 @@ M: farkup render*
 SINGLETON: inspector
 
 M: inspector render*
-    2drop [ describe ] with-html-writer ;
+    2drop [
+        [ describe ] with-html-writer
+    ] with-string-writer <unescaped> ;
 
 ! Diff component
 SINGLETON: comparison
@@ -180,4 +176,4 @@ M: comparison render*
 ! HTML component
 SINGLETON: html
 
-M: html render* 2drop write ;
+M: html render* 2drop string>xml-chunk ;

basis/html/elements/elements-docs.factor

@@ -14,7 +14,7 @@ $nl
 { $code "<a =href a> \"Click me\" write </a>" }
 { $code "<a \"http://\" prepend =href a> \"click\" write </a>" }
 { $code "<a [ \"http://\" % % ] \"\" make =href a> \"click\" write </a>" }
-"Tags that have no ``closing'' equivalent have a trailing " { $snippet "tag/>" } " form:"
+"Tags that have no “closing” equivalent have a trailing " { $snippet "tag/>" } " form:"
 { $code "<input \"text\" =type \"name\" =name 20 =size input/>" }
 "For the full list of HTML tags and attributes, consult the word list for the " { $vocab-link "html.elements" } " vocabulary. In addition to HTML tag and attribute words, a few utilities are provided."
 $nl

basis/html/templates/chloe/chloe-tests.factor

@@ -159,7 +159,7 @@ TUPLE: person first-name last-name ;
     "true" "b" set-value
 ] unit-test
 
-[ "<input type='checkbox' name='a'>a</input><input type='checkbox' name='b' checked='true'>b</input>" ] [
+[ "<input type=\"checkbox\" name=\"a\">a</input><input type=\"checkbox\" checked=\"true\" name=\"b\">b</input>" ] [
     [
         "test12" test-template call-template
     ] run-template

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

@@ -30,7 +30,7 @@ $nl
 { $table
     { { $slot "version" } { "The HTTP version. Default is " { $snippet "1.1" } " and should not be changed without good reason." } }
     { { $slot "code" } { "HTTP status code, an " { $link integer } ". Examples are 200 for success, 404 for file not found, and so on." } }
-    { { $slot "message" } { "HTTP status message, only displayed to the user. If the status code is 200, the status message might be ``Success'', for example." } }
+    { { $slot "message" } { "HTTP status message, only displayed to the user. If the status code is 200, the status message might be “Success”, for example." } }
     { { $slot "header" } { "An assoc of HTTP header values. See " { $link "http.headers" } } }
     { { $slot "cookies" } { "A sequence of HTTP cookies. See " { $link "http.cookies" } } }
     { { $slot "content-type" } { "an HTTP content type" } }
@@ -49,7 +49,7 @@ $nl
 { $table
     { { $slot "version" } { "The HTTP version. Default is " { $snippet "1.1" } " and should not be changed without good reason." } }
     { { $slot "code" } { "HTTP status code, an " { $link integer } ". Examples are 200 for success, 404 for file not found, and so on." } }
-    { { $slot "message" } { "HTTP status message, only displayed to the user. If the status code is 200, the status message might be ``Success'', for example." } }
+    { { $slot "message" } { "HTTP status message, only displayed to the user. If the status code is 200, the status message might be “Success”, for example." } }
     { { $slot "body" } { "an HTTP response body" } }
 } } ;
 
@@ -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
@@ -110,7 +110,7 @@ $nl
 HELP: set-header
 { $values { "request/response" "a " { $link request } " or a " { $link response } } { "value" object } { "key" string } }
 { $description "Stores a value into the HTTP header of a request or response. The value can be any object supported by " { $link present } "." }
-{ $notes "This word always returns the same object that was input. This allows for a ``pipeline'' coding style, where several header parameters are set in a row." }
+{ $notes "This word always returns the same object that was input. This allows for a “pipeline” coding style, where several header parameters are set in a row." }
 { $side-effects "request/response" } ;
 
 ARTICLE: "http.cookies" "HTTP cookies"

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,14 +213,11 @@ body ;
     raw-response new
         "1.1" >>version ;
 
-TUPLE: post-data raw content content-type form-variables uploaded-files ;
+TUPLE: post-data data params content-type content-encoding ;
 
-: <post-data> ( form-variables uploaded-files raw content-type -- post-data )
+: <post-data> ( content-type -- post-data )
     post-data new
-        swap >>content-type
+        swap >>content-type ;
-        swap >>raw
-        swap >>uploaded-files
-        swap >>form-variables ;
 
 : 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/dispatchers/dispatchers-docs.factor

@@ -41,7 +41,7 @@ main-responder set-global">
 }
 "In the above example, visiting any URL other than " { $snippet "/new" } ", " { $snippet "/edit" } ", " { $snippet "/delete" } ", or " { $snippet "/" } " will result in a 404 error."
 { $heading "Another pathname dispatcher" }
-"On the other hand, suppose we wanted to route all unrecognized paths to a ``view'' action:"
+"On the other hand, suppose we wanted to route all unrecognized paths to a “view” action:"
 { $code
     <" <dispatcher>
     <new-action> "new" add-responder

basis/http/server/server.factor

@@ -26,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
 
@@ -44,7 +42,7 @@ ERROR: no-boundary ;
     ";" split1 nip
     "=" split1 nip [ no-boundary ] unless* ;
 
-: read-multipart-data ( request -- form-variables uploaded-files )
+: read-multipart-data ( request -- mime-parts )
     [ "content-type" header ]
     [ "content-length" header string>number ] bi
     unlimit-input
@@ -55,18 +53,17 @@ ERROR: no-boundary ;
 : read-content ( request -- bytes )
     "content-length" header string>number read ;
 
-: parse-content ( request content-type -- form-variables uploaded-files raw )
+: parse-content ( request content-type -- post-data )
-    {
+    [ <post-data> swap ] keep {
-        { "multipart/form-data" [ read-multipart-data f ] }
+        { "multipart/form-data" [ read-multipart-data >>params ] }
-        { "application/x-www-form-urlencoded" [ read-content [ f f ] dip ] }
+        { "application/x-www-form-urlencoded" [ read-content query>assoc >>params ] }
-        [ drop read-content [ f f ] dip ]
+        [ drop read-content >>data ]
     } case ;
 
 : read-post-data ( request -- request )
     dup method>> "POST" = [
         dup dup "content-type" header
-        [ ";" split1 drop parse-content ] keep
+        ";" split1 drop parse-content >>post-data
-        <post-data> >>post-data
     ] when ;
 
 : extract-host ( request -- request )
@@ -199,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 ]

basis/interpolate/interpolate.factor

@@ -1,9 +1,11 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io kernel macros make multiline namespaces parser
 present sequences strings splitting fry accessors ;
 IN: interpolate
 
+<PRIVATE
+
 TUPLE: interpolate-var name ;
 
 : (parse-interpolate) ( string -- )
@@ -20,21 +22,22 @@ TUPLE: interpolate-var name ;
 : parse-interpolate ( string -- seq )
     [ (parse-interpolate) ] { } make ;
 
-MACRO: interpolate ( string -- )
+: (interpolate) ( string quot -- quot' )
-    parse-interpolate [
+    [ parse-interpolate ] dip '[
         dup interpolate-var?
-        [ name>> '[ _ get present write ] ]
+        [ name>> @ '[ _ @ present write ] ]
         [ '[ _ write ] ]
         if
-    ] map [ ] join ;
+    ] map [ ] join ; inline
+
+PRIVATE>
+
+MACRO: interpolate ( string -- )
+    [ [ get ] ] (interpolate) ;
 
 : interpolate-locals ( string -- quot )
-    parse-interpolate [
+    [ search [ ] ] (interpolate) ;
-        dup interpolate-var?
-        [ name>> search '[ _ present write ] ]
-        [ '[ _ write ] ]
-        if
-    ] map [ ] join ;
 
-: I[ "]I" parse-multiline-string
+: I[
-    interpolate-locals parsed \ call parsed ; parsing
+    "]I" parse-multiline-string
+    interpolate-locals over push-all ; parsing

basis/interval-maps/interval-maps-docs.factor

@@ -18,7 +18,8 @@ HELP: <interval-map>
 { $description "From a specification, produce an interval tree. The specification is an assoc where the keys are intervals, or pairs of numbers to represent intervals, or individual numbers to represent singleton intervals. The values are the values int he interval map. Construction time is O(n log n)." } ;
 
 ARTICLE: "interval-maps" "Interval maps"
-"Interval maps are a mechanism, similar to assocs, where a set of closed intervals of keys are associated with values. As such, interval maps do not conform to the assoc protocol, because intervals of floats, for example, can be used, and it is impossible to get a list of keys in between."
+"The " { $vocab-link "interval-maps" } " vocabulary implements a data structure, similar to assocs, where a set of closed intervals of keys are associated with values. As such, interval maps do not conform to the assoc protocol, because intervals of floats, for example, can be used, and it is impossible to get a list of keys in between."
+$nl
 "The following operations are used to query interval maps:"
 { $subsection interval-at* }
 { $subsection interval-at }

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

@@ -5,13 +5,13 @@ IN: io.directories
 HELP: cwd
 { $values { "path" "a pathname string" } }
 { $description "Outputs the current working directory of the Factor process." }
-{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
+{ $errors "Windows CE has no concept of “current directory”, so this word throws an error there." }
 { $notes "User code should use the value of the " { $link current-directory } " variable instead." } ;
 
 HELP: cd
 { $values { "path" "a pathname string" } }
 { $description "Changes the current working directory of the Factor process." }
-{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
+{ $errors "Windows CE has no concept of “current directory”, so this word throws an error there." }
 { $notes "User code should use " { $link with-directory } " or " { $link set-current-directory } " instead." } ;
 
 { cd cwd current-directory set-current-directory with-directory } related-words
@@ -116,7 +116,7 @@ ARTICLE: "current-directory" "Current working directory"
 "This variable can be changed with a pair of words:"
 { $subsection set-current-directory }
 { $subsection with-directory }
-"This variable is independent of the operating system notion of ``current working directory''. While all Factor I/O operations use the variable and not the operating system's value, care must be taken when making FFI calls which expect a pathname. The first option is to resolve relative paths:"
+"This variable is independent of the operating system notion of “current working directory”. While all Factor I/O operations use the variable and not the operating system's value, care must be taken when making FFI calls which expect a pathname. The first option is to resolve relative paths:"
 { $subsection (normalize-path) }
 "The second is to change the working directory of the current process:"
 { $subsection cd }
@@ -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/search/search-tests.factor

@@ -4,8 +4,7 @@ IN: io.directories.search.tests
 
 [ t ] [
     [
-        10 [ "io.paths.test" "gogogo" make-unique-file* ] replicate
+        10 [ "io.paths.test" "gogogo" make-unique-file ] replicate
-        current-directory get t [ ] find-all-files
+        current-temporary-directory get t [ ] find-all-files
-    ] with-unique-directory
+    ] with-unique-directory drop [ natural-sort ] bi@ =
-    [ natural-sort ] bi@ =
 ] unit-test

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/8-bit/8-bit-docs.factor

@@ -4,7 +4,7 @@ USING: help.syntax help.markup io.encodings.8-bit.private
 strings ;
 IN: io.encodings.8-bit
 
-ARTICLE: "io.encodings.8-bit" "8-bit encodings"
+ARTICLE: "io.encodings.8-bit" "Legacy 8-bit encodings"
 "Many encodings are a simple mapping of bytes onto characters. The " { $vocab-link "io.encodings.8-bit" } " vocabulary implements these generically using existing resource files. These encodings should be used with extreme caution, as fully general Unicode encodings like UTF-8 are nearly always more appropriate. The following 8-bit encodings are already defined:"
 { $subsection latin1 }
 { $subsection latin2 }

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/files/links/unix/unix-tests.factor

@@ -9,24 +9,30 @@ IN: io.files.links.unix.tests
 
 [ t ] [
     [
+        current-temporary-directory get [
             5 "lol" make-test-links
             "lol1" follow-links
-        current-directory get "lol5" append-path =
+            current-temporary-directory get "lol5" append-path =
-    ] with-unique-directory
+        ] with-directory
+    ] cleanup-unique-directory
 ] unit-test
 
 [
     [
+        current-temporary-directory get [
             100 "laf" make-test-links "laf1" follow-links
+        ] with-directory
     ] with-unique-directory
 ] [ too-many-symlinks? ] must-fail-with
 
 [ t ] [
     110 symlink-depth [
         [
+            current-temporary-directory get [
                 100 "laf" make-test-links
                 "laf1" follow-links
-            current-directory get "laf100" append-path =
+                current-temporary-directory get "laf100" append-path =
-        ] with-unique-directory
+            ] with-directory
+        ] cleanup-unique-directory
     ] with-variable
 ] unit-test

basis/io/files/unique/unique-docs.factor

@@ -1,8 +1,9 @@
 USING: help.markup help.syntax io io.ports kernel math
-io.pathnames io.directories math.parser io.files strings ;
+io.pathnames io.directories math.parser io.files strings
+quotations io.files.unique.private ;
 IN: io.files.unique
 
-HELP: temporary-path
+HELP: default-temporary-directory
 { $values
      { "path" "a pathname string" }
 }
@@ -25,42 +26,66 @@ HELP: unique-retries
 HELP: make-unique-file ( prefix suffix -- path )
 { $values { "prefix" "a string" } { "suffix" "a string" }
 { "path" "a pathname string" } }
-{ $description "Creates a file that is guaranteed not to exist in a platform-specific temporary directory. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." }
+{ $description "Creates a file that is guaranteed not to exist in the directory stored in " { $link current-temporary-directory } ". The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." }
 { $errors "Throws an error if a new unique file cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." } ;
 
-HELP: make-unique-file*
+{ unique-file make-unique-file cleanup-unique-file } related-words
-{ $values
-     { "prefix" string } { "suffix" string }
-     { "path" "a pathname string" }
-}
-{ $description "Creates a file that is guaranteed not to exist in the directory in the " { $link current-directory } " variable. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." } ;
 
-{ make-unique-file make-unique-file* with-unique-file } related-words
+HELP: cleanup-unique-file ( prefix suffix quot: ( path -- ) -- )
-
-HELP: with-unique-file ( prefix suffix quot: ( path -- ) -- )
 { $values { "prefix" "a string" } { "suffix" "a string" }
 { "quot" "a quotation" } }
 { $description "Creates a file with " { $link make-unique-file } " and calls the quotation with the path name on the stack." }
 { $notes "The unique file will be deleted after calling this word." } ;
 
-HELP: make-unique-directory ( -- path )
+HELP: unique-directory ( -- path )
 { $values { "path" "a pathname string" } }
-{ $description "Creates a directory that is guaranteed not to exist in a platform-specific temporary directory and returns the full pathname." }
+{ $description "Creates a directory in the value in " { $link current-temporary-directory } " that is guaranteed not to exist in and returns the full pathname." }
 { $errors "Throws an error if the directory cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." } ;
 
-HELP: with-unique-directory ( quot -- )
+HELP: cleanup-unique-directory ( quot -- )
 { $values { "quot" "a quotation" } }
-{ $description "Creates a directory with " { $link make-unique-directory } " and calls the quotation with the pathname on the stack using the " { $link with-directory } " combinator. The quotation can access the " { $link current-directory } " symbol for the name of the temporary directory." }
+{ $description "Creates a directory with " { $link unique-directory } " and calls the quotation with the pathname on the stack using the " { $link with-temporary-directory } " combinator. The quotation can access the " { $link current-temporary-directory } " symbol for the name of the temporary directory. Subsequent unique files will be created in this unique directory until the combinator returns." }
-{ $notes "The directory will be deleted after calling this word, even if an error is thrown in the quotation." } ;
+{ $notes "The directory will be deleted after calling this word, even if an error is thrown in the quotation. This combinator is like " { $link with-unique-directory } " but does not delete the directory." } ;
 
-ARTICLE: "io.files.unique" "Temporary files"
+HELP: with-unique-directory
-"The " { $vocab-link "io.files.unique" } " vocabulary implements cross-platform temporary file creation in a high-level and secure way." $nl
+{ $values
-"Creating temporary files:"
+     { "quot" quotation }
+     { "path" "a pathname string" }
+}
+{ $description "Creates a directory with " { $link unique-directory } " and calls the quotation with the pathname on the stack using the " { $link with-temporary-directory } " combinator. The quotation can access the " { $link current-temporary-directory } " symbol for the name of the temporary directory. Subsequent unique files will be created in this unique directory until the combinator returns." } ;
+
+HELP: current-temporary-directory
+{ $values
+     { "value" "a path" }
+}
+{ $description "The temporary directory used for creating unique files and directories." } ;
+
+HELP: unique-file
+{ $values
+     { "path" "a pathname string" }
+     { "path'" "a pathname string" }
+}
+{ $description "Creates a temporary file in the directory stored in " { $link current-temporary-directory } " and outputs the path name." } ;
+
+HELP: with-temporary-directory
+{ $values
+     { "path" "a pathname string" } { "quot" quotation }
+}
+{ $description "Sets " { $link current-temporary-directory } " to " { $snippet "path" } " and calls the quotation, restoring the previous temporary path after execution completes." } ;
+
+ARTICLE: "io.files.unique" "Unique files"
+"The " { $vocab-link "io.files.unique" } " vocabulary implements cross-platform unique file creation in temporary directories in a high-level and secure way." $nl
+"Changing the temporary path:"
+{ $subsection current-temporary-directory }
+"Creating unique files:"
+{ $subsection unique-file }
+{ $subsection cleanup-unique-file }
 { $subsection make-unique-file }
-{ $subsection make-unique-file* }
+"Creating unique directories:"
-{ $subsection with-unique-file }
+{ $subsection unique-directory }
-"Creating temporary directories:"
+{ $subsection with-unique-directory }
-{ $subsection make-unique-directory }
+{ $subsection cleanup-unique-directory }
-{ $subsection with-unique-directory } ;
+"Default temporary directory:"
+{ $subsection default-temporary-directory } ;
 
 ABOUT: "io.files.unique"

basis/io/files/unique/unique-tests.factor

@@ -1,21 +1,41 @@
 USING: io.encodings.ascii sequences strings io io.files accessors
 tools.test kernel io.files.unique namespaces continuations
-io.files.info io.pathnames ;
+io.files.info io.pathnames io.directories ;
 IN: io.files.unique.tests
 
 [ 123 ] [
     "core" ".test" [
         [ [ 123 CHAR: a <repetition> ] dip ascii set-file-contents ]
         [ file-info size>> ] bi
-    ] with-unique-file
+    ] cleanup-unique-file
 ] unit-test
 
 [ t ] [
-    [ current-directory get file-info directory? ] with-unique-directory
+    [ current-directory get file-info directory? ] cleanup-unique-directory
 ] unit-test
 
 [ t ] [
     current-directory get
-    [ [ "FAILDOG" throw ] with-unique-directory ] [ drop ] recover
+    [ [ "FAILDOG" throw ] cleanup-unique-directory ] [ drop ] recover
     current-directory get =
 ] unit-test
+
+[ t ] [
+    [
+        "asdf" unique-file drop
+        "asdf2" unique-file drop
+        current-temporary-directory get directory-files length 2 =
+    ] cleanup-unique-directory
+] unit-test
+
+[ t ] [
+    [ ] with-unique-directory >boolean
+] unit-test
+
+[ t ] [
+    [
+        "asdf" unique-file drop
+        "asdf" unique-file drop
+        current-temporary-directory get directory-files length 2 =
+    ] with-unique-directory drop
+] unit-test

basis/io/files/unique/unique.factor

@@ -6,8 +6,13 @@ kernel math math.bitwise math.parser namespaces random
 sequences system vocabs.loader ;
 IN: io.files.unique
 
-HOOK: touch-unique-file io-backend ( path -- )
+HOOK: (touch-unique-file) io-backend ( path -- )
-HOOK: temporary-path io-backend ( -- path )
+: touch-unique-file ( path -- )
+    normalize-path (touch-unique-file) ;
+
+HOOK: default-temporary-directory io-backend ( -- path )
+
+SYMBOL: current-temporary-directory
 
 SYMBOL: unique-length
 SYMBOL: unique-retries
@@ -15,6 +20,9 @@ SYMBOL: unique-retries
 10 unique-length set-global
 10 unique-retries set-global
 
+: with-temporary-directory ( path quot -- )
+    [ current-temporary-directory ] dip with-variable ; inline
+
 <PRIVATE
 
 : random-letter ( -- ch )
@@ -24,37 +32,44 @@ SYMBOL: unique-retries
     { t f } random
     [ 10 random CHAR: 0 + ] [ random-letter ] if ;
 
-: random-name ( n -- string )
+: random-name ( -- string )
-    [ random-ch ] "" replicate-as ;
+    unique-length get [ random-ch ] "" replicate-as ;
-
-PRIVATE>
 
 : (make-unique-file) ( path prefix suffix -- path )
     '[
-        _ _ _ unique-length get random-name glue append-path
+        _ _ _ random-name glue append-path
         dup touch-unique-file
     ] unique-retries get retry ;
 
+PRIVATE>
+
 : make-unique-file ( prefix suffix -- path )
-    [ temporary-path ] 2dip (make-unique-file) ;
+    [ current-temporary-directory get ] 2dip (make-unique-file) ;
 
-: make-unique-file* ( prefix suffix -- path )
+: cleanup-unique-file ( prefix suffix quot: ( path -- ) -- )
-    [ current-directory get ] 2dip (make-unique-file) ;
-
-: with-unique-file ( prefix suffix quot: ( path -- ) -- )
     [ make-unique-file ] dip [ delete-file ] bi ; inline
 
-: make-unique-directory ( -- path )
+: unique-directory ( -- path )
     [
-        temporary-path unique-length get random-name append-path
+        current-temporary-directory get
+        random-name append-path
         dup make-directory
     ] unique-retries get retry ;
 
-: with-unique-directory ( quot: ( -- ) -- )
+: with-unique-directory ( quot -- path )
-    [ make-unique-directory ] dip
+    [ unique-directory ] dip
-    '[ _ with-directory ] [ delete-tree ] bi ; inline
+    [ with-temporary-directory ] [ drop ] 2bi ; inline
+
+: cleanup-unique-directory ( quot: ( -- ) -- )
+    [ unique-directory ] dip
+    '[ _ with-temporary-directory ] [ delete-tree ] bi ; inline
+
+: unique-file ( path -- path' )
+    "" make-unique-file ;
 
 {
     { [ os unix? ] [ "io.files.unique.unix" ] }
     { [ os windows? ] [ "io.files.unique.windows" ] }
 } cond require
+
+default-temporary-directory current-temporary-directory set-global

basis/io/files/unique/unix/unix.factor

@@ -7,7 +7,7 @@ IN: io.files.unique.unix
 : open-unique-flags ( -- flags )
     { O_RDWR O_CREAT O_EXCL } flags ;
 
-M: unix touch-unique-file ( path -- )
+M: unix (touch-unique-file) ( path -- )
     open-unique-flags file-mode open-file close-file ;
 
-M: unix temporary-path ( -- path ) "/tmp" ;
+M: unix default-temporary-directory ( -- path ) "/tmp" ;

basis/io/files/unique/windows/windows.factor

@@ -3,8 +3,8 @@ io.files.windows io.ports windows destructors environment
 io.files.unique ;
 IN: io.files.unique.windows
 
-M: windows touch-unique-file ( path -- )
+M: windows (touch-unique-file) ( path -- )
     GENERIC_WRITE CREATE_NEW 0 open-file dispose ;
 
-M: windows temporary-path ( -- path )
+M: windows default-temporary-directory ( -- path )
     "TEMP" os-env ;

basis/io/monitors/linux/linux-tests.factor

@@ -16,7 +16,7 @@ destructors io.timeouts ;
     [ ] [ "monitor-test-self" temp-file touch-file ] unit-test
 
     [ t ] [
-        "m" get next-change drop
+        "m" get next-change path>>
         [ "" = ] [ "monitor-test-self" temp-file = ] bi or
     ] unit-test
 
@@ -29,7 +29,7 @@ destructors io.timeouts ;
     [ ] [ "monitor-test-self" temp-file touch-file ] unit-test
 
     [ t ] [
-        "m" get next-change drop
+        "m" get next-change path>>
         [ "" = ] [ "monitor-test-self" temp-file = ] bi or
     ] unit-test
 

basis/io/monitors/monitors-docs.factor

@@ -17,9 +17,12 @@ HELP: (monitor)
 { $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } " and posts notifications to " { $snippet "mailbox" } " as triples with shape " { $snippet "{ path changed monitor } " } ". The boolean indicates whether changes in subdirectories should be reported." }
 { $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;
 
+HELP: file-change
+{ $class-description "A change notification output by " { $link next-change } ". The " { $snippet "path" } " slot holds a pathname string. The " { $snippet "changed" } " slots holds a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ;
+
 HELP: next-change
-{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changed" "a change descriptor" } }
+{ $values { "monitor" "a monitor" } { "change" file-change } }
-{ $contract "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." }
+{ $contract "Waits for file system changes and outputs a change descriptor for the first changed file." }
 { $errors "Throws an error if the monitor is closed from another thread." } ;
 
 HELP: with-monitor
@@ -46,7 +49,9 @@ HELP: +rename-file+
 { $description "Indicates that a file has been renamed." } ;
 
 ARTICLE: "io.monitors.descriptors" "File system change descriptors"
-"Change descriptors output by " { $link next-change } ":"
+"The " { $link next-change } " word outputs instances of a class:"
+{ $subsection file-change }
+"The " { $slot "changed" } " slot holds a sequence which may contain any of the following symbols:"
 { $subsection +add-file+ }
 { $subsection +remove-file+ }
 { $subsection +modify-file+ }
@@ -55,7 +60,7 @@ ARTICLE: "io.monitors.descriptors" "File system change descriptors"
 { $subsection +rename-file+ } ;
 
 ARTICLE: "io.monitors.platforms" "Monitors on different platforms"
-"Whether the " { $snippet "path" } " output value of " { $link next-change } " contains an absolute path or a path relative to the path given to " { $link <monitor> } " is unspecified, and may even vary on the same platform. User code should not assume either case."
+"Whether the " { $slot "path" } " slot of a " { $link file-change } " contains an absolute path or a path relative to the path given to " { $link <monitor> } " is unspecified, and may even vary on the same platform. User code should not assume either case."
 $nl
 "If the immediate path being monitored was changed, then " { $snippet "path" } " will equal " { $snippet "\"\"" } "; however this condition is not reported on all platforms. See below."
 { $heading "Mac OS X" }
@@ -63,7 +68,7 @@ $nl
 $nl
 { $snippet "FSEventStream" } "s always monitor directory hierarchies recursively, and the " { $snippet "recursive?" } " parameter to " { $link <monitor> } " has no effect."
 $nl
-"The " { $snippet "changed" } " output value of the " { $link next-change } " word always outputs " { $link +modify-file+ } " and the " { $snippet "path" } " output value is always the directory containing the file that changed. Unlike other platforms, fine-grained information is not available."
+"The " { $snippet "changed" } " slot of the " { $link file-change } " word tuple always contains " { $link +modify-file+ } " and the " { $snippet "path" } " slot is always the directory containing the file that changed. Unlike other platforms, fine-grained information is not available."
 $nl
 "Only directories may be monitored, not individual files. Changes to the directory itself (permissions, modification time, and so on) are not reported; only changes to children are reported."
 { $heading "Windows" }
@@ -107,7 +112,7 @@ $nl
 { $code
     "USE: io.monitors"
     ": watch-loop ( monitor -- )"
-    "    dup next-change . . nl nl flush watch-loop ;"
+    "    dup next-change . nl nl flush watch-loop ;"
     ""
     ": watch-directory ( path -- )"
     "    [ t [ watch-loop ] with-monitor ] with-monitors"

basis/io/monitors/monitors-tests.factor

@@ -3,7 +3,7 @@ USING: io.monitors tools.test io.files system sequences
 continuations namespaces concurrency.count-downs kernel io
 threads calendar prettyprint destructors io.timeouts
 io.files.temp io.directories io.directories.hierarchy
-io.pathnames ;
+io.pathnames accessors ;
 
 os { winnt linux macosx } member? [
     [
@@ -53,7 +53,7 @@ os { winnt linux macosx } member? [
                 "b" get count-down
 
                 [
-                    "m" get next-change drop
+                    "m" get next-change path>>
                     dup print flush
                     dup parent-directory
                     [ trim-right-separators "xyz" tail? ] either? not
@@ -62,7 +62,7 @@ os { winnt linux macosx } member? [
                 "c1" get count-down
                 
                 [
-                    "m" get next-change drop
+                    "m" get next-change path>>
                     dup print flush
                     dup parent-directory
                     [ trim-right-separators "yxy" tail? ] either? not
@@ -101,13 +101,13 @@ os { winnt linux macosx } member? [
         ! Non-recursive
         [ ] [ "monitor-timeout-test" temp-file f <monitor> "m" set ] unit-test
         [ ] [ 3 seconds "m" get set-timeout ] unit-test
-        [ [ t ] [ "m" get next-change 2drop ] [ ] while ] must-fail
+        [ [ t ] [ "m" get next-change drop ] [ ] while ] must-fail
         [ ] [ "m" get dispose ] unit-test
 
         ! Recursive
         [ ] [ "monitor-timeout-test" temp-file t <monitor> "m" set ] unit-test
         [ ] [ 3 seconds "m" get set-timeout ] unit-test
-        [ [ t ] [ "m" get next-change 2drop ] [ ] while ] must-fail
+        [ [ t ] [ "m" get next-change drop ] [ ] while ] must-fail
         [ ] [ "m" get dispose ] unit-test
     ] with-monitors
 ] when

basis/io/monitors/monitors.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io.backend kernel continuations destructors namespaces
 sequences assocs hashtables sorting arrays threads boxes
-io.timeouts accessors concurrency.mailboxes
+io.timeouts accessors concurrency.mailboxes fry
 system vocabs.loader combinators ;
 IN: io.monitors
 
@@ -33,17 +33,19 @@ M: monitor set-timeout (>>timeout) ;
         swap >>queue
         swap >>path ; inline
 
+TUPLE: file-change path changed monitor ;
+
 : queue-change ( path changes monitor -- )
     3dup and and
-    [ [ 3array ] keep queue>> mailbox-put ] [ 3drop ] if ;
+    [ [ file-change boa ] keep queue>> mailbox-put ] [ 3drop ] if ;
 
 HOOK: (monitor) io-backend ( path recursive? mailbox -- monitor )
 
 : <monitor> ( path recursive? -- monitor )
     <mailbox> (monitor) ;
 
-: next-change ( monitor -- path changed )
+: next-change ( monitor -- change )
-    [ queue>> ] [ timeout ] bi mailbox-get-timeout first2 ;
+    [ queue>> ] [ timeout ] bi mailbox-get-timeout ;
 
 SYMBOL: +add-file+
 SYMBOL: +remove-file+
@@ -55,9 +57,15 @@ SYMBOL: +rename-file+
 : with-monitor ( path recursive? quot -- )
     [ <monitor> ] dip with-disposal ; inline
 
+: run-monitor ( path recursive? quot -- )
+    '[ [ @ t ] loop ] with-monitor ; inline
+
+: spawn-monitor ( path recursive? quot -- )
+    [ '[ _ _ _ run-monitor ] ] [ 2drop "Monitoring " prepend ] 3bi
+    spawn drop ;
 {
     { [ os macosx? ] [ "io.monitors.macosx" require ] }
     { [ os linux? ] [ "io.monitors.linux" require ] }
     { [ os winnt? ] [ "io.monitors.windows.nt" require ] }
-    [ ]
+    { [ os bsd? ] [ ] }
 } cond

basis/io/monitors/recursive/recursive.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors sequences assocs arrays continuations
 destructors combinators kernel threads concurrency.messaging
@@ -45,12 +45,11 @@ M: recursive-monitor dispose*
     bi ;
 
 : stop-pump ( -- )
-    monitor tget children>> [ nip dispose ] assoc-each ;
+    monitor tget children>> values dispose-each ;
 
 : pump-step ( msg -- )
-    first3 path>> swap [ prepend-path ] dip monitor tget 3array
+    [ [ monitor>> path>> ] [ path>> ] bi append-path ] [ changed>> ] bi
-    monitor tget queue>>
+    monitor tget queue-change ;
-    mailbox-put ;
 
 : child-added ( path monitor -- )
     path>> prepend-path add-child-monitor ;
@@ -59,7 +58,7 @@ M: recursive-monitor dispose*
     path>> prepend-path remove-child-monitor ;
 
 : update-hierarchy ( msg -- )
-    first3 swap [
+    [ path>> ] [ monitor>> ] [ changed>> ] tri [
         {
             { +add-file+ [ child-added ] }
             { +remove-file+ [ child-removed ] }

basis/io/pipes/pipes-docs.factor

@@ -29,7 +29,7 @@ HELP: run-pipeline
     }
 }
 { $examples
-    "Print the lines of a log file which contain the string ``error'', sort them and filter out duplicates, using Unix shell commands only:"
+    "Print the lines of a log file which contain the string “error”, sort them and filter out duplicates, using Unix shell commands only:"
     { $code "{ \"cat log.txt\" \"grep error\" \"sort\" \"uniq\" } run-pipeline" }
 } ;
 

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

@@ -81,7 +81,7 @@ ARTICLE: "io.streams.limited" "Limited input streams"
 "Unlimits a limited stream:"
 { $subsection unlimit }
 "Unlimits the current " { $link input-stream } ":"
-{ $subsection limit-input }
+{ $subsection unlimit-input }
 "Make a limited stream throw an exception on exhaustion:"
 { $subsection stream-throws }
 "Make a limited stream return " { $link f } " on exhaustion:"

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

@@ -1,6 +1,7 @@
 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 io.streams.string accessors ;
+namespaces tools.test strings kernel io.streams.string accessors
+io.encodings.utf8 io.files destructors ;
 IN: io.streams.limited.tests
 
 [ ] [
@@ -59,3 +60,19 @@ IN: io.streams.limited.tests
     "abc" <string-reader> 3 stream-eofs limit unlimit
     "abc" <string-reader> =
 ] unit-test
+
+[ t ]
+[
+    "abc" <string-reader> 3 stream-eofs limit unlimit
+    "abc" <string-reader> =
+] unit-test
+
+[ t ]
+[
+    [
+        "resource:license.txt" utf8 <file-reader> &dispose
+        3 stream-eofs limit unlimit
+        "resource:license.txt" utf8 <file-reader> &dispose
+        [ decoder? ] both?
+    ] with-destructors
+] unit-test

basis/io/streams/limited/limited.factor

@@ -5,7 +5,7 @@ USING: kernel math io io.encodings destructors accessors
 sequences namespaces byte-vectors fry combinators ;
 IN: io.streams.limited
 
-TUPLE: limited-stream stream count limit mode ;
+TUPLE: limited-stream stream count limit mode stack ;
 
 SINGLETONS: stream-throws stream-eofs ;
 
@@ -24,13 +24,24 @@ M: decoder limit ( stream limit mode -- stream' )
 M: object limit ( stream limit mode -- stream' )
     <limited-stream> ;
 
-: unlimit ( stream -- stream' )
+GENERIC: unlimit ( stream -- stream' )
+
+M: decoder unlimit ( stream -- stream' )
     [ stream>> ] change-stream ;
 
+M: object unlimit ( stream -- stream' )
+    stream>> stream>> ;
+
 : limit-input ( limit mode -- ) input-stream [ -rot limit ] change ;
 
 : unlimit-input ( -- ) input-stream [ unlimit ] change ;
 
+: with-unlimited-stream ( stream quot -- )
+    [ clone unlimit ] dip call ; inline
+
+: with-limited-stream ( stream limit mode quot -- )
+    [ limit ] dip call ; inline
+
 ERROR: limit-exceeded ;
 
 ERROR: bad-stream-mode mode ;

basis/lcs/diff2html/diff2html-tests.factor

@@ -0,0 +1,6 @@
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: lcs.diff2html lcs kernel tools.test strings sequences xml.writer ;
+IN: lcs.diff2html.tests
+
+[ ] [ "hello" "heyo" [ 1string ] { } map-as diff htmlize-diff xml-chunk>string drop ] unit-test

basis/lcs/diff2html/diff2html.factor

@@ -1,44 +1,42 @@
 ! Copyright (C) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: lcs html.elements kernel ;
+USING: lcs xml.interpolate xml.writer kernel strings ;
 FROM: accessors => item>> ;
 FROM: io => write ;
-FROM: sequences => each if-empty ;
+FROM: sequences => each if-empty when-empty map ;
-FROM: xml.entities => escape-string ;
 IN: lcs.diff2html
 
-GENERIC: diff-line ( obj -- )
+GENERIC: diff-line ( obj -- xml )
 
-: write-item ( item -- )
+: item-string ( item -- string )
-    item>> [ " " ] [ escape-string ] if-empty write ;
+    item>> [ CHAR: no-break-space 1string ] when-empty ;
 
 M: retain diff-line
-    <tr>
+    item-string
-        dup [
+    [XML <td class="retain"><-></td> XML]
-            <td "retain" =class td>
+    dup [XML <tr><-><-></tr> XML] ;
-                write-item
-            </td>
-        ] bi@
-    </tr> ;
 
 M: insert diff-line
+    item-string [XML
         <tr>
             <td> </td>
-        <td "insert" =class td>
+            <td class="insert"><-></td>
-            write-item
+        </tr>
-        </td>
+    XML] ;
-    </tr> ;
 
 M: delete diff-line
+    item-string [XML
         <tr>
-        <td "delete" =class td>
+            <td class="delete"><-></td>
-            write-item
-        </td>
             <td> </td>
-    </tr> ;
+        </tr>
+    XML] ;
 
-: htmlize-diff ( diff -- )
+: htmlize-diff ( diff -- xml )
-    <table "100%" =width "comparison" =class table>
+    [ diff-line ] map
-        <tr> <th> "Old" write </th> <th> "New" write </th> </tr>
+    [XML
-        [ diff-line ] each
+        <table width="100%" class="comparison">
-    </table> ;
+            <tr><th>Old</th><th>New</th></tr>
+            <->
+        </table>
+    XML] ;

basis/locals/locals-docs.factor

@@ -134,6 +134,7 @@ $nl
 }
 "In a word with locals, literals expand into code which constructs the literal, and so every invocation pushes a new object:"
 { $example
+    "USE: locals"
     "IN: scratchpad"
     "TUPLE: person first-name last-name ;"
     ":: ordinary-word-test ( -- tuple )"
@@ -166,7 +167,7 @@ $nl
 "Recall that the following two code snippets are equivalent:"
 { $code "'[ sq _ + ]" }
 { $code "[ [ sq ] dip + ] curry" }
-"The semantics of " { $link dip } " and " { $link curry } " are such that the first example behaves as if the top of the stack as ``inserted'' in the ``hole'' in the quotation's second element."
+"The semantics of " { $link dip } " and " { $link curry } " are such that the first example behaves as if the top of the stack as “inserted” in the “hole” in the quotation's second element."
 $nl
 "Conceptually, " { $link curry } " is defined so that the following two code snippets are equivalent:"
 { $code "3 [ - ] curry" }
@@ -179,7 +180,7 @@ $nl
 { $code "'[ [| a | a - ] curry ] call" }
 "Instead, the first line above expands into something like the following:"
 { $code "[ [ swap [| a | a - ] ] curry call ]" }
-"This ensures that the fried value appears ``underneath'' the local variable " { $snippet "a" } " when the quotation calls."
+"This ensures that the fried value appears “underneath” the local variable " { $snippet "a" } " when the quotation calls."
 $nl
 "The precise behavior is the following. When frying a lambda, a stack shuffle (" { $link mnswap } ") is prepended to the lambda so that the " { $snippet "m" } " curried values, which start off at the top of the stack, are transposed with the " { $snippet "n" } " inputs to the lambda." ;
 

basis/locals/locals-tests.factor

@@ -491,3 +491,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
 [ 10 ] [
     [| | 0 '[ [let | A [ 10 ] | A _ + ] ] call ] call
 ] unit-test
+
+! Discovered by littledan
+[ "bar" ] [ [let | a [ [let | foo [ "bar" ] | foo ] ] | a ] ] unit-test
+[ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test

basis/locals/parser/parser.factor

@@ -1,7 +1,7 @@
-! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
+! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays combinators effects.parser
-generic.parser kernel lexer locals.errors
+generic.parser kernel lexer locals.errors fry
 locals.rewrite.closures locals.types make namespaces parser
 quotations sequences splitting words vocabs.parser ;
 IN: locals.parser
@@ -56,19 +56,21 @@ SYMBOL: in-lambda?
         (parse-bindings)
     ] [ 2drop ] if ;
 
+: with-bindings ( quot -- words assoc )
+    '[
+        in-lambda? on
+        _ H{ } make-assoc
+    ] { } make swap ; inline
+
 : parse-bindings ( end -- bindings vars )
-    [
+    [ (parse-bindings) ] with-bindings ;
-        [ (parse-bindings) ] H{ } make-assoc
-    ] { } make swap ;
 
 : parse-bindings* ( end -- words assoc )
-    [
     [
         namespace push-locals
         (parse-bindings)
         namespace pop-locals
-        ] { } make-assoc
+    ] with-bindings ;
-    ] { } make swap ;
 
 : (parse-wbindings) ( end -- )
     dup parse-binding dup [
@@ -77,9 +79,7 @@ SYMBOL: in-lambda?
     ] [ 2drop ] if ;
 
 : parse-wbindings ( end -- bindings vars )
-    [
+    [ (parse-wbindings) ] with-bindings ;
-        [ (parse-wbindings) ] H{ } make-assoc
-    ] { } make swap ;
 
 : parse-locals ( -- vars assoc )
     "(" expect ")" parse-effect
@@ -88,8 +88,8 @@ SYMBOL: in-lambda?
 
 : parse-locals-definition ( word -- word quot )
     parse-locals \ ; (parse-lambda) <lambda>
-    2dup "lambda" set-word-prop
+    [ "lambda" set-word-prop ]
-    rewrite-closures dup length 1 = [ first ] [ bad-lambda-rewrite ] if ;
+    [ rewrite-closures dup length 1 = [ first ] [ bad-lambda-rewrite ] if ] 2bi ;
 
 : (::) ( -- word def ) CREATE-WORD parse-locals-definition ;
 

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/complex/complex-docs.factor

@@ -6,7 +6,7 @@ ARTICLE: "complex-numbers-zero" "Embedding of real numbers in complex numbers"
 "Constructing a complex number with an imaginary component equal to an integer zero simply returns the real number corresponding to the real component:"
 { $example "USING: math prettyprint ;" "C{ 1 2 } C{ 3 -2 } + ." "4" }
 "Constructing a complex number with an imaginary component equal to floating point zero will still output a new complex number, however:"
-{ $example "USING: math prettyprint ;" "C{ 0.0 2.0 } C{ 0.0 1.0 } * ." "C{ 2.0 0.0 }" }
+{ $example "USING: math prettyprint ;" "C{ 0.0 2.0 } C{ 0.0 1.0 } * ." "C{ -2.0 0.0 }" }
 "Unlike math, where all real numbers are also complex numbers, Factor only considers a number to be a complex number if its imaginary part is non-zero. However, complex number operations are fully supported for real numbers; they are treated as having an imaginary part of zero." ;
 
 ARTICLE: "complex-numbers" "Complex numbers"

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 < [