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

basis/alien/structs/fields/fields.factor

@@ -29,7 +29,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
     writer>> swap "writing" set-word-prop ;
 
 : reader-word ( class name vocab -- word )
-    [ "-" swap 3append ] dip create ;
+    [ "-" glue ] dip create ;
 
 : writer-word ( class name vocab -- word )
     [ [ swap "set-" % % "-" % % ] "" make ] dip create ;

basis/compiler/tree/builder/builder.factor

@@ -21,7 +21,7 @@ IN: compiler.tree.builder
 : build-tree-with ( in-stack quot -- nodes out-stack )
     #! Not safe to call from inference transforms.
     [
-        [ >vector meta-d set ]
+        [ >vector \ meta-d set ]
         [ f initial-recursive-state infer-quot ] bi*
     ] with-tree-builder nip
     unclip-last in-d>> ;

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -20,6 +20,10 @@ SYMBOL: node-count
 : count-nodes ( nodes -- )
     0 swap [ drop 1+ ] each-node node-count set ;
 
+! We try not to inline the same word too many times, to avoid
+! combinatorial explosion
+SYMBOL: inlining-count
+
 ! Splicing nodes
 GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
 
@@ -120,17 +124,25 @@ DEFER: (flat-length)
         bi and
     ] contains? ;
 
