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

basis/alien/c-types/c-types.factor

@@ -259,8 +259,9 @@ M: long-long-type box-return ( type -- )
     [ dup c-setter '[ _ <c-object> [ 0 @ ] keep ] ] bi
     (( value -- c-ptr )) define-inline ;
 
-: c-bool> ( int -- ? )
+: >c-bool ( ? -- int ) 1 0 ? ; inline
-    0 = not ; inline
+
+: c-bool> ( int -- ? ) 0 = not ; inline
 
 : define-primitive-type ( type name -- )
     [ typedef ]
@@ -409,8 +410,8 @@ CONSTANT: primitive-types
     "uchar" define-primitive-type
 
     <c-type>
-        [ alien-unsigned-1 zero? not ] >>getter
+        [ alien-unsigned-1 c-bool> ] >>getter
-        [ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter
+        [ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
         1 >>size
         1 >>align
         "box_boolean" >>boxer

basis/base64/base64-tests.factor

@@ -4,7 +4,7 @@ IN: base64.tests
 
 [ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" ascii encode >base64 base64> ascii decode
 ] unit-test
-[ f ] [ "" ascii encode >base64 base64> ascii decode ] unit-test
+[ "" ] [ "" ascii encode >base64 base64> ascii decode ] unit-test
 [ "a" ] [ "a" ascii encode >base64 base64> ascii decode ] unit-test
 [ "ab" ] [ "ab" ascii encode >base64 base64> ascii decode ] unit-test
 [ "abc" ] [ "abc" ascii encode >base64 base64> ascii decode ] unit-test

basis/bootstrap/image/image.factor

@@ -52,6 +52,9 @@ GENERIC: (eql?) ( obj1 obj2 -- ? )
 
 M: integer (eql?) = ;
 
+M: float (eql?)
+    over float? [ fp-bitwise= ] [ 2drop f ] if ;
+
 M: sequence (eql?)
     over sequence? [
         2dup [ length ] bi@ =

basis/checksums/common/common.factor

@@ -9,6 +9,9 @@ SYMBOL: bytes-read
 : calculate-pad-length ( length -- length' )
     [ 56 < 55 119 ? ] keep - ;
 
+: calculate-pad-length-long ( length -- length' )
+    [ 120 < 119 247 ? ] keep - ;
+
 : pad-last-block ( str big-endian? length -- str )
     [
         [ % ] 2dip HEX: 80 ,

basis/checksums/sha2/sha2-tests.factor

@@ -1,7 +1,42 @@
-USING: arrays kernel math namespaces sequences tools.test checksums.sha2 checksums ;
+USING: arrays kernel math namespaces sequences tools.test
-[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" sha-256 checksum-bytes hex-string ] unit-test
+checksums.sha2 checksums ;
-[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" sha-256 checksum-bytes hex-string ] unit-test
+IN: checksums.sha2.tests
-[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" sha-256 checksum-bytes hex-string ] unit-test
+
-[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" sha-256 checksum-bytes hex-string ] unit-test
+: test-checksum ( text identifier -- checksum )
-[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" sha-256 checksum-bytes hex-string ] unit-test
+    checksum-bytes hex-string ;
-[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" sha-256 checksum-bytes hex-string ] unit-test
+
+[ "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525" ]
+[
+    "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
+    sha-224 test-checksum
+] unit-test
+
+[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ]
+[ "" sha-256 test-checksum ] unit-test
+
+[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ]
+[ "abc" sha-256 test-checksum ] unit-test
+
+[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ]
+[ "message digest" sha-256 test-checksum ] unit-test
+
+[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ]
+[ "abcdefghijklmnopqrstuvwxyz" sha-256 test-checksum ] unit-test
+
+[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ]
+[
+    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
+    sha-256 test-checksum
+] unit-test
+
+[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ]
+[
+    "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+    sha-256 test-checksum
+] unit-test
+
+
+
+
+! [ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ]
+! [ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test

basis/checksums/sha2/sha2.factor

@@ -2,12 +2,27 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel splitting grouping math sequences namespaces make
 io.binary math.bitwise checksums checksums.common
-sbufs strings ;
+sbufs strings combinators.smart math.ranges fry combinators
+accessors locals ;
 IN: checksums.sha2
 
-<PRIVATE
+SINGLETON: sha-224
+SINGLETON: sha-256
 
-SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
+INSTANCE: sha-224 checksum
+INSTANCE: sha-256 checksum
+
+TUPLE: sha2-state K H word-size block-size ;
+
+TUPLE: sha2-short < sha2-state ;
+
+TUPLE: sha2-long < sha2-state ;
+
+TUPLE: sha-224-state < sha2-short ;
+
+TUPLE: sha-256-state < sha2-short ;
+
+<PRIVATE
 
 CONSTANT: a 0
 CONSTANT: b 1
@@ -18,13 +33,43 @@ CONSTANT: f 5
 CONSTANT: g 6
 CONSTANT: h 7
 
-: initial-H-256 ( -- seq )
+CONSTANT: initial-H-224
+    {
+        HEX: c1059ed8 HEX: 367cd507 HEX: 3070dd17 HEX: f70e5939
+        HEX: ffc00b31 HEX: 68581511 HEX: 64f98fa7 HEX: befa4fa4
+    }
+
+CONSTANT: initial-H-256
     {
         HEX: 6a09e667 HEX: bb67ae85 HEX: 3c6ef372 HEX: a54ff53a
         HEX: 510e527f HEX: 9b05688c HEX: 1f83d9ab HEX: 5be0cd19
-    } ;
+    }
 
-: K-256 ( -- seq )
+CONSTANT: initial-H-384
+    {
+        HEX: cbbb9d5dc1059ed8
+        HEX: 629a292a367cd507
+        HEX: 9159015a3070dd17
+        HEX: 152fecd8f70e5939
+        HEX: 67332667ffc00b31
+        HEX: 8eb44a8768581511
+        HEX: db0c2e0d64f98fa7
+        HEX: 47b5481dbefa4fa4
+    }
+
+CONSTANT: initial-H-512
+    {
+        HEX: 6a09e667f3bcc908
+        HEX: bb67ae8584caa73b
+        HEX: 3c6ef372fe94f82b
+        HEX: a54ff53a5f1d36f1
+        HEX: 510e527fade682d1
+        HEX: 9b05688c2b3e6c1f
+        HEX: 1f83d9abfb41bd6b
+        HEX: 5be0cd19137e2179
+    }
+
+CONSTANT: K-256
     {
         HEX: 428a2f98 HEX: 71374491 HEX: b5c0fbcf HEX: e9b5dba5
         HEX: 3956c25b HEX: 59f111f1 HEX: 923f82a4 HEX: ab1c5ed5
@@ -42,62 +87,163 @@ CONSTANT: h 7
         HEX: 391c0cb3 HEX: 4ed8aa4a HEX: 5b9cca4f HEX: 682e6ff3
         HEX: 748f82ee HEX: 78a5636f HEX: 84c87814 HEX: 8cc70208
         HEX: 90befffa HEX: a4506ceb HEX: bef9a3f7 HEX: c67178f2
-    } ;
+    }
+
+CONSTANT: K-384
+    {
+
+        HEX: 428a2f98d728ae22 HEX: 7137449123ef65cd HEX: b5c0fbcfec4d3b2f HEX: e9b5dba58189dbbc 
+        HEX: 3956c25bf348b538 HEX: 59f111f1b605d019 HEX: 923f82a4af194f9b HEX: ab1c5ed5da6d8118 
+        HEX: d807aa98a3030242 HEX: 12835b0145706fbe HEX: 243185be4ee4b28c HEX: 550c7dc3d5ffb4e2
+        HEX: 72be5d74f27b896f HEX: 80deb1fe3b1696b1 HEX: 9bdc06a725c71235 HEX: c19bf174cf692694 
+        HEX: e49b69c19ef14ad2 HEX: efbe4786384f25e3 HEX: 0fc19dc68b8cd5b5 HEX: 240ca1cc77ac9c65 
+        HEX: 2de92c6f592b0275 HEX: 4a7484aa6ea6e483 HEX: 5cb0a9dcbd41fbd4 HEX: 76f988da831153b5 
+        HEX: 983e5152ee66dfab HEX: a831c66d2db43210 HEX: b00327c898fb213f HEX: bf597fc7beef0ee4 
+        HEX: c6e00bf33da88fc2 HEX: d5a79147930aa725 HEX: 06ca6351e003826f HEX: 142929670a0e6e70 
+        HEX: 27b70a8546d22ffc HEX: 2e1b21385c26c926 HEX: 4d2c6dfc5ac42aed HEX: 53380d139d95b3df 
+        HEX: 650a73548baf63de HEX: 766a0abb3c77b2a8 HEX: 81c2c92e47edaee6 HEX: 92722c851482353b 
+        HEX: a2bfe8a14cf10364 HEX: a81a664bbc423001 HEX: c24b8b70d0f89791 HEX: c76c51a30654be30 
+        HEX: d192e819d6ef5218 HEX: d69906245565a910 HEX: f40e35855771202a HEX: 106aa07032bbd1b8 
+        HEX: 19a4c116b8d2d0c8 HEX: 1e376c085141ab53 HEX: 2748774cdf8eeb99 HEX: 34b0bcb5e19b48a8 
+        HEX: 391c0cb3c5c95a63 HEX: 4ed8aa4ae3418acb HEX: 5b9cca4f7763e373 HEX: 682e6ff3d6b2b8a3 
+        HEX: 748f82ee5defb2fc HEX: 78a5636f43172f60 HEX: 84c87814a1f0ab72 HEX: 8cc702081a6439ec 
+        HEX: 90befffa23631e28 HEX: a4506cebde82bde9 HEX: bef9a3f7b2c67915 HEX: c67178f2e372532b 
+        HEX: ca273eceea26619c HEX: d186b8c721c0c207 HEX: eada7dd6cde0eb1e HEX: f57d4f7fee6ed178 
+        HEX: 06f067aa72176fba HEX: 0a637dc5a2c898a6 HEX: 113f9804bef90dae HEX: 1b710b35131c471b 
+        HEX: 28db77f523047d84 HEX: 32caab7b40c72493 HEX: 3c9ebe0a15c9bebc HEX: 431d67c49c100d4c 
+        HEX: 4cc5d4becb3e42b6 HEX: 597f299cfc657e2a HEX: 5fcb6fab3ad6faec HEX: 6c44198c4a475817
+    }
+
+ALIAS: K-512 K-384
 
 : s0-256 ( x -- x' )
-    [ -7 bitroll-32 ] keep
+    [
-    [ -18 bitroll-32 ] keep
+        [ -7 bitroll-32 ]
-    -3 shift bitxor bitxor ; inline
+        [ -18 bitroll-32 ]
+        [ -3 shift ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
 : s1-256 ( x -- x' )
-    [ -17 bitroll-32 ] keep
+    [
-    [ -19 bitroll-32 ] keep
+        [ -17 bitroll-32 ]
-    -10 shift bitxor bitxor ; inline
+        [ -19 bitroll-32 ]
-
+        [ -10 shift ] tri
-: process-M-256 ( seq n -- )
+    ] [ bitxor ] reduce-outputs ; inline
-    [ 16 - swap nth ] 2keep
-    [ 15 - swap nth s0-256 ] 2keep
-    [ 7 - swap nth ] 2keep
-    [ 2 - swap nth s1-256 ] 2keep
-    [ + + w+ ] 2dip swap set-nth ; inline
-
-: prepare-message-schedule ( seq -- w-seq )
-    word-size get group [ be> ] map block-size get 0 pad-tail
-    dup 16 64 dup <slice> [
-        process-M-256
-    ] with each ;
-
-: ch ( x y z -- x' )
-    [ bitxor bitand ] keep bitxor ;
-
-: maj ( x y z -- x' )
-    [ [ bitand ] 2keep bitor ] dip bitand bitor ;
 
 : S0-256 ( x -- x' )
-    [ -2 bitroll-32 ] keep
+    [
-    [ -13 bitroll-32 ] keep
+        [ -2 bitroll-32 ]
-    -22 bitroll-32 bitxor bitxor ; inline
+        [ -13 bitroll-32 ]
+        [ -22 bitroll-32 ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
 : S1-256 ( x -- x' )
-    [ -6 bitroll-32 ] keep
+    [
-    [ -11 bitroll-32 ] keep
+        [ -6 bitroll-32 ]
-    -25 bitroll-32 bitxor bitxor ; inline
+        [ -11 bitroll-32 ]
+        [ -25 bitroll-32 ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
-: slice3 ( n seq -- a b c ) [ dup 3 + ] dip <slice> first3 ; inline
+: s0-512 ( x -- x' )
+    [
+        [ -1 bitroll-64 ]
+        [ -8 bitroll-64 ]
+        [ -7 shift ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
-: T1 ( W n -- T1 )
+: s1-512 ( x -- x' )
-    [ swap nth ] keep
+    [
-    K get nth +
+        [ -19 bitroll-64 ]
-    e vars get slice3 ch +
+        [ -61 bitroll-64 ]
-    e vars get nth S1-256 +
+        [ -6 shift ] tri
-    h vars get nth w+ ;
+    ] [ bitxor ] reduce-outputs ; inline
 
-: T2 ( -- T2 )
+: S0-512 ( x -- x' )
-    a vars get nth S0-256
+    [
-    a vars get slice3 maj w+ ;
+        [ -28 bitroll-64 ]
+        [ -34 bitroll-64 ]
+        [ -39 bitroll-64 ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
-: update-vars ( T1 T2 -- )
+: S1-512 ( x -- x' )
-    vars get
+    [
+        [ -14 bitroll-64 ]
+        [ -18 bitroll-64 ]
+        [ -41 bitroll-64 ] tri
+    ] [ bitxor ] reduce-outputs ; inline
+
+: process-M-256 ( n seq -- )
+    {
+        [ [ 16 - ] dip nth ]
+        [ [ 15 - ] dip nth s0-256 ]
+        [ [ 7 - ] dip nth ]
+        [ [ 2 - ] dip nth s1-256 w+ w+ w+ ]
+        [ ]
+    } 2cleave set-nth ; inline
+
+: process-M-512 ( n seq -- )
+    {
+        [ [ 16 - ] dip nth ]
+        [ [ 15 - ] dip nth s0-512 ]
+        [ [ 7 - ] dip nth ]
+        [ [ 2 - ] dip nth s1-512 w+ w+ w+ ]
+        [ ]
+    } 2cleave set-nth ; inline
+
+: ch ( x y z -- x' )
+    [ bitxor bitand ] keep bitxor ; inline
+
+: maj ( x y z -- x' )
+    [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; inline
+
+: slice3 ( n seq -- a b c )
+    [ dup 3 + ] dip <slice> first3 ; inline
+
+GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
+
+M: sha2-short pad-initial-bytes ( string sha2 -- padded-string )
+    drop
+    dup [
+        HEX: 80 ,
+        length
+        [ 64 mod calculate-pad-length 0 <string> % ]
+        [ 3 shift 8 >be % ] bi
+    ] "" make append ;
+
+M: sha2-long pad-initial-bytes ( string sha2 -- padded-string )
+    drop dup [
+        HEX: 80 ,
+        length
+        [ 128 mod calculate-pad-length-long 0 <string> % ]
+        [ 3 shift 8 >be % ] bi
+    ] "" make append ;
+
+: seq>byte-array ( seq n -- string )
+    '[ _ >be ] map B{ } join ;
+
+:: T1-256 ( n M H sha2 -- T1 )
+    n M nth
+    n sha2 K>> nth +
+    e H slice3 ch w+
+    e H nth S1-256 w+
+    h H nth w+ ; inline
+
+: T2-256 ( H -- T2 )
+    [ a swap nth S0-256 ]
+    [ a swap slice3 maj w+ ] bi ; inline
+
+:: T1-512 ( n M H sha2 -- T1 )
+    n M nth
+    n sha2 K>> nth +
+    e H slice3 ch w+
+    e H nth S1-512 w+
+    h H nth w+ ; inline
+
+: T2-512 ( H -- T2 )
+    [ a swap nth S0-512 ]
+    [ a swap slice3 maj w+ ] bi ; inline
+
+: update-H ( T1 T2 H -- )
     h g pick exchange
     g f pick exchange
     f e pick exchange
@@ -105,42 +251,56 @@ CONSTANT: h 7
     d c pick exchange
     c b pick exchange
     b a pick exchange
-    [ w+ a ] dip set-nth ;
+    [ w+ a ] dip set-nth ; inline
 
-: process-chunk ( M -- )
+: prepare-message-schedule ( seq sha2 -- w-seq )
-    H get clone vars set
+    [ word-size>> <sliced-groups> [ be> ] map ]
-    prepare-message-schedule block-size get [
+    [
-        T1 T2 update-vars
+        block-size>> [ 0 pad-tail 16 ] keep [a,b) over
-    ] with each vars get H get [ w+ ] 2map H set ;
+        '[ _ process-M-256 ] each
+    ] bi ; inline
 
-: seq>byte-array ( n seq -- string )
+:: process-chunk ( M block-size cloned-H sha2 -- )
-    [ swap [ >be % ] curry each ] B{ } make ;
+    block-size [
+        M cloned-H sha2 T1-256
+        cloned-H T2-256
+        cloned-H update-H
+    ] each
+    cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline
 
-: preprocess-plaintext ( string big-endian? -- padded-string )
+: sha2-steps ( sliced-groups state -- )
-    #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
+    '[
-    [ >sbuf ] dip over [
+        _
-        HEX: 80 ,
+        [ prepare-message-schedule ]
-        dup length HEX: 3f bitand
+        [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi
-        calculate-pad-length 0 <string> %
+    ] each ;
-        length 3 shift 8 rot [ >be ] [ >le ] if %
-    ] "" make over push-all ;
 
-: byte-array>sha2 ( byte-array -- string )
+: byte-array>sha2 ( bytes state -- )
-    t preprocess-plaintext
+    [ [ pad-initial-bytes ] [ nip block-size>> ] 2bi <sliced-groups> ]
-    block-size get group [ process-chunk ] each
+    [ sha2-steps ] bi ;
-    4 H get seq>byte-array ;
+
+: <sha-224-state> ( -- sha2-state )
+    sha-224-state new
+        K-256 >>K
+        initial-H-224 >>H
+        4 >>word-size
+        64 >>block-size ;
+
+: <sha-256-state> ( -- sha2-state )
+    sha-256-state new
+        K-256 >>K
+        initial-H-256 >>H
+        4 >>word-size
+        64 >>block-size ;
 
 PRIVATE>
 
-SINGLETON: sha-256
+M: sha-224 checksum-bytes
-
+    drop <sha-224-state>
-INSTANCE: sha-256 checksum
+    [ byte-array>sha2 ]
+    [ H>> 7 head 4 seq>byte-array ] bi ;
 
 M: sha-256 checksum-bytes
-    drop [
+    drop <sha-256-state>
-        K-256 K set
+    [ byte-array>sha2 ]
-        initial-H-256 H set
+    [ H>> 4 seq>byte-array ] bi ;
-        4 word-size set
-        64 block-size set
-        byte-array>sha2
-    ] with-scope ;

basis/cocoa/application/application.factor

@@ -14,7 +14,7 @@ NSApplicationDelegateReplyCancel
 NSApplicationDelegateReplyFailure ;
 
 : with-autorelease-pool ( quot -- )
-    NSAutoreleasePool -> new slip -> release ; inline
+    NSAutoreleasePool -> new [ call ] [ -> release ] bi* ; inline
 
 : NSApp ( -- app ) NSApplication -> sharedApplication ;
 

basis/cocoa/messages/messages.factor

@@ -68,7 +68,7 @@ MACRO: (send) ( selector super? -- quot )
     [ dup lookup-method ] dip
     [ make-prepare-send ] 2keep
     super-message-senders message-senders ? get at
-    '[ _ call _ execute ] ;
+    1quotation append ;
 
 : send ( receiver args... selector -- return... ) f (send) ; inline
 

basis/compiler/codegen/codegen.factor

@@ -444,8 +444,7 @@ TUPLE: callback-context ;
 
 : do-callback ( quot token -- )
     init-catchstack
-    dup 2 setenv
+    [ 2 setenv call ] keep
-    slip
     wait-to-return ; inline
 
 : callback-return-quot ( ctype -- quot )

basis/compiler/tests/curry.factor

@@ -33,7 +33,7 @@ IN: compiler.tests.curry
 ] unit-test
 
 : foobar ( quot: ( -- ) -- )
-    dup slip swap [ foobar ] [ drop ] if ; inline recursive
+    [ call ] keep swap [ foobar ] [ drop ] if ; inline recursive
 
 [ ] [ [ [ f ] foobar ] compile-call ] unit-test
 

basis/compiler/tree/escape-analysis/escape-analysis-tests.factor

@@ -302,7 +302,7 @@ C: <ro-box> ro-box
 [ 0 ] [ [ 1 cons boa "x" get slot ] count-unboxed-allocations ] unit-test
 
 : impeach-node ( quot: ( node -- ) -- )
-    dup slip impeach-node ; inline recursive
+    [ call ] keep impeach-node ; inline recursive
 
 : bleach-node ( quot: ( node -- ) -- )
     [ bleach-node ] curry [ ] compose impeach-node ; inline recursive

basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor

@@ -39,7 +39,7 @@ TUPLE: empty-tuple ;
 
 ! A more complicated example
 : impeach-node ( quot: ( node -- ) -- )
-    dup slip impeach-node ; inline recursive
+    [ call ] keep impeach-node ; inline recursive
 
 : bleach-node ( quot: ( node -- ) -- )
     [ bleach-node ] curry [ ] compose impeach-node ; inline recursive

basis/cpu/ppc/ppc.factor

@@ -2,11 +2,11 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs sequences kernel combinators make math
 math.order math.ranges system namespaces locals layouts words
-alien alien.c-types literals cpu.architecture cpu.ppc.assembler
+alien alien.accessors alien.c-types literals cpu.architecture
-cpu.ppc.assembler.backend literals compiler.cfg.registers
+cpu.ppc.assembler cpu.ppc.assembler.backend literals compiler.cfg.registers
 compiler.cfg.instructions compiler.constants compiler.codegen
 compiler.codegen.fixup compiler.cfg.intrinsics
-compiler.cfg.stack-frame ;
+compiler.cfg.stack-frame compiler.units ;
 IN: cpu.ppc
 
 ! PowerPC register assignments:
@@ -713,4 +713,14 @@ USE: vocabs.loader
 } cond
 
 "complex-double" c-type t >>return-in-registers? drop
-"bool" c-type 4 >>size 4 >>align drop
+
+[
+    <c-type>
+        [ alien-unsigned-4 c-bool> ] >>getter
+        [ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
+        4 >>size
+        4 >>align
+        "box_boolean" >>boxer
+        "to_boolean" >>unboxer
+    "bool" define-primitive-type
+] with-compilation-unit

basis/dlists/dlists-docs.factor

@@ -15,6 +15,7 @@ $nl
 "Iterating over elements:"
 { $subsection dlist-each }
 { $subsection dlist-find }
+{ $subsection dlist-filter }
 { $subsection dlist-any? }
 "Deleting a node matching a predicate:"
 { $subsection delete-node-if* }
@@ -40,6 +41,11 @@ HELP: dlist-find
     "This operation is O(n)."
 } ;
 
+HELP: dlist-filter
+{ $values { "dlist" { $link dlist } } { "quot" quotation } { "dlist" { $link dlist } } }
+{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, removing the corresponding nodes if the quotation returns " { $link f } "." }
+{ $side-effects { "dlist" } } ;
+
 HELP: dlist-any?
 { $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } }
 { $description "Just like " { $link dlist-find } " except it doesn't return the object." }

basis/dlists/dlists-tests.factor

@@ -79,3 +79,8 @@ IN: dlists.tests
 [ V{ f 3 1 f } ] [ <dlist> 1 over push-front 3 over push-front f over push-front f over push-back dlist>seq ] unit-test
 
 [ V{ } ] [ <dlist> dlist>seq ] unit-test
+
+[ V{ 0 2 4 } ] [ <dlist> { 0 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
+[ V{ 2 4 } ] [ <dlist> { 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
+[ V{ 2 4 } ] [ <dlist> { 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
+[ V{ 0 2 4 } ] [ <dlist> { 0 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test

basis/dlists/dlists.factor

@@ -95,7 +95,7 @@ M: dlist pop-front* ( dlist -- )
     [
         [
             [ empty-dlist ] unless*
-            [ f ] change-next drop
+            next>>
             f over set-prev-when
         ] change-front drop
     ] keep
@@ -108,7 +108,7 @@ M: dlist pop-back* ( dlist -- )
     [
         [
             [ empty-dlist ] unless*
-            [ f ] change-prev drop
+            prev>>
             f over set-next-when
         ] change-back drop
     ] keep
@@ -157,6 +157,9 @@ M: dlist clear-deque ( dlist -- )
 
 : 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
 
+: dlist-filter ( dlist quot -- dlist )
+    over [ '[ dup obj>> @ [ drop ] [ _ delete-node ] if ] dlist-each-node ] keep ; inline
+
 M: dlist clone
     <dlist> [ '[ _ push-back ] dlist-each ] keep ;
 

basis/fry/fry-docs.factor

@@ -57,7 +57,6 @@ $nl
 "Here are some built-in combinators rewritten in terms of fried quotations:"
 { $table
     { { $link literalize } { $snippet ": literalize '[ _ ] ;" } }
-    { { $link slip } { $snippet ": slip '[ @ _ ] call ;" } }
     { { $link curry } { $snippet ": curry '[ _ @ ] ;" } }
     { { $link compose } { $snippet ": compose '[ @ @ ] ;" } }
     { { $link bi@ } { $snippet ": bi@ tuck '[ _ @ _ @ ] call ;" } }

basis/generalizations/generalizations-docs.factor

@@ -161,22 +161,6 @@ HELP: ndip
     }
 } ;
 
-HELP: nslip
-{ $values { "n" integer } }
-{ $description "A generalization of " { $link slip } " that can work " 
-"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
-"removed from the stack, the quotation called, and the items restored."
-} 
-{ $examples
-  { $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip 6 narray ." "{ 99 1 2 3 4 5 }" }
-  "Some core words expressed in terms of " { $link nslip } ":"
-    { $table
-        { { $link slip } { $snippet "1 nslip" } }
-        { { $link 2slip } { $snippet "2 nslip" } }
-        { { $link 3slip } { $snippet "3 nslip" } }
-    }
-} ;
-
 HELP: nkeep
 { $values { "quot" quotation } { "n" integer } }
 { $description "A generalization of " { $link keep } " that can work " 
@@ -339,7 +323,6 @@ ARTICLE: "shuffle-generalizations" "Generalized shuffle words"
 
 ARTICLE: "combinator-generalizations" "Generalized combinators"
 { $subsection ndip }
-{ $subsection nslip }
 { $subsection nkeep }
 { $subsection napply }
 { $subsection ncleave }

basis/generalizations/generalizations-tests.factor

@@ -26,8 +26,6 @@ IN: generalizations.tests
 [ [ 1 ] 5 ndip ] must-infer
 [ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test
 
-[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer
-{ 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test
 [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
 { 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test
 [ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test

basis/generalizations/generalizations.factor

@@ -60,9 +60,6 @@ MACRO: ntuck ( n -- )
 MACRO: ndip ( quot n -- )
     [ '[ _ dip ] ] times ;
 
-MACRO: nslip ( n -- )
-    '[ [ call ] _ ndip ] ;
-
 MACRO: nkeep ( quot n -- )
     tuck '[ _ ndup _ _ ndip ] ;
 

basis/io/directories/search/search-docs.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations ;
+USING: help.markup help.syntax kernel quotations sequences ;
 IN: io.directories.search
 
 HELP: each-file
@@ -57,6 +57,32 @@ HELP: find-all-in-directories
 }
 { $description "Finds all files in the input directories matching the predicate quotation in a breadth-first or depth-first traversal." } ;
 
+HELP: find-by-extension
+{ $values
+    { "path" "a pathname string" } { "extension" "a file extension" }
+    { "seq" sequence }
+}
+{ $description "Searches a directory for all files with the given extension. File extension and filenames are converted to lower-case and compared using the " { $link tail? } " word. The file extension should contain the period." }
+{ $examples
+    { $unchecked-example
+        "USING: io.directories.search ;"
+        "\"/\" \".mp3\" find-by-extension"
+    }
+} ;
+
+HELP: find-by-extensions
+{ $values
+    { "path" "a pathname string" } { "extensions" "a sequence of file extensions" }
+    { "seq" sequence }
+}
+{ $description "Searches a directory for all files in the given list of extensions. File extensions and filenames are converted to lower-case and compared using the " { $link tail? } " word. File extensions should contain the period." }
+{ $examples
+    { $unchecked-example
+        "USING: io.directories.search ;"
+        "\"/\" { \".jpg\" \".gif\" \".tiff\" \".png\" \".bmp\" } find-by-extensions"
+    }
+} ;
+
 { find-file find-all-files find-in-directories find-all-in-directories } related-words
 
 ARTICLE: "io.directories.search" "Searching directories"
@@ -65,10 +91,13 @@ ARTICLE: "io.directories.search" "Searching directories"
 { $subsection recursive-directory-files }
 { $subsection recursive-directory-entries }
 { $subsection each-file }
-"Finding files:"
+"Finding files by name:"
 { $subsection find-file }
 { $subsection find-all-files }
 { $subsection find-in-directories }
-{ $subsection find-all-in-directories } ;
+{ $subsection find-all-in-directories }
+"Finding files by extension:"
+{ $subsection find-by-extension }
+{ $subsection find-by-extensions } ;
 
 ABOUT: "io.directories.search"

basis/io/directories/search/search.factor

@@ -3,7 +3,7 @@
 USING: accessors arrays continuations deques dlists fry
 io.directories io.files io.files.info io.pathnames kernel
 sequences system vocabs.loader locals math namespaces
-sorting assocs calendar threads io math.parser ;
+sorting assocs calendar threads io math.parser unicode.case ;
 IN: io.directories.search
 
 : qualified-directory-entries ( path -- seq )
@@ -106,4 +106,11 @@ ERROR: file-not-found path bfs? quot ;
         ] { } map>assoc
     ] with-qualified-directory-entries sort-values ;
 
+: find-by-extensions ( path extensions -- seq )
+    [ >lower ] map
+    '[ >lower _ [ tail? ] with any? ] find-all-files ;
+    
+: find-by-extension ( path extension -- seq )
+    1array find-by-extensions ;
+
 os windows? [ "io.directories.search.windows" require ] when

basis/io/launcher/unix/unix-tests.factor

@@ -48,7 +48,7 @@ concurrency.promises threads unix.process ;
     try-process
 ] unit-test
 
-[ f ] [
+[ "" ] [
     "cat"
     "launcher-test-1" temp-file
     2array

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

@@ -2,6 +2,8 @@ USING: io.streams.string io kernel arrays namespaces make
 tools.test ;
 IN: io.streams.string.tests
 
+[ "" ] [ "" [ contents ] with-string-reader ] unit-test
+
 [ "line 1" CHAR: l ]
 [
     "line 1\nline 2\nline 3" <string-reader>

basis/math/bitwise/bitwise.factor

@@ -35,6 +35,11 @@ IN: math.bitwise
 : w- ( int int -- int ) - 32 bits ; inline
 : w* ( int int -- int ) * 32 bits ; inline
 
+! 64-bit arithmetic
+: W+ ( int int -- int ) + 64 bits ; inline
+: W- ( int int -- int ) - 64 bits ; inline
+: W* ( int int -- int ) * 64 bits ; inline
+
 ! flags
 MACRO: flags ( values -- )
     [ 0 ] [ [ ?execute bitor ] curry compose ] reduce ;
@@ -106,3 +111,10 @@ PRIVATE>
 : >signed ( x n -- y )
     2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
 
+: >odd ( n -- int ) 0 set-bit ; foldable
+
+: >even ( n -- int ) 0 clear-bit ; foldable
+
+: next-even ( m -- n ) >even 2 + ; foldable
+
+: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; foldable

basis/math/miller-rabin/miller-rabin-docs.factor

@@ -1,100 +0,0 @@
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel sequences math ;
-IN: math.miller-rabin
-
-HELP: find-relative-prime
-{ $values
-    { "n" integer }
-    { "p" integer }
-}
-{ $description "Returns a number that is relatively prime to " { $snippet "n" } "." } ;
-
-HELP: find-relative-prime*
-{ $values
-    { "n" integer } { "guess" integer }
-    { "p" integer }
-}
-{ $description "Returns a number that is relatively prime to " { $snippet "n" } ", starting by trying " { $snippet "guess" } "." } ;
-
-HELP: miller-rabin
-{ $values
-    { "n" integer }
-    { "?" "a boolean" }
-}
-{ $description "Returns true if the number is a prime. Calls " { $link miller-rabin* } " with a default of 10 Miller-Rabin tests." } ;
-
-{ miller-rabin miller-rabin* } related-words
-
-HELP: miller-rabin*
-{ $values
-    { "n" integer } { "numtrials" integer }
-    { "?" "a boolean" }
-}
-{ $description "Performs " { $snippet "numtrials" } " trials of the Miller-Rabin probabilistic primality test algorithm and returns true if prime." } ;
-
-HELP: next-prime
-{ $values
-    { "n" integer }
-    { "p" integer }
-}
-{ $description "Tests consecutive numbers for primality with " { $link miller-rabin } " and returns the next prime." } ;
-
-HELP: next-safe-prime
-{ $values
-    { "n" integer }
-    { "q" integer }
-}
-{ $description "Tests consecutive numbers and returns the next safe prime. A safe prime is desirable in cryptography applications such as Diffie-Hellman and SRP6." } ;
-
-HELP: random-bits*
-{ $values
-    { "numbits" integer }
-    { "n" integer }
-}
-{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ;
-
-HELP: random-prime
-{ $values
-    { "numbits" integer }
-    { "p" integer }
-}
-{ $description "Returns a prime number exactly " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
-
-HELP: random-safe-prime
-{ $values
-    { "numbits" integer }
-    { "p" integer }
-}
-{ $description "Returns a safe prime number " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
-
-HELP: safe-prime?
-{ $values
-    { "q" integer }
-    { "?" "a boolean" }
-}
-{ $description "Tests whether the number is a safe prime. A safe prime " { $snippet "p" } " must be prime, as must " { $snippet "(p - 1) / 2" } "." } ;
-
-HELP: unique-primes
-{ $values
-    { "numbits" integer } { "n" integer }
-    { "seq" sequence }
-}
-{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ;
-
-ARTICLE: "math.miller-rabin" "Miller-Rabin probabilistic primality test"
-"The " { $vocab-link "math.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl
-"The Miller-Rabin probabilistic primality test:"
-{ $subsection miller-rabin }
-{ $subsection miller-rabin* }
-"Generating relative prime numbers:"
-{ $subsection find-relative-prime }
-{ $subsection find-relative-prime* }
-"Generating prime numbers:"
-{ $subsection next-prime }
-{ $subsection random-prime }
-"Generating safe prime numbers:"
-{ $subsection next-safe-prime }
-{ $subsection random-safe-prime } ;
-
-ABOUT: "math.miller-rabin"

basis/math/miller-rabin/miller-rabin-tests.factor

@@ -1,29 +0,0 @@
-USING: math.miller-rabin tools.test kernel sequences
-math.miller-rabin.private math ;
-IN: math.miller-rabin.tests
-
-[ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test
-[ t ] [ 2 miller-rabin ] unit-test
-[ t ] [ 3 miller-rabin ] unit-test
-[ f ] [ 36 miller-rabin ] unit-test
-[ t ] [ 37 miller-rabin ] unit-test
-[ 2 ] [ 1 next-prime ] unit-test
-[ 3 ] [ 2 next-prime ] unit-test
-[ 5 ] [ 3 next-prime ] unit-test
-[ 101 ] [ 100 next-prime ] unit-test
-[ t ] [ 2135623355842621559 miller-rabin ] unit-test
-[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test
-
-[ 863 ] [ 862 next-safe-prime ] unit-test
-[ f ] [ 862 safe-prime? ] unit-test
-[ t ] [ 7 safe-prime? ] unit-test
-[ f ] [ 31 safe-prime? ] unit-test
-[ t ] [ 47 safe-prime-candidate? ] unit-test
-[ t ] [ 47 safe-prime? ] unit-test
-[ t ] [ 863 safe-prime? ] unit-test
-
-[ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test
-
-[ 47 ] [ 31 next-safe-prime ] unit-test
-[ 49 ] [ 50 random-prime log2 ] unit-test
-[ 49 ] [ 50 random-bits* log2 ] unit-test

basis/math/miller-rabin/miller-rabin.factor

@@ -1,114 +0,0 @@
-! Copyright (c) 2008-2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel locals math math.functions math.ranges
-random sequences sets combinators.short-circuit math.bitwise
-math math.order ;
-IN: math.miller-rabin
-
-: >odd ( n -- int ) 0 set-bit ; foldable
-
-: >even ( n -- int ) 0 clear-bit ; foldable
-
-: next-even ( m -- n ) >even 2 + ;
-
-: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ;
-
-<PRIVATE
-
-:: (miller-rabin) ( n trials -- ? )
-    n 1 - :> n-1
-    n-1 factor-2s :> s :> r
-    0 :> a!
-    trials [
-        drop
-        2 n 2 - [a,b] random a!
-        a s n ^mod 1 = [
-            f
-        ] [
-            r iota [
-                2^ s * a swap n ^mod n - -1 =
-            ] any? not
-        ] if
-    ] any? not ;
-
-PRIVATE>
-
-: miller-rabin* ( n numtrials -- ? )
-    over {
-        { [ dup 1 <= ] [ 3drop f ] }
-        { [ dup 2 = ] [ 3drop t ] }
-        { [ dup even? ] [ 3drop f ] }
-        [ drop (miller-rabin) ]
-    } cond ;
-
-: miller-rabin ( n -- ? ) 10 miller-rabin* ;
-
-ERROR: prime-range-error n ;
-
-: next-prime ( n -- p )
-    dup 1 < [ prime-range-error ] when
-    dup 1 = [
-        drop 2
-    ] [
-        next-odd dup miller-rabin [ next-prime ] unless
-    ] if ;
-
-: random-bits* ( numbits -- n )
-    1 - [ random-bits ] keep set-bit ;
-
-: random-prime ( numbits -- p )
-    random-bits* next-prime ;
-
-ERROR: no-relative-prime n ;
-
-<PRIVATE
-
-: (find-relative-prime) ( n guess -- p )
-    over 1 <= [ over no-relative-prime ] when
-    dup 1 <= [ drop 3 ] when
-    2dup gcd nip 1 > [ 2 + (find-relative-prime) ] [ nip ] if ;
-
-PRIVATE>
-
-: find-relative-prime* ( n guess -- p )
-    #! find a prime relative to n with initial guess
-    >odd (find-relative-prime) ;
-
-: find-relative-prime ( n -- p )
-    dup random find-relative-prime* ;
-
-ERROR: too-few-primes ;
-
-: unique-primes ( numbits n -- seq )
-    #! generate two primes
-    swap
-    dup 5 < [ too-few-primes ] when
-    2dup [ random-prime ] curry replicate
-    dup all-unique? [ 2nip ] [ drop unique-primes ] if ;
-
-! Safe primes are of the form p = 2q + 1, p,q are prime
-! See http://en.wikipedia.org/wiki/Safe_prime
-
-<PRIVATE
-
-: safe-prime-candidate? ( n -- ? )
-    1 + 6 divisor? ;
-
-: next-safe-prime-candidate ( n -- candidate )
-    next-prime dup safe-prime-candidate?
-    [ next-safe-prime-candidate ] unless ;
-
-PRIVATE>
-
-: safe-prime? ( q -- ? )
-    {
-        [ 1 - 2 / dup integer? [ miller-rabin ] [ drop f ] if ]
-        [ miller-rabin ]
-    } 1&& ;
-
-: next-safe-prime ( n -- q )
-    next-safe-prime-candidate
-    dup safe-prime? [ next-safe-prime ] unless ;
-
-: random-safe-prime ( numbits -- p )
-    random-bits* next-safe-prime ;

basis/math/polynomials/polynomials-docs.factor

@@ -93,7 +93,13 @@ HELP: pdiff
 { $description "Finds the derivative of " { $snippet "p" } "." } ;
 
 HELP: polyval
-{ $values { "p" "a polynomial" } { "x" number } { "p[x]" number } }
+{ $values { "x" number } { "p" "a polynomial" } { "p[x]" number } }
 { $description "Evaluate " { $snippet "p" } " with the input " { $snippet "x" } "." }
-{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 0 1 } 2 polyval ." "5" } } ;
+{ $examples { $example "USING: math.polynomials prettyprint ;" "2 { 1 0 1 } polyval ." "5" } } ;
 
+HELP: polyval*
+{ $values { "p" "a literal polynomial" } }
+{ $description "Macro version of " { $link polyval } ". Evaluates the literal polynomial " { $snippet "p" } " at the value off the top of the stack." }
+{ $examples { $example "USING: math.polynomials prettyprint ;" "2 { 1 0 1 } polyval* ." "5" } } ;
+
+{ polyval polyval* } related-words

basis/math/polynomials/polynomials.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel make math math.order math.vectors sequences
-    splitting vectors ;
+    splitting vectors macros combinators ;
 IN: math.polynomials
 
 <PRIVATE
@@ -80,6 +80,12 @@ PRIVATE>
 : pdiff ( p -- p' )
     dup length v* { 0 } ?head drop ;
 
-: polyval ( p x -- p[x] )
+: polyval ( x p -- p[x] )
-    [ dup length ] dip powers v. ;
+    [ length swap powers ] [ nip ] 2bi v. ;
+
+MACRO: polyval* ( p -- )
+    reverse
+    [ 1 tail [ \ * swap \ + [ ] 3sequence ] map ]
+    [ first \ drop swap [ ] 2sequence ] bi
+    prefix \ cleave [ ] 2sequence ;
 

basis/math/primes/factors/factors.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2007-2009 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators kernel make math math.functions math.primes sequences ;
+USING: arrays combinators kernel make math math.functions
+math.primes sequences ;
 IN: math.primes.factors
 
 <PRIVATE

basis/math/primes/lucas-lehmer/authors.txt

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

basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor

@@ -0,0 +1,25 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel ;
+IN: math.primes.lucas-lehmer
+
+HELP: lucas-lehmer
+{ $values
+    { "p" "a prime number" }
+    { "?" "a boolean" }
+}
+{ $description "Runs the Lucas-Lehmer test on the prime " { $snippet "p" } " and returns " { $link t } " if " { $snippet "(2 ^ p) - 1" } " is prime." }
+{ $examples
+    { $example "! Test that (2 ^ 61) - 1 is prime:"
+               "USING: math.primes.lucas-lehmer prettyprint ;"
+               "61 lucas-lehmer ."
+               "t"
+    }
+} ;
+
+ARTICLE: "math.primes.lucas-lehmer" "Lucas-Lehmer Mersenne Primality test"
+"The " { $vocab-link "math.primes.lucas-lehmer" } " vocabulary tests numbers of the form " { $snippet "(2 ^ p) - 1" } " for primality, where " { $snippet "p" } " is prime." $nl
+"Run the Lucas-Lehmer test:"
+{ $subsection lucas-lehmer } ;
+
+ABOUT: "math.primes.lucas-lehmer"

basis/math/primes/lucas-lehmer/lucas-lehmer-tests.factor

@@ -0,0 +1,13 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test math.primes.lucas-lehmer ;
+IN: math.primes.lucas-lehmer.tests
+
+[ t ] [ 2 lucas-lehmer ] unit-test
+[ t ] [ 3 lucas-lehmer ] unit-test
+[ f ] [ 4 lucas-lehmer ] unit-test
+[ t ] [ 5 lucas-lehmer ] unit-test
+[ f ] [ 6 lucas-lehmer ] unit-test
+[ f ] [ 11 lucas-lehmer ] unit-test
+[ t ] [ 13 lucas-lehmer ] unit-test
+[ t ] [ 61 lucas-lehmer ] unit-test

basis/math/primes/lucas-lehmer/lucas-lehmer.factor

@@ -0,0 +1,27 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators fry kernel locals math
+math.primes combinators.short-circuit ;
+IN: math.primes.lucas-lehmer
+
+ERROR: invalid-lucas-lehmer-candidate obj ;
+
+<PRIVATE
+
+: do-lucas-lehmer ( p -- ? )
+    [ drop 4 ] [ 2 - ] [ 2^ 1 - ] tri
+    '[ sq 2 - _ mod ] times 0 = ;
+
+: lucas-lehmer-guard ( obj -- obj )
+    dup { [ integer? ] [ 0 > ] } 1&&
+    [ invalid-lucas-lehmer-candidate ] unless ;
+
+PRIVATE>
+
+: lucas-lehmer ( p -- ? )
+    lucas-lehmer-guard
+    {
+        { [ dup 2 = ] [ drop t ] }
+        { [ dup prime? ] [ do-lucas-lehmer ] }
+        [ drop f ]
+    } cond ;

basis/math/primes/miller-rabin/miller-rabin-docs.factor

@@ -0,0 +1,28 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel sequences math ;
+IN: math.primes.miller-rabin
+
+HELP: miller-rabin
+{ $values
+    { "n" integer }
+    { "?" "a boolean" }
+}
+{ $description "Returns true if the number is a prime. Calls " { $link miller-rabin* } " with a default of 10 Miller-Rabin tests." } ;
+
+{ miller-rabin miller-rabin* } related-words
+
+HELP: miller-rabin*
+{ $values
+    { "n" integer } { "numtrials" integer }
+    { "?" "a boolean" }
+}
+{ $description "Performs " { $snippet "numtrials" } " trials of the Miller-Rabin probabilistic primality test algorithm and returns true if prime." } ;
+
+ARTICLE: "math.primes.miller-rabin" "Miller-Rabin probabilistic primality test"
+"The " { $vocab-link "math.primes.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl
+"The Miller-Rabin probabilistic primality test:"
+{ $subsection miller-rabin }
+{ $subsection miller-rabin* } ;
+
+ABOUT: "math.primes.miller-rabin"

basis/math/primes/miller-rabin/miller-rabin-tests.factor

@@ -0,0 +1,11 @@
+USING: kernel math.primes.miller-rabin sequences tools.test ;
+IN: math.primes.miller-rabin.tests
+
+[ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test
+[ t ] [ 2 miller-rabin ] unit-test
+[ t ] [ 3 miller-rabin ] unit-test
+[ f ] [ 36 miller-rabin ] unit-test
+[ t ] [ 37 miller-rabin ] unit-test
+[ t ] [ 2135623355842621559 miller-rabin ] unit-test
+
+[ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test

basis/math/primes/miller-rabin/miller-rabin.factor

@@ -0,0 +1,35 @@
+! Copyright (c) 2008-2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators combinators.short-circuit kernel locals math
+math.functions math.ranges random sequences sets ;
+IN: math.primes.miller-rabin
+
+<PRIVATE
+
+:: (miller-rabin) ( n trials -- ? )
+    n 1 - :> n-1
+    n-1 factor-2s :> s :> r
+    0 :> a!
+    trials [
+        drop
+        2 n 2 - [a,b] random a!
+        a s n ^mod 1 = [
+            f
+        ] [
+            r iota [
+                2^ s * a swap n ^mod n - -1 =
+            ] any? not
+        ] if
+    ] any? not ;
+
+PRIVATE>
+
+: miller-rabin* ( n numtrials -- ? )
+    over {
+        { [ dup 1 <= ] [ 3drop f ] }
+        { [ dup 2 = ] [ 3drop t ] }
+        { [ dup even? ] [ 3drop f ] }
+        [ drop (miller-rabin) ]
+    } cond ;
+
+: miller-rabin ( n -- ? ) 10 miller-rabin* ;

basis/math/primes/primes-docs.factor

@@ -1,10 +1,10 @@
-USING: help.markup help.syntax ;
+USING: help.markup help.syntax math sequences ;
 IN: math.primes
 
 { next-prime prime? } related-words
 
 HELP: next-prime
-{ $values { "n" "an integer not smaller than 2" } { "p" "a prime number" } }
+{ $values { "n" integer } { "p" "a prime number" } }
 { $description "Return the next prime number greater than " { $snippet "n" } "." } ;
 
 HELP: prime?
@@ -20,3 +20,48 @@ HELP: primes-upto
 HELP: primes-between
 { $values { "low" "an integer" } { "high" "an integer" } { "seq" "a sequence" } }
 { $description "Return a sequence containing all the prime numbers between " { $snippet "low" } " and " { $snippet "high" } "." } ;
+
+HELP: find-relative-prime
+{ $values
+    { "n" integer }
+    { "p" integer }
+}
+{ $description "Returns a number that is relatively prime to " { $snippet "n" } "." } ;
+
+HELP: find-relative-prime*
+{ $values
+    { "n" integer } { "guess" integer }
+    { "p" integer }
+}
+{ $description "Returns a number that is relatively prime to " { $snippet "n" } ", starting by trying " { $snippet "guess" } "." } ;
+
+HELP: random-prime
+{ $values
+    { "numbits" integer }
+    { "p" integer }
+}
+{ $description "Returns a prime number exactly " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
+
+HELP: unique-primes
+{ $values
+    { "numbits" integer } { "n" integer }
+    { "seq" sequence }
+}
+{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ;
+
+ARTICLE: "math.primes" "Prime numbers"
+"The " { $vocab-link "math.primes" } " vocabulary implements words related to prime numbers. Serveral useful vocabularies exist for testing primality. The Sieve of Eratosthenes in " { $vocab-link "math.primes.erato" } " is useful for testing primality below five million. For larger integers, " { $vocab-link "math.primes.miller-rabin" } " is a fast probabilstic primality test. The " { $vocab-link "math.primes.lucas-lehmer" } " vocabulary implements an algorithm for finding huge Mersenne prime numbers." $nl
+"Testing if a number is prime:"
+{ $subsection prime? }
+"Generating prime numbers:"
+{ $subsection next-prime }
+{ $subsection primes-upto }
+{ $subsection primes-between }
+{ $subsection random-prime }
+"Generating relative prime numbers:"
+{ $subsection find-relative-prime }
+{ $subsection find-relative-prime* }
+"Make a sequence of random prime numbers:"
+{ $subsection unique-primes } ;
+
+ABOUT: "math.primes"

basis/math/primes/primes-tests.factor

@@ -1,4 +1,6 @@
-USING: arrays math.primes tools.test ;
+USING: arrays math math.primes math.primes.miller-rabin
+tools.test ;
+IN: math.primes.tests
 
 { 1237 } [ 1234 next-prime ] unit-test
 { f t } [ 1234 prime? 1237 prime? ] unit-test
@@ -7,3 +9,12 @@ USING: arrays math.primes tools.test ;
 
 { { 4999963 4999999 5000011 5000077 5000081 } }
 [ 4999962 5000082 primes-between >array ] unit-test
+
+[ 2 ] [ 1 next-prime ] unit-test
+[ 3 ] [ 2 next-prime ] unit-test
+[ 5 ] [ 3 next-prime ] unit-test
+[ 101 ] [ 100 next-prime ] unit-test
+[ t ] [ 2135623355842621559 miller-rabin ] unit-test
+[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test
+
+[ 49 ] [ 50 random-prime log2 ] unit-test

basis/math/primes/primes.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2007-2009 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel math math.functions math.miller-rabin
+USING: combinators kernel math math.bitwise math.functions
-math.order math.primes.erato math.ranges sequences ;
+math.order math.primes.erato math.primes.miller-rabin
+math.ranges random sequences sets fry ;
 IN: math.primes
 
 <PRIVATE
@@ -21,7 +22,11 @@ PRIVATE>
     } cond ; foldable
 
 : next-prime ( n -- p )
-    next-odd [ dup really-prime? ] [ 2 + ] until ; foldable
+    dup 2 < [
+        drop 2
+    ] [
+        next-odd [ dup really-prime? ] [ 2 + ] until
+    ] if ; foldable
 
 : primes-between ( low high -- seq )
     [ dup 3 max dup even? [ 1 + ] when ] dip
@@ -31,3 +36,34 @@ PRIVATE>
 : primes-upto ( n -- seq ) 2 swap primes-between ;
 
 : coprime? ( a b -- ? ) gcd nip 1 = ; foldable
+
+: random-prime ( numbits -- p )
+    random-bits* next-prime ;
+
+: estimated-primes ( m -- n )
+    dup log / ; foldable
+
+ERROR: no-relative-prime n ;
+
+<PRIVATE
+
+: (find-relative-prime) ( n guess -- p )
+    over 1 <= [ over no-relative-prime ] when
+    dup 1 <= [ drop 3 ] when
+    2dup gcd nip 1 > [ 2 + (find-relative-prime) ] [ nip ] if ;
+
+PRIVATE>
+
+: find-relative-prime* ( n guess -- p )
+    #! find a prime relative to n with initial guess
+    >odd (find-relative-prime) ;
+
+: find-relative-prime ( n -- p )
+    dup random find-relative-prime* ;
+
+ERROR: too-few-primes n numbits ;
+
+: unique-primes ( n numbits -- seq )
+    2dup 2^ estimated-primes > [ too-few-primes ] when
+    2dup '[ _ random-prime ] replicate
+    dup all-unique? [ 2nip ] [ drop unique-primes ] if ;

basis/math/primes/safe/authors.txt

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

basis/math/primes/safe/safe-docs.factor

@@ -0,0 +1,38 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.short-circuit help.markup help.syntax kernel
+math math.functions math.primes random ;
+IN: math.primes.safe
+
+HELP: next-safe-prime
+{ $values
+    { "n" integer }
+    { "q" integer }
+}
+{ $description "Tests consecutive numbers and returns the next safe prime. A safe prime is desirable in cryptography applications such as Diffie-Hellman and SRP6." } ;
+
+HELP: random-safe-prime
+{ $values
+    { "numbits" integer }
+    { "p" integer }
+}
+{ $description "Returns a safe prime number " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
+
+HELP: safe-prime?
+{ $values
+    { "q" integer }
+    { "?" "a boolean" }
+}
+{ $description "Tests whether the number is a safe prime. A safe prime " { $snippet "p" } " must be prime, as must " { $snippet "(p - 1) / 2" } "." } ;
+
+
+ARTICLE: "math.primes.safe" "Safe prime numbers"
+"The " { $vocab-link "math.primes.safe" } " vocabulary implements words to calculate safe prime numbers. Safe primes are of the form p = 2q + 1, where p,q are prime. Safe primes have desirable qualities for cryptographic applications." $nl
+
+"Testing if a number is a safe prime:"
+{ $subsection safe-prime? }
+"Generating safe prime numbers:"
+{ $subsection next-safe-prime }
+{ $subsection random-safe-prime } ;
+
+ABOUT: "math.primes.safe"

basis/math/primes/safe/safe-tests.factor

@@ -0,0 +1,14 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math.primes.safe math.primes.safe.private tools.test ;
+IN: math.primes.safe.tests
+
+[ 863 ] [ 862 next-safe-prime ] unit-test
+[ f ] [ 862 safe-prime? ] unit-test
+[ t ] [ 7 safe-prime? ] unit-test
+[ f ] [ 31 safe-prime? ] unit-test
+[ t ] [ 47 safe-prime-candidate? ] unit-test
+[ t ] [ 47 safe-prime? ] unit-test
+[ t ] [ 863 safe-prime? ] unit-test
+
+[ 47 ] [ 31 next-safe-prime ] unit-test

basis/math/primes/safe/safe.factor

@@ -0,0 +1,29 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.short-circuit kernel math math.functions
+math.primes random ;
+IN: math.primes.safe
+
+<PRIVATE
+
+: safe-prime-candidate? ( n -- ? )
+    1 + 6 divisor? ;
+
+: next-safe-prime-candidate ( n -- candidate )
+    next-prime dup safe-prime-candidate?
+    [ next-safe-prime-candidate ] unless ;
+
+PRIVATE>
+
+: safe-prime? ( q -- ? )
+    {
+        [ 1 - 2 / dup integer? [ prime? ] [ drop f ] if ]
+        [ prime? ]
+    } 1&& ;
+
+: next-safe-prime ( n -- q )
+    next-safe-prime-candidate
+    dup safe-prime? [ next-safe-prime ] unless ;
+
+: random-safe-prime ( numbits -- p )
+    random-bits* next-safe-prime ;

basis/math/rectangles/prettyprint/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/math/rectangles/prettyprint/prettyprint.factor

@@ -0,0 +1,7 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors math.rectangles kernel prettyprint.custom prettyprint.backend ;
+IN: math.rectangles.prettyprint
+
+M: rect pprint*
+    \ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ;

basis/math/rectangles/rectangles.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel arrays sequences math math.vectors accessors
-parser prettyprint.custom prettyprint.backend ;
+parser ;
 IN: math.rectangles
 
 TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
@@ -10,9 +10,6 @@ TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
 
 SYNTAX: RECT: scan-object scan-object <rect> parsed ;
 
-M: rect pprint*
-    \ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ;
-
 : <zero-rect> ( -- rect ) rect new ; inline
 
 : point>rect ( loc -- rect ) { 0 0 } <rect> ; inline
@@ -64,3 +61,7 @@ M: rect contains-point?
     [ [ loc>> ] dip (>>loc) ]
     [ [ dim>> ] dip (>>dim) ]
     2bi ; inline
+
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [ "math.rectangles.prettyprint" require ] when

basis/math/vectors/vectors.factor

@@ -41,6 +41,13 @@ IN: math.vectors
 : set-axis ( u v axis -- w )
     [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ;
 
+: 2tetra@ ( p q r s t u v w quot -- )
+    dup [ [ 2bi@ ] curry 4dip ] dip 2bi@ ; inline
+
+: trilerp ( aaa baa aba bba aab bab abb bbb {t,u,v} -- a_tuv )
+    [ first lerp ] [ second lerp ] [ third lerp ] tri-curry
+    [ 2tetra@ ] [ 2bi@ ] [ call ] tri* ;
+
 : bilerp ( aa ba ab bb {t,u} -- a_tu )
     [ first lerp ] [ second lerp ] bi-curry
     [ 2bi@ ] [ call ] bi* ;
@@ -72,3 +79,6 @@ HINTS: v. { array array } ;
 
 HINTS: vlerp { array array array } ;
 HINTS: vnlerp { array array object } ;
+
+HINTS: bilerp { object object object object array } ;
+HINTS: trilerp { object object object object object object object object array } ;

basis/none/deploy.factor

@@ -6,7 +6,6 @@ H{
     { deploy-name "none" }
     { "stop-after-last-window?" t }
     { deploy-c-types? f }
-    { deploy-compiler? f }
     { deploy-io 1 }
     { deploy-ui? f }
     { deploy-reflection 1 }

basis/random/random-docs.factor

@@ -40,9 +40,17 @@ HELP: random-bytes
 } ;
 
 HELP: random-bits
-{ $values { "n" "an integer" } { "r" "a random integer" } }
+{ $values { "numbits" integer } { "r" "a random integer" } }
 { $description "Outputs an random integer n bits in length." } ;
 
+HELP: random-bits*
+{ $values
+    { "numbits" integer }
+    { "n" integer }
+}
+{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ;
+
+
 HELP: with-random
 { $values { "tuple" "a random generator" } { "quot" "a quotation" } }
 { $description "Calls the quotation with the random generator in a dynamic variable.  All random numbers will be generated using this random generator." } ;
@@ -93,6 +101,9 @@ $nl
 "Randomizing a sequence:"
 { $subsection randomize }
 "Deleting a random element from a sequence:"
-{ $subsection delete-random } ;
+{ $subsection delete-random }
+"Random numbers with " { $snippet "n" } " bits:"
+{ $subsection random-bits }
+{ $subsection random-bits* } ;
 
 ABOUT: "random"

basis/random/random-tests.factor

@@ -23,3 +23,5 @@ IN: random.tests
 
 [ f ]
 [ 100 [ { 0 1 } random ] replicate all-equal? ] unit-test
+
+[ 49 ] [ 50 random-bits* log2 ] unit-test

basis/random/random.factor

@@ -45,7 +45,10 @@ M: f random-32* ( obj -- * ) no-random-number-generator ;
 
 PRIVATE>
 
-: random-bits ( n -- r ) 2^ random-integer ;
+: random-bits ( numbits -- r ) 2^ random-integer ;
+
+: random-bits* ( numbits -- n )
+    1 - [ random-bits ] keep set-bit ;
 
 : random ( seq -- elt )
     [ f ] [

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

@@ -95,15 +95,6 @@ M: composed infer-call*
 M: object infer-call*
     "literal quotation" literal-expected ;
 
-: infer-nslip ( n -- )
-    [ infer->r infer-call ] [ infer-r> ] bi ;
-
-: infer-slip ( -- ) 1 infer-nslip ;
-
-: infer-2slip ( -- ) 2 infer-nslip ;
-
-: infer-3slip ( -- ) 3 infer-nslip ;
-
 : infer-ndip ( word n -- )
     [ literals get ] 2dip
     [ '[ _ def>> infer-quot-here ] ]
@@ -180,9 +171,6 @@ M: object infer-call*
         { \ declare [ infer-declare ] }
         { \ call [ infer-call ] }
         { \ (call) [ infer-call ] }
-        { \ slip [ infer-slip ] }
-        { \ 2slip [ infer-2slip ] }
-        { \ 3slip [ infer-3slip ] }
         { \ dip [ infer-dip ] }
         { \ 2dip [ infer-2dip ] }
         { \ 3dip [ infer-3dip ] }
@@ -216,7 +204,7 @@ M: object infer-call*
     "local-word-def" word-prop infer-quot-here ;
 
 {
-    declare call (call) slip 2slip 3slip dip 2dip 3dip curry compose
+    declare call (call) dip 2dip 3dip curry compose
     execute (execute) call-effect-unsafe execute-effect-unsafe if
     dispatch <tuple-boa> exit load-local load-locals get-local
     drop-locals do-primitive alien-invoke alien-indirect

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

@@ -180,7 +180,7 @@ DEFER: blah4
     over [
         2drop
     ] [
-        [ swap slip ] keep swap bad-combinator
+        [ dip ] keep swap bad-combinator
     ] if ; inline recursive
 
 [ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail

basis/struct-arrays/struct-arrays.factor

@@ -35,6 +35,6 @@ ERROR: bad-byte-array-length byte-array ;
     heap-size struct-array boa ; inline
 
 : malloc-struct-array ( length c-type -- struct-array )
-    [ heap-size calloc ] 2keep <direct-struct-array> ;
+    [ heap-size calloc ] 2keep <direct-struct-array> ; inline
 
 INSTANCE: struct-array sequence

basis/tools/deploy/backend/backend.factor

@@ -43,14 +43,14 @@ CONSTANT: theme-path "basis/ui/gadgets/theme/"
     [ my-arch make-image ] unless ;
 
 : bootstrap-profile ( -- profile )
-    {
+    [
-        { "math"     deploy-math?     }
+        deploy-math? get [ "math" , ] when
-        { "compiler" deploy-compiler? }
+        deploy-threads? get [ "threads" , ] when
-        { "threads"  deploy-threads?  }
+        "compiler" ,
-        { "ui"       deploy-ui?       }
+        deploy-ui? get [ "ui" , ] when
-        { "unicode"  deploy-unicode?  }
+        deploy-unicode? get [ "unicode" , ] when
-    } [ nip get ] assoc-filter keys
+        native-io? [ "io" , ] when
-    native-io? [ "io" suffix ] when ;
+    ] { } make ;
 
 : staging-image-name ( profile -- name )
     "staging."

basis/tools/deploy/config/config-docs.factor

@@ -5,7 +5,6 @@ IN: tools.deploy.config
 ARTICLE: "deploy-flags" "Deployment flags"
 "There are two sets of deployment flags. The first set controls the major subsystems which are to be included in the deployment image:"
 { $subsection deploy-math?     }
-{ $subsection deploy-compiler? }
 { $subsection deploy-unicode?   }
 { $subsection deploy-threads?  }
 { $subsection deploy-ui?       }
@@ -53,11 +52,6 @@ HELP: deploy-math?
 $nl
 "On by default. Often the programmer will use rationals without realizing it. A small amount of space can be saved by stripping these features out, but some code may require changes to work properly." } ;
 
-HELP: deploy-compiler?
-{ $description "Deploy flag. If set, words in the deployed image will be compiled with the optimizing compiler when possible."
-$nl
-"On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ;
-
 HELP: deploy-unicode?
 { $description "Deploy flag. If set, full Unicode " { $link POSTPONE: CHAR: } " syntax is included."
 $nl

basis/tools/deploy/config/config.factor

@@ -7,7 +7,6 @@ IN: tools.deploy.config
 SYMBOL: deploy-name
 
 SYMBOL: deploy-ui?
-SYMBOL: deploy-compiler?
 SYMBOL: deploy-math?
 SYMBOL: deploy-unicode?
 SYMBOL: deploy-threads?
@@ -55,7 +54,6 @@ SYMBOL: deploy-image
         { deploy-ui?                f }
         { deploy-io                 2 }
         { deploy-reflection         1 }
-        { deploy-compiler?          t }
         { deploy-threads?           t }
         { deploy-unicode?           f }
         { deploy-math?              t }

basis/tools/deploy/deploy-docs.factor

@@ -29,6 +29,8 @@ ARTICLE: "tools.deploy.caveats" "Deploy tool caveats"
 "In deployed applications, the " { $link boa } " word does not verify that the parameters on the stack satisfy the tuple's slot declarations, if any. This reduces deploy image size but can make bugs harder to track down. Make sure your program is fully debugged before deployment."
 { $heading "Behavior of " { $link POSTPONE: execute( } }
 "Similarly, the " { $link POSTPONE: execute( } " word does not check word stack effects in deployed applications, since stack effects are stripped out, and so it behaves exactly like " { $link POSTPONE: execute-effect-unsafe } "."
+{ $heading "Behavior of " { $link POSTPONE: call-next-method } }
+"The " { $link POSTPONE: call-next-method } " word does not check if the input is of the right type in deployed applications."
 { $heading "Error reporting" }
 "If the " { $link deploy-reflection } " level in the configuration is low enough, the debugger is stripped out, and error messages can be rather cryptic. Increase the reflection level to get readable error messages."
 { $heading "Choosing the right deploy flags" }

basis/tools/deploy/deploy-tests.factor

@@ -11,7 +11,7 @@ io.directories tools.deploy.test ;
 
 [ t ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test
 
-[ "staging.math-compiler-threads-ui-strip.image" ] [
+[ "staging.math-threads-compiler-ui-strip.image" ] [
     "hello-ui" deploy-config
     [ bootstrap-profile staging-image-name file-name ] bind
 ] unit-test
@@ -20,6 +20,10 @@ io.directories tools.deploy.test ;
 
 [ t ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test
 
+[ t ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test
+
+[ t ] [ "terrain" shake-and-bake 1600000 small-enough? ] unit-test
+
 [ t ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test
 
 os macosx? [
@@ -84,7 +88,6 @@ M: quit-responder call-responder*
 {
     "tools.deploy.test.6"
     "tools.deploy.test.7"
-    "tools.deploy.test.8"
     "tools.deploy.test.9"
     "tools.deploy.test.10"
     "tools.deploy.test.11"
@@ -95,3 +98,7 @@ M: quit-responder call-responder*
         run-temp-image
     ] curry unit-test
 ] each
+
+os windows? os macosx? or [
+    [ ] [ "tools.deploy.test.8" shake-and-bake run-temp-image ] unit-test
+] when

basis/tools/deploy/shaker/shaker.factor

@@ -1,13 +1,11 @@
 ! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors io.backend io.streams.c init fry
+USING: arrays accessors io.backend io.streams.c init fry namespaces
-namespaces make assocs kernel parser lexer strings.parser vocabs
+make assocs kernel parser lexer strings.parser vocabs sequences words
-sequences words memory kernel.private
+memory kernel.private continuations io vocabs.loader system strings
-continuations io vocabs.loader system strings sets
+sets vectors quotations byte-arrays sorting compiler.units definitions
-vectors quotations byte-arrays sorting compiler.units
+generic generic.standard tools.deploy.config combinators classes ;
-definitions generic generic.standard tools.deploy.config ;
 QUALIFIED: bootstrap.stage2
-QUALIFIED: classes
 QUALIFIED: command-line
 QUALIFIED: compiler.errors
 QUALIFIED: continuations
@@ -43,7 +41,7 @@ IN: tools.deploy.shaker
     ] when
     strip-dictionary? [
         {
-            "compiler.units"
+            ! "compiler.units"
             "vocabs"
             "vocabs.cache"
             "source-files.errors"
@@ -193,6 +191,11 @@ IN: tools.deploy.shaker
     strip-word-names? [ dup strip-word-names ] when
     2drop ;
 
+: strip-compiler-classes ( -- )
+    "Stripping compiler classes" show
+    "compiler" child-vocabs [ words ] map concat [ class? ] filter
+    [ dup implementors [ "methods" word-prop delete-at ] with each ] each ;
+
 : strip-default-methods ( -- )
     strip-debugger? [
         "Stripping default methods" show
@@ -255,20 +258,20 @@ IN: tools.deploy.shaker
             {
                 gensym
                 name>char-hook
-                classes:next-method-quot-cache
+                next-method-quot-cache
-                classes:class-and-cache
+                class-and-cache
-                classes:class-not-cache
+                class-not-cache
-                classes:class-or-cache
+                class-or-cache
-                classes:class<=-cache
+                class<=-cache
-                classes:classes-intersect-cache
+                classes-intersect-cache
-                classes:implementors-map
+                implementors-map
-                classes:update-map
+                update-map
                 command-line:main-vocab-hook
                 compiled-crossref
                 compiled-generic-crossref
                 compiler-impl
                 compiler.errors:compiler-errors
-                definition-observers
+                ! definition-observers
                 interactive-vocabs
                 lexer-factory
                 print-use-hook
@@ -298,16 +301,16 @@ IN: tools.deploy.shaker
                 compiler.errors:compiler-errors
                 continuations:thread-error-hook
             } %
+            
+            deploy-ui? get [
+                "ui-error-hook" "ui.gadgets.worlds" lookup ,
+            ] when
         ] when
 
         deploy-c-types? get [
             "c-types" "alien.c-types" lookup ,
         ] unless
 
-        deploy-ui? get [
-            "ui-error-hook" "ui.gadgets.worlds" lookup ,
-        ] when
-
         "windows-messages" "windows.messages" lookup [ , ] when*
     ] { } make ;
 
@@ -334,8 +337,17 @@ IN: tools.deploy.shaker
     [ instances dup H{ } clone [ [ ] cache ] curry map ] dip call
     become ; inline
 
-: compress-byte-arrays ( -- )
+: compress-object? ( obj -- ? )
-    [ byte-array? ] [ ] "byte arrays" compress ;
+    {
+        { [ dup array? ] [ empty? ] }
+        { [ dup byte-array? ] [ drop t ] }
+        { [ dup string? ] [ drop t ] }
+        { [ dup wrapper? ] [ drop t ] }
+        [ drop f ]
+    } cond ;
+
+: compress-objects ( -- )
+    [ compress-object? ] [ ] "objects" compress ;
 
 : remain-compiled ( old new -- old new )
     #! Quotations which were formerly compiled must remain
@@ -349,12 +361,6 @@ IN: tools.deploy.shaker
     [ quotation? ] [ remain-compiled ] "quotations" compress
     [ quotation? ] instances [ f >>cached-effect f >>cache-counter drop ] each ;
 
-: compress-strings ( -- )
-    [ string? ] [ ] "strings" compress ;
-
-: compress-wrappers ( -- )
-    [ wrapper? ] [ ] "wrappers" compress ;
-
 SYMBOL: deploy-vocab
 
 : [:c] ( -- word ) ":c" "debugger" lookup ;
@@ -385,18 +391,23 @@ SYMBOL: deploy-vocab
     t "quiet" set-global
     f output-stream set-global ;
 
+: unsafe-next-method-quot ( method -- quot )
+    [ "method-class" word-prop ]
+    [ "method-generic" word-prop ] bi
+    next-method 1quotation ;
+
 : compute-next-methods ( -- )
     [ standard-generic? ] instances [
         "methods" word-prop [
-            nip
+            nip dup
-            dup next-method-quot "next-method-quot" set-word-prop
+            unsafe-next-method-quot
+            "next-method-quot" set-word-prop
         ] assoc-each
     ] each
     "vocab:tools/deploy/shaker/next-methods.factor" run-file ;
 
 : strip ( -- )
     init-stripper
-    strip-default-methods
     strip-libc
     strip-call
     strip-cocoa
@@ -404,14 +415,14 @@ SYMBOL: deploy-vocab
     compute-next-methods
     strip-init-hooks
     strip-c-io
+    strip-compiler-classes
+    strip-default-methods
     f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
     deploy-vocab get vocab-main deploy-boot-quot
     stripped-word-props
     stripped-globals strip-globals
-    compress-byte-arrays
+    compress-objects
     compress-quotations
-    compress-strings
-    compress-wrappers
     strip-words ;
 
 : deploy-error-handler ( quot -- )
@@ -432,6 +443,9 @@ SYMBOL: deploy-vocab
             strip-debugger? [
                 "debugger" require
                 "inspector" require
+                deploy-ui? get [
+                    "ui.debugger" require
+                ] when
             ] unless
             deploy-vocab set
             deploy-vocab get require

basis/tools/deploy/shaker/strip-cocoa.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2007, 2008 Slava Pestov
+! Copyright (C) 2007, 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: cocoa cocoa.messages cocoa.application cocoa.nibs assocs
 namespaces kernel kernel.private words compiler.units sequences
-init vocabs ;
+init vocabs memoize accessors ;
 IN: tools.deploy.shaker.cocoa
 
 : pool ( obj -- obj' ) \ pool get [ ] cache ;
@@ -42,3 +42,8 @@ H{ } clone \ pool [
         [ get values compile ] each
     ] bind
 ] with-variable
+
+\ make-prepare-send reset-memoized
+\ <selector> reset-memoized
+
+\ (send) def>> second clear-assoc

basis/tools/deploy/test/1/deploy.factor

@@ -8,7 +8,6 @@ H{
     { deploy-math? t }
     { deploy-io 2 }
     { deploy-name "tools.deploy.test.1" }
-    { deploy-compiler? t }
     { deploy-reflection 1 }
     { "stop-after-last-window?" t }
 }

basis/tools/deploy/test/10/deploy.factor

@@ -4,7 +4,6 @@ H{
     { deploy-unicode? f }
     { deploy-io 2 }
     { deploy-word-props? f }
-    { deploy-compiler? f }
     { deploy-threads? f }
     { deploy-word-defs? f }
     { "stop-after-last-window?" t }

basis/tools/deploy/test/11/deploy.factor

@@ -9,7 +9,6 @@ H{
     { deploy-math? f }
     { deploy-unicode? f }
     { deploy-threads? f }
-    { deploy-compiler? f }
     { deploy-io 2 }
     { deploy-ui? f }
 }

basis/tools/deploy/test/12/deploy.factor

@@ -9,7 +9,6 @@ H{
     { deploy-io 2 }
     { deploy-ui? f }
     { deploy-name "tools.deploy.test.12" }
-    { deploy-compiler? f }
     { deploy-word-defs? f }
     { deploy-threads? f }
 }

basis/tools/deploy/test/13/deploy.factor

@@ -1,7 +1,6 @@
 USING: tools.deploy.config ;
 H{
     { deploy-threads? t }
-    { deploy-compiler? t }
     { deploy-math? t }
     { deploy-io 2 }
     { "stop-after-last-window?" t }

basis/tools/deploy/test/2/deploy.factor

@@ -8,7 +8,6 @@ H{
     { deploy-math? t }
     { deploy-io 2 }
     { deploy-name "tools.deploy.test.2" }
-    { deploy-compiler? t }
     { deploy-reflection 1 }
     { "stop-after-last-window?" t }
 }

basis/tools/deploy/test/3/deploy.factor

@@ -6,7 +6,6 @@ H{
     { "stop-after-last-window?" t }
     { deploy-word-defs? f }
     { deploy-reflection 1 }
-    { deploy-compiler? t }
     { deploy-threads? t }
     { deploy-io 3 }
     { deploy-math? t }

basis/tools/deploy/test/4/deploy.factor

@@ -8,7 +8,6 @@ H{
     { deploy-math? t }
     { deploy-io 2 }
     { deploy-name "tools.deploy.test.4" }
-    { deploy-compiler? t }
     { deploy-reflection 1 }
     { "stop-after-last-window?" t }
 }

basis/tools/deploy/test/5/deploy.factor

@@ -8,7 +8,6 @@ H{
     { deploy-math? t }
     { deploy-io 3 }
     { deploy-name "tools.deploy.test.5" }
-    { deploy-compiler? t }
     { deploy-reflection 1 }
     { "stop-after-last-window?" t }
 }

basis/tools/deploy/test/6/deploy.factor

@@ -5,7 +5,6 @@ H{
     { deploy-io 1 }
     { deploy-name "tools.deploy.test.6" }
     { deploy-math? t }
-    { deploy-compiler? t }
     { deploy-ui? f }
     { deploy-c-types? f }
     { deploy-word-defs? f }

basis/tools/deploy/test/7/deploy.factor

@@ -6,7 +6,6 @@ H{
     { deploy-io 2 }
     { deploy-math? t }
     { "stop-after-last-window?" t }
-    { deploy-compiler? t }
     { deploy-unicode? f }
     { deploy-c-types? f }
     { deploy-reflection 1 }

basis/tools/deploy/test/8/8.factor

@@ -1,11 +1,21 @@
-USING: kernel ;
+USING: calendar game-input threads ui ui.gadgets.worlds kernel
+method-chains system ;
 IN: tools.deploy.test.8
 
-: literal-merge-test-1 ( -- x ) H{ { "lil" "wayne" } } ;
+TUPLE: my-world < world ;
-: literal-merge-test-2 ( -- x ) H{ { "lil" "wayne" } } ;
 
-: literal-merge-test ( -- )
+BEFORE: my-world begin-world drop open-game-input ;
-    literal-merge-test-1
-    literal-merge-test-2 eq? t assert= ;
 
-MAIN: literal-merge-test
+AFTER: my-world end-world drop close-game-input ;
+
+: test-game-input ( -- )
+    [
+        f T{ world-attributes
+             { world-class my-world }
+             { title "Test" }
+        } open-window
+        1 seconds sleep
+        0 exit
+    ] with-ui ;
+
+MAIN: test-game-input

basis/tools/deploy/test/8/deploy.factor

@@ -1,15 +1,14 @@
 USING: tools.deploy.config ;
 H{
-    { deploy-name "tools.deploy.test.8" }
     { deploy-c-types? f }
-    { deploy-word-props? f }
-    { deploy-ui? f }
-    { deploy-reflection 1 }
-    { deploy-compiler? f }
     { deploy-unicode? f }
-    { deploy-io 1 }
     { deploy-word-defs? f }
-    { deploy-threads? f }
+    { deploy-name "tools.deploy.test.8" }
     { "stop-after-last-window?" t }
-    { deploy-math? f }
+    { deploy-reflection 1 }
+    { deploy-ui? t }
+    { deploy-math? t }
+    { deploy-io 2 }
+    { deploy-word-props? f }
+    { deploy-threads? t }
 }

basis/tools/deploy/test/9/deploy.factor

@@ -6,7 +6,6 @@ H{
     { "stop-after-last-window?" t }
     { deploy-word-defs? f }
     { deploy-reflection 1 }
-    { deploy-compiler? t }
     { deploy-threads? f }
     { deploy-io 1 }
     { deploy-math? t }

basis/ui/backend/windows/windows.factor

@@ -616,19 +616,19 @@ M: windows-ui-backend do-events
     GetDoubleClickTime milliseconds double-click-timeout set-global ;
 
 : cleanup-win32-ui ( -- )
-    class-name-ptr get-global [ dup f UnregisterClass drop free ] when*
+    class-name-ptr [ [ [ f UnregisterClass drop ] [ free ] bi ] when* f ] change-global
-    msg-obj get-global [ free ] when*
+    msg-obj [ [ free ] when* f ] change-global ;
-    f class-name-ptr set-global
-    f msg-obj set-global ;
 
-: get-dc ( world -- ) handle>> dup hWnd>> GetDC dup win32-error=0/f >>hDC drop ;
+: get-dc ( world -- )
+    handle>> dup hWnd>> GetDC dup win32-error=0/f >>hDC drop ;
 
 : get-rc ( world -- )
     handle>> dup hDC>> dup wglCreateContext dup win32-error=0/f
     [ wglMakeCurrent win32-error=0/f ] keep >>hRC drop ;
 
 : set-pixel-format ( pixel-format hdc -- )
-    swap handle>> "PIXELFORMATDESCRIPTOR" <c-object> SetPixelFormat win32-error=0/f ;
+    swap handle>>
+    "PIXELFORMATDESCRIPTOR" <c-object> SetPixelFormat win32-error=0/f ;
 
 : setup-gl ( world -- )
     [ get-dc ] keep
@@ -715,6 +715,7 @@ M: windows-ui-backend beep ( -- )
 M: windows-ui-backend (grab-input) ( handle -- )
     0 ShowCursor drop
     hWnd>> client-area>RECT ClipCursor drop ;
+
 M: windows-ui-backend (ungrab-input) ( handle -- )
     drop
     f ClipCursor drop

basis/ui/debugger/debugger.factor

@@ -0,0 +1,19 @@
+! Copyright (C) 2006, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors debugger io kernel namespaces prettyprint
+ui.gadgets.panes ui.gadgets.worlds ui ;
+IN: ui.debugger
+
+: <error-pane> ( error -- pane )
+    <pane> [ [ print-error ] with-pane ] keep ; inline
+
+: error-window ( error -- )
+    <error-pane> "Error" open-window ;
+
+[ error-window ] ui-error-hook set-global
+
+M: world-error error.
+    "An error occurred while drawing the world " write
+    dup world>> pprint-short "." print
+    "This world has been deactivated to prevent cascading errors." print
+    error>> error. ;

basis/ui/gadgets/gadgets.factor

@@ -3,8 +3,7 @@
 USING: accessors arrays hashtables kernel models math namespaces
 make sequences quotations math.vectors combinators sorting
 binary-search vectors dlists deques models threads
-concurrency.flags math.order math.rectangles fry locals
+concurrency.flags math.order math.rectangles fry locals ;
-prettyprint.backend prettyprint.custom ;
 IN: ui.gadgets
 
 ! Values for orientation slot
@@ -28,9 +27,6 @@ interior
 boundary
 model ;
 
-! Don't print gadgets with RECT: syntax
-M: gadget pprint* pprint-tuple ;
-
 M: gadget equal? 2drop f ;
 
 M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ;
@@ -397,3 +393,7 @@ M: f request-focus-on 2drop ;
 
 : focus-path ( gadget -- seq )
     [ focus>> ] follow ;
+
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [ "ui.gadgets.prettyprint" require ] when

basis/ui/gadgets/presentations/presentations.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays accessors definitions hashtables io kernel sequences
-strings words help math models namespaces quotations ui.gadgets
+strings words math models namespaces quotations ui.gadgets
 ui.gadgets.borders ui.gadgets.buttons ui.gadgets.buttons.private
 ui.gadgets.labels ui.gadgets.menus ui.gadgets.worlds
 ui.gadgets.status-bar ui.commands ui.operations ui.gestures ;

basis/ui/gadgets/prettyprint/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/ui/gadgets/prettyprint/prettyprint.factor

@@ -0,0 +1,7 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ui.gadgets prettyprint.backend prettyprint.custom ;
+IN: ui.gadgets.prettyprint
+
+! Don't print gadgets with RECT: syntax
+M: gadget pprint* pprint-tuple ;

basis/ui/gadgets/worlds/worlds-docs.factor

@@ -13,6 +13,17 @@ HELP: origin
 HELP: hand-world
 { $var-description "Global variable. The " { $link world } " containing the gadget at the mouse location." } ;
 
+HELP: grab-input
+{ $values { "gadget" gadget } }
+{ $description "Sets the " { $link world } " containing " { $snippet "gadget" } " to grab mouse and keyboard input while focused." }
+{ $notes "Normal mouse gestures may not be available while input is grabbed." } ;
+
+HELP: ungrab-input
+{ $values { "gadget" gadget } }
+{ $description "Sets the " { $link world } " containing " { $snippet "gadget" } " not to grab mouse and keyboard input while focused." } ;
+
+{ grab-input ungrab-input } related-words
+
 HELP: set-title
 { $values { "string" string } { "world" world } }
 { $description "Sets the title bar of the native window containing the world." }
@@ -42,6 +53,7 @@ HELP: world
         { { $snippet "focus" } " - the current owner of the keyboard focus in the world." }
         { { $snippet "focused?" } " - a boolean indicating if the native window containing the world has keyboard focus." }
         { { $snippet "fonts" } " - a hashtable used by the " { $link font-renderer } "." }
+        { { $snippet "grab-input?" } " - if set to " { $link t } ", the world will hide the mouse cursor and disable normal mouse input while focused. Use " { $link grab-input } " and " { $link ungrab-input } " to change this setting." }
         { { $snippet "handle" } " - a backend-specific native handle representing the native window containing the world, or " { $link f } " if the world is not grafted." }
         { { $snippet "window-loc" } " - the on-screen location of the native window containing the world. The co-ordinate system here is backend-specific." }
     }

basis/ui/gadgets/worlds/worlds.factor

@@ -4,7 +4,7 @@ USING: accessors arrays assocs continuations kernel math models
 namespaces opengl opengl.textures sequences io combinators
 combinators.short-circuit fry math.vectors math.rectangles cache
 ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
-ui.commands ui.pixel-formats destructors literals ;
+ui.commands ui.pixel-formats destructors literals strings ;
 IN: ui.gadgets.worlds
 
 CONSTANT: default-world-pixel-format-attributes
@@ -21,7 +21,7 @@ TUPLE: world < track
 TUPLE: world-attributes
     { world-class initial: world }
     grab-input?
-    title
+    { title string initial: "Factor Window" }
     status
     gadgets
     { pixel-format-attributes initial: $ default-world-pixel-format-attributes } ;
@@ -31,6 +31,20 @@ TUPLE: world-attributes
 
 : find-world ( gadget -- world/f ) [ world? ] find-parent ;
 
+: grab-input ( gadget -- )
+    find-world dup grab-input?>>
+    [ drop ] [
+        t >>grab-input?
+        dup focused?>> [ handle>> (grab-input) ] [ drop ] if
+    ] if ;
+
+: ungrab-input ( gadget -- )
+    find-world dup grab-input?>>
+    [
+        f >>grab-input?
+        dup focused?>> [ handle>> (ungrab-input) ] [ drop ] if
+    ] [ drop ] if ;
+    
 : show-status ( string/f gadget -- )
     dup find-world dup [
         dup status>> [
@@ -63,7 +77,7 @@ M: world request-focus-on ( child gadget -- )
 : new-world ( class -- world )
     vertical swap new-track
         t >>root?
-        t >>active?
+        f >>active?
         { 0 0 } >>window-loc
         f >>grab-input? ;
 
@@ -87,7 +101,7 @@ M: world layout*
     [ call-next-method ]
     [ dup layers>> [ as-big-as-possible ] with each ] bi ;
 
-M: world focusable-child* gadget-child ;
+M: world focusable-child* children>> [ t ] [ first ] if-empty ;
 
 M: world children-on nip children>> ;
 

basis/ui/gestures/gestures.factor

@@ -3,8 +3,8 @@
 USING: accessors arrays assocs kernel math math.order models
 namespaces make sequences words strings system hashtables math.parser
 math.vectors classes.tuple classes boxes calendar alarms combinators
-sets columns fry deques ui.gadgets ui.gadgets.private unicode.case
+sets columns fry deques ui.gadgets ui.gadgets.private ascii
-unicode.categories combinators.short-circuit ;
+combinators.short-circuit ;
 IN: ui.gestures
 
 GENERIC: handle-gesture ( gesture gadget -- ? )
@@ -296,10 +296,10 @@ HOOK: modifiers>string os ( modifiers -- string )
 M: macosx modifiers>string
     [
         {
-            { A+ [ "\u{place-of-interest-sign}" ] }
+            { A+ [ "\u002318" ] }
-            { M+ [ "\u{option-key}" ] }
+            { M+ [ "\u002325" ] }
-            { S+ [ "\u{upwards-white-arrow}" ] }
+            { S+ [ "\u0021e7" ] }
-            { C+ [ "\u{up-arrowhead}" ] }
+            { C+ [ "\u002303" ] }
         } case
     ] map "" join ;
 

basis/ui/operations/operations.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays definitions kernel ui.commands
 ui.gestures sequences strings math words generic namespaces
-hashtables help.markup quotations assocs fry linked-assocs ;
+hashtables quotations assocs fry linked-assocs ;
 IN: ui.operations
 
 SYMBOL: +keyboard+

basis/ui/pixel-formats/pixel-formats.factor

@@ -1,6 +1,6 @@
 USING: accessors assocs classes destructors functors kernel
 lexer math parser sequences specialized-arrays.int ui.backend
-words.symbol ;
+words ;
 IN: ui.pixel-formats
 
 SYMBOLS:
@@ -71,7 +71,7 @@ GENERIC: >PFA ( attribute -- pfas )
 
 M: object >PFA
     drop { } ;
-M: symbol >PFA
+M: word >PFA
     TABLE at [ { } ] unless* ;
 M: pixel-format-attribute >PFA
     dup class TABLE at

basis/ui/tools/debugger/debugger.factor

@@ -8,7 +8,7 @@ ui.gadgets.buttons ui.gadgets.labels ui.gadgets.panes
 ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.tables
 ui.gadgets.tracks ui.gadgets.scrollers ui.gadgets.panes
 ui.gadgets.borders ui.gadgets.status-bar ui.tools.traceback
-ui.tools.inspector ui.tools.browser ;
+ui.tools.inspector ui.tools.browser ui.debugger ;
 IN: ui.tools.debugger
 
 TUPLE: debugger < track error restarts restart-hook restart-list continuation ;
@@ -27,9 +27,6 @@ M: restart-renderer row-columns
         t >>selection-required?
         t >>single-click? ; inline
 
-: <error-pane> ( error -- pane )
-    <pane> [ [ print-error ] with-pane ] keep ; inline
-
 : <error-display> ( debugger -- gadget )
     [ <filled-pile> ] dip
     [ error>> <error-pane> add-gadget ]
@@ -72,12 +69,6 @@ M: object error-in-debugger? drop f ;
     [ rethrow ] [ error-continuation get debugger-window ] if 
 ] ui-error-hook set-global
 
-M: world-error error.
-    "An error occurred while drawing the world " write
-    dup world>> pprint-short "." print
-    "This world has been deactivated to prevent cascading errors." print
-    error>> error. ;
-
 debugger "gestures" f {
     { T{ button-down } request-focus }
 } define-command-map

basis/ui/tools/deploy/deploy.factor

@@ -29,7 +29,6 @@ TUPLE: deploy-gadget < pack vocab settings ;
 
 : advanced-settings ( parent -- parent )
     "Advanced:" <label> add-gadget
-    deploy-compiler? get "Use optimizing compiler" <checkbox> add-gadget
     deploy-math? get "Rational and complex number support" <checkbox> add-gadget
     deploy-threads? get "Threading support" <checkbox> add-gadget
     deploy-unicode? get "Unicode character literal support" <checkbox> add-gadget

basis/ui/ui-docs.factor

@@ -40,12 +40,12 @@ HELP: find-window
 { $description "Finds a native window such that the gadget passed to " { $link open-window } " satisfies the quotation, outputting " { $link f } " if no such gadget could be found. The front-most native window is checked first." } ;
 
 HELP: register-window
-{ $values { "world" world } { "handle" "a baackend-specific handle" } }
+{ $values { "world" world } { "handle" "a backend-specific handle" } }
 { $description "Adds a window to the global " { $link windows } " variable." }
 { $notes "This word should only be called by the UI backend.  User code can open new windows with " { $link open-window } "." } ;
 
 HELP: unregister-window
-{ $values { "handle" "a baackend-specific handle" } }
+{ $values { "handle" "a backend-specific handle" } }
 { $description "Removes a window from the global " { $link windows } " variable." }
 { $notes "This word should only be called only by the UI backend, and not user code." } ;
 

basis/ui/ui.factor

@@ -59,22 +59,28 @@ SYMBOL: windows
     [ ?ungrab-input ]
     [ focus-path f swap focus-gestures ] bi ;
 
-: try-to-open-window ( world -- )
+: set-up-window ( world -- )
     {
-        [ (open-window) ]
         [ handle>> select-gl-context ]
-        [
+        [ [ title>> ] keep set-title ]
         [ begin-world ]
-            [ [ handle>> (close-window) ] [ ui-error ] bi* ]
-            recover
-        ]
         [ resize-world ]
+        [ t >>active? drop ]
+        [ request-focus ]
     } cleave ;
 
+: clean-up-broken-window ( world -- )
+    [
+        dup { [ focused?>> ] [ grab-input?>> ] } 1&&
+        [ handle>> (ungrab-input) ] [ drop ] if
+    ] [ handle>> (close-window) ] bi ;
+
 M: world graft*
-    [ try-to-open-window ]
+    [ (open-window) ]
-    [ [ title>> ] keep set-title ]
+    [
-    [ request-focus ] tri ;
+        [ set-up-window ]
+        [ [ clean-up-broken-window ] [ ui-error ] bi* ] recover
+    ] bi ;
 
 : reset-world ( world -- )
     #! This is used when a window is being closed, but also

basis/urls/encoding/encoding-tests.factor

@@ -2,8 +2,8 @@ IN: urls.encoding.tests
 USING: urls.encoding tools.test arrays kernel assocs present accessors ;
 
 [ "~hello world" ] [ "%7ehello world" url-decode ] unit-test
-[ f ] [ "%XX%XX%XX" url-decode ] unit-test
+[ "" ] [ "%XX%XX%XX" url-decode ] unit-test
-[ f ] [ "%XX%XX%X" url-decode ] unit-test
+[ "" ] [ "%XX%XX%X" url-decode ] unit-test
 
 [ "hello world" ] [ "hello%20world" url-decode ] unit-test
 [ " ! "         ] [ "%20%21%20"     url-decode ] unit-test

basis/urls/urls.factor

@@ -25,12 +25,14 @@ TUPLE: url protocol username password host port path query anchor ;
     ] if ;
 
 : parse-host ( string -- host port )
+    [
         ":" split1 [ url-decode ] [
             dup [
                 string>number
                 dup [ "Invalid port" throw ] unless
             ] when
-    ] bi* ;
+        ] bi*
+    ] [ f f ] if* ;
 
 GENERIC: >url ( obj -- url )
 

basis/windows/com/com.factor

@@ -40,6 +40,6 @@ COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046}
     IUnknown::Release drop ; inline
 
 : with-com-interface ( interface quot -- )
-    over [ slip ] [ com-release ] [ ] cleanup ; inline
+    over [ com-release ] curry [ ] cleanup ; inline
 
 DESTRUCTOR: com-release

basis/windows/com/wrapper/wrapper.factor

@@ -93,7 +93,7 @@ unless
 
 : compile-alien-callback ( word return parameters abi quot -- word )
     '[ _ _ _ _ alien-callback ]
-    [ [ (( -- alien )) define-declared ] pick slip ]
+    [ [ (( -- alien )) define-declared ] pick [ call ] dip ]
     with-compilation-unit ;
 
 : (callback-word) ( function-name interface-name counter -- word )

basis/windows/dinput/constants/constants.factor

@@ -2,7 +2,7 @@ USING: windows.dinput windows.kernel32 windows.ole32 windows.com
 windows.com.syntax alien alien.c-types alien.syntax kernel system namespaces
 combinators sequences fry math accessors macros words quotations
 libc continuations generalizations splitting locals assocs init
-struct-arrays ;
+struct-arrays memoize ;
 IN: windows.dinput.constants
 
 ! Some global variables aren't provided by the DirectInput DLL (they're in the
@@ -18,12 +18,15 @@ SYMBOLS:
 
 <PRIVATE
 
+MEMO: c-type* ( name -- c-type ) c-type ;
+MEMO: heap-size* ( c-type -- n ) heap-size ;
+
 : (field-spec-of) ( field struct -- field-spec )
-    c-type fields>> [ name>> = ] with find nip ;
+    c-type* fields>> [ name>> = ] with find nip ;
 : (offsetof) ( field struct -- offset )
     [ (field-spec-of) offset>> ] [ drop 0 ] if* ;
 : (sizeof) ( field struct -- size )
-    [ (field-spec-of) type>> "[" split1 drop heap-size ] [ drop 1 ] if* ;
+    [ (field-spec-of) type>> "[" split1 drop heap-size* ] [ drop 1 ] if* ;
 
 : (flag) ( thing -- integer )
     {
@@ -79,6 +82,9 @@ SYMBOLS:
     [ nip length ] [ malloc-DIOBJECTDATAFORMAT-array ] 2bi
     "DIDATAFORMAT" <c-object> (DIDATAFORMAT) ;
 
+: initialize ( symbol quot -- )
+    call swap set-global ; inline
+
 : (malloc-guid-symbol) ( symbol guid -- )
     '[
         _ execute( -- value )

basis/xml/xml.factor

@@ -143,7 +143,7 @@ PRIVATE>
 <PRIVATE
 
 : call-under ( quot object -- quot )
-    swap dup slip ; inline
+    swap [ call ] keep ; inline
 
 : xml-loop ( quot: ( xml-elem -- ) -- )
     parse-text call-under