diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor
index 38ca796384..640439312d 100755
--- a/core/classes/classes-tests.factor
+++ b/core/classes/classes-tests.factor
@@ -56,8 +56,8 @@ UNION: c a b ;
 [ t ] [ \ c \ tuple class< ] unit-test
 [ f ] [ \ tuple \ c class< ] unit-test
 
-DEFER: bah
-FORGET: bah
+! DEFER: bah
+! FORGET: bah
 UNION: bah fixnum alien ;
 [ bah ] [ \ bah? "predicating" word-prop ] unit-test
 
diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
index 631aa7e62d..b2fba47d3a 100755
--- a/core/generic/generic-docs.factor
+++ b/core/generic/generic-docs.factor
@@ -116,16 +116,18 @@ HELP: method-spec
 { $class-description "The class of method specifiers, which are two-element arrays consisting of a class word followed by a generic word." }
 { $examples { $code "{ fixnum + }" "{ editor draw-gadget* }" } } ;
 
+HELP: method-body
+{ $class-description "The class of method bodies, which are words with special word properties set." } ;
+
 HELP: method
-{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method } " or " { $link f } } }
-{ $description "Looks up a method definition." }
-{ $class-description "Instances of this class are methods. A method consists of a quotation together with a source location where it was defined." } ;
+{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } }
+{ $description "Looks up a method definition." } ;
 
 { method define-method POSTPONE: M: } related-words
 
 HELP: <method>
 { $values { "def" "a quotation" } { "method" "a new method definition" } }
-{ $description "Creates a new  "{ $link method } " instance." } ;
+{ $description "Creates a new method." } ;
 
 HELP: methods
 { $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 35cc471033..f73579661d 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -25,16 +25,12 @@ GENERIC: make-default-method ( generic combination -- method )
 
 PREDICATE: word generic "combination" word-prop >boolean ;
 
-M: generic definer drop f f ;
-
 M: generic definition drop f ;
 
 : make-generic ( word -- )
     dup { "unannotated-def" } reset-props
     dup dup "combination" word-prop perform-combination define ;
 
-TUPLE: method word def specializer generic loc ;
-
 : method ( class generic -- method/f )
     "methods" word-prop at ;
 
@@ -47,7 +43,7 @@ PREDICATE: pair method-spec
 : methods ( word -- assoc )
     "methods" word-prop
     [ keys sort-classes ] keep
-    [ dupd at method-word ] curry { } map>assoc ;
+    [ dupd at ] curry { } map>assoc ;
 
 TUPLE: check-method class generic ;
 
@@ -63,29 +59,33 @@ TUPLE: check-method class generic ;
 : method-word-name ( class word -- string )
     word-name "/" rot word-name 3append ;
 
-: make-method-def ( quot word combination -- quot )
+: make-method-def ( quot class generic -- quot )
     "combination" word-prop method-prologue swap append ;
 
-PREDICATE: word method-body "method" word-prop >boolean ;
+PREDICATE: word method-body "method-def" word-prop >boolean ;
 
 M: method-body stack-effect
-    "method" word-prop method-generic stack-effect ;
+    "method-generic" word-prop stack-effect ;
 
-: <method-word> ( quot class generic -- word )
-    [ make-method-def ] 2keep
-    method-word-name f <word>
-    dup rot define
-    dup xref ;
+: method-word-props ( quot class generic -- assoc )
+    [
+        "method-generic" set
+        "method-class" set
+        "method-def" set
+    ] H{ } make-assoc ;
 
-: <method> ( quot class generic -- method )
+: <method> ( quot class generic -- word )
     check-method
-    [ <method-word> ] 3keep f \ method construct-boa
-    dup method-word over "method" set-word-prop ;
+    [ make-method-def ] 3keep
+    [ method-word-props ] 2keep
+    method-word-name f <word>
+    tuck set-word-props
+    dup rot define ;
 
 : redefine-method ( quot class generic -- )
-    [ method set-method-def ] 3keep
+    [ method swap "method-def" set-word-prop ] 3keep
     [ make-method-def ] 2keep
-    method method-word swap define ;
+    method swap define ;
 
 : define-method ( quot class generic -- )
     >r bootstrap-word r>
@@ -102,21 +102,22 @@ M: method-body stack-effect
 
 ! Definition protocol
 M: method-spec where
-    dup first2 method [ method-word ] [ second ] ?if where ;
+    dup first2 method [ ] [ second ] ?if where ;
 
 M: method-spec set-where
-    first2 method method-word set-where ;
+    first2 method set-where ;
 
 M: method-spec definer
     drop \ M: \ ; ;
 
 M: method-spec definition
-    first2 method dup [ method-def ] when ;
+    first2 method dup
+    [ "method-def" word-prop ] when ;
 
 : forget-method ( class generic -- )
     check-method
     [ delete-at* ] with-methods
-    [ method-word forget-word ] [ drop ] if ;
+    [ forget-word ] [ drop ] if ;
 
 M: method-spec forget*
     first2 forget-method ;
@@ -125,11 +126,11 @@ M: method-body definer
     drop \ M: \ ; ;
 
 M: method-body definition
-    "method" word-prop method-def ;
+    "method-def" word-prop ;
 
 M: method-body forget*
-    "method" word-prop
-    { method-specializer method-generic } get-slots
+    dup "method-class" word-prop
+    swap "method-generic" word-prop
     forget-method ;
 
 : implementors* ( classes -- words )
@@ -168,8 +169,7 @@ M: word subwords drop f ;
 
 M: generic subwords
     dup "methods" word-prop values
-    swap "default-method" word-prop add
-    [ method-word ] map ;
+    swap "default-method" word-prop add ;
 
 M: generic forget-word
     dup subwords [ forget-word ] each (forget-word) ;
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index 0b2b9fcca3..27b0ddb7a2 100755
--- a/core/generic/math/math.factor
+++ b/core/generic/math/math.factor
@@ -43,7 +43,7 @@ TUPLE: no-math-method left right generic ;
 
 : applicable-method ( generic class -- quot )
     over method
-    [ method-word word-def ]
+    [ word-def ]
     [ default-math-method ] ?if ;
 
 : object-method ( generic -- quot )
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 230ec446c7..313f487c99 100755
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -69,7 +69,7 @@ TUPLE: no-method object generic ;
     ] if ;
 
 : default-method ( word -- pair )
-    "default-method" word-prop method-word
+    "default-method" word-prop
     object bootstrap-word swap 2array ;
 
 : method-alist>quot ( alist base-class -- quot )
diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor
index cadf326692..2a2e6995eb 100755
--- a/core/inference/backend/backend.factor
+++ b/core/inference/backend/backend.factor
@@ -10,8 +10,7 @@ IN: inference.backend
     recursive-state get at ;
 
 : inline? ( word -- ? )
-    dup "method" word-prop
-    [ method-generic inline? ] [ "inline" word-prop ] ?if ;
+    dup "method-generic" word-prop swap or "inline" word-prop ;
 
 : local-recursive-state ( -- assoc )
     recursive-state get dup keys
diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor
index f3709780f9..04d7ab4ee5 100755
--- a/core/optimizer/inlining/inlining.factor
+++ b/core/optimizer/inlining/inlining.factor
@@ -1,208 +1,208 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic assocs inference inference.class
-inference.dataflow inference.backend inference.state io kernel
-math namespaces sequences vectors words quotations hashtables
-combinators classes generic.math continuations optimizer.def-use
-optimizer.backend generic.standard optimizer.specializers
-optimizer.def-use optimizer.pattern-match generic.standard
-optimizer.control kernel.private ;
-IN: optimizer.inlining
-
-: remember-inlining ( node history -- )
-    [ swap set-node-history ] curry each-node ;
-
-: inlining-quot ( node quot -- node )
-    over node-in-d dataflow-with
-    dup rot infer-classes/node ;
-
-: splice-quot ( #call quot history -- node )
-    #! Must add history *before* splicing in, otherwise
-    #! the rest of the IR will also remember the history
-    pick node-history append
-    >r dupd inlining-quot dup r> remember-inlining
-    tuck splice-node ;
-
-! A heuristic to avoid excessive inlining
-DEFER: (flat-length)
-
-: word-flat-length ( word -- n )
-    {
-        ! heuristic: { ... } declare comes up in method bodies
-        ! and we don't care about it
-        { [ dup \ declare eq? ] [ drop -2 ] }
-        ! recursive
-        { [ dup get ] [ drop 1 ] }
-        ! not inline
-        { [ dup inline? not ] [ drop 1 ] }
-        ! inline
-        { [ t ] [ dup dup set word-def (flat-length) ] }
-    } cond ;
-
-: (flat-length) ( seq -- n )
-    [
-        {
-            { [ dup quotation? ] [ (flat-length) 1+ ] }
-            { [ dup array? ] [ (flat-length) ] }
-            { [ dup word? ] [ word-flat-length ] }
-            { [ t ] [ drop 1 ] }
-        } cond
-    ] map sum ;
-
-: flat-length ( seq -- n )
-    [ word-def (flat-length) ] with-scope ;
-
-! Single dispatch method inlining optimization
-: specific-method ( class word -- class ) order min-class ;
-
-: node-class# ( node n -- class )
-    over node-in-d <reversed> ?nth node-class ;
-
-: dispatching-class ( node word -- class )
-    [ dispatch# node-class# ] keep specific-method ;
-
-: inline-standard-method ( node word -- node )
-    2dup dispatching-class dup [
-        over +inlined+ depends-on
-        swap method method-word 1quotation f splice-quot
-    ] [
-        3drop t
-    ] if ;
-
-! Partial dispatch of math-generic words
-: math-both-known? ( word left right -- ? )
-    math-class-max swap specific-method ;
-
-: inline-math-method ( #call word -- node )
-    over node-input-classes first2 3dup math-both-known?
-    [ math-method f splice-quot ] [ 2drop 2drop t ] if ;
-
-: inline-method ( #call -- node )
-    dup node-param {
-        { [ dup standard-generic? ] [ inline-standard-method ] }
-        { [ dup math-generic? ] [ inline-math-method ] }
-        { [ t ] [ 2drop t ] }
-    } cond ;
-
-! Resolve type checks at compile time where possible
-: comparable? ( actual testing -- ? )
-    #! If actual is a subset of testing or if the two classes
-    #! are disjoint, return t.
-    2dup class< >r classes-intersect? not r> or ;
-
-: optimize-predicate? ( #call -- ? )
-    dup node-param "predicating" word-prop dup [
-        >r node-class-first r> comparable?
-    ] [
-        2drop f
-    ] if ;
-
-: literal-quot ( node literals -- quot )
-    #! Outputs a quotation which drops the node's inputs, and
-    #! pushes some literals.
-    >r node-in-d length \ drop <repetition>
-    r> [ literalize ] map append >quotation ;
-
-: inline-literals ( node literals -- node )
-    #! Make #shuffle -> #push -> #return -> successor
-    dupd literal-quot f splice-quot ;
-
-: evaluate-predicate ( #call -- ? )
-    dup node-param "predicating" word-prop >r
-    node-class-first r> class< ;
-
-: optimize-predicate ( #call -- node )
-    #! If the predicate is followed by a branch we fold it
-    #! immediately
-    dup evaluate-predicate swap
-    dup node-successor #if? [
-        dup drop-inputs >r
-        node-successor swap 0 1 ? fold-branch
-        r> [ set-node-successor ] keep
-    ] [
-        swap 1array inline-literals
-    ] if ;
-
-: optimizer-hooks ( node -- conditions )
-    node-param "optimizer-hooks" word-prop ;
-
-: optimizer-hook ( node -- pair/f )
-    dup optimizer-hooks [ first call ] find 2nip ;
-
-: optimize-hook ( node -- )
-    dup optimizer-hook second call ;
-
-: define-optimizers ( word optimizers -- )
-    "optimizer-hooks" set-word-prop ;
-
-: flush-eval? ( #call -- ? )
-    dup node-param "flushable" word-prop [
-        node-out-d [ unused? ] all?
-    ] [
-        drop f
-    ] if ;
-
-: flush-eval ( #call -- node )
-    dup node-param +inlined+ depends-on
-    dup node-out-d length f <repetition> inline-literals ;
-
-: partial-eval? ( #call -- ? )
-    dup node-param "foldable" word-prop [
-        dup node-in-d [ node-literal? ] with all?
-    ] [
-        drop f
-    ] if ;
-
-: literal-in-d ( #call -- inputs )
-    dup node-in-d [ node-literal ] with map ;
-
-: partial-eval ( #call -- node )
-    dup node-param +inlined+ depends-on
-    dup literal-in-d over node-param 1quotation
-    [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
-
-: define-identities ( words identities -- )
-    [ "identities" set-word-prop ] curry each ;
-
-: find-identity ( node -- quot )
-    [ node-param "identities" word-prop ] keep
-    [ swap first in-d-match? ] curry find
-    nip dup [ second ] when ;
-
-: apply-identities ( node -- node/f )
-    dup find-identity dup [ f splice-quot ] [ 2drop f ] if ;
-
-: optimistic-inline? ( #call -- ? )
-    dup node-param "specializer" word-prop dup [
-        >r node-input-classes r> specialized-length tail*
-        [ types length 1 = ] all?
-    ] [
-        2drop f
-    ] if ;
-
-: splice-word-def ( #call word -- node )
-    dup +inlined+ depends-on
-    dup word-def swap 1array splice-quot ;
-
-: optimistic-inline ( #call -- node )
-    dup node-param over node-history memq? [
-        drop t
-    ] [
-        dup node-param splice-word-def
-    ] if ;
-
-: method-body-inline? ( #call -- ? )
-    node-param dup method-body?
-    [ flat-length 10 <= ] [ drop f ] if ;
-
-M: #call optimize-node*
-    {
-        { [ dup flush-eval? ] [ flush-eval ] }
-        { [ dup partial-eval? ] [ partial-eval ] }
-        { [ dup find-identity ] [ apply-identities ] }
-        { [ dup optimizer-hook ] [ optimize-hook ] }
-        { [ dup optimize-predicate? ] [ optimize-predicate ] }
-        { [ dup optimistic-inline? ] [ optimistic-inline ] }
-        { [ dup method-body-inline? ] [ optimistic-inline ] }
-        { [ t ] [ inline-method ] }
-    } cond dup not ;
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays generic assocs inference inference.class
+inference.dataflow inference.backend inference.state io kernel
+math namespaces sequences vectors words quotations hashtables
+combinators classes generic.math continuations optimizer.def-use
+optimizer.backend generic.standard optimizer.specializers
+optimizer.def-use optimizer.pattern-match generic.standard
+optimizer.control kernel.private ;
+IN: optimizer.inlining
+
+: remember-inlining ( node history -- )
+    [ swap set-node-history ] curry each-node ;
+
+: inlining-quot ( node quot -- node )
+    over node-in-d dataflow-with
+    dup rot infer-classes/node ;
+
+: splice-quot ( #call quot history -- node )
+    #! Must add history *before* splicing in, otherwise
+    #! the rest of the IR will also remember the history
+    pick node-history append
+    >r dupd inlining-quot dup r> remember-inlining
+    tuck splice-node ;
+
+! A heuristic to avoid excessive inlining
+DEFER: (flat-length)
+
+: word-flat-length ( word -- n )
+    {
+        ! heuristic: { ... } declare comes up in method bodies
+        ! and we don't care about it
+        { [ dup \ declare eq? ] [ drop -2 ] }
+        ! recursive
+        { [ dup get ] [ drop 1 ] }
+        ! not inline
+        { [ dup inline? not ] [ drop 1 ] }
+        ! inline
+        { [ t ] [ dup dup set word-def (flat-length) ] }
+    } cond ;
+
+: (flat-length) ( seq -- n )
+    [
+        {
+            { [ dup quotation? ] [ (flat-length) 1+ ] }
+            { [ dup array? ] [ (flat-length) ] }
+            { [ dup word? ] [ word-flat-length ] }
+            { [ t ] [ drop 1 ] }
+        } cond
+    ] map sum ;
+
+: flat-length ( seq -- n )
+    [ word-def (flat-length) ] with-scope ;
+
+! Single dispatch method inlining optimization
+: specific-method ( class word -- class ) order min-class ;
+
+: node-class# ( node n -- class )
+    over node-in-d <reversed> ?nth node-class ;
+
+: dispatching-class ( node word -- class )
+    [ dispatch# node-class# ] keep specific-method ;
+
+: inline-standard-method ( node word -- node )
+    2dup dispatching-class dup [
+        over +inlined+ depends-on
+        swap method 1quotation f splice-quot
+    ] [
+        3drop t
+    ] if ;
+
+! Partial dispatch of math-generic words
+: math-both-known? ( word left right -- ? )
+    math-class-max swap specific-method ;
+
+: inline-math-method ( #call word -- node )
+    over node-input-classes first2 3dup math-both-known?
+    [ math-method f splice-quot ] [ 2drop 2drop t ] if ;
+
+: inline-method ( #call -- node )
+    dup node-param {
+        { [ dup standard-generic? ] [ inline-standard-method ] }
+        { [ dup math-generic? ] [ inline-math-method ] }
+        { [ t ] [ 2drop t ] }
+    } cond ;
+
+! Resolve type checks at compile time where possible
+: comparable? ( actual testing -- ? )
+    #! If actual is a subset of testing or if the two classes
+    #! are disjoint, return t.
+    2dup class< >r classes-intersect? not r> or ;
+
+: optimize-predicate? ( #call -- ? )
+    dup node-param "predicating" word-prop dup [
+        >r node-class-first r> comparable?
+    ] [
+        2drop f
+    ] if ;
+
+: literal-quot ( node literals -- quot )
+    #! Outputs a quotation which drops the node's inputs, and
+    #! pushes some literals.
+    >r node-in-d length \ drop <repetition>
+    r> [ literalize ] map append >quotation ;
+
+: inline-literals ( node literals -- node )
+    #! Make #shuffle -> #push -> #return -> successor
+    dupd literal-quot f splice-quot ;
+
+: evaluate-predicate ( #call -- ? )
+    dup node-param "predicating" word-prop >r
+    node-class-first r> class< ;
+
+: optimize-predicate ( #call -- node )
+    #! If the predicate is followed by a branch we fold it
+    #! immediately
+    dup evaluate-predicate swap
+    dup node-successor #if? [
+        dup drop-inputs >r
+        node-successor swap 0 1 ? fold-branch
+        r> [ set-node-successor ] keep
+    ] [
+        swap 1array inline-literals
+    ] if ;
+
+: optimizer-hooks ( node -- conditions )
+    node-param "optimizer-hooks" word-prop ;
+
+: optimizer-hook ( node -- pair/f )
+    dup optimizer-hooks [ first call ] find 2nip ;
+
+: optimize-hook ( node -- )
+    dup optimizer-hook second call ;
+
+: define-optimizers ( word optimizers -- )
+    "optimizer-hooks" set-word-prop ;
+
+: flush-eval? ( #call -- ? )
+    dup node-param "flushable" word-prop [
+        node-out-d [ unused? ] all?
+    ] [
+        drop f
+    ] if ;
+
+: flush-eval ( #call -- node )
+    dup node-param +inlined+ depends-on
+    dup node-out-d length f <repetition> inline-literals ;
+
+: partial-eval? ( #call -- ? )
+    dup node-param "foldable" word-prop [
+        dup node-in-d [ node-literal? ] with all?
+    ] [
+        drop f
+    ] if ;
+
+: literal-in-d ( #call -- inputs )
+    dup node-in-d [ node-literal ] with map ;
+
+: partial-eval ( #call -- node )
+    dup node-param +inlined+ depends-on
+    dup literal-in-d over node-param 1quotation
+    [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
+
+: define-identities ( words identities -- )
+    [ "identities" set-word-prop ] curry each ;
+
+: find-identity ( node -- quot )
+    [ node-param "identities" word-prop ] keep
+    [ swap first in-d-match? ] curry find
+    nip dup [ second ] when ;
+
+: apply-identities ( node -- node/f )
+    dup find-identity dup [ f splice-quot ] [ 2drop f ] if ;
+
+: optimistic-inline? ( #call -- ? )
+    dup node-param "specializer" word-prop dup [
+        >r node-input-classes r> specialized-length tail*
+        [ types length 1 = ] all?
+    ] [
+        2drop f
+    ] if ;
+
+: splice-word-def ( #call word -- node )
+    dup +inlined+ depends-on
+    dup word-def swap 1array splice-quot ;
+
+: optimistic-inline ( #call -- node )
+    dup node-param over node-history memq? [
+        drop t
+    ] [
+        dup node-param splice-word-def
+    ] if ;
+
+: method-body-inline? ( #call -- ? )
+    node-param dup method-body?
+    [ flat-length 10 <= ] [ drop f ] if ;
+
+M: #call optimize-node*
+    {
+        { [ dup flush-eval? ] [ flush-eval ] }
+        { [ dup partial-eval? ] [ partial-eval ] }
+        { [ dup find-identity ] [ apply-identities ] }
+        { [ dup optimizer-hook ] [ optimize-hook ] }
+        { [ dup optimize-predicate? ] [ optimize-predicate ] }
+        { [ dup optimistic-inline? ] [ optimistic-inline ] }
+        { [ dup method-body-inline? ] [ optimistic-inline ] }
+        { [ t ] [ inline-method ] }
+    } cond dup not ;
diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor
index 5116d66715..3abccecc7f 100755
--- a/core/optimizer/optimizer-tests.factor
+++ b/core/optimizer/optimizer-tests.factor
@@ -1,378 +1,378 @@
-USING: arrays compiler.units generic hashtables inference kernel
-kernel.private math optimizer prettyprint sequences sbufs
-strings tools.test vectors words sequences.private quotations
-optimizer.backend classes inference.dataflow tuples.private
-continuations growable optimizer.inlining namespaces hints ;
-IN: optimizer.tests
-
-[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
-    H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union*
-] unit-test
-
-[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [
-    H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union*
-] unit-test
-
-! Test method inlining
-[ f ] [ fixnum { } min-class ] unit-test
-
-[ string ] [
-    \ string
-    [ integer string array reversed sbuf
-    slice vector quotation ]
-    sort-classes min-class
-] unit-test
-
-[ fixnum ] [
-    \ fixnum
-    [ fixnum integer object ]
-    sort-classes min-class
-] unit-test
-
-[ integer ] [
-    \ fixnum
-    [ integer float object ]
-    sort-classes min-class
-] unit-test
-
-[ object ] [
-    \ word
-    [ integer float object ]
-    sort-classes min-class
-] unit-test
-
-[ reversed ] [
-    \ reversed
-    [ integer reversed slice ]
-    sort-classes min-class
-] unit-test
-
-GENERIC: xyz ( obj -- obj )
-M: array xyz xyz ;
-
-[ t ] [ \ xyz compiled? ] unit-test
-
-! Test predicate inlining
-: pred-test-1
-    dup fixnum? [
-        dup integer? [ "integer" ] [ "nope" ] if
-    ] [
-        "not a fixnum"
-    ] if ;
-
-[ 1 "integer" ] [ 1 pred-test-1 ] unit-test
-
-TUPLE: pred-test ;
-
-: pred-test-2
-    dup tuple? [
-        dup pred-test? [ "pred-test" ] [ "nope" ] if
-    ] [
-        "not a tuple"
-    ] if ;
-
-[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test
-
-: pred-test-3
-    dup pred-test? [
-        dup tuple? [ "pred-test" ] [ "nope" ] if
-    ] [
-        "not a tuple"
-    ] if ;
-
-[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test
-
-: inline-test
-    "nom" = ;
-
-[ t ] [ "nom" inline-test ] unit-test
-[ f ] [ "shayin" inline-test ] unit-test
-[ f ] [ 3 inline-test ] unit-test
-
-: fixnum-declarations >fixnum 24 shift 1234 bitxor ;
-
-[ ] [ 1000000 fixnum-declarations . ] unit-test
-
-! regression
-
-: literal-not-branch 0 not [ ] [ ] if ;
-
-[ ] [ literal-not-branch ] unit-test
-
-! regression
-
-: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline
-: bad-kill-2 bad-kill-1 drop ;
-
-[ 3 ] [ t bad-kill-2 ] unit-test
-
-! regression
-: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline
-: the-test ( -- x y ) 2 dup (the-test) ;
-
-[ 2 0 ] [ the-test ] unit-test
-
-! regression
-: (double-recursion) ( start end -- )
-    < [
-        6 1 (double-recursion)
-        3 2 (double-recursion)
-    ] when ; inline
-
-: double-recursion 0 2 (double-recursion) ;
-
-[ ] [ double-recursion ] unit-test
-
-! regression
-: double-label-1 ( a b c -- d )
-    [ f double-label-1 ] [ swap nth-unsafe ] if ; inline
-
-: double-label-2 ( a -- b )
-    dup array? [ ] [ ] if 0 t double-label-1 ;
-
-[ 0 ] [ 10 double-label-2 ] unit-test
-
-! regression
-GENERIC: void-generic ( obj -- * )
-: breakage "hi" void-generic ;
-[ t ] [ \ breakage compiled? ] unit-test
-[ breakage ] must-fail
-
-! regression
-: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline
-: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline
-: test-2 ( -- ) 5 test-1 ;
-
-[ f ] [ f test-2 ] unit-test
-
-: branch-fold-regression-0 ( m -- n )
-    t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
-
-: branch-fold-regression-1 ( -- m )
-    10 branch-fold-regression-0 ;
-
-[ 10 ] [ branch-fold-regression-1 ] unit-test
-
-! another regression
-: constant-branch-fold-0 "hey" ; foldable
-: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline
-[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test
-
-! another regression
-: foo f ;
-: bar foo 4 4 = and ;
-[ f ] [ bar ] unit-test
-
-! ensure identities are working in some form
-[ t ] [
-    [ { number } declare 0 + ] dataflow optimize
-    [ #push? ] node-exists? not
-] unit-test
-
-! compiling <tuple> with a non-literal class failed
-: <tuple>-regression <tuple> ;
-
-[ t ] [ \ <tuple>-regression compiled? ] unit-test
-
-GENERIC: foozul ( a -- b )
-M: reversed foozul ;
-M: integer foozul ;
-M: slice foozul ;
-
-[ reversed ] [ reversed \ foozul specific-method ] unit-test
-
-! regression
-: constant-fold-2 f ; foldable
-: constant-fold-3 4 ; foldable
-
-[ f t ] [
-    [ constant-fold-2 constant-fold-3 4 = ] compile-call
-] unit-test
-
-: constant-fold-4 f ; foldable
-: constant-fold-5 f ; foldable
-
-[ f ] [
-    [ constant-fold-4 constant-fold-5 or ] compile-call
-] unit-test
-
-[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test
-[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test
-
-[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test
-[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test
-[ 0 ] [ 5 [ dup - ] compile-call ] unit-test
-
-[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test
-[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test
-[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test
-[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test
-[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test
-[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test
-
-[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test
-[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test
-
-[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test
-[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test
-[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test
-[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test
-[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test
-
-[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test
-[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test
-[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test
-[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test
-[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test
-
-[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test
-[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test
-[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test
-[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test
-[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test
-
-[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test
-[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test
-
-[ f ] [ 5 [ dup < ] compile-call ] unit-test
-[ t ] [ 5 [ dup <= ] compile-call ] unit-test
-[ f ] [ 5 [ dup > ] compile-call ] unit-test
-[ t ] [ 5 [ dup >= ] compile-call ] unit-test
-
-[ t ] [ 5 [ dup eq? ] compile-call ] unit-test
-[ t ] [ 5 [ dup = ] compile-call ] unit-test
-[ t ] [ 5 [ dup number= ] compile-call ] unit-test
-[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test
-
-GENERIC: detect-number ( obj -- obj )
-M: number detect-number ;
-
-[ 10 f [ <array> 0 + detect-number ] compile-call ] must-fail
-
-! Regression
-[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test
-
-! Regression
-USE: sorting
-USE: sorting.private
-
-: old-binsearch ( elt quot seq -- elt quot i )
-    dup length 1 <= [
-        slice-from
-    ] [
-        [ midpoint swap call ] 3keep roll dup zero?
-        [ drop dup slice-from swap midpoint@ + ]
-        [ partition old-binsearch ] if
-    ] if ; inline
-
-[ 10 ] [
-    10 20 >vector <flat-slice>
-    [ [ - ] swap old-binsearch ] compile-call 2nip
-] unit-test
-
-! Regression
-TUPLE: silly-tuple a b ;
-
-[ 1 2 { silly-tuple-a silly-tuple-b } ] [
-    T{ silly-tuple f 1 2 }
-    [
-        { silly-tuple-a silly-tuple-b } [ get-slots ] keep
-    ] compile-call
-] unit-test
-
-! Regression
-: empty-compound ;
-
-: node-successor-f-bug ( x -- * )
-    [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
-
-[ t ] [ \ node-successor-f-bug compiled? ] unit-test
-
-[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
-
-[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
-
-! Make sure we have sane heuristics
-: should-inline? method method-word flat-length 10 <= ;
-
-[ t ] [ \ fixnum \ shift should-inline? ] unit-test
-[ f ] [ \ array \ equal? should-inline? ] unit-test
-[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test
-[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test
-[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test
-[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test
-
-! Regression
-: lift-throw-tail-regression
-    dup integer? [ "an integer" ] [
-        dup string? [ "a string" ] [
-            "error" throw
-        ] if
-    ] if ;
-
-[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test
-[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
-[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
-
-: lift-loop-tail-test-1 ( a quot -- )
-    over even? [
-        [ >r 3 - r> call ] keep lift-loop-tail-test-1
-    ] [
-        over 0 < [
-            2drop
-        ] [
-            [ >r 2 - r> call ] keep lift-loop-tail-test-1
-        ] if
-    ] if ; inline
-
-: lift-loop-tail-test-2
-    10 [ ] lift-loop-tail-test-1 1 2 3 ;
-
-[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
-
-! Make sure we don't lose
-GENERIC: generic-inline-test ( x -- y )
-M: integer generic-inline-test ;
-
-: generic-inline-test-1
-    1
-    generic-inline-test
-    generic-inline-test
-    generic-inline-test
-    generic-inline-test
-    generic-inline-test
-    generic-inline-test
-    generic-inline-test
-    generic-inline-test
-    generic-inline-test
-    generic-inline-test ;
-
-[ { t f } ] [
-    \ generic-inline-test-1 word-def dataflow
-    [ optimize-1 , optimize-1 , drop ] { } make
-] unit-test
-
-! Forgot a recursive inline check
-: recursive-inline-hang ( a -- a )
-    dup array? [ recursive-inline-hang ] when ;
-
-HINTS: recursive-inline-hang array ;
-
-: recursive-inline-hang-1
-    { } recursive-inline-hang ;
-
-[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test
-
-DEFER: recursive-inline-hang-3
-
-: recursive-inline-hang-2 ( a -- a )
-    dup array? [ recursive-inline-hang-3 ] when ;
-
-HINTS: recursive-inline-hang-2 array ;
-
-: recursive-inline-hang-3 ( a -- a )
-    dup array? [ recursive-inline-hang-2 ] when ;
-
-HINTS: recursive-inline-hang-3 array ;
-
-
+USING: arrays compiler.units generic hashtables inference kernel
+kernel.private math optimizer prettyprint sequences sbufs
+strings tools.test vectors words sequences.private quotations
+optimizer.backend classes inference.dataflow tuples.private
+continuations growable optimizer.inlining namespaces hints ;
+IN: optimizer.tests
+
+[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
+    H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union*
+] unit-test
+
+[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [
+    H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union*
+] unit-test
+
+! Test method inlining
+[ f ] [ fixnum { } min-class ] unit-test
+
+[ string ] [
+    \ string
+    [ integer string array reversed sbuf
+    slice vector quotation ]
+    sort-classes min-class
+] unit-test
+
+[ fixnum ] [
+    \ fixnum
+    [ fixnum integer object ]
+    sort-classes min-class
+] unit-test
+
+[ integer ] [
+    \ fixnum
+    [ integer float object ]
+    sort-classes min-class
+] unit-test
+
+[ object ] [
+    \ word
+    [ integer float object ]
+    sort-classes min-class
+] unit-test
+
+[ reversed ] [
+    \ reversed
+    [ integer reversed slice ]
+    sort-classes min-class
+] unit-test
+
+GENERIC: xyz ( obj -- obj )
+M: array xyz xyz ;
+
+[ t ] [ \ xyz compiled? ] unit-test
+
+! Test predicate inlining
+: pred-test-1
+    dup fixnum? [
+        dup integer? [ "integer" ] [ "nope" ] if
+    ] [
+        "not a fixnum"
+    ] if ;
+
+[ 1 "integer" ] [ 1 pred-test-1 ] unit-test
+
+TUPLE: pred-test ;
+
+: pred-test-2
+    dup tuple? [
+        dup pred-test? [ "pred-test" ] [ "nope" ] if
+    ] [
+        "not a tuple"
+    ] if ;
+
+[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test
+
+: pred-test-3
+    dup pred-test? [
+        dup tuple? [ "pred-test" ] [ "nope" ] if
+    ] [
+        "not a tuple"
+    ] if ;
+
+[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test
+
+: inline-test
+    "nom" = ;
+
+[ t ] [ "nom" inline-test ] unit-test
+[ f ] [ "shayin" inline-test ] unit-test
+[ f ] [ 3 inline-test ] unit-test
+
+: fixnum-declarations >fixnum 24 shift 1234 bitxor ;
+
+[ ] [ 1000000 fixnum-declarations . ] unit-test
+
+! regression
+
+: literal-not-branch 0 not [ ] [ ] if ;
+
+[ ] [ literal-not-branch ] unit-test
+
+! regression
+
+: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline
+: bad-kill-2 bad-kill-1 drop ;
+
+[ 3 ] [ t bad-kill-2 ] unit-test
+
+! regression
+: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline
+: the-test ( -- x y ) 2 dup (the-test) ;
+
+[ 2 0 ] [ the-test ] unit-test
+
+! regression
+: (double-recursion) ( start end -- )
+    < [
+        6 1 (double-recursion)
+        3 2 (double-recursion)
+    ] when ; inline
+
+: double-recursion 0 2 (double-recursion) ;
+
+[ ] [ double-recursion ] unit-test
+
+! regression
+: double-label-1 ( a b c -- d )
+    [ f double-label-1 ] [ swap nth-unsafe ] if ; inline
+
+: double-label-2 ( a -- b )
+    dup array? [ ] [ ] if 0 t double-label-1 ;
+
+[ 0 ] [ 10 double-label-2 ] unit-test
+
+! regression
+GENERIC: void-generic ( obj -- * )
+: breakage "hi" void-generic ;
+[ t ] [ \ breakage compiled? ] unit-test
+[ breakage ] must-fail
+
+! regression
+: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline
+: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline
+: test-2 ( -- ) 5 test-1 ;
+
+[ f ] [ f test-2 ] unit-test
+
+: branch-fold-regression-0 ( m -- n )
+    t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
+
+: branch-fold-regression-1 ( -- m )
+    10 branch-fold-regression-0 ;
+
+[ 10 ] [ branch-fold-regression-1 ] unit-test
+
+! another regression
+: constant-branch-fold-0 "hey" ; foldable
+: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline
+[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test
+
+! another regression
+: foo f ;
+: bar foo 4 4 = and ;
+[ f ] [ bar ] unit-test
+
+! ensure identities are working in some form
+[ t ] [
+    [ { number } declare 0 + ] dataflow optimize
+    [ #push? ] node-exists? not
+] unit-test
+
+! compiling <tuple> with a non-literal class failed
+: <tuple>-regression <tuple> ;
+
+[ t ] [ \ <tuple>-regression compiled? ] unit-test
+
+GENERIC: foozul ( a -- b )
+M: reversed foozul ;
+M: integer foozul ;
+M: slice foozul ;
+
+[ reversed ] [ reversed \ foozul specific-method ] unit-test
+
+! regression
+: constant-fold-2 f ; foldable
+: constant-fold-3 4 ; foldable
+
+[ f t ] [
+    [ constant-fold-2 constant-fold-3 4 = ] compile-call
+] unit-test
+
+: constant-fold-4 f ; foldable
+: constant-fold-5 f ; foldable
+
+[ f ] [
+    [ constant-fold-4 constant-fold-5 or ] compile-call
+] unit-test
+
+[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test
+[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test
+
+[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test
+[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test
+[ 0 ] [ 5 [ dup - ] compile-call ] unit-test
+
+[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test
+[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test
+[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test
+[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test
+[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test
+[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test
+
+[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test
+[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test
+
+[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test
+[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test
+[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test
+[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test
+[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test
+
+[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test
+[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test
+[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test
+[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test
+[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test
+
+[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test
+[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test
+[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test
+[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test
+[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test
+
+[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test
+[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test
+
+[ f ] [ 5 [ dup < ] compile-call ] unit-test
+[ t ] [ 5 [ dup <= ] compile-call ] unit-test
+[ f ] [ 5 [ dup > ] compile-call ] unit-test
+[ t ] [ 5 [ dup >= ] compile-call ] unit-test
+
+[ t ] [ 5 [ dup eq? ] compile-call ] unit-test
+[ t ] [ 5 [ dup = ] compile-call ] unit-test
+[ t ] [ 5 [ dup number= ] compile-call ] unit-test
+[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test
+
+GENERIC: detect-number ( obj -- obj )
+M: number detect-number ;
+
+[ 10 f [ <array> 0 + detect-number ] compile-call ] must-fail
+
+! Regression
+[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test
+
+! Regression
+USE: sorting
+USE: sorting.private
+
+: old-binsearch ( elt quot seq -- elt quot i )
+    dup length 1 <= [
+        slice-from
+    ] [
+        [ midpoint swap call ] 3keep roll dup zero?
+        [ drop dup slice-from swap midpoint@ + ]
+        [ partition old-binsearch ] if
+    ] if ; inline
+
+[ 10 ] [
+    10 20 >vector <flat-slice>
+    [ [ - ] swap old-binsearch ] compile-call 2nip
+] unit-test
+
+! Regression
+TUPLE: silly-tuple a b ;
+
+[ 1 2 { silly-tuple-a silly-tuple-b } ] [
+    T{ silly-tuple f 1 2 }
+    [
+        { silly-tuple-a silly-tuple-b } [ get-slots ] keep
+    ] compile-call
+] unit-test
+
+! Regression
+: empty-compound ;
+
+: node-successor-f-bug ( x -- * )
+    [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
+
+[ t ] [ \ node-successor-f-bug compiled? ] unit-test
+
+[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
+
+[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
+
+! Make sure we have sane heuristics
+: should-inline? method flat-length 10 <= ;
+
+[ t ] [ \ fixnum \ shift should-inline? ] unit-test
+[ f ] [ \ array \ equal? should-inline? ] unit-test
+[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test
+[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test
+[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test
+[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test
+
+! Regression
+: lift-throw-tail-regression
+    dup integer? [ "an integer" ] [
+        dup string? [ "a string" ] [
+            "error" throw
+        ] if
+    ] if ;
+
+[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test
+[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
+[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
+
+: lift-loop-tail-test-1 ( a quot -- )
+    over even? [
+        [ >r 3 - r> call ] keep lift-loop-tail-test-1
+    ] [
+        over 0 < [
+            2drop
+        ] [
+            [ >r 2 - r> call ] keep lift-loop-tail-test-1
+        ] if
+    ] if ; inline
+
+: lift-loop-tail-test-2
+    10 [ ] lift-loop-tail-test-1 1 2 3 ;
+
+[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
+
+! Make sure we don't lose
+GENERIC: generic-inline-test ( x -- y )
+M: integer generic-inline-test ;
+
+: generic-inline-test-1
+    1
+    generic-inline-test
+    generic-inline-test
+    generic-inline-test
+    generic-inline-test
+    generic-inline-test
+    generic-inline-test
+    generic-inline-test
+    generic-inline-test
+    generic-inline-test
+    generic-inline-test ;
+
+[ { t f } ] [
+    \ generic-inline-test-1 word-def dataflow
+    [ optimize-1 , optimize-1 , drop ] { } make
+] unit-test
+
+! Forgot a recursive inline check
+: recursive-inline-hang ( a -- a )
+    dup array? [ recursive-inline-hang ] when ;
+
+HINTS: recursive-inline-hang array ;
+
+: recursive-inline-hang-1
+    { } recursive-inline-hang ;
+
+[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test
+
+DEFER: recursive-inline-hang-3
+
+: recursive-inline-hang-2 ( a -- a )
+    dup array? [ recursive-inline-hang-3 ] when ;
+
+HINTS: recursive-inline-hang-2 array ;
+
+: recursive-inline-hang-3 ( a -- a )
+    dup array? [ recursive-inline-hang-2 ] when ;
+
+HINTS: recursive-inline-hang-3 array ;
+
+
diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor
index 2efc9b4e67..6cb03e4199 100755
--- a/core/prettyprint/prettyprint.factor
+++ b/core/prettyprint/prettyprint.factor
@@ -175,10 +175,10 @@ M: method-spec synopsis*
     dup definer. [ pprint-word ] each ;
 
 M: method-body synopsis*
-    dup definer.
-    "method" word-prop dup
-    method-specializer pprint*
-    method-generic pprint* ;
+    dup dup
+    definer.
+    "method-class" word-prop pprint*
+    "method-generic" word-prop pprint* ;
 
 M: mixin-instance synopsis*
     dup definer.
@@ -269,7 +269,7 @@ M: builtin-class see-class*
 
 : see-implementors ( class -- seq )
     dup implementors
-    [ method method-word ] with map
+    [ method ] with map
     natural-sort ;
 
 : see-class ( class -- )
@@ -280,9 +280,7 @@ M: builtin-class see-class*
     ] when drop ;
 
 : see-methods ( generic -- seq )
-    "methods" word-prop
-    [ nip method-word ] { } assoc>map
-    natural-sort ;
+    "methods" word-prop values natural-sort ;
 
 M: word see
     dup see-class
diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor
index 720a1ef645..1a3fecc3fb 100755
--- a/core/vocabs/vocabs.factor
+++ b/core/vocabs/vocabs.factor
@@ -55,6 +55,8 @@ M: f vocab-docs-loaded? ;
 
 M: f set-vocab-docs-loaded? 2drop ;
 
+M: f vocab-help ;
+
 : create-vocab ( name -- vocab )
     dictionary get [ <vocab> ] cache ;
 
diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor
index 97ce86d38a..06f3c7a782 100755
--- a/core/words/words-tests.factor
+++ b/core/words/words-tests.factor
@@ -141,7 +141,7 @@ SYMBOL: quot-uses-b
 
 [ { + } ] [ \ quot-uses-b uses ] unit-test
 
-[ "IN: words.tests : undef-test ; << undef-test >>" eval ]
+[ "IN: words.tests FORGET: undef-test : undef-test ; << undef-test >>" eval ]
 [ [ undefined? ] is? ] must-fail-with
 
 [ ] [
diff --git a/core/words/words.factor b/core/words/words.factor
index e8b3fd9781..ce69c1ff2e 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -68,7 +68,7 @@ SYMBOL: bootstrapping?
 : crossref? ( word -- ? )
     {
         { [ dup "forgotten" word-prop ] [ f ] }
-        { [ dup "method" word-prop ] [ t ] }
+        { [ dup "method-def" word-prop ] [ t ] }
         { [ dup word-vocabulary ] [ t ] }
         { [ t ] [ f ] }
     } cond nip ;
diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor
index 182f04a367..88095759e6 100755
--- a/extra/assocs/lib/lib.factor
+++ b/extra/assocs/lib/lib.factor
@@ -16,13 +16,16 @@ IN: assocs.lib
 : at-default ( key assoc -- value/key )
     dupd at [ nip ] when* ;
 
+: replace-at ( assoc value key -- assoc )
+    >r >r dup r> 1vector r> rot set-at ;
+
 : insert-at ( value key assoc -- )
     [ ?push ] change-at ;
 
-: peek-at* ( key assoc -- obj ? )
-    at* dup [ >r peek r> ] when ;
+: peek-at* ( assoc key -- obj ? )
+    swap at* dup [ >r peek r> ] when ;
 
-: peek-at ( key assoc -- obj )
+: peek-at ( assoc key -- obj )
     peek-at* drop ;
 
 : >multi-assoc ( assoc -- new-assoc )
diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor
index bd13455357..231c6edf50 100755
--- a/extra/benchmark/benchmark.factor
+++ b/extra/benchmark/benchmark.factor
@@ -21,7 +21,7 @@ IN: benchmark
         ] with-row
         [
             [
-                swap [ ($vocab-link) ] with-cell
+                swap [ dup ($vocab-link) ] with-cell
                 first2 pprint-cell pprint-cell
             ] with-row
         ] assoc-each
diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor
index c739bb787c..4927776575 100755
--- a/extra/benchmark/sockets/sockets.factor
+++ b/extra/benchmark/sockets/sockets.factor
@@ -1,65 +1,58 @@
-USING: io.sockets io kernel math threads
-debugger tools.time prettyprint concurrency.count-downs
-namespaces arrays continuations ;
-IN: benchmark.sockets
-
-SYMBOL: counter
-
-: number-of-requests 1 ;
-
-: server-addr "127.0.0.1" 7777 <inet4> ;
-
-: server-loop ( server -- )
-    dup accept [
-        [
-            read1 CHAR: x = [
-                "server" get dispose
-            ] [
-                number-of-requests
-                [ read1 write1 flush ] times
-                counter get count-down
-            ] if
-        ] with-stream
-    ] curry "Client handler" spawn drop server-loop ;
-
-: simple-server ( -- )
-    [
-        server-addr <server> dup "server" set [
-            server-loop
-        ] with-disposal
-    ] ignore-errors ;
-
-: simple-client ( -- )
-    server-addr <client> [
-        CHAR: b write1 flush
-        number-of-requests
-        [ CHAR: a dup write1 flush read1 assert= ] times
-        counter get count-down
-    ] with-stream ;
-
-: stop-server ( -- )
-    server-addr <client> [
-        CHAR: x write1
-    ] with-stream ;
-
-: clients ( n -- )
-    dup pprint " clients: " write [
-        dup 2 * <count-down> counter set
-        [ simple-server ] "Simple server" spawn drop
-        yield yield
-        [ [ simple-client ] "Simple client" spawn drop ] times
-        counter get await
-        stop-server
-        yield yield
-    ] time ;
-
-: socket-benchmarks
-    10 clients
-    20 clients
-    40 clients ;
-    ! 80 clients
-    ! 160 clients
-    ! 320 clients
-    ! 640 clients ;
-
-MAIN: socket-benchmarks
+USING: io.sockets io kernel math threads
+debugger tools.time prettyprint concurrency.count-downs
+namespaces arrays continuations ;
+IN: benchmark.sockets
+
+SYMBOL: counter
+
+: number-of-requests 1 ;
+
+: server-addr "127.0.0.1" 7777 <inet4> ;
+
+: server-loop ( server -- )
+    dup accept [
+        [
+            read1 CHAR: x = [
+                "server" get dispose
+            ] [
+                number-of-requests
+                [ read1 write1 flush ] times
+                counter get count-down
+            ] if
+        ] with-stream
+    ] curry "Client handler" spawn drop server-loop ;
+
+: simple-server ( -- )
+    [
+        server-addr <server> dup "server" set [
+            server-loop
+        ] with-disposal
+    ] ignore-errors ;
+
+: simple-client ( -- )
+    server-addr <client> [
+        CHAR: b write1 flush
+        number-of-requests
+        [ CHAR: a dup write1 flush read1 assert= ] times
+        counter get count-down
+    ] with-stream ;
+
+: stop-server ( -- )
+    server-addr <client> [
+        CHAR: x write1
+    ] with-stream ;
+
+: clients ( n -- )
+    dup pprint " clients: " write [
+        dup 2 * <count-down> counter set
+        [ simple-server ] "Simple server" spawn drop
+        yield yield
+        [ [ simple-client ] "Simple client" spawn drop ] times
+        counter get await
+        stop-server
+        yield yield
+    ] time ;
+
+: socket-benchmarks ;
+
+MAIN: socket-benchmarks
diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor
index 084f30a103..3c0b464dbf 100755
--- a/extra/bootstrap/image/upload/upload.factor
+++ b/extra/bootstrap/image/upload/upload.factor
@@ -8,7 +8,7 @@ SYMBOL: upload-images-destination
 
 : destination ( -- dest )
   upload-images-destination get
-  "slava@/var/www/factorcode.org/newsite/images/latest/"
+  "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
   or ;
 
 : checksums "checksums.txt" temp-file ;
diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor
index 8c957108e1..63bce0a8c3 100755
--- a/extra/db/sqlite/ffi/ffi.factor
+++ b/extra/db/sqlite/ffi/ffi.factor
@@ -112,7 +112,7 @@ FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppSt
 FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
 FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
 FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;
-FUNCTION: int sqlite3_last_insert_rowid ( sqlite3* pStmt ) ;
+FUNCTION: sqlite3_int64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ;
 FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ;
 FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ;
 FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;
diff --git a/extra/db/sqlite/test.db b/extra/db/sqlite/test.db
new file mode 100644
index 0000000000..e483c47cea
Binary files /dev/null and b/extra/db/sqlite/test.db differ
diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor
index 10a7c115ac..32055ccedc 100755
--- a/extra/db/tuples/tuples.factor
+++ b/extra/db/tuples/tuples.factor
@@ -100,7 +100,7 @@ HOOK: insert-tuple* db ( tuple statement -- )
     db get db-delete-statements [ <delete-tuple-statement> ] cache
     [ bind-tuple ] keep execute-statement ;
 
-: select-tuples ( tuple -- tuple )
+: select-tuples ( tuple -- tuples )
     dup dup class <select-by-slots-statement> [
         [ bind-tuple ] keep query-tuples
     ] with-disposal ;
diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor
index 667805dcc3..654d096b26 100755
--- a/extra/delegate/delegate.factor
+++ b/extra/delegate/delegate.factor
@@ -39,7 +39,8 @@ M: tuple-class group-words
 : define-mimic ( group mimicker mimicked -- )
     >r >r group-words r> r> [
         pick "methods" word-prop at dup
-        [ method-def spin define-method ] [ 3drop ] if
+        [ "method-def" word-prop spin define-method ]
+        [ 3drop ] if
     ] 2curry each ; 
 
 : MIMIC:
diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor
index 590b3c82a7..3bbd2d03da 100755
--- a/extra/furnace/furnace.factor
+++ b/extra/furnace/furnace.factor
@@ -35,6 +35,17 @@ SYMBOL: current-action
 SYMBOL: validators-errored
 SYMBOL: validation-errors
 
+: build-url ( str query-params -- newstr )
+    [
+        over %
+        dup assoc-empty? [
+            2drop
+        ] [
+            CHAR: ? rot member? "&" "?" ? %
+            assoc>query %
+        ] if
+    ] "" make ;
+
 : action-link ( query action -- url )
     [
         "/responder/" %
diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor
old mode 100644
new mode 100755
index 5f1b027823..32e29db7db
--- a/extra/help/markup/markup.factor
+++ b/extra/help/markup/markup.factor
@@ -144,24 +144,36 @@ M: f print-element drop ;
 : $link ( element -- )
     first ($link) ;
 
-: ($subsection) ( object -- )
-    [ article-title ] keep >link write-object ;
+: ($long-link) ( object -- )
+    dup article-title swap >link write-link ;
 
-: $subsection ( element -- )
+: ($subsection) ( element quot -- )
     [
         subsection-style get [
             bullet get write bl
-            first ($subsection)
+            call
         ] with-style
-    ] ($block) ;
+    ] ($block) ; inline
 
-: ($vocab-link) ( vocab -- ) dup f >vocab-link write-link ;
+: $subsection ( element -- )
+    [ first ($long-link) ] ($subsection) ;
 
-: $vocab-link ( element -- ) first ($vocab-link) ;
+: ($vocab-link) ( text vocab -- ) f >vocab-link write-link ;
+
+: $vocab-subsection ( element -- )
+    [
+        first2 dup vocab-help dup [
+            2nip ($long-link)
+        ] [
+            drop ($vocab-link)
+        ] if
+    ] ($subsection) ;
+
+: $vocab-link ( element -- ) first dup ($vocab-link) ;
 
 : $vocabulary ( element -- )
     first word-vocabulary [
-        "Vocabulary" $heading nl ($vocab-link)
+        "Vocabulary" $heading nl dup ($vocab-link)
     ] when* ;
 
 : textual-list ( seq quot -- )
diff --git a/extra/http/basic-authentication/authors.txt b/extra/http/basic-authentication/authors.txt
deleted file mode 100644
index 44b06f94bc..0000000000
--- a/extra/http/basic-authentication/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Chris Double
diff --git a/extra/http/basic-authentication/basic-authentication-docs.factor b/extra/http/basic-authentication/basic-authentication-docs.factor
deleted file mode 100644
index 68d6e6bf1d..0000000000
--- a/extra/http/basic-authentication/basic-authentication-docs.factor
+++ /dev/null
@@ -1,69 +0,0 @@
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax crypto.sha2 ;
-IN: http.basic-authentication
-
-HELP: realms
-{ $description 
-   "A hashtable mapping a basic authentication realm (a string) "
-   "to either a quotation or a hashtable. The quotation has "
-   "stack effect ( username sha-256-string -- bool ). It "
-   "is expected to perform the user authentication when called." $nl
-   "If the realm maps to a hashtable then the hashtable should be a "
-   "mapping of usernames to sha-256 hashed passwords." $nl
-   "If the 'realms' variable does not exist in the current scope then "
-   "authentication will always fail." }
-{ $see-also add-realm with-basic-authentication } ;
-
-HELP: add-realm
-{ $values 
-  { "data" "a quotation or a hashtable" } { "name" "a string" } }
-{ $description 
-   "Adds the authentication data to the " { $link realms } ". 'data' can be "
-   "a quotation with stack effect ( username sha-256-string -- bool ) or "
-   "a hashtable mapping username strings to sha-256-string passwords." }
-{ $examples
-  { $code "H{ { \"admin\" \"...\" } { \"user\" \"...\" } } \"my-realm\" add-realm" }
-  { $code "[ \"...\" = swap \"admin\" = and ] \"my-realm\" add-realm" }
-}
-{ $see-also with-basic-authentication realms } ;
-
-HELP: with-basic-authentication
-{ $values 
-  { "realm" "a string" } { "quot" "a quotation with stack effect ( -- )" } }
-{ $description 
-   "Checks if the HTTP request has the correct authorisation headers "
-   "for basic authentication within the named realm. If the headers "
-   "are not present then a '401' HTTP response results from the "
-   "request, otherwise the quotation is called." }
-{ $examples
-{ $code "\"my-realm\" [\n  serving-html \"<html><body>Success!</body></html>\" write\n] with-basic-authentication" } }
-{ $see-also add-realm realms }
- ;
-
-ARTICLE: { "http-authentication" "basic-authentication" } "Basic Authentication"
-"The Basic Authentication system provides a simple browser based " 
-"authentication method to web applications. When the browser requests "
-"a resource protected with basic authentication the server responds with "
-"a '401' response code which means the user is unauthorized."
-$nl
-"When the browser receives this it prompts the user for a username and " 
-"password. This is sent back to the server in a special HTTP header. The "
-"server then checks this against its authentication information and either "
-"accepts or rejects the users request."
-$nl
-"Authentication is split up into " { $link realms } ". Each realm can have "
-"a different database of username and password information. A responder can "
-"require basic authentication by using the " { $link with-basic-authentication } " word."
-$nl
-"Username and password information can be maintained using " { $link realms } " and " { $link add-realm } "."
-$nl
-"All passwords on the server should be stored as sha-256 strings generated with the " { $link string>sha-256-string } " word."
-$nl
-"Note that Basic Authentication itself is insecure in that it "
-"sends the username and password as clear text (although it is "
-"base64 encoded this is not much help). To prevent eavesdropping "
-"it is best to use Basic Authentication with SSL."  ;
-
-IN: http.basic-authentication
-ABOUT: { "http-authentication" "basic-authentication" }
diff --git a/extra/http/basic-authentication/basic-authentication-tests.factor b/extra/http/basic-authentication/basic-authentication-tests.factor
deleted file mode 100644
index 318123b0b4..0000000000
--- a/extra/http/basic-authentication/basic-authentication-tests.factor
+++ /dev/null
@@ -1,66 +0,0 @@
-! Copyright (c) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel crypto.sha2 http.basic-authentication tools.test 
-       namespaces base64 sequences ;
-
-{ t } [
-  [
-    H{ } clone realms set    
-    H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm
-    "test-realm" "Basic " "admin:password" >base64 append authorization-ok?
-  ] with-scope 
-] unit-test 
-
-{ f } [
-  [
-    H{ } clone realms set    
-    H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm
-    "test-realm" "Basic " "admin:passwordx" >base64 append authorization-ok?
-  ] with-scope 
-] unit-test 
-
-{ f } [
-  [
-    H{ } clone realms set    
-    H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm
-    "test-realm" "Basic " "xadmin:password" >base64 append authorization-ok?
-  ] with-scope 
-] unit-test 
-
-{ t } [
-  [
-    H{ } clone realms set    
-    [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm
-    "test-realm" "Basic " "admin:password" >base64 append authorization-ok?
-  ] with-scope 
-] unit-test 
-
-{ f } [
-  [
-    H{ } clone realms set    
-    [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm
-    "test-realm" "Basic " "xadmin:password" >base64 append authorization-ok?
-  ] with-scope 
-] unit-test 
-
-{ f } [
-  [
-    H{ } clone realms set    
-    [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm
-    "test-realm" "Basic " "admin:xpassword" >base64 append authorization-ok?
-  ] with-scope 
-] unit-test 
-
-{ f } [
-  [
-    f realms set    
-    "test-realm" "Basic " "admin:password" >base64 append authorization-ok?
-  ] with-scope 
-] unit-test 
-
-{ f } [
-  [
-    H{ } clone realms set    
-    "test-realm" "Basic " "admin:password" >base64 append authorization-ok?
-  ] with-scope 
-] unit-test 
diff --git a/extra/http/basic-authentication/basic-authentication.factor b/extra/http/basic-authentication/basic-authentication.factor
deleted file mode 100644
index dfe04dc4b5..0000000000
--- a/extra/http/basic-authentication/basic-authentication.factor
+++ /dev/null
@@ -1,65 +0,0 @@
-! Copyright (c) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel base64 http.server crypto.sha2 namespaces assocs
-       quotations hashtables combinators splitting sequences
-       http.server.responders io html.elements ;
-IN: http.basic-authentication
-
-! 'realms' is a hashtable mapping a realm (a string) to 
-! either a quotation or a hashtable. The quotation 
-! has stack effect ( username sha-256-string -- bool ).
-! It should perform the user authentication. 'sha-256-string'
-! is the plain text password provided by the user passed through
-! 'string>sha-256-string'. If 'realms' maps to a hashtable then
-! it is a mapping of usernames to sha-256 hashed passwords. 
-!
-! 'realms' can be set on a per vhost basis in the vhosts 
-! table.
-!
-! If there are no realms then authentication fails.
-SYMBOL: realms
- 
-: add-realm ( data name  -- )
-  #! Add the named realm to the realms table.
-  #! 'data' should be a hashtable or a quotation.
-  realms get [ H{ } clone dup realms set ] unless* 
-  set-at ;
-
-: user-authorized? ( username password realm -- bool )
-  realms get dup [
-    at {
-      { [ dup quotation? ] [ call ] }
-      { [ dup hashtable? ] [ swapd at = ] }
-      { [ t ] [ 3drop f ] }
-    } cond 
-  ] [
-    3drop drop f
-  ] if ;
-
-: authorization-ok? ( realm header -- bool )  
-  #! Given the realm and the 'Authorization' header,
-  #! authenticate the user.
-  dup [
-    " " split dup first "Basic" = [
-      second base64> ":" split first2 string>sha-256-string rot 
-      user-authorized?
-    ] [
-      2drop f
-    ] if   
-  ] [
-    2drop f
-  ] if ;
-
-: authentication-error ( realm -- )
-  "401 Unauthorized" response
-  "Basic realm=\"" swap "\"" 3append "WWW-Authenticate" associate print-header
-  <html> <body>
-    "Username or Password is invalid" write
-  </body> </html> ;
-
-: with-basic-authentication ( realm quot -- )
-  #! Check if the user is authenticated in the given realm
-  #! to run the specified quotation. If not, use Basic
-  #! Authentication to ask for authorization details.
-  over "authorization" header-param authorization-ok?
-  [ nip call ] [ drop authentication-error ] if ;
diff --git a/extra/http/basic-authentication/summary.txt b/extra/http/basic-authentication/summary.txt
deleted file mode 100644
index 60cef7e630..0000000000
--- a/extra/http/basic-authentication/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-HTTP Basic Authentication implementation
diff --git a/extra/http/basic-authentication/tags.txt b/extra/http/basic-authentication/tags.txt
deleted file mode 100644
index c0772185a0..0000000000
--- a/extra/http/basic-authentication/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-web
diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor
index d2fb719acd..4fca1697a5 100755
--- a/extra/http/client/client-tests.factor
+++ b/extra/http/client/client-tests.factor
@@ -1,14 +1,28 @@
-USING: http.client tools.test ;
+USING: http.client http.client.private http tools.test
+tuple-syntax namespaces ;
 [ "localhost" 80 ] [ "localhost" parse-host ] unit-test
 [ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
-[ "localhost:8888" "/foo" ] [ "http://localhost:8888/foo" parse-url ] unit-test
-[ "localhost:8888" "/" ] [ "http://localhost:8888" parse-url ] unit-test
-[ 404 ] [ "HTTP/1.1 404 File not found" parse-response ] unit-test
-[ 404 ] [ "404 File not found" parse-response ] unit-test
-[ 200 ] [ "HTTP/1.0 200" parse-response ] unit-test
-[ 200 ] [ "HTTP/1.0 200 Success" parse-response ] unit-test
+[ "/foo" "localhost" 8888 ] [ "http://localhost:8888/foo" parse-url ] unit-test
+[ "/" "localhost" 8888 ] [ "http://localhost:8888" parse-url ] unit-test
 
 [ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test
 [ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt?xxx" download-name ] unit-test
 [ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt/" download-name ] unit-test
 [ "www.arcsucks.com" ] [ "http://www.arcsucks.com////" download-name ] unit-test
+
+[
+    TUPLE{ request
+        method: "GET"
+        host: "www.apple.com"
+        path: "/index.html"
+        port: 80
+        version: "1.1"
+        cookies: V{ }
+    }
+] [
+    [
+        "http://www.apple.com/index.html"
+        <get-request>
+        request-with-url
+    ] with-scope
+] unit-test
diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor
index 99ba045019..1c408e44e3 100755
--- a/extra/http/client/client.factor
+++ b/extra/http/client/client.factor
@@ -2,64 +2,72 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs http kernel math math.parser namespaces sequences
 io io.sockets io.streams.string io.files io.timeouts strings
-splitting continuations assocs.lib calendar ;
+splitting continuations calendar vectors hashtables
+accessors ;
 IN: http.client
 
-: parse-host ( url -- host port )
-    #! Extract the host name and port number from an HTTP URL.
-    ":" split1 [ string>number ] [ 80 ] if* ;
-
-SYMBOL: domain
-
-: parse-url ( url -- host resource )
-    dup "https://" head? [
-        "ssl not yet supported: " swap append throw
-    ] when "http://" ?head drop
+: parse-url ( url -- resource host port )
+    "http://" ?head [ "Only http:// supported" throw ] unless
     "/" split1 [ "/" swap append ] [ "/" ] if*
-    >r dup empty? [ drop domain get ] [ dup domain set ] if r> ;
+    swap parse-host ;
 
-: parse-response ( line -- code )
-    "HTTP/" ?head [ " " split1 nip ] when
-    " " split1 drop string>number [
-        "Premature end of stream" throw
-    ] unless* ;
+<PRIVATE
 
-: read-response ( -- code header )
-    #! After sending a GET or POST we read a response line and
-    #! header.
-    flush readln parse-response read-header ;
+: store-path ( request path -- request )
+    "?" split1 >r >>path r> dup [ query>assoc ] when >>query ;
 
-: crlf "\r\n" write ;
+! This is all pretty complex because it needs to handle
+! HTTP redirects, which might be absolute or relative
+: request-with-url ( url request -- request )
+    clone dup "request" set
+    swap parse-url >r >r store-path r> >>host r> >>port ;
 
-: http-request ( host resource method -- )
-    write bl write " HTTP/1.0" write crlf
-    "Host: " write write crlf ;
+DEFER: (http-request)
 
-: get-request ( host resource -- )
-    "GET" http-request crlf ;
+: absolute-redirect ( url -- request )
+    "request" get request-with-url ;
 
-DEFER: http-get-stream
+: relative-redirect ( path -- request )
+    "request" get swap store-path ;
 
-: do-redirect ( code headers stream -- code headers stream )
-    #! Should this support Location: headers that are
-    #! relative URLs?
-    pick 100 /i 3 = [
-        dispose "location" swap peek-at nip http-get-stream
-    ] when ;
+: do-redirect ( response -- response stream )
+    dup response-code 300 399 between? [
+        header>> "location" swap at
+        dup "http://" head? [
+            absolute-redirect
+        ] [
+            relative-redirect
+        ] if "GET" >>method (http-request)
+    ] [
+        stdio get
+    ] if ;
 
-: default-timeout 1 minutes over set-timeout ;
+: (http-request) ( request -- response stream )
+    dup host>> over port>> <inet> <client> stdio set
+    dup "r" set-global  write-request flush read-response
+    do-redirect ;
 
-: http-get-stream ( url -- code headers stream )
-    #! Opens a stream for reading from an HTTP URL.
-    parse-url over parse-host <inet> <client> [
-        [ [ get-request read-response ] with-stream* ] keep
-        default-timeout
-    ] [ ] [ dispose ] cleanup do-redirect ;
+PRIVATE>
+
+: http-request ( url request -- response stream )
+    [
+        request-with-url
+        [
+            (http-request)
+            1 minutes over set-timeout
+        ] [ ] [ stdio get dispose ] cleanup
+    ] with-scope ;
+
+: <get-request> ( -- request )
+    <request> "GET" >>method ;
+
+: http-get-stream ( url -- response stream )
+    <get-request> http-request ;
 
 : success? ( code -- ? ) 200 = ;
 
-: check-response ( code headers stream -- stream )
-    nip swap success?
+: check-response ( response stream -- stream )
+    swap code>> success?
     [ dispose "HTTP download failed" throw ] unless ;
 
 : http-get ( url -- string )
@@ -70,23 +78,18 @@ DEFER: http-get-stream
 
 : download-to ( url file -- )
     #! Downloads the contents of a URL to a file.
-    >r http-get-stream check-response
-    r> <file-writer> stream-copy ;
+    swap http-get-stream check-response
+    [ swap <file-writer> stream-copy ] with-disposal ;
 
 : download ( url -- )
     dup download-name download-to ;
 
-: post-request ( content-type content host resource -- )
-    #! Note: It is up to the caller to url encode the content if
-    #! it is required according to the content-type.
-    "POST" http-request [
-        "Content-Length: " write length number>string write crlf
-        "Content-Type: " write url-encode write crlf
-        crlf
-    ] keep write ;
+: <post-request> ( content-type content -- request )
+    <request>
+    "POST" >>method
+    swap >>post-data
+    swap >>post-data-type ;
 
-: http-post ( content-type content url -- code headers string )
-    #! Make a POST request. The content is URL encoded for you.
-    parse-url over parse-host <inet> <client> [
-        post-request flush read-response stdio get contents
-    ] with-stream ;
+: http-post ( content-type content url -- response string )
+    #! The content is URL encoded for you.
+    -rot url-encode <post-request> http-request contents ;
diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor
old mode 100644
new mode 100755
index 0a4941aaa0..b706f34d13
--- a/extra/http/http-tests.factor
+++ b/extra/http/http-tests.factor
@@ -1,4 +1,5 @@
-USING: http tools.test ;
+USING: http tools.test multiline tuple-syntax
+io.streams.string kernel arrays splitting sequences     ;
 IN: http.tests
 
 [ "hello%20world" ] [ "hello world" url-encode ] unit-test
@@ -16,3 +17,113 @@ IN: http.tests
 [ "%20%21%20"     ] [ " ! "            url-encode ] unit-test
 
 [ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test
+
+[ "/" ] [ "http://foo.com" url>path ] unit-test
+[ "/" ] [ "http://foo.com/" url>path ] unit-test
+[ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test
+[ "/bar" ] [ "/bar" url>path ] unit-test
+
+STRING: read-request-test-1
+GET http://foo/bar HTTP/1.1
+Some-Header: 1
+Some-Header: 2
+Content-Length: 4
+
+blah
+;
+
+[
+    TUPLE{ request
+        port: 80
+        method: "GET"
+        path: "/bar"
+        query: H{ }
+        version: "1.1"
+        header: H{ { "some-header" "1; 2" } { "content-length" "4" } }
+        post-data: "blah"
+        cookies: V{ }
+    }
+] [
+    read-request-test-1 [
+        read-request
+    ] with-string-reader
+] unit-test
+
+STRING: read-request-test-1'
+GET /bar HTTP/1.1
+content-length: 4
+some-header: 1; 2
+
+blah
+;
+
+read-request-test-1' 1array [
+    read-request-test-1
+    [ read-request ] with-string-reader
+    [ write-request ] with-string-writer
+    ! normalize crlf
+    string-lines "\n" join
+] unit-test
+
+STRING: read-request-test-2
+HEAD  http://foo/bar   HTTP/1.1
+Host: www.sex.com
+;
+
+[
+    TUPLE{ request
+        port: 80
+        method: "HEAD"
+        path: "/bar"
+        query: H{ }
+        version: "1.1"
+        header: H{ { "host" "www.sex.com" } }
+        host: "www.sex.com"
+        cookies: V{ }
+    }
+] [
+    read-request-test-2 [
+        read-request
+    ] with-string-reader
+] unit-test
+
+STRING: read-response-test-1
+HTTP/1.1 404 not found
+Content-Type: text/html
+
+blah
+;
+
+[
+    TUPLE{ response
+        version: "1.1"
+        code: 404
+        message: "not found"
+        header: H{ { "content-type" "text/html" } }
+        cookies: V{ }
+    }
+] [
+    read-response-test-1
+    [ read-response ] with-string-reader
+] unit-test
+
+
+STRING: read-response-test-1'
+HTTP/1.1 404 not found
+content-type: text/html
+
+
+;
+
+read-response-test-1' 1array [
+    read-response-test-1
+    [ read-response ] with-string-reader
+    [ write-response ] with-string-writer
+    ! normalize crlf
+    string-lines "\n" join
+] unit-test
+
+[ t ] [
+    "rmid=732423sdfs73242; path=/; domain=.example.net; expires=Fri, 31-Dec-2010 23:59:59 GMT"
+    dup parse-cookies unparse-cookies =
+] unit-test
diff --git a/extra/http/http.factor b/extra/http/http.factor
index 5c4dae94c7..35fe3ce544 100755
--- a/extra/http/http.factor
+++ b/extra/http/http.factor
@@ -1,19 +1,13 @@
-! Copyright (C) 2003, 2007 Slava Pestov.
+! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables io kernel math namespaces math.parser assocs
-sequences strings splitting ascii io.encodings.utf8 assocs.lib
-namespaces unicode.case ;
+USING: hashtables io io.streams.string kernel math namespaces
+math.parser assocs sequences strings splitting ascii
+io.encodings.utf8 namespaces unicode.case combinators
+vectors sorting new-slots accessors calendar calendar.format
+quotations arrays ;
 IN: http
 
-: header-line ( line -- )
-    ": " split1 dup [ swap >lower insert ] [ 2drop ] if ;
-
-: (read-header) ( -- )
-    readln dup
-    empty? [ drop ] [ header-line (read-header) ] if ;
-
-: read-header ( -- hash )
-    [ (read-header) ] H{ } make-assoc ;
+: http-port 80 ; inline
 
 : url-quotable? ( ch -- ? )
     #! In a URL, can this character be used without
@@ -23,7 +17,7 @@ IN: http
     over digit? or
     swap "/_-." member? or ; foldable
 
-: push-utf8 ( string -- )
+: push-utf8 ( ch -- )
     1string encode-utf8 [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
 
 : url-encode ( str -- str )
@@ -58,17 +52,375 @@ IN: http
 : url-decode ( str -- str )
     [ 0 swap url-decode-iter ] "" make decode-utf8 ;
 
-: hash>query ( hash -- str )
+: crlf "\r\n" write ;
+
+: add-header ( value key assoc -- )
+    [ at dup [ "; " rot 3append ] [ drop ] if ] 2keep set-at ;
+
+: header-line ( line -- )
+    dup first blank? [
+        [ blank? ] left-trim
+        "last-header" get
+        "header" get
+        add-header
+    ] [
+        ": " split1 dup [
+            swap >lower dup "last-header" set
+            "header" get add-header
+        ] [
+            2drop
+        ] if
+    ] if ;
+
+: read-header-line ( -- )
+    readln dup
+    empty? [ drop ] [ header-line read-header-line ] if ;
+
+: read-header ( -- assoc )
+    H{ } clone [
+        "header" [ read-header-line ] with-variable
+    ] keep ;
+
+: header-value>string ( value -- string )
+    {
+        { [ dup number? ] [ number>string ] }
+        { [ dup timestamp? ] [ timestamp>http-string ] }
+        { [ dup string? ] [ ] }
+        { [ dup sequence? ] [ [ header-value>string ] map "; " join ] }
+    } cond ;
+
+: check-header-string ( str -- str )
+    #! http://en.wikipedia.org/wiki/HTTP_Header_Injection
+    dup [ "\r\n" member? ] contains?
+    [ "Header injection attack" throw ] when ;
+
+: write-header ( assoc -- )
+    >alist sort-keys [
+        swap url-encode write ": " write
+        header-value>string check-header-string write crlf
+    ] assoc-each crlf ;
+
+: query>assoc ( query -- assoc )
+    dup [
+        "&" split [
+            "=" split1 [ dup [ url-decode ] when ] 2apply
+        ] H{ } map>assoc
+    ] when ;
+
+: assoc>query ( hash -- str )
     [ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map
     "&" join ;
 
-: build-url ( str query-params -- newstr )
+TUPLE: cookie name value path domain expires http-only ;
+
+: <cookie> ( value name -- cookie )
+    cookie construct-empty
+    swap >>name swap >>value ;
+
+: parse-cookies ( string -- seq )
     [
-        over %
-        dup assoc-empty? [
-            2drop
-        ] [
-            CHAR: ? rot member? "&" "?" ? %
-            hash>query %
-        ] if
-    ] "" make ;
+        f swap
+
+        ";" split [
+            [ blank? ] trim "=" split1 swap >lower {
+                { "expires" [ >>expires ] }
+                { "domain" [ >>domain ] }
+                { "path" [ >>path ] }
+                { "httponly" [ drop t >>http-only ] }
+                { "" [ drop ] }
+                [ <cookie> dup , nip ]
+            } case
+        ] each
+
+        drop
+    ] { } make ;
+
+: (unparse-cookie) ( key value -- )
+    {
+        { [ dup f eq? ] [ 2drop ] }
+        { [ dup t eq? ] [ drop , ] }
+        { [ t ] [ "=" swap 3append , ] }
+    } cond ;
+
+: unparse-cookie ( cookie -- strings )
+    [
+        dup name>> >lower over value>> (unparse-cookie)
+        "path" over path>> (unparse-cookie)
+        "domain" over domain>> (unparse-cookie)
+        "expires" over expires>> (unparse-cookie)
+        "httponly" over http-only>> (unparse-cookie)
+        drop
+    ] { } make ;
+
+: unparse-cookies ( cookies -- string )
+    [ unparse-cookie ] map concat "; " join ;
+
+TUPLE: request
+host
+port
+method
+path
+query
+version
+header
+post-data
+post-data-type
+cookies ;
+
+: <request>
+    request construct-empty
+    "1.1" >>version
+    http-port >>port
+    H{ } clone >>query
+    V{ } clone >>cookies ;
+
+: query-param ( request key -- value )
+    swap query>> at ;
+
+: set-query-param ( request value key -- request )
+    pick query>> set-at ;
+
+: chop-hostname ( str -- str' )
+    CHAR: / over index over length or tail
+    dup empty? [ drop "/" ] when ;
+
+: url>path ( url -- path )
+    #! Technically, only proxies are meant to support hostnames
+    #! in HTTP requests, but IE sends these sometimes so we
+    #! just chop the hostname part.
+    url-decode "http://" ?head [ chop-hostname ] when ;
+
+: read-method ( request -- request )
+    " " read-until [ "Bad request: method" throw ] unless
+    >>method ;
+
+: read-query ( request -- request )
+    " " read-until
+    [ "Bad request: query params" throw ] unless
+    query>assoc >>query ;
+
+: read-url ( request -- request )
+    " ?" read-until {
+        { CHAR: \s [ dup empty? [ drop read-url ] [ url>path >>path ] if ] }
+        { CHAR: ? [ url>path >>path read-query ] }
+        [ "Bad request: URL" throw ]
+    } case ;
+
+: parse-version ( string -- version )
+    "HTTP/" ?head [ "Bad version" throw ] unless
+    dup { "1.0" "1.1" } member? [ "Bad version" throw ] unless ;
+
+: read-request-version ( request -- request )
+    readln [ CHAR: \s = ] left-trim
+    parse-version
+    >>version ;
+
+: read-request-header ( request -- request )
+    read-header >>header ;
+
+: header ( request/response key -- value )
+    swap header>> at ;
+
+SYMBOL: max-post-request
+
+1024 256 * max-post-request set-global
+
+: content-length ( header -- n )
+    "content-length" swap at string>number dup [
+        dup max-post-request get > [
+            "content-length > max-post-request" throw
+        ] when
+    ] when ;
+
+: read-post-data ( request -- request )
+    dup header>> content-length [ read >>post-data ] when* ;
+
+: parse-host ( string -- host port )
+    "." ?tail drop ":" split1
+    [ string>number ] [ http-port ] if* ;
+
+: extract-host ( request -- request )
+    dup "host" header parse-host >r >>host r> >>port ;
+
+: extract-post-data-type ( request -- request )
+    dup "content-type" header >>post-data-type ;
+
+: extract-cookies ( request -- request )
+    dup "cookie" header [ parse-cookies >>cookies ] when* ;
+
+: read-request ( -- request )
+    <request>
+    read-method
+    read-url
+    read-request-version
+    read-request-header
+    read-post-data
+    extract-host
+    extract-post-data-type
+    extract-cookies ;
+
+: write-method ( request -- request )
+    dup method>> write bl ;
+
+: write-url ( request -- request )
+    dup path>> url-encode write
+    dup query>> dup assoc-empty? [ drop ] [
+        "?" write
+        assoc>query write
+    ] if ;
+
+: write-request-url ( request -- request )
+    write-url bl ;
+
+: write-version ( request -- request )
+    "HTTP/" write dup request-version write crlf ;
+
+: write-request-header ( request -- request )
+    dup header>> >hashtable
+    over host>> [ "host" pick set-at ] when*
+    over post-data>> [ length "content-length" pick set-at ] when*
+    over post-data-type>> [ "content-type" pick set-at ] when*
+    over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when*
+    write-header ;
+
+: write-post-data ( request -- request )
+    dup post-data>> [ write ] when* ;
+
+: write-request ( request -- )
+    write-method
+    write-request-url
+    write-version
+    write-request-header
+    write-post-data
+    flush
+    drop ;
+
+: request-url ( request -- url )
+    [
+        dup host>> [
+            "http://" write
+            dup host>> url-encode write
+            ":" write
+            dup port>> number>string write
+        ] when
+        dup path>> "/" head? [ "/" write ] unless
+        write-url
+        drop
+    ] with-string-writer ;
+
+: set-header ( request/response value key -- request/response )
+    pick header>> set-at ;
+
+GENERIC: write-response ( response -- )
+
+GENERIC: write-full-response ( request response -- )
+
+TUPLE: response
+version
+code
+message
+header
+cookies
+body ;
+
+: <response>
+    response construct-empty
+    "1.1" >>version
+    H{ } clone >>header
+    "close" "connection" set-header
+    now timestamp>http-string "date" set-header
+    V{ } clone >>cookies ;
+
+: read-response-version
+    " \t" read-until
+    [ "Bad response: version" throw ] unless
+    parse-version
+    >>version ;
+
+: read-response-code
+    " \t" read-until [ "Bad response: code" throw ] unless
+    string>number [ "Bad response: code" throw ] unless*
+    >>code ;
+
+: read-response-message
+    readln >>message ;
+
+: read-response-header
+    read-header >>header
+    dup "set-cookie" header [ parse-cookies >>cookies ] when* ;
+
+: read-response ( -- response )
+    <response>
+    read-response-version
+    read-response-code
+    read-response-message
+    read-response-header ;
+
+: write-response-version ( response -- response )
+    "HTTP/" write
+    dup version>> write bl ;
+
+: write-response-code ( response -- response )
+    dup code>> number>string write bl ;
+
+: write-response-message ( response -- response )
+    dup message>> write crlf ;
+
+: write-response-header ( response -- response )
+    dup header>> clone
+    over cookies>> f like
+    [ unparse-cookies "set-cookie" pick set-at ] when*
+    write-header ;
+
+: write-response-body ( response -- response )
+    dup body>> {
+        { [ dup not ] [ drop ] }
+        { [ dup string? ] [ write ] }
+        { [ dup callable? ] [ call ] }
+        { [ t ] [ stdio get stream-copy ] }
+    } cond ;
+
+M: response write-response ( respose -- )
+    write-response-version
+    write-response-code
+    write-response-message
+    write-response-header
+    flush
+    drop ;
+
+M: response write-full-response ( request response -- )
+    dup write-response
+    swap method>> "HEAD" = [ write-response-body ] unless ;
+
+: set-content-type ( request/response content-type -- request/response )
+    "content-type" set-header ;
+
+: get-cookie ( request/response name -- cookie/f )
+    >r cookies>> r> [ swap name>> = ] curry find nip ;
+
+: delete-cookie ( request/response name -- )
+    over cookies>> >r get-cookie r> delete ;
+
+: put-cookie ( request/response cookie -- request/response )
+    [ dupd name>> get-cookie [ dupd delete-cookie ] when* ] keep
+    over cookies>> push ;
+
+TUPLE: raw-response 
+version
+code
+message
+body ;
+
+: <raw-response> ( -- response )
+    raw-response construct-empty
+    "1.1" >>version ;
+
+M: raw-response write-response ( respose -- )
+    write-response-version
+    write-response-code
+    write-response-message
+    write-response-body
+    drop ;
+
+M: raw-response write-full-response ( response -- )
+    write-response nip ;
diff --git a/extra/http/mime/mime.factor b/extra/http/mime/mime.factor
old mode 100644
new mode 100755
index 3365127d87..f9097ecce3
--- a/extra/http/mime/mime.factor
+++ b/extra/http/mime/mime.factor
@@ -30,5 +30,6 @@ H{
     { "pdf"    "application/pdf"                  }
 
     { "factor" "text/plain"                       }
+    { "cgi"    "application/x-cgi-script"         }
     { "fhtml"  "application/x-factor-server-page" }
 } "mime-types" set-global
diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor
new file mode 100644
index 0000000000..2d74e92e86
--- /dev/null
+++ b/extra/http/server/actions/actions-tests.factor
@@ -0,0 +1,37 @@
+IN: http.server.actions.tests
+USING: http.server.actions tools.test math math.parser
+multiline namespaces http io.streams.string http.server
+sequences ;
+
+[ + ]
+{ { "a" [ string>number ] } { "b" [ string>number ] } }
+"GET" <action> "action-1" set
+
+STRING: action-request-test-1
+GET http://foo/bar?a=12&b=13 HTTP/1.1
+
+blah
+;
+
+[ 25 ] [
+    action-request-test-1 [ read-request ] with-string-reader
+    "/blah"
+    "action-1" get call-responder
+] unit-test
+
+[ "X" <repetition> concat append ]
+{ { +path+ [ ] } { "xxx" [ string>number ] } }
+"POST" <action> "action-2" set
+
+STRING: action-request-test-2
+POST http://foo/bar/baz HTTP/1.1
+content-length: 5
+
+xxx=4
+;
+
+[ "/blahXXXX" ] [
+    action-request-test-2 [ read-request ] with-string-reader
+    "/blah"
+    "action-2" get call-responder
+] unit-test
diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor
new file mode 100755
index 0000000000..feb16a4488
--- /dev/null
+++ b/extra/http/server/actions/actions.factor
@@ -0,0 +1,30 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors new-slots sequences kernel assocs combinators
+http.server http hashtables namespaces ;
+IN: http.server.actions
+
+SYMBOL: +path+
+
+TUPLE: action quot params method ;
+
+C: <action> action
+
+: extract-params ( request path -- assoc )
+    >r dup method>> {
+        { "GET" [ query>> ] }
+        { "POST" [ post-data>> query>assoc ] }
+    } case r> +path+ associate union ;
+
+: push-params ( assoc action -- ... )
+    params>> [ first2 >r swap at r> call ] with each ;
+
+M: action call-responder ( request path action -- response )
+    pick request set
+    pick method>> over method>> = [
+        >r extract-params r>
+        [ push-params ] keep
+        quot>> call
+    ] [
+        3drop <400>
+    ] if ;
diff --git a/extra/http/server/authentication/basic/basic.factor b/extra/http/server/authentication/basic/basic.factor
new file mode 100755
index 0000000000..b6dbed4b62
--- /dev/null
+++ b/extra/http/server/authentication/basic/basic.factor
@@ -0,0 +1,50 @@
+! Copyright (c) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+IN: http.server.authentication.basic
+USING: accessors new-slots quotations assocs kernel splitting
+base64 crypto.sha2 html.elements io combinators http.server
+http sequences ;
+
+! 'users' is a quotation or an assoc. The quotation 
+! has stack effect ( sha-256-string username -- ? ).
+! It should perform the user authentication. 'sha-256-string'
+! is the plain text password provided by the user passed through
+! 'string>sha-256-string'. If 'users' is an assoc then
+! it is a mapping of usernames to sha-256 hashed passwords. 
+TUPLE: realm responder name users ;
+
+C: <realm> realm
+
+: user-authorized? ( password username realm -- ? )
+    users>> {
+        { [ dup callable? ] [ call ] }
+        { [ dup assoc? ] [ at = ] }
+    } cond ;
+
+: authorization-ok? ( realm header -- bool )  
+    #! Given the realm and the 'Authorization' header,
+    #! authenticate the user.
+    dup [
+        " " split1 swap "Basic" = [
+            base64> ":" split1 string>sha-256-string
+            spin user-authorized?
+        ] [
+            2drop f
+        ] if
+    ] [
+        2drop f
+    ] if ;
+
+: <401> ( realm -- response )
+    401 "Unauthorized" <trivial-response>
+    "Basic realm=\"" rot name>> "\"" 3append
+    "WWW-Authenticate" set-header
+    [
+        <html> <body>
+            "Username or Password is invalid" write
+        </body> </html>
+    ] >>body ;
+
+M: realm call-responder ( request path realm -- response )
+    pick "authorization" header dupd authorization-ok?
+    [ responder>> call-responder ] [ 2nip <401> ] if ;
diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor
new file mode 100755
index 0000000000..fd2e8f8ad7
--- /dev/null
+++ b/extra/http/server/callbacks/callbacks.factor
@@ -0,0 +1,135 @@
+! Copyright (C) 2004 Chris Double.
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: html http http.server io kernel math namespaces
+continuations calendar sequences assocs new-slots hashtables
+accessors arrays alarms quotations combinators ;
+IN: http.server.callbacks
+
+SYMBOL: responder
+
+TUPLE: callback-responder responder callbacks ;
+
+: <callback-responder> ( responder -- responder' )
+    #! A continuation responder is a special type of session
+    #! manager. However it works entirely differently from
+    #! the URL and cookie session managers.
+    H{ } clone callback-responder construct-boa ;
+
+TUPLE: callback cont quot expires alarm responder ;
+
+: timeout 20 minutes ;
+
+: timeout-callback ( callback -- )
+    dup alarm>> cancel-alarm
+    dup responder>> callbacks>> delete-at ;
+
+: touch-callback ( callback -- )
+    dup expires>> [
+        dup alarm>> [ cancel-alarm ] when*
+        dup [ timeout-callback ] curry timeout later >>alarm
+    ] when drop ;
+
+: <callback> ( cont quot expires? -- callback )
+    [ f responder get callback construct-boa ] keep
+    [ dup touch-callback ] when ;
+
+: invoke-callback ( request exit-cont callback -- response )
+    [ quot>> 3array ] keep cont>> continue-with ;
+
+: register-callback ( cont quot expires? -- id )
+    <callback>
+    responder get callbacks>> generate-key
+    [ responder get callbacks>> set-at ] keep ;
+
+SYMBOL: exit-continuation
+
+: exit-with exit-continuation get continue-with ;
+
+: forward-to-url ( url -- * )
+    #! When executed inside a 'show' call, this will force a
+    #! HTTP 302 to occur to instruct the browser to forward to
+    #! the request URL.
+    request get swap <temporary-redirect> exit-with ;
+
+: cont-id "factorcontid" ;
+
+: id>url ( id -- url )
+    request get
+    swap cont-id associate >>query
+    request-url ;
+
+: forward-to-id ( id -- * )
+    #! When executed inside a 'show' call, this will force a
+    #! HTTP 302 to occur to instruct the browser to forward to
+    #! the request URL.
+    id>url forward-to-url ;
+
+: restore-request ( pair -- )
+    first3 >r exit-continuation set request set r> call ;
+
+: resume-page ( request page responder callback -- * )
+    dup touch-callback
+    >r 2drop exit-continuation get
+    r> invoke-callback ;
+
+SYMBOL: post-refresh-get?
+
+: redirect-to-here ( -- )
+    #! Force a redirect to the client browser so that the browser
+    #! goes to the current point in the code. This forces an URL
+    #! change on the browser so that refreshing that URL will
+    #! immediately run from this code point. This prevents the
+    #! "this request will issue a POST" warning from the browser
+    #! and prevents re-running the previous POST logic. This is
+    #! known as the 'post-refresh-get' pattern.
+    post-refresh-get? get [
+        [
+            [ ] t register-callback forward-to-id
+        ] callcc1 restore-request
+    ] [
+        post-refresh-get? on
+    ] if ;
+
+SYMBOL: current-show
+
+: store-current-show ( -- )
+    #! Store the current continuation in the variable 'current-show'
+    #! so it can be returned to later by 'quot-id'. Note that it
+    #! recalls itself when the continuation is called to ensure that
+    #! it resets its value back to the most recent show call.
+    [ current-show set f ] callcc1
+    [ restore-request store-current-show ] when* ;
+
+: show-final ( quot -- * )
+    >r redirect-to-here store-current-show
+    r> call exit-with ; inline
+
+M: callback-responder call-responder
+    [
+        [
+            exit-continuation set
+            dup responder set
+            pick request set
+            pick cont-id query-param over callbacks>> at [
+                resume-page
+            ] [
+                responder>> call-responder
+                "Continuation responder pages must use show-final" throw
+            ] if*
+        ] with-scope
+    ] callcc1 >r 3drop r> ;
+
+: show-page ( quot -- )
+    >r redirect-to-here store-current-show r>
+    [
+        [ ] register-callback
+        with-scope
+        exit-with
+    ] callcc1 restore-request ; inline
+
+: quot-id ( quot -- id )
+    current-show get swap t register-callback ;
+
+: quot-url ( quot -- url )
+    quot-id id>url ;
diff --git a/extra/http/server/cgi/cgi.factor b/extra/http/server/cgi/cgi.factor
new file mode 100755
index 0000000000..9950a9a4a4
--- /dev/null
+++ b/extra/http/server/cgi/cgi.factor
@@ -0,0 +1,65 @@
+! Copyright (C) 2007, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces kernel assocs io.files combinators
+arrays io.launcher io http.server.static http.server
+http accessors sequences strings math.parser ;
+IN: http.server.cgi
+
+: post? request get method>> "POST" = ;
+
+: cgi-variables ( script-path -- assoc )
+    #! This needs some work.
+    [
+        "CGI/1.0" "GATEWAY_INTERFACE" set
+        "HTTP/" request get version>> append "SERVER_PROTOCOL" set
+        "Factor" "SERVER_SOFTWARE" set
+
+        dup "PATH_TRANSLATED" set
+        "SCRIPT_FILENAME" set
+
+        request get path>> "SCRIPT_NAME" set
+
+        request get host>> "SERVER_NAME" set
+        request get port>> number>string "SERVER_PORT" set
+        "" "PATH_INFO" set
+        "" "REMOTE_HOST" set
+        "" "REMOTE_ADDR" set
+        "" "AUTH_TYPE" set
+        "" "REMOTE_USER" set
+        "" "REMOTE_IDENT" set
+
+        request get method>> "REQUEST_METHOD" set
+        request get query>> assoc>query "QUERY_STRING" set
+        request get "cookie" header "HTTP_COOKIE" set 
+
+        request get "user-agent" header "HTTP_USER_AGENT" set
+        request get "accept" header "HTTP_ACCEPT" set
+
+        post? [
+            request get post-data-type>> "CONTENT_TYPE" set
+            request get post-data>> length number>string "CONTENT_LENGTH" set
+        ] when
+    ] H{ } make-assoc ;
+
+: cgi-descriptor ( name -- desc )
+    [
+        dup 1array +arguments+ set
+        cgi-variables +environment+ set
+    ] H{ } make-assoc ;
+    
+: serve-cgi ( name -- response )
+    <raw-response>
+    200 >>code
+    "CGI output follows" >>message
+    swap [
+        stdio get swap cgi-descriptor <process-stream> [
+            post? [
+                request get post-data>> write flush
+            ] when
+            stdio get swap (stream-copy)
+        ] with-stream
+    ] curry >>body ;
+
+: enable-cgi ( responder -- responder )
+    [ serve-cgi ] "application/x-cgi-script"
+    pick special>> set-at ;
diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor
new file mode 100755
index 0000000000..4baee5f02b
--- /dev/null
+++ b/extra/http/server/db/db.factor
@@ -0,0 +1,14 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: db http.server kernel new-slots accessors
+continuations namespaces ;
+IN: http.server.db
+
+TUPLE: db-persistence responder db params ;
+
+C: <db-persistence> db-persistence
+
+M: db-persistence call-responder
+    dup db>> over params>> make-db dup db-open [
+        db set responder>> call-responder
+    ] with-disposal ;
diff --git a/extra/http/server/responders/authors.txt b/extra/http/server/responders/authors.txt
deleted file mode 100755
index 1901f27a24..0000000000
--- a/extra/http/server/responders/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor
deleted file mode 100755
index ac317e2605..0000000000
--- a/extra/http/server/responders/responders.factor
+++ /dev/null
@@ -1,225 +0,0 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs hashtables html html.elements splitting
-http io kernel math math.parser namespaces parser sequences
-strings io.server vectors assocs.lib logging ;
-
-IN: http.server.responders
-
-! Variables
-SYMBOL: vhosts
-SYMBOL: responders
-
-: >header ( value key -- multi-hash )
-    H{ } clone [ insert-at ] keep ;
-
-: print-header ( alist -- )
-    [ swap write ": " write print ] multi-assoc-each nl ;
-
-: response ( msg -- ) "HTTP/1.0 " write print ;
-
-: error-body ( error -- )
-    <html> <body> <h1> write </h1> </body> </html> ;
-
-: error-head ( error -- )
-    response
-    H{ { "Content-Type" V{ "text/html" } } } print-header nl ;
-
-: httpd-error ( error -- )
-    #! This must be run from handle-request
-    dup error-head
-    "head" "method" get = [ drop ] [ error-body ] if ;
-
-\ httpd-error ERROR add-error-logging
-
-: bad-request ( -- )
-    [
-        ! Make httpd-error print a body
-        "get" "method" set
-        "400 Bad request" httpd-error
-    ] with-scope ;
-
-: serving-content ( mime -- )
-    "200 Document follows" response
-    "Content-Type" >header print-header ;
-
-: serving-html "text/html" serving-content ;
-
-: serve-html ( quot -- )
-    serving-html with-html-stream ;
-
-: serving-text "text/plain" serving-content ;
-
-: redirect ( to response -- )
-    response "Location" >header print-header ;
-
-: permanent-redirect ( to -- )
-    "301 Moved Permanently" redirect ;
-
-: temporary-redirect ( to -- )
-    "307 Temporary Redirect" redirect ;
-
-: directory-no/ ( -- )
-    [
-        "request" get % CHAR: / ,
-        "raw-query" get [ CHAR: ? , % ] when*
-    ] "" make permanent-redirect ;
-
-: query>hash ( query -- hash )
-    dup [
-        "&" split [
-            "=" split1 [ dup [ url-decode ] when ] 2apply 2array
-        ] map
-    ] when >hashtable ;
-
-SYMBOL: max-post-request
-
-1024 256 * max-post-request set-global
-
-: content-length ( header -- n )
-    "content-length" swap peek-at string>number dup [
-        dup max-post-request get > [
-            "Content-Length > max-post-request" throw
-        ] when
-    ] when ;
-
-: read-post-request ( header -- str hash )
-    content-length [ read dup query>hash ] [ f f ] if* ;
-
-LOG: log-headers DEBUG
-
-: interesting-headers ( assoc -- string )
-    [
-        [
-            drop {
-                "user-agent"
-                "referer"
-                "x-forwarded-for"
-                "host"
-            } member?
-        ] assoc-subset [
-            ": " swap 3append % "\n" %
-        ] multi-assoc-each
-    ] "" make ;
-
-: prepare-url ( url -- url )
-    #! This is executed in the with-request namespace.
-    "?" split1
-    dup "raw-query" set query>hash "query" set
-    dup "request" set ;
-
-: prepare-header ( -- )
-    read-header
-    dup "header" set
-    dup interesting-headers log-headers
-    read-post-request "response" set "raw-response" set ;
-
-! Responders are called in a new namespace with these
-! variables:
-
-! - method -- one of get, post, or head.
-! - request -- the entire URL requested, including responder
-!              name
-! - responder-url -- the component of the URL for the responder
-! - raw-query -- raw query string
-! - query -- a hashtable of query parameters, eg
-!            foo.bar?a=b&c=d becomes
-!            H{ { "a" "b" } { "c" "d" } }
-! - header -- a hashtable of headers from the user's client
-! - response -- a hashtable of the POST request response
-! - raw-response -- raw POST request response
-
-: query-param ( key -- value ) "query" get at ;
-
-: header-param ( key -- value )
-    "header" get peek-at ;
-
-: host ( -- string )
-    #! The host the current responder was called from.
-    "host" header-param ":" split1 drop ;
-
-: add-responder ( responder -- )
-    #! Add a responder object to the list.
-    "responder" over at responders get set-at ;
-
-: make-responder ( quot -- )
-    #! quot has stack effect ( url -- )
-    [
-        [
-            drop "GET method not implemented" httpd-error
-        ] "get" set
-        [
-            drop "POST method not implemented" httpd-error
-        ] "post" set
-        [
-            drop "HEAD method not implemented" httpd-error
-        ] "head" set
-        [
-            drop bad-request
-        ] "bad" set
-        
-        call
-    ] H{ } make-assoc add-responder ;
-
-: add-simple-responder ( name quot -- )
-    [
-        [ drop ] swap append dup "get" set "post" set
-        "responder" set
-    ] make-responder ;
-
-: vhost ( name -- vhost )
-    vhosts get at [ "default" vhost ] unless* ;
-
-: responder ( name -- responder )
-    responders get at [ "404" responder ] unless* ;
-
-: set-default-responder ( name -- )
-    responder "default" responders get set-at ;
-
-: call-responder ( method argument responder -- )
-    over "argument" set [ swap get with-scope ] bind ;
-
-: serve-default-responder ( method url -- )
-    "/" "responder-url" set
-    "default" responder call-responder ;
-
-: trim-/ ( url -- url )
-    #! Trim a leading /, if there is one.
-    "/" ?head drop ;
-
-: serve-explicit-responder ( method url -- )
-    "/" split1
-    "/responder/" pick "/" 3append "responder-url" set
-    dup [
-        swap responder call-responder
-    ] [
-        ! Just a responder name by itself
-        drop "request" get "/" append permanent-redirect 2drop
-    ] if ;
-
-: serve-responder ( method path host -- )
-    #! Responder paths come in two forms:
-    #! /foo/bar... - default responder used
-    #! /responder/foo/bar - responder foo, argument bar
-    vhost [
-        trim-/ "responder/" ?head [
-            serve-explicit-responder
-        ] [
-            serve-default-responder
-        ] if
-    ] bind ;
-
-\ serve-responder DEBUG add-input-logging
-
-: no-such-responder ( -- )
-    "404 No such responder" httpd-error ;
-
-! create a responders hash if it doesn't already exist
-global [
-    responders [ H{ } assoc-like ] change
-    
-    ! 404 error message pages are served by this guy
-    "404" [ no-such-responder ] add-simple-responder
-    
-    H{ } clone "default" associate vhosts set
-] bind
diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor
index 627d7d889d..0635e1f895 100755
--- a/extra/http/server/server-tests.factor
+++ b/extra/http/server/server-tests.factor
@@ -1,39 +1,61 @@
-USING: webapps.file http.server.responders http
-http.server namespaces io tools.test strings io.server
-logging ;
+USING: http.server tools.test kernel namespaces accessors
+new-slots io http math sequences assocs ;
 IN: http.server.tests
 
-[ ] [ f [ "404 not found" httpd-error ] with-logging ] unit-test
+TUPLE: mock-responder path ;
 
-[ "inspect/global" ] [ "/inspect/global" trim-/ ] unit-test
+C: <mock-responder> mock-responder
 
-[ "index.html" ]
-[ "http://www.jedit.org/index.html" url>path ] unit-test
+M: mock-responder call-responder
+    2nip
+    path>> on
+    "text/plain" <content> ;
 
-[ "foo/bar" ]
-[ "http://www.jedit.org/foo/bar" url>path ] unit-test
+: check-dispatch ( tag path -- ? )
+    over off
+    <request> swap default-host get call-responder
+    write-response get ;
 
-[ "" ]
-[ "http://www.jedit.org/" url>path ] unit-test
+[
+    <dispatcher>
+        "foo" <mock-responder> "foo" add-responder
+        "bar" <mock-responder> "bar" add-responder
+        <dispatcher>
+            "123" <mock-responder> "123" add-responder
+            "default" <mock-responder> >>default
+        "baz" add-responder
+    default-host set
 
-[ "" ]
-[ "http://www.jedit.org" url>path ] unit-test
+    [ "foo" ] [
+        "foo" default-host get find-responder path>> nip
+    ] unit-test
 
-[ "foobar" ]
-[ "foobar" secure-path ] unit-test
+    [ "bar" ] [
+        "bar" default-host get find-responder path>> nip
+    ] unit-test
 
-[ f ]
-[ "foobar/../baz" secure-path ] unit-test
+    [ t ] [ "foo" "foo" check-dispatch ] unit-test
+    [ f ] [ "foo" "bar" check-dispatch ] unit-test
+    [ t ] [ "bar" "bar" check-dispatch ] unit-test
+    [ t ] [ "default" "baz/xxx" check-dispatch ] unit-test
+    [ t ] [ "default" "baz/xxx//" check-dispatch ] unit-test
+    [ t ] [ "default" "/baz/xxx//" check-dispatch ] unit-test
+    [ t ] [ "123" "baz/123" check-dispatch ] unit-test
+    [ t ] [ "123" "baz///123" check-dispatch ] unit-test
 
-[ ] [ f [ "GET ../index.html" parse-request ] with-logging ] unit-test
-[ ] [ f [ "POO" parse-request ] with-logging ] unit-test
+    [ t ] [
+        <request>
+        "baz" >>path
+        "baz" default-host get call-responder
+        dup code>> 300 399 between? >r
+        header>> "location" swap at "baz/" tail? r> and
+    ] unit-test
+] with-scope
 
-[ H{ { "Foo" "Bar" } } ] [ "Foo=Bar" query>hash ] unit-test
+[
+    <dispatcher>
+        "default" <mock-responder> >>default
+    default-host set
 
-[ H{ { "Foo" "Bar" } { "Baz" "Quux" } } ]
-[ "Foo=Bar&Baz=Quux" query>hash ] unit-test
-
-[ H{ { "Baz" " " } } ]
-[ "Baz=%20" query>hash ] unit-test
-
-[ H{ { "Foo" f } } ] [ "Foo" query>hash ] unit-test
+    [ "/default" ] [ "/default" default-host get find-responder drop ] unit-test
+] with-scope
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index a2f5c3474b..f397b280d0 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -1,65 +1,170 @@
 ! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs kernel namespaces io io.timeouts strings splitting
-threads http http.server.responders sequences prettyprint
-io.server logging calendar ;
-
+threads http sequences prettyprint io.server logging calendar
+new-slots html.elements accessors math.parser combinators.lib
+vocabs.loader debugger html continuations random combinators ;
 IN: http.server
 
-: (url>path) ( uri -- path )
-    url-decode "http://" ?head [
-        "/" split1 dup "" ? nip
-    ] when ;
+GENERIC: call-responder ( request path responder -- response )
 
-: url>path ( uri -- path )
-    "?" split1 dup [
-      >r (url>path) "?" r> 3append
-    ] [
-      drop (url>path)
-    ] if ;
+TUPLE: trivial-responder response ;
 
-: secure-path ( path -- path )
-    ".." over subseq? [ drop f ] when ;
+C: <trivial-responder> trivial-responder
 
-: request-method ( cmd -- method )
-    H{
-        { "GET" "get" }
-        { "POST" "post" }
-        { "HEAD" "head" }
-    } at "bad" or ;
+M: trivial-responder call-responder nip response>> call ;
 
-: (handle-request) ( arg cmd -- method path host )
-    request-method dup "method" set swap
-    prepare-url prepare-header host ;
+: trivial-response-body ( code message -- )
+    <html>
+        <body>
+            <h1> swap number>string write bl write </h1>
+        </body>
+    </html> ;
 
-: handle-request ( arg cmd -- )
-    [ (handle-request) serve-responder ] with-scope ;
+: <trivial-response> ( code message -- response )
+    <response>
+    2over [ trivial-response-body ] 2curry >>body
+    "text/html" set-content-type
+    swap >>message
+    swap >>code ;
 
-: parse-request ( request -- )
-    " " split1 dup [
-        " HTTP" split1 drop url>path secure-path dup [
-            swap handle-request
+: <400> ( -- response )
+    400 "Bad request" <trivial-response> ;
+
+: <404> ( -- response )
+    404 "Not Found" <trivial-response> ;
+
+SYMBOL: 404-responder
+
+[ drop <404> ] <trivial-responder> 404-responder set-global
+
+: modify-for-redirect ( request to -- url )
+    {
+        { [ dup "http://" head? ] [ nip ] }
+        { [ dup "/" head? ] [ >>path request-url ] }
+        { [ t ] [ >r dup path>> "/" last-split1 drop "/" r> 3append >>path request-url ] }
+    } cond ;
+
+: <redirect> ( request to code message -- response )
+    <trivial-response>
+    -rot modify-for-redirect
+    "location" set-header ;
+
+\ <redirect> DEBUG add-input-logging
+
+: <permanent-redirect> ( request to -- response )
+    301 "Moved Permanently" <redirect> ;
+
+: <temporary-redirect> ( request to -- response )
+    307 "Temporary Redirect" <redirect> ;
+
+: <content> ( content-type -- response )
+    <response>
+    200 >>code
+    swap set-content-type ;
+
+TUPLE: dispatcher default responders ;
+
+: <dispatcher> ( -- dispatcher )
+    404-responder H{ } clone dispatcher construct-boa ;
+
+: set-main ( dispatcher name -- dispatcher )
+    [ <permanent-redirect> ] curry
+    <trivial-responder> >>default ;
+
+: split-path ( path -- rest first )
+    [ CHAR: / = ] left-trim "/" split1 swap ;
+
+: find-responder ( path dispatcher -- path responder )
+    over split-path pick responders>> at*
+    [ >r >r 2drop r> r> ] [ 2drop default>> ] if ;
+
+: redirect-with-/ ( request -- response )
+    dup path>> "/" append <permanent-redirect> ;
+
+M: dispatcher call-responder
+    over [
+        3dup find-responder call-responder [
+            >r 3drop r>
         ] [
-            2drop bad-request
-        ] if
+            default>> [
+                call-responder
+            ] [
+                3drop f
+            ] if*
+        ] if*
     ] [
-        2drop bad-request
+        2drop redirect-with-/
     ] if ;
 
-\ parse-request NOTICE add-input-logging
+: add-responder ( dispatcher responder path -- dispatcher )
+    pick responders>> set-at ;
+
+: add-main-responder ( dispatcher responder path -- dispatcher )
+    [ add-responder ] keep set-main ;
+
+: <webapp> ( class -- dispatcher )
+    <dispatcher> swap construct-delegate ; inline
+
+SYMBOL: virtual-hosts
+SYMBOL: default-host
+
+virtual-hosts global [ drop H{ } clone ] cache drop
+default-host global [ drop 404-responder get-global ] cache drop
+
+: find-virtual-host ( host -- responder )
+    virtual-hosts get at [ default-host get ] unless* ;
+
+SYMBOL: development-mode
+
+: <500> ( error -- response )
+    500 "Internal server error" <trivial-response>
+    swap [
+        "Internal server error" [
+            development-mode get [
+                [ print-error nl :c ] with-html-stream
+            ] [
+                500 "Internal server error"
+                trivial-response-body
+            ] if
+        ] simple-page
+    ] curry >>body ;
+
+: do-response ( request response -- )
+    dup write-response
+    swap method>> "HEAD" =
+    [ drop ] [ write-response-body ] if ;
+
+: do-request ( request -- request )
+    [
+        dup dup path>> over host>>
+        find-virtual-host call-responder
+        [ <404> ] unless*
+    ] [ dup \ do-request log-error <500> ] recover ;
+
+: default-timeout 1 minutes stdio get set-timeout ;
+
+LOG: httpd-hit NOTICE
+
+: log-request ( request -- )
+    { method>> host>> path>> } map-exec-with httpd-hit ;
+
+: handle-client ( -- )
+    default-timeout
+    development-mode get-global
+    [ global [ refresh-all ] bind ] when
+    read-request
+    dup log-request
+    do-request do-response ;
 
 : httpd ( port -- )
-    internet-server "http.server" [
-        1 minutes stdio get set-timeout
-        readln [ parse-request ] when*
-    ] with-server ;
+    internet-server "http.server"
+    [ handle-client ] with-server ;
 
 : httpd-main ( -- ) 8888 httpd ;
 
 MAIN: httpd-main
 
-! Load default webapps
-USE: webapps.file
-USE: webapps.callback
-USE: webapps.continuation
-USE: webapps.cgi
+: generate-key ( assoc -- str )
+    4 big-random >hex dup pick key?
+    [ drop generate-key ] [ nip ] if ;
diff --git a/extra/http/server/sessions/authors.txt b/extra/http/server/sessions/authors.txt
new file mode 100755
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/extra/http/server/sessions/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor
new file mode 100755
index 0000000000..4c21ba3c8d
--- /dev/null
+++ b/extra/http/server/sessions/sessions-tests.factor
@@ -0,0 +1,34 @@
+IN: http.server.sessions.tests
+USING: tools.test http.server.sessions math namespaces
+kernel accessors ;
+
+: with-session \ session swap with-variable ; inline
+
+"1234" f <session> [
+    [ ] [ 3 "x" sset ] unit-test
+    
+    [ 9 ] [ "x" sget sq ] unit-test
+    
+    [ ] [ "x" [ 1- ] schange ] unit-test
+    
+    [ 4 ] [ "x" sget sq ] unit-test
+] with-session
+
+[ t ] [ f <url-sessions> url-sessions? ] unit-test
+[ t ] [ f <cookie-sessions> cookie-sessions? ] unit-test
+
+[ ] [
+    f <url-sessions>
+        [ 0 "x" sset ] >>init
+    "manager" set
+] unit-test
+
+[ { 5 0 } ] [
+    [
+        "manager" get new-session
+        dup "manager" get get-session [ 5 "a" sset ] with-session
+        dup "manager" get get-session [ "a" sget , ] with-session
+        dup "manager" get get-session [ "x" sget , ] with-session
+        "manager" get get-session delete-session
+    ] { } make
+] unit-test
diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor
new file mode 100755
index 0000000000..2977e5938d
--- /dev/null
+++ b/extra/http/server/sessions/sessions.factor
@@ -0,0 +1,112 @@
+! Copyright (C) 2008 Doug Coleman, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs calendar kernel math.parser namespaces random
+boxes alarms new-slots accessors http http.server
+quotations hashtables sequences ;
+IN: http.server.sessions
+
+! ! ! ! ! !
+! WARNING: this session manager is vulnerable to XSRF attacks
+! ! ! ! ! !
+
+GENERIC: init-session ( responder -- )
+
+TUPLE: session-manager responder sessions ;
+
+: <session-manager> ( responder class -- responder' )
+    >r H{ } clone session-manager construct-boa r>
+    construct-delegate ; inline
+
+TUPLE: session id manager namespace alarm ;
+
+: <session> ( id manager -- session )
+    H{ } clone <box> \ session construct-boa ;
+
+: timeout ( -- dt ) 20 minutes ;
+
+: cancel-timeout ( session -- )
+    alarm>> [ cancel-alarm ] if-box? ;
+
+: delete-session ( session -- )
+    dup cancel-timeout
+    dup manager>> sessions>> delete-at ;
+
+: touch-session ( session -- )
+    dup cancel-timeout
+    dup [ delete-session ] curry timeout later
+    swap session-alarm >box ;
+
+: session ( -- assoc ) \ session get namespace>> ;
+
+: sget ( key -- value ) session at ;
+
+: sset ( value key -- ) session set-at ;
+
+: schange ( key quot -- ) session swap change-at ; inline
+
+: new-session ( responder -- id )
+    [ sessions>> generate-key dup ] keep
+    [ <session> dup touch-session ] keep
+    [ swap \ session [ responder>> init-session ] with-variable ] 2keep
+    >r over r> sessions>> set-at ;
+
+: get-session ( id responder -- session )
+    sessions>> tuck at* [
+        nip dup touch-session
+    ] [
+        2drop f
+    ] if ;
+
+: call-responder/session ( request path responder session -- response )
+    \ session set responder>> call-responder ;
+
+: sessions ( -- manager/f )
+    \ session get dup [ manager>> ] when ;
+
+GENERIC: session-link* ( url query sessions -- string )
+
+M: object session-link* 2drop url-encode ;
+
+: session-link ( url query -- string ) sessions session-link* ;
+
+TUPLE: url-sessions ;
+
+: <url-sessions> ( responder -- responder' )
+    url-sessions <session-manager> ;
+
+: sess-id "factorsessid" ;
+
+M: url-sessions call-responder ( request path responder -- response )
+    pick sess-id query-param over get-session [
+        call-responder/session
+    ] [
+        new-session nip sess-id set-query-param
+        dup request-url <temporary-redirect>
+    ] if* ;
+
+M: url-sessions session-link*
+    drop
+    \ session get id>> sess-id associate union assoc>query
+    >r url-encode r>
+    dup assoc-empty? [ drop ] [ "?" swap 3append ] if ;
+
+TUPLE: cookie-sessions ;
+
+: <cookie-sessions> ( responder -- responder' )
+    cookie-sessions <session-manager> ;
+
+: get-session-cookie ( request responder -- cookie )
+    >r sess-id get-cookie dup
+    [ value>> r> get-session ] [ r> 2drop f ] if ;
+
+: <session-cookie> ( id -- cookie )
+    sess-id <cookie> ;
+
+M: cookie-sessions call-responder ( request path responder -- response )
+    3dup nip get-session-cookie [
+        call-responder/session
+    ] [
+        dup new-session
+        [ over get-session call-responder/session ] keep
+        <session-cookie> put-cookie
+    ] if* ;
diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor
new file mode 100755
index 0000000000..8d47d38eb1
--- /dev/null
+++ b/extra/http/server/static/static.factor
@@ -0,0 +1,101 @@
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: calendar html io io.files kernel math math.parser http
+http.server namespaces parser sequences strings assocs
+hashtables debugger http.mime sorting html.elements logging
+calendar.format new-slots accessors ;
+IN: http.server.static
+
+SYMBOL: responder
+
+! special maps mime types to quots with effect ( path -- )
+TUPLE: file-responder root hook special ;
+
+: unix-time>timestamp ( n -- timestamp )
+    >r unix-1970 r> seconds time+ ;
+
+: file-http-date ( filename -- string )
+    file-modified unix-time>timestamp timestamp>http-string ;
+
+: last-modified-matches? ( filename -- ? )
+    file-http-date dup [
+        request get "if-modified-since" header =
+    ] when ;
+
+: <304> ( -- response )
+    304 "Not modified" <trivial-response> ;
+
+: <file-responder> ( root hook -- responder )
+    H{ } clone file-responder construct-boa ;
+
+: <static> ( root -- responder )
+    [
+        <content>
+        over file-length "content-length" set-header
+        over file-http-date "last-modified" set-header
+        swap [ <file-reader> stdio get stream-copy ] curry >>body
+    ] <file-responder> ;
+
+: serve-static ( filename mime-type -- response )
+    over last-modified-matches?
+    [ 2drop <304> ] [ responder get hook>> call ] if ;
+
+: serving-path ( filename -- filename )
+    "" or responder get root>> swap path+ ;
+
+: serve-file ( filename -- response )
+    dup mime-type
+    dup responder get special>> at
+    [ call ] [ serve-static ] ?if ;
+
+\ serve-file NOTICE add-input-logging
+
+: file. ( name dirp -- )
+    [ "/" append ] when
+    dup <a =href a> write </a> ;
+
+: directory. ( path -- )
+    dup file-name [
+        <h1> dup file-name write </h1>
+        <ul>
+            directory sort-keys
+            [ <li> file. </li> ] assoc-each
+        </ul>
+    ] simple-html-document ;
+
+: list-directory ( directory -- response )
+    "text/html" <content>
+    swap [ directory. ] curry >>body ;
+
+: find-index ( filename -- path )
+    { "index.html" "index.fhtml" }
+    [ dupd path+ exists? ] find nip
+    dup [ path+ ] [ nip ] if ;
+
+: serve-directory ( filename -- response )
+    dup "/" tail? [
+        dup find-index
+        [ serve-file ] [ list-directory ] ?if
+    ] [
+        drop request get redirect-with-/
+    ] if ;
+
+: serve-object ( filename -- response )
+    serving-path dup exists? [
+        dup directory? [ serve-directory ] [ serve-file ] if
+    ] [
+        drop <404>
+    ] if ;
+
+M: file-responder call-responder ( request path responder -- response )
+    over [
+        ".." pick subseq? [
+            3drop <400>
+        ] [
+            responder set
+            swap request set
+            serve-object
+        ] if
+    ] [
+        2drop redirect-with-/
+    ] if ;
diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor
index 4c451f7f6e..b298faca74 100755
--- a/extra/http/server/templating/templating.factor
+++ b/extra/http/server/templating/templating.factor
@@ -4,7 +4,8 @@
 USING: continuations sequences kernel parser namespaces io
 io.files io.streams.lines io.streams.string html html.elements
 source-files debugger combinators math quotations generic
-strings splitting ;
+strings splitting accessors http.server.static http.server
+assocs ;
 
 IN: http.server.templating
 
@@ -93,3 +94,13 @@ DEFER: <% delimiter
 
 : template-convert ( infile outfile -- )
     [ run-template-file ] with-file-writer ;
+
+! file responder integration
+: serve-fhtml ( filename -- response )
+    "text/html" <content>
+    swap [ run-template-file ] curry >>body ;
+
+: enable-fhtml ( responder -- responder )
+    [ serve-fhtml ]
+    "application/x-factor-server-page"
+    pick special>> set-at ;
diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor
index 96639dee87..31d7e7a60d 100755
--- a/extra/io/launcher/launcher-docs.factor
+++ b/extra/io/launcher/launcher-docs.factor
@@ -35,33 +35,43 @@ HELP: +environment-mode+
 HELP: +stdin+
 { $description "Launch descriptor key. Must equal one of the following:"
     { $list
-        { { $link f } " - standard input is inherited" }
+        { { $link f } " - standard input is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
+        { { $link +inherit+ } " - standard input is inherited from the current process" }
         { { $link +closed+ } " - standard input is closed" }
         { "a path name - standard input is read from the given file, which must exist" }
+        { "a file stream or a socket - standard input is read from the given stream, which must be closed after the process has been started" }
     }
 } ;
 
 HELP: +stdout+
 { $description "Launch descriptor key. Must equal one of the following:"
     { $list
-        { { $link f } " - standard output is inherited" }
+        { { $link f } " - standard output is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
+        { { $link +inherit+ } " - standard output is inherited from the current process" }
         { { $link +closed+ } " - standard output is closed" }
         { "a path name - standard output is written to the given file, which is overwritten if it already exists" }
+        { "a file stream or a socket - standard output is written to the given stream, which must be closed after the process has been started" }
     }
 } ;
 
 HELP: +stderr+
 { $description "Launch descriptor key. Must equal one of the following:"
     { $list
-        { { $link f } " - standard error is inherited" }
+        { { $link f } " - standard error is inherited from the current process" }
+        { { $link +inherit+ } " - same as above" }
+        { { $link +stdout+ } " - standard error is merged with standard output" }
         { { $link +closed+ } " - standard error is closed" }
         { "a path name - standard error is written to the given file, which is overwritten if it already exists" }
+        { "a file stream or a socket - standard error is written to the given stream, which must be closed after the process has been started" }
     }
 } ;
 
 HELP: +closed+
 { $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ;
 
+HELP: +inherit+
+{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ;
+
 HELP: +prepend-environment+
 { $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence."
 $nl
diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor
index cd9bb9baef..a4a3122b4d 100755
--- a/extra/io/windows/nt/launcher/launcher.factor
+++ b/extra/io/windows/nt/launcher/launcher.factor
@@ -1,18 +1,38 @@
-! Copyright (C) 2007 Doug Coleman, Slava Pestov.
+! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types arrays continuations destructors io
 io.windows libc io.nonblocking io.streams.duplex windows.types
 math windows.kernel32 windows namespaces io.launcher kernel
 sequences windows.errors assocs splitting system strings
 io.windows.launcher io.windows.nt.pipes io.backend
-combinators ;
+combinators shuffle ;
 IN: io.windows.nt.launcher
 
+: duplicate-handle ( handle -- handle' )
+    GetCurrentProcess ! source process
+    swap ! handle
+    GetCurrentProcess ! target process
+    f <void*> [ ! target handle
+        DUPLICATE_SAME_ACCESS ! desired access
+        TRUE ! inherit handle
+        DUPLICATE_CLOSE_SOURCE ! options
+        DuplicateHandle win32-error=0/f
+    ] keep *void* ;
+
 ! The below code is based on the example given in
 ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
 
-: (redirect) ( path access-mode create-mode -- handle )
-    >r >r
+: redirect-default ( default obj access-mode create-mode -- handle )
+    3drop ;
+
+: redirect-inherit ( default obj access-mode create-mode -- handle )
+    4drop f ;
+
+: redirect-closed ( default obj access-mode create-mode -- handle )
+    drop 2nip null-pipe ;
+
+: redirect-file ( default path access-mode create-mode -- handle )
+    >r >r >r drop r>
     normalize-pathname
     r> ! access-mode
     share-mode
@@ -22,47 +42,59 @@ IN: io.windows.nt.launcher
     f ! template file
     CreateFile dup invalid-handle? dup close-later ;
 
-: redirect ( obj access-mode create-mode -- handle )
-    {
-        { [ pick not ] [ 3drop f ] }
-        { [ pick +closed+ eq? ] [ drop nip null-pipe ] }
-        { [ pick string? ] [ (redirect) ] }
-    } cond ;
-
-: ?closed or dup t eq? [ drop f ] when ;
-
-: inherited-stdout ( args -- handle )
-    CreateProcess-args-stdout-pipe
-    [ pipe-out ] [ STD_OUTPUT_HANDLE GetStdHandle ] if* ;
-
-: redirect-stdout ( args -- handle )
-    +stdout+ get GENERIC_WRITE CREATE_ALWAYS redirect
-    swap inherited-stdout ?closed ;
-
-: inherited-stderr ( args -- handle )
-    drop STD_ERROR_HANDLE GetStdHandle ;
-
-: redirect-stderr ( args -- handle )
-    +stderr+ get
-    dup +stdout+ eq? [
-        drop
-        CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput
-    ] [
-        GENERIC_WRITE CREATE_ALWAYS redirect
-        swap inherited-stderr ?closed
-    ] if ;
-
-: inherited-stdin ( args -- handle )
-    CreateProcess-args-stdin-pipe
-    [ pipe-in ] [ STD_INPUT_HANDLE GetStdHandle ] if* ;
-
-: redirect-stdin ( args -- handle )
-    +stdin+ get GENERIC_READ OPEN_EXISTING redirect
-    swap inherited-stdin ?closed ;
-
 : set-inherit ( handle ? -- )
     >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
 
+: redirect-stream ( default stream access-mode create-mode -- handle )
+    2drop nip
+    underlying-handle win32-file-handle
+    duplicate-handle dup t set-inherit ;
+
+: redirect ( default obj access-mode create-mode -- handle )
+    {
+        { [ pick not ] [ redirect-default ] }
+        { [ pick +inherit+ eq? ] [ redirect-inherit ] }
+        { [ pick +closed+ eq? ] [ redirect-closed ] }
+        { [ pick string? ] [ redirect-file ] }
+        { [ t ] [ redirect-stream ] }
+    } cond ;
+
+: default-stdout ( args -- handle )
+    CreateProcess-args-stdout-pipe dup [ pipe-out ] when ;
+
+: redirect-stdout ( args -- handle )
+    default-stdout
+    +stdout+ get
+    GENERIC_WRITE
+    CREATE_ALWAYS
+    redirect
+    STD_OUTPUT_HANDLE GetStdHandle or ;
+
+: redirect-stderr ( args -- handle )
+    +stderr+ get +stdout+ eq? [
+        CreateProcess-args-lpStartupInfo
+        STARTUPINFO-hStdOutput
+    ] [
+        drop
+        f
+        +stderr+ get
+        GENERIC_WRITE
+        CREATE_ALWAYS
+        redirect
+        STD_ERROR_HANDLE GetStdHandle or
+    ] if ;
+
+: default-stdin ( args -- handle )
+    CreateProcess-args-stdin-pipe dup [ pipe-in ] when ;
+
+: redirect-stdin ( args -- handle )
+    default-stdin
+    +stdin+ get
+    GENERIC_READ
+    OPEN_EXISTING
+    redirect
+    STD_INPUT_HANDLE GetStdHandle or ;
+
 : add-pipe-dtors ( pipe -- )
     dup
     pipe-in close-later
diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor
index 38b7d4829c..291bef6018 100755
--- a/extra/io/windows/windows.factor
+++ b/extra/io/windows/windows.factor
@@ -55,7 +55,7 @@ M: win32-file close-handle ( handle -- )
 : open-file ( path access-mode create-mode flags -- handle )
     [
         >r >r >r normalize-pathname r>
-        share-mode f r> r> CreateFile-flags f CreateFile
+        share-mode security-attributes-inherit r> r> CreateFile-flags f CreateFile
         dup invalid-handle? dup close-later
         dup add-completion
     ] with-destructors ;
diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor
index 2e6fd6485d..5f58f1464a 100755
--- a/extra/locals/locals.factor
+++ b/extra/locals/locals.factor
@@ -279,7 +279,7 @@ MACRO: with-locals ( form -- quot ) lambda-rewrite ;
 ! are unified
 : create-method ( class generic -- method )
     2dup method dup
-    [ 2nip method-word ]
+    [ 2nip ]
     [ drop 2dup [ ] -rot define-method create-method ] if ;
 
 : CREATE-METHOD ( -- class generic body )
@@ -367,16 +367,16 @@ M: lambda-method definer drop \ M:: \ ; ;
 M: lambda-method definition
     "lambda" word-prop lambda-body ;
 
-: method-stack-effect
+: method-stack-effect ( method -- effect )
     dup "lambda" word-prop lambda-vars
-    swap "method" word-prop method-generic stack-effect dup [ effect-out ] when
+    swap "method-generic" word-prop stack-effect
+    dup [ effect-out ] when
     <effect> ;
 
 M: lambda-method synopsis*
-    dup definer.
-    dup "method" word-prop dup
-        method-specializer pprint*
-        method-generic pprint*
+    dup dup dup definer.
+    "method-specializer" word-prop pprint*
+    "method-generic" word-prop pprint*
     method-stack-effect effect>string comment. ;
 
 PRIVATE>
diff --git a/extra/logging/insomniac/insomniac-docs.factor b/extra/logging/insomniac/insomniac-docs.factor
old mode 100644
new mode 100755
index 64ac3b4ff6..93485e4c7c
--- a/extra/logging/insomniac/insomniac-docs.factor
+++ b/extra/logging/insomniac/insomniac-docs.factor
@@ -27,7 +27,7 @@ HELP: schedule-insomniac
 { $values { "alist" "a sequence of pairs of shape " { $snippet "{ service word-names }" } } }
 { $description "Starts a thread which e-mails log reports and rotates logs daily." } ;
 
-ARTICLE: "logging.insomniac" "Automating log analysis and rotation"
+ARTICLE: "logging.insomniac" "Automated log analysis"
 "The " { $vocab-link "logging.insomniac" } " vocabulary builds on the " { $vocab-link "logging.analysis" } " vocabulary. It provides support for e-mailing log reports and rotating logs on a daily basis. E-mails are sent using the " { $vocab-link "smtp" } " vocabulary."
 $nl
 "Required configuration parameters:"
diff --git a/extra/logging/logging-docs.factor b/extra/logging/logging-docs.factor
old mode 100644
new mode 100755
index 939388026d..715b1551b9
--- a/extra/logging/logging-docs.factor
+++ b/extra/logging/logging-docs.factor
@@ -115,9 +115,9 @@ ARTICLE: "logging" "Logging framework"
 { $subsection "logging.levels" }
 { $subsection "logging.messages" }
 { $subsection "logging.rotation" }
-{ $subsection "logging.parser" }
-{ $subsection "logging.analysis" }
-{ $subsection "logging.insomniac" }
+{ $vocab-subsection "Log file parser" "logging.parser" }
+{ $vocab-subsection "Log analysis" "logging.analysis" }
+{ $vocab-subsection "Automated log analysis" "logging.insomniac" }
 { $subsection "logging.server" } ;
 
 ABOUT: "logging"
diff --git a/extra/tools/crossref/crossref-tests.factor b/extra/tools/crossref/crossref-tests.factor
index a277a68ed7..0717763ed0 100755
--- a/extra/tools/crossref/crossref-tests.factor
+++ b/extra/tools/crossref/crossref-tests.factor
@@ -8,5 +8,5 @@ M: integer foo + ;
 
 "resource:extra/tools/crossref/test/foo.factor" run-file
 
-[ t ] [ integer \ foo method method-word \ + usage member? ] unit-test
+[ t ] [ integer \ foo method \ + usage member? ] unit-test
 [ t ] [ \ foo usage [ pathname? ] contains? ] unit-test
diff --git a/extra/tools/deploy/shaker/strip-cocoa.factor b/extra/tools/deploy/shaker/strip-cocoa.factor
index 2eddce6475..b37e42f323 100755
--- a/extra/tools/deploy/shaker/strip-cocoa.factor
+++ b/extra/tools/deploy/shaker/strip-cocoa.factor
@@ -1,5 +1,6 @@
 USING: cocoa cocoa.messages cocoa.application cocoa.nibs
-assocs namespaces kernel words compiler sequences ui.cocoa ;
+assocs namespaces kernel words compiler.units sequences
+ui.cocoa ;
 
 "stop-after-last-window?" get
 global [
diff --git a/extra/tools/profiler/profiler.factor b/extra/tools/profiler/profiler.factor
index 784c9e8da6..467fcc14f4 100755
--- a/extra/tools/profiler/profiler.factor
+++ b/extra/tools/profiler/profiler.factor
@@ -29,9 +29,8 @@ M: string (profile.)
     dup <vocab-profile> write-object ;
 
 M: method-body (profile.)
-    "method" word-prop
-    dup method-specializer over method-generic 2array synopsis
-    swap method-generic <usage-profile> write-object ;
+    dup synopsis swap "method-generic" word-prop
+    <usage-profile> write-object ;
 
 : counter. ( obj n -- )
     [
diff --git a/extra/webapps/cgi/authors.txt b/extra/webapps/cgi/authors.txt
deleted file mode 100755
index 1901f27a24..0000000000
--- a/extra/webapps/cgi/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/extra/webapps/cgi/cgi.factor b/extra/webapps/cgi/cgi.factor
deleted file mode 100755
index 5dba9dae00..0000000000
--- a/extra/webapps/cgi/cgi.factor
+++ /dev/null
@@ -1,75 +0,0 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces kernel assocs io.files combinators
-arrays io.launcher io http.server.responders webapps.file
-sequences strings math.parser unicode.case ;
-IN: webapps.cgi
-
-SYMBOL: cgi-root
-
-: post? "method" get "post" = ;
-
-: cgi-variables ( script-path -- assoc )
-    #! This needs some work.
-    [
-        "CGI/1.0" "GATEWAY_INTERFACE" set
-        "HTTP/1.0" "SERVER_PROTOCOL" set
-        "Factor" "SERVER_SOFTWARE" set
-
-        dup "PATH_TRANSLATED" set
-        "SCRIPT_FILENAME" set
-
-        "request" get "SCRIPT_NAME" set
-
-        host "SERVER_NAME" set
-        "" "SERVER_PORT" set
-        "" "PATH_INFO" set
-        "" "REMOTE_HOST" set
-        "" "REMOTE_ADDR" set
-        "" "AUTH_TYPE" set
-        "" "REMOTE_USER" set
-        "" "REMOTE_IDENT" set
-
-        "method" get >upper "REQUEST_METHOD" set
-        "raw-query" get "QUERY_STRING" set
-        "cookie" header-param "HTTP_COOKIE" set 
-
-        "user-agent" header-param "HTTP_USER_AGENT" set
-        "accept" header-param "HTTP_ACCEPT" set
-
-        post? [
-            "content-type" header-param "CONTENT_TYPE" set
-            "raw-response" get length number>string "CONTENT_LENGTH" set
-        ] when
-    ] H{ } make-assoc ;
-
-: cgi-descriptor ( name -- desc )
-    [
-        cgi-root get swap path+ dup 1array +arguments+ set
-        cgi-variables +environment+ set
-    ] H{ } make-assoc ;
-    
-: (do-cgi) ( name -- )
-    "200 CGI output follows" response
-    stdio get swap cgi-descriptor <process-stream> [
-        post? [
-            "raw-response" get write flush
-        ] when
-        stdio get swap (stream-copy)
-    ] with-stream ;
-
-: serve-regular-file ( -- )
-    cgi-root get doc-root [ file-responder ] with-variable ;
-
-: do-cgi ( name -- )
-    {
-        { [ dup ".cgi" tail? not ] [ drop serve-regular-file ] }
-        { [ dup empty? ] [ "403 forbidden" httpd-error ] }
-        { [ cgi-root get not ] [ "404 cgi-root not set" httpd-error ] }
-        { [ ".." over subseq? ] [ "403 forbidden" httpd-error ] }
-        { [ t ] [ (do-cgi) ] }
-    } cond ;
-
-global [
-    "cgi" [ "argument" get do-cgi ] add-simple-responder
-] bind
diff --git a/extra/webapps/file/authors.txt b/extra/webapps/file/authors.txt
deleted file mode 100755
index 1901f27a24..0000000000
--- a/extra/webapps/file/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/extra/webapps/file/file.factor b/extra/webapps/file/file.factor
deleted file mode 100755
index 411c70c76a..0000000000
--- a/extra/webapps/file/file.factor
+++ /dev/null
@@ -1,136 +0,0 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: calendar html io io.files kernel math math.parser
-http.server.responders http.server.templating namespaces parser
-sequences strings assocs hashtables debugger http.mime sorting
-html.elements logging calendar.format ;
-IN: webapps.file
-
-SYMBOL: doc-root
-
-: serving-path ( filename -- filename )
-    "" or doc-root get swap path+ ;
-
-: unix-time>timestamp ( n -- timestamp )
-    >r unix-1970 r> seconds time+ ;
-
-: file-http-date ( filename -- string )
-    file-modified unix-time>timestamp timestamp>http-string ;
-
-: file-response ( filename mime-type -- )
-    "200 OK" response
-    [
-        "Content-Type" set
-        dup file-length number>string "Content-Length" set
-        file-http-date "Last-Modified" set
-        now timestamp>http-string "Date" set
-    ] H{ } make-assoc print-header ;
-
-: last-modified-matches? ( filename -- bool )
-    file-http-date dup [
-        "if-modified-since" header-param = 
-    ] when ;
-
-: not-modified-response ( -- )
-    "304 Not Modified" response
-    now timestamp>http-string "Date" associate print-header ;  
-
-! You can override how files are served in a custom responder
-SYMBOL: serve-file-hook
-
-[
-    dupd
-    file-response
-    <file-reader> stdio get stream-copy
-] serve-file-hook set-global
-
-: serve-static ( filename mime-type -- )
-    over last-modified-matches? [
-        2drop not-modified-response
-    ] [
-        "method" get "head" = [
-            file-response
-        ] [
-            serve-file-hook get call
-        ] if 
-    ] if ;
-
-SYMBOL: page
-
-: run-page ( filename -- )
-    dup
-    [ [ dup page set run-template-file ] with-scope ] try
-    drop ;
-
-\ run-page DEBUG add-input-logging
-
-: include-page ( filename -- )
-    serving-path run-page ;
-
-: serve-fhtml ( filename -- )
-    serving-html
-    "method" get "head" = [ drop ] [ run-page ] if ;
-
-: serve-file ( filename -- )
-    dup mime-type dup "application/x-factor-server-page" =
-    [ drop serve-fhtml ] [ serve-static ] if ;
-
-\ serve-file NOTICE add-input-logging
-
-: file. ( name dirp -- )
-    [ "/" append ] when
-    dup <a =href a> write </a> ;
-
-: directory. ( path request -- )
-    dup [
-        <h1> write </h1>
-        <ul>
-            directory sort-keys
-            [ <li> file. </li> ] assoc-each
-        </ul>
-    ] simple-html-document ;
-
-: list-directory ( directory -- )
-    serving-html
-     "method" get "head" = [
-        drop
-    ] [
-        "request" get directory.
-    ] if ;
-
-: find-index ( filename -- path )
-    { "index.html" "index.fhtml" }
-    [ dupd path+ exists? ] find nip
-    dup [ path+ ] [ nip ] if ;
-
-: serve-directory ( filename -- )
-    dup "/" tail? [
-        dup find-index
-        [ serve-file ] [ list-directory ] ?if
-    ] [
-        drop directory-no/
-    ] if ;
-
-: serve-object ( filename -- )
-    serving-path dup exists? [
-        dup directory? [ serve-directory ] [ serve-file ] if
-    ] [
-        drop "404 not found" httpd-error
-    ] if ;
-
-: file-responder ( -- )
-    doc-root get [
-        "argument" get serve-object
-    ] [
-        "404 doc-root not set" httpd-error
-    ] if ;
-
-global [
-    ! Serves files from a directory stored in the doc-root
-    ! variable. You can set the variable in the global
-    ! namespace, or inside the responder.
-    "file" [ file-responder ] add-simple-responder
-    
-    ! The root directory is served by...
-    "file" set-default-responder
-] bind
\ No newline at end of file
diff --git a/extra/webapps/source/authors.txt b/extra/webapps/source/authors.txt
deleted file mode 100755
index 1901f27a24..0000000000
--- a/extra/webapps/source/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/extra/webapps/source/source.factor b/extra/webapps/source/source.factor
deleted file mode 100755
index 98fb5b8873..0000000000
--- a/extra/webapps/source/source.factor
+++ /dev/null
@@ -1,35 +0,0 @@
-! Copyright (C) 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: io.files namespaces webapps.file http.server.responders
-xmode.code2html kernel html sequences ;
-IN: webapps.source
-
-! This responder is a potential security problem. Make sure you
-! don't have sensitive files stored under vm/, core/, extra/
-! or misc/.
-
-: check-source-path ( path -- ? )
-    { "vm/" "core/" "extra/" "misc/" }
-    [ head? ] with contains? ;
-
-: source-responder ( path mime-type -- )
-    drop
-    serving-html
-    [
-        dup file-name swap <file-reader> htmlize-stream
-    ] with-html-stream ;
-
-global [
-    ! Serve up our own source code
-    "source" [
-        "argument" get check-source-path [
-            [
-                "" resource-path doc-root set
-                [ source-responder ] serve-file-hook set
-                file-responder
-            ] with-scope
-        ] [
-            "403 forbidden" httpd-error
-        ] if
-    ] add-simple-responder
-] bind
diff --git a/extra/xmode/code2html/responder/responder.factor b/extra/xmode/code2html/responder/responder.factor
new file mode 100755
index 0000000000..d14ffd93b3
--- /dev/null
+++ b/extra/xmode/code2html/responder/responder.factor
@@ -0,0 +1,15 @@
+! Copyright (C) 2007, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.files namespaces http.server http.server.static http
+xmode.code2html kernel html sequences accessors ;
+IN: xmode.code2html.responder
+
+: <sources> ( root -- responder )
+    [
+        drop
+        "text/html" <content>
+        over file-http-date "last-modified" set-header
+        swap [
+            dup file-name swap <file-reader> htmlize-stream
+        ] curry >>body
+    ] <file-responder> ;