+: node-count-bias ( -- n )
+    45 node-count get [-] 8 /i ;
+
+: body-length-bias ( word -- n )
+    [ flat-length ] [ inlining-count get at 0 or 2/ 1+ ] bi *
+    24 swap [-] 4 /i ;
+
 : inlining-rank ( #call word -- n )
     [ classes-known? 2 0 ? ]
     [
         {
-            [ drop node-count get 45 swap [-] 8 /i ]
+            [ body-length-bias ]
-            [ flat-length 24 swap [-] 4 /i ]
             [ "default" word-prop -4 0 ? ]
             [ "specializer" word-prop 1 0 ? ]
             [ method-body? 1 0 ? ]
         } cleave
-    ] bi* + + + + + ;
+        node-count-bias
+        loop-nesting get 0 or 2 *
+    ] bi* + + + + + + ;
 
 : should-inline? ( #call word -- ? )
     dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
@@ -138,12 +150,12 @@ DEFER: (flat-length)
 SYMBOL: history
 
 : remember-inlining ( word -- )
-    history [ swap suffix ] change ;
+    [ [ 1 ] dip inlining-count get at+ ]
+    [ history [ swap suffix ] change ]
+    bi ;
 
 : inline-word-def ( #call word quot -- ? )
-    over history get memq? [
+    over history get memq? [ 3drop f ] [
-        3drop f
-    ] [
         [
             swap remember-inlining
             dupd splicing-nodes >>body

basis/compiler/tree/propagation/nodes/nodes.factor

@@ -6,6 +6,8 @@ compiler.tree.propagation.copy
 compiler.tree.propagation.info ;
 IN: compiler.tree.propagation.nodes
 
+SYMBOL: loop-nesting
+
 GENERIC: propagate-before ( node -- )
 
 GENERIC: propagate-after ( node -- )

basis/compiler/tree/propagation/propagation.factor

@@ -19,5 +19,6 @@ IN: compiler.tree.propagation
     H{ } clone copies set
     H{ } clone 1array value-infos set
     H{ } clone 1array constraints set
+    H{ } clone inlining-count set
     dup count-nodes
     dup (propagate) ;

basis/compiler/tree/propagation/recursive/recursive.factor

@@ -55,6 +55,8 @@ IN: compiler.tree.propagation.recursive
 M: #recursive propagate-around ( #recursive -- )
     constraints [ H{ } clone suffix ] change
     [
+        loop-nesting inc
+
         constraints [ but-last H{ } clone suffix ] change
 
         child>>
@@ -62,6 +64,8 @@ M: #recursive propagate-around ( #recursive -- )
         [ first propagate-recursive-phi ]
         [ (propagate) ]
         tri
+
+        loop-nesting dec
     ] until-fixed-point ;
 
 : recursive-phi-infos ( node -- infos )

basis/db/postgresql/postgresql.factor

@@ -266,8 +266,8 @@ M: postgresql-db persistent-table ( -- hashtable )
 ERROR: no-compound-found string object ;
 M: postgresql-db compound ( string object -- string' )
     over {
-        { "default" [ first number>string join-space ] }
+        { "default" [ first number>string " " glue ] }
-        { "varchar" [ first number>string paren append ] }
+        { "varchar" [ first number>string "(" ")" surround append ] }
         { "references" [ >reference-string ] }
         [ drop no-compound-found ]
     } case ;

basis/db/queries/queries.factor

@@ -162,22 +162,19 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
         where-clause
     ] query-make ;
 
-: splice ( string1 string2 string3 -- string )
-    swap 3append ;
-
 : do-group ( tuple groups -- )
     dup string? [ 1array ] when
-    [ ", " join " group by " splice ] curry change-sql drop ;
+    [ ", " join " group by " glue ] curry change-sql drop ;
 
 : do-order ( tuple order -- )
     dup string? [ 1array ] when
-    [ ", " join " order by " splice ] curry change-sql drop ;
+    [ ", " join " order by " glue ] curry change-sql drop ;
 
 : do-offset ( tuple n -- )
-    [ number>string " offset " splice ] curry change-sql drop ;
+    [ number>string " offset " glue ] curry change-sql drop ;
 
 : do-limit ( tuple n -- )
-    [ number>string " limit " splice ] curry change-sql drop ;
+    [ number>string " limit " glue ] curry change-sql drop ;
 
 : make-query* ( tuple query -- tuple' )
     dupd

basis/db/sqlite/sqlite.factor

@@ -308,7 +308,7 @@ M: sqlite-db persistent-table ( -- assoc )
 
 M: sqlite-db compound ( string seq -- new-string )
     over {
-        { "default" [ first number>string join-space ] }
+        { "default" [ first number>string " " glue ] }
         { "references" [
             [ >reference-string ] keep
             first2 [ "foreign-table" set ]

basis/db/types/types-docs.factor

@@ -147,12 +147,6 @@ HELP: get-slot-named
      { "value" "the value stored in the slot" } }
 { $description "Returns the value stored in a tuple slot, where the tuple slot is a string." } ;
 
-HELP: join-space
-{ $values
-     { "string1" string } { "string2" string }
-     { "new-string" null } }
-{ $description "" } ;
-
 HELP: literal-bind
 { $description "" } ;
 

basis/db/types/types.factor

@@ -158,12 +158,6 @@ ERROR: no-sql-type type ;
     modifiers>> [ lookup-modifier ] map " " join
     [ "" ] [ " " prepend ] if-empty ;
 
-: join-space ( string1 string2 -- new-string )
-    " " swap 3append ;
-
-: paren ( string -- new-string )
-    "(" swap ")" 3append ;
-
 HOOK: bind% db ( spec -- )
 HOOK: bind# db ( spec obj -- )
 
@@ -171,7 +165,7 @@ ERROR: no-column column ;
 
 : >reference-string ( string pair -- string )
     first2
-    [ [ unparse join-space ] [ db-columns ] bi ] dip
+    [ [ unparse " " glue ] [ db-columns ] bi ] dip
     swap [ column-name>> = ] with find nip
     [ no-column ] unless*
-    column-name>> paren append ;
+    column-name>> "(" ")" surround append ;

basis/editors/scite/scite.factor

@@ -14,7 +14,10 @@ IN: editors.scite
 
 : scite-path ( -- path )
     \ scite-path get-global [
-        program-files "wscite\\SciTE.exe" append-path
+        program-files "ScITE Source Code Editor\\SciTE.exe" append-path
+        dup exists? [
+            drop program-files "wscite\\SciTE.exe" append-path
+        ] unless
     ] unless* ;
 
 : scite-command ( file line -- cmd )

basis/environment/environment.factor

@@ -18,7 +18,7 @@ HOOK: (set-os-envs) os ( seq -- )
     (os-envs) [ "=" split1 ] H{ } map>assoc ;
 
 : set-os-envs ( assoc -- )
-    [ "=" swap 3append ] { } assoc>map (set-os-envs) ;
+    [ "=" glue ] { } assoc>map (set-os-envs) ;
 
 {
     { [ os unix? ] [ "environment.unix" require ] }

basis/ftp/server/server.factor

@@ -7,8 +7,7 @@ namespaces make sequences ftp io.unix.launcher.parser
 unicode.case splitting assocs classes io.servers.connection
 destructors calendar io.timeouts io.streams.duplex threads
 continuations math concurrency.promises byte-arrays
-io.backend sequences.lib tools.hexdump tools.files
+io.backend tools.hexdump tools.files io.streams.string ;
-io.streams.string ;
 IN: ftp.server
 
 TUPLE: ftp-client url mode state command-promise user password ;
@@ -231,7 +230,7 @@ M: ftp-put service-command ( stream obj -- )
     expect-connection
     [
         "Entering Passive Mode (127,0,0,1," %
-        port>bytes [ number>string ] bi@ "," splice %
+        port>bytes [ number>string ] bi@ "," glue %
         ")" %
     ] "" make 227 swap server-response ;
 

basis/furnace/utilities/utilities.factor

@@ -7,7 +7,7 @@ http.server.redirection http.server.remapping ;
 IN: furnace.utilities
 
 : word>string ( word -- string )
-    [ vocabulary>> ] [ name>> ] bi ":" swap 3append ;
+    [ vocabulary>> ] [ name>> ] bi ":" glue ;
 
 : words>strings ( seq -- seq' )
     [ word>string ] map ;

basis/http/http.factor

@@ -111,7 +111,7 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s
                 { [ dup real? ] [ number>string ] }
                 [ ]
             } cond
-            [ check-cookie-string ] bi@ "=" swap 3append ,
+            [ check-cookie-string ] bi@ "=" glue ,
         ]
     } case ;
 

basis/interpolate/interpolate-tests.factor

@@ -1,4 +1,22 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test interpolate ;
+USING: interpolate io.streams.string namespaces tools.test locals ;
 IN: interpolate.tests
+
+[ "Hello, Jane." ] [
+    "Jane" "name" set
+    [ "Hello, ${name}." interpolate ] with-string-writer
+] unit-test
+
+[ "Sup Dawg, we heard you liked rims, so we put rims on your rims so you can roll while you roll." ] [
+    "Dawg" "name" set
+    "rims" "noun" set
+    "roll" "verb" set
+    [ "Sup ${name}, we heard you liked ${noun}, so we put ${noun} on your ${noun} so you can ${verb} while you ${verb}." interpolate ] with-string-writer
+] unit-test
+
+[ "Oops, I accidentally the whole economy..." ] [
+    [let | noun [ "economy" ] |
+        [ I[ Oops, I accidentally the whole ${noun}...]I ] with-string-writer
+    ]
+] unit-test

basis/interpolate/interpolate.factor

@@ -1,21 +1,40 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io kernel macros make multiline namespaces parser
-peg.ebnf present sequences strings ;
+present sequences strings splitting fry accessors ;
 IN: interpolate
 
-MACRO: interpolate ( string -- )
+TUPLE: interpolate-var name ;
-[EBNF
-var = "${" [^}]+ "}" => [[ second >string [ get present write ] curry ]]
-text = [^$]+ => [[ >string [ write ] curry ]]
-interpolate = (var|text)* => [[ [ ] join ]]
-EBNF] ;
 
-EBNF: interpolate-locals
+: (parse-interpolate) ( string -- )
-var = "${" [^}]+ "}" => [[ [ second >string search , [ present write ] % ] [ ] make ]]
+    [
-text = [^$]+ => [[ [ >string , [ write ] % ] [ ] make ]]
+        "${" split1-slice [ >string , ] [
-interpolate = (var|text)* => [[ [ ] join ]]
+            [
-;EBNF
+                "}" split1-slice
+                [ >string interpolate-var boa , ]
+                [ (parse-interpolate) ] bi*
+            ] when*
+        ] bi*
+    ] unless-empty ;
+
+: parse-interpolate ( string -- seq )
+    [ (parse-interpolate) ] { } make ;
+
+MACRO: interpolate ( string -- )
+    parse-interpolate [
+        dup interpolate-var?
+        [ name>> '[ _ get present write ] ]
+        [ '[ _ write ] ]
+        if
+    ] map [ ] join ;
+
+: interpolate-locals ( string -- quot )
+    parse-interpolate [
+        dup interpolate-var?
+        [ name>> search '[ _ present write ] ]
+        [ '[ _ write ] ]
+        if
+    ] map [ ] join ;
 
 : I[ "]I" parse-multiline-string
     interpolate-locals parsed \ call parsed ; parsing

basis/io/files/unique/unique.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.bitwise combinators.lib math.parser
+USING: kernel math math.bitwise math.parser
-random sequences sequences.lib continuations namespaces
+random sequences continuations namespaces
 io.files io arrays io.files.unique.backend system
 combinators vocabs.loader fry ;
 IN: io.files.unique
@@ -29,7 +29,7 @@ PRIVATE>
 : make-unique-file ( prefix suffix -- path )
     temporary-path -rot
     [
-        unique-length get random-name swap 3append append-path
+        unique-length get random-name glue append-path
         dup (make-unique-file)
     ] 3curry unique-retries get retry ;
 

basis/io/mmap/ushort/ushort.factor

@@ -1,4 +1,4 @@
-USE: specialized-arrays.functor
+USING: io.mmap.functor specialized-arrays.direct.ushort ;
-IN: specialized-arrays.ushort
+IN: io.mmap.ushort
 
-<< "ushort" define-array >>
+<< "ushort" define-mapped-array >>

basis/io/servers/connection/connection.factor

@@ -79,7 +79,7 @@ M: threaded-server handle-client* handler>> call ;
 \ handle-client ERROR add-error-logging
 
 : thread-name ( server-name addrspec -- string )
-    unparse-short " connection from " swap 3append ;
+    unparse-short " connection from " glue ;
 
 : accept-connection ( threaded-server -- )
     [ accept ] [ addr>> ] bi

basis/io/sockets/sockets.factor

@@ -115,7 +115,7 @@ M: invalid-inet6 summary drop "Invalid IPv6 address" ;
 : pad-inet6 ( string1 string2 -- seq )
     2dup [ length ] bi@ + 8 swap -
     dup 0 < [ "More than 8 components" throw ] when
-    <byte-array> swap 3append ;
+    <byte-array> glue ;
 
 : inet6-bytes ( seq -- bytes )
     [ 2 >be ] { } map-as concat >byte-array ;

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

@@ -4,7 +4,7 @@ USING: alien.syntax kernel unix.stat math unix
 combinators system io.backend accessors alien.c-types
 io.encodings.utf8 alien.strings unix.types io.unix.files
 io.files unix.statvfs.netbsd unix.getfsstat.netbsd
-grouping sequences ;
+grouping sequences io.encodings.utf8 ;
 IN: io.unix.files.netbsd
 
 TUPLE: netbsd-file-system-info < unix-file-system-info
@@ -40,13 +40,13 @@ M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-inf
         [ statvfs-f_namemax >>name-max ]
         [ statvfs-f_owner >>owner ]
         ! [ statvfs-f_spare >>spare ]
-        [ statvfs-f_fstypename alien>native-string >>type ]
+        [ statvfs-f_fstypename utf8 alien>string >>type ]
-        [ statvfs-f_mntonname alien>native-string >>mount-point ]
+        [ statvfs-f_mntonname utf8 alien>string >>mount-point ]
-        [ statvfs-f_mntfromname alien>native-string >>device-name ]
+        [ statvfs-f_mntfromname utf8 alien>string >>device-name ]
     } cleave ;
 
 M: netbsd file-systems ( -- array )
     f 0 0 getvfsstat dup io-error
     "statvfs" <c-array> dup dup length 0 getvfsstat io-error
     "statvfs" heap-size group
-    [ statvfs-f_mntonname alien>native-string file-system-info ] map ;
+    [ statvfs-f_mntonname utf8 alien>string file-system-info ] map ;

basis/io/unix/launcher/launcher.factor

@@ -16,7 +16,7 @@ USE: unix
     command>> dup string? [ tokenize-command ] when ;
 
 : assoc>env ( assoc -- env )
-    [ "=" swap 3append ] { } assoc>map ;
+    [ "=" glue ] { } assoc>map ;
 
 : setup-priority ( process -- process )
     dup priority>> [

basis/io/windows/mmap/mmap-tests.factor

@@ -1,8 +0,0 @@
-USING: io io.mmap io.files kernel tools.test continuations
-sequences io.encodings.ascii accessors ;
-IN: io.windows.mmap.tests
-
-[ ] [ "a" "mmap-grow-test.txt" temp-file ascii set-file-contents ] unit-test
-[ 1 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test
-[ ] [ "mmap-grow-test.txt" temp-file 100 [ [ ] change-each ] with-mapped-file ] unit-test
-[ 100 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test

basis/math/statistics/statistics-docs.factor

@@ -10,6 +10,7 @@ HELP: geometric-mean
 HELP: harmonic-mean
 { $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
 { $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." }
+{ $notes "Positive reals only." }
 { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } harmonic-mean ." "6/11" } }
 { $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
 
@@ -36,7 +37,7 @@ HELP: range
 
 HELP: std
 { $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
-{ $description "Computes the standard deviation of " { $snippet "seq" } " by squaring the variance of the sequence.  It measures how widely spread the values in a sequence are about the mean." }
+{ $description "Computes the standard deviation of " { $snippet "seq" } ", which is the square root of the variance. It measures how widely spread the values in a sequence are about the mean." }
 { $examples
   { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } std ." "1.0" }
   { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } std ." "1.290994448735806" } } ;

basis/math/statistics/statistics.factor

@@ -5,20 +5,15 @@ USING: arrays combinators kernel math math.analysis math.functions sequences
 IN: math.statistics
 
 : mean ( seq -- n )
-    #! arithmetic mean, sum divided by length
     [ sum ] [ length ] bi / ;
 
 : geometric-mean ( seq -- n )
-    #! geometric mean, nth root of product
     [ length ] [ product ] bi nth-root ;
 
 : harmonic-mean ( seq -- n )
-    #! harmonic mean, reciprocal of sum of reciprocals.
-    #! positive reals only
     [ recip ] sigma recip ;
 
 : median ( seq -- n )
-    #! middle number if odd, avg of two middle numbers if even
     natural-sort dup length even? [
         [ midpoint@ dup 1- 2array ] keep nths mean
     ] [
@@ -26,11 +21,10 @@ IN: math.statistics
     ] if ;
 
 : range ( seq -- n )
-    #! max - min
     minmax swap - ;
 
 : var ( seq -- x )
-    #! variance, normalize by N-1
+    #! normalize by N-1
     dup length 1 <= [
         drop 0
     ] [
@@ -39,11 +33,9 @@ IN: math.statistics
     ] if ;
 
 : std ( seq -- x )
-    #! standard deviation, sqrt of variance
     var sqrt ;
 
 : ste ( seq -- x )
-    #! standard error, standard deviation / sqrt ( length of sequence )
     [ std ] [ length ] bi sqrt / ;
 
 : ((r)) ( mean(x) mean(y) {x} {y} -- (r) )

basis/prettyprint/prettyprint.factor

@@ -129,7 +129,7 @@ SYMBOL: ->
 : remove-breakpoints ( quot pos -- quot' )
     over quotation? [
         1+ cut [ (remove-breakpoints) ] bi@
-        [ -> ] swap 3append
+        [ -> ] glue 
     ] [
         drop
     ] if ;

basis/random/mersenne-twister/mersenne-twister.factor

@@ -15,11 +15,14 @@ TUPLE: mersenne-twister { seq uint-array } { i fixnum } ;
 : mt-m 397 ; inline
 : mt-a HEX: 9908b0df ; inline
 
+: mersenne-wrap ( n -- n' )
+    dup mt-n > [ mt-n - ] when ; inline
+
 : wrap-nth ( n seq -- obj )
-    [ length mod ] keep nth-unsafe ; inline
+    [ mersenne-wrap ] dip nth-unsafe ; inline
 
 : set-wrap-nth ( obj n seq -- )
-    [ length mod ] keep set-nth-unsafe ; inline
+    [ mersenne-wrap ] dip set-nth-unsafe ; inline
 
 : calculate-y ( n seq -- y )
     [ wrap-nth 31 mask-bit ]
@@ -50,7 +53,7 @@ TUPLE: mersenne-twister { seq uint-array } { i fixnum } ;
 
 : init-mt-seq ( seed -- seq )
     32 bits mt-n <uint-array>
-    [ set-first ] [ init-mt-rest ] [ ] tri ;
+    [ set-first ] [ init-mt-rest ] [ ] tri ; inline
 
 : mt-temper ( y -- yt )
     dup -11 shift bitxor

basis/specialized-arrays/direct/functor/functor.factor

@@ -20,7 +20,7 @@ SET-NTH [ T dup c-setter array-accessor ]
 WHERE
 
 TUPLE: A
-{ underlying alien read-only }
+{ underlying c-ptr read-only }
 { length fixnum read-only } ;
 
 : <A> ( alien len -- direct-array ) A boa ; inline

basis/stack-checker/backend/backend-tests.factor

@@ -3,20 +3,21 @@ stack-checker.state sequences ;
 IN: stack-checker.backend.tests
 
 [ ] [
-    V{ } clone meta-d set
+    V{ } clone \ meta-d set
-    V{ } clone meta-r set
+    V{ } clone \ meta-r set
+    V{ } clone \ literals set
     0 d-in set
 ] unit-test
 
 [ 0 ] [ 0 ensure-d length ] unit-test
 
 [ 2 ] [ 2 ensure-d length ] unit-test
-[ 2 ] [ meta-d get length ] unit-test
+[ 2 ] [ meta-d length ] unit-test
 
 [ 3 ] [ 3 ensure-d length ] unit-test
-[ 3 ] [ meta-d get length ] unit-test
+[ 3 ] [ meta-d length ] unit-test
 
 [ 1 ] [ 1 ensure-d length ] unit-test
-[ 3 ] [ meta-d get length ] unit-test
+[ 3 ] [ meta-d length ] unit-test
 
 [ ] [ 1 consume-d drop ] unit-test

basis/stack-checker/backend/backend.factor

@@ -9,10 +9,10 @@ stack-checker.visitor stack-checker.errors
 stack-checker.values stack-checker.recursive-state ;
 IN: stack-checker.backend
 
-: push-d ( obj -- ) meta-d get push ;
+: push-d ( obj -- ) meta-d push ;
 
 : pop-d  ( -- obj )
-    meta-d get [
+    meta-d [
         <value> dup 1array #introduce, d-in inc
     ] [ pop ] if-empty ;
 
@@ -22,46 +22,52 @@ IN: stack-checker.backend
     [ <value> ] replicate ;
 
 : ensure-d ( n -- values )
-    meta-d get 2dup length > [
+    meta-d 2dup length > [
         2dup
         [ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri
-        [ length d-in +@ ] [ #introduce, ] [ meta-d get push-all ] tri
+        [ length d-in +@ ] [ #introduce, ] [ meta-d push-all ] tri
-        meta-d get push-all
+        meta-d push-all
     ] when swap tail* ;
 
 : shorten-by ( n seq -- )
     [ length swap - ] keep shorten ; inline
 
 : consume-d ( n -- seq )
-    [ ensure-d ] [ meta-d get shorten-by ] bi ;
+    [ ensure-d ] [ meta-d shorten-by ] bi ;
 
-: output-d ( values -- ) meta-d get push-all ;
+: output-d ( values -- ) meta-d push-all ;
 
 : produce-d ( n -- values )
-    make-values dup meta-d get push-all ;
+    make-values dup meta-d push-all ;
 
-: push-r ( obj -- ) meta-r get push ;
+: push-r ( obj -- ) meta-r push ;
 
 : pop-r ( -- obj )
-    meta-r get dup empty?
+    meta-r dup empty?
     [ too-many-r> inference-error ] [ pop ] if ;
 
 : consume-r ( n -- seq )
-    meta-r get 2dup length >
+    meta-r 2dup length >
     [ too-many-r> inference-error ] when
     [ swap tail* ] [ shorten-by ] 2bi ;
 
-: output-r ( seq -- ) meta-r get push-all ;
+: output-r ( seq -- ) meta-r push-all ;
-
-: pop-literal ( -- rstate obj )
-    pop-d
-    [ 1array #drop, ]
-    [ literal [ recursion>> ] [ value>> ] bi ] bi ;
-
-GENERIC: apply-object ( obj -- )
 
 : push-literal ( obj -- )
-    dup <literal> make-known [ nip push-d ] [ #push, ] 2bi ;
+    literals get push ;
+
+: pop-literal ( -- rstate obj )
+    literals get [
+        pop-d
+        [ 1array #drop, ]
+        [ literal [ recursion>> ] [ value>> ] bi ] bi
+    ] [ pop recursive-state get swap ] if-empty ;
+
+: literals-available? ( n -- literals ? )
+    literals get 2dup length <=
+    [ [ swap tail* ] [ shorten-by ] 2bi t ] [ 2drop f f ] if ;
+
+GENERIC: apply-object ( obj -- )
 
 M: wrapper apply-object
     wrapped>>
@@ -72,10 +78,17 @@ M: wrapper apply-object
 M: object apply-object push-literal ;
 
 : terminate ( -- )
-    terminated? on meta-d get clone meta-r get clone #terminate, ;
+    terminated? on meta-d clone meta-r clone #terminate, ;
+
+: check->r ( -- )
+    meta-r empty? [ \ too-many->r inference-error ] unless ;
 
 : infer-quot-here ( quot -- )
-    [ apply-object terminated? get not ] all? drop ;
+    meta-r [
+        V{ } clone \ meta-r set
+        [ apply-object terminated? get not ] all?
+        [ commit-literals check->r ] [ literals get delete-all ] if
+    ] dip \ meta-r set ;
 
 : infer-quot ( quot rstate -- )
     recursive-state get [
@@ -103,10 +116,10 @@ M: object apply-object push-literal ;
     ] if ;
 
 : infer->r ( n -- )
-    consume-d dup copy-values [ #>r, ] [ nip output-r ] 2bi ;
+    consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi ;
 
 : infer-r> ( n -- )
-    consume-r dup copy-values [ #r>, ] [ nip output-d ] 2bi ;
+    consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ;
 
 : undo-infer ( -- )
     recorded get [ f "inferred-effect" set-word-prop ] each ;
@@ -127,13 +140,8 @@ M: object apply-object push-literal ;
 : infer-word-def ( word -- )
     [ specialized-def ] [ add-recursive-state ] bi infer-quot ;
 
-: check->r ( -- )
-    meta-r get empty? terminated? get or
-    [ \ too-many->r inference-error ] unless ;
-
 : end-infer ( -- )
-    check->r
+    meta-d clone #return, ;
-    meta-d get clone #return, ;
 
 : effect-required? ( word -- ? )
     {

basis/stack-checker/branches/branches.factor

@@ -57,9 +57,9 @@ SYMBOL: quotations
     branch-variable ;
 
 : datastack-phi ( seq -- phi-in phi-out )
-    [ d-in branch-variable ] [ meta-d active-variable ] bi
+    [ d-in branch-variable ] [ \ meta-d active-variable ] bi
     unify-branches
-    [ d-in set ] [ ] [ dup >vector meta-d set ] tri* ;
+    [ d-in set ] [ ] [ dup >vector \ meta-d set ] tri* ;
 
 : terminated-phi ( seq -- terminated )
     terminated? branch-variable ;
@@ -74,17 +74,25 @@ SYMBOL: quotations
     tri ;
 
 : copy-inference ( -- )
-    meta-d [ clone ] change
+    \ meta-d [ clone ] change
-    V{ } clone meta-r set
+    literals [ clone ] change
     d-in [ ] change ;
 
-: infer-branch ( literal -- namespace )
+GENERIC: infer-branch ( literal -- namespace )
+
+M: literal infer-branch
     [
         copy-inference
         nest-visitor
         [ value>> quotation set ] [ infer-literal-quot ] bi
-        check->r
+    ] H{ } make-assoc ;
-    ] H{ } make-assoc ; inline
+
+M: callable infer-branch
+    [
+        copy-inference
+        nest-visitor
+        [ quotation set ] [ infer-quot-here ] bi
+    ] H{ } make-assoc ;
 
 : infer-branches ( branches -- input children data )
     [ pop-d ] dip
@@ -96,16 +104,19 @@ SYMBOL: quotations
     [ first2 #if, ] dip compute-phi-function ;
 
 : infer-if ( -- )
-    2 consume-d
+    2 literals-available? [
+        (infer-if)
+    ] [
+        drop 2 consume-d
         dup [ known [ curried? ] [ composed? ] bi or ] contains? [
             output-d
             [ rot [ drop call ] [ nip call ] if ]
             infer-quot-here
         ] [
             [ #drop, ] [ [ literal ] map (infer-if) ] bi
+        ] if
     ] if ;
 
 : infer-dispatch ( -- )
-    pop-literal nip [ <literal> ] map
+    pop-literal nip infer-branches
-    infer-branches
     [ #dispatch, ] dip compute-phi-function ;

basis/stack-checker/inlining/inlining.factor

@@ -51,14 +51,14 @@ SYMBOL: enter-out
 : prepare-stack ( word -- )
     required-stack-effect in>>
     [ length ensure-d drop ] [
-        meta-d get clone enter-in set
+        meta-d clone enter-in set
-        meta-d get swap make-copies enter-out set
+        meta-d swap make-copies enter-out set
     ] bi ;
 
 : emit-enter-recursive ( label -- )
     enter-out get >>enter-out
     enter-in get enter-out get #enter-recursive,
-    enter-out get >vector meta-d set ;
+    enter-out get >vector \ meta-d set ;
 
 : entry-stack-height ( label -- stack )
     enter-out>> length ;
@@ -77,7 +77,7 @@ SYMBOL: enter-out
 
 : end-recursive-word ( word label -- )
     [ check-return ]
-    [ meta-d get dup copy-values dup meta-d set #return-recursive, ]
+    [ meta-d dup copy-values dup \ meta-d set #return-recursive, ]
     bi ;
 
 : recursive-word-inputs ( label -- n )
@@ -95,10 +95,8 @@ SYMBOL: enter-out
         [ nip ]
         2tri
 
-        check->r
-
         dup recursive-word-inputs
-        meta-d get
+        meta-d
         stack-visitor get
         terminated? get
     ] with-scope ;
@@ -116,7 +114,7 @@ SYMBOL: enter-out
     swap word>> required-stack-effect in>> length tail* ;
 
 : call-site-stack ( label -- stack )
-    meta-d get trim-stack ;
+    meta-d trim-stack ;
 
 : trimmed-enter-out ( label -- stack )
     dup enter-out>> trim-stack ;
@@ -131,7 +129,7 @@ SYMBOL: enter-out
 
 : adjust-stack-effect ( effect -- effect' )
     [ in>> ] [ out>> ] bi
-    meta-d get length pick length [-]
+    meta-d length pick length [-]
     object <repetition> '[ _ prepend ] bi@
     <effect> ;
 
@@ -142,6 +140,7 @@ SYMBOL: enter-out
     ] [ drop undeclared-recursion-error inference-error ] if ;
 
 : inline-word ( word -- )
+    commit-literals
     [ inlined-dependency depends-on ]
     [
         dup inline-recursive-label [

basis/stack-checker/known-words/known-words.factor

@@ -63,7 +63,9 @@ IN: stack-checker.known-words
 
 GENERIC: infer-call* ( value known -- )
 
-: infer-call ( value -- ) dup known infer-call* ;
+: (infer-call) ( value -- ) dup known infer-call* ;
+
+: infer-call ( -- ) pop-d (infer-call) ;
 
 M: literal infer-call*
     [ 1array #drop, ] [ infer-literal-quot ] bi* ;
@@ -73,7 +75,7 @@ M: curried infer-call*
     [ uncurry ] infer-quot-here
     [ quot>> known pop-d [ set-known ] keep ]
     [ obj>> known pop-d [ set-known ] keep ] bi
-    push-d infer-call ;
+    push-d (infer-call) ;
 
 M: composed infer-call*
     swap push-d
@@ -81,20 +83,41 @@ M: composed infer-call*
     [ quot2>> known pop-d [ set-known ] keep ]
     [ quot1>> known pop-d [ set-known ] keep ] bi
     push-d push-d
-    1 infer->r pop-d infer-call
+    1 infer->r infer-call
-    terminated? get [ 1 infer-r> pop-d infer-call ] unless ;
+    terminated? get [ 1 infer-r> infer-call ] unless ;
 
 M: object infer-call*
     \ literal-expected inference-warning ;
 
 : infer-slip ( -- )
-    1 infer->r pop-d infer-call 1 infer-r> ;
+    1 infer->r infer-call 1 infer-r> ;
 
 : infer-2slip ( -- )
-    2 infer->r pop-d infer-call 2 infer-r> ;
+    2 infer->r infer-call 2 infer-r> ;
 
 : infer-3slip ( -- )
-    3 infer->r pop-d infer-call 3 infer-r> ;
+    3 infer->r infer-call 3 infer-r> ;
+
+: infer-dip ( -- )
+    commit-literals
+    literals get
+    [ \ dip def>> infer-quot-here ]
+    [ pop 1 infer->r infer-quot-here 1 infer-r>  ]
+    if-empty ;
+
+: infer-2dip ( -- )
+    commit-literals
+    literals get
+    [ \ 2dip def>> infer-quot-here ]
+    [ pop 2 infer->r infer-quot-here 2 infer-r>  ]
+    if-empty ;
+
+: infer-3dip ( -- )
+    commit-literals
+    literals get
+    [ \ 3dip def>> infer-quot-here ]
+    [ pop 3 infer->r infer-quot-here 3 infer-r>  ]
+    if-empty ;
 
 : infer-curry ( -- )
     2 consume-d
@@ -157,11 +180,14 @@ M: object infer-call*
         { \ >r [ 1 infer->r ] }
         { \ r> [ 1 infer-r> ] }
         { \ declare [ infer-declare ] }
-        { \ call [ pop-d infer-call ] }
+        { \ call [ infer-call ] }
-        { \ (call) [ pop-d infer-call ] }
+        { \ (call) [ infer-call ] }
         { \ slip [ infer-slip ] }
         { \ 2slip [ infer-2slip ] }
         { \ 3slip [ infer-3slip ] }
+        { \ dip [ infer-dip ] }
+        { \ 2dip [ infer-2dip ] }
+        { \ 3dip [ infer-3dip ] }
         { \ curry [ infer-curry ] }
         { \ compose [ infer-compose ] }
         { \ execute [ infer-execute ] }
@@ -190,10 +216,10 @@ M: object infer-call*
     "local-word-def" word-prop infer-quot-here ;
 
 {
-    >r r> declare call (call) slip 2slip 3slip curry compose
+    >r r> declare call (call) slip 2slip 3slip dip 2dip 3dip
-    execute (execute) if dispatch <tuple-boa> (throw)
+    curry compose execute (execute) if dispatch <tuple-boa>
-    load-locals get-local drop-locals do-primitive alien-invoke
+    (throw) load-locals get-local drop-locals do-primitive
-    alien-indirect alien-callback
+    alien-invoke alien-indirect alien-callback
 } [ t "special" set-word-prop ] each
 
 { call execute dispatch load-locals get-local drop-locals }

basis/stack-checker/state/state.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs arrays namespaces sequences kernel definitions
 math effects accessors words fry classes.algebra
-compiler.units ;
+compiler.units stack-checker.values stack-checker.visitor ;
 IN: stack-checker.state
 
 ! Did the current control-flow path throw an error?
@@ -11,23 +11,40 @@ SYMBOL: terminated?
 ! Number of inputs current word expects from the stack
 SYMBOL: d-in
 
+DEFER: commit-literals
+
 ! Compile-time data stack
-SYMBOL: meta-d
+: meta-d ( -- stack ) commit-literals \ meta-d get ;
 
 ! Compile-time retain stack
-SYMBOL: meta-r
+: meta-r ( -- stack ) \ meta-r get ;
 
-: current-stack-height ( -- n ) meta-d get length d-in get - ;
+! Uncommitted literals. This is a form of local dead-code
+! elimination; the goal is to reduce the number of IR nodes
+! which get constructed. Technically it is redundant since
+! we do global DCE later, but it speeds up compile time.
+SYMBOL: literals
+
+: (push-literal) ( obj -- )
+    dup <literal> make-known
+    [ nip \ meta-d get push ] [ #push, ] 2bi ;
+
+: commit-literals ( -- )
+    literals get [
+        [ [ (push-literal) ] each ] [ delete-all ] bi
+    ] unless-empty ;
+
+: current-stack-height ( -- n ) meta-d length d-in get - ;
 
 : current-effect ( -- effect )
     d-in get
-    meta-d get length <effect>
+    meta-d length <effect>
     terminated? get >>terminated? ;
 
 : init-inference ( -- )
     terminated? off
-    V{ } clone meta-d set
+    V{ } clone \ meta-d set
-    V{ } clone meta-r set
+    V{ } clone literals set
     0 d-in set ;
 
 ! Words that the current quotation depends on

basis/stack-checker/transforms/transforms.factor

@@ -19,11 +19,8 @@ IN: stack-checker.transforms
     rot with-datastack first2
     dup [
         [
-            [ drop ] [
+            [ drop ]
-                [ length meta-d get '[ _ pop* ] times ]
+            [ [ length meta-d shorten-by ] [ #drop, ] bi ] bi*
-                [ #drop, ]
-                bi
-            ] bi*
         ] 2dip
         swap infer-quot
     ] [

basis/struct-arrays/struct-arrays-docs.factor

@@ -7,11 +7,11 @@ $nl
 "The " { $slot "underlying" } " slot holds a " { $link c-ptr } " with the raw data. This pointer can be passed to C functions." } ;
 
 HELP: <struct-array>
-{ $values { "length" integer } { "c-type" string } }
+{ $values { "length" integer } { "c-type" string } { "struct-array" struct-array } }
 { $description "Creates a new array for holding values of the specified C type." } ;
 
 HELP: <direct-struct-array>
-{ $values { "alien" c-ptr } { "length" integer } { "c-type" string } }
+{ $values { "alien" c-ptr } { "length" integer } { "c-type" string } { "struct-array" struct-array } }
 { $description "Creates a new array for holding values of the specified C type, backed by the memory at " { $snippet "alien" } "." } ;
 
 ARTICLE: "struct-arrays" "C struct and union arrays"

basis/tools/memory/memory.factor

@@ -10,7 +10,7 @@ IN: tools.memory
 
 : write-size ( n -- )
     number>string
-    dup length 4 > [ 3 cut* "," swap 3append ] when
+    dup length 4 > [ 3 cut* "," glue ] when
     " KB" append write-cell ;
 
 : write-total/used/free ( free total str -- )

basis/tools/vocabs/vocabs.factor

@@ -238,7 +238,7 @@ M: vocab-link summary vocab-summary ;
         vocab-dir append-path dup exists?
         [ subdirs ] [ drop { } ] if
     ] keep [
-        swap [ "." swap 3append ] with map
+        swap [ "." glue ] with map
     ] unless-empty ;
 
 : vocabs-in-dir ( root name -- )

basis/tools/walker/walker.factor

@@ -126,7 +126,7 @@ SYMBOL: +stopped+
     [
         2dup length = [ nip [ break ] append ] [
             2dup nth \ break = [ nip ] [
-                swap 1+ cut [ break ] swap 3append
+                swap 1+ cut [ break ] glue 
             ] if
         ] if
     ] change-frame ;

basis/unicode/breaks/breaks.factor

@@ -72,7 +72,7 @@ VALUE: grapheme-table
     grapheme-table nth nth not ;
 
 : chars ( i str n -- str[i] str[i+n] )
-    swap >r dupd + r> [ ?nth ] curry bi@ ;
+    swap [ dupd + ] dip [ ?nth ] curry bi@ ;
 
 : find-index ( seq quot -- i ) find drop ; inline
 : find-last-index ( seq quot -- i ) find-last drop ; inline

basis/unicode/collation/collation.factor

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

basis/urls/encoding/encoding.factor

@@ -91,6 +91,6 @@ PRIVATE>
     [
         [
             [ url-encode ] dip
-            [ url-encode "=" swap 3append , ] with each
+            [ url-encode "=" glue , ] with each
         ] assoc-each
     ] { } make "&" join ;

core/continuations/continuations-docs.factor

@@ -79,6 +79,7 @@ $nl
 { $subsection continue-with }
 "Continuations as control-flow:"
 { $subsection attempt-all }
+{ $subsection retry }
 { $subsection with-return }
 "Reflecting the datastack:"
 { $subsection with-datastack }
@@ -237,6 +238,20 @@ HELP: attempt-all
     }
 } ;
 
+HELP: retry
+{ $values
+     { "quot" quotation } { "n" null }
+}
+{ $description "Tries the quotation up to " { $snippet "n" } " times until it returns true. Retries the quotation if an exception is thrown or if the quotation returns " { $link f } ". The quotation is expected to have side effects that may fail, such as generating a random name for a new file until successful." }
+{ $examples
+    { $unchecked-example "USING: continuations math prettyprint ;"
+        "[ 5 random 0 = ] retry t"
+        "t"
+    }
+} ;
+
+{ attempt-all retry } related-words
+
 HELP: return
 { $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ;
 

core/continuations/continuations.factor

@@ -154,6 +154,8 @@ ERROR: attempt-all-error ;
         ] { } make peek swap [ rethrow ] when
     ] if ; inline
 
+: retry ( quot: ( -- ? )  n -- ) swap [ drop ] prepose attempt-all ; inline
+
 TUPLE: condition error restarts continuation ;
 
 C: <condition> condition ( error restarts cc -- condition )

core/effects/effects.factor

@@ -26,7 +26,7 @@ GENERIC: effect>string ( obj -- str )
 M: string effect>string ;
 M: word effect>string name>> ;
 M: integer effect>string number>string ;
-M: pair effect>string first2 [ effect>string ] bi@ ": " swap 3append ;
+M: pair effect>string first2 [ effect>string ] bi@ ": " glue ;
 
 : stack-picture ( seq -- string )
     dup integer? [ "object" <repetition> ] when

core/generic/generic.factor

@@ -77,7 +77,7 @@ TUPLE: check-method class generic ;
     3tri ; inline
 
 : method-word-name ( class word -- string )
-    [ name>> ] bi@ "=>" swap 3append ;
+    [ name>> ] bi@ "=>" glue ;
 
 PREDICATE: method-body < word
     "method-generic" word-prop >boolean ;

core/kernel/kernel-docs.factor

@@ -758,12 +758,10 @@ $nl
 "Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:"
 { $code
     "! First alternative; uses dip"
-    "[ [ 1 + ] dip 1 - dip ] 2 *"
+    "[ [ 1 + ] dip 1 - ] dip 2 *"
     "! Second alternative: uses tri*"
     "[ 1 + ] [ 1 - ] [ 2 * ] tri*"
 }
-
-$nl
 "A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
 { $subsection "spread-shuffle-equivalence" } ;
 

core/kernel/kernel.factor

@@ -52,7 +52,9 @@ DEFER: if
 : ?if ( default cond true false -- )
     pick [ roll 2drop call ] [ 2nip call ] if ; inline
 
-! Slippers
+! Slippers and dippers.
+! Not declared inline because the compiler special-cases them
+
 : slip ( quot x -- x )
     #! 'slip' and 'dip' can be defined in terms of each other
     #! because the JIT special-cases a 'dip' preceeded by
@@ -71,11 +73,11 @@ DEFER: if
     #! a literal quotation.
     [ call ] 3dip ;
 
-: dip ( x quot -- x ) swap slip ; inline
+: dip ( x quot -- x ) swap slip ;
 
-: 2dip ( x y quot -- x y ) -rot 2slip ; inline
+: 2dip ( x y quot -- x y ) -rot 2slip ;
 
-: 3dip ( x y z quot -- x y z ) -roll 3slip ; inline
+: 3dip ( x y z quot -- x y z ) -roll 3slip ;
 
 ! Keepers
 : keep ( x quot -- x ) over slip ; inline

core/math/floats/floats-docs.factor

@@ -6,7 +6,7 @@ ARTICLE: "floats" "Floats"
 "Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximation" } ". While rationals can grow to any required precision, floating point numbers are fixed-width, and manipulating them is usually faster than manipulating ratios or bignums (but slower than manipulating fixnums). Floating point numbers are often used to represent irrational numbers, which have no exact representation as a ratio of two integers."
 $nl
 "Introducing a floating point number in a computation forces the result to be expressed in floating point."
-{ $example "5/4 1/2 + ." "7/4" }
+{ $example "5/4 1/2 + ." "1+3/4" }
 { $example "5/4 0.5 + ." "1.75" }
 "Integers and rationals can be converted to floats:"
 { $subsection >float }

core/math/parser/parser.factor

@@ -128,7 +128,7 @@ M: ratio >base
         [
             [ numerator (>base) ]
             [ denominator (>base) ] bi
-            "/" swap 3append
+            "/" glue
         ] bi* append
         negative? get [ CHAR: - prefix ] when
     ] with-radix ;

core/sequences/sequences-docs.factor

@@ -714,6 +714,26 @@ HELP: 3append
     }
 } ;
 
+HELP: surround
+{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "newseq" sequence } }
+{ $description "Outputs a new sequence with " { $snippet "seq1" } " inserted between " { $snippet "seq2" } " and " { $snippet "seq3" } "." }
+{ $examples
+    { $example "USING: sequences prettyprint ;"
+               "\"sssssh\" \"(\" \")\" surround ."
+               "\"(sssssh)\""
+    }
+} ;
+
+HELP: glue
+{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "newseq" sequence } }
+{ $description "Outputs a new sequence with " { $snippet "seq3" } " inserted between " { $snippet "seq1" } " and " { $snippet "seq2" } "." }
+{ $examples
+    { $example "USING: sequences prettyprint ;"
+               "\"a\" \"b\" \",\" glue ."
+               "\"a,b\""
+    }
+} ;
+
 HELP: subseq
 { $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq" sequence } { "subseq" "a new sequence" } }
 { $description "Outputs a new sequence consisting of all elements starting from and including " { $snippet "from" } ", and up to but not including " { $snippet "to" } "." }
@@ -1348,6 +1368,8 @@ ARTICLE: "sequences-appending" "Appending sequences"
 { $subsection append }
 { $subsection prepend }
 { $subsection 3append }
+{ $subsection surround }
+{ $subsection glue }
 { $subsection concat }
 { $subsection join }
 "A pair of words useful for aligning strings:"

core/sequences/sequences-tests.factor

@@ -268,3 +268,6 @@ M: bogus-hashcode hashcode* 2drop 0 >bignum ;
 [ { 1 3 "X" 5 7 } ] [ "X" 2 { 1 3 5 7 } insert-nth ] unit-test
 
 [ V{ 0 2 } ] [ "a" { "a" "b" "a" } indices ] unit-test
+
+[ "a,b" ] [ "a" "b" "," glue ] unit-test
+[ "(abc)" ] [ "abc" "(" ")" surround ] unit-test

core/sequences/sequences.factor

@@ -317,6 +317,10 @@ PRIVATE>
 
 : 3append ( seq1 seq2 seq3 -- newseq ) pick 3append-as ;
 
+: surround ( seq1 seq2 seq3 -- newseq ) swapd 3append ; inline
+
+: glue ( seq1 seq2 seq3 -- newseq ) swap 3append ; inline
+
 : change-nth ( i seq quot -- )
     [ [ nth ] dip call ] 3keep drop set-nth ; inline
 

extra/benchmark/knucleotide/knucleotide.factor

@@ -9,7 +9,7 @@ IN: benchmark.knucleotide
     "." split1 rot
     over length over <
     [ CHAR: 0 pad-right ] 
-    [ head ] if "." swap 3append ;
+    [ head ] if "." glue ;
 
 : discard-lines ( -- )
     readln

extra/bitfields/bitfields.factor

@@ -80,7 +80,7 @@ M: check< summary drop "Number exceeds upper bound" ;
     [ ":" split1 string>number [ dup length ] unless* ] { } map>assoc ;
 
 : define-slots ( prefix names quots -- )
-    >r [ "-" swap 3append create-in ] with map r>
+    >r [ "-" glue create-in ] with map r>
     [ define ] 2each ;
 
 : define-accessors ( classname slots -- )

extra/combinators/lib/lib.factor

@@ -135,9 +135,6 @@ MACRO: multikeep ( word out-indexes -- ... )
         r> [ drop \ r> , ] each
     ] [ ] make ;
 
-: retry ( quot n -- )
-    [ drop ] rot compose attempt-all ; inline
-
 : do-while ( pred body tail -- )
     [ tuck 2slip ] dip while ; inline
 

extra/dns/dns.factor

@@ -285,7 +285,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
           [ get-label ]
           [ skip-label get-name ]
           2bi
-          "." swap 3append
+          "." glue 
         ]
       }
     }

extra/hardware-info/windows/ce/ce.factor

@@ -5,7 +5,7 @@ IN: hardware-info.windows.ce
 : memory-status ( -- MEMORYSTATUS )
     "MEMORYSTATUS" <c-object>
     "MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength
-    [ GlobalMemoryStatus ] keep ;
+    dup GlobalMemoryStatus ;
 
 M: wince cpus ( -- n ) 1 ;
 

extra/hardware-info/windows/nt/nt.factor

@@ -1,18 +1,16 @@
 USING: alien alien.c-types alien.strings
 kernel libc math namespaces hardware-info.backend
-windows windows.advapi32 windows.kernel32 system ;
+hardware-info.windows windows windows.advapi32
+windows.kernel32 system byte-arrays ;
 IN: hardware-info.windows.nt
 
-: system-info ( -- SYSTEM_INFO )
-    "SYSTEM_INFO" <c-object> [ GetSystemInfo ] keep ;
-
 M: winnt cpus ( -- n )
     system-info SYSTEM_INFO-dwNumberOfProcessors ;
 
 : memory-status ( -- MEMORYSTATUSEX )
     "MEMORYSTATUSEX" <c-object>
     "MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength
-    [ GlobalMemoryStatusEx ] keep swap zero? [ win32-error ] when ;
+    dup GlobalMemoryStatusEx win32-error=0/f ;
 
 M: winnt memory-load ( -- n )
     memory-status MEMORYSTATUSEX-dwMemoryLoad ;
@@ -35,21 +33,12 @@ M: winnt total-virtual-mem ( -- n )
 M: winnt available-virtual-mem ( -- n )
     memory-status MEMORYSTATUSEX-ullAvailVirtual ;
 
-: pull-win32-string ( alien -- string )
-    [ utf16n alien>string ] keep free ;
-
 : computer-name ( -- string )
-    MAX_COMPUTERNAME_LENGTH 1+ [ malloc ] keep
+    MAX_COMPUTERNAME_LENGTH 1+
-    <int> dupd GetComputerName zero? [
+    [ <byte-array> dup ] keep <uint>
-        free win32-error f
+    GetComputerName win32-error=0/f alien>native-string ;
-    ] [
-        pull-win32-string
-    ] if ;
  
 : username ( -- string )
-    UNLEN 1+ [ malloc ] keep
+    UNLEN 1+
-    <int> dupd GetUserName zero? [
+    [ <byte-array> dup ] keep <uint>
-        free win32-error f
+    GetUserName win32-error=0/f alien>native-string ;
-    ] [
-        pull-win32-string
-    ] if ;

extra/hardware-info/windows/windows.factor

@@ -21,7 +21,7 @@ IN: hardware-info.windows
 : os-version ( -- os-version )
     "OSVERSIONINFO" <c-object>
     "OSVERSIONINFO" heap-size over set-OSVERSIONINFO-dwOSVersionInfoSize
-    [ GetVersionEx ] keep swap zero? [ win32-error ] when ;
+    dup GetVersionEx win32-error=0/f ;
 
 : windows-major ( -- n )
     os-version OSVERSIONINFO-dwMajorVersion ;
@@ -36,7 +36,7 @@ IN: hardware-info.windows
     os-version OSVERSIONINFO-dwPlatformId ;
 
 : windows-service-pack ( -- string )
-    os-version OSVERSIONINFO-szCSDVersion utf16n alien>string ;
+    os-version OSVERSIONINFO-szCSDVersion alien>native-string ;
 
 : feature-present? ( n -- ? )
     IsProcessorFeaturePresent zero? not ;
@@ -51,8 +51,8 @@ IN: hardware-info.windows
     "ushort" <c-array> ;
 
 : get-directory ( word -- str )
-    >r MAX_UNICODE_PATH [ <u16-string-object> ] keep dupd r>
+    [ MAX_UNICODE_PATH [ <u16-string-object> ] keep dupd ] dip
-    execute win32-error=0/f utf16n alien>string ; inline
+    execute win32-error=0/f alien>native-string ; inline
 
 : windows-directory ( -- str )
     \ GetWindowsDirectory get-directory ;

extra/irc/gitbot/gitbot.factor

@@ -31,7 +31,7 @@ M: object handle-message drop ;
         "git-log" ,
         "--no-merges" ,
         "--pretty=format:%h %an: %s" ,
-        ".." swap 3append ,
+        ".." glue ,
     ] { } make
     latin1 [ input-stream get lines ] with-process-reader ;
 

extra/math/floating-point/floating-point-tests.factor

@@ -1,7 +1,15 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test math.floating-point math.constants kernel ;
+USING: tools.test math.floating-point math.constants kernel
+math.constants fry sequences kernel math ;
 IN: math.floating-point.tests
 
 [ t ] [ pi >double< >double pi = ] unit-test
 [ t ] [ -1.0 >double< >double -1.0 = ] unit-test
+
+[ t ] [ 1/0. infinity? ] unit-test
+[ t ] [ -1/0. infinity? ] unit-test
+[ f ] [ 0/0. infinity? ] unit-test
+[ f ] [ 10. infinity? ] unit-test
+[ f ] [ -10. infinity? ] unit-test
+[ f ] [ 0. infinity? ] unit-test

extra/math/floating-point/floating-point.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math sequences prettyprint math.parser io
-math.functions math.bitwise ;
+math.functions math.bitwise combinators.short-circuit ;
 IN: math.floating-point
 
 : (double-sign) ( bits -- n ) -63 shift ; inline
@@ -37,3 +37,10 @@ IN: math.floating-point
         (double-mantissa-bits) >bin 52 CHAR: 0 pad-left
         11 [ bl ] times print
     ] tri ;
+
+: infinity? ( double -- ? )
+    double>bits
+    {
+        [ (double-exponent-bits) 11 on-bits = ]
+        [ (double-mantissa-bits) 0 = ]
+    } 1&& ;

extra/math/text/english/english.factor

@@ -56,7 +56,7 @@ SYMBOL: and-needed?
 
 : text-with-scale ( index seq -- str )
     [ nth 3digits>text ] [ drop scale-numbers ] 2bi
-    [ " " swap 3append ] unless-empty ;
+    [ " " glue ] unless-empty ;
 
 : append-with-conjunction ( str1 str2 -- newstr )
     over length zero? [

extra/money/money.factor

@@ -12,7 +12,7 @@ CHAR: $ \ currency-token set-global
 : (money>string) ( dollars cents -- string )
     [ number>string ] bi@
     [ <reversed> 3 group "," join <reversed> ]
-    [ 2 CHAR: 0 pad-left ] bi* "." swap 3append ;
+    [ 2 CHAR: 0 pad-left ] bi* "." glue ;
 
 : money>string ( object -- string )
     dollars/cents (money>string) currency-token get prefix ;

extra/printf/printf.factor

@@ -28,7 +28,7 @@ IN: printf
     [ 0 ] [ string>number ] if-empty ;
 
 : pad-digits ( string digits -- string' )
-    [ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." swap 3append ;
+    [ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." glue ;
 
 : max-digits ( n digits -- n' )
     10 swap ^ [ * round ] keep / ;

extra/project-euler/002/002-tests.factor

@@ -3,3 +3,4 @@ IN: project-euler.002.tests
 
 [ 4613732 ] [ euler002 ] unit-test
 [ 4613732 ] [ euler002a ] unit-test
+[ 4613732 ] [ euler002b ] unit-test

extra/project-euler/002/002.factor

@@ -1,4 +1,4 @@
-! Copyright (c) 2007 Aaron Schaefer, Alexander Solovyov.
+! Copyright (c) 2007, 2008 Aaron Schaefer, Alexander Solovyov, Vishal Talwar.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math sequences shuffle ;
 IN: project-euler.002
@@ -50,4 +50,31 @@ PRIVATE>
 ! [ euler002a ] 100 ave-time
 ! 0 ms ave run time - 0.2 SD (100 trials)
 
-MAIN: euler002a
+
+<PRIVATE
+
+: next-fibs ( x y -- y x+y )
+    tuck + ;
+
+: ?retotal ( total fib- fib+ -- retotal fib- fib+ )
+    dup even? [ [ nip + ] 2keep ] when ;
+
+: (sum-even-fibs-below) ( partial fib- fib+ max -- total )
+    2dup > [
+        3drop
+    ] [
+        [ ?retotal next-fibs ] dip (sum-even-fibs-below)
+    ] if ;
+
+PRIVATE>
+
+: sum-even-fibs-below ( max -- sum )
+    [ 0 0 1 ] dip (sum-even-fibs-below) ;
+
+: euler002b ( -- answer )
+    4000000 sum-even-fibs-below ;
+
+! [ euler002b ] 100 ave-time
+! 0 ms ave run time - 0.0 SD (100 trials)
+
+MAIN: euler002b

extra/project-euler/050/050-tests.factor

@@ -0,0 +1,6 @@
+USING: project-euler.050 project-euler.050.private tools.test ;
+IN: project-euler.050.tests
+
+[ 41 ] [ 100 solve ] unit-test
+[ 953 ] [ 1000 solve ] unit-test
+[ 997651 ] [ euler050 ] unit-test