Merge branch 'master' into llvm

basis/compiler/cfg/branch-splitting/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/compiler/cfg/branch-splitting/branch-splitting.factor

@@ -0,0 +1,29 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit compiler.cfg.def-use
+compiler.cfg.rpo kernel math sequences ;
+IN: compiler.cfg.branch-splitting
+
+: split-branch ( branch -- )
+    [
+        [ instructions>> ] [ predecessors>> ] bi [
+            instructions>> [ pop* ] [ push-all ] bi
+        ] with each
+    ] [
+        [ successors>> ] [ predecessors>> ] bi [
+            [ drop clone ] change-successors drop
+        ] with each
+    ] bi ;
+
+: split-branches? ( bb -- ? )
+    {
+        [ predecessors>> length 1 >= ]
+        [ successors>> length 1 <= ]
+        [ instructions>> [ defs-vregs ] any? not ]
+        [ instructions>> [ temp-vregs ] any? not ]
+    } 1&& ;
+
+: split-branches ( cfg -- cfg' )
+    dup [
+        dup split-branches? [ split-branch ] [ drop ] if
+    ] each-basic-block f >>post-order ;

basis/compiler/cfg/instructions/instructions.factor

@@ -248,4 +248,4 @@ INSN: _reload dst class n ;
 INSN: _copy dst src class ;
 INSN: _spill-counts counts ;
 
-SYMBOL: temp-spill
+SYMBOL: spill-temp

basis/compiler/cfg/intrinsics/fixnum/fixnum.factor

@@ -18,13 +18,14 @@ IN: compiler.cfg.intrinsics.fixnum
     0 cc= ^^compare-imm
     ds-push ;
 
-: (emit-fixnum-imm-op) ( infos insn -- dst )
+: tag-literal ( n -- tagged )
-    ds-drop
+    literal>> [ tag-fixnum ] [ \ f tag-number ] if* ;
-    [ ds-pop ]
+
-    [ second literal>> [ tag-fixnum ] [ \ f tag-number ] if* ]
+: emit-fixnum-imm-op1 ( infos insn -- dst )
-    [ ]
+    [ ds-pop ds-drop ] [ first tag-literal ] [ ] tri* call ; inline
-    tri*
+
-    call ; inline
+: emit-fixnum-imm-op2 ( infos insn -- dst )
+    [ ds-drop ds-pop ] [ second tag-literal ] [ ] tri* call ; inline
 
 : (emit-fixnum-op) ( insn -- dst )
     [ 2inputs ] dip call ; inline
@@ -32,9 +33,22 @@ IN: compiler.cfg.intrinsics.fixnum
 :: emit-fixnum-op ( node insn imm-insn -- )
     [let | infos [ node node-input-infos ] |
         infos second value-info-small-tagged?
-        [ infos imm-insn (emit-fixnum-imm-op) ]
+        [ infos imm-insn emit-fixnum-imm-op2 ]
-        [ insn (emit-fixnum-op) ]
+        [ insn (emit-fixnum-op) ] if
-        if
+        ds-push
+    ] ; inline
+
+:: emit-commutative-fixnum-op ( node insn imm-insn -- )
+    [let | infos [ node node-input-infos ] |
+        infos first value-info-small-tagged?
+        [ infos imm-insn emit-fixnum-imm-op1 ]
+        [
+            infos second value-info-small-tagged? [
+                infos imm-insn emit-fixnum-imm-op2
+            ] [
+                insn (emit-fixnum-op)
+            ] if
+        ] if
         ds-push
     ] ; inline
 
@@ -69,9 +83,14 @@ IN: compiler.cfg.intrinsics.fixnum
     [ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
     ds-push ;
 
+: (emit-fixnum-comparison) ( cc -- quot1 quot2 )
+    [ ^^compare ] [ ^^compare-imm ] bi-curry ; inline
+
+: emit-eq ( node cc -- )
+    (emit-fixnum-comparison) emit-commutative-fixnum-op ;
+
 : emit-fixnum-comparison ( node cc -- )
-    [  ^^compare ] [ ^^compare-imm ] bi-curry
+    (emit-fixnum-comparison) emit-fixnum-op ;
-    emit-fixnum-op ;
 
 : emit-bignum>fixnum ( -- )
     ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -103,11 +103,11 @@ IN: compiler.cfg.intrinsics
         { \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] }
         { \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] }
         { \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] [ i i ##fixnum-mul-tail ] emit-fixnum-overflow-op ] }
-        { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op iterate-next ] }
+        { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-commutative-fixnum-op iterate-next ] }
         { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op iterate-next ] }
