Merge branch 'master' into checksums

basis/alien/arrays/arrays.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.strings alien.c-types alien.accessors alien.structs
 arrays words sequences math kernel namespaces fry libc cpu.architecture
-io.encodings.utf8 io.encodings.utf16n ;
+io.encodings.utf8 ;
 IN: alien.arrays
 
 UNION: value-type array struct-type ;
@@ -95,5 +95,4 @@ M: string-type c-type-setter
 
 { "char*" utf8 } "char*" typedef
 "char*" "uchar*" typedef
-{ "char*" utf16n } "wchar_t*" typedef
 

basis/bitstreams/bitstreams-tests.factor

@@ -5,23 +5,51 @@ grouping compression.lzw multiline byte-arrays io.encodings.binary
 io.streams.byte-array ;
 IN: bitstreams.tests
 
-[ 1 t ]
-[ B{ 254 } binary <byte-reader> <bitstream-reader> read-bit ] unit-test
 
-[ 254 8 t ]
+[ BIN: 1111111111 ]
-[ B{ 254 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
-
-[ 4095 12 t ]
-[ B{ 255 255 } binary <byte-reader> <bitstream-reader> 12 swap read-bits ] unit-test
-
-[ B{ 254 } ]
 [
-    binary <byte-writer> <bitstream-writer> 254 8 rot
+    B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
-    [ write-bits ] keep stream>> >byte-array
+    2 >>byte-pos 6 >>bit-pos
+    10 swap peek
 ] unit-test
 
-[ 255 8 t ]
+[ BIN: 111111111 ]
-[ B{ 255 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
+[
+    B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+    2 >>byte-pos 6 >>bit-pos
+    9 swap peek
+] unit-test
 
-[ 255 8 f ]
+[ BIN: 11111111 ]
-[ B{ 255 } binary <byte-reader> <bitstream-reader> 9 swap read-bits ] unit-test
+[
+    B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+    2 >>byte-pos 6 >>bit-pos
+    8 swap peek
+] unit-test
+
+[ BIN: 1111111 ]
+[
+    B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+    2 >>byte-pos 6 >>bit-pos
+    7 swap peek
+] unit-test
+
+[ BIN: 111111 ]
+[
+    B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+    2 >>byte-pos 6 >>bit-pos
+    6 swap peek
+] unit-test
+
+[ BIN: 11111 ]
+[
+    B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+    2 >>byte-pos 6 >>bit-pos
+    5 swap peek
+] unit-test
+
+[ B{ } <msb0-bit-reader> 5 swap peek ] must-fail
+[ B{ } <msb0-bit-reader> 1 swap peek ] must-fail
+[ B{ } <msb0-bit-reader> 8 swap peek ] must-fail
+
+[ 0 ] [ B{ } <msb0-bit-reader> 0 swap peek ] unit-test

basis/bitstreams/bitstreams.factor

@@ -1,96 +1,160 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors byte-arrays destructors fry io kernel locals
+USING: accessors alien.accessors assocs byte-arrays combinators
-math sequences ;
+constructors destructors fry io io.binary io.encodings.binary
+io.streams.byte-array kernel locals macros math math.ranges
+multiline sequences sequences.private vectors byte-vectors
+combinators.short-circuit math.bitwise ;
 IN: bitstreams
 
-TUPLE: bitstream stream end-of-stream? current-bits #bits disposed ;
+TUPLE: widthed { bits integer read-only } { #bits integer read-only } ;
-TUPLE: bitstream-reader < bitstream ;
 
-: reset-bitstream ( stream -- stream )
+ERROR: invalid-widthed bits #bits ;
-    0 >>#bits 0 >>current-bits ; inline
 
-: new-bitstream ( stream class -- bitstream )
+: check-widthed ( bits #bits -- bits #bits )
+    dup 0 < [ invalid-widthed ] when
+    2dup { [ nip 0 = ] [ drop 0 = not ] } 2&& [ invalid-widthed ] when
+    over 0 = [
+        2dup [ dup 0 < [ neg ] when log2 1 + ] dip > [ invalid-widthed ] when
+    ] unless ;
+
+: <widthed> ( bits #bits -- widthed )
+    check-widthed
+    widthed boa ;
+
+: zero-widthed ( -- widthed ) 0 0 <widthed> ;
+: zero-widthed? ( widthed -- ? ) zero-widthed = ;
+
+TUPLE: bit-reader
+    { bytes byte-array }
+    { byte-pos array-capacity initial: 0 }
+    { bit-pos array-capacity initial: 0 } ;
+
+TUPLE: bit-writer
+    { bytes byte-vector }
+    { widthed widthed } ;
+
+TUPLE: msb0-bit-reader < bit-reader ;
+TUPLE: lsb0-bit-reader < bit-reader ;
+CONSTRUCTOR: msb0-bit-reader ( bytes -- bs ) ;
+CONSTRUCTOR: lsb0-bit-reader ( bytes -- bs ) ;
+
+TUPLE: msb0-bit-writer < bit-writer ;
+TUPLE: lsb0-bit-writer < bit-writer ;
+
+: new-bit-writer ( class -- bs )
     new
-        swap >>stream
+        BV{ } clone >>bytes
-        reset-bitstream ; inline
+        0 0 <widthed> >>widthed ; inline
 
-M: bitstream-reader dispose ( stream -- )
+: <msb0-bit-writer> ( -- bs )
-    stream>> dispose ;
+    msb0-bit-writer new-bit-writer ;
 
-: <bitstream-reader> ( stream -- bitstream )
+: <lsb0-bit-writer> ( -- bs )
-    bitstream-reader new-bitstream ; inline
+    lsb0-bit-writer new-bit-writer ;
 
-: read-next-byte ( bitstream -- bitstream )
+GENERIC: peek ( n bitstream -- value )
-    dup stream>> stream-read1 [
+GENERIC: poke ( value n bitstream -- )
-        >>current-bits 8 >>#bits
+
+: seek ( n bitstream -- )
+    {
+        [ byte-pos>> 8 * ]
+        [ bit-pos>> + + 8 /mod ]
+        [ (>>bit-pos) ]
+        [ (>>byte-pos) ]
+    } cleave ; inline
+
+: read ( n bitstream -- value )
+    [ peek ] [ seek ] 2bi ; inline
+
+<PRIVATE
+
+ERROR: not-enough-bits widthed n ;
+
+: widthed-bits ( widthed n -- bits )
+    dup 0 < [ not-enough-bits ] when
+    2dup [ #bits>> ] dip < [ not-enough-bits ] when
+    [ [ bits>> ] [ #bits>> ] bi ] dip
+    [ - neg shift ] keep <widthed> ;
+
+: split-widthed ( widthed n -- widthed1 widthed2 )
+    2dup [ #bits>> ] dip < [
+        drop zero-widthed
     ] [
-        0 >>#bits
+        [ widthed-bits ]
-        t >>end-of-stream?
+        [ [ [ bits>> ] [ #bits>> ] bi ] dip - [ bits ] keep <widthed> ] 2bi
-    ] if* ;
-
-: maybe-read-next-byte ( bitstream -- bitstream )
-    dup #bits>> 0 = [ read-next-byte ] when ; inline
-
-: shift-one-bit ( bitstream -- n )
-    [ current-bits>> ] [ #bits>> ] bi 1- neg shift 1 bitand ; inline
-
-: next-bit ( bitstream -- n/f ? )
-    maybe-read-next-byte
-    dup end-of-stream?>> [
-        drop f
-    ] [
-        [ shift-one-bit ]
-        [ [ 1- ] change-#bits maybe-read-next-byte drop ] bi
-    ] if dup >boolean ;
-
-: read-bit ( bitstream -- n ? )
-    dup #bits>> 1 = [
-        [ current-bits>> 1 bitand ]
-        [ read-next-byte drop ] bi t
-    ] [
-        next-bit
-    ] if ; inline
-
-: bits>integer ( seq -- n )
-    0 [ [ 1 shift ] dip bitor ] reduce ; inline
-
-: read-bits ( width bitstream -- n width ? )
-    [
-        '[ _ read-bit drop ] replicate
-        [ f = ] trim-tail
-        [ bits>integer ] [ length ] bi
-    ] 2keep drop over = ;
-
-TUPLE: bitstream-writer < bitstream ;
-
-: <bitstream-writer> ( stream -- bitstream )
-    bitstream-writer new-bitstream ; inline
-
-: write-bit ( n bitstream -- )
-    [ 1 shift bitor ] change-current-bits
-    [ 1+ ] change-#bits
-    dup #bits>> 8 = [
-        [ [ current-bits>> ] [ stream>> stream-write1 ] bi ]
-        [ reset-bitstream drop ] bi
-    ] [
-        drop
-    ] if ; inline
-
-ERROR: invalid-bit-width n ;
-
-:: write-bits ( n width bitstream -- )
-    n 0 < [ n invalid-bit-width ] when
-    n 0 = [
-        width [ 0 bitstream write-bit ] times
-    ] [
-        width n log2 1+ dup :> n-length - [ 0 bitstream write-bit ] times
-        n-length [
-            n-length swap - 1- neg n swap shift 1 bitand
-            bitstream write-bit
-        ] each
     ] if ;
 
-: flush-bits ( bitstream -- ) stream>> stream-flush ;
+: widthed>bytes ( widthed -- bytes widthed )
+    [ 8 split-widthed dup zero-widthed? not ]
+    [ swap bits>> ] B{ } produce-as nip swap ;
 
-: bitstream-output ( bitstream -- bytes ) stream>> >byte-array ;
+:: |widthed ( widthed1 widthed2 -- widthed3 )
+    widthed1 bits>> :> bits1
+    widthed1 #bits>> :> #bits1
+    widthed2 bits>> :> bits2
+    widthed2 #bits>> :> #bits2
+    bits1 #bits2 shift bits2 bitor
+    #bits1 #bits2 + <widthed> ;
+
+PRIVATE>
+
+M:: lsb0-bit-writer poke ( value n bs -- )
+    value n <widthed> :> widthed
+    widthed
+    bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte
+    byte bs widthed>> |widthed :> new-byte
+    new-byte #bits>> 8 = [
+        new-byte bits>> bs bytes>> push
+        zero-widthed bs (>>widthed)
+        remainder widthed>bytes
+        [ bs bytes>> push-all ] [ bs (>>widthed) ] bi*
+    ] [
+        byte bs (>>widthed)
+    ] if ;
+
+: enough-bits? ( n bs -- ? )
+    [ bytes>> length ]
+    [ byte-pos>> - 8 * ]
+    [ bit-pos>> - ] tri <= ;
+
+ERROR: not-enough-bits n bit-reader ;
+
+: #bits>#bytes ( #bits -- #bytes )
+    8 /mod 0 = [ 1 + ] unless ; inline
+
+:: subseq>bits-le ( bignum n bs -- bits )
+    bignum bs bit-pos>> neg shift n bits ;
+
+:: subseq>bits-be ( bignum n bs -- bits )
+    bignum 
+    8 bs bit-pos>> - n - 8 mod dup 0 < [ 8 + ] when
+    neg shift n bits ;
+
+:: adjust-bits ( n bs -- )
+    n 8 /mod :> #bits :> #bytes
+    bs [ #bytes + ] change-byte-pos
+    bit-pos>> #bits + dup 8 >= [
+        8 - bs (>>bit-pos)
+        bs [ 1 + ] change-byte-pos drop
+    ] [
+        bs (>>bit-pos)
+    ] if ;
+
+:: (peek) ( n bs endian> subseq-endian -- bits )
+    n bs enough-bits? [ n bs not-enough-bits ] unless
+    bs [ byte-pos>> ] [ bit-pos>> n + ] bi #bits>#bytes dupd +
+    bs bytes>> subseq endian> execute( seq -- x ) :> bignum
+    bignum n bs subseq-endian execute( bignum n bs -- bits ) ;
+
+M: lsb0-bit-reader peek ( n bs -- bits ) \ le> \ subseq>bits-le (peek) ;
+
+M: msb0-bit-reader peek ( n bs -- bits ) \ be> \ subseq>bits-be (peek) ;
+
+:: bit-writer-bytes ( writer -- bytes )
+    writer widthed>> #bits>> :> n
+    n 0 = [
+        writer widthed>> bits>> 8 n - shift
+        writer bytes>> swap push
+    ] unless
+    writer bytes>> ;

basis/bootstrap/image/image.factor

@@ -448,7 +448,6 @@ M: quotation '
         array>> '
         quotation [
             emit ! array
-            f ' emit ! compiled
             f ' emit ! cached-effect
             f ' emit ! cache-counter
             0 emit ! xt

basis/bootstrap/stage2.factor

@@ -12,6 +12,16 @@ SYMBOL: core-bootstrap-time
 
 SYMBOL: bootstrap-time
 
+: strip-encodings ( -- )
+    os unix? [
+        [
+            P" resource:core/io/encodings/utf16/utf16.factor" 
+            P" resource:core/io/encodings/utf16n/utf16n.factor" [ forget ] bi@
+            "io.encodings.utf16" 
+            "io.encodings.utf16n" [ child-vocabs [ forget-vocab ] each ] bi@
+        ] with-compilation-unit
+    ] when ;
+
 : default-image-name ( -- string )
     vm file-name os windows? [ "." split1-last drop ] when
     ".image" append resource-path ;
@@ -55,6 +65,8 @@ SYMBOL: bootstrap-time
     "math compiler threads help io tools ui ui.tools unicode handbook" "include" set-global
     "" "exclude" set-global
 
+    strip-encodings
+
     (command-line) parse-command-line
 
     ! Set dll paths

basis/circular/circular-docs.factor

@@ -43,6 +43,11 @@ HELP: push-growing-circular
      { "elt" object } { "circular" circular } }
 { $description "Pushes an element onto a " { $link growing-circular } " object." } ;
 
+HELP: rotate-circular
+{ $values
+    { "circular" circular } }
+{ $description "Advances the start index of a circular object by one." } ;
+
 ARTICLE: "circular" "Circular sequences"
 "The " { $vocab-link "circular" } " vocabulary implements the " { $link "sequence-protocol" } " to allow an arbitrary start index and wrap-around indexing." $nl
 "Creating a new circular object:"
@@ -51,6 +56,7 @@ ARTICLE: "circular" "Circular sequences"
 { $subsection <growing-circular> }
 "Changing the start index:"
 { $subsection change-circular-start }
+{ $subsection rotate-circular }
 "Pushing new elements:"
 { $subsection push-circular }
 { $subsection push-growing-circular } ;

basis/circular/circular-tests.factor

@@ -12,6 +12,7 @@ circular strings ;
 [ CHAR: e ] [ "test" <circular> 5 swap nth-unsafe ] unit-test
  
 [ [ 1 2 3 ] ] [ { 1 2 3 } <circular> [ ] like ] unit-test
+[ [ 2 3 1 ] ] [ { 1 2 3 } <circular> [ rotate-circular ] keep [ ] like ] unit-test
 [ [ 2 3 1 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start [ ] like ] unit-test
 [ [ 3 1 2 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start 1 over change-circular-start [ ] like ] unit-test
 [ [ 3 1 2 ] ] [ { 1 2 3 } <circular> -100 over change-circular-start [ ] like ] unit-test

basis/circular/circular.factor

@@ -27,6 +27,9 @@ M: circular virtual-seq seq>> ;
     #! change start to (start + n) mod length
     circular-wrap (>>start) ;
 
+: rotate-circular ( circular -- )
+    [ start>> 1 + ] keep circular-wrap (>>start) ;
+
 : push-circular ( elt circular -- )
     [ set-first ] [ 1 swap change-circular-start ] bi ;
 

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/combinators/smart/smart.factor

@@ -11,8 +11,8 @@ MACRO: output>sequence ( quot exemplar -- newquot )
     [ dup infer out>> ] dip
     '[ @ _ _ nsequence ] ;
 
-: output>array ( quot -- newquot )
+MACRO: output>array ( quot -- newquot )
-    { } output>sequence ; inline
+    '[ _ { } output>sequence ] ;
 
 MACRO: input<sequence ( quot -- newquot )
     [ infer in>> ] keep
@@ -25,8 +25,8 @@ MACRO: input<sequence-unsafe ( quot -- newquot )
 MACRO: reduce-outputs ( quot operation -- newquot )
     [ dup infer out>> 1 [-] ] dip n*quot compose ;
 
-: sum-outputs ( quot -- n )
+MACRO: sum-outputs ( quot -- n )
-    [ + ] reduce-outputs ; inline
+    '[ _ [ + ] reduce-outputs ] ;
 
 MACRO: map-reduce-outputs ( quot mapper reducer -- newquot )
     [ dup infer out>> ] 2dip
@@ -37,5 +37,5 @@ MACRO: map-reduce-outputs ( quot mapper reducer -- newquot )
 MACRO: append-outputs-as ( quot exemplar -- newquot )
     [ dup infer out>> ] dip '[ @ _ _ nappend-as ] ;
 
-: append-outputs ( quot -- seq )
+MACRO: append-outputs ( quot -- seq )
-    { } append-outputs-as ; inline
+    '[ _ { } append-outputs-as ] ;

basis/compiler/constants/constants.factor

@@ -20,7 +20,7 @@ CONSTANT: deck-bits 18
 : underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline
 : tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
 : word-xt-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
-: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline
+: quot-xt-offset ( -- n ) 4 bootstrap-cells quotation tag-number - ; inline
 : word-code-offset ( -- n ) 11 bootstrap-cells \ word tag-number - ; inline
 : array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline
 : compiled-header-size ( -- n ) 4 bootstrap-cells ; inline

basis/compiler/tests/optimizer.factor

@@ -396,3 +396,19 @@ DEFER: loop-bbb
 
 [ 1 ] [ 257 modular-arithmetic-bug ] unit-test
 [ -10 ] [ -10 modular-arithmetic-bug ] unit-test
+
+! Optimizer needs to ignore invalid generics
+GENERIC# bad-dispatch-position-test* 3 ( -- )
+
+M: object bad-dispatch-position-test* ;
+
+: bad-dispatch-position-test ( -- ) bad-dispatch-position-test* ;
+
+[ 1 2 3 4 bad-dispatch-position-test ] must-fail
+
+[ ] [
+    [
+        \ bad-dispatch-position-test forget
+        \ bad-dispatch-position-test* forget
+    ] with-compilation-unit
+] unit-test

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

@@ -59,9 +59,11 @@ M: callable splicing-nodes splicing-body ;
 
 : inlining-standard-method ( #call word -- class/f method/f )
     dup "methods" word-prop assoc-empty? [ 2drop f f ] [
+        2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [
             [ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
             [ swap nth value-info class>> dup ] dip
             specific-method
+        ] if
     ] if ;
 
 : inline-standard-method ( #call word -- ? )

basis/compression/huffman/huffman.factor

@@ -0,0 +1,88 @@
+! Copyright (C) 2009 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs constructors fry
+hashtables io kernel locals math math.order math.parser
+math.ranges multiline sequences ;
+IN: compression.huffman
+
+QUALIFIED-WITH: bitstreams bs
+
+<PRIVATE
+
+! huffman codes
+
+TUPLE: huffman-code
+    { value }
+    { size }
+    { code } ;
+
+: <huffman-code> ( -- code ) 0 0 0 huffman-code boa ;
+: next-size ( code -- ) [ 1+ ] change-size [ 2 * ] change-code drop ;
+: next-code ( code -- ) [ 1+ ] change-code drop ;
+
+:: all-patterns ( huff n -- seq )
+    n log2 huff size>> - :> free-bits
+    free-bits 0 >
+    [ free-bits 2^ [0,b) [ huff code>> free-bits 2^ * + ] map ]
+    [ huff code>> free-bits neg 2^ /i 1array ] if ;
+
+:: huffman-each ( tdesc quot: ( huff -- ) -- )
+    <huffman-code> :> code
+    tdesc
+    [
+        code next-size
+        [ code (>>value) code clone quot call code next-code ] each
+    ] each ; inline
+
+: update-reverse-table ( huff n table -- )
+    [ drop all-patterns ]
+    [ nip '[ _ swap _ set-at ] each ] 3bi ;
+
+:: reverse-table ( tdesc n -- rtable )
+   n f <array> <enum> :> table
+   tdesc [ n table update-reverse-table ] huffman-each
+   table seq>> ;
+
+:: huffman-table ( tdesc max -- table )
+   max f <array> :> table
+   tdesc [ [ ] [ value>> ] bi table set-nth ] huffman-each
+   table ;
+
+PRIVATE>
+
+! decoder
+
+TUPLE: huffman-decoder
+    { bs }
+    { tdesc }
+    { rtable }
+    { bits/level } ;
+
+CONSTRUCTOR: huffman-decoder ( bs tdesc -- decoder )
+    16 >>bits/level
+    [ ] [ tdesc>> ] [ bits/level>> 2^ ] tri reverse-table >>rtable ;
+
+: read1-huff ( decoder -- elt )
+    16 over [ bs>> bs:peek ] [ rtable>> nth ] bi ! first/last
+    [ size>> swap bs>> bs:seek ] [ value>> ] bi ;
+
+! %remove
+: reverse-bits ( value bits -- value' )
+    [ >bin ] [ CHAR: 0 pad-head <reversed> bin> ] bi* ;
+
+: read1-huff2 ( decoder -- elt )
+    16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi ! first/last
+    [ size>> swap bs>> bs:seek ] [ value>> ] bi ;
+
+/*
+: huff>string ( code -- str )
+    [ value>> number>string ]
+    [ [ code>> ] [ size>> bits>string ] bi ] bi
+    " = " glue ;
+
+: huff. ( code -- ) huff>string print ;
+
+:: rtable. ( rtable -- )
+    rtable length>> log2 :> n
+    rtable <enum> [ swap n bits. [ huff. ] each ] assoc-each ;
+*/

basis/compression/inflate/inflate.factor

@@ -0,0 +1,211 @@
+! Copyright (C) 2009 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs byte-arrays
+byte-vectors combinators constructors fry grouping hashtables
+compression.huffman images io.binary kernel locals
+math math.bitwise math.order math.ranges multiline sequences
+sorting ;
+IN: compression.inflate
+
+QUALIFIED-WITH: bitstreams bs
+
+<PRIVATE
+
+: enum>seq ( assoc -- seq )
+    dup keys [ ] [ max ] map-reduce 1 + f <array>
+    [ '[ swap _ set-nth ] assoc-each ] keep ;
+
+ERROR: zlib-unimplemented ;
+ERROR: bad-zlib-data ;
+ERROR: bad-zlib-header ;
+    
+:: check-zlib-header ( data -- )
+    16 data bs:peek 2 >le be> 31 mod    ! checksum
+    0 assert=                           
+    4 data bs:read 8 assert=            ! compression method: deflate
+    4 data bs:read                      ! log2(max length)-8, 32K max
+    7 <= [ bad-zlib-header ] unless     
+    5 data bs:seek                      ! drop check bits 
+    1 data bs:read 0 assert=            ! dictionnary - not allowed in png
+    2 data bs:seek                      ! compression level; ignore
+    ;
+
+:: default-table ( -- table )
+    0 <hashtable> :> table
+    0 143 [a,b] 280 287 [a,b] append 8 table set-at
+    144 255 [a,b] >array 9 table set-at
+    256 279 [a,b] >array 7 table set-at 
+    table enum>seq 1 tail ;
+
+CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }
+
+: get-table ( values size -- table ) 
+    16 f <array> clone <enum> 
+    [ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ;
+
+:: decode-huffman-tables ( bitstream -- tables )
+    5 bitstream bs:read 257 +
+    5 bitstream bs:read 1 +
+    4 bitstream bs:read 4 +
+    clen-shuffle swap head
+    dup [ drop 3 bitstream bs:read ] map
+    get-table
+    bitstream swap <huffman-decoder> 
+    [ 2dup + ] dip swap :> k!
+    '[
+        _ read1-huff2
+        {
+            { [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] }
+            { [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] }
+            { [ dup 18 = ] [ 7 bitstream bs:read 11 + 2array ] }
+            [ ]
+        } cond
+        dup array? [ dup second ] [ 1 ] if
+        k swap - dup k! 0 >
+    ] 
+    [ ] produce swap suffix
+    { } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1+ swap <repetition> append ] bi* ] [ suffix ] if ] reduce
+    [ dup array? [ second 0 <repetition> ] [ 1array ] if ] map concat
+    nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ;
+    
+CONSTANT: length-table
+    {
+        3 4 5 6 7 8 9 10
+        11 13 15 17
+        19 23 27 31
+        35 43 51 59
+        67 83 99 115
+        131 163 195 227
+    }
+
+CONSTANT: dist-table
+    { 1 2 3 4 
+      5 7 9 13 
+      17 25 33 49
+      65 97 129 193
+      257 385 513 769
+      1025 1537 2049 3073
+      4097 6145 8193 12289
+      16385 24577 }
+
+: nth* ( n seq -- elt )
+    [ length 1- swap - ] [ nth ] bi ;
+
+:: inflate-lz77 ( seq -- bytes )
+    1000 <byte-vector> :> bytes
+    seq
+    [
+        dup array?
+        [ first2 '[ _ 1- bytes nth* bytes push ] times ]
+        [ bytes push ] if
+    ] each 
+    bytes ;
+
+:: inflate-dynamic ( bitstream -- bytes )
+    bitstream decode-huffman-tables
+    bitstream '[ _ swap <huffman-decoder> ] map :> tables
+    [
+        tables first read1-huff2
+        dup 256 >
+        [
+            dup 285 = 
+            [ ]
+            [ 
+                dup 264 > 
+                [ 
+                    dup 261 - 4 /i dup 5 > 
+                    [ bad-zlib-data ] when 
+                    bitstream bs:read 2array 
+                ]
+                when 
+            ] if
+            ! 5 bitstream read-bits ! distance
+            tables second read1-huff2
+            dup 3 > 
+            [ 
+                dup 2 - 2 /i dup 13 >
+                [ bad-zlib-data ] when
+                bitstream bs:read 2array
+            ] 
+            when
+            2array
+        ]
+        when
+        dup 256 = not
+    ]
+    [ ] produce nip
+    [
+        dup array? [
+            first2
+            [  
+                dup array? [ first2 ] [ 0 ] if
+                [ 257 - length-table nth ] [ + ] bi*
+            ] 
+            [
+                dup array? [ first2 ] [ 0 ] if
+                [ dist-table nth ] [ + ] bi*
+            ] bi*
+            2array
+        ] when
+    ] map ;
+    
+: inflate-raw ( bitstream -- bytes ) zlib-unimplemented ;
+: inflate-static ( bitstream -- bytes ) zlib-unimplemented ;
+
+:: inflate-loop ( bitstream -- bytes )
+    [ 1 bitstream bs:read 0 = ]
+    [
+        bitstream
+        2 bitstream bs:read ! B
+        { 
+            { 0 [ inflate-raw ] }
+            { 1 [ inflate-static ] }
+            { 2 [ inflate-dynamic ] }
+            { 3 [ bad-zlib-data f ] }
+        }
+        case
+    ]
+    [ produce ] keep call suffix concat ;
+    
+  !  [ produce ] keep dip swap suffix
+
+:: paeth ( a b c -- p ) 
+    a b + c - { a b c } [ [ - abs ] keep 2array ] with map 
+    sort-keys first second ;
+    
+:: png-unfilter-line ( prev curr filter -- curr' )
+    prev :> c
+    prev 3 tail-slice :> b
+    curr :> a
+    curr 3 tail-slice :> x
+    x length [0,b)
+    filter
+    {
+        { 0 [ drop ] }
+        { 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
+        { 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
+        { 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
+        { 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
+        
+    } case 
+    curr 3 tail ;
+
+PRIVATE>
+
+! for debug -- shows residual values
+: reverse-png-filter' ( lines -- filtered )
+    [ first ] [ 1 tail ] [ map ] bi-curry@ bi nip
+    concat [ 128 + 256 wrap ] map ;
+    
+: reverse-png-filter ( lines -- filtered )
+    dup first [ 0 ] replicate prefix
+    [ { 0 0 } prepend  ] map
+    2 clump [
+        first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line
+    ] map concat ;
+
+: zlib-inflate ( bytes -- bytes )
+    bs:<lsb0-bit-reader>
+    [ check-zlib-header ]
+    [ inflate-loop ] bi
+    inflate-lz77 ;

basis/compression/lzw/lzw.factor

@@ -1,20 +1,19 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs bitstreams byte-vectors combinators io
+USING: accessors alien.accessors assocs byte-arrays combinators
 io.encodings.binary io.streams.byte-array kernel math sequences
 vectors ;
 IN: compression.lzw
 
+QUALIFIED-WITH: bitstreams bs
+
 CONSTANT: clear-code 256
 CONSTANT: end-of-information 257
 
-TUPLE: lzw input output end-of-input? table count k omega omega-k #bits
+TUPLE: lzw input output table code old-code ;
-code old-code ;
 
 SYMBOL: table-full
 
-ERROR: index-too-big n ;
-
 : lzw-bit-width ( n -- n' )
     {
         { [ dup 510 <= ] [ drop 9 ] }
@@ -24,36 +23,14 @@ ERROR: index-too-big n ;
         [ drop table-full ]
     } cond ;
 
-: lzw-bit-width-compress ( lzw -- n )
-    count>> lzw-bit-width ;
-
 : lzw-bit-width-uncompress ( lzw -- n )
     table>> length lzw-bit-width ;
 
-: initial-compress-table ( -- assoc )
-    258 iota [ [ 1vector ] keep ] H{ } map>assoc ;
-
 : initial-uncompress-table ( -- seq )
     258 iota [ 1vector ] V{ } map-as ;
 
-: reset-lzw ( lzw -- lzw )
-    257 >>count
-    V{ } clone >>omega
-    V{ } clone >>omega-k
-    9 >>#bits ;
-
-: reset-lzw-compress ( lzw -- lzw )
-    f >>k
-    initial-compress-table >>table reset-lzw ;
-
 : reset-lzw-uncompress ( lzw -- lzw )
-    initial-uncompress-table >>table reset-lzw ;
+    initial-uncompress-table >>table ;
-
-: <lzw-compress> ( input -- obj )
-    lzw new
-        swap >>input
-        binary <byte-writer> <bitstream-writer> >>output
-        reset-lzw-compress ;
 
 : <lzw-uncompress> ( input -- obj )
     lzw new
@@ -61,79 +38,8 @@ ERROR: index-too-big n ;
         BV{ } clone >>output
         reset-lzw-uncompress ;
 
-: push-k ( lzw -- lzw )
-    [ ]
-    [ k>> ]
-    [ omega>> clone [ push ] keep ] tri >>omega-k ;
-
-: omega-k-in-table? ( lzw -- ? )
-    [ omega-k>> ] [ table>> ] bi key? ;
-
 ERROR: not-in-table value ;
 
-: write-output ( lzw -- )
-    [
-        [ omega>> ] [ table>> ] bi ?at [ not-in-table ] unless
-    ] [
-        [ lzw-bit-width-compress ]
-        [ output>> write-bits ] bi
-    ] bi ;
-
-: omega-k>omega ( lzw -- lzw )
-    dup omega-k>> clone >>omega ;
-
-: k>omega ( lzw -- lzw )
-    dup k>> 1vector >>omega ;
-
-: add-omega-k ( lzw -- )
-    [ [ 1+ ] change-count count>> ]
-    [ omega-k>> clone ]
-    [ table>> ] tri set-at ;
-
-: lzw-compress-char ( lzw k -- )
-    >>k push-k dup omega-k-in-table? [
-        omega-k>omega drop
-    ] [
-        [ write-output ]
-        [ add-omega-k ]
-        [ k>omega drop ] tri
-    ] if ;
-
-: (lzw-compress-chars) ( lzw -- )
-    dup lzw-bit-width-compress table-full = [
-        drop
-    ] [
-        dup input>> stream-read1
-        [ [ lzw-compress-char ] [ drop (lzw-compress-chars) ] 2bi ]
-        [ t >>end-of-input? drop ] if*
-    ] if ;
-
-: lzw-compress-chars ( lzw -- )
-    {
-        ! [ [ clear-code lzw-compress-char ] [ drop ] bi ] ! reset-lzw-compress drop ] bi ]
-        [
-            [ clear-code ] dip
-            [ lzw-bit-width-compress ]
-            [ output>> write-bits ] bi
-        ]
-        [ (lzw-compress-chars) ]
-        [
-            [ k>> ]
-            [ lzw-bit-width-compress ]
-            [ output>> write-bits ] tri
-        ]
-        [
-            [ end-of-information ] dip
-            [ lzw-bit-width-compress ]
-            [ output>> write-bits ] bi
-        ]
-        [ ]
-    } cleave dup end-of-input?>> [ drop ] [ lzw-compress-chars ] if ;
-
-: lzw-compress ( byte-array -- seq )
-    binary <byte-reader> <lzw-compress>
-    [ lzw-compress-chars ] [ output>> stream>> ] bi ;
-
 : lookup-old-code ( lzw -- vector )
     [ old-code>> ] [ table>> ] bi nth ;
 
@@ -152,7 +58,7 @@ ERROR: not-in-table value ;
 : add-to-table ( seq lzw -- ) table>> push ;
 
 : lzw-read ( lzw -- lzw n )
-    [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri read-bits 2drop ;
+    [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri bs:read ;
 
 DEFER: lzw-uncompress-char
 : handle-clear-code ( lzw -- )
@@ -200,5 +106,6 @@ DEFER: lzw-uncompress-char
     ] if* ;
 
 : lzw-uncompress ( seq -- byte-array )
-    binary <byte-reader> <bitstream-reader>
+    bs:<msb0-bit-reader>
-    <lzw-uncompress> [ lzw-uncompress-char ] [ output>> ] bi ;
+    <lzw-uncompress>
+    [ lzw-uncompress-char ] [ output>> ] bi ;

basis/core-graphics/core-graphics.factor

@@ -110,10 +110,14 @@ FUNCTION: CGDirectDisplayID CGMainDisplayID ( ) ;
 FUNCTION: CGError CGDisplayHideCursor ( CGDirectDisplayID display ) ;
 FUNCTION: CGError CGDisplayShowCursor ( CGDirectDisplayID display ) ;
 
+FUNCTION: CGError CGDisplayMoveCursorToPoint ( CGDirectDisplayID display, CGPoint point ) ;
+
 FUNCTION: CGError CGAssociateMouseAndMouseCursorPosition ( boolean_t connected ) ;
 
 FUNCTION: CGError CGWarpMouseCursorPosition ( CGPoint newCursorPosition ) ;
 
+FUNCTION: uint GetCurrentButtonState ( ) ;
+
 <PRIVATE
 
 : bitmap-flags ( -- flags )

basis/editors/gvim/gvim.factor

@@ -11,7 +11,10 @@ SINGLETON: gvim
 HOOK: gvim-path io-backend ( -- path )
 
 M: gvim vim-command ( file line -- string )
-    [ gvim-path , "+" swap number>string append , , ] { } make ;
+    [
+        gvim-path ,
+        number>string "+" prepend , ,
+    ] { } make ;
 
 gvim vim-editor set-global
 

basis/editors/macvim/macvim.factor

@@ -3,11 +3,9 @@ namespaces prettyprint editors make ;
 
 IN: editors.macvim
 
-: macvim-location ( file line -- )
+: macvim ( file line -- )
     drop
     [ "open" , "-a" , "MacVim", , ] { } make
-    try-process ;
+    run-detached drop ;
-
-[ macvim-location ] edit-hook set-global
-
 
+[ macvim ] edit-hook set-global

basis/editors/scite/scite.factor

@@ -25,7 +25,7 @@ IN: editors.scite
         number>string "-goto:" prepend ,
     ] { } make ;
 
-: scite-location ( file line -- )
+: scite ( file line -- )
     scite-command run-detached drop ;
 
-[ scite-location ] edit-hook set-global
+[ scite ] edit-hook set-global

basis/editors/textedit/textedit.factor

@@ -2,9 +2,9 @@ USING: definitions io.launcher kernel math math.parser parser
 namespaces prettyprint editors make ;
 IN: editors.textedit
 
-: textedit-location ( file line -- )
+: textedit ( file line -- )
     drop
     [ "open" , "-a" , "TextEdit", , ] { } make
-    try-process ;
+    run-detached drop ;
 
-[ textedit-location ] edit-hook set-global
+[ textedit ] edit-hook set-global

basis/editors/textmate/textmate.factor

@@ -1,10 +1,9 @@
 USING: definitions io.launcher kernel math math.parser parser
 namespaces prettyprint editors make ;
-
 IN: editors.textmate
 
-: textmate-location ( file line -- )
+: textmate ( file line -- )
     [ "mate" , "-a" , "-l" , number>string , , ] { } make
-    try-process ;
+    run-detached drop ;
 
-[ textmate-location ] edit-hook set-global
+[ textmate ] edit-hook set-global

basis/editors/vim/vim-docs.factor

@@ -3,7 +3,7 @@ USING: definitions editors help help.markup help.syntax io io.files
 IN: editors.vim
 
 ARTICLE: { "vim" "vim" } "Vim support"
-"This module makes the " { $link edit } " word work with Vim by setting the " { $link edit-hook } " global variable to call " { $link vim-location } ". The " { $link vim-path } " variable contains the name of the vim executable.  The default " { $link vim-path } " is " { $snippet "\"gvim\"" } "."
+"This module makes the " { $link edit } " word work with Vim by setting the " { $link edit-hook } " global variable to call " { $link vim } ". The " { $link vim-path } " variable contains the name of the vim executable.  The default " { $link vim-path } " is " { $snippet "\"gvim\"" } "."
 $nl
 "If you intend to use this module regularly, it helps to have it load during stage 2 bootstrap. On Windows, place the following example " { $snippet ".factor-boot-rc" } " in the directory returned by " { $link home } ":"
 { $code

basis/editors/vim/vim.factor

@@ -4,7 +4,6 @@ make ;
 IN: editors.vim
 
 SYMBOL: vim-path
-
 SYMBOL: vim-editor
 HOOK: vim-command vim-editor ( file line -- array )
 
@@ -12,12 +11,13 @@ SINGLETON: vim
 
 M: vim vim-command
     [
-        vim-path get , swap , "+" swap number>string append ,
+        vim-path get ,
+        [ , ] [ number>string "+" prepend , ] bi*
     ] { } make ;
 
-: vim-location ( file line -- )
+: vim ( file line -- )
-    vim-command try-process ;
+    vim-command run-detached drop ;
 
 "vim" vim-path set-global
-[ vim-location ] edit-hook set-global
+[ vim ] edit-hook set-global
-vim vim-editor set-global
+\ vim vim-editor set-global

basis/game-input/game-input-tests.factor

@@ -0,0 +1,8 @@
+IN: game-input.tests
+USING: ui game-input tools.test kernel system threads calendar ;
+
+os windows? os macosx? or [
+    [ ] [ open-game-input ] unit-test
+    [ ] [ 1 seconds sleep ] unit-test
+    [ ] [ close-game-input ] unit-test
+] when

basis/game-input/iokit/iokit.factor

@@ -3,7 +3,7 @@ kernel cocoa.enumeration destructors math.parser cocoa.application
 sequences locals combinators.short-circuit threads
 namespaces assocs vectors arrays combinators hints alien
 core-foundation.run-loop accessors sequences.private
-alien.c-types math parser game-input vectors ;
+alien.c-types math parser game-input vectors bit-arrays ;
 IN: game-input.iokit
 
 SINGLETON: iokit-game-input-backend
@@ -12,10 +12,11 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ;
 
 iokit-game-input-backend game-input-backend set-global
 
-: hid-manager-matching ( matching-seq -- alien )
+: make-hid-manager ( -- alien )
-    f 0 IOHIDManagerCreate
+    f 0 IOHIDManagerCreate ;
-    [ swap >plist IOHIDManagerSetDeviceMatchingMultiple ]
+
-    keep ;
+: set-hid-manager-matching ( alien matching-seq -- )
+    >plist IOHIDManagerSetDeviceMatchingMultiple ;
 
 : devices-from-hid-manager ( manager -- vector )
     [
@@ -85,9 +86,6 @@ CONSTANT: hat-switch-matching-hash
 : ?hat-switch ( device -- ? )
     hat-switch-matching-hash ?axis ;
 
-: hid-manager-matching-game-devices ( -- alien )
-    game-devices-matching-seq hid-manager-matching ;
-
 : device-property ( device key -- value )
     <NSString> IOHIDDeviceGetProperty [ plist> ] [ f ] if* ;
 : element-property ( element key -- value )
@@ -186,7 +184,7 @@ HINTS: record-controller { controller-state alien } ;
         rot ?set-nth
     ] [ 3drop ] if ;
 
-HINTS: record-keyboard { array alien } ;
+HINTS: record-keyboard { bit-array alien } ;
 
 : record-mouse ( mouse-state value -- )
     dup IOHIDValueGetElement {
@@ -285,15 +283,16 @@ M: iokit-game-input-backend reset-mouse
     4 <vector> +controller-states+ set-global
     0 0 0 0 2 <vector> mouse-state boa
         +mouse-state+ set-global
-    256 f <array> +keyboard-state+ set-global ;
+    256 <bit-array> +keyboard-state+ set-global ;
 
 M: iokit-game-input-backend (open-game-input)
-    hid-manager-matching-game-devices {
+    make-hid-manager {
         [ initialize-variables ]
         [ device-matched-callback f IOHIDManagerRegisterDeviceMatchingCallback ]
         [ device-removed-callback f IOHIDManagerRegisterDeviceRemovalCallback ]
         [ device-input-callback f IOHIDManagerRegisterInputValueCallback ]
         [ 0 IOHIDManagerOpen mach-error ]
+        [ game-devices-matching-seq set-hid-manager-matching ]
         [
             CFRunLoopGetMain CFRunLoopDefaultMode
             IOHIDManagerScheduleWithRunLoop

basis/images/jpeg/jpeg.factor

@@ -0,0 +1,304 @@
+! Copyright (C) 2009 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays byte-arrays combinators
+constructors grouping compression.huffman images
+images.processing io io.binary io.encodings.binary io.files
+io.streams.byte-array kernel locals math math.bitwise
+math.constants math.functions math.matrices math.order
+math.ranges math.vectors memoize multiline namespaces
+sequences sequences.deep ;
+IN: images.jpeg
+
+QUALIFIED-WITH: bitstreams bs
+
+TUPLE: jpeg-image < image
+    { headers }
+    { bitstream }
+    { color-info initial: { f f f f } }
+    { quant-tables initial: { f f } }
+    { huff-tables initial: { f f f f } }
+    { components } ;
+
+<PRIVATE
+
+CONSTRUCTOR: jpeg-image ( headers bitstream -- image ) ;
+
+SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
+APP JPG COM TEM RES ;
+
+! ISO/IEC 10918-1 Table B.1
+:: >marker ( byte -- marker )
+    byte
+    {
+      { [ dup HEX: CC = ] [ { DAC } ] }
+      { [ dup HEX: C4 = ] [ { DHT } ] }
+      { [ dup HEX: C9 = ] [ { JPG } ] }
+      { [ dup -4 shift HEX: C = ] [ SOF byte 4 bits 2array ] }
+
+      { [ dup HEX: D8 = ] [ { SOI } ] }
+      { [ dup HEX: D9 = ] [ { EOI } ] }
+      { [ dup HEX: DA = ] [ { SOS } ] }
+      { [ dup HEX: DB = ] [ { DQT } ] }
+      { [ dup HEX: DC = ] [ { DNL } ] }
+      { [ dup HEX: DD = ] [ { DRI } ] }
+      { [ dup HEX: DE = ] [ { DHP } ] }
+      { [ dup HEX: DF = ] [ { EXP } ] }
+      { [ dup -4 shift HEX: D = ] [ RST byte 4 bits 2array ] }
+
+      { [ dup -4 shift HEX: E = ] [ APP byte 4 bits 2array ] }
+      { [ dup HEX: FE = ] [ { COM } ] }
+      { [ dup -4 shift HEX: F = ] [ JPG byte 4 bits 2array ] }
+
+      { [ dup HEX: 01 = ] [ { TEM } ] }
+      [ { RES } ]
+    }
+    cond nip ;
+
+TUPLE: jpeg-chunk length type data ;
+
+CONSTRUCTOR: jpeg-chunk ( type length data -- jpeg-chunk ) ;
+
+TUPLE: jpeg-color-info
+    h v quant-table dc-huff-table ac-huff-table { diff initial: 0 } id ;
+
+CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ;
+
+: jpeg> ( -- jpeg-image ) jpeg-image get ;
+
+: apply-diff ( dc color -- dc' )
+    [ diff>> + dup ] [ (>>diff) ] bi ;
+
+: fetch-tables ( component -- )
+    [ [ jpeg> quant-tables>> nth ] change-quant-table drop ]
+    [ [ jpeg> huff-tables>> nth ] change-dc-huff-table drop ]
+    [ [ 2 + jpeg> huff-tables>> nth ] change-ac-huff-table drop ] tri ;
+
+: read4/4 ( -- a b ) read1 16 /mod ;
+
+
+! headers
+
+: decode-frame ( header -- )
+    data>>
+    binary
+    [
+        read1 8 assert=
+        2 read be>
+        2 read be>
+        swap 2array jpeg> (>>dim)
+        read1
+        [
+            read1 read4/4 read1 <jpeg-color-info>
+            swap [ >>id ] keep jpeg> color-info>> set-nth
+        ] times
+    ] with-byte-reader ;
+
+: decode-quant-table ( chunk -- )
+    dup data>>
+    binary
+    [
+        length>>
+        2 - 65 /
+        [
+            read4/4 [ 0 assert= ] dip
+            64 read
+            swap jpeg> quant-tables>> set-nth
+        ] times
+    ] with-byte-reader ;
+
+: decode-huff-table ( chunk -- )
+    data>>
+    binary
+    [
+        1 ! %fixme: Should handle multiple tables at once
+        [
+            read4/4 swap 2 * +
+            16 read
+            dup [ ] [ + ] map-reduce read
+            binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader
+            swap jpeg> huff-tables>> set-nth
+        ] times
+    ] with-byte-reader ;
+
+: decode-scan ( chunk -- )
+    data>>
+    binary
+    [
+        read1 [0,b)
+        [   drop
+            read1 jpeg> color-info>> nth clone
+            read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi*
+        ] map jpeg> (>>components)
+        read1 0 assert=
+        read1 63 assert=
+        read1 16 /mod [ 0 assert= ] bi@
+    ] with-byte-reader ;
+
+: singleton-first ( seq -- elt )
+    [ length 1 assert= ] [ first ] bi ;
+
+: baseline-parse ( -- )
+    jpeg> headers>>
+    {
+        [ [ type>> { SOF 0 } = ] filter singleton-first decode-frame ]
+        [ [ type>> { DQT } = ] filter [ decode-quant-table ] each ]
+        [ [ type>> { DHT } = ] filter [ decode-huff-table ] each ]
+        [ [ type>> { SOS } = ] filter singleton-first decode-scan ]
+    } cleave ;
+
+: parse-marker ( -- marker )
+    read1 HEX: FF assert=
+    read1 >marker ;
+
+: parse-headers ( -- chunks )
+    [ parse-marker dup { SOS } = not ]
+    [
+        2 read be>
+        dup 2 - read <jpeg-chunk>
+    ] [ produce ] keep dip swap suffix ;
+
+MEMO: zig-zag ( -- zz )
+    {
+        {  0  1  5  6 14 15 27 28 }
+        {  2  4  7 13 16 26 29 42 }
+        {  3  8 12 17 25 30 41 43 }
+        {  9 11 18 24 31 40 44 53 }
+        { 10 19 23 32 39 45 52 54 }
+        { 20 22 33 38 46 51 55 60 }
+        { 21 34 37 47 50 56 59 61 }
+        { 35 36 48 49 57 58 62 63 }
+    } flatten ;
+
+MEMO: yuv>bgr-matrix ( -- m )
+    {
+        { 1  2.03211  0       }
+        { 1 -0.39465 -0.58060 }
+        { 1  0        1.13983 }
+    } ;
+
+: wave ( x u -- n ) swap 2 * 1 + * pi * 16 / cos ;
+
+:: dct-vect ( u v -- basis )
+    { 8 8 } coord-matrix [ { u v } [ wave ] 2map product ] map^2
+    1 u v [ 0 = [ 2 sqrt / ] when ] bi@ 4 / m*n ;
+
+MEMO: dct-matrix ( -- m ) 64 [0,b) [ 8 /mod dct-vect flatten ] map ;
+
+: mb-dim ( component -- dim )  [ h>> ] [ v>> ] bi 2array ;
+
+: all-macroblocks ( quot: ( mb -- ) -- )
+    [
+        jpeg>
+        [ dim>> 8 v/n ]
+        [ color-info>> sift { 0 0 } [ mb-dim vmax ] reduce v/ ] bi
+        [ ceiling ] map
+        coord-matrix flip concat
+    ]
+    [ each ] bi* ; inline
+
+: reverse-zigzag ( b -- b' ) zig-zag swap [ nth ] curry map ;
+
+: idct-factor ( b -- b' ) dct-matrix v.m ;
+
+USE: math.blas.vectors
+USE: math.blas.matrices
+
+MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
+: V.M ( x A -- x.A ) Mtranspose swap M.V ;
+: idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ;
+
+: idct ( b -- b' ) idct-blas ;
+
+:: draw-block ( block x,y color jpeg-image -- )
+    block dup length>> sqrt >fixnum group flip
+    dup matrix-dim coord-matrix flip
+    [
+        [ first2 spin nth nth ]
+        [ x,y v+ color id>> 1- jpeg-image draw-color ] bi
+    ] with each^2 ;
+
+: sign-extend ( bits v -- v' )
+    swap [ ] [ 1- 2^ < ] 2bi
+    [ -1 swap shift 1+ + ] [ drop ] if ;
+
+: read1-jpeg-dc ( decoder -- dc )
+    [ read1-huff dup ] [ bs>> bs:read ] bi sign-extend ;
+
+: read1-jpeg-ac ( decoder -- run/ac )
+    [ read1-huff 16 /mod dup ] [ bs>> bs:read ] bi sign-extend 2array ;
+
+:: decode-block ( pos color -- )
+    color dc-huff-table>> read1-jpeg-dc color apply-diff
+    64 0 <array> :> coefs
+    0 coefs set-nth
+    0 :> k!
+    [
+        color ac-huff-table>> read1-jpeg-ac
+        [ first 1+ k + k! ] [ second k coefs set-nth ] [ ] tri
+        { 0 0 } = not
+        k 63 < and
+    ] loop
+    coefs color quant-table>> v*
+    reverse-zigzag idct
+    ! %fixme: color hack
+    ! this eat 50% cpu time
+    color h>> 2 =
+    [ 8 group 2 matrix-zoom concat ] unless
+    pos { 8 8 } v* color jpeg> draw-block ;
+
+: decode-macroblock ( mb -- )
+    jpeg> components>>
+    [
+        [ mb-dim coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ]
+        [ [ decode-block ] curry each ] bi
+    ] with each ;
+
+: cleanup-bitstream ( bytes -- bytes' )
+    binary [
+        [
+            { HEX: FF } read-until
+            read1 tuck HEX: 00 = and
+        ]
+        [ drop ] produce
+        swap >marker {  EOI } assert=
+        swap suffix
+        { HEX: FF } join
+    ] with-byte-reader ;
+
+: setup-bitmap ( image -- )
+    dup dim>> 16 v/n [ ceiling ] map 16 v*n >>dim
+    BGR >>component-order
+    f >>upside-down?
+    dup dim>> first2 * 3 * 0 <array> >>bitmap
+    drop ;
+
+: baseline-decompress ( -- )
+    jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append
+    >byte-array bs:<msb0-bit-reader> jpeg> (>>bitstream)
+    jpeg> [ bitstream>> ] [ [ [ <huffman-decoder> ] with map ] change-huff-tables drop ] bi
+    jpeg> components>> [ fetch-tables ] each
+    jpeg> setup-bitmap
+    [ decode-macroblock ] all-macroblocks ;
+
+! this eats ~25% cpu time
+: color-transform ( yuv -- rgb )
+    { 128 0 0 } v+ yuv>bgr-matrix swap m.v
+    [ 0 max 255 min >fixnum ] map ;
+
+PRIVATE>
+
+: load-jpeg ( path -- image )
+    binary [
+        parse-marker { SOI } assert=
+        parse-headers
+        contents <jpeg-image>
+    ] with-file-reader
+    dup jpeg-image [
+        baseline-parse
+        baseline-decompress
+        jpeg> bitmap>> 3 <groups> [ color-transform ] change-each
+        jpeg> [ >byte-array ] change-bitmap drop
+    ] with-variable ;
+
+M: jpeg-image load-image* ( path jpeg-image -- bitmap )
+    drop load-jpeg ;

basis/images/loader/loader.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: constructors kernel splitting unicode.case combinators
-accessors images.bitmap images.tiff images io.pathnames ;
+accessors images.bitmap images.tiff images io.pathnames
+images.jpeg images.png ;
 IN: images.loader
 
 ERROR: unknown-image-extension extension ;
@@ -11,6 +12,9 @@ ERROR: unknown-image-extension extension ;
         { "bmp" [ bitmap-image ] }
         { "tif" [ tiff-image ] }
         { "tiff" [ tiff-image ] }
+        { "jpg" [ jpeg-image ] }
+        { "jpeg" [ jpeg-image ] }
+        { "png" [ png-image ] }
         [ unknown-image-extension ]
     } case ;
 

basis/images/png/png.factor

@@ -3,7 +3,7 @@
 USING: accessors constructors images io io.binary io.encodings.ascii
 io.encodings.binary io.encodings.string io.files io.files.info kernel
 sequences io.streams.limited fry combinators arrays math
-checksums checksums.crc32 ;
+checksums checksums.crc32 compression.inflate grouping byte-arrays ;
 IN: images.png
 
 TUPLE: png-image < image chunks
@@ -17,7 +17,8 @@ TUPLE: png-chunk length type data ;
 
 CONSTRUCTOR: png-chunk ( -- png-chunk ) ;
 
-CONSTANT: png-header B{ HEX: 89 HEX: 50 HEX: 4e HEX: 47 HEX: 0d HEX: 0a HEX: 1a HEX: 0a }
+CONSTANT: png-header
+    B{ HEX: 89 HEX: 50 HEX: 4e HEX: 47 HEX: 0d HEX: 0a HEX: 1a HEX: 0a }
 
 ERROR: bad-png-header header ;
 
@@ -61,6 +62,46 @@ ERROR: bad-checksum ;
 : fill-image-data ( image -- image )
     dup [ width>> ] [ height>> ] bi 2array >>dim ;
 
+: zlib-data ( png-image -- bytes ) 
+    chunks>> [ type>> "IDAT" = ] find nip data>> ;
+
+ERROR: unknown-color-type n ;
+ERROR: unimplemented-color-type image ;
+
+: inflate-data ( image -- bytes )
+    zlib-data zlib-inflate ; 
+
+: decode-greyscale ( image -- image )
+    unimplemented-color-type ;
+
+: decode-truecolor ( image -- image )
+    {
+        [ inflate-data ]
+        [ dim>> first 3 * 1 + group reverse-png-filter ]
+        [ swap >byte-array >>bitmap drop ]
+        [ RGB >>component-order drop ]
+        [ ]
+    } cleave ;
+    
+: decode-indexed-color ( image -- image )
+    unimplemented-color-type ;
+
+: decode-greyscale-alpha ( image -- image )
+    unimplemented-color-type ;
+
+: decode-truecolor-alpha ( image -- image )
+    unimplemented-color-type ;
+
+: decode-png ( image -- image ) 
+    dup color-type>> {
+        { 0 [ decode-greyscale ] }
+        { 2 [ decode-truecolor ] }
+        { 3 [ decode-indexed-color ] }
+        { 4 [ decode-greyscale-alpha ] }
+        { 6 [ decode-truecolor-alpha ] }
+        [ unknown-color-type ]
+    } case ;
+
 : load-png ( path -- image )
     [ binary <file-reader> ] [ file-info size>> ] bi
     stream-throws <limited-stream> [
@@ -69,4 +110,8 @@ ERROR: bad-checksum ;
         read-png-chunks
         parse-ihdr-chunk
         fill-image-data
+        decode-png
     ] with-input-stream ;
+
+M: png-image load-image*
+    drop load-png ;

basis/images/processing/processing.factor

@@ -0,0 +1,40 @@
+! Copyright (C) 2009 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays byte-arrays combinators grouping images
+kernel locals math math.order
+math.ranges math.vectors sequences sequences.deep fry ;
+IN: images.processing
+
+: coord-matrix ( dim -- m )
+    [ [0,b) ] map first2 [ [ 2array ] with map ] curry map ;
+
+: map^2 ( m quot -- m' ) '[ _ map ] map ; inline
+: each^2 ( m quot -- m' ) '[ _ each ] each ; inline
+
+: matrix-dim ( m -- dim ) [ length ] [ first length ] bi 2array ;
+    
+: matrix>image ( m -- image )
+    <image> over matrix-dim >>dim
+    swap flip flatten
+    [ 128 * 128 + 0 max 255 min  >fixnum ] map
+    >byte-array >>bitmap L >>component-order ;
+
+:: matrix-zoom ( m f -- m' )
+    m matrix-dim f v*n coord-matrix
+    [ [ f /i ] map first2 swap m nth nth ] map^2 ;
+
+:: image-offset ( x,y image -- xy )
+    image dim>> first
+    x,y second * x,y first + ;
+        
+:: draw-grey ( value x,y image -- )
+    x,y image image-offset 3 * { 0 1 2 }
+    [
+        + value 128 + >fixnum 0 max 255 min swap image bitmap>> set-nth
+    ] with each ;
+
+:: draw-color ( value x,y color-id image -- )
+    x,y image image-offset 3 * color-id + value >fixnum
+    swap image bitmap>> set-nth ;
+
+! : matrix. ( m -- ) 10 matrix-zoom matrix>image image. ;

basis/io/backend/unix/unix.factor

@@ -173,10 +173,11 @@ M: stdin refill
         size-read-fd <fd> init-fd <input-port> >>size
         data-read-fd <fd> >>data ;
 
-M: unix (init-stdio)
+M: unix init-stdio
     <stdin> <input-port>
     1 <fd> <output-port>
-    2 <fd> <output-port> t ;
+    2 <fd> <output-port>
+    set-stdio ;
 
 ! mx io-task for embedding an fd-based mx inside another mx
 TUPLE: mx-port < port mx ;

basis/io/backend/windows/nt/nt.factor

@@ -1,9 +1,9 @@
-USING: alien alien.c-types arrays assocs combinators
+USING: alien alien.c-types arrays assocs combinators continuations
-continuations destructors io io.backend io.ports io.timeouts
+destructors io io.backend io.ports io.timeouts io.backend.windows
-io.backend.windows io.files.windows io.files.windows.nt io.files
+io.files.windows io.files.windows.nt io.files io.pathnames io.buffers
-io.pathnames io.buffers io.streams.c libc kernel math namespaces
+io.streams.c io.streams.null libc kernel math namespaces sequences
-sequences threads windows windows.errors windows.kernel32
+threads windows windows.errors windows.kernel32 strings splitting
-strings splitting ascii system accessors locals ;
+ascii system accessors locals ;
 QUALIFIED: windows.winsock
 IN: io.backend.windows.nt
 
@@ -140,7 +140,9 @@ M: winnt (wait-to-read) ( port -- )
 
 : console-app? ( -- ? ) GetConsoleWindow >boolean ;
 
-M: winnt (init-stdio)
+M: winnt init-stdio
-    console-app? [ init-c-stdio t ] [ f f f f ] if ;
+    console-app?
+    [ init-c-stdio ]
+    [ null-reader null-writer null-writer set-stdio ] if ;
 
 winnt set-io-backend

basis/io/directories/hierarchy/hierarchy.factor

@@ -20,7 +20,7 @@ DEFER: copy-tree-into
     {
         { +symbolic-link+ [ copy-link ] }
         { +directory+ [ '[ [ _ copy-tree-into ] each ] with-directory-files ] }
-        [ drop copy-file ]
+        [ drop copy-file-and-info ]
     } case ;
 
 : copy-tree-into ( from to -- )

basis/io/directories/unix/linux/linux.factor

@@ -0,0 +1,10 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types io.directories.unix kernel system unix ;
+IN: io.directories.unix.linux
+
+M: unix find-next-file ( DIR* -- byte-array )
+    "dirent" <c-object>
+    f <void*>
+    [ readdir64_r 0 = [ (io-error) ] unless ] 2keep
+    *void* [ drop f ] unless ;

basis/io/directories/unix/linux/tags.txt

@@ -0,0 +1 @@
+unportable

basis/io/directories/unix/unix.factor

@@ -4,7 +4,7 @@ USING: accessors alien.c-types alien.strings combinators
 continuations destructors fry io io.backend io.backend.unix
 io.directories io.encodings.binary io.encodings.utf8 io.files
 io.pathnames io.files.types kernel math.bitwise sequences system
-unix unix.stat ;
+unix unix.stat vocabs.loader ;
 IN: io.directories.unix
 
 : touch-mode ( -- n )
@@ -34,7 +34,9 @@ M: unix copy-file ( from to -- )
     [ opendir dup [ (io-error) ] unless ] dip
     dupd curry swap '[ _ closedir io-error ] [ ] cleanup ; inline
 
-: find-next-file ( DIR* -- byte-array )
+HOOK: find-next-file os ( DIR* -- byte-array )
+
+M: unix find-next-file ( DIR* -- byte-array )
     "dirent" <c-object>
     f <void*>
     [ readdir_r 0 = [ (io-error) ] unless ] 2keep
@@ -54,8 +56,10 @@ M: unix copy-file ( from to -- )
     } case ;
 
 M: unix >directory-entry ( byte-array -- directory-entry )
+    {
         [ dirent-d_name utf8 alien>string ]
-    [ dirent-d_type dirent-type>file-type ] bi directory-entry boa ;
+        [ dirent-d_type dirent-type>file-type ]
+    } cleave directory-entry boa ;
 
 M: unix (directory-entries) ( path -- seq )
     [
@@ -63,3 +67,5 @@ M: unix (directory-entries) ( path -- seq )
         [ >directory-entry ]
         produce nip
     ] with-unix-directory ;
+
+os linux? [ "io.directories.unix.linux" require ] when

basis/io/files/info/info.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman, Eduardo Cavazos.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel system sequences combinators
-vocabs.loader io.files.types ;
+vocabs.loader io.files.types io.directories math ;
 IN: io.files.info
 
 ! File info
@@ -14,6 +14,9 @@ HOOK: link-info os ( path -- info )
 
 : directory? ( file-info -- ? ) type>> +directory+ = ;
 
+: sparse-file? ( file-info -- ? )
+    [ size-on-disk>> ] [ size>> ] bi < ;
+
 ! File systems
 HOOK: file-systems os ( -- array )
 
@@ -26,3 +29,7 @@ HOOK: file-system-info os ( path -- file-system-info )
     { [ os unix? ] [ "io.files.info.unix." os name>> append ] }
     { [ os windows? ] [ "io.files.info.windows" ] }
 } cond require
+
+HOOK: copy-file-and-info os ( from to -- )
+
+M: object copy-file-and-info copy-file ;

basis/io/files/info/unix/unix.factor

@@ -3,7 +3,7 @@
 USING: accessors kernel system math math.bitwise strings arrays
 sequences combinators combinators.short-circuit alien.c-types
 vocabs.loader calendar calendar.unix io.files.info
-io.files.types io.backend unix unix.stat unix.time unix.users
+io.files.types io.backend io.directories unix unix.stat unix.time unix.users
 unix.groups ;
 IN: io.files.info.unix
 
@@ -174,6 +174,9 @@ CONSTANT: OTHER-EXECUTE OCT: 0000001
 : file-permissions ( path -- n )
     normalize-path file-info permissions>> ;
 
+M: unix copy-file-and-info ( from to -- )
+    [ copy-file ] [ swap file-permissions set-file-permissions ] 2bi ;
+
 <PRIVATE
 
 : make-timeval-array ( array -- byte-array )

basis/io/launcher/launcher.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: system kernel namespaces strings hashtables sequences 
+USING: system kernel namespaces strings hashtables sequences assocs
-assocs combinators vocabs.loader init threads continuations
+combinators vocabs.loader init threads continuations math accessors
-math accessors concurrency.flags destructors environment
+concurrency.flags destructors environment io io.encodings.ascii
-io io.encodings.ascii io.backend io.timeouts io.pipes
+io.backend io.timeouts io.pipes io.pipes.private io.encodings
-io.pipes.private io.encodings io.streams.duplex io.ports
+io.encodings.utf8 io.streams.duplex io.ports debugger prettyprint
-debugger prettyprint summary calendar ;
+summary calendar ;
 IN: io.launcher
 
 TUPLE: process < identity-tuple
@@ -254,6 +254,21 @@ M: object run-pipeline-element
     swap [ with-stream ] dip
     wait-for-success ; inline
 
+ERROR: output-process-error { output string } { process process } ;
+
+M: output-process-error error.
+    [ "Process:" print process>> . nl ]
+    [ "Output:" print output>> print ]
+    bi ;
+
+: try-output-process ( command -- )
+    >process
+    +stdout+ >>stderr
+    +closed+ >>stdin
+    utf8 <process-reader*>
+    [ stream-contents ] [ dup wait-for-process ] bi*
+    0 = [ 2drop ] [ output-process-error ] if ;
+
 : notify-exit ( process status -- )
     >>status
     [ processes get delete-at* drop [ resume ] each ] keep

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/opengl/framebuffers/framebuffers.factor

@@ -28,6 +28,7 @@ IN: opengl.framebuffers
         { GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT [ "framebuffer incomplete (format mismatch)" ] }
         { GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT [ "framebuffer incomplete (draw buffer(s) have no attachment)" ] }
         { GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT [ "framebuffer incomplete (read buffer has no attachment)" ] }
+        { GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE_EXT [ "framebuffer incomplete (multisample counts don't match)" ] }
         [ drop gl-error "unknown framebuffer error" ]
     } case throw ;
 
@@ -35,9 +36,19 @@ IN: opengl.framebuffers
     framebuffer-incomplete? [ framebuffer-error ] when* ;
 
 : with-framebuffer ( id quot -- )
-    GL_FRAMEBUFFER_EXT rot glBindFramebufferEXT
+    [ GL_FRAMEBUFFER_EXT swap glBindFramebufferEXT ] dip
     [ GL_FRAMEBUFFER_EXT 0 glBindFramebufferEXT ] [ ] cleanup ; inline
 
+: with-draw-read-framebuffers ( draw-id read-id quot -- )
+    [
+        [ GL_DRAW_FRAMEBUFFER_EXT swap glBindFramebufferEXT ]
+        [ GL_READ_FRAMEBUFFER_EXT swap glBindFramebufferEXT ] bi*
+    ] dip
+    [ 
+        GL_DRAW_FRAMEBUFFER_EXT 0 glBindFramebufferEXT
+        GL_READ_FRAMEBUFFER_EXT 0 glBindFramebufferEXT
+    ] [ ] cleanup ; inline
+
 : framebuffer-attachment ( attachment -- id )
     GL_FRAMEBUFFER_EXT swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT
     0 <uint> [ glGetFramebufferAttachmentParameterivEXT ] keep *uint ;

basis/opengl/gl/gl.factor

@@ -1774,6 +1774,33 @@ GL-FUNCTION: GLboolean glIsRenderbufferEXT { } ( GLuint renderbuffer ) ;
 GL-FUNCTION: void glRenderbufferStorageEXT { } ( GLenum target, GLenum internalformat, GLsizei width, GLsizei height ) ;
 
 
+! GL_EXT_framebuffer_blit
+
+
+GL-FUNCTION: void glBlitFramebufferEXT { } ( GLint srcX0, GLint srcY0, GLint srcX1, GLint srcY1,
+                                             GLint dstX0, GLint dstY0, GLint dstX1, GLint dstY1,
+                                             GLbitfield mask, GLenum filter ) ;
+
+CONSTANT: GL_READ_FRAMEBUFFER_EXT HEX: 8CA8
+CONSTANT: GL_DRAW_FRAMEBUFFER_EXT HEX: 8CA9
+
+ALIAS: GL_DRAW_FRAMEBUFFER_BINDING_EXT GL_FRAMEBUFFER_BINDING_EXT
+CONSTANT: GL_READ_FRAMEBUFFER_BINDING_EXT HEX: 8CAA
+
+
+! GL_EXT_framebuffer_multisample
+
+
+GL-FUNCTION: void glRenderbufferStorageMultisampleEXT { } (
+            GLenum target, GLsizei samples,
+            GLenum internalformat,
+            GLsizei width, GLsizei height ) ;
+
+CONSTANT: GL_RENDERBUFFER_SAMPLES_EXT HEX: 8CAB
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE_EXT HEX: 8D56
+CONSTANT: GL_MAX_SAMPLES_EXT HEX: 8D57
+
+
 ! GL_ARB_texture_float
 
 
@@ -1798,3 +1825,218 @@ CONSTANT: GL_TEXTURE_INTENSITY_TYPE_ARB HEX: 8C15
 CONSTANT: GL_TEXTURE_DEPTH_TYPE_ARB HEX: 8C16
 CONSTANT: GL_UNSIGNED_NORMALIZED_ARB HEX: 8C17
 
+
+! GL_EXT_gpu_shader4
+
+
+GL-FUNCTION: void glVertexAttribI1iEXT { } ( GLuint index, GLint x ) ;
+GL-FUNCTION: void glVertexAttribI2iEXT { } ( GLuint index, GLint x, GLint y ) ;
+GL-FUNCTION: void glVertexAttribI3iEXT { } ( GLuint index, GLint x, GLint y, GLint z ) ;
+GL-FUNCTION: void glVertexAttribI4iEXT { } ( GLuint index, GLint x, GLint y, GLint z, GLint w ) ;
+
+GL-FUNCTION: void glVertexAttribI1uiEXT { } ( GLuint index, GLuint x ) ;
+GL-FUNCTION: void glVertexAttribI2uiEXT { } ( GLuint index, GLuint x, GLuint y ) ;
+GL-FUNCTION: void glVertexAttribI3uiEXT { } ( GLuint index, GLuint x, GLuint y, GLuint z ) ;
+GL-FUNCTION: void glVertexAttribI4uiEXT { } ( GLuint index, GLuint x, GLuint y, GLuint z, GLuint w ) ;
+
+GL-FUNCTION: void glVertexAttribI1ivEXT { } ( GLuint index, GLint* v ) ;
+GL-FUNCTION: void glVertexAttribI2ivEXT { } ( GLuint index, GLint* v ) ;
+GL-FUNCTION: void glVertexAttribI3ivEXT { } ( GLuint index, GLint* v ) ;
+GL-FUNCTION: void glVertexAttribI4ivEXT { } ( GLuint index, GLint* v ) ;
+
+GL-FUNCTION: void glVertexAttribI1uivEXT { } ( GLuint index, GLuint* v ) ;
+GL-FUNCTION: void glVertexAttribI2uivEXT { } ( GLuint index, GLuint* v ) ;
+GL-FUNCTION: void glVertexAttribI3uivEXT { } ( GLuint index, GLuint* v ) ;
+GL-FUNCTION: void glVertexAttribI4uivEXT { } ( GLuint index, GLuint* v ) ;
+
+GL-FUNCTION: void glVertexAttribI4bvEXT { } ( GLuint index, GLbyte* v ) ;
+GL-FUNCTION: void glVertexAttribI4svEXT { } ( GLuint index, GLshort* v ) ;
+GL-FUNCTION: void glVertexAttribI4ubvEXT { } ( GLuint index, GLubyte* v ) ;
+GL-FUNCTION: void glVertexAttribI4usvEXT { } ( GLuint index, GLushort* v ) ;
+
+GL-FUNCTION: void glVertexAttribIPointerEXT { } ( GLuint index, GLint size, GLenum type, GLsizei stride, void* pointer ) ;
+
+GL-FUNCTION: void glGetVertexAttribIivEXT { } ( GLuint index, GLenum pname, GLint* params ) ;
+GL-FUNCTION: void glGetVertexAttribIuivEXT { } ( GLuint index, GLenum pname, GLuint* params ) ;
+
+GL-FUNCTION: void glUniform1uiEXT { } ( GLint location, GLuint v0 ) ;
+GL-FUNCTION: void glUniform2uiEXT { } ( GLint location, GLuint v0, GLuint v1 ) ;
+GL-FUNCTION: void glUniform3uiEXT { } ( GLint location, GLuint v0, GLuint v1, GLuint v2 ) ;
+GL-FUNCTION: void glUniform4uiEXT { } ( GLint location, GLuint v0, GLuint v1, GLuint v2, GLuint v3 ) ;
+
+GL-FUNCTION: void glUniform1uivEXT { } ( GLint location, GLsizei count, GLuint* value ) ;
+GL-FUNCTION: void glUniform2uivEXT { } ( GLint location, GLsizei count, GLuint* value ) ;
+GL-FUNCTION: void glUniform3uivEXT { } ( GLint location, GLsizei count, GLuint* value ) ;
+GL-FUNCTION: void glUniform4uivEXT { } ( GLint location, GLsizei count, GLuint* value ) ;
+
+GL-FUNCTION: void glGetUniformuivEXT { } ( GLuint program, GLint location, GLuint* params ) ;
+
+GL-FUNCTION: void glBindFragDataLocationEXT { } ( GLuint program, GLuint colorNumber, GLchar* name ) ;
+GL-FUNCTION: GLint GetFragDataLocationEXT { } ( GLuint program, GLchar* name ) ;
+
+CONSTANT: GL_VERTEX_ATTRIB_ARRAY_INTEGER_EXT HEX: 88FD
+CONSTANT: GL_SAMPLER_1D_ARRAY_EXT HEX: 8DC0
+CONSTANT: GL_SAMPLER_2D_ARRAY_EXT HEX: 8DC1
+CONSTANT: GL_SAMPLER_BUFFER_EXT HEX: 8DC2
+CONSTANT: GL_SAMPLER_1D_ARRAY_SHADOW_EXT HEX: 8DC3
+CONSTANT: GL_SAMPLER_2D_ARRAY_SHADOW_EXT HEX: 8DC4
+CONSTANT: GL_SAMPLER_CUBE_SHADOW_EXT HEX: 8DC5
+CONSTANT: GL_UNSIGNED_INT_VEC2_EXT HEX: 8DC6
+CONSTANT: GL_UNSIGNED_INT_VEC3_EXT HEX: 8DC7
+CONSTANT: GL_UNSIGNED_INT_VEC4_EXT HEX: 8DC8
+CONSTANT: GL_INT_SAMPLER_1D_EXT HEX: 8DC9
+CONSTANT: GL_INT_SAMPLER_2D_EXT HEX: 8DCA
+CONSTANT: GL_INT_SAMPLER_3D_EXT HEX: 8DCB
+CONSTANT: GL_INT_SAMPLER_CUBE_EXT HEX: 8DCC
+CONSTANT: GL_INT_SAMPLER_2D_RECT_EXT HEX: 8DCD
+CONSTANT: GL_INT_SAMPLER_1D_ARRAY_EXT HEX: 8DCE
+CONSTANT: GL_INT_SAMPLER_2D_ARRAY_EXT HEX: 8DCF
+CONSTANT: GL_INT_SAMPLER_BUFFER_EXT HEX: 8DD0
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_1D_EXT HEX: 8DD1
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_2D_EXT HEX: 8DD2
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_3D_EXT HEX: 8DD3
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_CUBE_EXT HEX: 8DD4
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_2D_RECT_EXT HEX: 8DD5
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_1D_ARRAY_EXT HEX: 8DD6
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_2D_ARRAY_EXT HEX: 8DD7
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_BUFFER_EXT HEX: 8DD8
+CONSTANT: GL_MIN_PROGRAM_TEXEL_OFFSET_EXT HEX: 8904
+CONSTANT: GL_MAX_PROGRAM_TEXEL_OFFSET_EXT HEX: 8905
+
+
+! GL_EXT_geometry_shader4
+
+
+GL-FUNCTION: void glProgramParameteriEXT { } ( GLuint program, GLenum pname, GLint value ) ;
+GL-FUNCTION: void glFramebufferTextureEXT { } ( GLenum target, GLenum attachment, 
+                                                GLuint texture, GLint level ) ;
+GL-FUNCTION: void glFramebufferTextureLayerEXT { } ( GLenum target, GLenum attachment, 
+                                                     GLuint texture, GLint level, GLint layer ) ;
+GL-FUNCTION: void glFramebufferTextureFaceEXT { } ( GLenum target, GLenum attachment,
+                                                    GLuint texture, GLint level, GLenum face ) ;
+
+CONSTANT: GL_GEOMETRY_SHADER_EXT HEX: 8DD9
+CONSTANT: GL_GEOMETRY_VERTICES_OUT_EXT HEX: 8DDA
+CONSTANT: GL_GEOMETRY_INPUT_TYPE_EXT HEX: 8DDB
+CONSTANT: GL_GEOMETRY_OUTPUT_TYPE_EXT HEX: 8DDC
+CONSTANT: GL_MAX_GEOMETRY_TEXTURE_IMAGE_UNITS_EXT HEX: 8C29
+CONSTANT: GL_MAX_GEOMETRY_VARYING_COMPONENTS_EXT HEX: 8DDD
+CONSTANT: GL_MAX_VERTEX_VARYING_COMPONENTS_EXT HEX: 8DDE
+CONSTANT: GL_MAX_VARYING_COMPONENTS_EXT HEX: 8B4B
+CONSTANT: GL_MAX_GEOMETRY_UNIFORM_COMPONENTS_EXT HEX: 8DDF
+CONSTANT: GL_MAX_GEOMETRY_OUTPUT_VERTICES_EXT HEX: 8DE0
+CONSTANT: GL_MAX_GEOMETRY_TOTAL_OUTPUT_COMPONENTS_EXT HEX: 8DE1
+CONSTANT: GL_LINES_ADJACENCY_EXT HEX: A
+CONSTANT: GL_LINE_STRIP_ADJACENCY_EXT HEX: B
+CONSTANT: GL_TRIANGLES_ADJACENCY_EXT HEX: C
+CONSTANT: GL_TRIANGLE_STRIP_ADJACENCY_EXT HEX: D
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS_EXT HEX: 8DA8
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_LAYER_COUNT_EXT HEX: 8DA9
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_LAYERED_EXT HEX: 8DA7
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_LAYER_EXT GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_3D_ZOFFSET_EXT
+CONSTANT: GL_PROGRAM_POINT_SIZE_EXT HEX: 8642
+
+
+! GL_EXT_texture_integer
+
+
+GL-FUNCTION: void glClearColorIiEXT { } ( GLint r, GLint g, GLint b, GLint a ) ;
+GL-FUNCTION: void glClearColorIuiEXT { } ( GLuint r, GLuint g, GLuint b, GLuint a ) ;
+GL-FUNCTION: void glTexParameterIivEXT { } ( GLenum target, GLenum pname, GLint* params ) ;
+GL-FUNCTION: void glTexParameterIuivEXT { } ( GLenum target, GLenum pname, GLuint* params ) ;
+GL-FUNCTION: void glGetTexParameterIivEXT { } ( GLenum target, GLenum pname, GLint* params ) ;
+GL-FUNCTION: void glGetTexParameterIuivEXT { } ( GLenum target, GLenum pname, GLuint* params ) ;
+
+CONSTANT: GL_RGBA_INTEGER_MODE_EXT HEX: 8D9E
+
+CONSTANT: GL_RGBA32UI_EXT HEX: 8D70
+CONSTANT: GL_RGB32UI_EXT HEX: 8D71
+CONSTANT: GL_ALPHA32UI_EXT HEX: 8D72
+CONSTANT: GL_INTENSITY32UI_EXT HEX: 8D73
+CONSTANT: GL_LUMINANCE32UI_EXT HEX: 8D74
+CONSTANT: GL_LUMINANCE_ALPHA32UI_EXT HEX: 8D75
+
+CONSTANT: GL_RGBA16UI_EXT HEX: 8D76
+CONSTANT: GL_RGB16UI_EXT HEX: 8D77
+CONSTANT: GL_ALPHA16UI_EXT HEX: 8D78
+CONSTANT: GL_INTENSITY16UI_EXT HEX: 8D79
+CONSTANT: GL_LUMINANCE16UI_EXT HEX: 8D7A
+CONSTANT: GL_LUMINANCE_ALPHA16UI_EXT HEX: 8D7B
+
+CONSTANT: GL_RGBA8UI_EXT HEX: 8D7C
+CONSTANT: GL_RGB8UI_EXT HEX: 8D7D
+CONSTANT: GL_ALPHA8UI_EXT HEX: 8D7E
+CONSTANT: GL_INTENSITY8UI_EXT HEX: 8D7F
+CONSTANT: GL_LUMINANCE8UI_EXT HEX: 8D80
+CONSTANT: GL_LUMINANCE_ALPHA8UI_EXT HEX: 8D81
+
+CONSTANT: GL_RGBA32I_EXT HEX: 8D82
+CONSTANT: GL_RGB32I_EXT HEX: 8D83
+CONSTANT: GL_ALPHA32I_EXT HEX: 8D84
+CONSTANT: GL_INTENSITY32I_EXT HEX: 8D85
+CONSTANT: GL_LUMINANCE32I_EXT HEX: 8D86
+CONSTANT: GL_LUMINANCE_ALPHA32I_EXT HEX: 8D87
+
+CONSTANT: GL_RGBA16I_EXT HEX: 8D88
+CONSTANT: GL_RGB16I_EXT HEX: 8D89
+CONSTANT: GL_ALPHA16I_EXT HEX: 8D8A
+CONSTANT: GL_INTENSITY16I_EXT HEX: 8D8B
+CONSTANT: GL_LUMINANCE16I_EXT HEX: 8D8C
+CONSTANT: GL_LUMINANCE_ALPHA16I_EXT HEX: 8D8D
+
+CONSTANT: GL_RGBA8I_EXT HEX: 8D8E
+CONSTANT: GL_RGB8I_EXT HEX: 8D8F
+CONSTANT: GL_ALPHA8I_EXT HEX: 8D90
+CONSTANT: GL_INTENSITY8I_EXT HEX: 8D91
+CONSTANT: GL_LUMINANCE8I_EXT HEX: 8D92
+CONSTANT: GL_LUMINANCE_ALPHA8I_EXT HEX: 8D93
+
+CONSTANT: GL_RED_INTEGER_EXT HEX: 8D94
+CONSTANT: GL_GREEN_INTEGER_EXT HEX: 8D95
+CONSTANT: GL_BLUE_INTEGER_EXT HEX: 8D96
+CONSTANT: GL_ALPHA_INTEGER_EXT HEX: 8D97
+CONSTANT: GL_RGB_INTEGER_EXT HEX: 8D98
+CONSTANT: GL_RGBA_INTEGER_EXT HEX: 8D99
+CONSTANT: GL_BGR_INTEGER_EXT HEX: 8D9A
+CONSTANT: GL_BGRA_INTEGER_EXT HEX: 8D9B
+CONSTANT: GL_LUMINANCE_INTEGER_EXT HEX: 8D9C
+CONSTANT: GL_LUMINANCE_ALPHA_INTEGER_EXT HEX: 8D9D
+
+
+! GL_EXT_transform_feedback
+
+
+GL-FUNCTION: void glBindBufferRangeEXT { } ( GLenum target, GLuint index, GLuint buffer,
+                           GLintptr offset, GLsizeiptr size ) ;
+GL-FUNCTION: void glBindBufferOffsetEXT { } ( GLenum target, GLuint index, GLuint buffer,
+                            GLintptr offset ) ;
+GL-FUNCTION: void glBindBufferBaseEXT { } ( GLenum target, GLuint index, GLuint buffer ) ;
+
+GL-FUNCTION: void glBeginTransformFeedbackEXT { } ( GLenum primitiveMode ) ;
+GL-FUNCTION: void glEndTransformFeedbackEXT { } ( ) ;
+
+GL-FUNCTION: void glTransformFeedbackVaryingsEXT { } ( GLuint program, GLsizei count,
+                                      GLchar** varyings, GLenum bufferMode ) ;
+GL-FUNCTION: void glGetTransformFeedbackVaryingEXT { } ( GLuint program, GLuint index,
+                                        GLsizei bufSize, GLsizei* length, 
+                                        GLsizei* size, GLenum* type, GLchar* name ) ;
+
+GL-FUNCTION: void glGetIntegerIndexedvEXT { } ( GLenum param, GLuint index, GLint* values ) ;
+GL-FUNCTION: void glGetBooleanIndexedvEXT { } ( GLenum param, GLuint index, GLboolean* values ) ;
+
+CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_EXT HEX: 8C8E
+CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_START_EXT HEX: 8C84
+CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_SIZE_EXT HEX: 8C85
+CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_BINDING_EXT HEX: 8C8F
+CONSTANT: GL_INTERLEAVED_ATTRIBS_EXT HEX: 8C8C
+CONSTANT: GL_SEPARATE_ATTRIBS_EXT HEX: 8C8D
+CONSTANT: GL_PRIMITIVES_GENERATED_EXT HEX: 8C87
+CONSTANT: GL_TRANSFORM_FEEDBACK_PRIMITIVES_WRITTEN_EXT HEX: 8C88
+CONSTANT: GL_RASTERIZER_DISCARD_EXT HEX: 8C89
+CONSTANT: GL_MAX_TRANSFORM_FEEDBACK_INTERLEAVED_COMPONENTS_EXT HEX: 8C8A
+CONSTANT: GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_ATTRIBS_EXT HEX: 8C8B
+CONSTANT: GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_COMPONENTS_EXT HEX: 8C80
+CONSTANT: GL_TRANSFORM_FEEDBACK_VARYINGS_EXT HEX: 8C83
+CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_MODE_EXT HEX: 8C7F
+CONSTANT: GL_TRANSFORM_FEEDBACK_VARYING_MAX_LENGTH_EXT HEX: 8C76
+

basis/openssl/libcrypto/libcrypto.factor

@@ -13,6 +13,7 @@ IN: openssl.libcrypto
 <<
 {
     { [ os openbsd? ] [ ] } ! VM is linked with it
+    { [ os netbsd? ] [ ] }
     { [ os winnt? ] [ "libcrypto" "libeay32.dll" "cdecl" add-library ] }
     { [ os macosx? ] [ "libcrypto" "libcrypto.dylib" "cdecl" add-library ] }
     { [ os unix? ] [ "libcrypto" "libcrypto.so" "cdecl" add-library ] }

basis/openssl/libssl/libssl.factor

@@ -9,6 +9,7 @@ IN: openssl.libssl
 
 << {
     { [ os openbsd? ] [ ] } ! VM is linked with it
+    { [ os netbsd? ] [ ] }
     { [ os winnt? ] [ "libssl" "ssleay32.dll" "cdecl" add-library ] }
     { [ os macosx? ] [ "libssl" "libssl.dylib" "cdecl" add-library ] }
     { [ os unix? ] [ "libssl" "libssl.so" "cdecl" add-library ] }

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/annotations/annotations.factor

@@ -43,29 +43,17 @@ PRIVATE>
 
 <PRIVATE
 
-: word-inputs ( word -- seq )
+: stack-values ( names -- alist )
-    stack-effect [
+    [ datastack ] dip [ nip ] [ length tail* ] 2bi zip ;
-        [ datastack ] dip in>> length tail*
-    ] [
-        datastack
-    ] if* ;
 
-: entering ( str -- )
+: trace-message ( word quot str -- )
-    "/-- Entering: " write dup .
+    "--- " write write bl over .
-    word-inputs stack.
+    [ stack-effect ] dip '[ @ stack-values ] [ f ] if*
-    "\\--" print flush ;
+    [ simple-table. ] unless-empty flush ; inline
 
-: word-outputs ( word -- seq )
+: entering ( str -- ) [ in>> ] "Entering" trace-message ;
-    stack-effect [
-        [ datastack ] dip out>> length tail*
-    ] [
-        datastack
-    ] if* ;
 
-: leaving ( str -- )
+: leaving ( str -- ) [ out>> ] "Leaving" trace-message ;
-    "/-- Leaving: " write dup .
-    word-outputs stack.
-     "\\--" print flush ;
 
 : (watch) ( word def -- def )
     over '[ _ entering @ _ leaving ] ;

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,13 @@
 ! 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
+math make assocs kernel parser lexer strings.parser vocabs sequences
-sequences words memory kernel.private
+sequences.private words memory kernel.private continuations io
-continuations io vocabs.loader system strings sets
+vocabs.loader system strings sets vectors quotations byte-arrays
-vectors quotations byte-arrays sorting compiler.units
+sorting compiler.units definitions generic generic.standard
-definitions generic generic.standard tools.deploy.config ;
+generic.single tools.deploy.config combinators classes
+slots.private ;
 QUALIFIED: bootstrap.stage2
-QUALIFIED: classes
 QUALIFIED: command-line
 QUALIFIED: compiler.errors
 QUALIFIED: continuations
@@ -40,10 +40,11 @@ IN: tools.deploy.shaker
     strip-io? [
         "io.files" init-hooks get delete-at
         "io.backend" init-hooks get delete-at
+        "io.thread" init-hooks get delete-at
     ] when
     strip-dictionary? [
         {
-            "compiler.units"
+            ! "compiler.units"
             "vocabs"
             "vocabs.cache"
             "source-files.errors"
@@ -193,6 +194,14 @@ IN: tools.deploy.shaker
     strip-word-names? [ dup strip-word-names ] when
     2drop ;
 
+: strip-compiler-classes ( -- )
+    strip-dictionary? [
+        "Stripping compiler classes" show
+        { "compiler" "stack-checker" }
+        [ child-vocabs [ words ] map concat [ class? ] filter ] map concat
+        [ dup implementors [ "methods" word-prop delete-at ] with each ] each
+    ] when ;
+
 : strip-default-methods ( -- )
     strip-debugger? [
         "Stripping default methods" show
@@ -255,20 +264,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 +307,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 ;
 
@@ -322,26 +331,40 @@ IN: tools.deploy.shaker
     ] [ drop ] if ;
 
 : strip-c-io ( -- )
-    deploy-io get 2 = os windows? or [
+    strip-io?
+    deploy-io get 3 = os windows? not and
+    or [
         [
             c-io-backend forget
             "io.streams.c" forget-vocab
+            "io-thread-running?" "io.thread" lookup [
+                global delete-at
+            ] when*
         ] with-compilation-unit
-    ] unless ;
+    ] when ;
 
 : compress ( pred post-process string -- )
     "Compressing " prepend show
     [ 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
     #! compiled.
     2dup [
-        2dup [ compiled>> ] [ compiled>> not ] bi* and
+        2dup [ quot-compiled? ] [ quot-compiled? not ] bi* and
         [ nip jit-compile ] [ 2drop ] if
     ] 2each ;
 
@@ -349,12 +372,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 +402,40 @@ 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 ;
 
+: (clear-megamorphic-cache) ( i array -- )
+    2dup 1 slot < [
+        2dup [ f ] 2dip set-array-nth
+        [ 1 + ] dip (clear-megamorphic-cache)
+    ] [ 2drop ] if ;
+
+: clear-megamorphic-cache ( array -- )
+    [ 0 ] dip (clear-megamorphic-cache) ;
+
+: find-megamorphic-caches ( -- seq )
+    "Finding megamorphic caches" show
+    [ standard-generic? ] instances [ def>> third ] map ;
+
+: clear-megamorphic-caches ( cache -- )
+    "Clearing megamorphic caches" show
+    [ clear-megamorphic-cache ] each ;
+
 : strip ( -- )
     init-stripper
-    strip-default-methods
     strip-libc
     strip-call
     strip-cocoa
@@ -404,15 +443,17 @@ 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
+    find-megamorphic-caches
     stripped-word-props
     stripped-globals strip-globals
-    compress-byte-arrays
+    compress-objects
     compress-quotations
-    compress-strings
+    strip-words
-    compress-wrappers
+    clear-megamorphic-caches ;
-    strip-words ;
 
 : deploy-error-handler ( quot -- )
     [
@@ -432,6 +473,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/tools/deploy/test/test.factor

@@ -1,5 +1,5 @@
 USING: accessors arrays continuations io.directories io.files.info
-io.files.temp io.launcher kernel layouts math sequences system
+io.files.temp io.launcher io.backend kernel layouts math sequences system
 tools.deploy.backend tools.deploy.config.editor ;
 IN: tools.deploy.test
 
@@ -14,7 +14,6 @@ IN: tools.deploy.test
     [ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ;
 
 : run-temp-image ( -- )
-    vm
+    os macosx?
-    "-i=" "test.image" temp-file append
+    "resource:Factor.app/Contents/MacOS/factor" normalize-path vm ?
-    2array
+    "-i=" "test.image" temp-file append 2array try-output-process ;
-    <process> swap >>command +closed+ >>stdin try-process ;

basis/tools/files/files.factor

@@ -74,7 +74,7 @@ M: object file-spec>string ( file-listing spec -- string )
 
 : list-files-slow ( listing-tool -- array )
     [ path>> ] [ sort>> ] [ specs>> ] tri '[
-            [ dup name>> file-info file-listing boa ] map
+        [ dup name>> link-info file-listing boa ] map
         _ [ sort-by ] when*
         [ _ [ file-spec>string ] with map ] map
     ] with-directory-entries ; inline
@@ -115,11 +115,14 @@ SYMBOLS: +device-name+ +mount-point+ +type+
     [ file-systems-info ]
     [ [ unparse ] map ] bi prefix simple-table. ;
 
-: file-systems. ( -- )
+CONSTANT: default-file-systems-spec
     {
         +device-name+ +available-space+ +free-space+ +used-space+
         +total-space+ +percent-used+ +mount-point+
-    } print-file-systems ;
+    }
+
+: file-systems. ( -- )
+    default-file-systems-spec print-file-systems ;
 
 {
     { [ os unix? ] [ "tools.files.unix" ] }

basis/ui/backend/backend.factor

@@ -7,9 +7,9 @@ SYMBOL: ui-backend
 
 HOOK: set-title ui-backend ( string world -- )
 
-HOOK: set-fullscreen* ui-backend ( ? world -- )
+HOOK: (set-fullscreen) ui-backend ( world ? -- )
 
-HOOK: fullscreen* ui-backend ( world -- ? )
+HOOK: (fullscreen?) ui-backend ( world -- ? )
 
 HOOK: (open-window) ui-backend ( world -- )
 

basis/ui/backend/cocoa/cocoa.factor

@@ -99,12 +99,14 @@ M: cocoa-ui-backend set-title ( string world -- )
     drop ;
 
 : exit-fullscreen ( world -- )
-    handle>> view>> f -> exitFullScreenModeWithOptions: ;
+    handle>>
+    [ view>> f -> exitFullScreenModeWithOptions: ] 
+    [ [ window>> ] [ view>> ] bi -> makeFirstResponder: drop ] bi ;
 
-M: cocoa-ui-backend set-fullscreen* ( ? world -- )
+M: cocoa-ui-backend (set-fullscreen) ( world ? -- )
-    swap [ enter-fullscreen ] [ exit-fullscreen ] if ;
+    [ enter-fullscreen ] [ exit-fullscreen ] if ;
 
-M: cocoa-ui-backend fullscreen* ( world -- ? )
+M: cocoa-ui-backend (fullscreen?) ( world -- ? )
     handle>> view>> -> isInFullScreenMode zero? not ;
 
 M:: cocoa-ui-backend (open-window) ( world -- )
@@ -120,13 +122,20 @@ M:: cocoa-ui-backend (open-window) ( world -- )
     window f -> makeKeyAndOrderFront: ;
 
 M: cocoa-ui-backend (close-window) ( handle -- )
-    window>> -> release ;
+    [
+        view>> dup -> isInFullScreenMode zero?
+        [ drop ]
+        [ f -> exitFullScreenModeWithOptions: ] if
+    ] [ window>> -> release ] bi ;
 
 M: cocoa-ui-backend (grab-input) ( handle -- )
     0 CGAssociateMouseAndMouseCursorPosition drop
     CGMainDisplayID CGDisplayHideCursor drop
     window>> -> frame CGRect>rect rect-center
-    first2 <CGPoint> CGWarpMouseCursorPosition drop ;
+    NSScreen -> screens 0 -> objectAtIndex: -> frame CGRect-h
+    [ drop first ] [ swap second - ] 2bi <CGPoint>
+    [ GetCurrentButtonState zero? not ] [ yield ] while
+    CGWarpMouseCursorPosition drop ;
 
 M: cocoa-ui-backend (ungrab-input) ( handle -- )
     drop