diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index 15e67bf0fe..e4a0e4dcf0 100755 --- a/basis/alien/arrays/arrays.factor +++ b/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 diff --git a/basis/bitstreams/bitstreams-tests.factor b/basis/bitstreams/bitstreams-tests.factor index 769efcbb04..a5b1b43acd 100644 --- a/basis/bitstreams/bitstreams-tests.factor +++ b/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 read-bit ] unit-test -[ 254 8 t ] -[ B{ 254 } binary 8 swap read-bits ] unit-test - -[ 4095 12 t ] -[ B{ 255 255 } binary 12 swap read-bits ] unit-test - -[ B{ 254 } ] +[ BIN: 1111111111 ] [ - binary 254 8 rot - [ write-bits ] keep stream>> >byte-array + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 10 swap peek ] unit-test -[ 255 8 t ] -[ B{ 255 } binary 8 swap read-bits ] unit-test +[ BIN: 111111111 ] +[ + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 9 swap peek +] unit-test -[ 255 8 f ] -[ B{ 255 } binary 9 swap read-bits ] unit-test +[ BIN: 11111111 ] +[ + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 8 swap peek +] unit-test + +[ BIN: 1111111 ] +[ + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 7 swap peek +] unit-test + +[ BIN: 111111 ] +[ + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 6 swap peek +] unit-test + +[ BIN: 11111 ] +[ + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 5 swap peek +] unit-test + +[ B{ } 5 swap peek ] must-fail +[ B{ } 1 swap peek ] must-fail +[ B{ } 8 swap peek ] must-fail + +[ 0 ] [ B{ } 0 swap peek ] unit-test diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index 7113b650fd..cb6a753735 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/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 -math sequences ; +USING: accessors alien.accessors assocs byte-arrays combinators +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: bitstream-reader < bitstream ; +TUPLE: widthed { bits integer read-only } { #bits integer read-only } ; -: reset-bitstream ( stream -- stream ) - 0 >>#bits 0 >>current-bits ; inline +ERROR: invalid-widthed bits #bits ; -: 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 ; + +: ( bits #bits -- widthed ) + check-widthed + widthed boa ; + +: zero-widthed ( -- widthed ) 0 0 ; +: 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 - reset-bitstream ; inline + BV{ } clone >>bytes + 0 0 >>widthed ; inline -M: bitstream-reader dispose ( stream -- ) - stream>> dispose ; +: ( -- bs ) + msb0-bit-writer new-bit-writer ; -: ( stream -- bitstream ) - bitstream-reader new-bitstream ; inline +: ( -- bs ) + lsb0-bit-writer new-bit-writer ; -: read-next-byte ( bitstream -- bitstream ) - dup stream>> stream-read1 [ - >>current-bits 8 >>#bits +GENERIC: peek ( n bitstream -- value ) +GENERIC: poke ( value n bitstream -- ) + +: seek ( n bitstream -- ) + { + [ byte-pos>> 8 * ] + [ bit-pos>> + + 8 /mod ] + [ (>>bit-pos) ] + [ (>>byte-pos) ] + } cleave ; inline + +: read ( n bitstream -- value ) + [ peek ] [ seek ] 2bi ; inline + +> ] dip < [ not-enough-bits ] when + [ [ bits>> ] [ #bits>> ] bi ] dip + [ - neg shift ] keep ; + +: split-widthed ( widthed n -- widthed1 widthed2 ) + 2dup [ #bits>> ] dip < [ + drop zero-widthed ] [ - 0 >>#bits - t >>end-of-stream? - ] 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 ; - -: ( 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 + [ widthed-bits ] + [ [ [ bits>> ] [ #bits>> ] bi ] dip - [ bits ] keep ] 2bi ] 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 + ; + +PRIVATE> + +M:: lsb0-bit-writer poke ( value n bs -- ) + value n :> 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>> ; diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 92d75604e0..4a7a558703 100644 --- a/basis/bootstrap/image/image.factor +++ b/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 diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 9d19e4a231..3cbe155dd2 100644 --- a/basis/bootstrap/stage2.factor +++ b/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 diff --git a/basis/circular/circular-docs.factor b/basis/circular/circular-docs.factor index c7af57c1fe..235d5db2c7 100644 --- a/basis/circular/circular-docs.factor +++ b/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 } "Changing the start index:" { $subsection change-circular-start } +{ $subsection rotate-circular } "Pushing new elements:" { $subsection push-circular } { $subsection push-growing-circular } ; diff --git a/basis/circular/circular-tests.factor b/basis/circular/circular-tests.factor index 105e3790aa..3a94e14640 100644 --- a/basis/circular/circular-tests.factor +++ b/basis/circular/circular-tests.factor @@ -12,6 +12,7 @@ circular strings ; [ CHAR: e ] [ "test" 5 swap nth-unsafe ] unit-test [ [ 1 2 3 ] ] [ { 1 2 3 } [ ] like ] unit-test +[ [ 2 3 1 ] ] [ { 1 2 3 } [ rotate-circular ] keep [ ] like ] unit-test [ [ 2 3 1 ] ] [ { 1 2 3 } 1 over change-circular-start [ ] like ] unit-test [ [ 3 1 2 ] ] [ { 1 2 3 } 1 over change-circular-start 1 over change-circular-start [ ] like ] unit-test [ [ 3 1 2 ] ] [ { 1 2 3 } -100 over change-circular-start [ ] like ] unit-test diff --git a/basis/circular/circular.factor b/basis/circular/circular.factor index 9f3a71f2a8..909b2ed713 100644 --- a/basis/circular/circular.factor +++ b/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 ; diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 65bb2c02ef..fdd4ba81d7 100644 --- a/basis/cocoa/messages/messages.factor +++ b/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 diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor index 9519847810..751a1f52e1 100644 --- a/basis/combinators/smart/smart.factor +++ b/basis/combinators/smart/smart.factor @@ -11,8 +11,8 @@ MACRO: output>sequence ( quot exemplar -- newquot ) [ dup infer out>> ] dip '[ @ _ _ nsequence ] ; -: output>array ( quot -- newquot ) - { } output>sequence ; inline +MACRO: output>array ( quot -- newquot ) + '[ _ { } output>sequence ] ; MACRO: input> ] keep @@ -25,8 +25,8 @@ MACRO: input> 1 [-] ] dip n*quot compose ; -: sum-outputs ( quot -- n ) - [ + ] reduce-outputs ; inline +MACRO: sum-outputs ( quot -- n ) + '[ _ [ + ] 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 ) - { } append-outputs-as ; inline +MACRO: append-outputs ( quot -- seq ) + '[ _ { } append-outputs-as ] ; diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index 6b383388ef..b795862970 100644 --- a/basis/compiler/constants/constants.factor +++ b/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 diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index fa1248435b..72618db456 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -395,4 +395,20 @@ DEFER: loop-bbb : modular-arithmetic-bug ( a -- b ) >integer 256 mod ; [ 1 ] [ 257 modular-arithmetic-bug ] unit-test -[ -10 ] [ -10 modular-arithmetic-bug ] unit-test \ No newline at end of file +[ -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 \ No newline at end of file diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index ee9abf00ec..6be3bed8d3 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/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 ] [ - [ in-d>> ] [ [ dispatch# ] keep ] bi* - [ swap nth value-info class>> dup ] dip - specific-method + 2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [ + [ in-d>> ] [ [ dispatch# ] keep ] bi* + [ swap nth value-info class>> dup ] dip + specific-method + ] if ] if ; : inline-standard-method ( #call word -- ? ) diff --git a/basis/compression/huffman/huffman.factor b/basis/compression/huffman/huffman.factor new file mode 100755 index 0000000000..6ef9c2fabc --- /dev/null +++ b/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 + + ( -- 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 -- ) -- ) + :> 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 :> table + tdesc [ n table update-reverse-table ] huffman-each + table seq>> ; + +:: huffman-table ( tdesc max -- table ) + max f :> 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 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 [ swap n bits. [ huff. ] each ] assoc-each ; +*/ diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor new file mode 100755 index 0000000000..3fe07b5994 --- /dev/null +++ b/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 + +seq ( assoc -- seq ) + dup keys [ ] [ max ] map-reduce 1 + f + [ '[ 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 :> 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 clone + [ '[ _ 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 + [ 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 append ] bi* ] [ suffix ] if ] reduce + [ dup array? [ second 0 ] [ 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 :> 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 ] 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: + [ check-zlib-header ] + [ inflate-loop ] bi + inflate-lz77 ; diff --git a/basis/compression/lzw/lzw.factor b/basis/compression/lzw/lzw.factor index 29cbe96d69..46a319662e 100644 --- a/basis/compression/lzw/lzw.factor +++ b/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 -code old-code ; +TUPLE: lzw input output table 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 ; - -: ( input -- obj ) - lzw new - swap >>input - binary >>output - reset-lzw-compress ; + initial-uncompress-table >>table ; : ( 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 - [ 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 - [ lzw-uncompress-char ] [ output>> ] bi ; + bs: + + [ lzw-uncompress-char ] [ output>> ] bi ; diff --git a/basis/core-graphics/core-graphics.factor b/basis/core-graphics/core-graphics.factor index 924f7130f0..6612a43dca 100644 --- a/basis/core-graphics/core-graphics.factor +++ b/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 ( ) ; + string append , , ] { } make ; + [ + gvim-path , + number>string "+" prepend , , + ] { } make ; gvim vim-editor set-global diff --git a/basis/editors/macvim/macvim.factor b/basis/editors/macvim/macvim.factor index b5f864dcd0..c178207e49 100644 --- a/basis/editors/macvim/macvim.factor +++ b/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 ; - -[ macvim-location ] edit-hook set-global - + run-detached drop ; +[ macvim ] edit-hook set-global diff --git a/basis/editors/scite/scite.factor b/basis/editors/scite/scite.factor index 7e8a540b73..605b4d53aa 100644 --- a/basis/editors/scite/scite.factor +++ b/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 diff --git a/basis/editors/textedit/textedit.factor b/basis/editors/textedit/textedit.factor index cccc94b539..4b5f2c6886 100644 --- a/basis/editors/textedit/textedit.factor +++ b/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 diff --git a/basis/editors/textmate/textmate.factor b/basis/editors/textmate/textmate.factor index 8bea085c7f..65395bd590 100644 --- a/basis/editors/textmate/textmate.factor +++ b/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 diff --git a/basis/editors/vim/vim-docs.factor b/basis/editors/vim/vim-docs.factor index 7f527bf18f..1ec3a37061 100644 --- a/basis/editors/vim/vim-docs.factor +++ b/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 diff --git a/basis/editors/vim/vim.factor b/basis/editors/vim/vim.factor index f07f257888..88c8b8051e 100644 --- a/basis/editors/vim/vim.factor +++ b/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-command try-process ; +: vim ( file line -- ) + vim-command run-detached drop ; "vim" vim-path set-global -[ vim-location ] edit-hook set-global -vim vim-editor set-global +[ vim ] edit-hook set-global +\ vim vim-editor set-global diff --git a/extra/game-input/authors.txt b/basis/game-input/authors.txt similarity index 100% rename from extra/game-input/authors.txt rename to basis/game-input/authors.txt diff --git a/extra/game-input/dinput/authors.txt b/basis/game-input/dinput/authors.txt similarity index 100% rename from extra/game-input/dinput/authors.txt rename to basis/game-input/dinput/authors.txt diff --git a/extra/game-input/dinput/dinput.factor b/basis/game-input/dinput/dinput.factor similarity index 100% rename from extra/game-input/dinput/dinput.factor rename to basis/game-input/dinput/dinput.factor diff --git a/extra/game-input/dinput/keys-array/keys-array.factor b/basis/game-input/dinput/keys-array/keys-array.factor similarity index 100% rename from extra/game-input/dinput/keys-array/keys-array.factor rename to basis/game-input/dinput/keys-array/keys-array.factor diff --git a/extra/game-input/dinput/summary.txt b/basis/game-input/dinput/summary.txt similarity index 100% rename from extra/game-input/dinput/summary.txt rename to basis/game-input/dinput/summary.txt diff --git a/extra/game-input/dinput/tags.txt b/basis/game-input/dinput/tags.txt similarity index 100% rename from extra/game-input/dinput/tags.txt rename to basis/game-input/dinput/tags.txt diff --git a/extra/game-input/game-input-docs.factor b/basis/game-input/game-input-docs.factor similarity index 100% rename from extra/game-input/game-input-docs.factor rename to basis/game-input/game-input-docs.factor diff --git a/basis/game-input/game-input-tests.factor b/basis/game-input/game-input-tests.factor new file mode 100644 index 0000000000..3cce0da575 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/extra/game-input/game-input.factor b/basis/game-input/game-input.factor similarity index 100% rename from extra/game-input/game-input.factor rename to basis/game-input/game-input.factor diff --git a/extra/game-input/iokit/authors.txt b/basis/game-input/iokit/authors.txt similarity index 100% rename from extra/game-input/iokit/authors.txt rename to basis/game-input/iokit/authors.txt diff --git a/extra/game-input/iokit/iokit.factor b/basis/game-input/iokit/iokit.factor similarity index 96% rename from extra/game-input/iokit/iokit.factor rename to basis/game-input/iokit/iokit.factor index 5f09a054f9..68ecaecc29 100755 --- a/extra/game-input/iokit/iokit.factor +++ b/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 ) - f 0 IOHIDManagerCreate - [ swap >plist IOHIDManagerSetDeviceMatchingMultiple ] - keep ; +: make-hid-manager ( -- alien ) + f 0 IOHIDManagerCreate ; + +: 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 ) 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 +controller-states+ set-global 0 0 0 0 2 mouse-state boa +mouse-state+ set-global - 256 f +keyboard-state+ set-global ; + 256 +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 diff --git a/extra/game-input/iokit/summary.txt b/basis/game-input/iokit/summary.txt similarity index 100% rename from extra/game-input/iokit/summary.txt rename to basis/game-input/iokit/summary.txt diff --git a/extra/game-input/iokit/tags.txt b/basis/game-input/iokit/tags.txt similarity index 100% rename from extra/game-input/iokit/tags.txt rename to basis/game-input/iokit/tags.txt diff --git a/extra/game-input/scancodes/authors.txt b/basis/game-input/scancodes/authors.txt similarity index 100% rename from extra/game-input/scancodes/authors.txt rename to basis/game-input/scancodes/authors.txt diff --git a/extra/game-input/scancodes/scancodes.factor b/basis/game-input/scancodes/scancodes.factor similarity index 100% rename from extra/game-input/scancodes/scancodes.factor rename to basis/game-input/scancodes/scancodes.factor diff --git a/extra/game-input/scancodes/summary.txt b/basis/game-input/scancodes/summary.txt similarity index 100% rename from extra/game-input/scancodes/summary.txt rename to basis/game-input/scancodes/summary.txt diff --git a/extra/game-input/scancodes/tags.txt b/basis/game-input/scancodes/tags.txt similarity index 100% rename from extra/game-input/scancodes/tags.txt rename to basis/game-input/scancodes/tags.txt diff --git a/extra/game-input/summary.txt b/basis/game-input/summary.txt similarity index 100% rename from extra/game-input/summary.txt rename to basis/game-input/summary.txt diff --git a/extra/game-input/tags.txt b/basis/game-input/tags.txt similarity index 100% rename from extra/game-input/tags.txt rename to basis/game-input/tags.txt diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor new file mode 100755 index 0000000000..648923704a --- /dev/null +++ b/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 } ; + +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 + 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 + ] [ 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 :> 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 >>bitmap + drop ; + +: baseline-decompress ( -- ) + jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append + >byte-array bs: jpeg> (>>bitstream) + jpeg> [ bitstream>> ] [ [ [ ] 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 + ] with-file-reader + dup jpeg-image [ + baseline-parse + baseline-decompress + jpeg> bitmap>> 3 [ color-transform ] change-each + jpeg> [ >byte-array ] change-bitmap drop + ] with-variable ; + +M: jpeg-image load-image* ( path jpeg-image -- bitmap ) + drop load-jpeg ; diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index fe33cc8f00..27b726f3c0 100644 --- a/basis/images/loader/loader.factor +++ b/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 ; diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index b027362977..c5b84de221 100755 --- a/basis/images/png/png.factor +++ b/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-info size>> ] bi stream-throws [ @@ -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 ; diff --git a/basis/images/processing/processing.factor b/basis/images/processing/processing.factor new file mode 100755 index 0000000000..fc463731b3 --- /dev/null +++ b/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 ) + 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. ; diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index f210180517..1a52ce6f34 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -173,10 +173,11 @@ M: stdin refill size-read-fd init-fd >>size data-read-fd >>data ; -M: unix (init-stdio) +M: unix init-stdio 1 - 2 t ; + 2 + set-stdio ; ! mx io-task for embedding an fd-based mx inside another mx TUPLE: mx-port < port mx ; diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index 4dfe02d651..69a695ac72 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -1,9 +1,9 @@ -USING: alien alien.c-types arrays assocs combinators -continuations destructors io io.backend io.ports io.timeouts -io.backend.windows io.files.windows io.files.windows.nt io.files -io.pathnames io.buffers io.streams.c libc kernel math namespaces -sequences threads windows windows.errors windows.kernel32 -strings splitting ascii system accessors locals ; +USING: alien alien.c-types arrays assocs combinators continuations +destructors io io.backend io.ports io.timeouts io.backend.windows +io.files.windows io.files.windows.nt io.files io.pathnames io.buffers +io.streams.c io.streams.null libc kernel math namespaces sequences +threads windows windows.errors windows.kernel32 strings splitting +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) - console-app? [ init-c-stdio t ] [ f f f f ] if ; +M: winnt init-stdio + console-app? + [ init-c-stdio ] + [ null-reader null-writer null-writer set-stdio ] if ; winnt set-io-backend diff --git a/basis/io/directories/hierarchy/hierarchy.factor b/basis/io/directories/hierarchy/hierarchy.factor index 555f001bfc..4a2955ccaf 100644 --- a/basis/io/directories/hierarchy/hierarchy.factor +++ b/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 -- ) diff --git a/basis/io/directories/unix/linux/linux.factor b/basis/io/directories/unix/linux/linux.factor new file mode 100644 index 0000000000..ba5b27dacd --- /dev/null +++ b/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" + f + [ readdir64_r 0 = [ (io-error) ] unless ] 2keep + *void* [ drop f ] unless ; diff --git a/basis/io/directories/unix/linux/tags.txt b/basis/io/directories/unix/linux/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/directories/unix/linux/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/directories/unix/unix.factor b/basis/io/directories/unix/unix.factor index 395ce73d7c..b8b781ec12 100644 --- a/basis/io/directories/unix/unix.factor +++ b/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" f [ 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_name utf8 alien>string ] + [ 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 diff --git a/basis/io/files/info/info.factor b/basis/io/files/info/info.factor index 5c5d2c93d2..60a9308f38 100644 --- a/basis/io/files/info/info.factor +++ b/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 ; diff --git a/basis/io/files/info/unix/unix.factor b/basis/io/files/info/unix/unix.factor index 80f4b74ac8..94cb60a2c6 100644 --- a/basis/io/files/info/unix/unix.factor +++ b/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 ; + > . nl ] + [ "Output:" print output>> print ] + bi ; + +: try-output-process ( command -- ) + >process + +stdout+ >>stderr + +closed+ >>stdin + utf8 + [ 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 diff --git a/core/io/streams/null/authors.txt b/basis/io/streams/null/authors.txt similarity index 100% rename from core/io/streams/null/authors.txt rename to basis/io/streams/null/authors.txt diff --git a/core/io/streams/null/null-docs.factor b/basis/io/streams/null/null-docs.factor similarity index 100% rename from core/io/streams/null/null-docs.factor rename to basis/io/streams/null/null-docs.factor diff --git a/core/io/streams/null/null.factor b/basis/io/streams/null/null.factor similarity index 100% rename from core/io/streams/null/null.factor rename to basis/io/streams/null/null.factor diff --git a/core/io/streams/null/summary.txt b/basis/io/streams/null/summary.txt similarity index 100% rename from core/io/streams/null/summary.txt rename to basis/io/streams/null/summary.txt diff --git a/extra/iokit/authors.txt b/basis/iokit/authors.txt similarity index 100% rename from extra/iokit/authors.txt rename to basis/iokit/authors.txt diff --git a/extra/iokit/hid/authors.txt b/basis/iokit/hid/authors.txt similarity index 100% rename from extra/iokit/hid/authors.txt rename to basis/iokit/hid/authors.txt diff --git a/extra/iokit/hid/hid.factor b/basis/iokit/hid/hid.factor similarity index 100% rename from extra/iokit/hid/hid.factor rename to basis/iokit/hid/hid.factor diff --git a/extra/iokit/hid/summary.txt b/basis/iokit/hid/summary.txt similarity index 100% rename from extra/iokit/hid/summary.txt rename to basis/iokit/hid/summary.txt diff --git a/extra/iokit/hid/tags.txt b/basis/iokit/hid/tags.txt similarity index 100% rename from extra/iokit/hid/tags.txt rename to basis/iokit/hid/tags.txt diff --git a/extra/iokit/iokit.factor b/basis/iokit/iokit.factor similarity index 100% rename from extra/iokit/iokit.factor rename to basis/iokit/iokit.factor diff --git a/extra/iokit/summary.txt b/basis/iokit/summary.txt similarity index 100% rename from extra/iokit/summary.txt rename to basis/iokit/summary.txt diff --git a/extra/iokit/tags.txt b/basis/iokit/tags.txt similarity index 100% rename from extra/iokit/tags.txt rename to basis/iokit/tags.txt diff --git a/basis/none/deploy.factor b/basis/none/deploy.factor index f604beab3f..06cc8c6a20 100644 --- a/basis/none/deploy.factor +++ b/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 } diff --git a/basis/opengl/framebuffers/framebuffers.factor b/basis/opengl/framebuffers/framebuffers.factor index 346789e1c5..f3ed8d320d 100644 --- a/basis/opengl/framebuffers/framebuffers.factor +++ b/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 [ glGetFramebufferAttachmentParameterivEXT ] keep *uint ; diff --git a/basis/opengl/gl/gl.factor b/basis/opengl/gl/gl.factor index 6181a72ffc..39a8a2c4fe 100644 --- a/basis/opengl/gl/gl.factor +++ b/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 + diff --git a/basis/openssl/libcrypto/libcrypto.factor b/basis/openssl/libcrypto/libcrypto.factor index b9e00b6c8d..0eba1d2854 100644 --- a/basis/openssl/libcrypto/libcrypto.factor +++ b/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 ] } diff --git a/basis/openssl/libssl/libssl.factor b/basis/openssl/libssl/libssl.factor index 21f712fdc8..520c7175c6 100644 --- a/basis/openssl/libssl/libssl.factor +++ b/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 ] } diff --git a/basis/struct-arrays/struct-arrays.factor b/basis/struct-arrays/struct-arrays.factor index ba0524009f..5aaf2c2ea6 100755 --- a/basis/struct-arrays/struct-arrays.factor +++ b/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 ; + [ heap-size calloc ] 2keep ; inline INSTANCE: struct-array sequence diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor index 2639d48be2..3cb74fb00b 100644 --- a/basis/tools/annotations/annotations.factor +++ b/basis/tools/annotations/annotations.factor @@ -43,29 +43,17 @@ PRIVATE> > length tail* - ] [ - datastack - ] if* ; +: stack-values ( names -- alist ) + [ datastack ] dip [ nip ] [ length tail* ] 2bi zip ; -: entering ( str -- ) - "/-- Entering: " write dup . - word-inputs stack. - "\\--" print flush ; +: trace-message ( word quot str -- ) + "--- " write write bl over . + [ stack-effect ] dip '[ @ stack-values ] [ f ] if* + [ simple-table. ] unless-empty flush ; inline -: word-outputs ( word -- seq ) - stack-effect [ - [ datastack ] dip out>> length tail* - ] [ - datastack - ] if* ; +: entering ( str -- ) [ in>> ] "Entering" trace-message ; -: leaving ( str -- ) - "/-- Leaving: " write dup . - word-outputs stack. - "\\--" print flush ; +: leaving ( str -- ) [ out>> ] "Leaving" trace-message ; : (watch) ( word def -- def ) over '[ _ entering @ _ leaving ] ; diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor index b74548a65f..ba82276927 100755 --- a/basis/tools/deploy/backend/backend.factor +++ b/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? } - { "compiler" deploy-compiler? } - { "threads" deploy-threads? } - { "ui" deploy-ui? } - { "unicode" deploy-unicode? } - } [ nip get ] assoc-filter keys - native-io? [ "io" suffix ] when ; + [ + deploy-math? get [ "math" , ] when + deploy-threads? get [ "threads" , ] when + "compiler" , + deploy-ui? get [ "ui" , ] when + deploy-unicode? get [ "unicode" , ] when + native-io? [ "io" , ] when + ] { } make ; : staging-image-name ( profile -- name ) "staging." diff --git a/basis/tools/deploy/config/config-docs.factor b/basis/tools/deploy/config/config-docs.factor index c8249e4e41..bd612c644a 100644 --- a/basis/tools/deploy/config/config-docs.factor +++ b/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 diff --git a/basis/tools/deploy/config/config.factor b/basis/tools/deploy/config/config.factor index 63c8393b51..89d1fe3821 100644 --- a/basis/tools/deploy/config/config.factor +++ b/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 } diff --git a/basis/tools/deploy/deploy-docs.factor b/basis/tools/deploy/deploy-docs.factor index 4c03047eb8..71701b6a56 100644 --- a/basis/tools/deploy/deploy-docs.factor +++ b/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" } diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 3bebf7236d..9cf21d1716 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/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" @@ -94,4 +97,8 @@ M: quit-responder call-responder* shake-and-bake run-temp-image ] curry unit-test -] each \ No newline at end of file +] each + +os windows? os macosx? or [ + [ ] [ "tools.deploy.test.8" shake-and-bake run-temp-image ] unit-test +] when \ No newline at end of file diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 816dbb7979..5a64878aee 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/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 -namespaces make assocs kernel parser lexer strings.parser vocabs -sequences words memory kernel.private -continuations io vocabs.loader system strings sets -vectors quotations byte-arrays sorting compiler.units -definitions generic generic.standard tools.deploy.config ; +USING: arrays accessors io.backend io.streams.c init fry namespaces +math make assocs kernel parser lexer strings.parser vocabs sequences +sequences.private words memory kernel.private continuations io +vocabs.loader system strings sets vectors quotations byte-arrays +sorting compiler.units definitions generic generic.standard +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 - classes:class-and-cache - classes:class-not-cache - classes:class-or-cache - classes:class<=-cache - classes:classes-intersect-cache - classes:implementors-map - classes:update-map + next-method-quot-cache + class-and-cache + class-not-cache + class-or-cache + class<=-cache + classes-intersect-cache + implementors-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 ( -- ) - [ byte-array? ] [ ] "byte arrays" compress ; +: compress-object? ( obj -- ? ) + { + { [ 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 - dup next-method-quot "next-method-quot" set-word-prop + nip dup + 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 - compress-wrappers - strip-words ; + strip-words + clear-megamorphic-caches ; : 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 diff --git a/basis/tools/deploy/shaker/strip-cocoa.factor b/basis/tools/deploy/shaker/strip-cocoa.factor index df64443b7b..133308b732 100644 --- a/basis/tools/deploy/shaker/strip-cocoa.factor +++ b/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 +\ reset-memoized + +\ (send) def>> second clear-assoc \ No newline at end of file diff --git a/basis/tools/deploy/test/1/deploy.factor b/basis/tools/deploy/test/1/deploy.factor index 6d6a1c1bd3..509024a5c3 100644 --- a/basis/tools/deploy/test/1/deploy.factor +++ b/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 } } diff --git a/basis/tools/deploy/test/10/deploy.factor b/basis/tools/deploy/test/10/deploy.factor index 3f5940651d..c42063f644 100644 --- a/basis/tools/deploy/test/10/deploy.factor +++ b/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 } diff --git a/basis/tools/deploy/test/11/deploy.factor b/basis/tools/deploy/test/11/deploy.factor index 42f707b332..4828f70d90 100644 --- a/basis/tools/deploy/test/11/deploy.factor +++ b/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 } } diff --git a/basis/tools/deploy/test/12/deploy.factor b/basis/tools/deploy/test/12/deploy.factor index 638e1ca000..a3aaa3bca2 100644 --- a/basis/tools/deploy/test/12/deploy.factor +++ b/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 } } diff --git a/basis/tools/deploy/test/13/deploy.factor b/basis/tools/deploy/test/13/deploy.factor index 9513192311..d175075c14 100644 --- a/basis/tools/deploy/test/13/deploy.factor +++ b/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 } diff --git a/basis/tools/deploy/test/2/deploy.factor b/basis/tools/deploy/test/2/deploy.factor index 1457769ce1..10cd7a85d9 100644 --- a/basis/tools/deploy/test/2/deploy.factor +++ b/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 } } diff --git a/basis/tools/deploy/test/3/deploy.factor b/basis/tools/deploy/test/3/deploy.factor index f3131237bf..b72b00d1e4 100644 --- a/basis/tools/deploy/test/3/deploy.factor +++ b/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 } diff --git a/basis/tools/deploy/test/4/deploy.factor b/basis/tools/deploy/test/4/deploy.factor index 981bbcf982..b2f22055c4 100644 --- a/basis/tools/deploy/test/4/deploy.factor +++ b/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 } } diff --git a/basis/tools/deploy/test/5/deploy.factor b/basis/tools/deploy/test/5/deploy.factor index 22f5021497..3f9b7f1599 100644 --- a/basis/tools/deploy/test/5/deploy.factor +++ b/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 } } diff --git a/basis/tools/deploy/test/6/deploy.factor b/basis/tools/deploy/test/6/deploy.factor index c474fcdadf..b86bfdb31a 100644 --- a/basis/tools/deploy/test/6/deploy.factor +++ b/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 } diff --git a/basis/tools/deploy/test/7/deploy.factor b/basis/tools/deploy/test/7/deploy.factor index bc374f1088..d1e93fc7c2 100644 --- a/basis/tools/deploy/test/7/deploy.factor +++ b/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 } diff --git a/basis/tools/deploy/test/8/8.factor b/basis/tools/deploy/test/8/8.factor index c495928bf2..ddf08d3654 100644 --- a/basis/tools/deploy/test/8/8.factor +++ b/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" } } ; -: literal-merge-test-2 ( -- x ) H{ { "lil" "wayne" } } ; +TUPLE: my-world < world ; -: literal-merge-test ( -- ) - literal-merge-test-1 - literal-merge-test-2 eq? t assert= ; +BEFORE: my-world begin-world drop open-game-input ; -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 \ No newline at end of file diff --git a/basis/tools/deploy/test/8/deploy.factor b/basis/tools/deploy/test/8/deploy.factor index 3bea1edfc7..1f7fb4d7ee 100644 --- a/basis/tools/deploy/test/8/deploy.factor +++ b/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 } } diff --git a/basis/tools/deploy/test/9/deploy.factor b/basis/tools/deploy/test/9/deploy.factor index 91b1da5697..caddbe36d0 100644 --- a/basis/tools/deploy/test/9/deploy.factor +++ b/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 } diff --git a/basis/tools/deploy/test/test.factor b/basis/tools/deploy/test/test.factor index f997a6eb3a..9a54e65f1a 100644 --- a/basis/tools/deploy/test/test.factor +++ b/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 - "-i=" "test.image" temp-file append - 2array - swap >>command +closed+ >>stdin try-process ; \ No newline at end of file + os macosx? + "resource:Factor.app/Contents/MacOS/factor" normalize-path vm ? + "-i=" "test.image" temp-file append 2array try-output-process ; \ No newline at end of file diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index 146a119a63..29d3674b60 100755 --- a/basis/tools/files/files.factor +++ b/basis/tools/files/files.factor @@ -74,9 +74,9 @@ 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 - _ [ sort-by ] when* - [ _ [ file-spec>string ] with map ] map + [ dup name>> link-info file-listing boa ] map + _ [ sort-by ] when* + [ _ [ file-spec>string ] with map ] map ] with-directory-entries ; inline : list-files ( listing-tool -- array ) @@ -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" ] } diff --git a/basis/ui/backend/backend.factor b/basis/ui/backend/backend.factor index 63d551798c..3d38439f69 100755 --- a/basis/ui/backend/backend.factor +++ b/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 -- ) diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index 47a3bfc1a6..b6c9b43271 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/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 -- ) - swap [ enter-fullscreen ] [ exit-fullscreen ] if ; +M: cocoa-ui-backend (set-fullscreen) ( world ? -- ) + [ 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 CGWarpMouseCursorPosition drop ; + NSScreen -> screens 0 -> objectAtIndex: -> frame CGRect-h + [ drop first ] [ swap second - ] 2bi + [ GetCurrentButtonState zero? not ] [ yield ] while + CGWarpMouseCursorPosition drop ; M: cocoa-ui-backend (ungrab-input) ( handle -- ) drop diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor index aab851c783..a9568d4f75 100644 --- a/basis/ui/backend/cocoa/views/views.factor +++ b/basis/ui/backend/cocoa/views/views.factor @@ -391,7 +391,10 @@ CLASS: { { "windowDidResignKey:" "void" { "id" "SEL" "id" } [ forget-rollover - 2nip -> object -> contentView window unfocus-world + 2nip -> object -> contentView + dup -> isInFullScreenMode zero? + [ window unfocus-world ] + [ drop ] if ] } diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 2cf4091937..1ca3e85232 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -556,11 +556,9 @@ M: windows-ui-backend do-events [ DispatchMessage drop ] bi ] if ; -: register-wndclassex ( -- class ) - "WNDCLASSEX" - f GetModuleHandle - class-name-ptr get-global - pick GetClassInfoEx zero? [ +:: register-window-class ( class-name-ptr -- ) + "WNDCLASSEX" f GetModuleHandle + class-name-ptr pick GetClassInfoEx 0 = [ "WNDCLASSEX" heap-size over set-WNDCLASSEX-cbSize { CS_HREDRAW CS_VREDRAW CS_OWNDC } flags over set-WNDCLASSEX-style ui-wndproc over set-WNDCLASSEX-lpfnWndProc @@ -571,9 +569,9 @@ M: windows-ui-backend do-events over set-WNDCLASSEX-hIcon f IDC_ARROW LoadCursor over set-WNDCLASSEX-hCursor - class-name-ptr get-global over set-WNDCLASSEX-lpszClassName - RegisterClassEx dup win32-error=0/f - ] when ; + class-name-ptr over set-WNDCLASSEX-lpszClassName + RegisterClassEx win32-error=0/f + ] [ drop ] if ; : adjust-RECT ( RECT -- ) style 0 ex-style AdjustWindowRectEx win32-error=0/f ; @@ -594,9 +592,16 @@ M: windows-ui-backend do-events dup adjust-RECT swap [ dup default-position-RECT ] when ; +: get-window-class ( -- class-name ) + class-name-ptr [ + dup expired? [ drop "Factor-window" utf16n malloc-string ] when + dup register-window-class + dup + ] change-global ; + : create-window ( rect -- hwnd ) make-adjusted-RECT - [ class-name-ptr get-global f ] dip + [ get-window-class f ] dip [ [ ex-style ] 2dip { WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags @@ -611,15 +616,11 @@ M: windows-ui-backend do-events : init-win32-ui ( -- ) V{ } clone nc-buttons set-global "MSG" malloc-object msg-obj set-global - "Factor-window" utf16n malloc-string class-name-ptr set-global - register-wndclassex drop GetDoubleClickTime milliseconds double-click-timeout set-global ; : cleanup-win32-ui ( -- ) - class-name-ptr [ - [ [ f UnregisterClass drop ] [ free ] bi ] when* f - ] change-global - msg-obj change-global [ [ free ] when* f ] ; + class-name-ptr [ [ [ f UnregisterClass drop ] [ free ] bi ] when* f ] change-global + msg-obj [ [ free ] when* f ] change-global ; : get-dc ( world -- ) handle>> dup hWnd>> GetDC dup win32-error=0/f >>hDC drop ; @@ -760,8 +761,13 @@ M: windows-ui-backend (ungrab-input) ( handle -- ) [ SW_RESTORE ShowWindow win32-error=0/f ] } cleave ; -M: windows-ui-backend set-fullscreen* ( ? world -- ) - swap [ enter-fullscreen ] [ exit-fullscreen ] if ; +M: windows-ui-backend (set-fullscreen) ( ? world -- ) + [ enter-fullscreen ] [ exit-fullscreen ] if ; + +M: windows-ui-backend (fullscreen?) ( world -- ? ) + [ handle>> hWnd>> hwnd>RECT ] + [ handle>> hWnd>> fullscreen-RECT ] bi + [ get-RECT-dimensions 2array 2nip ] bi@ = ; windows-ui-backend ui-backend set-global diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor index 76fd9fa30c..aca80cbc96 100755 --- a/basis/ui/backend/x11/x11.factor +++ b/basis/ui/backend/x11/x11.factor @@ -268,10 +268,12 @@ M: x11-ui-backend set-title ( string world -- ) handle>> window>> swap [ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ; -M: x11-ui-backend set-fullscreen* ( ? world -- ) - handle>> window>> "XClientMessageEvent" - [ set-XClientMessageEvent-window ] keep - swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? +M: x11-ui-backend (set-fullscreen) ( world ? -- ) + [ + handle>> window>> "XClientMessageEvent" + [ set-XClientMessageEvent-window ] keep + ] dip + _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? over set-XClientMessageEvent-data0 ClientMessage over set-XClientMessageEvent-type dpy get over set-XClientMessageEvent-display diff --git a/basis/ui/debugger/debugger.factor b/basis/ui/debugger/debugger.factor new file mode 100755 index 0000000000..e2c8b06bdd --- /dev/null +++ b/basis/ui/debugger/debugger.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2006, 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors debugger io kernel namespaces prettyprint +ui.gadgets.panes ui.gadgets.worlds ui ; +IN: ui.debugger + +: ( error -- pane ) + [ [ print-error ] with-pane ] keep ; inline + +: error-window ( error -- ) + "Error" open-window ; + +[ error-window ] ui-error-hook set-global + +M: world-error error. + "An error occurred while drawing the world " write + dup world>> pprint-short "." print + "This world has been deactivated to prevent cascading errors." print + error>> error. ; diff --git a/basis/ui/gadgets/presentations/presentations.factor b/basis/ui/gadgets/presentations/presentations.factor old mode 100644 new mode 100755 index a0799c7b86..93a585e330 --- a/basis/ui/gadgets/presentations/presentations.factor +++ b/basis/ui/gadgets/presentations/presentations.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays accessors definitions hashtables io kernel sequences -strings words help math models namespaces quotations ui.gadgets +strings words math models namespaces quotations ui.gadgets ui.gadgets.borders ui.gadgets.buttons ui.gadgets.buttons.private ui.gadgets.labels ui.gadgets.menus ui.gadgets.worlds ui.gadgets.status-bar ui.commands ui.operations ui.gestures ; diff --git a/basis/ui/gadgets/worlds/worlds-docs.factor b/basis/ui/gadgets/worlds/worlds-docs.factor index d4e9790d89..c12c6b93aa 100755 --- a/basis/ui/gadgets/worlds/worlds-docs.factor +++ b/basis/ui/gadgets/worlds/worlds-docs.factor @@ -13,6 +13,17 @@ HELP: origin HELP: hand-world { $var-description "Global variable. The " { $link world } " containing the gadget at the mouse location." } ; +HELP: grab-input +{ $values { "gadget" gadget } } +{ $description "Sets the " { $link world } " containing " { $snippet "gadget" } " to grab mouse and keyboard input while focused." } +{ $notes "Normal mouse gestures may not be available while input is grabbed." } ; + +HELP: ungrab-input +{ $values { "gadget" gadget } } +{ $description "Sets the " { $link world } " containing " { $snippet "gadget" } " not to grab mouse and keyboard input while focused." } ; + +{ grab-input ungrab-input } related-words + HELP: set-title { $values { "string" string } { "world" world } } { $description "Sets the title bar of the native window containing the world." } @@ -42,6 +53,7 @@ HELP: world { { $snippet "focus" } " - the current owner of the keyboard focus in the world." } { { $snippet "focused?" } " - a boolean indicating if the native window containing the world has keyboard focus." } { { $snippet "fonts" } " - a hashtable used by the " { $link font-renderer } "." } + { { $snippet "grab-input?" } " - if set to " { $link t } ", the world will hide the mouse cursor and disable normal mouse input while focused. Use " { $link grab-input } " and " { $link ungrab-input } " to change this setting." } { { $snippet "handle" } " - a backend-specific native handle representing the native window containing the world, or " { $link f } " if the world is not grafted." } { { $snippet "window-loc" } " - the on-screen location of the native window containing the world. The co-ordinate system here is backend-specific." } } diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index eec5666f0e..38fb220c69 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -4,7 +4,7 @@ USING: accessors arrays assocs continuations kernel math models namespaces opengl opengl.textures sequences io combinators combinators.short-circuit fry math.vectors math.rectangles cache ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks -ui.commands ui.pixel-formats destructors literals ; +ui.pixel-formats destructors literals strings ; IN: ui.gadgets.worlds CONSTANT: default-world-pixel-format-attributes @@ -21,7 +21,7 @@ TUPLE: world < track TUPLE: world-attributes { world-class initial: world } grab-input? - title + { title string initial: "Factor Window" } status gadgets { pixel-format-attributes initial: $ default-world-pixel-format-attributes } ; @@ -31,6 +31,20 @@ TUPLE: world-attributes : find-world ( gadget -- world/f ) [ world? ] find-parent ; +: grab-input ( gadget -- ) + find-world dup grab-input?>> + [ drop ] [ + t >>grab-input? + dup focused?>> [ handle>> (grab-input) ] [ drop ] if + ] if ; + +: ungrab-input ( gadget -- ) + find-world dup grab-input?>> + [ + f >>grab-input? + dup focused?>> [ handle>> (ungrab-input) ] [ drop ] if + ] [ drop ] if ; + : show-status ( string/f gadget -- ) dup find-world dup [ dup status>> [ @@ -63,7 +77,7 @@ M: world request-focus-on ( child gadget -- ) : new-world ( class -- world ) vertical swap new-track t >>root? - t >>active? + f >>active? { 0 0 } >>window-loc f >>grab-input? ; @@ -87,7 +101,7 @@ M: world layout* [ call-next-method ] [ dup layers>> [ as-big-as-possible ] with each ] bi ; -M: world focusable-child* gadget-child ; +M: world focusable-child* children>> [ t ] [ first ] if-empty ; M: world children-on nip children>> ; diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor index 7e038ef2e0..073b2d5e26 100644 --- a/basis/ui/gestures/gestures.factor +++ b/basis/ui/gestures/gestures.factor @@ -3,8 +3,8 @@ USING: accessors arrays assocs kernel math math.order models namespaces make sequences words strings system hashtables math.parser math.vectors classes.tuple classes boxes calendar alarms combinators -sets columns fry deques ui.gadgets ui.gadgets.private unicode.case -unicode.categories combinators.short-circuit ; +sets columns fry deques ui.gadgets ui.gadgets.private ascii +combinators.short-circuit ; IN: ui.gestures GENERIC: handle-gesture ( gesture gadget -- ? ) @@ -296,10 +296,10 @@ HOOK: modifiers>string os ( modifiers -- string ) M: macosx modifiers>string [ { - { A+ [ "\u{place-of-interest-sign}" ] } - { M+ [ "\u{option-key}" ] } - { S+ [ "\u{upwards-white-arrow}" ] } - { C+ [ "\u{up-arrowhead}" ] } + { A+ [ "\u002318" ] } + { M+ [ "\u002325" ] } + { S+ [ "\u0021e7" ] } + { C+ [ "\u002303" ] } } case ] map "" join ; diff --git a/basis/ui/operations/operations.factor b/basis/ui/operations/operations.factor old mode 100644 new mode 100755 index db6048061e..a502707ee6 --- a/basis/ui/operations/operations.factor +++ b/basis/ui/operations/operations.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays definitions kernel ui.commands ui.gestures sequences strings math words generic namespaces -hashtables help.markup quotations assocs fry linked-assocs ; +hashtables quotations assocs fry linked-assocs ; IN: ui.operations SYMBOL: +keyboard+ diff --git a/basis/ui/pixel-formats/pixel-formats.factor b/basis/ui/pixel-formats/pixel-formats.factor index 52abf44362..a280ab0666 100644 --- a/basis/ui/pixel-formats/pixel-formats.factor +++ b/basis/ui/pixel-formats/pixel-formats.factor @@ -1,6 +1,6 @@ USING: accessors assocs classes destructors functors kernel lexer math parser sequences specialized-arrays.int ui.backend -words.symbol ; +words ; IN: ui.pixel-formats SYMBOLS: @@ -71,7 +71,7 @@ GENERIC: >PFA ( attribute -- pfas ) M: object >PFA drop { } ; -M: symbol >PFA +M: word >PFA TABLE at [ { } ] unless* ; M: pixel-format-attribute >PFA dup class TABLE at diff --git a/basis/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor old mode 100644 new mode 100755 index 42666ab064..4d6960306c --- a/basis/ui/tools/debugger/debugger.factor +++ b/basis/ui/tools/debugger/debugger.factor @@ -8,7 +8,7 @@ ui.gadgets.buttons ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.tables ui.gadgets.tracks ui.gadgets.scrollers ui.gadgets.panes ui.gadgets.borders ui.gadgets.status-bar ui.tools.traceback -ui.tools.inspector ui.tools.browser ; +ui.tools.inspector ui.tools.browser ui.debugger ; IN: ui.tools.debugger TUPLE: debugger < track error restarts restart-hook restart-list continuation ; @@ -27,9 +27,6 @@ M: restart-renderer row-columns t >>selection-required? t >>single-click? ; inline -: ( error -- pane ) - [ [ print-error ] with-pane ] keep ; inline - : ( debugger -- gadget ) [ ] dip [ error>> add-gadget ] @@ -63,7 +60,7 @@ M: debugger focusable-child* GENERIC: error-in-debugger? ( error -- ? ) -M: world-error error-in-debugger? world>> gadget-child debugger? ; +M: world-error error-in-debugger? world>> children>> [ f ] [ first debugger? ] if-empty ; M: object error-in-debugger? drop f ; @@ -72,12 +69,6 @@ M: object error-in-debugger? drop f ; [ rethrow ] [ error-continuation get debugger-window ] if ] ui-error-hook set-global -M: world-error error. - "An error occurred while drawing the world " write - dup world>> pprint-short "." print - "This world has been deactivated to prevent cascading errors." print - error>> error. ; - debugger "gestures" f { { T{ button-down } request-focus } } define-command-map diff --git a/basis/ui/tools/deploy/deploy.factor b/basis/ui/tools/deploy/deploy.factor index 6a8322ac02..d3c1278bf5 100644 --- a/basis/ui/tools/deploy/deploy.factor +++ b/basis/ui/tools/deploy/deploy.factor @@ -29,7 +29,6 @@ TUPLE: deploy-gadget < pack vocab settings ; : advanced-settings ( parent -- parent ) "Advanced:"