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

core/alien/compiler/compiler-tests.factor

@@ -3,7 +3,7 @@ USING: alien alien.c-types alien.syntax compiler kernel
 namespaces namespaces tools.test sequences inference words
 arrays parser quotations continuations inference.backend effects
 namespaces.private io io.streams.string memory system threads
-tools.test ;
+tools.test math ;
 
 FUNCTION: void ffi_test_0 ;
 [ ] [ ffi_test_0 ] unit-test
@@ -354,3 +354,14 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
     ] alien-callback ;
 
 [ ] [ callback-8 callback_test_1 ] unit-test
+
+: callback-9
+    "int" { "int" "int" "int" } "cdecl" [
+        + + 1+
+    ] alien-callback ;
+
+FUNCTION: int ffi_test_37 ( void* func ) ;
+
+[ 1 ] [ callback-9 ffi_test_37 ] unit-test
+
+[ 7 ] [ callback-9 ffi_test_37 ] unit-test

core/alien/compiler/compiler.factor

@@ -403,7 +403,6 @@ TUPLE: callback-context ;
 : generate-callback ( node -- )
     dup xt>> dup [
         init-templates
-        %save-word-xt
         %prologue-later
         dup alien-stack-frame [
             dup registers>objects

core/bootstrap/stage2.factor

@@ -27,10 +27,6 @@ SYMBOL: bootstrap-time
     diff
     [ "bootstrap." prepend require ] each ;
 
-! : compile-remaining ( -- )
-!     "Compiling remaining words..." print flush
-!     vocabs [ words [ compiled? not ] subset compile ] each ;
-
 : count-words ( pred -- )
     all-words swap subset length number>string write ;
 

core/compiler/tests/templates.factor

@@ -3,7 +3,7 @@ USING: arrays compiler kernel kernel.private math
 hashtables.private math.private namespaces sequences
 sequences.private tools.test namespaces.private slots.private
 sequences.private byte-arrays alien alien.accessors layouts
-words definitions compiler.units io combinators ;
+words definitions compiler.units io combinators vectors ;
 IN: compiler.tests
 
 ! Oops!
@@ -246,3 +246,12 @@ TUPLE: my-tuple ;
     } cleave ;
 
 [ t ] [ \ float-spill-bug compiled? ] unit-test
+
+! Regression
+: dispatch-alignment-regression ( -- c )
+    { tuple vector } 3 slot { word } declare
+    dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
+
+[ t ] [ \ dispatch-alignment-regression compiled? ] unit-test
+
+[ vector ] [ dispatch-alignment-regression ] unit-test

core/cpu/architecture/architecture.factor

@@ -56,7 +56,7 @@ HOOK: %call cpu ( word -- )
 HOOK: %jump-label cpu ( label -- )
 
 ! Test if vreg is 'f' or not
-HOOK: %jump-t cpu ( label -- )
+HOOK: %jump-f cpu ( label -- )
 
 HOOK: %dispatch cpu ( -- )
 

core/cpu/ppc/architecture/architecture.factor

@@ -106,8 +106,8 @@ M: ppc %call ( label -- ) BL ;
 
 M: ppc %jump-label ( label -- ) B ;
 
-M: ppc %jump-t ( label -- )
+M: ppc %jump-f ( label -- )
-    0 "flag" operand f v>operand CMPI BNE ;
+    0 "flag" operand f v>operand CMPI BEQ ;
 
 M: ppc %dispatch ( -- )
     [

core/cpu/ppc/intrinsics/intrinsics.factor

@@ -217,11 +217,11 @@ IN: cpu.ppc.intrinsics
     2array define-if-intrinsics ;
 
 {
-    { fixnum< BLT }
+    { fixnum< BGE }
-    { fixnum<= BLE }
+    { fixnum<= BGT }
-    { fixnum> BGT }
+    { fixnum> BLE }
-    { fixnum>= BGE }
+    { fixnum>= BLT }
-    { eq? BEQ }
+    { eq? BNE }
 } [
     first2 define-fixnum-jump
 ] each
@@ -356,11 +356,11 @@ IN: cpu.ppc.intrinsics
     { { float "x" } { float "y" } } define-if-intrinsic ;
 
 {
-    { float< BLT }
+    { float< BGE }
-    { float<= BLE }
+    { float<= BGT }
-    { float> BGT }
+    { float> BLE }
-    { float>= BGE }
+    { float>= BLT }
-    { float= BEQ }
+    { float= BNE }
 } [
     first2 define-float-jump
 ] each

core/cpu/x86/32/32.factor

@@ -16,7 +16,6 @@ IN: cpu.x86.32
 M: x86.32 ds-reg ESI ;
 M: x86.32 rs-reg EDI ;
 M: x86.32 stack-reg ESP ;
-M: x86.32 xt-reg ECX ;
 M: x86.32 stack-save-reg EDX ;
 
 M: temp-reg v>operand drop EBX ;
@@ -267,7 +266,7 @@ os windows? [
     EDX 26 SHR
     EDX 1 AND
     { EAX EBX ECX EDX } [ POP ] each
-    JNE
+    JE
 ] { } define-if-intrinsic
 
 "-no-sse2" cli-args member? [

core/cpu/x86/64/64.factor

@@ -11,7 +11,6 @@ IN: cpu.x86.64
 M: x86.64 ds-reg R14 ;
 M: x86.64 rs-reg R15 ;
 M: x86.64 stack-reg RSP ;
-M: x86.64 xt-reg RCX ;
 M: x86.64 stack-save-reg RSI ;
 
 M: temp-reg v>operand drop RBX ;

core/cpu/x86/architecture/architecture.factor

@@ -9,7 +9,6 @@ IN: cpu.x86.architecture
 HOOK: ds-reg cpu
 HOOK: rs-reg cpu
 HOOK: stack-reg cpu
-HOOK: xt-reg cpu
 HOOK: stack-save-reg cpu
 
 : stack@ stack-reg swap [+] ;
@@ -47,13 +46,13 @@ M: x86 stack-frame ( n -- i )
     3 cells + 16 align cell - ;
 
 M: x86 %save-word-xt ( -- )
-    xt-reg 0 MOV rc-absolute-cell rel-this ;
+    temp-reg v>operand 0 MOV rc-absolute-cell rel-this ;
 
 : factor-area-size 4 cells ;
 
 M: x86 %prologue ( n -- )
     dup cell + PUSH
-    xt-reg PUSH
+    temp-reg v>operand PUSH
     stack-reg swap 2 cells - SUB ;
 
 M: x86 %epilogue ( n -- )
@@ -76,8 +75,8 @@ M: x86 %call ( label -- ) CALL ;
 
 M: x86 %jump-label ( label -- ) JMP ;
 
-M: x86 %jump-t ( label -- )
+M: x86 %jump-f ( label -- )
-    "flag" operand f v>operand CMP JNE ;
+    "flag" operand f v>operand CMP JE ;
 
 : code-alignment ( -- n )
     building get length dup cell align swap - ;

core/cpu/x86/intrinsics/intrinsics.factor

@@ -212,11 +212,11 @@ IN: cpu.x86.intrinsics
     2array define-if-intrinsics ;
 
 {
-    { fixnum< JL }
+    { fixnum< JGE }
-    { fixnum<= JLE }
+    { fixnum<= JG }
-    { fixnum> JG }
+    { fixnum> JLE }
-    { fixnum>= JGE }
+    { fixnum>= JL }
-    { eq? JE }
+    { eq? JNE }
 } [
     first2 define-fixnum-jump
 ] each

core/cpu/x86/sse2/sse2.factor

@@ -27,11 +27,11 @@ IN: cpu.x86.sse2
     { { float "x" } { float "y" } } define-if-intrinsic ;
 
 {
-    { float< JB }
+    { float< JAE }
-    { float<= JBE }
+    { float<= JA }
-    { float> JA }
+    { float> JBE }
-    { float>= JAE }
+    { float>= JB }
-    { float= JE }
+    { float= JNE }
 } [
     first2 define-float-jump
 ] each

core/generator/generator.factor

@@ -131,14 +131,14 @@ M: #loop generate-node
 
 : generate-if ( node label -- next )
     <label> [
-        >r >r node-children first2 generate-branch
+        >r >r node-children first2 swap generate-branch
         r> r> end-false-branch resolve-label
         generate-branch
         init-templates
     ] keep resolve-label iterate-next ;
 
 M: #if generate-node
-    [ <label> dup %jump-t ]
+    [ <label> dup %jump-f ]
     H{ { +input+ { { f "flag" } } } }
     with-template
     generate-if ;
@@ -189,13 +189,13 @@ M: #dispatch generate-node
     "if-intrinsics" set-word-prop ;
 
 : if>boolean-intrinsic ( quot -- )
-    "true" define-label
+    "false" define-label
     "end" define-label
-    "true" get swap call
+    "false" get swap call
-    f "if-scratch" get load-literal
-    "end" get %jump-label
-    "true" resolve-label
     t "if-scratch" get load-literal
+    "end" get %jump-label
+    "false" resolve-label
+    f "if-scratch" get load-literal
     "end" resolve-label
     "if-scratch" get phantom-push ; inline
 

core/generator/registers/registers.factor

@@ -65,9 +65,7 @@ M: float-regs move-spec drop float ;
 M: float-regs operand-class* drop float ;
 
 ! Temporary register for stack shuffling
-TUPLE: temp-reg reg-class>> ;
+SINGLETON: temp-reg
-
-: temp-reg T{ temp-reg f int-regs } ;
 
 M: temp-reg move-spec drop f ;
 

core/generic/standard/engines/tuple/tuple.factor

@@ -1,8 +1,11 @@
-IN: generic.standard.engines.tuple
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
 USING: kernel classes.tuple.private hashtables assocs sorting
 accessors combinators sequences slots.private math.parser words
 effects namespaces generic generic.standard.engines
-classes.algebra math math.private quotations arrays ;
+classes.algebra math math.private kernel.private
+quotations arrays ;
+IN: generic.standard.engines.tuple
 
 TUPLE: echelon-dispatch-engine n methods ;
 
@@ -27,14 +30,7 @@ TUPLE: tuple-dispatch-engine echelons ;
 
 : <tuple-dispatch-engine> ( methods -- engine )
     echelon-sort
-    [
+    [ dupd <echelon-dispatch-engine> ] assoc-map
-        over zero? [
-            dup assoc-empty?
-            [ drop f ] [ values first ] if
-        ] [
-            dupd <echelon-dispatch-engine>
-        ] if
-    ] assoc-map [ nip ] assoc-subset
     \ tuple-dispatch-engine boa ;
 
 : convert-tuple-methods ( assoc -- assoc' )
@@ -48,52 +44,51 @@ M: trivial-tuple-dispatch-engine engine>quot
     >alist V{ } clone [ hashcode 1array ] distribute-buckets
     [ <trivial-tuple-dispatch-engine> ] map ;
 
+: word-hashcode% [ 1 slot ] % ;
+
 : class-hash-dispatch-quot ( methods -- quot )
-    #! 1 slot == word hashcode
     [
-        [ dup 1 slot ] %
+        \ dup ,
+        word-hashcode%
         hash-methods [ engine>quot ] map hash-dispatch-quot %
     ] [ ] make ;
 
-: tuple-dispatch-engine-word-name ( engine -- string )
+: engine-word-name ( -- string )
-    [
+    generic get word-name "/tuple-dispatch-engine" append ;
-        generic get word-name %
-        "/tuple-dispatch-engine/" %
-        n>> #
-    ] "" make ;
 
-PREDICATE: tuple-dispatch-engine-word < word
+PREDICATE: engine-word < word
     "tuple-dispatch-generic" word-prop generic? ;
 
-M: tuple-dispatch-engine-word stack-effect
+M: engine-word stack-effect
     "tuple-dispatch-generic" word-prop
     [ extra-values ] [ stack-effect ] bi
     dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
 
-M: tuple-dispatch-engine-word compiled-crossref?
+M: engine-word compiled-crossref?
     drop t ;
 
 : remember-engine ( word -- )
     generic get "engines" word-prop push ;
 
-: <tuple-dispatch-engine-word> ( engine -- word )
+: <engine-word> ( -- word )
-    tuple-dispatch-engine-word-name f <word>
+    engine-word-name f <word>
-    [ generic get "tuple-dispatch-generic" set-word-prop ]
+    dup generic get "tuple-dispatch-generic" set-word-prop ;
-    [ remember-engine ]
-    [ ]
-    tri ;
 
-: define-tuple-dispatch-engine-word ( engine quot -- word )
+: define-engine-word ( quot -- word )
-    >r <tuple-dispatch-engine-word> dup r> define ;
+    >r <engine-word> dup r> define ;
+
+: array-nth% 2 + , [ slot { word } declare ] % ;
+
+: tuple-layout-superclasses ( obj -- array )
+    { tuple } declare
+    1 slot { tuple-layout } declare
+    4 slot { array } declare ; inline
 
 : tuple-dispatch-engine-body ( engine -- quot )
-    #! 1 slot == tuple-layout
-    #! 2 slot == 0 array-nth
-    #! 4 slot == layout-superclasses
     [
         picker %
-        [ 1 slot 4 slot ] %
+        [ tuple-layout-superclasses ] %
-        [ n>> 2 + , [ slot ] % ]
+        [ n>> array-nth% ]
         [
             methods>> [
                 <trivial-tuple-dispatch-engine> engine>quot
@@ -104,25 +99,54 @@ M: tuple-dispatch-engine-word compiled-crossref?
     ] [ ] make ;
 
 M: echelon-dispatch-engine engine>quot
-    dup tuple-dispatch-engine-body
+    dup n>> zero? [
-    define-tuple-dispatch-engine-word
+        methods>> dup assoc-empty?
-    1quotation ;
+        [ drop default get ] [ values first engine>quot ] if
+    ] [
+        [
+            picker %
+            [ tuple-layout-superclasses ] %
+            [ n>> array-nth% ]
+            [
+                methods>> [
+                    <trivial-tuple-dispatch-engine> engine>quot
+                ] [
+                    class-hash-dispatch-quot
+                ] if-small? %
+            ] bi
+        ] [ ] make
+    ] if ;
 
 : >=-case-quot ( alist -- quot )
     default get [ drop ] prepend swap
     [ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map
     alist>quot ;
 
+: tuple-layout-echelon ( obj -- array )
+    { tuple } declare
+    1 slot { tuple-layout } declare
+    5 slot ; inline
+
+: unclip-last [ 1 head* ] [ peek ] bi ;
+
 M: tuple-dispatch-engine engine>quot
-    #! 1 slot == tuple-layout
-    #! 5 slot == layout-echelon
     [
         picker %
-        [ 1 slot 5 slot ] %
+        [ tuple-layout-echelon ] %
-        echelons>>
         [
             tuple assumed set
-            [ engine>quot dup default set ] assoc-map
+            echelons>> dup empty? [
+                unclip-last
+                [
+                    [
+                        engine>quot define-engine-word
+                        [ remember-engine ] [ 1quotation ] bi
+                        dup default set
+                    ] assoc-map
+                ]
+                [ first2 engine>quot 2array ] bi*
+                suffix
+            ] unless
         ] with-scope
         >=-case-quot %
     ] [ ] make ;

core/generic/standard/standard-tests.factor

@@ -251,6 +251,14 @@ HOOK: my-tuple-hook my-var ( -- x )
 
 M: sequence my-tuple-hook my-hook ;
 
+TUPLE: m-t-h-a ;
+
+M: m-t-h-a my-tuple-hook "foo" ;
+
+TUPLE: m-t-h-b < m-t-h-a ;
+
+M: m-t-h-b my-tuple-hook "bar" ;
+
 [ f ] [
     \ my-tuple-hook [ "engines" word-prop ] keep prefix
     [ 1quotation infer ] map all-equal?

core/inference/backend/backend.factor

@@ -15,7 +15,7 @@ GENERIC: inline? ( word -- ? )
 M: method-body inline?
     "method-generic" word-prop inline? ;
 
-M: tuple-dispatch-engine-word inline?
+M: engine-word inline?
     "tuple-dispatch-generic" word-prop inline? ;
 
 M: word inline?
@@ -130,25 +130,27 @@ TUPLE: too-many->r ;
 
 TUPLE: too-many-r> ;
 
-: check-r> ( -- )
+: check-r> ( n -- )
-    meta-r get empty?
+    meta-r get length >
     [ \ too-many-r> inference-error ] when ;
 
-: infer->r ( -- )
+: infer->r ( n -- )
-    1 ensure-values
+    dup ensure-values
     #>r
-    1 0 pick node-inputs
+    over 0 pick node-inputs
-    pop-d push-r
+    over [ drop pop-d ] map reverse [ push-r ] each
-    0 1 pick node-outputs
+    0 pick pick node-outputs
-    node, ;
+    node,
+    drop ;
 
-: infer-r> ( -- )
+: infer-r> ( n -- )
-    check-r>
+    dup check-r>
     #r>
-    0 1 pick node-inputs
+    0 pick pick node-inputs
-    pop-r push-d
+    over [ drop pop-r ] map reverse [ push-d ] each
-    1 0 pick node-outputs
+    over 0 pick node-outputs
-    node, ;
+    node,
+    drop ;
 
 : undo-infer ( -- )
     recorded get [ f "inferred-effect" set-word-prop ] each ;
@@ -199,18 +201,18 @@ M: object constructor drop f ;
     dup infer-uncurry
     constructor [
         peek-d reify-curry
-        infer->r
+        1 infer->r
         peek-d reify-curry
-        infer-r>
+        1 infer-r>
         2 1 <effect> swap #call consume/produce
     ] when* ;
 
 : reify-curries ( n -- )
     meta-d get reverse [
         dup special? [
-            over [ infer->r ] times
+            over infer->r
             dup reify-curry
-            over [ infer-r> ] times
+            over infer-r>
         ] when 2drop
     ] 2each ;
 

core/inference/known-words/known-words.factor

@@ -54,9 +54,9 @@ IN: inference.known-words
     { swap  T{ effect f 2 { 1 0         } } }
 } [ define-shuffle ] assoc-each
 
-\ >r [ infer->r ] "infer" set-word-prop
+\ >r [ 1 infer->r ] "infer" set-word-prop
 
-\ r> [ infer-r> ] "infer" set-word-prop
+\ r> [ 1 infer-r> ] "infer" set-word-prop
 
 \ declare [
     1 ensure-values
@@ -81,8 +81,8 @@ M: curried infer-call
 
 M: composed infer-call
     infer-uncurry
-    infer->r peek-d infer-call
+    1 infer->r peek-d infer-call
-    terminated? get [ infer-r> peek-d infer-call ] unless ;
+    terminated? get [ 1 infer-r> peek-d infer-call ] unless ;
 
 M: object infer-call
     \ literal-expected inference-warning ;

core/threads/threads-docs.factor

@@ -26,7 +26,7 @@ ARTICLE: "threads-yield" "Yielding and suspending threads"
 { $subsection resume }
 { $subsection resume-with } ;
 
-ARTICLE: "thread-state" "Thread-local state"
+ARTICLE: "thread-state" "Thread-local state and variables"
 "Threads form a class of objects:"
 { $subsection thread }
 "The current thread:"
@@ -36,6 +36,8 @@ ARTICLE: "thread-state" "Thread-local state"
 { $subsection tget }
 { $subsection tset }
 { $subsection tchange }
+"Each thread has its own independent set of thread-local variables and newly-spawned threads begin with an empty set."
+$nl
 "Global hashtable of all threads, keyed by " { $link thread-id } ":"
 { $subsection threads }
 "Threads have an identity independent of continuations. If a continuation is refied in one thread and then resumed in another thread, the code running in that continuation will observe a change in the value output by " { $link self } "." ;

core/threads/threads-tests.factor

@@ -1,4 +1,5 @@
-USING: namespaces io tools.test threads kernel ;
+USING: namespaces io tools.test threads kernel
+concurrency.combinators math ;
 IN: threads.tests
 
 3 "x" set
@@ -16,3 +17,13 @@ yield
 ] unit-test
 
 [ f ] [ f get-global ] unit-test
+
+{ { 0 3 6 9 12 15 18 21 24 27 } } [
+    10 [
+        0 "i" tset
+        [
+            "i" [ yield 3 + ] tchange
+        ] times yield
+        "i" tget
+    ] parallel-map
+] unit-test

core/threads/threads.factor

@@ -27,7 +27,7 @@ mailbox variables sleep-entry ;
     tnamespace set-at ;
 
 : tchange ( key quot -- )
-    tnamespace change-at ; inline
+    tnamespace swap change-at ; inline
 
 : threads 41 getenv ;
 

extra/farkup/farkup-tests.factor

@@ -61,3 +61,5 @@ IN: farkup.tests
 [ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
 [ "<p><a href=\"lol.com\"></a></p>" ] [ "[[lol.com]]" convert-farkup ] unit-test
 [ "<p><a href=\"lol.com\">haha</a></p>" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test
+
+[ ] [ "[{}]" convert-farkup drop ] unit-test

extra/html/elements/elements.factor

@@ -161,6 +161,6 @@ SYMBOL: html
         "id" "onclick" "style" "valign" "accesskey"
         "src" "language" "colspan" "onchange" "rel"
         "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
-        "media"
+        "media" "title"
     ] [ define-attribute-word ] each
 ] with-compilation-unit

extra/http/http.factor

@@ -394,16 +394,18 @@ body ;
     [ unparse-cookies "set-cookie" pick set-at ] when*
     write-header ;
 
-: body>quot ( body -- quot )
+GENERIC: write-response-body* ( body -- )
-    {
+
-        { [ dup not ] [ drop [ ] ] }
+M: f write-response-body* drop ;
-        { [ dup string? ] [ [ write ] curry ] }
+
-        { [ dup callable? ] [ ] }
+M: string write-response-body* write ;
-        [ [ stdio get stream-copy ] curry ]
+
-    } cond ;
+M: callable write-response-body* call ;
+
+M: object write-response-body* stdio get stream-copy ;
 
 : write-response-body ( response -- response )
-    dup body>> body>quot call ;
+    dup body>> write-response-body* ;
 
 M: response write-response ( respose -- )
     write-response-version

extra/http/server/auth/login/login.factor

@@ -68,10 +68,7 @@ M: user-saver dispose
         <action>
             [ blank-values ] >>init
 
-            [
+            [ form edit-form ] >>display
-                "text/html" <content>
-                [ form edit-form ] >>body
-            ] >>display
 
             [
                 blank-values
@@ -120,10 +117,7 @@ SYMBOL: user-exists?
         <action>
             [ blank-values ] >>init
 
-            [
+            [ form edit-form ] >>display
-                "text/html" <content>
-                [ form edit-form ] >>body
-            ] >>display
 
             [
                 blank-values
@@ -174,10 +168,7 @@ SYMBOL: previous-page
                 dup email>> "email" set-value
             ] >>init
 
-            [
+            [ form edit-form ] >>display
-                "text/html" <content>
-                [ form edit-form ] >>body
-            ] >>display
 
             [
                 blank-values
@@ -262,10 +253,7 @@ SYMBOL: lost-password-from
         <action>
             [ blank-values ] >>init
 
-            [
+            [ form edit-form ] >>display
-                "text/html" <content>
-                [ form edit-form ] >>body
-            ] >>display
 
             [
                 blank-values
@@ -314,10 +302,7 @@ SYMBOL: lost-password-from
                 ] H{ } make-assoc values set
             ] >>init
 
-            [
+            [ <recover-form-3> edit-form ] >>display
-                "text/html" <content>
-                [ <recover-form-3> edit-form ] >>body
-            ] >>display
 
             [
                 blank-values

extra/http/server/boilerplate/boilerplate.factor

@@ -2,6 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel namespaces boxes sequences strings
 io io.streams.string
+http
 http.server
 http.server.templating ;
 IN: http.server.boilerplate
@@ -27,6 +28,8 @@ SYMBOL: style
 : write-style ( -- )
     style get >string write ;
 
+SYMBOL: nested-template?
+
 SYMBOL: next-template
 
 : call-next-template ( -- )
@@ -39,9 +42,15 @@ M: f call-template drop call-next-template ;
         title get [ <box> title set ] unless
         style get [ SBUF" " clone style set ] unless
 
-        swap with-string-writer next-template set
+        [
-
+            [
-        call-template
+                nested-template? on
+                write-response-body*
+            ] with-string-writer
+            next-template set
+        ]
+        [ call-template ]
+        bi*
     ] with-scope ; inline
 
 M: boilerplate call-responder

extra/http/server/components/components-tests.factor

@@ -1,12 +1,10 @@
 IN: http.server.components.tests
 USING: http.server.components http.server.forms
 http.server.validators namespaces tools.test kernel accessors
-tuple-syntax mirrors http.server.actions
+tuple-syntax mirrors
-http.server.templating.fhtml
+http http.server.actions http.server.templating.fhtml
 io.streams.string io.streams.null ;
 
-\ render-edit must-infer
-
 validation-failed? off
 
 [ 3 ] [ "3" "n" <number> validate ] unit-test
@@ -65,9 +63,9 @@ TUPLE: test-tuple text number more-text ;
             "hi" >>default
             add-field ;
 
-[ ] [ <test-tuple> <mirror> values set <test-form> view-form ] unit-test
+[ ] [ <test-tuple> <mirror> values set <test-form> view-form write-response-body drop ] unit-test
 
-[ ] [ <test-tuple> <mirror> values set <test-form> edit-form ] unit-test
+[ ] [ <test-tuple> <mirror> values set <test-form> edit-form write-response-body drop ] unit-test
 
 [ TUPLE{ test-tuple number: 123 more-text: "hi" } ] [
     <test-tuple> from-tuple

extra/http/server/components/components.factor

@@ -7,9 +7,12 @@ continuations math ;
 IN: http.server.components
 
 ! Renderer protocol
+GENERIC: render-summary* ( value renderer -- )
 GENERIC: render-view* ( value renderer -- )
 GENERIC: render-edit* ( value id renderer -- )
 
+M: object render-summary* render-view* ;
+
 TUPLE: field type ;
 
 C: <field> field
@@ -235,3 +238,35 @@ TUPLE: text < string ;
 
 : <text> ( id -- component )
     text new-text ;
+
+! List components
+SYMBOL: +plain+
+SYMBOL: +ordered+
+SYMBOL: +unordered+
+
+TUPLE: list-renderer component type ;
+
+C: <list-renderer> list-renderer
+
+: render-list ( value component -- )
+    [ render-summary* ] curry each ;
+
+: render-ordered-list ( value component -- )
+    [ <li> render-summary* </li> ] curry each ;
+
+: render-unordered-list ( value component -- )
+    [ <li> render-summary* </li> ] curry each ;
+
+M: list-renderer render-view*
+    [ component>> ] [ type>> ] bi {
+        { +plain+ [ render-list ] }
+        { +ordered+ [ <ol> render-ordered-list </ol> ] }
+        { +unordered+ [ <ul> render-unordered-list </ul> ] }
+    } case ;
+
+TUPLE: list < component ;
+
+: <list> ( id component type -- list )
+    <list-renderer> list swap new-component ;
+
+M: list component-string drop ;

extra/http/server/crud/crud.factor

@@ -15,10 +15,7 @@ IN: http.server.crud
 
         [ "id" get ctor call select-tuple from-tuple ] >>init
 
-        [
+        [ form view-form ] >>display ;
-            "text/html" <content>
-            [ form view-form ] >>body
-        ] >>display ;
 
 : <id-redirect> ( id next -- response )
     swap number>string "id" associate <permanent-redirect> ;
@@ -36,10 +33,7 @@ IN: http.server.crud
             if
         ] >>init
 
-        [
+        [ form edit-form ] >>display
-            "text/html" <content>
-            [ form edit-form ] >>body
-        ] >>display
 
         [
             f ctor call from-tuple
@@ -64,13 +58,10 @@ IN: http.server.crud
 
 :: <list-action> ( form ctor -- action )
     <action>
-        [
-            "text/html" <content>
         [
             blank-values
 
             f ctor call select-tuples "list" set-value
 
             form view-form
-            ] >>body
         ] >>display ;

extra/http/server/forms/forms.factor

@@ -1,4 +1,7 @@
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors assocs namespaces io.files sequences fry
+http.server
 http.server.actions
 http.server.components
 http.server.validators
@@ -17,8 +20,11 @@ M: form init V{ } clone >>components ;
 : add-field ( form component -- form )
     dup id>> pick components>> set-at ;
 
+: set-components ( form -- )
+    components>> components set ;
+
 : with-form ( form quot -- )
-    >r components>> components r> with-variable ; inline
+    [ [ set-components ] [ call ] bi* ] with-scope ; inline
 
 : set-defaults ( form -- )
     [
@@ -29,14 +35,16 @@ M: form init V{ } clone >>components ;
         ] assoc-each
     ] with-form ;
 
-: view-form ( form -- )
+: <form-response> ( form template -- response )
-    dup view-template>> '[ , call-template ] with-form ;
+    [ components>> components set ]
+    [ "text/html" <content> swap >>body ]
+    bi* ;
 
-: edit-form ( form -- )
+: view-form ( form -- response )
-    dup edit-template>> '[ , call-template ] with-form ;
+    dup view-template>> <form-response> ;
 
-: summary-form ( form -- )
+: edit-form ( form -- response )
-    dup summary-template>> '[ , call-template ] with-form ;
+    dup edit-template>> <form-response> ;
 
 : validate-param ( id component -- )
     [ [ params get at ] [ validate ] bi* ]
@@ -52,19 +60,19 @@ M: form init V{ } clone >>components ;
 : validate-form ( form -- )
     (validate-form) [ validation-failed ] when ;
 
-! List components
+: render-form ( value form template -- )
-TUPLE: list-renderer form ;
+    [
+        [ from-tuple ]
+        [ set-components ]
+        [ call-template ]
+        tri*
+    ] with-scope ;
 
-C: <list-renderer> list-renderer
+M: form render-summary*
+    dup summary-template>> render-form ;
 
-M: list-renderer render-view*
+M: form render-view*
-    form>> [
+    dup view-template>> render-form ;
-        [ >r from-tuple r> summary-form ] with-scope
-    ] curry each ;
 
-TUPLE: list < component ;
+M: form render-edit*
-
+    dup edit-template>> render-form ;
-: <list> ( id form -- list )
-    list swap <list-renderer> new-component ;
-
-M: list component-string drop ;

extra/http/server/templating/chloe/chloe.factor

@@ -156,13 +156,19 @@ SYMBOL: tags
     [
         V{ } clone tags set
 
+        nested-template? get [
+            process-template
+        ] [
             {
                 [ xml-prolog write-prolog ]
                 [ xml-before write-chunk  ]
                 [ process-template        ]
                 [ xml-after write-chunk   ]
             } cleave
+        ] if
     ] with-scope ;
 
 M: chloe call-template
     path>> utf8 <file-reader> read-xml process-chloe ;
+
+INSTANCE: chloe template

extra/http/server/templating/fhtml/fhtml.factor

@@ -94,3 +94,5 @@ M: fhtml call-template ( filename -- )
     [ <fhtml> serve-template ]
     "application/x-factor-server-page"
     pick special>> set-at ;
+
+INSTANCE: fhtml template

extra/http/server/templating/templating.factor

@@ -1,9 +1,13 @@
 USING: accessors kernel fry io.encodings.utf8 io.files
-http.server ;
+http http.server ;
 IN: http.server.templating
 
+MIXIN: template
+
 GENERIC: call-template ( template -- )
 
+M: template write-response-body* call-template ;
+
 : template-convert ( template output -- )
     utf8 [ call-template ] with-file-writer ;
 

extra/locals/backend/backend-tests.factor

@@ -0,0 +1,38 @@
+IN: locals.backend.tests
+USING: tools.test locals.backend kernel arrays ;
+
+[ 3 ] [ 3 >r 1 get-local r> drop ] unit-test
+
+[ 4 ] [ 3 4 >r >r 2 get-local 2 drop-locals ] unit-test
+
+: get-local-test-1 3 >r 1 get-local r> drop ;
+
+{ 0 1 } [ get-local-test-1 ] must-infer-as
+
+[ 3 ] [ get-local-test-1 ] unit-test
+
+: get-local-test-2 3 4 >r >r 2 get-local 2 drop-locals ;
+
+{ 0 1 } [ get-local-test-2 ] must-infer-as
+
+[ 4 ] [ get-local-test-2 ] unit-test
+
+: get-local-test-3 3 4 >r >r 2 get-local r> r> 2array ;
+
+{ 0 2 } [ get-local-test-3 ] must-infer-as
+
+[ 4 { 3 4 } ] [ get-local-test-3 ] unit-test
+
+: get-local-test-4 3 4 >r >r r> r> dup swap >r swap >r r> r> 2array ;
+
+{ 0 2 } [ get-local-test-4 ] must-infer-as
+
+[ 4 { 3 4 } ] [ get-local-test-4 ] unit-test
+
+[ 1 2 ] [ 1 2 2 load-locals r> r> ] unit-test
+
+: load-locals-test-1 1 2 2 load-locals r> r> ;
+
+{ 0 2 } [ load-locals-test-1 ] must-infer-as
+
+[ 1 2 ] [ load-locals-test-1 ] unit-test

extra/locals/backend/backend.factor

@@ -0,0 +1,37 @@
+USING: math kernel slots.private inference.known-words
+inference.backend sequences effects words ;
+IN: locals.backend
+
+: load-locals ( n -- )
+    dup zero? [ drop ] [ swap >r 1- load-locals ] if ;
+
+: get-local ( n -- value )
+    dup zero? [ drop dup ] [ r> swap 1- get-local swap >r ] if ;
+
+: local-value 2 slot ; inline
+
+: set-local-value 2 set-slot ; inline
+
+: drop-locals ( n -- )
+    dup zero? [ drop ] [ r> drop 1- drop-locals ] if ;
+
+\ load-locals [
+    pop-literal nip
+    [ dup reverse <effect> infer-shuffle ]
+    [ infer->r ]
+    bi
+] "infer" set-word-prop
+
+\ get-local [
+    pop-literal nip
+    [ infer-r> ]
+    [ dup 0 prefix <effect> infer-shuffle ]
+    [ infer->r ]
+    tri
+] "infer" set-word-prop
+
+\ drop-locals [
+    pop-literal nip
+    [ infer-r> ]
+    [ { } <effect> infer-shuffle ] bi
+] "infer" set-word-prop

extra/locals/locals-tests.factor

@@ -82,6 +82,8 @@ IN: locals.tests
 
 0 write-test-1 "q" set
 
+{ 1 1 } "q" get must-infer-as
+
 [ 1 ] [ 1 "q" get call ] unit-test
 
 [ 2 ] [ 1 "q" get call ] unit-test

extra/locals/locals.factor

@@ -4,7 +4,8 @@ USING: kernel namespaces sequences sequences.private assocs math
 inference.transforms parser words quotations debugger macros
 arrays macros splitting combinators prettyprint.backend
 definitions prettyprint hashtables prettyprint.sections sets
-sequences.private effects generic compiler.units accessors ;
+sequences.private effects generic compiler.units accessors
+locals.backend ;
 IN: locals
 
 ! Inspired by
@@ -56,95 +57,80 @@ TUPLE: quote local ;
 
 C: <quote> quote
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! read-local
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 : local-index ( obj args -- n )
     [ dup quote? [ quote-local ] when eq? ] with find drop ;
 
-: read-local ( obj args -- quot )
+: read-local-quot ( obj args -- quot )
-    local-index 1+
+    local-index 1+ [ get-local ] curry ;
-    dup [ r> ] <repetition> concat [ dup ] append
-    swap [ swap >r ] <repetition> concat append ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! localize
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : localize-writer ( obj args -- quot )
-  >r "local-reader" word-prop r> read-local [ 0 swap set-array-nth ] append ;
+  >r "local-reader" word-prop r>
+  read-local-quot [ set-local-value ] append ;
 
 : localize ( obj args -- quot )
     {
-        { [ over local? ]        [ read-local ] }
+        { [ over local? ]        [ read-local-quot ] }
-        { [ over quote? ]        [ >r quote-local r> read-local ] }
+        { [ over quote? ]        [ >r quote-local r> read-local-quot ] }
-        { [ over local-word? ]   [ read-local [ call ] append ] }
+        { [ over local-word? ]   [ read-local-quot [ call ] append ] }
-        { [ over local-reader? ] [ read-local [ 0 swap array-nth ] append ] }
+        { [ over local-reader? ] [ read-local-quot [ local-value ] append ] }
         { [ over local-writer? ] [ localize-writer ] }
         { [ over \ lambda eq? ]  [ 2drop [ ] ] }
         { [ t ]                  [ drop 1quotation ] }
     } cond ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! point-free
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 UNION: special local quote local-word local-reader local-writer ;
 
-: load-local ( arg -- quot ) 
+: load-locals-quot ( args -- quot )
-    local-reader? [ 1array >r ] [ >r ] ? ;
+    dup [ local-reader? ] contains? [
+        <reversed> [
+            local-reader? [ 1array >r ] [ >r ] ?
+        ] map concat
+    ] [
+        length [ load-locals ] curry >quotation
+    ] if ;
 
-: load-locals ( quot args -- quot )
+: drop-locals-quot ( args -- quot )
-    nip <reversed> [ load-local ] map concat ;
+    length [ drop-locals ] curry ;
-
-: drop-locals ( args -- args quot )
-    dup length [ r> drop ] <repetition> concat ;
 
 : point-free-body ( quot args -- newquot )
     >r 1 head-slice* r> [ localize ] curry map concat ;
 
 : point-free-end ( quot args -- newquot )
     over peek special?
-    [ drop-locals >r >r peek r> localize r> append ]
+    [ dup drop-locals-quot >r >r peek r> localize r> append ]
-    [ drop-locals nip swap peek suffix ]
+    [ dup drop-locals-quot nip swap peek suffix ]
     if ;
 
 : (point-free) ( quot args -- newquot )
-    [ load-locals ] [ point-free-body ] [ point-free-end ]
+    [ nip load-locals-quot ]
+    [ point-free-body ]
+    [ point-free-end ]
     2tri 3append >quotation ;
 
 : point-free ( quot args -- newquot )
     over empty? [ drop ] [ (point-free) ] if ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! free-vars
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 UNION: lexical local local-reader local-writer local-word ;
 
-GENERIC: free-vars ( form -- vars )
+GENERIC: free-vars* ( form -- )
 
-: add-if-free ( vars object -- vars )
+: free-vars ( form -- vars )
+    [ free-vars* ] { } make prune ;
+
+: add-if-free ( object -- )
   {
-      { [ dup local-writer? ] [ "local-reader" word-prop suffix ] }
+      { [ dup local-writer? ] [ "local-reader" word-prop , ] }
-      { [ dup lexical? ]      [ suffix ] }
+      { [ dup lexical? ]      [ , ] }
-      { [ dup quote? ]        [ quote-local suffix ] }
+      { [ dup quote? ]        [ local>> , ] }
-      { [ t ]                 [ free-vars append ] }
+      { [ t ]                 [ free-vars* ] }
   } cond ;
 
-M: object free-vars drop { } ;
+M: object free-vars* drop ;
 
-M: quotation free-vars { } [ add-if-free ] reduce ;
+M: quotation free-vars* [ add-if-free ] each ;
 
-M: lambda free-vars
+M: lambda free-vars*
-    dup vars>> swap body>> free-vars diff ;
+    [ vars>> ] [ body>> ] bi free-vars diff % ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! lambda-rewrite
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 GENERIC: lambda-rewrite* ( obj -- )
 
@@ -172,8 +158,8 @@ M: lambda block-vars vars>> ;
 M: lambda block-body body>> ;
 
 M: lambda local-rewrite*
-    dup vars>> swap body>>
+    [ vars>> ] [ body>> ] bi
-    [ local-rewrite* \ call , ] [ ] make <lambda> , ;
+    [ [ local-rewrite* ] each ] [ ] make <lambda> , ;
 
 M: block lambda-rewrite*
     #! Turn free variables into bound variables, curry them
@@ -188,8 +174,6 @@ M: object lambda-rewrite* , ;
 
 M: object local-rewrite* , ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 : make-local ( name -- word )
     "!" ?tail [
         <local-reader>

extra/project-euler/076/076.factor

@@ -0,0 +1,53 @@
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs combinators kernel math sequences math.ranges locals ;
+IN: project-euler.076
+
+! http://projecteuler.net/index.php?section=problems&id=76
+
+! DESCRIPTION
+! -----------
+
+! How many different ways can one hundred be written as a
+! sum of at least two positive integers?
+
+! SOLUTION
+! --------
+
+! This solution uses dynamic programming and the following
+! recurence relation:
+
+! ways(0,_) = 1
+! ways(_,0) = 0
+! ways(n,i) = ways(n-i,i) + ways(n,i-1)
+
+<PRIVATE
+
+: init ( n -- table )
+    [1,b] [ 0 2array 0 ] H{ } map>assoc
+    1 { 0 0 } pick set-at ;
+
+: use ( n i -- n i )
+    [ - dup ] keep min ; inline
+
+: ways ( n i table -- )
+    over zero? [
+        3drop
+    ] [
+        [ [ 1-  2array ] dip at     ]
+        [ [ use 2array ] dip at +   ]
+        [ [     2array ] dip set-at ] 3tri
+    ] if ;
+
+:: each-subproblem ( n quot -- )
+    n [1,b] [ dup [1,b] quot with each ] each ; inline
+
+PRIVATE>
+
+: (euler076) ( n -- m )
+    dup init
+    [ [ ways ] curry each-subproblem ]
+    [ [ dup 2array ] dip at 1- ] 2bi ;
+
+: euler076 ( -- m )
+    100 (euler076) ;

extra/project-euler/116/116.factor

@@ -0,0 +1,55 @@
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.ranges sequences sequences.lib ;
+
+IN: project-euler.116
+
+! http://projecteuler.net/index.php?section=problems&id=116
+
+! DESCRIPTION
+! -----------
+
+! A row of five black square tiles is to have a number of its tiles replaced
+! with coloured oblong tiles chosen from red (length two), green (length
+! three), or blue (length four).
+
+! If red tiles are chosen there are exactly seven ways this can be done.
+! If green tiles are chosen there are three ways.
+! And if blue tiles are chosen there are two ways.
+
+! Assuming that colours cannot be mixed there are 7 + 3 + 2 = 12 ways of
+! replacing the black tiles in a row measuring five units in length.
+
+! How many different ways can the black tiles in a row measuring fifty units in
+! length be replaced if colours cannot be mixed and at least one coloured tile
+! must be used?
+
+! SOLUTION
+! --------
+
+! This solution uses a simple dynamic programming approach using the
+! following recurence relation
+
+! ways(n,_) = 0   | n < 0
+! ways(0,_) = 1
+! ways(n,i) = ways(n-i,i) + ways(n-1,i)
+! solution(n) = ways(n,1) - 1 + ways(n,2) - 1 + ways(n,3) - 1
+
+<PRIVATE
+
+: nth* ( n seq -- elt/0 )
+    [ length swap - 1- ] keep ?nth 0 or ;
+
+: next ( colortile seq -- )
+     [ nth* ] [ peek + ] [ push ] tri ;
+
+: ways ( length colortile -- permutations )
+    V{ 1 } clone [ [ next ] 2curry times ] keep peek 1- ;
+
+PRIVATE>
+
+: (euler116) ( length -- permutations )
+    3 [1,b] [ ways ] with sigma ;
+
+: euler116 ( -- permutations )
+    50 (euler116) ;

extra/project-euler/117/117.factor

@@ -0,0 +1,42 @@
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math splitting sequences ;
+
+IN: project-euler.117
+
+! http://projecteuler.net/index.php?section=problems&id=117
+
+! DESCRIPTION
+! -----------
+
+! Using a combination of black square tiles and oblong tiles chosen
+! from: red tiles measuring two units, green tiles measuring three
+! units, and blue tiles measuring four units, it is possible to tile a
+! row measuring five units in length in exactly fifteen different ways.
+
+!  How many ways can a row measuring fifty units in length be tiled?
+
+! SOLUTION
+! --------
+
+! This solution uses a simple dynamic programming approach using the
+! following recurence relation
+
+! ways(i) = 1 | i <= 0
+! ways(i) = ways(i-4) + ways(i-3) + ways(i-2) + ways(i-1)
+
+<PRIVATE
+
+: short ( seq n -- seq n )
+    over length min ;
+
+: next ( seq -- )
+    [ 4 short tail* sum ] keep push ;
+
+PRIVATE>
+
+: (euler117) ( n -- m )
+    V{ 1 } clone tuck [ next ] curry times peek ;
+
+: euler117 ( -- m )
+    50 (euler117) ;

extra/project-euler/150/150.factor

@@ -0,0 +1,44 @@
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences locals ;
+IN: project-euler.150
+
+<PRIVATE
+
+! sequence helper functions
+
+: partial-sums ( seq -- seq )
+    0 [ + ] accumulate swap suffix ; inline
+
+: generate ( n quot -- seq )
+    [ drop ] swap compose map ; inline
+
+: map-infimum ( seq quot -- min )
+    [ min ] compose 0 swap reduce ; inline
+
+
+! triangle generator functions
+
+: next ( t -- new-t s )
+    615949 * 797807 + 1 20 shift mod dup 1 19 shift - ; inline
+
+: sums-triangle ( -- seq )
+    0 1000 [ 1+ [ next ] generate partial-sums ] map nip ;
+
+PRIVATE>
+
+:: (euler150) ( m -- n )
+    [let | table [ sums-triangle ] |
+        m [| x |
+            x 1+ [| y |
+                m x - [| z |
+                    x z + table nth
+                    [ y z + 1+ swap nth ]
+                    [ y        swap nth ] bi -
+                ] map partial-sums infimum
+            ] map-infimum
+        ] map-infimum
+    ] ;
+
+: euler150 ( -- n )
+    1000 (euler150) ;

extra/random/blum-blum-shub/blum-blum-shub.factor

@@ -12,17 +12,16 @@ TUPLE: blum-blum-shub x n ;
 : generate-bbs-primes ( numbits -- p q )
     [ [ random-prime ] curry [ 4 mod 3 = ] generate ] dup bi ;
 
+: next-bbs-bit ( bbs -- bit )
+    [ [ x>> 2 ] [ n>> ] bi ^mod dup ] keep (>>x) 1 bitand ;
+
+PRIVATE>
+
 : <blum-blum-shub> ( numbits -- blum-blum-shub )
     generate-bbs-primes *
     [ find-relative-prime ] keep
     blum-blum-shub boa ;
 
-: next-bbs-bit ( bbs -- bit )
-    [ [ x>> 2 ] [ n>> ] bi ^mod ] keep
-    over >>x drop 1 bitand ;
-
-PRIVATE>
-
 M: blum-blum-shub random-32* ( bbs -- r )
     0 32 rot
     [ next-bbs-bit swap 1 shift bitor ] curry times ;

extra/regexp/regexp-tests.factor

@@ -226,3 +226,10 @@ IN: regexp-tests
 [ t ] [ "s@f" "[a-z.-]@[a-z]" f <regexp> matches? ] unit-test
 [ f ] [ "a" "[a-z.-]@[a-z]" f <regexp> matches? ] unit-test
 [ t ] [ ".o" "\\.[a-z]" f <regexp> matches? ] unit-test
+
+! Bug in parsing word
+[ t ] [
+    "a"
+    R' a'
+    matches?
+] unit-test

extra/regexp/regexp.factor

@@ -290,10 +290,11 @@ TUPLE: regexp source parser ignore-case? ;
     } case ;
 
 : parse-regexp ( accum end -- accum )
-    lexer get dup skip-blank [
+    lexer get dup skip-blank
-        [ index* dup 1+ swap ] 2keep swapd subseq swap
+    [ [ index* dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
-    ] change-lexer-column
+    lexer get dup still-parsing-line?
-    lexer get (parse-token) parse-options <regexp> parsed ;
+    [ (parse-token) parse-options ] [ drop f ] if
+    <regexp> parsed ;
 
 : R! CHAR: ! parse-regexp ; parsing
 : R" CHAR: " parse-regexp ; parsing

extra/rss/rss-tests.factor

@@ -1,4 +1,5 @@
-USING: rss io kernel io.files tools.test io.encodings.utf8 ;
+USING: rss io kernel io.files tools.test io.encodings.utf8
+calendar ;
 IN: rss.tests
 
 : load-news-file ( filename -- feed )
@@ -35,7 +36,7 @@ IN: rss.tests
             "http://example.org/2005/04/02/atom"
             "\n         <div xmlns=\"http://www.w3.org/1999/xhtml\">\n           <p><i>[Update: The Atom draft is finished.]</i></p>\n         </div>\n       "
 
-            "2003-12-13T08:29:29-04:00"
+            T{ timestamp f 2003 12 13 8 29 29 -4 }
         }
     }
 } ] [ "extra/rss/atom.xml" resource-path load-news-file ] unit-test

extra/rss/rss.factor

@@ -4,10 +4,8 @@ IN: rss
 USING: xml.utilities kernel assocs xml.generator
     strings sequences xml.data xml.writer
     io.streams.string combinators xml xml.entities io.files io
-    http.client namespaces xml.generator hashtables ;
+    http.client namespaces xml.generator hashtables
-
+    calendar.format accessors continuations ;
-: ?children>string ( tag/f -- string/f )
-    [ children>string ] [ f ] if* ;
 
 : any-tag-named ( tag names -- tag-inside )
     f -rot [ tag-named nip dup ] with find 2drop ;
@@ -25,7 +23,7 @@ C: <entry> entry
     [ "link" tag-named children>string ] keep
     [ "description" tag-named children>string ] keep
     f "date" "http://purl.org/dc/elements/1.1/" <name>
-    tag-named ?children>string
+    tag-named dup [ children>string rfc3339>timestamp ] when
     <entry> ;
 
 : rss1.0 ( xml -- feed )
@@ -41,7 +39,7 @@ C: <entry> entry
     [ "link" tag-named ] keep
     [ "guid" tag-named dupd ? children>string ] keep
     [ "description" tag-named children>string ] keep
-    "pubDate" tag-named children>string <entry> ;
+    "pubDate" tag-named children>string rfc3339>timestamp <entry> ;
 
 : rss2.0 ( xml -- feed )
     "channel" tag-named 
@@ -59,7 +57,7 @@ C: <entry> entry
         [ children>string ] if
     ] keep
     { "published" "updated" "issued" "modified" } any-tag-named
-    children>string <entry> ;
+    children>string rfc3339>timestamp <entry> ;
 
 : atom1.0 ( xml -- feed )
     [ "title" tag-named children>string ] keep
@@ -78,10 +76,10 @@ C: <entry> entry
 
 : download-feed ( url -- feed )
     #! Retrieve an news syndication file, return as a feed tuple.
-    http-get-stream rot success? [
+    http-get-stream swap code>> success? [
-        nip read-feed
+        read-feed
     ] [
-        2drop "Error retrieving newsfeed file" throw
+        dispose "Error retrieving newsfeed file" throw
     ] if ;
 
 ! Atom generation
@@ -95,7 +93,7 @@ C: <entry> entry
     "entry" [
         dup entry-title "title" { { "type" "html" } } simple-tag*,
         "link" over entry-link "href" associate contained*,
-        dup entry-pub-date "published" simple-tag,
+        dup entry-pub-date timestamp>rfc3339 "published" simple-tag,
         entry-description [ "content" { { "type" "html" } } simple-tag*, ] when*
     ] tag, ;
 

extra/shell/parser/parser.factor

@@ -0,0 +1,73 @@
+
+USING: kernel arrays strings sequences sequences.deep peg peg.ebnf ;
+
+IN: shell.parser
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: incantation command stdin stdout background ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: single-quoted-expr expr ;
+TUPLE: double-quoted-expr expr ;
+TUPLE: back-quoted-expr   expr ;
+TUPLE: glob-expr          expr ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: <single-quoted-expr> single-quoted-expr boa ;
+: <double-quoted-expr> double-quoted-expr boa ;
+: <back-quoted-expr>   back-quoted-expr boa ;
+: <glob-expr>          glob-expr boa ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+EBNF: expr
+
+space = " "
+
+tab   = "\t"
+
+white = (space | tab)
+
+whitespace = (white)* => [[ drop ignore ]]
+
+squote        = "'"
+
+single-quoted = squote (!(squote) .)* squote => [[ second >string <single-quoted-expr> ]]
+
+dquote        = '"'
+
+double-quoted = dquote (!(dquote) .)* dquote => [[ second >string <double-quoted-expr> ]]
+
+bquote = "`"
+
+back-quoted = bquote (!(bquote) .)* bquote => [[ second >string <back-quoted-expr> ]]
+
+glob-char = ("*" | "?")
+
+non-glob-char = !(glob-char | white) .
+
+glob-beginning-string = (non-glob-char)* [[ >string ]]
+
+glob-rest-string = (non-glob-char)+ [[ >string ]]
+
+glob = glob-beginning-string glob-char (glob-rest-string | glob-char)* => [[ flatten concat <glob-expr> ]]
+
+other = (!(white | "&" | ">" | ">>" | "<") .)+ => [[ >string ]]
+
+element = (single-quoted | double-quoted | back-quoted | glob | other)
+
+to-file = ">" whitespace other => [[ second ]]
+
+in-file = "<" whitespace other => [[ second ]]
+
+ap-file = ">>" whitespace other  => [[ second ]]
+
+redirection = (in-file)? whitespace (to-file | ap-file)?
+
+line = (element whitespace)+ (in-file)? whitespace (to-file | ap-file)? whitespace ("&")? => [[ first4 incantation boa ]]
+
+;EBNF
+

extra/shell/shell.factor

@@ -0,0 +1,88 @@
+
+USING: kernel words continuations namespaces debugger sequences combinators
+       io io.files io.launcher
+       accessors multi-methods newfx shell.parser ;
+
+IN: shell
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cd ( args -- )
+  dup empty?
+    [ drop home set-current-directory ]
+    [ first     set-current-directory ]
+  if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pwd ( args -- )
+  drop
+  current-directory get
+  print ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: swords ( -- seq ) { "cd" "pwd" } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: expand ( expr -- expr )
+
+METHOD: expand { single-quoted-expr } expr>> ;
+
+METHOD: expand { double-quoted-expr } expr>> ;
+
+METHOD: expand { object } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: expansion ( command -- command ) [ expand ] map ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run-incantation ( incantation -- )
+  <process>
+    over command>> expansion >>command
+    over stdin>>             >>stdin
+    over stdout>>            >>stdout
+  swap background>>
+    [ run-detached drop ]
+    [ [ try-process ] [ print-error drop ] recover ]
+  if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: chant ( incantation -- )
+    dup command>> first swords member-of?
+      [ command>> unclip "shell" lookup execute ]
+      [ run-incantation ]
+    if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: prompt ( -- )
+  current-directory get write
+  " $ " write
+  flush ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: shell ( -- )
+  prompt
+  readln
+    {
+      { [ dup f = ] [ drop ] }
+      { [ dup "exit" = ] [ drop ] }
+      { [ dup "" = ] [ drop shell ] }
+      { [ dup expr ] [ expr ast>> chant shell ] }
+      { [ t ]        [ drop shell ] }
+    }
+  cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ix ( -- ) shell ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: ix

extra/tools/deploy/backend/backend.factor

@@ -9,6 +9,15 @@ quotations io.launcher words.private tools.deploy.config
 bootstrap.image io.encodings.utf8 accessors ;
 IN: tools.deploy.backend
     
+: copy-vm ( executable bundle-name extension -- vm )
+  [ prepend-path ] dip append vm over copy-file ;
+  
+: copy-fonts ( name dir -- )  
+  append-path "fonts/" resource-path swap copy-tree-into ;
+  
+: image-name ( vocab bundle-name -- str )  
+  prepend-path ".image" append ;
+
 : (copy-lines) ( stream -- )
     dup stream-readln dup
     [ print flush (copy-lines) ] [ 2drop ] if ;

extra/tools/deploy/deploy-docs.factor

@@ -7,7 +7,12 @@ ARTICLE: "tools.deploy" "Application deployment"
 $nl
 "For example, we can deploy the " { $vocab-link "hello-world" } " demo which comes with Factor:"
 { $code "\"hello-ui\" deploy" }
-"On Mac OS X, this yields a program named " { $snippet "Hello world.app" } ". On Windows, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui.exe" } ". In both cases, running the program displays a window with a message."
+{ $list
+   { "On Mac OS X, this yields a program named " { $snippet "Hello world.app" } "." }
+   { "On Windows, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui.exe" } "." }
+   { "On Unix-like systems (Linux, BSD, Solaris, etc), it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui" } "." }
+}
+"In all cases, running the program displays a window with a message."
 $nl
 "The deployment tool works by bootstrapping a fresh image, loading the vocabulary into this image, then applying various heuristics to strip the image down to minimal size."
 $nl

extra/tools/deploy/deploy.factor

@@ -7,3 +7,4 @@ IN: tools.deploy
 
 os macosx? [ "tools.deploy.macosx" require ] when
 os winnt? [ "tools.deploy.windows" require ] when
+os unix? [ "tools.deploy.unix" require ] when

extra/tools/deploy/macosx/macosx.factor

@@ -14,13 +14,6 @@ IN: tools.deploy.macosx
     bundle-dir over append-path -rot
     "Contents" prepend-path append-path copy-tree ;
 
-: copy-vm ( executable bundle-name -- vm )
-    "Contents/MacOS/" append-path prepend-path vm over copy-file ;
-
-: copy-fonts ( name -- )
-    "fonts/" resource-path
-    swap "Contents/Resources/" append-path copy-tree-into ;
-
 : app-plist ( executable bundle-name -- assoc )
     [
         "6.0" "CFBundleInfoDictionaryVersion" set
@@ -40,8 +33,8 @@ IN: tools.deploy.macosx
 : create-app-dir ( vocab bundle-name -- vm )
     dup "Frameworks" copy-bundle-dir
     dup "Resources/English.lproj/MiniFactor.nib" copy-bundle-dir
-    dup copy-fonts
+    dup "Contents/Resources/" copy-fonts
-    2dup create-app-plist copy-vm ;
+    2dup create-app-plist "Contents/MacOS/" append-path "" copy-vm ;
 
 : deploy.app-image ( vocab bundle-name -- str )
     [ % "/Contents/Resources/" % % ".image" % ] "" make ;

extra/tools/deploy/unix/authors.txt

@@ -0,0 +1 @@
+James Cash

extra/tools/deploy/unix/summary.txt

@@ -0,0 +1 @@
+Deploying minimal stand-alone binaries on *nix-like systems

extra/tools/deploy/unix/tags.txt

@@ -0,0 +1 @@
+tools

extra/tools/deploy/unix/unix.factor

@@ -0,0 +1,23 @@
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.files io.backend kernel namespaces sequences
+system tools.deploy.backend tools.deploy.config assocs
+hashtables prettyprint ;
+IN: tools.deploy.linux
+  
+: create-app-dir ( vocab bundle-name -- vm )  
+  dup "" copy-fonts
+  "" copy-vm ;
+  
+: bundle-name ( -- str )  
+  deploy-name get ;
+
+M: linux deploy* ( vocab -- )
+   "." resource-path [
+       dup deploy-config [
+           [ bundle-name create-app-dir ] keep
+           [ bundle-name image-name ] keep
+           namespace make-deploy-image
+           bundle-name normalize-path [ "Binary deployed to " % % "." % ] "" make print
+     ] bind
+   ] with-directory ;  

extra/tools/deploy/windows/windows.factor

@@ -5,13 +5,6 @@ tools.deploy.backend tools.deploy.config assocs hashtables
 prettyprint windows.shell32 windows.user32 ;
 IN: tools.deploy.windows
 
-: copy-vm ( executable bundle-name -- vm )
-    prepend-path ".exe" append
-    vm over copy-file ;
-
-: copy-fonts ( bundle-name -- )
-    "fonts/" resource-path swap copy-tree-into ;
-
 : copy-dlls ( bundle-name -- )
     { "freetype6.dll" "zlib1.dll" "factor.dll" }
     [ resource-path ] map
@@ -19,11 +12,8 @@ IN: tools.deploy.windows
 
 : create-exe-dir ( vocab bundle-name -- vm )
     dup copy-dlls
-    dup copy-fonts
+    dup "" copy-fonts
-    copy-vm ;
+    ".exe" copy-vm ;
-
-: image-name ( vocab bundle-name -- str )
-    prepend-path ".image" append ;
 
 M: winnt deploy*
     "." resource-path [

extra/tools/walker/walker.factor

@@ -138,7 +138,6 @@ SYMBOL: +stopped+
     >n ndrop >c c>
     continue continue-with
     stop yield suspend sleep (spawn)
-    suspend
 } [
     dup [ execute break ] curry
     "step-into" set-word-prop

extra/ui/tools/listener/listener.factor

@@ -111,7 +111,7 @@ M: method-body word-completion-string
 
 USE: generic.standard.engines.tuple
 
-M: tuple-dispatch-engine-word word-completion-string
+M: engine-word word-completion-string
     "engine-generic" word-prop word-completion-string ;
 
 : use-if-necessary ( word seq -- )

extra/webapps/todo/todo.css

@@ -7,7 +7,7 @@
 	background-color: #f5f5f5;
 	padding: 5px;
 	font-size: 150%;
-	color: #000000;3
+	color: #000000;
 }
 
 .link-button {

extra/webapps/todo/todo.factor

@@ -53,7 +53,7 @@ todo "TODO"
 : <todo-list-form> ( -- form )
     "todo-list" <form>
         "todo-list" todo-template >>view-template
-        "list" <todo-form> <list>
+        "list" <todo-form> +plain+ <list>
         add-field ;
 
 TUPLE: todo-responder < dispatcher ;

extra/xmode/catalog/catalog.factor

@@ -36,9 +36,13 @@ TAGS>
     f \ modes set-global ;
 
 MEMO: (load-mode) ( name -- rule-sets )
-    modes at mode-file
+    modes at [
+        mode-file
         "extra/xmode/modes/" prepend
-    resource-path utf8 <file-reader> parse-mode ;
+        resource-path utf8 <file-reader> parse-mode
+    ] [
+        "text" (load-mode)
+    ] if* ;
 
 SYMBOL: rule-sets
 

vm/ffi_test.c

@@ -250,3 +250,13 @@ double ffi_test_36(struct test_struct_12 x)
 {
 	return x.x;
 }
+
+int ffi_test_37(int (*f)(int, int, int))
+{
+	static int global_var = 0;
+	printf("ffi_test_37\n");
+	global_var = f(global_var,global_var * 2,global_var * 3);
+	printf("global_var is %d\n",global_var);
+	fflush(stdout);
+	return global_var;
+}