-        { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op iterate-next ] }
+        { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-commutative-fixnum-op iterate-next ] }
-        { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op iterate-next ] }
+        { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-commutative-fixnum-op iterate-next ] }
-        { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op iterate-next ] }
+        { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-commutative-fixnum-op iterate-next ] }
         { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast iterate-next ] }
         { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot iterate-next ] }
         { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 iterate-next ] }
@@ -116,7 +116,7 @@ IN: compiler.cfg.intrinsics
         { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison iterate-next ] }
         { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison iterate-next ] }
         { \ math.private:fixnum> [ cc> emit-fixnum-comparison iterate-next ] }
-        { \ kernel:eq? [ cc= emit-fixnum-comparison iterate-next ] }
+        { \ kernel:eq? [ cc= emit-eq iterate-next ] }
         { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum iterate-next ] }
         { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum iterate-next ] }
         { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op iterate-next ] }

basis/compiler/cfg/linear-scan/allocation/allocation.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs heaps kernel namespaces sequences fry math
-combinators arrays sorting compiler.utilities
+math.order combinators arrays sorting compiler.utilities
 compiler.cfg.linear-scan.live-intervals
 compiler.cfg.linear-scan.allocation.coalescing
 compiler.cfg.linear-scan.allocation.spilling
@@ -12,17 +12,23 @@ IN: compiler.cfg.linear-scan.allocation
 : free-positions ( new -- assoc )
     vreg>> reg-class>> registers get at [ 1/0. ] H{ } map>assoc ;
 
-: active-positions ( new -- assoc )
+: add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ;
-    vreg>> active-intervals-for [ reg>> 0 ] H{ } map>assoc ;
 
-: inactive-positions ( new -- assoc )
+: active-positions ( new assoc -- )
-    dup vreg>> inactive-intervals-for
+    [ vreg>> active-intervals-for ] dip
-    [ [ reg>> swap ] keep relevant-ranges intersect-live-ranges ]
+    '[ [ 0 ] dip reg>> _ add-use-position ] each ;
-    with H{ } map>assoc ;
+
+: inactive-positions ( new assoc -- )
+    [ [ vreg>> inactive-intervals-for ] keep ] dip
+    '[
+        [ _ relevant-ranges intersect-live-ranges ] [ reg>> ] bi
+        _ add-use-position
+    ] each ;
 
 : compute-free-pos ( new -- free-pos )
-    [ free-positions ] [ inactive-positions ] [ active-positions ] tri
+    dup free-positions
-    3array assoc-combine >alist alist-max ;
+    [ inactive-positions ] [ active-positions ] [ nip ] 2tri
+    >alist alist-max ;
 
 : no-free-registers? ( result -- ? )
     second 0 = ; inline

basis/compiler/cfg/linear-scan/assignment/assignment.factor

@@ -104,8 +104,19 @@ GENERIC: assign-registers-in-insn ( insn -- )
 : all-vregs ( insn -- vregs )
     [ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
 
+SYMBOL: check-assignment?
+
+ERROR: overlapping-registers intervals ;
+
+: check-assignment ( intervals -- )
+    dup [ copy-from>> ] map sift '[ vreg>> _ member? not ] filter
+    dup [ reg>> ] map all-unique? [ drop ] [ overlapping-registers ] if ;
+
 : active-intervals ( insn -- intervals )
-    insn#>> pending-intervals get [ covers? ] with filter ;
+    insn#>> pending-intervals get [ covers? ] with filter
+    check-assignment? get [
+        dup check-assignment
+    ] when ;
 
 M: vreg-insn assign-registers-in-insn
     dup [ active-intervals ] [ all-vregs ] bi

basis/compiler/cfg/linear-scan/linear-scan-tests.factor

@@ -18,10 +18,12 @@ compiler.cfg.linear-scan.allocation
 compiler.cfg.linear-scan.allocation.state
 compiler.cfg.linear-scan.allocation.splitting
 compiler.cfg.linear-scan.allocation.spilling
-compiler.cfg.linear-scan.assignment
 compiler.cfg.linear-scan.debugger ;
 
+FROM: compiler.cfg.linear-scan.assignment => check-assignment? ;
+
 check-allocation? on
+check-assignment? on
 
 [
     { T{ live-range f 1 10 } T{ live-range f 15 15 } }
@@ -1417,6 +1419,58 @@ USING: math.private ;
     relevant-ranges intersect-live-ranges
 ] unit-test
 
+! compute-free-pos had problems because it used map>assoc where the sequence
+! had multiple keys
+[ { 0 10 } ] [
+    H{ { int-regs { 0 1 } } } registers set
+    H{
+        { int-regs
+          {
+              T{ live-interval
+                 { vreg V int-regs 1 }
+                 { start 0 }
+                 { end 20 }
+                 { reg 0 }
+                 { ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } }
+                 { uses V{ 0 2 10 20 } }
+              }
+
+              T{ live-interval
+                 { vreg V int-regs 2 }
+                 { start 4 }
+                 { end 40 }
+                 { reg 0 }
+                 { ranges V{ T{ live-range f 4 6 } T{ live-range f 30 40 } } }
+                 { uses V{ 4 6 30 40 } }
+              }
+          }
+        }
+    } inactive-intervals set
+    H{
+        { int-regs
+          {
+              T{ live-interval
+                 { vreg V int-regs 3 }
+                 { start 0 }
+                 { end 40 }
+                 { reg 1 }
+                 { ranges V{ T{ live-range f 0 40 } } }
+                 { uses V{ 0 40 } }
+              }
+          }
+        }
+    } active-intervals set
+
+    T{ live-interval
+       { vreg V int-regs 4 }
+        { start 8 }
+        { end 10 }
+        { ranges V{ T{ live-range f 8 10 } } }
+        { uses V{ 8 10 } }
+    }
+    compute-free-pos
+] unit-test
+
 ! Bug in live spill slots calculation
 
 V{ T{ ##prologue } T{ ##branch } } 0 test-bb

basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor

@@ -68,12 +68,12 @@ T{ live-interval
 [
     {
         T{ _copy { dst 5 } { src 4 } { class int-regs } }
-        T{ _spill { src 0 } { class int-regs } { n 6 } }
+        T{ _spill { src 1 } { class int-regs } { n spill-temp } }
-        T{ _copy { dst 0 } { src 1 } { class int-regs } }
+        T{ _copy { dst 1 } { src 0 } { class int-regs } }
-        T{ _reload { dst 1 } { class int-regs } { n 6 } }
+        T{ _reload { dst 0 } { class int-regs } { n spill-temp } }
-        T{ _spill { src 0 } { class float-regs } { n 7 } }
+        T{ _spill { src 1 } { class float-regs } { n spill-temp } }
-        T{ _copy { dst 0 } { src 1 } { class float-regs } }
+        T{ _copy { dst 1 } { src 0 } { class float-regs } }
-        T{ _reload { dst 1 } { class float-regs } { n 7 } }
+        T{ _reload { dst 0 } { class float-regs } { n spill-temp } }
     }
 ] [
     {
@@ -87,10 +87,10 @@ T{ live-interval
 
 [
     {
-        T{ _spill { src 0 } { class int-regs } { n 3 } }
+        T{ _spill { src 2 } { class int-regs } { n spill-temp } }
-        T{ _copy { dst 0 } { src 2 } { class int-regs } }
         T{ _copy { dst 2 } { src 1 } { class int-regs } }
-        T{ _reload { dst 1 } { class int-regs } { n 3 } }
+        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _reload { dst 0 } { class int-regs } { n spill-temp } }
     }
 ] [
     {
@@ -102,10 +102,10 @@ T{ live-interval
 
 [
     {
-        T{ _spill { src 0 } { class int-regs } { n 3 } }
+        T{ _spill { src 0 } { class int-regs } { n spill-temp } }
         T{ _copy { dst 0 } { src 2 } { class int-regs } }
         T{ _copy { dst 2 } { src 1 } { class int-regs } }
-        T{ _reload { dst 1 } { class int-regs } { n 3 } }
+        T{ _reload { dst 1 } { class int-regs } { n spill-temp } }
     }
 ] [
     {
@@ -136,7 +136,7 @@ T{ live-interval
 ] unit-test
 
 [
-    { T{ _spill { src 4 } { class int-regs } { n 4 } } }
+    { T{ _spill { src 4 } { class int-regs } { n spill-temp } } }
 ] [
     {
        T{ register->memory { from 4 } { to 4 } { reg-class int-regs } }
@@ -162,10 +162,10 @@ T{ live-interval
     {
         T{ _copy { dst 1 } { src 0 } { class int-regs } }
         T{ _copy { dst 2 } { src 0 } { class int-regs } }
-        T{ _spill { src 3 } { class int-regs } { n 5 } }
+        T{ _spill { src 4 } { class int-regs } { n spill-temp } }
         T{ _copy { dst 4 } { src 0 } { class int-regs } }
-        T{ _copy { dst 3 } { src 4 } { class int-regs } }
+        T{ _copy { dst 0 } { src 3 } { class int-regs } }
-        T{ _reload { dst 0 } { class int-regs } { n 5 } }
+        T{ _reload { dst 3 } { class int-regs } { n spill-temp } }
     }
 ] [
     {
@@ -182,10 +182,10 @@ T{ live-interval
         T{ _copy { dst 2 } { src 0 } { class int-regs } }
         T{ _copy { dst 9 } { src 1 } { class int-regs } }
         T{ _copy { dst 1 } { src 0 } { class int-regs } }
-        T{ _spill { src 3 } { class int-regs } { n 10 } }
+        T{ _spill { src 4 } { class int-regs } { n spill-temp } }
         T{ _copy { dst 4 } { src 0 } { class int-regs } }
-        T{ _copy { dst 3 } { src 4 } { class int-regs } }
+        T{ _copy { dst 0 } { src 3 } { class int-regs } }
-        T{ _reload { dst 0 } { class int-regs } { n 10 } }
+        T{ _reload { dst 3 } { class int-regs } { n spill-temp } }
     }
 ] [
     {

basis/compiler/cfg/linear-scan/resolve/resolve.factor

@@ -68,10 +68,10 @@ M: memory->memory >insn
     [ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ;
 
 M: register->memory >insn
-    [ from>> ] [ reg-class>> ] [ to>> ] tri _spill ;
+    [ from>> ] [ reg-class>> ] bi spill-temp _spill ;
 
 M: memory->register >insn
-    [ to>> ] [ reg-class>> ] [ from>> ] tri _reload ;
+    [ to>> ] [ reg-class>> ] bi spill-temp _reload ;
 
 M: register->register >insn
     [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
@@ -82,10 +82,10 @@ M: memory->memory >collision-table
     [ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ;
 
 M: register->memory >collision-table
-    [ from>> ] [ reg-class>> ] [ to>> ] tri _spill ;
+    [ from>> ] [ reg-class>> ] bi spill-temp _spill ;
 
 M: memory->register >collision-table
-    [ to>> ] [ reg-class>> ] [ from>> ] tri _reload ;
+    [ to>> ] [ reg-class>> ] bi spill-temp _reload ;
 
 M: register->register >collision-table
     [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
@@ -119,10 +119,6 @@ M: register->register to-loc drop register ;
 : independent-assignment? ( operations -- pair )
     to-reg froms get key? not ;
 
-: init-temp-spill ( operations -- )
-    [ [ to>> ] [ from>> ] bi max ] [ max ] map-reduce
-    1 + temp-spill set ;
-
 : set-tos/froms ( operations -- )
     [ [ [ from-reg ] keep ] H{ } map>assoc froms set ]
     [ [ [ to-reg ] keep ] H{ } map>assoc tos set ]
@@ -130,26 +126,40 @@ M: register->register to-loc drop register ;
 
 :: (trace-chain) ( obj hashtable -- )
     obj to-reg froms get at* [
+        dup ,
         obj over hashtable clone [ maybe-set-at ] keep swap
-        [ (trace-chain) ] [ , drop ] if
+        [ (trace-chain) ] [ 2drop ] if
     ] [
-        drop hashtable ,
+        drop
     ] if ;
 
 : trace-chain ( obj -- seq )
     [
+        dup ,
         dup dup associate (trace-chain)
-    ] { } make [ keys ] map concat reverse ;
+    ] { } make prune reverse ;
+
 
 : trace-chains ( seq -- seq' )
     [ trace-chain ] map concat ;
 
-: break-cycle-n ( operations -- operations' )
+ERROR: resolve-error ;
+
+: split-cycle ( operations -- chain spilled-operation )
     unclip [
-        [ from>> temp-spill get ]
+        [ set-tos/froms ]
+        [
+            [ start? ] find nip
+            [ resolve-error ] unless* trace-chain
+        ] bi
+    ] dip ;
+
+: break-cycle-n ( operations -- operations' )
+    split-cycle [
+        [ from>> spill-temp ]
         [ reg-class>> ] bi \ register->memory boa
     ] [
-        [ to>> temp-spill [ get ] [ inc ] bi swap ]
+        [ to>> spill-temp swap ]
         [ reg-class>> ] bi \ memory->register boa
     ] bi [ 1array ] bi@ surround ;
 
@@ -182,9 +192,7 @@ M: register->register to-loc drop register ;
 
 : mapping-instructions ( mappings -- insns )
     [
-        [ init-temp-spill ]
+        [ set-tos/froms ] [ parallel-mappings ] bi
-        [ set-tos/froms ]
-        [ parallel-mappings ] tri
         [ [ >insn ] each ] { } make
     ] with-scope ;
 

basis/compiler/cfg/optimizer/optimizer-tests.factor

@@ -1,6 +1,7 @@
-USING: arrays sequences tools.test compiler.cfg.checker compiler.cfg.debugger
+USING: arrays sequences tools.test compiler.cfg.checker
-compiler.cfg.def-use sets kernel kernel.private fry slots.private vectors
+compiler.cfg.debugger compiler.cfg.def-use sets kernel
-sequences.private math sbufs math.private slots.private strings ;
+kernel.private fry slots.private vectors sequences.private
+math sbufs math.private strings ;
 IN: compiler.cfg.optimizer.tests
 
 ! Miscellaneous tests

basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor

@@ -17,8 +17,6 @@ IN: compiler.cfg.stack-analysis.tests
 : linearize ( cfg -- mr )
     flatten-cfg instructions>> ;
 
-local-only? off
-
 [ ] [ [ ] test-stack-analysis drop ] unit-test
 
 ! Only peek once

basis/compiler/cfg/stack-analysis/stack-analysis.factor

@@ -59,17 +59,12 @@ UNION: sync-if-back-edge
     ##dispatch
     ##loop-entry ;
 
-SYMBOL: local-only?
-
-t local-only? set-global
-
 : back-edge? ( from to -- ? )
     [ number>> ] bi@ > ;
 
 : sync-state? ( -- ? )
     basic-block get successors>>
-    [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any?
+    [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any? ;
-    local-only? get or ;
 
 M: sync-if-back-edge visit
     sync-state? [ sync-state ] when , ;

basis/cpu/x86/32/32.factor

@@ -29,13 +29,15 @@ M: x86.32 temp-reg-2 EDX ;
 
 M:: x86.32 %dispatch ( src temp -- )
     ! Load jump table base.
-    src HEX: ffffffff ADD
+    temp src HEX: ffffffff [+] LEA
+    building get length cell - :> start
     0 rc-absolute-cell rel-here
     ! Go
-    src HEX: 7f [+] JMP
+    temp HEX: 7f [+] JMP
+    building get length :> end
     ! Fix up the displacement above
     cell code-alignment
-    [ 7 + building get dup pop* push ]
+    [ end start - + building get dup pop* push ]
     [ align-code ]
     bi ;
 

basis/cpu/x86/64/64.factor

@@ -23,15 +23,17 @@ M: x86.64 rs-reg R15 ;
 M: x86.64 stack-reg RSP ;
 
 M:: x86.64 %dispatch ( src temp -- )
+    building get length :> start
     ! Load jump table base.
     temp HEX: ffffffff MOV
     0 rc-absolute-cell rel-here
     ! Add jump table base
-    src temp ADD
+    temp src ADD
-    src HEX: 7f [+] JMP
+    temp HEX: 7f [+] JMP
+    building get length :> end
     ! Fix up the displacement above
     cell code-alignment
-    [ 15 + building get dup pop* push ]
+    [ end start - 2 - + building get dup pop* push ]
     [ align-code ]
     bi ;
 

basis/disjoint-sets/disjoint-sets-tests.factor

@@ -0,0 +1,16 @@
+IN: disjoint-sets.testes
+USING: tools.test disjoint-sets namespaces slots.private ;
+
+SYMBOL: +blah+
+-405534154 +blah+ 1 set-slot
+
+SYMBOL: uf
+
+[ ] [
+    <disjoint-set> uf set
+    +blah+ uf get add-atom
+    19026 uf get add-atom
+    19026 +blah+ uf get equate
+] unit-test
+
+[ 2 ] [ 19026 uf get equiv-set-size ] unit-test

extra/webapps/imagebin/imagebin.factor

@@ -1,39 +1,45 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel furnace.actions html.forms
+USING: accessors furnace.actions furnace.redirection
-http.server.dispatchers db db.tuples db.types urls
+html.forms http http.server http.server.dispatchers
-furnace.redirection multiline http namespaces ;
+io.directories io.encodings.utf8 io.files io.pathnames
+kernel math.parser multiline namespaces sequences urls ;
 IN: webapps.imagebin
 
-TUPLE: imagebin < dispatcher ;
+TUPLE: imagebin < dispatcher path n ;
-
-TUPLE: image id path ;
-
-image "IMAGE" {
-    { "id" "ID" INTEGER +db-assigned-id+ }
-    { "path" "PATH" { VARCHAR 256 } +not-null+ }
-} define-persistent
 
 : <uploaded-image-action> ( -- action )
     <page-action>
         { imagebin "uploaded-image" } >>template ;
 
-SYMBOL: my-post-data
+: next-image-path ( -- path )
+    imagebin get
+    [ path>> ] [ n>> number>string ] bi append-path ; 
+
+M: imagebin call-responder*
+    [ imagebin set ] [ call-next-method ] bi ;
+
+: move-image ( mime-file -- )
+    next-image-path
+    [ [ temporary-path>> ] dip move-file ]
+    [ [ filename>> ] dip ".txt" append utf8 set-file-contents ] 2bi ;
+
 : <upload-image-action> ( -- action )
     <page-action>
         { imagebin "upload-image" } >>template
         [
-            
+            "file1" param [ move-image ] when*
-            ! request get post-data>> my-post-data set-global
+            "file2" param [ move-image ] when*
-            ! image new
+            "file3" param [ move-image ] when*
-            !    "file" value
-                ! insert-tuple
             "uploaded-image" <redirect>
         ] >>submit ;
 
-: <imagebin> ( -- responder )
+: <imagebin> ( image-directory -- responder )
     imagebin new-dispatcher
+        swap [ make-directories ] [ >>path ] bi
+        0 >>n
         <upload-image-action> "" add-responder
         <upload-image-action> "upload-image" add-responder
         <uploaded-image-action> "uploaded-image" add-responder ;
 
+"resource:images" <imagebin> main-responder set-global

extra/webapps/imagebin/uploaded-image.xml

@@ -2,6 +2,6 @@
 <html>
 <head><title>Uploaded</title></head>
 <body>
-hi from uploaded-image
+You uploaded something!
 </body>
 </html>