diff --git a/README.txt b/README.txt index addbe38f0d..a33a85b218 100755 --- a/README.txt +++ b/README.txt @@ -20,25 +20,18 @@ implementation. It is not an introduction to the language itself. * Compiling the Factor VM -The Factor runtime is written in GNU C++, and is built with GNU make and -gcc. - Factor supports various platforms. For an up-to-date list, see . -Factor requires gcc 3.4 or later. - -On x86, Factor /will not/ build using gcc 3.3 or earlier. - -If you are using gcc 4.3, you might get an unusable Factor binary unless -you add 'SITE_CFLAGS=-fno-forward-propagate' to the command-line -arguments for make. +The Factor VM is written in C++ and uses GNU extensions. When compiling +with GCC 3.x, boost::unordered_map must be installed. On GCC 4.x, Factor +uses std::tr1::unordered_map which is shipped as part of GCC. Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM. * Bootstrapping the Factor image -Once you have compiled the Factor runtime, you must bootstrap the Factor +Once you have compiled the Factor VM, you must bootstrap the Factor system using the image that corresponds to your CPU architecture. Boot images can be obtained from . @@ -97,7 +90,7 @@ When compiling Factor, pass the X11=1 parameter: Then bootstrap with the following switches: - ./factor -i=boot..image -ui-backend=x11 -ui-text-backend=pango + ./factor -i=boot..image -ui-backend=x11 Now if $DISPLAY is set, running ./factor will start the UI. @@ -138,7 +131,7 @@ usage documentation, enter the following in the UI listener: The Factor source tree is organized as follows: build-support/ - scripts used for compiling Factor - vm/ - sources for the Factor VM, written in C++ + vm/ - Factor VM core/ - Factor core library basis/ - Factor basis library, compiler, tools extra/ - more libraries and applications 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/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 9cd57f61ab..df5a5bbba8 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -259,8 +259,9 @@ M: long-long-type box-return ( type -- ) [ dup c-setter '[ _ [ 0 @ ] keep ] ] bi (( value -- c-ptr )) define-inline ; -: c-bool> ( int -- ? ) - 0 = not ; inline +: >c-bool ( ? -- int ) 1 0 ? ; inline + +: c-bool> ( int -- ? ) 0 = not ; inline : define-primitive-type ( type name -- ) [ typedef ] @@ -409,10 +410,10 @@ CONSTANT: primitive-types "uchar" define-primitive-type - [ alien-unsigned-4 zero? not ] >>getter - [ [ 1 0 ? ] 2dip set-alien-unsigned-4 ] >>setter - 4 >>size - 4 >>align + [ alien-unsigned-1 c-bool> ] >>getter + [ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter + 1 >>size + 1 >>align "box_boolean" >>boxer "to_boolean" >>unboxer "bool" define-primitive-type diff --git a/basis/alien/libraries/libraries.factor b/basis/alien/libraries/libraries.factor old mode 100644 new mode 100755 index 6c18065ab6..0b39bedadd --- a/basis/alien/libraries/libraries.factor +++ b/basis/alien/libraries/libraries.factor @@ -5,7 +5,7 @@ IN: alien.libraries : dlopen ( path -- dll ) native-string>alien (dlopen) ; -: dlsym ( name dll -- alien ) [ native-string>alien ] dip (dlsym) ; +: dlsym ( name dll -- alien ) [ string>symbol ] dip (dlsym) ; SYMBOL: libraries diff --git a/basis/base64/base64-tests.factor b/basis/base64/base64-tests.factor index 9094286575..e962fa7e59 100644 --- a/basis/base64/base64-tests.factor +++ b/basis/base64/base64-tests.factor @@ -4,7 +4,7 @@ IN: base64.tests [ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" ascii encode >base64 base64> ascii decode ] unit-test -[ f ] [ "" ascii encode >base64 base64> ascii decode ] unit-test +[ "" ] [ "" ascii encode >base64 base64> ascii decode ] unit-test [ "a" ] [ "a" ascii encode >base64 base64> ascii decode ] unit-test [ "ab" ] [ "ab" ascii encode >base64 base64> ascii decode ] unit-test [ "abc" ] [ "abc" ascii encode >base64 base64> ascii decode ] unit-test diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor old mode 100644 new mode 100755 index 7940703140..3aefdec29f --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -41,7 +41,7 @@ nl ! which are also quick to compile are replaced by ! compiled definitions as soon as possible. { - roll -roll declare not + not array? hashtable? vector? tuple? sbuf? tombstone? diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index cad40b6384..4a7a558703 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -9,7 +9,7 @@ classes.builtin classes.tuple classes.tuple.private vocabs vocabs.loader source-files definitions debugger quotations.private sequences.private combinators math.order math.private accessors slots.private generic.single.private compiler.units compiler.constants -fry ; +fry bootstrap.image.syntax ; IN: bootstrap.image : arch ( os cpu -- arch ) @@ -52,6 +52,9 @@ GENERIC: (eql?) ( obj1 obj2 -- ? ) M: integer (eql?) = ; +M: float (eql?) + over float? [ fp-bitwise= ] [ 2drop f ] if ; + M: sequence (eql?) over sequence? [ 2dup [ length ] bi@ = @@ -93,24 +96,19 @@ CONSTANT: -1-offset 9 SYMBOL: sub-primitives -SYMBOL: jit-define-rc -SYMBOL: jit-define-rt -SYMBOL: jit-define-offset +SYMBOL: jit-relocations -: compute-offset ( -- offset ) - building get length jit-define-rc get rc-absolute-cell = bootstrap-cell 4 ? - ; +: compute-offset ( rc -- offset ) + [ building get length ] dip rc-absolute-cell = bootstrap-cell 4 ? - ; : jit-rel ( rc rt -- ) - jit-define-rt set - jit-define-rc set - compute-offset jit-define-offset set ; + over compute-offset 3array jit-relocations get push-all ; -: make-jit ( quot -- quad ) +: make-jit ( quot -- jit-data ) [ + V{ } clone jit-relocations set call( -- ) - jit-define-rc get - jit-define-rt get - jit-define-offset get 3array + jit-relocations get >array ] B{ } make prefix ; : jit-define ( quot name -- ) @@ -128,98 +126,59 @@ SYMBOL: big-endian ! Bootstrap architecture name SYMBOL: architecture -! Bootstrap global namesapce -SYMBOL: bootstrap-global +RESET ! Boot quotation, set in stage1.factor -SYMBOL: bootstrap-boot-quot +USERENV: bootstrap-boot-quot 20 + +! Bootstrap global namesapce +USERENV: bootstrap-global 21 ! JIT parameters -SYMBOL: jit-prolog -SYMBOL: jit-primitive-word -SYMBOL: jit-primitive -SYMBOL: jit-word-jump -SYMBOL: jit-word-call -SYMBOL: jit-push-immediate -SYMBOL: jit-if-word -SYMBOL: jit-if-1 -SYMBOL: jit-if-2 -SYMBOL: jit-dip-word -SYMBOL: jit-dip -SYMBOL: jit-2dip-word -SYMBOL: jit-2dip -SYMBOL: jit-3dip-word -SYMBOL: jit-3dip -SYMBOL: jit-execute-word -SYMBOL: jit-execute-jump -SYMBOL: jit-execute-call -SYMBOL: jit-epilog -SYMBOL: jit-return -SYMBOL: jit-profiling -SYMBOL: jit-save-stack +USERENV: jit-prolog 23 +USERENV: jit-primitive-word 24 +USERENV: jit-primitive 25 +USERENV: jit-word-jump 26 +USERENV: jit-word-call 27 +USERENV: jit-word-special 28 +USERENV: jit-if-word 29 +USERENV: jit-if 30 +USERENV: jit-epilog 31 +USERENV: jit-return 32 +USERENV: jit-profiling 33 +USERENV: jit-push-immediate 34 +USERENV: jit-dip-word 35 +USERENV: jit-dip 36 +USERENV: jit-2dip-word 37 +USERENV: jit-2dip 38 +USERENV: jit-3dip-word 39 +USERENV: jit-3dip 40 +USERENV: jit-execute-word 41 +USERENV: jit-execute-jump 42 +USERENV: jit-execute-call 43 ! PIC stubs -SYMBOL: pic-load -SYMBOL: pic-tag -SYMBOL: pic-hi-tag -SYMBOL: pic-tuple -SYMBOL: pic-hi-tag-tuple -SYMBOL: pic-check-tag -SYMBOL: pic-check -SYMBOL: pic-hit -SYMBOL: pic-miss-word +USERENV: pic-load 47 +USERENV: pic-tag 48 +USERENV: pic-hi-tag 49 +USERENV: pic-tuple 50 +USERENV: pic-hi-tag-tuple 51 +USERENV: pic-check-tag 52 +USERENV: pic-check 53 +USERENV: pic-hit 54 +USERENV: pic-miss-word 55 +USERENV: pic-miss-tail-word 56 ! Megamorphic dispatch -SYMBOL: mega-lookup -SYMBOL: mega-lookup-word -SYMBOL: mega-miss-word +USERENV: mega-lookup 57 +USERENV: mega-lookup-word 58 +USERENV: mega-miss-word 59 ! Default definition for undefined words -SYMBOL: undefined-quot - -: userenvs ( -- assoc ) - H{ - { bootstrap-boot-quot 20 } - { bootstrap-global 21 } - { jit-prolog 23 } - { jit-primitive-word 24 } - { jit-primitive 25 } - { jit-word-jump 26 } - { jit-word-call 27 } - { jit-if-word 28 } - { jit-if-1 29 } - { jit-if-2 30 } - { jit-epilog 33 } - { jit-return 34 } - { jit-profiling 35 } - { jit-push-immediate 36 } - { jit-save-stack 38 } - { jit-dip-word 39 } - { jit-dip 40 } - { jit-2dip-word 41 } - { jit-2dip 42 } - { jit-3dip-word 43 } - { jit-3dip 44 } - { jit-execute-word 45 } - { jit-execute-jump 46 } - { jit-execute-call 47 } - { pic-load 48 } - { pic-tag 49 } - { pic-hi-tag 50 } - { pic-tuple 51 } - { pic-hi-tag-tuple 52 } - { pic-check-tag 53 } - { pic-check 54 } - { pic-hit 55 } - { pic-miss-word 56 } - { mega-lookup 57 } - { mega-lookup-word 58 } - { mega-miss-word 59 } - { undefined-quot 60 } - } ; inline +USERENV: undefined-quot 60 : userenv-offset ( symbol -- n ) - userenvs at header-size + ; + userenvs get at header-size + ; : emit ( cell -- ) image get push ; @@ -351,7 +310,8 @@ M: f ' [ vocabulary>> , ] [ def>> , ] [ props>> , ] - [ direct-entry-def>> , ] ! direct-entry-def + [ pic-def>> , ] + [ pic-tail-def>> , ] [ drop 0 , ] ! count [ word-sub-primitive , ] [ drop 0 , ] ! xt @@ -488,7 +448,6 @@ M: quotation ' array>> ' quotation [ emit ! array - f ' emit ! compiled f ' emit ! cached-effect f ' emit ! cache-counter 0 emit ! xt @@ -510,11 +469,7 @@ M: quotation ' class<=-cache class-not-cache classes-intersect-cache class-and-cache class-or-cache next-method-quot-cache } [ H{ } clone ] H{ } map>assoc assoc-union - bootstrap-global set - bootstrap-global emit-userenv ; - -: emit-boot-quot ( -- ) - bootstrap-boot-quot emit-userenv ; + bootstrap-global set ; : emit-jit-data ( -- ) \ if jit-if-word set @@ -524,46 +479,13 @@ M: quotation ' \ 3dip jit-3dip-word set \ (execute) jit-execute-word set \ inline-cache-miss \ pic-miss-word set + \ inline-cache-miss-tail \ pic-miss-tail-word set \ mega-cache-lookup \ mega-lookup-word set \ mega-cache-miss \ mega-miss-word set - [ undefined ] undefined-quot set - { - jit-prolog - jit-primitive-word - jit-primitive - jit-word-jump - jit-word-call - jit-push-immediate - jit-if-word - jit-if-1 - jit-if-2 - jit-dip-word - jit-dip - jit-2dip-word - jit-2dip - jit-3dip-word - jit-3dip - jit-execute-word - jit-execute-jump - jit-execute-call - jit-epilog - jit-return - jit-profiling - jit-save-stack - pic-load - pic-tag - pic-hi-tag - pic-tuple - pic-hi-tag-tuple - pic-check-tag - pic-check - pic-hit - pic-miss-word - mega-lookup - mega-lookup-word - mega-miss-word - undefined-quot - } [ emit-userenv ] each ; + [ undefined ] undefined-quot set ; + +: emit-userenvs ( -- ) + userenvs get keys [ emit-userenv ] each ; : fixup-header ( -- ) heap-size data-heap-size-offset fixup ; @@ -580,8 +502,8 @@ M: quotation ' emit-jit-data "Serializing global namespace..." print flush emit-global - "Serializing boot quotation..." print flush - emit-boot-quot + "Serializing user environment..." print flush + emit-userenvs "Performing word fixups..." print flush fixup-words "Performing header fixups..." print flush diff --git a/basis/bootstrap/image/syntax/authors.txt b/basis/bootstrap/image/syntax/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/bootstrap/image/syntax/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/bootstrap/image/syntax/syntax.factor b/basis/bootstrap/image/syntax/syntax.factor new file mode 100644 index 0000000000..29dc09717a --- /dev/null +++ b/basis/bootstrap/image/syntax/syntax.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: parser kernel namespaces assocs words.symbol ; +IN: bootstrap.image.syntax + +SYMBOL: userenvs + +SYNTAX: RESET H{ } clone userenvs set-global ; + +SYNTAX: USERENV: + CREATE-WORD scan-word + [ swap userenvs get set-at ] + [ drop define-symbol ] + 2bi ; \ No newline at end of file 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/checksums/common/common.factor b/basis/checksums/common/common.factor index 0ae4328446..76675f9413 100644 --- a/basis/checksums/common/common.factor +++ b/basis/checksums/common/common.factor @@ -9,6 +9,9 @@ SYMBOL: bytes-read : calculate-pad-length ( length -- length' ) [ 56 < 55 119 ? ] keep - ; +: calculate-pad-length-long ( length -- length' ) + [ 120 < 119 247 ? ] keep - ; + : pad-last-block ( str big-endian? length -- str ) [ [ % ] 2dip HEX: 80 , diff --git a/basis/checksums/sha2/sha2-tests.factor b/basis/checksums/sha2/sha2-tests.factor index 2f4e3c51c4..c14ea5a98d 100644 --- a/basis/checksums/sha2/sha2-tests.factor +++ b/basis/checksums/sha2/sha2-tests.factor @@ -1,7 +1,42 @@ -USING: arrays kernel math namespaces sequences tools.test checksums.sha2 checksums ; -[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" sha-256 checksum-bytes hex-string ] unit-test -[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" sha-256 checksum-bytes hex-string ] unit-test -[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" sha-256 checksum-bytes hex-string ] unit-test -[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" sha-256 checksum-bytes hex-string ] unit-test -[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" sha-256 checksum-bytes hex-string ] unit-test -[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" sha-256 checksum-bytes hex-string ] unit-test +USING: arrays kernel math namespaces sequences tools.test +checksums.sha2 checksums ; +IN: checksums.sha2.tests + +: test-checksum ( text identifier -- checksum ) + checksum-bytes hex-string ; + +[ "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525" ] +[ + "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" + sha-224 test-checksum +] unit-test + +[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] +[ "" sha-256 test-checksum ] unit-test + +[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] +[ "abc" sha-256 test-checksum ] unit-test + +[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] +[ "message digest" sha-256 test-checksum ] unit-test + +[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] +[ "abcdefghijklmnopqrstuvwxyz" sha-256 test-checksum ] unit-test + +[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] +[ + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" + sha-256 test-checksum +] unit-test + +[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] +[ + "12345678901234567890123456789012345678901234567890123456789012345678901234567890" + sha-256 test-checksum +] unit-test + + + + +! [ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ] +! [ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index 3b092a78de..12e32f6c69 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -2,12 +2,27 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel splitting grouping math sequences namespaces make io.binary math.bitwise checksums checksums.common -sbufs strings ; +sbufs strings combinators.smart math.ranges fry combinators +accessors locals ; IN: checksums.sha2 - ] map block-size get 0 pad-tail - dup 16 64 dup [ - process-M-256 - ] with each ; - -: ch ( x y z -- x' ) - [ bitxor bitand ] keep bitxor ; - -: maj ( x y z -- x' ) - [ [ bitand ] 2keep bitor ] dip bitand bitor ; + [ + [ -17 bitroll-32 ] + [ -19 bitroll-32 ] + [ -10 shift ] tri + ] [ bitxor ] reduce-outputs ; inline : S0-256 ( x -- x' ) - [ -2 bitroll-32 ] keep - [ -13 bitroll-32 ] keep - -22 bitroll-32 bitxor bitxor ; inline + [ + [ -2 bitroll-32 ] + [ -13 bitroll-32 ] + [ -22 bitroll-32 ] tri + ] [ bitxor ] reduce-outputs ; inline : S1-256 ( x -- x' ) - [ -6 bitroll-32 ] keep - [ -11 bitroll-32 ] keep - -25 bitroll-32 bitxor bitxor ; inline + [ + [ -6 bitroll-32 ] + [ -11 bitroll-32 ] + [ -25 bitroll-32 ] tri + ] [ bitxor ] reduce-outputs ; inline -: slice3 ( n seq -- a b c ) [ dup 3 + ] dip first3 ; inline +: s0-512 ( x -- x' ) + [ + [ -1 bitroll-64 ] + [ -8 bitroll-64 ] + [ -7 shift ] tri + ] [ bitxor ] reduce-outputs ; inline -: T1 ( W n -- T1 ) - [ swap nth ] keep - K get nth + - e vars get slice3 ch + - e vars get nth S1-256 + - h vars get nth w+ ; +: s1-512 ( x -- x' ) + [ + [ -19 bitroll-64 ] + [ -61 bitroll-64 ] + [ -6 shift ] tri + ] [ bitxor ] reduce-outputs ; inline -: T2 ( -- T2 ) - a vars get nth S0-256 - a vars get slice3 maj w+ ; +: S0-512 ( x -- x' ) + [ + [ -28 bitroll-64 ] + [ -34 bitroll-64 ] + [ -39 bitroll-64 ] tri + ] [ bitxor ] reduce-outputs ; inline -: update-vars ( T1 T2 -- ) - vars get +: S1-512 ( x -- x' ) + [ + [ -14 bitroll-64 ] + [ -18 bitroll-64 ] + [ -41 bitroll-64 ] tri + ] [ bitxor ] reduce-outputs ; inline + +: process-M-256 ( n seq -- ) + { + [ [ 16 - ] dip nth ] + [ [ 15 - ] dip nth s0-256 ] + [ [ 7 - ] dip nth ] + [ [ 2 - ] dip nth s1-256 w+ w+ w+ ] + [ ] + } 2cleave set-nth ; inline + +: process-M-512 ( n seq -- ) + { + [ [ 16 - ] dip nth ] + [ [ 15 - ] dip nth s0-512 ] + [ [ 7 - ] dip nth ] + [ [ 2 - ] dip nth s1-512 w+ w+ w+ ] + [ ] + } 2cleave set-nth ; inline + +: ch ( x y z -- x' ) + [ bitxor bitand ] keep bitxor ; inline + +: maj ( x y z -- x' ) + [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; inline + +: slice3 ( n seq -- a b c ) + [ dup 3 + ] dip first3 ; inline + +GENERIC: pad-initial-bytes ( string sha2 -- padded-string ) + +M: sha2-short pad-initial-bytes ( string sha2 -- padded-string ) + drop + dup [ + HEX: 80 , + length + [ 64 mod calculate-pad-length 0 % ] + [ 3 shift 8 >be % ] bi + ] "" make append ; + +M: sha2-long pad-initial-bytes ( string sha2 -- padded-string ) + drop dup [ + HEX: 80 , + length + [ 128 mod calculate-pad-length-long 0 % ] + [ 3 shift 8 >be % ] bi + ] "" make append ; + +: seq>byte-array ( seq n -- string ) + '[ _ >be ] map B{ } join ; + +:: T1-256 ( n M H sha2 -- T1 ) + n M nth + n sha2 K>> nth + + e H slice3 ch w+ + e H nth S1-256 w+ + h H nth w+ ; inline + +: T2-256 ( H -- T2 ) + [ a swap nth S0-256 ] + [ a swap slice3 maj w+ ] bi ; inline + +:: T1-512 ( n M H sha2 -- T1 ) + n M nth + n sha2 K>> nth + + e H slice3 ch w+ + e H nth S1-512 w+ + h H nth w+ ; inline + +: T2-512 ( H -- T2 ) + [ a swap nth S0-512 ] + [ a swap slice3 maj w+ ] bi ; inline + +: update-H ( T1 T2 H -- ) h g pick exchange g f pick exchange f e pick exchange @@ -105,42 +251,56 @@ CONSTANT: h 7 d c pick exchange c b pick exchange b a pick exchange - [ w+ a ] dip set-nth ; + [ w+ a ] dip set-nth ; inline -: process-chunk ( M -- ) - H get clone vars set - prepare-message-schedule block-size get [ - T1 T2 update-vars - ] with each vars get H get [ w+ ] 2map H set ; +: prepare-message-schedule ( seq sha2 -- w-seq ) + [ word-size>> [ be> ] map ] + [ + block-size>> [ 0 pad-tail 16 ] keep [a,b) over + '[ _ process-M-256 ] each + ] bi ; inline -: seq>byte-array ( n seq -- string ) - [ swap [ >be % ] curry each ] B{ } make ; +:: process-chunk ( M block-size cloned-H sha2 -- ) + block-size [ + M cloned-H sha2 T1-256 + cloned-H T2-256 + cloned-H update-H + ] each + cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline -: preprocess-plaintext ( string big-endian? -- padded-string ) - #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits - [ >sbuf ] dip over [ - HEX: 80 , - dup length HEX: 3f bitand - calculate-pad-length 0 % - length 3 shift 8 rot [ >be ] [ >le ] if % - ] "" make over push-all ; +: sha2-steps ( sliced-groups state -- ) + '[ + _ + [ prepare-message-schedule ] + [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi + ] each ; -: byte-array>sha2 ( byte-array -- string ) - t preprocess-plaintext - block-size get group [ process-chunk ] each - 4 H get seq>byte-array ; +: byte-array>sha2 ( bytes state -- ) + [ [ pad-initial-bytes ] [ nip block-size>> ] 2bi ] + [ sha2-steps ] bi ; + +: ( -- sha2-state ) + sha-224-state new + K-256 >>K + initial-H-224 >>H + 4 >>word-size + 64 >>block-size ; + +: ( -- sha2-state ) + sha-256-state new + K-256 >>K + initial-H-256 >>H + 4 >>word-size + 64 >>block-size ; PRIVATE> -SINGLETON: sha-256 - -INSTANCE: sha-256 checksum +M: sha-224 checksum-bytes + drop + [ byte-array>sha2 ] + [ H>> 7 head 4 seq>byte-array ] bi ; M: sha-256 checksum-bytes - drop [ - K-256 K set - initial-H-256 H set - 4 word-size set - 64 block-size set - byte-array>sha2 - ] with-scope ; + drop + [ byte-array>sha2 ] + [ H>> 4 seq>byte-array ] bi ; 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/application/application.factor b/basis/cocoa/application/application.factor index 8b33986fc2..66093645c1 100644 --- a/basis/cocoa/application/application.factor +++ b/basis/cocoa/application/application.factor @@ -14,7 +14,7 @@ NSApplicationDelegateReplyCancel NSApplicationDelegateReplyFailure ; : with-autorelease-pool ( quot -- ) - NSAutoreleasePool -> new slip -> release ; inline + NSAutoreleasePool -> new [ call ] [ -> release ] bi* ; inline : NSApp ( -- app ) NSApplication -> sharedApplication ; diff --git a/basis/cocoa/cocoa.factor b/basis/cocoa/cocoa.factor index 3e933e6643..b78bb020d0 100644 --- a/basis/cocoa/cocoa.factor +++ b/basis/cocoa/cocoa.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006 Slava Pestov +! Copyright (C) 2006, 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: compiler io kernel cocoa.runtime cocoa.subclassing cocoa.messages cocoa.types sequences words vocabs parser @@ -27,22 +27,16 @@ SYMBOL: frameworks frameworks [ V{ } clone ] initialize -[ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook +[ frameworks get [ load-framework ] each ] "cocoa" add-init-hook SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ; SYNTAX: IMPORT: scan [ ] import-objc-class ; -"Compiling Objective C bridge..." print +"Importing Cocoa classes..." print "cocoa.classes" create-vocab drop -{ - "cocoa" "cocoa.runtime" "cocoa.messages" "cocoa.subclassing" -} [ words ] map concat compile - -"Importing Cocoa classes..." print - [ { "NSApplication" 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/cocoa/plists/plists.factor b/basis/cocoa/plists/plists.factor index 31b59a6eac..ceb097bb3a 100644 --- a/basis/cocoa/plists/plists.factor +++ b/basis/cocoa/plists/plists.factor @@ -4,7 +4,7 @@ USING: strings arrays hashtables assocs sequences fry macros cocoa.messages cocoa.classes cocoa.application cocoa kernel namespaces io.backend math cocoa.enumeration byte-arrays -combinators alien.c-types words core-foundation +combinators alien.c-types words core-foundation quotations core-foundation.data core-foundation.utilities ; IN: cocoa.plists @@ -41,10 +41,16 @@ DEFER: plist> *void* [ -> release "read-plist failed" throw ] when* ; MACRO: objc-class-case ( alist -- quot ) - [ [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip ] assoc-map '[ _ cond ] ; + [ + dup callable? + [ first2 [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip 2array ] + unless + ] map '[ _ cond ] ; PRIVATE> +ERROR: invalid-plist-object object ; + : plist> ( plist -- value ) { { NSString [ (plist-NSString>) ] } @@ -53,6 +59,7 @@ PRIVATE> { NSArray [ (plist-NSArray>) ] } { NSDictionary [ (plist-NSDictionary>) ] } { NSObject [ ] } + [ invalid-plist-object ] } objc-class-case ; : read-plist ( path -- assoc ) 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/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 826fa87b73..c7b67b72b4 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -88,7 +88,7 @@ M: ##call generate-insn word>> dup sub-primitive>> [ first % ] [ [ add-call ] [ %call ] bi ] ?if ; -M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ; +M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ; M: ##return generate-insn drop %return ; @@ -444,8 +444,7 @@ TUPLE: callback-context ; : do-callback ( quot token -- ) init-catchstack - dup 2 setenv - slip + [ 2 setenv call ] keep wait-to-return ; inline : callback-return-quot ( ctype -- quot ) diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index 99f258d93c..d0c874feb0 100755 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/basis/compiler/codegen/fixup/fixup.factor @@ -56,8 +56,11 @@ SYMBOL: literal-table : rel-word ( word class -- ) [ add-literal ] dip rt-xt rel-fixup ; -: rel-word-direct ( word class -- ) - [ add-literal ] dip rt-xt-direct rel-fixup ; +: rel-word-pic ( word class -- ) + [ add-literal ] dip rt-xt-pic rel-fixup ; + +: rel-word-pic-tail ( word class -- ) + [ add-literal ] dip rt-xt-pic-tail rel-fixup ; : rel-primitive ( word class -- ) [ def>> first add-literal ] dip rt-primitive rel-fixup ; diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index e418f0ef60..01e58461ff 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -112,19 +112,18 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ; } cond ; : optimize? ( word -- ? ) - { - [ predicate-engine-word? ] - [ contains-breakpoints? ] - [ single-generic? ] - } 1|| not ; + { [ predicate-engine-word? ] [ single-generic? ] } 1|| not ; + +: contains-breakpoints? ( -- ? ) + dependencies get keys [ "break?" word-prop ] any? ; : frontend ( word -- nodes ) #! If the word contains breakpoints, don't optimize it, since #! the walker does not support this. - dup optimize? - [ [ build-tree ] [ deoptimize ] recover optimize-tree ] - [ dup def>> deoptimize-with ] - if ; + dup optimize? [ + [ [ build-tree ] [ deoptimize ] recover optimize-tree ] keep + contains-breakpoints? [ nip dup def>> deoptimize-with ] [ drop ] if + ] [ dup def>> deoptimize-with ] if ; : compile-dependency ( word -- ) #! If a word calls an unoptimized word, try to compile the callee. diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index 2f0494b58a..b795862970 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel layouts system strings words quotations byte-arrays -alien arrays ; +alien arrays literals sequences ; IN: compiler.constants ! These constants must match vm/memory.h @@ -14,42 +14,42 @@ CONSTANT: deck-bits 18 : float-offset ( -- n ) 8 float tag-number - ; inline : string-offset ( -- n ) 4 bootstrap-cells string tag-number - ; inline : string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline -: profile-count-offset ( -- n ) 7 bootstrap-cells \ word tag-number - ; inline +: profile-count-offset ( -- n ) 8 bootstrap-cells \ word tag-number - ; inline : byte-array-offset ( -- n ) 2 bootstrap-cells byte-array tag-number - ; inline : alien-offset ( -- n ) 3 bootstrap-cells alien tag-number - ; inline : underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline : tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline -: word-xt-offset ( -- n ) 9 bootstrap-cells \ word tag-number - ; inline -: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline -: word-code-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline +: word-xt-offset ( -- n ) 10 bootstrap-cells \ word 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 ) 5 bootstrap-cells ; inline +: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline ! Relocation classes -CONSTANT: rc-absolute-cell 0 -CONSTANT: rc-absolute 1 -CONSTANT: rc-relative 2 +CONSTANT: rc-absolute-cell 0 +CONSTANT: rc-absolute 1 +CONSTANT: rc-relative 2 CONSTANT: rc-absolute-ppc-2/2 3 -CONSTANT: rc-relative-ppc-2 4 -CONSTANT: rc-relative-ppc-3 5 -CONSTANT: rc-relative-arm-3 6 -CONSTANT: rc-indirect-arm 7 -CONSTANT: rc-indirect-arm-pc 8 +CONSTANT: rc-absolute-ppc-2 4 +CONSTANT: rc-relative-ppc-2 5 +CONSTANT: rc-relative-ppc-3 6 +CONSTANT: rc-relative-arm-3 7 +CONSTANT: rc-indirect-arm 8 +CONSTANT: rc-indirect-arm-pc 9 ! Relocation types -CONSTANT: rt-primitive 0 -CONSTANT: rt-dlsym 1 -CONSTANT: rt-dispatch 2 -CONSTANT: rt-xt 3 -CONSTANT: rt-xt-direct 4 -CONSTANT: rt-here 5 -CONSTANT: rt-this 6 -CONSTANT: rt-immediate 7 -CONSTANT: rt-stack-chain 8 -CONSTANT: rt-untagged 9 +CONSTANT: rt-primitive 0 +CONSTANT: rt-dlsym 1 +CONSTANT: rt-dispatch 2 +CONSTANT: rt-xt 3 +CONSTANT: rt-xt-pic 4 +CONSTANT: rt-xt-pic-tail 5 +CONSTANT: rt-here 6 +CONSTANT: rt-this 7 +CONSTANT: rt-immediate 8 +CONSTANT: rt-stack-chain 9 +CONSTANT: rt-untagged 10 +CONSTANT: rt-megamorphic-cache-hits 11 : rc-absolute? ( n -- ? ) - [ rc-absolute-ppc-2/2 = ] - [ rc-absolute-cell = ] - [ rc-absolute = ] - tri or or ; + ${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ; diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 42ed90d64a..f7f24433d7 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -588,3 +588,16 @@ FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ; C{ 1.0 2.0 } C{ 1.5 1.0 } ffi_test_47 ] unit-test + +! Reported by jedahu +C-STRUCT: bool-field-test + { "char*" "name" } + { "bool" "on" } + { "short" "parents" } ; + +FUNCTION: short ffi_test_48 ( bool-field-test x ) ; + +[ 123 ] [ + "bool-field-test" 123 over set-bool-field-test-parents + ffi_test_48 +] unit-test \ No newline at end of file diff --git a/basis/compiler/tests/curry.factor b/basis/compiler/tests/curry.factor index 32611ba87a..b541e19f34 100644 --- a/basis/compiler/tests/curry.factor +++ b/basis/compiler/tests/curry.factor @@ -33,7 +33,7 @@ IN: compiler.tests.curry ] unit-test : foobar ( quot: ( -- ) -- ) - dup slip swap [ foobar ] [ drop ] if ; inline recursive + [ call ] keep swap [ foobar ] [ drop ] if ; inline recursive [ ] [ [ [ f ] foobar ] compile-call ] unit-test diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index f19a950711..72618db456 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -389,4 +389,26 @@ DEFER: loop-bbb [ f ] [ \ broken-declaration optimized? ] unit-test -[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test \ No newline at end of file +[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test + +! Modular arithmetic bug +: modular-arithmetic-bug ( a -- b ) >integer 256 mod ; + +[ 1 ] [ 257 modular-arithmetic-bug ] unit-test +[ -10 ] [ -10 modular-arithmetic-bug ] unit-test + +! Optimizer needs to ignore invalid generics +GENERIC# bad-dispatch-position-test* 3 ( -- ) + +M: object bad-dispatch-position-test* ; + +: bad-dispatch-position-test ( -- ) bad-dispatch-position-test* ; + +[ 1 2 3 4 bad-dispatch-position-test ] must-fail + +[ ] [ + [ + \ bad-dispatch-position-test forget + \ bad-dispatch-position-test* forget + ] with-compilation-unit +] unit-test \ No newline at end of file diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index 37cc1f05da..00325f5a72 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -65,5 +65,3 @@ PRIVATE> ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ] with-variable ; -: contains-breakpoints? ( word -- ? ) - def>> [ word? ] filter [ "break?" word-prop ] any? ; diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor index 5f89372ebe..3d9d77ae56 100644 --- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor @@ -302,7 +302,7 @@ C: ro-box [ 0 ] [ [ 1 cons boa "x" get slot ] count-unboxed-allocations ] unit-test : impeach-node ( quot: ( node -- ) -- ) - dup slip impeach-node ; inline recursive + [ call ] keep impeach-node ; inline recursive : bleach-node ( quot: ( node -- ) -- ) [ bleach-node ] curry [ ] compose impeach-node ; inline recursive diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor index 5d6a9cdea1..6e1c32d89d 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor @@ -98,13 +98,18 @@ TUPLE: declared-fixnum { x fixnum } ; ] { mod fixnum-mod } inlined? ] unit-test - [ f ] [ [ 256 mod ] { mod fixnum-mod } inlined? ] unit-test +[ f ] [ + [ + >fixnum 256 mod + ] { mod fixnum-mod } inlined? +] unit-test + [ f ] [ [ dup 0 >= [ 256 mod ] when @@ -128,3 +133,6 @@ TUPLE: declared-fixnum { x fixnum } ; { integer } declare [ 256 rem ] map ] { mod fixnum-mod rem } inlined? ] unit-test + +[ [ >fixnum 255 fixnum-bitand ] ] +[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test \ No newline at end of file diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor index de2600f691..31939a0d22 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor @@ -2,6 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: math math.partial-dispatch namespaces sequences sets accessors assocs words kernel memoize fry combinators +combinators.short-circuit compiler.tree compiler.tree.combinators compiler.tree.def-use @@ -69,6 +70,12 @@ GENERIC: optimize-modular-arithmetic* ( node -- nodes ) : optimize->fixnum ( #call -- nodes ) dup redundant->fixnum? [ drop f ] when ; +: optimize->integer ( #call -- nodes ) + dup out-d>> first actually-used-by dup length 1 = [ + first node>> { [ #call? ] [ word>> \ >fixnum eq? ] } 1&& + [ drop { } ] when + ] [ drop ] if ; + MEMO: fixnum-coercion ( flags -- nodes ) [ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ; @@ -87,6 +94,7 @@ MEMO: fixnum-coercion ( flags -- nodes ) M: #call optimize-modular-arithmetic* dup word>> { { [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] } + { [ dup \ >integer eq? ] [ drop optimize->integer ] } { [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] } [ drop ] } cond ; diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 2a7d431314..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 -- ? ) @@ -157,11 +159,7 @@ DEFER: (flat-length) ] sum-outputs ; : should-inline? ( #call word -- ? ) - { - { [ dup contains-breakpoints? ] [ 2drop f ] } - { [ dup "inline" word-prop ] [ 2drop t ] } - [ inlining-rank 5 >= ] - } cond ; + dup inline? [ 2drop t ] [ inlining-rank 5 >= ] if ; SYMBOL: history diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index b91a1157f7..2f5c166ac5 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -148,10 +148,6 @@ most-negative-fixnum most-positive-fixnum [a,b] comparison-ops [ dup '[ _ define-comparison-constraints ] each-derived-op ] each -! generic-comparison-ops [ -! dup specific-comparison define-comparison-constraints -! ] each - ! Remove redundant comparisons : fold-comparison ( info1 info2 word -- info ) [ [ interval>> ] bi@ ] dip interval-comparison { @@ -217,6 +213,8 @@ generic-comparison-ops [ { >float float } { fixnum>float float } { bignum>float float } + + { >integer integer } } [ '[ _ @@ -228,19 +226,26 @@ generic-comparison-ops [ ] "outputs" set-word-prop ] assoc-each +: rem-custom-inlining ( #call -- quot/f ) + second value-info literal>> dup integer? + [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ; + { mod-integer-integer mod-integer-fixnum mod-fixnum-integer fixnum-mod - rem } [ [ - in-d>> second value-info >literal< - [ dup integer? [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ] when + in-d>> dup first value-info interval>> [0,inf] interval-subset? + [ rem-custom-inlining ] [ drop f ] if ] "custom-inlining" set-word-prop ] each +\ rem [ + in-d>> rem-custom-inlining +] "custom-inlining" set-word-prop + { bitand-integer-integer bitand-integer-fixnum diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index eba41dbfdf..aba8dc9eda 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -690,4 +690,7 @@ TUPLE: littledan-2 { from read-only } { to read-only } ; ! Mutable tuples with circularity should not cause problems TUPLE: circle me ; -[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test \ No newline at end of file +[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test + +! Joe found an oversight +[ V{ integer } ] [ [ >integer ] final-classes ] unit-test \ No newline at end of file diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor index 70670648b1..0d5f05fab0 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor @@ -39,7 +39,7 @@ TUPLE: empty-tuple ; ! A more complicated example : impeach-node ( quot: ( node -- ) -- ) - dup slip impeach-node ; inline recursive + [ call ] keep impeach-node ; inline recursive : bleach-node ( quot: ( node -- ) -- ) [ bleach-node ] curry [ ] compose impeach-node ; inline recursive diff --git a/basis/core-graphics/core-graphics.factor b/basis/core-graphics/core-graphics.factor index 5e95e2e36e..6612a43dca 100644 --- a/basis/core-graphics/core-graphics.factor +++ b/basis/core-graphics/core-graphics.factor @@ -105,6 +105,19 @@ CONSTANT: kCGLRendererGenericFloatID HEX: 00020400 FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ; +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 ( ) ; + be % ; : a-insn ( d a b c xo rc opcode -- ) [ { 0 1 6 11 16 21 } bitfield ] dip insn ; @@ -74,21 +73,16 @@ SYNTAX: XO1: (XO) (1) (( a s -- )) define-declared ; GENERIC# (B) 2 ( dest aa lk -- ) M: integer (B) 18 i-insn ; -M: word (B) [ 0 ] 2dip (B) rc-relative-ppc-3 rel-word ; -M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ; GENERIC: BC ( a b c -- ) M: integer BC 0 0 16 b-insn ; -M: word BC [ 0 BC ] dip rc-relative-ppc-2 rel-word ; -M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ; : CREATE-B ( -- word ) scan "B" prepend create-in ; SYNTAX: BC: CREATE-B scan-word scan-word - [ rot BC ] 2curry (( c -- )) define-declared ; + '[ [ _ _ ] dip BC ] (( c -- )) define-declared ; SYNTAX: B: CREATE-B scan-word scan-word scan-word scan-word scan-word - [ b-insn ] curry curry curry curry curry - (( bo -- )) define-declared ; + '[ _ _ _ _ _ b-insn ] (( bo -- )) define-declared ; diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 7278fd2092..b09938f4b9 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -9,8 +9,8 @@ IN: bootstrap.ppc 4 \ cell set big-endian on -CONSTANT: ds-reg 29 -CONSTANT: rs-reg 30 +CONSTANT: ds-reg 13 +CONSTANT: rs-reg 14 : factor-area-size ( -- n ) 4 bootstrap-cells ; @@ -21,46 +21,48 @@ CONSTANT: rs-reg 30 : xt-save ( -- n ) stack-frame 2 bootstrap-cells - ; [ - 0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel - 11 6 profile-count-offset LWZ + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel + 11 3 profile-count-offset LWZ 11 11 1 tag-fixnum ADDI - 11 6 profile-count-offset STW - 11 6 word-code-offset LWZ + 11 3 profile-count-offset STW + 11 3 word-code-offset LWZ 11 11 compiled-header-size ADDI 11 MTCTR BCTR ] jit-profiling jit-define [ - 0 6 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel 0 MFLR 1 1 stack-frame SUBI - 6 1 xt-save STW - stack-frame 6 LI - 6 1 next-save STW + 3 1 xt-save STW + stack-frame 3 LI + 3 1 next-save STW 0 1 lr-save stack-frame + STW ] jit-prolog jit-define [ - 0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel - 6 ds-reg 4 STWU + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel + 3 ds-reg 4 STWU ] jit-push-immediate jit-define [ - 0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel - 7 6 0 LWZ - 1 7 0 STW -] jit-save-stack jit-define - -[ - 0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel - 6 MTCTR + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel + 4 3 0 LWZ + 1 4 0 STW + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel + 3 MTCTR BCTR ] jit-primitive jit-define -[ 0 BL rc-relative-ppc-3 rt-xt-direct jit-rel ] jit-word-call jit-define +[ 0 BL rc-relative-ppc-3 rt-xt-pic jit-rel ] jit-word-call jit-define -[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-jump jit-define +[ + 0 6 LOAD32 rc-absolute-ppc-2/2 rt-here jit-rel + 0 B rc-relative-ppc-3 rt-xt-pic-tail jit-rel +] jit-word-jump jit-define + +[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-special jit-define [ 3 ds-reg 0 LWZ @@ -68,11 +70,8 @@ CONSTANT: rs-reg 30 0 3 \ f tag-number CMPI 2 BEQ 0 B rc-relative-ppc-3 rt-xt jit-rel -] jit-if-1 jit-define - -[ 0 B rc-relative-ppc-3 rt-xt jit-rel -] jit-if-2 jit-define +] jit-if jit-define : jit->r ( -- ) 4 ds-reg 0 LWZ @@ -138,6 +137,16 @@ CONSTANT: rs-reg 30 jit-3r> ] jit-3dip jit-define +: prepare-(execute) ( -- operand ) + 3 ds-reg 0 LWZ + ds-reg dup 4 SUBI + 4 3 word-xt-offset LWZ + 4 ; + +[ prepare-(execute) MTCTR BCTR ] jit-execute-jump jit-define + +[ prepare-(execute) MTLR BLRL ] jit-execute-call jit-define + [ 0 1 lr-save stack-frame + LWZ 1 1 stack-frame ADDI @@ -146,7 +155,99 @@ CONSTANT: rs-reg 30 [ BLR ] jit-return jit-define -! Sub-primitives +! ! ! Polymorphic inline caches + +! Don't touch r6 here; it's used to pass the tail call site +! address for tail PICs + +! Load a value from a stack position +[ + 4 ds-reg 0 LWZ rc-absolute-ppc-2 rt-untagged jit-rel +] pic-load jit-define + +! Tag +: load-tag ( -- ) + 4 4 tag-mask get ANDI + 4 4 tag-bits get SLWI ; + +[ load-tag ] pic-tag jit-define + +! Hi-tag +[ + 3 4 MR + load-tag + 0 4 object tag-number tag-fixnum CMPI + 2 BNE + 4 3 object tag-number neg LWZ +] pic-hi-tag jit-define + +! Tuple +[ + 3 4 MR + load-tag + 0 4 tuple tag-number tag-fixnum CMPI + 2 BNE + 4 3 tuple tag-number neg bootstrap-cell + LWZ +] pic-tuple jit-define + +! Hi-tag and tuple +[ + 3 4 MR + load-tag + ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple) + 0 4 BIN: 110 tag-fixnum CMPI + 5 BLT + ! Untag r3 + 3 3 0 0 31 tag-bits get - RLWINM + ! Set r4 to 0 for objects, and bootstrap-cell for tuples + 4 4 1 tag-fixnum ANDI + 4 4 1 SRAWI + ! Load header cell or tuple layout cell + 4 4 3 LWZX +] pic-hi-tag-tuple jit-define + +[ + 0 4 0 CMPI rc-absolute-ppc-2 rt-immediate jit-rel +] pic-check-tag jit-define + +[ + 0 5 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel + 4 0 5 CMP +] pic-check jit-define + +[ 2 BNE 0 B rc-relative-ppc-3 rt-xt jit-rel ] pic-hit jit-define + +! ! ! Megamorphic caches + +[ + ! cache = ... + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel + ! key = class + 5 4 MR + ! key &= cache.length - 1 + 5 5 mega-cache-size get 1- bootstrap-cell * ANDI + ! cache += array-start-offset + 3 3 array-start-offset ADDI + ! cache += key + 3 3 5 ADD + ! if(get(cache) == class) + 6 3 0 LWZ + 6 0 4 CMP + 10 BNE + ! megamorphic_cache_hits++ + 0 4 LOAD32 rc-absolute-ppc-2/2 rt-megamorphic-cache-hits jit-rel + 5 4 0 LWZ + 5 5 1 ADDI + 5 4 0 STW + ! ... goto get(cache + bootstrap-cell) + 3 3 4 LWZ + 3 3 word-xt-offset LWZ + 3 MTCTR + BCTR + ! fall-through on miss +] mega-lookup jit-define + +! ! ! Sub-primitives ! Quotations and words [ @@ -157,14 +258,6 @@ CONSTANT: rs-reg 30 BCTR ] \ (call) define-sub-primitive -[ - 3 ds-reg 0 LWZ - ds-reg dup 4 SUBI - 4 3 word-xt-offset LWZ - 4 MTCTR - BCTR -] \ (execute) define-sub-primitive - ! Objects [ 3 ds-reg 0 LWZ diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 85bf188bb8..dc7108b3a1 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -1,33 +1,39 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs sequences kernel combinators make math math.order math.ranges system namespaces locals layouts words -alien alien.c-types cpu.architecture cpu.ppc.assembler -compiler.cfg.registers compiler.cfg.instructions -compiler.constants compiler.codegen compiler.codegen.fixup -compiler.cfg.intrinsics compiler.cfg.stack-frame ; +alien alien.accessors alien.c-types literals cpu.architecture +cpu.ppc.assembler cpu.ppc.assembler.backend literals compiler.cfg.registers +compiler.cfg.instructions compiler.constants compiler.codegen +compiler.codegen.fixup compiler.cfg.intrinsics +compiler.cfg.stack-frame compiler.units ; IN: cpu.ppc ! PowerPC register assignments: -! r2-r27: integer vregs -! r28: integer scratch -! r29: data stack -! r30: retain stack +! r2-r12: integer vregs +! r15-r29 +! r30: integer scratch ! f0-f29: float vregs -! f30, f31: float scratch +! f30: float scratch + +! Add some methods to the assembler that are useful to us +M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ; +M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ; enable-float-intrinsics -<< \ ##integer>float t frame-required? set-word-prop -\ ##float>integer t frame-required? set-word-prop >> +<< +\ ##integer>float t frame-required? set-word-prop +\ ##float>integer t frame-required? set-word-prop +>> M: ppc machine-registers { - { int-regs T{ range f 2 26 1 } } - { double-float-regs T{ range f 0 29 1 } } + { int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] } + { double-float-regs $[ 0 29 [a,b] ] } } ; -CONSTANT: scratch-reg 28 +CONSTANT: scratch-reg 30 CONSTANT: fp-scratch-reg 30 M: ppc two-operand? f ; @@ -40,8 +46,8 @@ M: ppc %load-reference ( reg obj -- ) M: ppc %alien-global ( register symbol dll -- ) [ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ; -CONSTANT: ds-reg 29 -CONSTANT: rs-reg 30 +CONSTANT: ds-reg 13 +CONSTANT: rs-reg 14 GENERIC: loc-reg ( loc -- reg ) @@ -108,7 +114,12 @@ M: ppc stack-frame-size ( stack-frame -- i ) factor-area-size + 4 cells align ; -M: ppc %call ( label -- ) BL ; +M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ; + +M: ppc %jump ( word -- ) + 0 6 LOAD32 8 rc-absolute-ppc-2/2 rel-here + 0 B rc-relative-ppc-3 rel-word-pic-tail ; + M: ppc %jump-label ( label -- ) B ; M: ppc %return ( -- ) BLR ; @@ -120,7 +131,7 @@ M:: ppc %dispatch ( src temp offset -- ) BCTR ; M: ppc %dispatch-label ( word -- ) - 0 , rc-absolute-cell rel-word ; + B{ 0 0 0 0 } % rc-absolute-cell rel-word ; :: (%slot) ( obj slot tag temp -- reg offset ) temp slot obj ADD @@ -641,10 +652,10 @@ M: ppc %alien-callback ( quot -- ) M: ppc %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke - 13 3 MR ; + 15 3 MR ; M: ppc %alien-indirect ( -- ) - 13 MTLR BLRL ; + 15 MTLR BLRL ; M: ppc %callback-value ( ctype -- ) ! Save top of data stack @@ -702,3 +713,14 @@ USE: vocabs.loader } cond "complex-double" c-type t >>return-in-registers? drop + +[ + + [ alien-unsigned-4 c-bool> ] >>getter + [ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter + 4 >>size + 4 >>align + "box_boolean" >>boxer + "to_boolean" >>unboxer + "bool" define-primitive-type +] with-compilation-unit diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 10cd9c8657..0a0ac4a53e 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -42,11 +42,13 @@ M:: x86.32 %dispatch ( src temp offset -- ) M: x86.32 param-reg-1 EAX ; M: x86.32 param-reg-2 EDX ; +M: x86.32 pic-tail-reg EBX ; + M: x86.32 reserved-area-size 0 ; -M: x86.32 %alien-invoke (CALL) rel-dlsym ; +M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ; -M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ; +M: x86.32 %alien-invoke-tail 0 JMP rc-relative rel-dlsym ; M: x86.32 return-struct-in-registers? ( c-type -- ? ) c-type diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index be21344815..490d37ccbc 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel namespaces system cpu.x86.assembler layouts vocabs parser compiler.constants ; @@ -26,10 +26,8 @@ IN: bootstrap.x86 temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel ! save stack pointer temp0 [] stack-reg MOV -] jit-save-stack jit-define - -[ - (JMP) drop rc-relative rt-primitive jit-rel + ! call the primitive + 0 JMP rc-relative rt-primitive jit-rel ] jit-primitive jit-define << "vocab:cpu/x86/bootstrap.factor" parse-file parsed >> diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 8cc69958a4..ad1b487e44 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -39,6 +39,8 @@ M: x86.64 param-reg-1 int-regs param-regs first ; M: x86.64 param-reg-2 int-regs param-regs second ; : param-reg-3 ( -- reg ) int-regs param-regs third ; inline +M: x86.64 pic-tail-reg RBX ; + M: int-regs return-reg drop RAX ; M: float-regs return-reg drop XMM0 ; diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index 8d1ed086e7..c5c7e63dbc 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel namespaces system cpu.x86.assembler layouts vocabs parser compiler.constants math ; @@ -25,9 +25,6 @@ IN: bootstrap.x86 temp0 temp0 [] MOV ! save stack pointer temp0 [] stack-reg MOV -] jit-save-stack jit-define - -[ ! load XT temp1 0 MOV rc-absolute-cell rt-primitive jit-rel ! go diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 5560d17a1e..2b40aa2053 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -1,12 +1,11 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays cpu.architecture compiler.constants -compiler.codegen.fixup io.binary kernel combinators -kernel.private math namespaces make sequences words system -layouts math.order accessors cpu.x86.assembler.syntax ; +USING: arrays io.binary kernel combinators +kernel.private math namespaces make sequences words system layouts +math.order accessors cpu.x86.assembler.syntax ; IN: cpu.x86.assembler -! A postfix assembler for x86 and AMD64. +! A postfix assembler for x86-32 and x86-64. ! In 32-bit mode, { 1234 } is absolute indirect addressing. ! In 64-bit mode, { 1234 } is RIP-relative. @@ -296,36 +295,23 @@ M: operand (MOV-I) { BIN: 000 t HEX: c6 } pick byte? [ immediate-1 ] [ immediate-4 ] if ; -PREDICATE: callable < word register? not ; - GENERIC: MOV ( dst src -- ) M: immediate MOV swap (MOV-I) ; -M: callable MOV [ 0 ] 2dip (MOV-I) rc-absolute-cell rel-word ; M: operand MOV HEX: 88 2-operand ; : LEA ( dst src -- ) swap HEX: 8d 2-operand ; ! Control flow GENERIC: JMP ( op -- ) -: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ; -M: f JMP (JMP) 2drop ; -M: callable JMP (JMP) rel-word ; -M: label JMP (JMP) label-fixup ; +M: integer JMP HEX: e9 , 4, ; M: operand JMP { BIN: 100 t HEX: ff } 1-operand ; GENERIC: CALL ( op -- ) -: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ; -M: f CALL (CALL) 2drop ; -M: callable CALL (CALL) rel-word-direct ; -M: label CALL (CALL) label-fixup ; +M: integer CALL HEX: e8 , 4, ; M: operand CALL { BIN: 010 t HEX: ff } 1-operand ; GENERIC# JUMPcc 1 ( addr opcode -- ) -: (JUMPcc) ( addr n -- rel-class ) extended-opcode, 4, rc-relative ; -M: f JUMPcc [ 0 ] dip (JUMPcc) 2drop ; -M: integer JUMPcc (JUMPcc) drop ; -M: callable JUMPcc [ 0 ] dip (JUMPcc) rel-word ; -M: label JUMPcc [ 0 ] dip (JUMPcc) label-fixup ; +M: integer JUMPcc extended-opcode, 4, ; : JO ( dst -- ) HEX: 80 JUMPcc ; : JNO ( dst -- ) HEX: 81 JUMPcc ; diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 4fe5e5cd33..474ce2ea46 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -42,13 +42,18 @@ big-endian off ] jit-push-immediate jit-define [ - f JMP rc-relative rt-xt jit-rel + temp3 0 MOV rc-absolute-cell rt-here jit-rel + 0 JMP rc-relative rt-xt-pic-tail jit-rel ] jit-word-jump jit-define [ - f CALL rc-relative rt-xt-direct jit-rel + 0 CALL rc-relative rt-xt-pic jit-rel ] jit-word-call jit-define +[ + 0 JMP rc-relative rt-xt jit-rel +] jit-word-special jit-define + [ ! load boolean temp0 ds-reg [] MOV @@ -57,13 +62,10 @@ big-endian off ! compare boolean with f temp0 \ f tag-number CMP ! jump to true branch if not equal - f JNE rc-relative rt-xt jit-rel -] jit-if-1 jit-define - -[ + 0 JNE rc-relative rt-xt jit-rel ! jump to false branch if equal - f JMP rc-relative rt-xt jit-rel -] jit-if-2 jit-define + 0 JMP rc-relative rt-xt jit-rel +] jit-if jit-define : jit->r ( -- ) rs-reg bootstrap-cell ADD @@ -115,19 +117,19 @@ big-endian off [ jit->r - f CALL rc-relative rt-xt jit-rel + 0 CALL rc-relative rt-xt jit-rel jit-r> ] jit-dip jit-define [ jit-2>r - f CALL rc-relative rt-xt jit-rel + 0 CALL rc-relative rt-xt jit-rel jit-2r> ] jit-2dip jit-define [ jit-3>r - f CALL rc-relative rt-xt jit-rel + 0 CALL rc-relative rt-xt jit-rel jit-3r> ] jit-3dip jit-define @@ -152,8 +154,7 @@ big-endian off ! ! ! Polymorphic inline caches -! temp0 contains the object being dispatched on -! temp1 contains its class +! The PIC and megamorphic code stubs are not permitted to touch temp3. ! Load a value from a stack position [ @@ -197,7 +198,7 @@ big-endian off [ ! Untag temp0 temp0 tag-mask get bitnot AND - ! Set temp1 to 0 for objects, and 8 for tuples + ! Set temp1 to 0 for objects, and bootstrap-cell for tuples temp1 1 tag-fixnum AND bootstrap-cell 4 = [ temp1 1 SHR ] when ! Load header cell or tuple layout cell @@ -214,7 +215,7 @@ big-endian off temp1 temp2 CMP ] pic-check jit-define -[ f JE rc-relative rt-xt jit-rel ] pic-hit jit-define +[ 0 JE rc-relative rt-xt jit-rel ] pic-hit jit-define ! ! ! Megamorphic caches @@ -232,12 +233,13 @@ big-endian off temp0 temp2 ADD ! if(get(cache) == class) temp0 [] temp1 CMP - ! ... goto get(cache + bootstrap-cell) - [ - temp0 temp0 bootstrap-cell [+] MOV - temp0 word-xt-offset [+] JMP - ] [ ] make - [ length JNE ] [ % ] bi + bootstrap-cell 4 = 14 22 ? JNE ! Yuck! + ! megamorphic_cache_hits++ + temp1 0 MOV rc-absolute-cell rt-megamorphic-cache-hits jit-rel + temp1 [] 1 ADD + ! goto get(cache + bootstrap-cell) + temp0 temp0 bootstrap-cell [+] MOV + temp0 word-xt-offset [+] JMP ! fall-through on miss ] mega-lookup jit-define diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 2859e71be2..e12cec9738 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -11,6 +11,10 @@ IN: cpu.x86 << enable-fixnum-log2 >> +! Add some methods to the assembler to be more useful to the backend +M: label JMP 0 JMP rc-relative label-fixup ; +M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ; + M: x86 two-operand? t ; HOOK: temp-reg-1 cpu ( -- reg ) @@ -19,6 +23,8 @@ HOOK: temp-reg-2 cpu ( -- reg ) HOOK: param-reg-1 cpu ( -- reg ) HOOK: param-reg-2 cpu ( -- reg ) +HOOK: pic-tail-reg cpu ( -- reg ) + M: x86 %load-immediate MOV ; M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ; @@ -53,8 +59,18 @@ M: x86 stack-frame-size ( stack-frame -- i ) reserved-area-size + align-stack ; -M: x86 %call ( label -- ) CALL ; -M: x86 %jump-label ( label -- ) JMP ; +M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ; + +: xt-tail-pic-offset ( -- n ) + #! See the comment in vm/cpu-x86.hpp + cell 4 + 1 + ; inline + +M: x86 %jump ( word -- ) + pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here + 0 JMP rc-relative rel-word-pic-tail ; + +M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ; + M: x86 %return ( -- ) 0 RET ; : code-alignment ( align -- n ) diff --git a/basis/dlists/dlists-docs.factor b/basis/dlists/dlists-docs.factor index 12e39746c7..e210ad35ce 100755 --- a/basis/dlists/dlists-docs.factor +++ b/basis/dlists/dlists-docs.factor @@ -15,6 +15,7 @@ $nl "Iterating over elements:" { $subsection dlist-each } { $subsection dlist-find } +{ $subsection dlist-filter } { $subsection dlist-any? } "Deleting a node matching a predicate:" { $subsection delete-node-if* } @@ -40,6 +41,11 @@ HELP: dlist-find "This operation is O(n)." } ; +HELP: dlist-filter +{ $values { "dlist" { $link dlist } } { "quot" quotation } { "dlist" { $link dlist } } } +{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, removing the corresponding nodes if the quotation returns " { $link f } "." } +{ $side-effects { "dlist" } } ; + HELP: dlist-any? { $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } } { $description "Just like " { $link dlist-find } " except it doesn't return the object." } diff --git a/basis/dlists/dlists-tests.factor b/basis/dlists/dlists-tests.factor index 3689680157..8072c93753 100755 --- a/basis/dlists/dlists-tests.factor +++ b/basis/dlists/dlists-tests.factor @@ -79,3 +79,8 @@ IN: dlists.tests [ V{ f 3 1 f } ] [ 1 over push-front 3 over push-front f over push-front f over push-back dlist>seq ] unit-test [ V{ } ] [ dlist>seq ] unit-test + +[ V{ 0 2 4 } ] [ { 0 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test +[ V{ 2 4 } ] [ { 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test +[ V{ 2 4 } ] [ { 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test +[ V{ 0 2 4 } ] [ { 0 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor index 3d7224ed16..89675c6469 100755 --- a/basis/dlists/dlists.factor +++ b/basis/dlists/dlists.factor @@ -95,7 +95,7 @@ M: dlist pop-front* ( dlist -- ) [ [ [ empty-dlist ] unless* - [ f ] change-next drop + next>> f over set-prev-when ] change-front drop ] keep @@ -108,7 +108,7 @@ M: dlist pop-back* ( dlist -- ) [ [ [ empty-dlist ] unless* - [ f ] change-prev drop + prev>> f over set-next-when ] change-back drop ] keep @@ -157,6 +157,9 @@ M: dlist clear-deque ( dlist -- ) : 1dlist ( obj -- dlist ) [ push-front ] keep ; +: dlist-filter ( dlist quot -- dlist ) + over [ '[ dup obj>> @ [ drop ] [ _ delete-node ] if ] dlist-each-node ] keep ; inline + M: dlist clone [ '[ _ push-back ] dlist-each ] keep ; diff --git a/basis/fry/fry-docs.factor b/basis/fry/fry-docs.factor index 5d750775e5..32ad856d00 100644 --- a/basis/fry/fry-docs.factor +++ b/basis/fry/fry-docs.factor @@ -57,7 +57,6 @@ $nl "Here are some built-in combinators rewritten in terms of fried quotations:" { $table { { $link literalize } { $snippet ": literalize '[ _ ] ;" } } - { { $link slip } { $snippet ": slip '[ @ _ ] call ;" } } { { $link curry } { $snippet ": curry '[ _ @ ] ;" } } { { $link compose } { $snippet ": compose '[ @ @ ] ;" } } { { $link bi@ } { $snippet ": bi@ tuck '[ _ @ _ @ ] call ;" } } 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 80% rename from extra/game-input/dinput/dinput.factor rename to basis/game-input/dinput/dinput.factor index 20815859ab..8540907db9 100755 --- a/extra/game-input/dinput/dinput.factor +++ b/basis/game-input/dinput/dinput.factor @@ -5,16 +5,20 @@ windows.user32 windows.messages sequences combinators locals math.rectangles accessors math alien alien.strings io.encodings.utf16 io.encodings.utf16n continuations byte-arrays game-input.dinput.keys-array game-input -ui.backend.windows windows.errors ; +ui.backend.windows windows.errors struct-arrays +math.bitwise ; IN: game-input.dinput +CONSTANT: MOUSE-BUFFER-SIZE 16 + SINGLETON: dinput-game-input-backend dinput-game-input-backend game-input-backend set-global SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ +controller-devices+ +controller-guids+ - +device-change-window+ +device-change-handle+ ; + +device-change-window+ +device-change-handle+ + +mouse-device+ +mouse-state+ +mouse-buffer+ ; : create-dinput ( -- ) f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid @@ -35,8 +39,24 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ : set-data-format ( device format-symbol -- ) get IDirectInputDevice8W::SetDataFormat ole32-error ; +: ( size -- DIPROPDWORD ) + "DIPROPDWORD" + "DIPROPDWORD" heap-size over set-DIPROPHEADER-dwSize + "DIPROPHEADER" heap-size over set-DIPROPHEADER-dwHeaderSize + 0 over set-DIPROPHEADER-dwObj + DIPH_DEVICE over set-DIPROPHEADER-dwHow + swap over set-DIPROPDWORD-dwData ; + +: set-buffer-size ( device size -- ) + DIPROP_BUFFERSIZE swap + IDirectInputDevice8W::SetProperty ole32-error ; + : configure-keyboard ( keyboard -- ) [ c_dfDIKeyboard_HID set-data-format ] [ set-coop-level ] bi ; +: configure-mouse ( mouse -- ) + [ c_dfDIMouse2 set-data-format ] + [ MOUSE-BUFFER-SIZE set-buffer-size ] + [ set-coop-level ] tri ; : configure-controller ( controller -- ) [ c_dfDIJoystick2 set-data-format ] [ set-coop-level ] bi ; @@ -47,6 +67,15 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ 256 keyboard-state boa +keyboard-state+ set-global ; +: find-mouse ( -- ) + GUID_SysMouse device-for-guid + [ configure-mouse ] + [ +mouse-device+ set-global ] bi + 0 0 0 0 8 f mouse-state boa + +mouse-state+ set-global + MOUSE-BUFFER-SIZE "DIDEVICEOBJECTDATA" + +mouse-buffer+ set-global ; + : device-info ( device -- DIDEVICEIMAGEINFOW ) "DIDEVICEINSTANCEW" "DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize @@ -190,16 +219,22 @@ TUPLE: window-rect < rect window-loc ; +keyboard-device+ [ com-release f ] change-global f +keyboard-state+ set-global ; +: release-mouse ( -- ) + +mouse-device+ [ com-release f ] change-global + f +mouse-state+ set-global ; + M: dinput-game-input-backend (open-game-input) create-dinput create-device-change-window find-keyboard + find-mouse set-up-controllers add-wm-devicechange ; M: dinput-game-input-backend (close-game-input) remove-wm-devicechange release-controllers + release-mouse release-keyboard close-device-change-window delete-dinput ; @@ -263,6 +298,22 @@ CONSTANT: pov-values [ DIJOYSTATE2-rgbButtons over buttons>> length >buttons >>buttons ] } 2cleave ; +: read-device-buffer ( device buffer count -- buffer count' ) + [ "DIDEVICEOBJECTDATA" heap-size ] 2dip + [ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep *uint ; + +: (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- state ) + [ DIDEVICEOBJECTDATA-dwData 32 >signed ] [ DIDEVICEOBJECTDATA-dwOfs ] bi { + { DIMOFS_X [ [ + ] curry change-dx ] } + { DIMOFS_Y [ [ + ] curry change-dy ] } + { DIMOFS_Z [ [ + ] curry change-scroll-dy ] } + [ [ c-bool> ] [ DIMOFS_BUTTON0 - ] bi* rot [ buttons>> set-nth ] keep ] + } case ; + +: fill-mouse-state ( buffer count -- state ) + [ +mouse-state+ get ] 2dip swap + [ "DIDEVICEOBJECTDATA" byte-array>struct-array nth (fill-mouse-state) ] curry each ; + : get-device-state ( device byte-array -- ) [ dup IDirectInputDevice8W::Poll ole32-error ] dip [ length ] keep @@ -283,3 +334,17 @@ M: dinput-game-input-backend read-keyboard +keyboard-device+ get [ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ] [ ] [ f ] with-acquisition ; + +M: dinput-game-input-backend read-mouse + +mouse-device+ get [ +mouse-buffer+ get MOUSE-BUFFER-SIZE read-device-buffer ] + [ fill-mouse-state ] [ f ] with-acquisition ; + +M: dinput-game-input-backend reset-mouse + +mouse-device+ get [ f MOUSE-BUFFER-SIZE read-device-buffer ] + [ 2drop ] [ ] with-acquisition + +mouse-state+ get + 0 >>dx + 0 >>dy + 0 >>scroll-dx + 0 >>scroll-dy + drop ; 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 84% rename from extra/game-input/game-input-docs.factor rename to basis/game-input/game-input-docs.factor index 5428ca66d0..4ef0acdaaf 100755 --- a/extra/game-input/game-input-docs.factor +++ b/basis/game-input/game-input-docs.factor @@ -3,7 +3,7 @@ sequences strings math ; IN: game-input ARTICLE: "game-input" "Game controller input" -"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard input." $nl +"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard and mouse input." $nl "The game input interface must be initialized before being used:" { $subsection open-game-input } { $subsection close-game-input } @@ -18,17 +18,19 @@ ARTICLE: "game-input" "Game controller input" { $subsection instance-id } "A hook is provided for invoking the system calibration tool:" { $subsection calibrate-controller } -"The current state of a controller or the keyboard can be read:" +"The current state of a controller, the keyboard, and the mouse can be read:" { $subsection read-controller } { $subsection read-keyboard } +{ $subsection read-mouse } { $subsection controller-state } -{ $subsection keyboard-state } ; +{ $subsection keyboard-state } +{ $subsection mouse-state } ; HELP: open-game-input -{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. If the game input interface is already opened, nothing happens." } ; +{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. Calls to open-game-input are reference counted; each call to open-game-input needs a corresponding call to close-game-input to close the game input interface." } ; HELP: close-game-input -{ $description "Closes the game input interface, releasing any allocated resources. Once this word is called, any remaining " { $link controller } " objects are invalid. If the game input interface is not opened, nothing happens." } ; +{ $description "Closes the game input interface, releasing any allocated resources. Once this word is called, any remaining " { $link controller } " objects are invalid." } ; HELP: game-input-opened? { $values { "?" "a boolean" } } @@ -86,6 +88,14 @@ HELP: read-keyboard { $warning "For efficiency, the implementation may reuse the returned " { $snippet "keyboard-state" } " object next time " { $snippet "read-keyboard" } " is called. You should " { $link clone } " any values from the returned tuple you need to preserve." $nl "The keyboard state returned by this word is unprocessed by any keymaps, modifier keys, key repeat settings, or other operating environment postprocessing. Because of this, " { $snippet "read-keyboard" } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ; +HELP: read-mouse +{ $values { "mouse-state" mouse-state } } +{ $description "Reads the current mouse state relative to either when the game input interface was opened with " { $link open-game-input } " or when the mouse state was reset with " { $link reset-mouse } "." } +{ $warning "For efficiency, the implementation may reuse the returned " { $snippet "mouse-state" } " object for future " { $snippet "read-mouse" } " or " { $snippet "reset-mouse" } " calls. You should " { $link clone } " the " { $snippet "mouse-state" } " object if you need to preserve it." } ; + +HELP: reset-mouse +{ $description "Resets the mouse state. Future " { $link read-mouse } " values will be relative to the time this word is called." } ; + HELP: controller-state { $class-description "The " { $link read-controller } " word returns objects of this class. " { $snippet "controller-state" } " objects have the following slots:" { $list @@ -121,6 +131,19 @@ HELP: keyboard-state { $class-description "The " { $link read-keyboard } " word returns objects of this class. The " { $snippet "keys" } " slot of a " { $snippet "keyboard-state" } " object contains a " { $link sequence } " of 256 members representing the state of the keys on the keyboard. Each element is a boolean value indicating whether the corresponding key is pressed. The sequence is indexed by scancode as defined under usage page 7 of the USB HID standard. Named scancode constants are provided in the " { $vocab-link "game-input.scancodes" } " vocabulary." } { $warning "The scancodes used to index " { $snippet "keyboard-state" } " objects correspond to physical key positions on the keyboard--they are unaffected by keymaps, modifier keys, or other operating environment postprocessing. The face value of the constants in " { $vocab-link "game-input.scancodes" } " do not necessarily correspond to what the user expects the key to type. Because of this, " { $link read-keyboard } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ; +HELP: mouse-state +{ $class-description "The " { $link read-mouse } " word returns objects of this class. " { $snippet "mouse-state" } " objects have the following slots:" +{ $list + { { $snippet "dx" } " contains the mouse's X axis movement." } + { { $snippet "dy" } " contains the mouse's Y axis movement." } + { { $snippet "scroll-dx" } " contains the scroller's X axis movement." } + { { $snippet "scroll-dy" } " contains the scroller's Y axis movement." } + { { $snippet "buttons" } " contains a sequence of boolean values indicate the state of the mouse's buttons." } +} +"Mouse movement is recorded relative to when the game input interface was opened with " { $link open-game-input } " or the mouse state is reset with " { $link reset-mouse } "." +} ; + + { keyboard-state read-keyboard } related-words ABOUT: "game-input" 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 78% rename from extra/game-input/game-input.factor rename to basis/game-input/game-input.factor index 6efe31861a..922906df48 100755 --- a/extra/game-input/game-input.factor +++ b/basis/game-input/game-input.factor @@ -1,38 +1,61 @@ -USING: arrays accessors continuations kernel system +USING: arrays accessors continuations kernel math system sequences namespaces init vocabs vocabs.loader combinators ; IN: game-input SYMBOLS: game-input-backend game-input-opened ; +game-input-opened [ 0 ] initialize + HOOK: (open-game-input) game-input-backend ( -- ) HOOK: (close-game-input) game-input-backend ( -- ) HOOK: (reset-game-input) game-input-backend ( -- ) +HOOK: get-controllers game-input-backend ( -- sequence ) + +HOOK: product-string game-input-backend ( controller -- string ) +HOOK: product-id game-input-backend ( controller -- id ) +HOOK: instance-id game-input-backend ( controller -- id ) + +HOOK: read-controller game-input-backend ( controller -- controller-state ) +HOOK: calibrate-controller game-input-backend ( controller -- ) + +HOOK: read-keyboard game-input-backend ( -- keyboard-state ) + +HOOK: read-mouse game-input-backend ( -- mouse-state ) + +HOOK: reset-mouse game-input-backend ( -- ) + : game-input-opened? ( -- ? ) - game-input-opened get ; + game-input-opened get zero? not ; +ERROR: game-input-not-open ; + : open-game-input ( -- ) game-input-opened? [ (open-game-input) - game-input-opened on - ] unless ; + ] unless + game-input-opened [ 1+ ] change-global + reset-mouse ; : close-game-input ( -- ) + game-input-opened [ + dup zero? [ game-input-not-open ] when + 1- + ] change-global game-input-opened? [ (close-game-input) reset-game-input - ] when ; + ] unless ; : with-game-input ( quot -- ) open-game-input [ close-game-input ] [ ] cleanup ; inline @@ -48,12 +71,6 @@ SYMBOLS: pov-up pov-up-right pov-right pov-down-right pov-down pov-down-left pov-left pov-up-left ; -HOOK: get-controllers game-input-backend ( -- sequence ) - -HOOK: product-string game-input-backend ( controller -- string ) -HOOK: product-id game-input-backend ( controller -- id ) -HOOK: instance-id game-input-backend ( controller -- id ) - : find-controller-products ( product-id -- sequence ) get-controllers [ product-id = ] with filter ; : find-controller-instance ( product-id instance-id -- controller/f ) @@ -63,15 +80,15 @@ HOOK: instance-id game-input-backend ( controller -- id ) [ instance-id = ] 2bi* and ] with with find nip ; -HOOK: read-controller game-input-backend ( controller -- controller-state ) -HOOK: calibrate-controller game-input-backend ( controller -- ) - TUPLE: keyboard-state keys ; M: keyboard-state clone call-next-method dup keys>> clone >>keys ; -HOOK: read-keyboard game-input-backend ( -- keyboard-state ) +TUPLE: mouse-state dx dy scroll-dx scroll-dy buttons ; + +M: mouse-state clone + call-next-method dup buttons>> clone >>buttons ; { { [ os windows? ] [ "game-input.dinput" require ] } 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 65% rename from extra/game-input/iokit/iokit.factor rename to basis/game-input/iokit/iokit.factor index 2ded263899..5f09a054f9 100755 --- a/extra/game-input/iokit/iokit.factor +++ b/basis/game-input/iokit/iokit.factor @@ -1,13 +1,15 @@ USING: cocoa cocoa.plists core-foundation iokit iokit.hid kernel cocoa.enumeration destructors math.parser cocoa.application sequences locals combinators.short-circuit threads -namespaces assocs vectors arrays combinators +namespaces assocs vectors arrays combinators hints alien core-foundation.run-loop accessors sequences.private -alien.c-types math parser game-input ; +alien.c-types math parser game-input vectors ; IN: game-input.iokit SINGLETON: iokit-game-input-backend +SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ; + iokit-game-input-backend game-input-backend set-global : hid-manager-matching ( matching-seq -- alien ) @@ -23,9 +25,12 @@ iokit-game-input-backend game-input-backend set-global CONSTANT: game-devices-matching-seq { + H{ { "DeviceUsage" 2 } { "DeviceUsagePage" 1 } } ! mouses H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads H{ { "DeviceUsage" 6 } { "DeviceUsagePage" 1 } } ! keyboards + H{ { "DeviceUsage" 7 } { "DeviceUsagePage" 1 } } ! keypads + H{ { "DeviceUsage" 8 } { "DeviceUsagePage" 1 } } ! multiaxis controllers } CONSTANT: buttons-matching-hash @@ -46,6 +51,8 @@ CONSTANT: rz-axis-matching-hash H{ { "UsagePage" 1 } { "Usage" HEX: 35 } { "Type" 1 } } CONSTANT: slider-matching-hash H{ { "UsagePage" 1 } { "Usage" HEX: 36 } { "Type" 1 } } +CONSTANT: wheel-matching-hash + H{ { "UsagePage" 1 } { "Usage" HEX: 38 } { "Type" 1 } } CONSTANT: hat-switch-matching-hash H{ { "UsagePage" 1 } { "Usage" HEX: 39 } { "Type" 1 } } @@ -82,44 +89,54 @@ CONSTANT: hat-switch-matching-hash game-devices-matching-seq hid-manager-matching ; : device-property ( device key -- value ) - IOHIDDeviceGetProperty plist> ; + IOHIDDeviceGetProperty [ plist> ] [ f ] if* ; : element-property ( element key -- value ) - IOHIDElementGetProperty plist> ; + IOHIDElementGetProperty [ plist> ] [ f ] if* ; : set-element-property ( element key value -- ) [ ] [ >plist ] bi* IOHIDElementSetProperty drop ; : transfer-element-property ( element from-key to-key -- ) - [ dupd element-property ] dip swap set-element-property ; + [ dupd element-property ] dip swap + [ set-element-property ] [ 2drop ] if* ; + +: mouse-device? ( device -- ? ) + 1 2 IOHIDDeviceConformsTo ; : controller-device? ( device -- ? ) { [ 1 4 IOHIDDeviceConformsTo ] [ 1 5 IOHIDDeviceConformsTo ] + [ 1 8 IOHIDDeviceConformsTo ] } 1|| ; : element-usage ( element -- {usage-page,usage} ) [ IOHIDElementGetUsagePage ] [ IOHIDElementGetUsage ] bi 2array ; -: button? ( {usage-page,usage} -- ? ) - first 9 = ; inline -: keyboard-key? ( {usage-page,usage} -- ? ) - first 7 = ; inline +: button? ( element -- ? ) + IOHIDElementGetUsagePage 9 = ; inline +: keyboard-key? ( element -- ? ) + IOHIDElementGetUsagePage 7 = ; inline +: axis? ( element -- ? ) + IOHIDElementGetUsagePage 1 = ; inline + : x-axis? ( {usage-page,usage} -- ? ) - { 1 HEX: 30 } = ; inline + IOHIDElementGetUsage HEX: 30 = ; inline : y-axis? ( {usage-page,usage} -- ? ) - { 1 HEX: 31 } = ; inline + IOHIDElementGetUsage HEX: 31 = ; inline : z-axis? ( {usage-page,usage} -- ? ) - { 1 HEX: 32 } = ; inline + IOHIDElementGetUsage HEX: 32 = ; inline : rx-axis? ( {usage-page,usage} -- ? ) - { 1 HEX: 33 } = ; inline + IOHIDElementGetUsage HEX: 33 = ; inline : ry-axis? ( {usage-page,usage} -- ? ) - { 1 HEX: 34 } = ; inline + IOHIDElementGetUsage HEX: 34 = ; inline : rz-axis? ( {usage-page,usage} -- ? ) - { 1 HEX: 35 } = ; inline + IOHIDElementGetUsage HEX: 35 = ; inline : slider? ( {usage-page,usage} -- ? ) - { 1 HEX: 36 } = ; inline + IOHIDElementGetUsage HEX: 36 = ; inline +: wheel? ( {usage-page,usage} -- ? ) + IOHIDElementGetUsage HEX: 38 = ; inline : hat-switch? ( {usage-page,usage} -- ? ) - { 1 HEX: 39 } = ; inline + IOHIDElementGetUsage HEX: 39 = ; inline CONSTANT: pov-values { @@ -132,34 +149,70 @@ CONSTANT: pov-values IOHIDValueGetIntegerValue dup zero? [ drop f ] when ; : axis-value ( value -- [-1,1] ) kIOHIDValueScaleTypeCalibrated IOHIDValueGetScaledValue ; +: mouse-axis-value ( value -- n ) + IOHIDValueGetIntegerValue ; : pov-value ( value -- pov-direction ) IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ; +: record-button ( state hid-value element -- ) + [ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1- ] tri* rot set-nth ; + : record-controller ( controller-state value -- ) - dup IOHIDValueGetElement element-usage { - { [ dup button? ] [ [ button-value ] [ second 1- ] bi* rot buttons>> set-nth ] } - { [ dup x-axis? ] [ drop axis-value >>x drop ] } - { [ dup y-axis? ] [ drop axis-value >>y drop ] } - { [ dup z-axis? ] [ drop axis-value >>z drop ] } - { [ dup rx-axis? ] [ drop axis-value >>rx drop ] } - { [ dup ry-axis? ] [ drop axis-value >>ry drop ] } - { [ dup rz-axis? ] [ drop axis-value >>rz drop ] } - { [ dup slider? ] [ drop axis-value >>slider drop ] } - { [ dup hat-switch? ] [ drop pov-value >>pov drop ] } + dup IOHIDValueGetElement { + { [ dup button? ] [ record-button ] } + { [ dup axis? ] [ { + { [ dup x-axis? ] [ drop axis-value >>x drop ] } + { [ dup y-axis? ] [ drop axis-value >>y drop ] } + { [ dup z-axis? ] [ drop axis-value >>z drop ] } + { [ dup rx-axis? ] [ drop axis-value >>rx drop ] } + { [ dup ry-axis? ] [ drop axis-value >>ry drop ] } + { [ dup rz-axis? ] [ drop axis-value >>rz drop ] } + { [ dup slider? ] [ drop axis-value >>slider drop ] } + { [ dup hat-switch? ] [ drop pov-value >>pov drop ] } + [ 3drop ] + } cond ] } [ 3drop ] } cond ; -SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ; +HINTS: record-controller { controller-state alien } ; : ?set-nth ( value nth seq -- ) 2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ; -: record-keyboard ( value -- ) - dup IOHIDValueGetElement element-usage keyboard-key? [ +: record-keyboard ( keyboard-state value -- ) + dup IOHIDValueGetElement dup keyboard-key? [ [ IOHIDValueGetIntegerValue c-bool> ] - [ IOHIDValueGetElement IOHIDElementGetUsage ] bi - +keyboard-state+ get ?set-nth - ] [ drop ] if ; + [ IOHIDElementGetUsage ] bi* + rot ?set-nth + ] [ 3drop ] if ; + +HINTS: record-keyboard { array alien } ; + +: record-mouse ( mouse-state value -- ) + dup IOHIDValueGetElement { + { [ dup button? ] [ record-button ] } + { [ dup axis? ] [ { + { [ dup x-axis? ] [ drop mouse-axis-value [ + ] curry change-dx drop ] } + { [ dup y-axis? ] [ drop mouse-axis-value [ + ] curry change-dy drop ] } + { [ dup wheel? ] [ drop mouse-axis-value [ + ] curry change-scroll-dx drop ] } + { [ dup z-axis? ] [ drop mouse-axis-value [ + ] curry change-scroll-dy drop ] } + [ 3drop ] + } cond ] } + [ 3drop ] + } cond ; + +HINTS: record-mouse { mouse-state alien } ; + +M: iokit-game-input-backend read-mouse + +mouse-state+ get ; + +M: iokit-game-input-backend reset-mouse + +mouse-state+ get + 0 >>dx + 0 >>dy + 0 >>scroll-dx + 0 >>scroll-dy + drop ; : default-calibrate-saturation ( element -- ) [ kIOHIDElementMinKey kIOHIDElementCalibrationSaturationMinKey transfer-element-property ] @@ -194,12 +247,21 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ; [ button-count f ] } cleave controller-state boa ; +: ?add-mouse-buttons ( device -- ) + button-count +mouse-state+ get buttons>> + 2dup length > + [ set-length ] [ 2drop ] if ; + : device-matched-callback ( -- alien ) [| context result sender device | - device controller-device? [ - device - device +controller-states+ get set-at - ] when + { + { [ device controller-device? ] [ + device + device +controller-states+ get set-at + ] } + { [ device mouse-device? ] [ device ?add-mouse-buttons ] } + [ ] + } cond ] IOHIDDeviceCallback ; : device-removed-callback ( -- alien ) @@ -209,15 +271,20 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ; : device-input-callback ( -- alien ) [| context result sender value | - sender controller-device? - [ sender +controller-states+ get at value record-controller ] - [ value record-keyboard ] - if + { + { [ sender controller-device? ] [ + sender +controller-states+ get at value record-controller + ] } + { [ sender mouse-device? ] [ +mouse-state+ get value record-mouse ] } + [ +keyboard-state+ get value record-keyboard ] + } cond ] IOHIDValueCallback ; : initialize-variables ( manager -- ) +hid-manager+ set-global 4 +controller-states+ set-global + 0 0 0 0 2 mouse-state boa + +mouse-state+ set-global 256 f +keyboard-state+ set-global ; M: iokit-game-input-backend (open-game-input) @@ -234,7 +301,7 @@ M: iokit-game-input-backend (open-game-input) } cleave ; M: iokit-game-input-backend (reset-game-input) - { +hid-manager+ +keyboard-state+ +controller-states+ } + { +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ } [ f swap set-global ] each ; M: iokit-game-input-backend (close-game-input) @@ -249,6 +316,7 @@ M: iokit-game-input-backend (close-game-input) f ] change-global f +keyboard-state+ set-global + f +mouse-state+ set-global f +controller-states+ set-global ] when ; 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/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index 3671511194..d6a3aa948a 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -161,22 +161,6 @@ HELP: ndip } } ; -HELP: nslip -{ $values { "n" integer } } -{ $description "A generalization of " { $link slip } " that can work " -"for any stack depth. The first " { $snippet "n" } " items after the quotation will be " -"removed from the stack, the quotation called, and the items restored." -} -{ $examples - { $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip 6 narray ." "{ 99 1 2 3 4 5 }" } - "Some core words expressed in terms of " { $link nslip } ":" - { $table - { { $link slip } { $snippet "1 nslip" } } - { { $link 2slip } { $snippet "2 nslip" } } - { { $link 3slip } { $snippet "3 nslip" } } - } -} ; - HELP: nkeep { $values { "quot" quotation } { "n" integer } } { $description "A generalization of " { $link keep } " that can work " @@ -339,7 +323,6 @@ ARTICLE: "shuffle-generalizations" "Generalized shuffle words" ARTICLE: "combinator-generalizations" "Generalized combinators" { $subsection ndip } -{ $subsection nslip } { $subsection nkeep } { $subsection napply } { $subsection ncleave } diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor index 7ede271d01..d0f614f9cd 100644 --- a/basis/generalizations/generalizations-tests.factor +++ b/basis/generalizations/generalizations-tests.factor @@ -26,8 +26,6 @@ IN: generalizations.tests [ [ 1 ] 5 ndip ] must-infer [ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test -[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer -{ 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer { 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test [ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 139b7a528a..397166a418 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -60,9 +60,6 @@ MACRO: ntuck ( n -- ) MACRO: ndip ( quot n -- ) [ '[ _ dip ] ] times ; -MACRO: nslip ( n -- ) - '[ [ call ] _ ndip ] ; - MACRO: nkeep ( quot n -- ) tuck '[ _ ndup _ _ ndip ] ; diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index f25d5f0f93..7a5b482270 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -87,7 +87,7 @@ PRIVATE> : help-lint-all ( -- ) "" help-lint ; -: :lint-failures ( -- ) lint-failures get errors. ; +: :lint-failures ( -- ) lint-failures get values errors. ; : unlinked-words ( words -- seq ) all-word-help [ article-parent not ] filter ; diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 6bf1ea2ff1..27dc25de73 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -5,7 +5,7 @@ compression.lzw constructors endian fry grouping images io io.binary io.encodings.ascii io.encodings.binary io.encodings.string io.encodings.utf8 io.files kernel math math.bitwise math.order math.parser pack prettyprint sequences -strings math.vectors specialized-arrays.float ; +strings math.vectors specialized-arrays.float locals ; IN: images.tiff TUPLE: tiff-image < image ; @@ -184,7 +184,7 @@ samples-per-pixel new-subfile-type subfile-type orientation software date-time photoshop exif-ifd sub-ifd inter-color-profile xmp iptc fill-order document-name page-number page-name x-position y-position host-computer copyright artist -min-sample-value max-sample-value make model cell-width cell-length +min-sample-value max-sample-value tiff-make tiff-model cell-width cell-length gray-response-unit gray-response-curve color-map threshholding image-description free-offsets free-byte-counts tile-width tile-length matteing data-type image-depth tile-depth @@ -243,10 +243,13 @@ ERROR: bad-tiff-magic bytes ; ERROR: no-tag class ; -: find-tag ( idf class -- tag ) - swap processed-tags>> ?at [ no-tag ] unless ; +: find-tag* ( ifd class -- tag/class ? ) + swap processed-tags>> ?at ; -: tag? ( idf class -- tag ) +: find-tag ( ifd class -- tag ) + find-tag* [ no-tag ] unless ; + +: tag? ( ifd class -- tag ) swap processed-tags>> key? ; : read-strips ( ifd -- ifd ) @@ -339,8 +342,8 @@ ERROR: bad-small-ifd-type n ; { 266 [ fill-order ] } { 269 [ ascii decode document-name ] } { 270 [ ascii decode image-description ] } - { 271 [ ascii decode make ] } - { 272 [ ascii decode model ] } + { 271 [ ascii decode tiff-make ] } + { 272 [ ascii decode tiff-model ] } { 273 [ strip-offsets ] } { 274 [ orientation ] } { 277 [ samples-per-pixel ] } @@ -350,7 +353,7 @@ ERROR: bad-small-ifd-type n ; { 281 [ max-sample-value ] } { 282 [ first x-resolution ] } { 283 [ first y-resolution ] } - { 284 [ planar-configuration ] } + { 284 [ lookup-planar-configuration planar-configuration ] } { 285 [ page-name ] } { 286 [ x-position ] } { 287 [ y-position ] } @@ -437,8 +440,8 @@ ERROR: unhandled-compression compression ; [ samples-per-pixel find-tag ] tri [ * ] keep '[ - _ group [ _ group [ rest ] [ first ] bi - [ v+ ] accumulate swap suffix concat ] map + _ group + [ _ group unclip [ v+ ] accumulate swap suffix concat ] map concat >byte-array ] change-bitmap ; @@ -521,23 +524,39 @@ ERROR: unknown-component-order ifd ; ] with-tiff-endianness ] with-file-reader ; -: process-tif-ifds ( parsed-tiff -- parsed-tiff ) - dup ifds>> [ - read-strips - uncompress-strips - strips>bitmap - fix-bitmap-endianness - strips-predictor - dup extra-samples tag? [ handle-alpha-data ] when - drop - ] each ; +: process-chunky-ifd ( ifd -- ) + read-strips + uncompress-strips + strips>bitmap + fix-bitmap-endianness + strips-predictor + dup extra-samples tag? [ handle-alpha-data ] when + drop ; + +: process-planar-ifd ( ifd -- ) + "planar ifd not supported" throw ; + +: dispatch-planar-configuration ( ifd planar-configuration -- ) + { + { planar-configuration-chunky [ process-chunky-ifd ] } + { planar-configuration-planar [ process-planar-ifd ] } + } case ; + +: process-ifd ( ifd -- ) + dup planar-configuration find-tag* [ + dispatch-planar-configuration + ] [ + drop "no planar configuration" throw + ] if ; + +: process-tif-ifds ( parsed-tiff -- ) + ifds>> [ process-ifd ] each ; : load-tiff ( path -- parsed-tiff ) - [ load-tiff-ifds ] [ - binary [ - [ process-tif-ifds ] with-tiff-endianness - ] with-file-reader - ] bi ; + [ load-tiff-ifds dup ] keep + binary [ + [ process-tif-ifds ] with-tiff-endianness + ] with-file-reader ; ! tiff files can store several images -- we just take the first for now M: tiff-image load-image* ( path tiff-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/backend/windows/privileges/privileges-tests.factor b/basis/io/backend/windows/privileges/privileges-tests.factor new file mode 100755 index 0000000000..7237651b80 --- /dev/null +++ b/basis/io/backend/windows/privileges/privileges-tests.factor @@ -0,0 +1,4 @@ +IN: io.backend.windows.privileges.tests +USING: io.backend.windows.privileges tools.test ; + +[ [ ] with-privileges ] must-infer diff --git a/basis/io/backend/windows/privileges/privileges.factor b/basis/io/backend/windows/privileges/privileges.factor old mode 100644 new mode 100755 index 8661ba99d9..58806cc4df --- a/basis/io/backend/windows/privileges/privileges.factor +++ b/basis/io/backend/windows/privileges/privileges.factor @@ -1,12 +1,13 @@ USING: io.backend kernel continuations sequences -system vocabs.loader combinators ; +system vocabs.loader combinators fry ; IN: io.backend.windows.privileges -HOOK: set-privilege io-backend ( name ? -- ) inline +HOOK: set-privilege io-backend ( name ? -- ) : with-privileges ( seq quot -- ) - over [ [ t set-privilege ] each ] curry compose - swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline + [ '[ _ [ t set-privilege ] each @ ] ] + [ drop '[ _ [ f set-privilege ] each ] ] + 2bi [ ] cleanup ; inline { { [ os winnt? ] [ "io.backend.windows.nt.privileges" require ] } 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/search/search-docs.factor b/basis/io/directories/search/search-docs.factor index a6c82a1bff..6bfaa07227 100644 --- a/basis/io/directories/search/search-docs.factor +++ b/basis/io/directories/search/search-docs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax kernel quotations ; +USING: help.markup help.syntax kernel quotations sequences ; IN: io.directories.search HELP: each-file @@ -57,6 +57,32 @@ HELP: find-all-in-directories } { $description "Finds all files in the input directories matching the predicate quotation in a breadth-first or depth-first traversal." } ; +HELP: find-by-extension +{ $values + { "path" "a pathname string" } { "extension" "a file extension" } + { "seq" sequence } +} +{ $description "Searches a directory for all files with the given extension. File extension and filenames are converted to lower-case and compared using the " { $link tail? } " word. The file extension should contain the period." } +{ $examples + { $unchecked-example + "USING: io.directories.search ;" + "\"/\" \".mp3\" find-by-extension" + } +} ; + +HELP: find-by-extensions +{ $values + { "path" "a pathname string" } { "extensions" "a sequence of file extensions" } + { "seq" sequence } +} +{ $description "Searches a directory for all files in the given list of extensions. File extensions and filenames are converted to lower-case and compared using the " { $link tail? } " word. File extensions should contain the period." } +{ $examples + { $unchecked-example + "USING: io.directories.search ;" + "\"/\" { \".jpg\" \".gif\" \".tiff\" \".png\" \".bmp\" } find-by-extensions" + } +} ; + { find-file find-all-files find-in-directories find-all-in-directories } related-words ARTICLE: "io.directories.search" "Searching directories" @@ -65,10 +91,13 @@ ARTICLE: "io.directories.search" "Searching directories" { $subsection recursive-directory-files } { $subsection recursive-directory-entries } { $subsection each-file } -"Finding files:" +"Finding files by name:" { $subsection find-file } { $subsection find-all-files } { $subsection find-in-directories } -{ $subsection find-all-in-directories } ; +{ $subsection find-all-in-directories } +"Finding files by extension:" +{ $subsection find-by-extension } +{ $subsection find-by-extensions } ; ABOUT: "io.directories.search" diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index f7d18306f8..3fbf09a3c3 100755 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -3,7 +3,7 @@ USING: accessors arrays continuations deques dlists fry io.directories io.files io.files.info io.pathnames kernel sequences system vocabs.loader locals math namespaces -sorting assocs calendar threads io math.parser ; +sorting assocs calendar threads io math.parser unicode.case ; IN: io.directories.search : qualified-directory-entries ( path -- seq ) @@ -106,4 +106,11 @@ ERROR: file-not-found path bfs? quot ; ] { } map>assoc ] with-qualified-directory-entries sort-values ; +: find-by-extensions ( path extensions -- seq ) + [ >lower ] map + '[ >lower _ [ tail? ] with any? ] find-all-files ; + +: find-by-extension ( path extension -- seq ) + 1array find-by-extensions ; + os windows? [ "io.directories.search.windows" require ] when 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/extra/modules/using/tests/tags.txt b/basis/io/directories/unix/linux/tags.txt similarity index 100% rename from extra/modules/using/tests/tags.txt rename to basis/io/directories/unix/linux/tags.txt 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/basis/io/launcher/unix/unix-tests.factor b/basis/io/launcher/unix/unix-tests.factor index 99d45e4fd7..852d8171e4 100644 --- a/basis/io/launcher/unix/unix-tests.factor +++ b/basis/io/launcher/unix/unix-tests.factor @@ -48,7 +48,7 @@ concurrency.promises threads unix.process ; try-process ] unit-test -[ f ] [ +[ "" ] [ "cat" "launcher-test-1" temp-file 2array diff --git a/basis/io/launcher/windows/nt/nt-tests.factor b/basis/io/launcher/windows/nt/nt-tests.factor index 53b3d3ce7e..4587556e0c 100755 --- a/basis/io/launcher/windows/nt/nt-tests.factor +++ b/basis/io/launcher/windows/nt/nt-tests.factor @@ -42,7 +42,7 @@ IN: io.launcher.windows.nt.tests console-vm "-run=listener" 2array >>command +closed+ >>stdin +stdout+ >>stderr - ascii [ input-stream get contents ] with-process-reader + ascii [ contents ] with-process-reader ] unit-test : launcher-test-path ( -- str ) @@ -85,7 +85,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "stderr.factor" 3array >>command "err2.txt" temp-file >>stderr - ascii lines first + ascii stream-lines first ] with-directory ] unit-test @@ -97,7 +97,7 @@ IN: io.launcher.windows.nt.tests launcher-test-path [ console-vm "-script" "env.factor" 3array >>command - ascii contents + ascii stream-contents ] with-directory eval( -- alist ) os-envs = @@ -109,7 +109,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "env.factor" 3array >>command +replace-environment+ >>environment-mode os-envs >>environment - ascii contents + ascii stream-contents ] with-directory eval( -- alist ) os-envs = @@ -120,7 +120,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "env.factor" 3array >>command { { "A" "B" } } >>environment - ascii contents + ascii stream-contents ] with-directory eval( -- alist ) "A" swap at @@ -132,7 +132,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "env.factor" 3array >>command { { "USERPROFILE" "XXX" } } >>environment +prepend-environment+ >>environment-mode - ascii contents + ascii stream-contents ] with-directory eval( -- alist ) "USERPROFILE" swap at "XXX" = 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/basis/io/streams/string/string-tests.factor b/basis/io/streams/string/string-tests.factor index 967c0d4613..27971f1431 100644 --- a/basis/io/streams/string/string-tests.factor +++ b/basis/io/streams/string/string-tests.factor @@ -2,6 +2,8 @@ USING: io.streams.string io kernel arrays namespaces make tools.test ; IN: io.streams.string.tests +[ "" ] [ "" [ contents ] with-string-reader ] unit-test + [ "line 1" CHAR: l ] [ "line 1\nline 2\nline 3" 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/literals/literals-docs.factor b/basis/literals/literals-docs.factor index 0d61dcb467..9dd398d962 100644 --- a/basis/literals/literals-docs.factor +++ b/basis/literals/literals-docs.factor @@ -21,7 +21,7 @@ CONSTANT: five 5 USING: kernel literals prettyprint ; IN: scratchpad -<< : seven-eleven ( -- a b ) 7 11 ; >> +: seven-eleven ( -- a b ) 7 11 ; { $ seven-eleven } . "> "{ 7 11 }" } @@ -43,7 +43,24 @@ IN: scratchpad } ; -{ POSTPONE: $ POSTPONE: $[ } related-words +HELP: ${ +{ $syntax "${ code }" } +{ $description "Outputs an array containing the results of executing " { $snippet "code" } " at parse time." } +{ $notes { $snippet "code" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." } +{ $examples + + { $example <" +USING: kernel literals math prettyprint ; +IN: scratchpad + +CONSTANT: five 5 +CONSTANT: six 6 +${ five six 7 } . + "> "{ 5 6 7 }" + } +} ; + +{ POSTPONE: $ POSTPONE: $[ POSTPONE: ${ } related-words ARTICLE: "literals" "Interpolating code results into literal values" "The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values." @@ -51,11 +68,12 @@ ARTICLE: "literals" "Interpolating code results into literal values" USING: kernel literals math prettyprint ; IN: scratchpad -<< CONSTANT: five 5 >> +CONSTANT: five 5 { $ five $[ five dup 1+ dup 2 + ] } . "> "{ 5 5 6 8 }" } { $subsection POSTPONE: $ } { $subsection POSTPONE: $[ } +{ $subsection POSTPONE: ${ } ; ABOUT: "literals" diff --git a/basis/literals/literals-tests.factor b/basis/literals/literals-tests.factor old mode 100644 new mode 100755 index 29072f1299..d7256a64b1 --- a/basis/literals/literals-tests.factor +++ b/basis/literals/literals-tests.factor @@ -20,8 +20,10 @@ IN: literals.tests [ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test -<< CONSTANT: constant-a 3 ->> [ { 3 10 "ftw" } ] [ ${ constant-a 10 "ftw" } ] unit-test + +: sixty-nine ( -- a b ) 6 9 ; + +[ { 6 9 } ] [ ${ sixty-nine } ] unit-test diff --git a/basis/literals/literals.factor b/basis/literals/literals.factor old mode 100644 new mode 100755 index 7c7592dda8..ba1da393b1 --- a/basis/literals/literals.factor +++ b/basis/literals/literals.factor @@ -1,8 +1,21 @@ ! (c) Joe Groff, see license for details USING: accessors continuations kernel parser words quotations -combinators.smart vectors sequences ; +combinators.smart vectors sequences fry ; IN: literals -SYNTAX: $ scan-word [ def>> call ] curry with-datastack >vector ; +> call so that CONSTANT:s defined in the same file can +! be called + +: expand-literal ( seq obj -- seq' ) + '[ _ dup word? [ def>> call ] when ] with-datastack ; + +: expand-literals ( seq -- seq' ) + [ [ { } ] dip expand-literal ] map concat ; + +PRIVATE> + +SYNTAX: $ scan-word expand-literal >vector ; SYNTAX: $[ parse-quotation with-datastack >vector ; -SYNTAX: ${ \ } [ [ ?execute ] { } map-as ] parse-literal ; +SYNTAX: ${ \ } [ expand-literals ] parse-literal ; diff --git a/basis/math/bits/bits.factor b/basis/math/bits/bits.factor index 8920955df3..72b83a991f 100644 --- a/basis/math/bits/bits.factor +++ b/basis/math/bits/bits.factor @@ -7,7 +7,7 @@ TUPLE: bits { number read-only } { length read-only } ; C: bits : make-bits ( number -- bits ) - dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1+ ] if ; inline + dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1 + ] if ; inline M: bits length length>> ; diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index 3148567bc0..ff4806348b 100755 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -13,10 +13,10 @@ IN: math.bitwise : unmask? ( x n -- ? ) unmask 0 > ; inline : mask ( x n -- ? ) bitand ; inline : mask? ( x n -- ? ) mask 0 > ; inline -: wrap ( m n -- m' ) 1- bitand ; inline +: wrap ( m n -- m' ) 1 - bitand ; inline : bits ( m n -- m' ) 2^ wrap ; inline : mask-bit ( m n -- m' ) 2^ mask ; inline -: on-bits ( n -- m ) 2^ 1- ; inline +: on-bits ( n -- m ) 2^ 1 - ; inline : toggle-bit ( m n -- m' ) 2^ bitxor ; inline : shift-mod ( n s w -- n ) @@ -35,6 +35,11 @@ IN: math.bitwise : w- ( int int -- int ) - 32 bits ; inline : w* ( int int -- int ) * 32 bits ; inline +! 64-bit arithmetic +: W+ ( int int -- int ) + 64 bits ; inline +: W- ( int int -- int ) - 64 bits ; inline +: W* ( int int -- int ) * 64 bits ; inline + ! flags MACRO: flags ( values -- ) [ 0 ] [ [ ?execute bitor ] curry compose ] reduce ; @@ -64,8 +69,8 @@ DEFER: byte-bit-count << \ byte-bit-count -256 [ - 8 0 [ [ 1+ ] when ] reduce +256 iota [ + 8 0 [ [ 1 + ] when ] reduce ] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ] (( byte -- table )) define-declared @@ -97,12 +102,19 @@ PRIVATE> ! Signed byte array to integer conversion : signed-le> ( bytes -- x ) - [ le> ] [ length 8 * 1- on-bits ] bi + [ le> ] [ length 8 * 1 - on-bits ] bi 2dup > [ bitnot bitor ] [ drop ] if ; : signed-be> ( bytes -- x ) signed-le> ; : >signed ( x n -- y ) - 2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ; + 2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ; +: >odd ( n -- int ) 0 set-bit ; foldable + +: >even ( n -- int ) 0 clear-bit ; foldable + +: next-even ( m -- n ) >even 2 + ; foldable + +: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; foldable diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index d7c6ebc927..3017a12b18 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -164,7 +164,7 @@ M: VECTOR element-type M: VECTOR Vswap (prepare-swap) [ XSWAP ] 2dip ; M: VECTOR Viamax - (prepare-nrm2) IXAMAX 1- ; + (prepare-nrm2) IXAMAX 1 - ; M: VECTOR (blas-vector-like) drop ; diff --git a/basis/math/combinatorics/combinatorics-docs.factor b/basis/math/combinatorics/combinatorics-docs.factor index 514c808ee0..041539c981 100644 --- a/basis/math/combinatorics/combinatorics-docs.factor +++ b/basis/math/combinatorics/combinatorics-docs.factor @@ -1,37 +1,93 @@ -USING: help.markup help.syntax kernel math math.order sequences ; +USING: help.markup help.syntax kernel math math.order multiline sequences ; IN: math.combinatorics HELP: factorial { $values { "n" "a non-negative integer" } { "n!" integer } } { $description "Outputs the product of all positive integers less than or equal to " { $snippet "n" } "." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "4 factorial ." "24" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "4 factorial ." "24" } +} ; HELP: nPk { $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nPk" integer } } { $description "Outputs the total number of unique permutations of size " { $snippet "k" } " (order does matter) that can be taken from a set of size " { $snippet "n" } "." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nPk ." "5040" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "10 4 nPk ." "5040" } +} ; HELP: nCk { $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nCk" integer } } { $description "Outputs the total number of unique combinations of size " { $snippet "k" } " (order does not matter) that can be taken from a set of size " { $snippet "n" } ". Commonly written as \"n choose k\"." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nCk ." "210" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "10 4 nCk ." "210" } +} ; HELP: permutation { $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } } { $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." } { $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1-" } "." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "1 3 permutation ." "{ 0 2 1 }" } { $example "USING: math.combinatorics prettyprint ;" "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "1 3 permutation ." "{ 0 2 1 }" } + { $example "USING: math.combinatorics prettyprint ;" + "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" } +} ; HELP: all-permutations { $values { "seq" sequence } { "seq" sequence } } { $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } +} ; + +HELP: each-permutation +{ $values { "seq" sequence } { "quot" { $quotation "( seq -- )" } } } +{ $description "Applies the quotation to each permuation of " { $snippet "seq" } " in order." } ; HELP: inverse-permutation { $values { "seq" sequence } { "permutation" sequence } } { $description "Outputs a sequence of indices representing the lexicographical permutation of " { $snippet "seq" } "." } { $notes "All items in " { $snippet "seq" } " must be comparable by " { $link <=> } "." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } { $example "USING: math.combinatorics prettyprint ;" "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } + { $example "USING: math.combinatorics prettyprint ;" + "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } +} ; + +HELP: combination +{ $values { "m" "a non-negative integer" } { "seq" sequence } { "k" "a non-negative integer" } { "seq" sequence } } +{ $description "Outputs the " { $snippet "mth" } " lexicographical combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements." } +{ $notes "Combinations are 0-based and a bounds error will be thrown if " { $snippet "m" } " is larger than " { $snippet "seq length k nCk" } "." } +{ $examples + { $example "USING: math.combinatorics sequences prettyprint ;" + "6 7 iota 4 combination ." "{ 0 1 3 6 }" } + { $example "USING: math.combinatorics prettyprint ;" + "0 { \"a\" \"b\" \"c\" \"d\" } 2 combination ." "{ \"a\" \"b\" }" } +} ; + +HELP: all-combinations +{ $values { "seq" sequence } { "k" "a non-negative integer" } { "seq" sequence } } +{ $description "Outputs a sequence containing all combinations of " { $snippet "seq" } " choosing " { $snippet "k" } " elements, in lexicographical order." } +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "{ \"a\" \"b\" \"c\" \"d\" } 2 all-combinations ." +<" { + { "a" "b" } + { "a" "c" } + { "a" "d" } + { "b" "c" } + { "b" "d" } + { "c" "d" } +}"> } } ; + +HELP: each-combination +{ $values { "seq" sequence } { "k" "a non-negative integer" } { "quot" { $quotation "( seq -- )" } } } +{ $description "Applies the quotation to each combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements, in order." } ; IN: math.combinatorics.private diff --git a/basis/math/combinatorics/combinatorics-tests.factor b/basis/math/combinatorics/combinatorics-tests.factor index 5ef435a4e0..ca6ec9cb53 100644 --- a/basis/math/combinatorics/combinatorics-tests.factor +++ b/basis/math/combinatorics/combinatorics-tests.factor @@ -1,18 +1,6 @@ -USING: math.combinatorics math.combinatorics.private tools.test ; +USING: math.combinatorics math.combinatorics.private tools.test sequences ; IN: math.combinatorics.tests -[ { } ] [ 0 factoradic ] unit-test -[ { 1 0 } ] [ 1 factoradic ] unit-test -[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test - -[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test -[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test -[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test - -[ { 0 1 2 3 } ] [ 0 4 permutation-indices ] unit-test -[ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test -[ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test - [ 1 ] [ 0 factorial ] unit-test [ 1 ] [ 1 factorial ] unit-test [ 3628800 ] [ 10 factorial ] unit-test @@ -31,6 +19,19 @@ IN: math.combinatorics.tests [ 2598960 ] [ 52 5 nCk ] unit-test [ 2598960 ] [ 52 47 nCk ] unit-test + +[ { } ] [ 0 factoradic ] unit-test +[ { 1 0 } ] [ 1 factoradic ] unit-test +[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test + +[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test +[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test +[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test + +[ { 0 1 2 3 } ] [ 0 4 iota permutation-indices ] unit-test +[ { 0 1 3 2 } ] [ 1 4 iota permutation-indices ] unit-test +[ { 1 2 0 6 3 5 4 } ] [ 859 7 iota permutation-indices ] unit-test + [ { "a" "b" "c" "d" } ] [ 0 { "a" "b" "c" "d" } permutation ] unit-test [ { "d" "c" "b" "a" } ] [ 23 { "a" "b" "c" "d" } permutation ] unit-test [ { "d" "a" "b" "c" } ] [ 18 { "a" "b" "c" "d" } permutation ] unit-test @@ -43,3 +44,29 @@ IN: math.combinatorics.tests [ { 2 1 0 } ] [ { "c" "b" "a" } inverse-permutation ] unit-test [ { 3 0 2 1 } ] [ { 12 45 34 2 } inverse-permutation ] unit-test + +[ 2598960 ] [ 52 iota 5 choose ] unit-test + +[ 6 3 13 6 ] [ 7 4 28 next-values ] unit-test +[ 5 2 3 5 ] [ 6 3 13 next-values ] unit-test +[ 3 1 0 3 ] [ 5 2 3 next-values ] unit-test +[ 0 0 0 0 ] [ 3 1 0 next-values ] unit-test + +[ 9 ] [ 0 5 iota 3 dual-index ] unit-test +[ 0 ] [ 9 5 iota 3 dual-index ] unit-test +[ 179 ] [ 72 10 iota 5 dual-index ] unit-test + +[ { 5 3 2 1 } ] [ 7 4 8 combinadic ] unit-test +[ { 4 3 2 1 0 } ] [ 10 iota 5 0 combinadic ] unit-test +[ { 8 6 3 1 0 } ] [ 10 iota 5 72 combinadic ] unit-test +[ { 9 8 7 6 5 } ] [ 10 iota 5 251 combinadic ] unit-test + +[ { 0 1 2 } ] [ 0 5 iota 3 combination-indices ] unit-test +[ { 2 3 4 } ] [ 9 5 iota 3 combination-indices ] unit-test + +[ { "a" "b" "c" } ] [ 0 { "a" "b" "c" "d" "e" } 3 combination ] unit-test +[ { "c" "d" "e" } ] [ 9 { "a" "b" "c" "d" "e" } 3 combination ] unit-test + +[ { { "a" "b" } { "a" "c" } + { "a" "d" } { "b" "c" } + { "b" "d" } { "c" "d" } } ] [ { "a" "b" "c" "d" } 2 all-combinations ] unit-test diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index afdf4e378e..bc09f9fe0f 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -1,7 +1,7 @@ -! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer. +! Copyright (c) 2007-2009 Slava Pestov, Doug Coleman, Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs kernel math math.order math.ranges mirrors -namespaces sequences sorting fry ; +USING: accessors assocs binary-search fry kernel locals math math.order + math.ranges mirrors namespaces sequences sorting ; IN: math.combinatorics [ dupd - ] when ; inline -! See this article for explanation of the factoradic-based permutation methodology: -! http://msdn2.microsoft.com/en-us/library/aa302371.aspx +PRIVATE> + +: factorial ( n -- n! ) + 1 [ 1 + * ] reduce ; + +: nPk ( n k -- nPk ) + 2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ; + +: nCk ( n k -- nCk ) + twiddle [ nPk ] keep factorial / ; + + +! Factoradic-based permutation methodology + + ] [ 1+ [ /mod ] keep swap ] produce reverse 2nip ; + 0 [ over 0 > ] [ 1 + [ /mod ] keep swap ] produce reverse 2nip ; : (>permutation) ( seq n -- seq ) - [ '[ _ dupd >= [ 1+ ] when ] map ] keep prefix ; + [ '[ _ dupd >= [ 1 + ] when ] map ] keep prefix ; : >permutation ( factoradic -- permutation ) reverse 1 cut [ (>permutation) ] each ; @@ -29,27 +42,84 @@ IN: math.combinatorics PRIVATE> -: factorial ( n -- n! ) - 1 [ 1+ * ] reduce ; - -: nPk ( n k -- nPk ) - 2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ; - -: nCk ( n k -- nCk ) - twiddle [ nPk ] keep factorial / ; - : permutation ( n seq -- seq ) [ permutation-indices ] keep nths ; : all-permutations ( seq -- seq ) - [ length factorial ] keep '[ _ permutation ] map ; + [ length factorial ] keep + '[ _ permutation ] map ; : each-permutation ( seq quot -- ) [ [ length factorial ] keep ] dip '[ _ permutation @ ] each ; inline -: reduce-permutations ( seq initial quot -- result ) +: reduce-permutations ( seq identity quot -- result ) swapd each-permutation ; inline : inverse-permutation ( seq -- permutation ) >alist sort-values keys ; + + +! Combinadic-based combination methodology + + combo + +: choose ( combo -- nCk ) + [ seq>> length ] [ k>> ] bi nCk ; + +: largest-value ( a b x -- v ) + dup 0 = [ + drop 1 - nip + ] [ + [ [0,b) ] 2dip '[ _ nCk _ >=< ] search nip + ] if ; + +:: next-values ( a b x -- a' b' x' v ) + a b x largest-value dup :> v ! a' + b 1 - ! b' + x v b nCk - ! x' + v ; ! v == a' + +: dual-index ( m combo -- m' ) + choose 1 - swap - ; + +: initial-values ( combo m -- n k m ) + [ [ seq>> length ] [ k>> ] bi ] dip ; + +: combinadic ( combo m -- combinadic ) + initial-values [ over 0 > ] [ next-values ] produce + [ 3drop ] dip ; + +: combination-indices ( m combo -- seq ) + [ tuck dual-index combinadic ] keep + seq>> length 1 - swap [ - ] with map ; + +: apply-combination ( m combo -- seq ) + [ combination-indices ] keep seq>> nths ; + +PRIVATE> + +: combination ( m seq k -- seq ) + apply-combination ; + +: all-combinations ( seq k -- seq ) + [ choose [0,b) ] keep + '[ _ apply-combination ] map ; + +: each-combination ( seq k quot -- ) + [ [ choose [0,b) ] keep ] dip + '[ _ apply-combination @ ] each ; inline + +: map-combinations ( seq k quot -- ) + [ [ choose [0,b) ] keep ] dip + '[ _ apply-combination @ ] map ; inline + +: reduce-combinations ( seq k identity quot -- result ) + [ -rot ] dip each-combination ; inline + diff --git a/basis/math/constants/constants.factor b/basis/math/constants/constants.factor index 118a8e8197..a2d3213e78 100644 --- a/basis/math/constants/constants.factor +++ b/basis/math/constants/constants.factor @@ -7,6 +7,7 @@ IN: math.constants : euler ( -- gamma ) 0.57721566490153286060 ; inline : phi ( -- phi ) 1.61803398874989484820 ; inline : pi ( -- pi ) 3.14159265358979323846 ; inline +: 2pi ( -- pi ) 2 pi * ; inline : epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline : smallest-float ( -- x ) HEX: 1 bits>double ; foldable : largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor index 397a7cc2f3..66d813bab8 100644 --- a/basis/math/functions/functions-tests.factor +++ b/basis/math/functions/functions-tests.factor @@ -157,3 +157,8 @@ IN: math.functions.tests 2135623355842621559 [ >bignum ] tri@ ^mod ] unit-test + +[ 1.0 ] [ 1.0 2.5 0.0 lerp ] unit-test +[ 2.5 ] [ 1.0 2.5 1.0 lerp ] unit-test +[ 1.75 ] [ 1.0 2.5 0.5 lerp ] unit-test + diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index c21053317e..a1bf9480d5 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -18,12 +18,12 @@ M: real sqrt : factor-2s ( n -- r s ) #! factor an integer into 2^r * s dup 0 = [ 1 ] [ - 0 swap [ dup even? ] [ [ 1+ ] [ 2/ ] bi* ] while + 0 swap [ dup even? ] [ [ 1 + ] [ 2/ ] bi* ] while ] if ; inline interval ] } [ (interval-abs) points>interval ] } cond ; @@ -376,11 +378,11 @@ SYMBOL: incomparable : interval-log2 ( i1 -- i2 ) { { empty-interval [ empty-interval ] } - { full-interval [ 0 [a,inf] ] } + { full-interval [ [0,inf] ] } [ to>> first 1 max dup most-positive-fixnum > [ drop full-interval interval-log2 ] - [ 1+ >integer log2 0 swap [a,b] ] + [ 1 + >integer log2 0 swap [a,b] ] if ] } case ; @@ -407,7 +409,7 @@ SYMBOL: incomparable : integral-closure ( i1 -- i2 ) dup special-interval? [ - [ from>> first2 [ 1+ ] unless ] - [ to>> first2 [ 1- ] unless ] + [ from>> first2 [ 1 + ] unless ] + [ to>> first2 [ 1 - ] unless ] bi [a,b] ] unless ; diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/miller-rabin/miller-rabin.factor deleted file mode 100755 index 8c237d0dc3..0000000000 --- a/basis/math/miller-rabin/miller-rabin.factor +++ /dev/null @@ -1,76 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel locals math math.functions math.ranges -random sequences sets ; -IN: math.miller-rabin - -odd ( n -- int ) dup even? [ 1+ ] when ; foldable - -TUPLE: positive-even-expected n ; - -:: (miller-rabin) ( n trials -- ? ) - [let | r [ n 1- factor-2s drop ] - s [ n 1- factor-2s nip ] - prime?! [ t ] - a! [ 0 ] - count! [ 0 ] | - trials [ - n 1- [1,b] random a! - a s n ^mod 1 = [ - 0 count! - r [ - 2^ s * a swap n ^mod n - -1 = - [ count 1+ count! r + ] when - ] each - count zero? [ f prime?! trials + ] when - ] unless drop - ] each prime? ] ; - -PRIVATE> - -: next-odd ( m -- n ) dup even? [ 1+ ] [ 2 + ] if ; - -: miller-rabin* ( n numtrials -- ? ) - over { - { [ dup 1 <= ] [ 3drop f ] } - { [ dup 2 = ] [ 3drop t ] } - { [ dup even? ] [ 3drop f ] } - [ drop (miller-rabin) ] - } cond ; - -: miller-rabin ( n -- ? ) 10 miller-rabin* ; - -: next-prime ( n -- p ) - next-odd dup miller-rabin [ next-prime ] unless ; - -: random-prime ( numbits -- p ) - random-bits next-prime ; - -ERROR: no-relative-prime n ; - - [ 2 + (find-relative-prime) ] [ nip ] if ; - -PRIVATE> - -: find-relative-prime* ( n guess -- p ) - #! find a prime relative to n with initial guess - >odd (find-relative-prime) ; - -: find-relative-prime ( n -- p ) - dup random find-relative-prime* ; - -ERROR: too-few-primes ; - -: unique-primes ( numbits n -- seq ) - #! generate two primes - swap - dup 5 < [ too-few-primes ] when - 2dup [ random-prime ] curry replicate - dup all-unique? [ 2nip ] [ drop unique-primes ] if ; diff --git a/basis/math/polynomials/polynomials-docs.factor b/basis/math/polynomials/polynomials-docs.factor index edffa5377d..6617556270 100644 --- a/basis/math/polynomials/polynomials-docs.factor +++ b/basis/math/polynomials/polynomials-docs.factor @@ -93,7 +93,13 @@ HELP: pdiff { $description "Finds the derivative of " { $snippet "p" } "." } ; HELP: polyval -{ $values { "p" "a polynomial" } { "x" number } { "p[x]" number } } +{ $values { "x" number } { "p" "a polynomial" } { "p[x]" number } } { $description "Evaluate " { $snippet "p" } " with the input " { $snippet "x" } "." } -{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 0 1 } 2 polyval ." "5" } } ; +{ $examples { $example "USING: math.polynomials prettyprint ;" "2 { 1 0 1 } polyval ." "5" } } ; +HELP: polyval* +{ $values { "p" "a literal polynomial" } } +{ $description "Macro version of " { $link polyval } ". Evaluates the literal polynomial " { $snippet "p" } " at the value off the top of the stack." } +{ $examples { $example "USING: math.polynomials prettyprint ;" "2 { 1 0 1 } polyval* ." "5" } } ; + +{ polyval polyval* } related-words diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor index 749bde3a10..fd6eda4a90 100644 --- a/basis/math/polynomials/polynomials.factor +++ b/basis/math/polynomials/polynomials.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel make math math.order math.vectors sequences - splitting vectors ; + splitting vectors macros combinators ; IN: math.polynomials : powers ( n x -- seq ) - 1 [ * ] accumulate nip ; + 1 [ * ] accumulate nip ; : p= ( p q -- ? ) pextend = ; @@ -29,7 +29,7 @@ PRIVATE> : n*p ( n p -- n*p ) n*v ; : pextend-conv ( p q -- p q ) - 2dup [ length ] bi@ + 1- 2pad-tail [ >vector ] bi@ ; + 2dup [ length ] bi@ + 1 - 2pad-tail [ >vector ] bi@ ; : p* ( p q -- r ) 2unempty pextend-conv dup length @@ -44,7 +44,7 @@ PRIVATE> 2ptrim 2dup [ length ] bi@ - dup 1 < [ drop 1 ] when - [ over length + 0 pad-head pextend ] keep 1+ ; + [ over length + 0 pad-head pextend ] keep 1 + ; : /-last ( seq seq -- a ) #! divide the last two numbers in the sequences @@ -80,6 +80,12 @@ PRIVATE> : pdiff ( p -- p' ) dup length v* { 0 } ?head drop ; -: polyval ( p x -- p[x] ) - [ dup length ] dip powers v. ; +: polyval ( x p -- p[x] ) + [ length swap powers ] [ nip ] 2bi v. ; + +MACRO: polyval* ( p -- ) + reverse + [ 1 tail [ \ * swap \ + [ ] 3sequence ] map ] + [ first \ drop swap [ ] 2sequence ] bi + prefix \ cleave [ ] 2sequence ; diff --git a/basis/math/primes/factors/factors.factor b/basis/math/primes/factors/factors.factor index 278bf70b3d..f5fa468687 100644 --- a/basis/math/primes/factors/factors.factor +++ b/basis/math/primes/factors/factors.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2007-2009 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays combinators kernel make math math.functions math.primes sequences ; +USING: arrays combinators kernel make math math.functions +math.primes sequences ; IN: math.primes.factors ] } 1&& + [ invalid-lucas-lehmer-candidate ] unless ; + +PRIVATE> + +: lucas-lehmer ( p -- ? ) + lucas-lehmer-guard + { + { [ dup 2 = ] [ drop t ] } + { [ dup prime? ] [ do-lucas-lehmer ] } + [ drop f ] + } cond ; diff --git a/basis/math/miller-rabin/authors.txt b/basis/math/primes/miller-rabin/authors.txt similarity index 100% rename from basis/math/miller-rabin/authors.txt rename to basis/math/primes/miller-rabin/authors.txt diff --git a/basis/math/primes/miller-rabin/miller-rabin-docs.factor b/basis/math/primes/miller-rabin/miller-rabin-docs.factor new file mode 100644 index 0000000000..2d19d51e06 --- /dev/null +++ b/basis/math/primes/miller-rabin/miller-rabin-docs.factor @@ -0,0 +1,28 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel sequences math ; +IN: math.primes.miller-rabin + +HELP: miller-rabin +{ $values + { "n" integer } + { "?" "a boolean" } +} +{ $description "Returns true if the number is a prime. Calls " { $link miller-rabin* } " with a default of 10 Miller-Rabin tests." } ; + +{ miller-rabin miller-rabin* } related-words + +HELP: miller-rabin* +{ $values + { "n" integer } { "numtrials" integer } + { "?" "a boolean" } +} +{ $description "Performs " { $snippet "numtrials" } " trials of the Miller-Rabin probabilistic primality test algorithm and returns true if prime." } ; + +ARTICLE: "math.primes.miller-rabin" "Miller-Rabin probabilistic primality test" +"The " { $vocab-link "math.primes.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl +"The Miller-Rabin probabilistic primality test:" +{ $subsection miller-rabin } +{ $subsection miller-rabin* } ; + +ABOUT: "math.primes.miller-rabin" diff --git a/basis/math/miller-rabin/miller-rabin-tests.factor b/basis/math/primes/miller-rabin/miller-rabin-tests.factor similarity index 68% rename from basis/math/miller-rabin/miller-rabin-tests.factor rename to basis/math/primes/miller-rabin/miller-rabin-tests.factor index 5f1b9835e4..d201abfef8 100644 --- a/basis/math/miller-rabin/miller-rabin-tests.factor +++ b/basis/math/primes/miller-rabin/miller-rabin-tests.factor @@ -1,11 +1,11 @@ -USING: math.miller-rabin tools.test ; -IN: math.miller-rabin.tests +USING: kernel math.primes.miller-rabin sequences tools.test ; +IN: math.primes.miller-rabin.tests [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test [ t ] [ 2 miller-rabin ] unit-test [ t ] [ 3 miller-rabin ] unit-test [ f ] [ 36 miller-rabin ] unit-test [ t ] [ 37 miller-rabin ] unit-test -[ 101 ] [ 100 next-prime ] unit-test [ t ] [ 2135623355842621559 miller-rabin ] unit-test -[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test \ No newline at end of file + +[ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test diff --git a/basis/math/primes/miller-rabin/miller-rabin.factor b/basis/math/primes/miller-rabin/miller-rabin.factor new file mode 100755 index 0000000000..b0dfc4ed35 --- /dev/null +++ b/basis/math/primes/miller-rabin/miller-rabin.factor @@ -0,0 +1,35 @@ +! Copyright (c) 2008-2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators combinators.short-circuit kernel locals math +math.functions math.ranges random sequences sets ; +IN: math.primes.miller-rabin + + n-1 + n-1 factor-2s :> s :> r + 0 :> a! + trials [ + drop + 2 n 2 - [a,b] random a! + a s n ^mod 1 = [ + f + ] [ + r iota [ + 2^ s * a swap n ^mod n - -1 = + ] any? not + ] if + ] any? not ; + +PRIVATE> + +: miller-rabin* ( n numtrials -- ? ) + over { + { [ dup 1 <= ] [ 3drop f ] } + { [ dup 2 = ] [ 3drop t ] } + { [ dup even? ] [ 3drop f ] } + [ drop (miller-rabin) ] + } cond ; + +: miller-rabin ( n -- ? ) 10 miller-rabin* ; diff --git a/basis/math/miller-rabin/summary.txt b/basis/math/primes/miller-rabin/summary.txt similarity index 100% rename from basis/math/miller-rabin/summary.txt rename to basis/math/primes/miller-rabin/summary.txt diff --git a/basis/math/primes/primes-docs.factor b/basis/math/primes/primes-docs.factor index c7dbc950e8..71bf3ac2c8 100644 --- a/basis/math/primes/primes-docs.factor +++ b/basis/math/primes/primes-docs.factor @@ -1,10 +1,10 @@ -USING: help.markup help.syntax ; +USING: help.markup help.syntax math sequences ; IN: math.primes { next-prime prime? } related-words HELP: next-prime -{ $values { "n" "an integer not smaller than 2" } { "p" "a prime number" } } +{ $values { "n" integer } { "p" "a prime number" } } { $description "Return the next prime number greater than " { $snippet "n" } "." } ; HELP: prime? @@ -20,3 +20,48 @@ HELP: primes-upto HELP: primes-between { $values { "low" "an integer" } { "high" "an integer" } { "seq" "a sequence" } } { $description "Return a sequence containing all the prime numbers between " { $snippet "low" } " and " { $snippet "high" } "." } ; + +HELP: find-relative-prime +{ $values + { "n" integer } + { "p" integer } +} +{ $description "Returns a number that is relatively prime to " { $snippet "n" } "." } ; + +HELP: find-relative-prime* +{ $values + { "n" integer } { "guess" integer } + { "p" integer } +} +{ $description "Returns a number that is relatively prime to " { $snippet "n" } ", starting by trying " { $snippet "guess" } "." } ; + +HELP: random-prime +{ $values + { "numbits" integer } + { "p" integer } +} +{ $description "Returns a prime number exactly " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ; + +HELP: unique-primes +{ $values + { "numbits" integer } { "n" integer } + { "seq" sequence } +} +{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ; + +ARTICLE: "math.primes" "Prime numbers" +"The " { $vocab-link "math.primes" } " vocabulary implements words related to prime numbers. Serveral useful vocabularies exist for testing primality. The Sieve of Eratosthenes in " { $vocab-link "math.primes.erato" } " is useful for testing primality below five million. For larger integers, " { $vocab-link "math.primes.miller-rabin" } " is a fast probabilstic primality test. The " { $vocab-link "math.primes.lucas-lehmer" } " vocabulary implements an algorithm for finding huge Mersenne prime numbers." $nl +"Testing if a number is prime:" +{ $subsection prime? } +"Generating prime numbers:" +{ $subsection next-prime } +{ $subsection primes-upto } +{ $subsection primes-between } +{ $subsection random-prime } +"Generating relative prime numbers:" +{ $subsection find-relative-prime } +{ $subsection find-relative-prime* } +"Make a sequence of random prime numbers:" +{ $subsection unique-primes } ; + +ABOUT: "math.primes" diff --git a/basis/math/primes/primes-tests.factor b/basis/math/primes/primes-tests.factor index db738399ef..6580f0780e 100644 --- a/basis/math/primes/primes-tests.factor +++ b/basis/math/primes/primes-tests.factor @@ -1,4 +1,6 @@ -USING: arrays math.primes tools.test ; +USING: arrays math math.primes math.primes.miller-rabin +tools.test ; +IN: math.primes.tests { 1237 } [ 1234 next-prime ] unit-test { f t } [ 1234 prime? 1237 prime? ] unit-test @@ -7,3 +9,12 @@ USING: arrays math.primes tools.test ; { { 4999963 4999999 5000011 5000077 5000081 } } [ 4999962 5000082 primes-between >array ] unit-test + +[ 2 ] [ 1 next-prime ] unit-test +[ 3 ] [ 2 next-prime ] unit-test +[ 5 ] [ 3 next-prime ] unit-test +[ 101 ] [ 100 next-prime ] unit-test +[ t ] [ 2135623355842621559 miller-rabin ] unit-test +[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test + +[ 49 ] [ 50 random-prime log2 ] unit-test diff --git a/basis/math/primes/primes.factor b/basis/math/primes/primes.factor index 688fdad713..e3985fc600 100644 --- a/basis/math/primes/primes.factor +++ b/basis/math/primes/primes.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007-2009 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel math math.functions math.miller-rabin -math.order math.primes.erato math.ranges sequences ; +USING: combinators kernel math math.bitwise math.functions +math.order math.primes.erato math.primes.miller-rabin +math.ranges random sequences sets fry ; IN: math.primes } cond ; foldable : next-prime ( n -- p ) - next-odd [ dup really-prime? ] [ 2 + ] until ; foldable + dup 2 < [ + drop 2 + ] [ + next-odd [ dup really-prime? ] [ 2 + ] until + ] if ; foldable : primes-between ( low high -- seq ) [ dup 3 max dup even? [ 1 + ] when ] dip @@ -31,3 +36,34 @@ PRIVATE> : primes-upto ( n -- seq ) 2 swap primes-between ; : coprime? ( a b -- ? ) gcd nip 1 = ; foldable + +: random-prime ( numbits -- p ) + random-bits* next-prime ; + +: estimated-primes ( m -- n ) + dup log / ; foldable + +ERROR: no-relative-prime n ; + + [ 2 + (find-relative-prime) ] [ nip ] if ; + +PRIVATE> + +: find-relative-prime* ( n guess -- p ) + #! find a prime relative to n with initial guess + >odd (find-relative-prime) ; + +: find-relative-prime ( n -- p ) + dup random find-relative-prime* ; + +ERROR: too-few-primes n numbits ; + +: unique-primes ( n numbits -- seq ) + 2dup 2^ estimated-primes > [ too-few-primes ] when + 2dup '[ _ random-prime ] replicate + dup all-unique? [ 2nip ] [ drop unique-primes ] if ; diff --git a/basis/math/primes/safe/authors.txt b/basis/math/primes/safe/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/math/primes/safe/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/math/primes/safe/safe-docs.factor b/basis/math/primes/safe/safe-docs.factor new file mode 100644 index 0000000000..861fc4e4ed --- /dev/null +++ b/basis/math/primes/safe/safe-docs.factor @@ -0,0 +1,38 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.short-circuit help.markup help.syntax kernel +math math.functions math.primes random ; +IN: math.primes.safe + +HELP: next-safe-prime +{ $values + { "n" integer } + { "q" integer } +} +{ $description "Tests consecutive numbers and returns the next safe prime. A safe prime is desirable in cryptography applications such as Diffie-Hellman and SRP6." } ; + +HELP: random-safe-prime +{ $values + { "numbits" integer } + { "p" integer } +} +{ $description "Returns a safe prime number " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ; + +HELP: safe-prime? +{ $values + { "q" integer } + { "?" "a boolean" } +} +{ $description "Tests whether the number is a safe prime. A safe prime " { $snippet "p" } " must be prime, as must " { $snippet "(p - 1) / 2" } "." } ; + + +ARTICLE: "math.primes.safe" "Safe prime numbers" +"The " { $vocab-link "math.primes.safe" } " vocabulary implements words to calculate safe prime numbers. Safe primes are of the form p = 2q + 1, where p,q are prime. Safe primes have desirable qualities for cryptographic applications." $nl + +"Testing if a number is a safe prime:" +{ $subsection safe-prime? } +"Generating safe prime numbers:" +{ $subsection next-safe-prime } +{ $subsection random-safe-prime } ; + +ABOUT: "math.primes.safe" diff --git a/basis/math/primes/safe/safe-tests.factor b/basis/math/primes/safe/safe-tests.factor new file mode 100644 index 0000000000..ef9aa9246f --- /dev/null +++ b/basis/math/primes/safe/safe-tests.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: math.primes.safe math.primes.safe.private tools.test ; +IN: math.primes.safe.tests + +[ 863 ] [ 862 next-safe-prime ] unit-test +[ f ] [ 862 safe-prime? ] unit-test +[ t ] [ 7 safe-prime? ] unit-test +[ f ] [ 31 safe-prime? ] unit-test +[ t ] [ 47 safe-prime-candidate? ] unit-test +[ t ] [ 47 safe-prime? ] unit-test +[ t ] [ 863 safe-prime? ] unit-test + +[ 47 ] [ 31 next-safe-prime ] unit-test diff --git a/basis/math/primes/safe/safe.factor b/basis/math/primes/safe/safe.factor new file mode 100644 index 0000000000..a3becb628f --- /dev/null +++ b/basis/math/primes/safe/safe.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.short-circuit kernel math math.functions +math.primes random ; +IN: math.primes.safe + + + +: safe-prime? ( q -- ? ) + { + [ 1 - 2 / dup integer? [ prime? ] [ drop f ] if ] + [ prime? ] + } 1&& ; + +: next-safe-prime ( n -- q ) + next-safe-prime-candidate + dup safe-prime? [ next-safe-prime ] unless ; + +: random-safe-prime ( numbits -- p ) + random-bits* next-safe-prime ; diff --git a/basis/math/ranges/ranges.factor b/basis/math/ranges/ranges.factor index 068f599b6f..883be006dc 100644 --- a/basis/math/ranges/ranges.factor +++ b/basis/math/ranges/ranges.factor @@ -10,7 +10,7 @@ TUPLE: range { step read-only } ; : ( a b step -- range ) - [ over - ] dip [ /i 1+ 0 max ] keep range boa ; inline + [ over - ] dip [ /i 1 + 0 max ] keep range boa ; inline M: range length ( seq -- n ) length>> ; diff --git a/basis/math/rectangles/prettyprint/authors.txt b/basis/math/rectangles/prettyprint/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/math/rectangles/prettyprint/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/math/rectangles/prettyprint/prettyprint.factor b/basis/math/rectangles/prettyprint/prettyprint.factor new file mode 100644 index 0000000000..c23be50029 --- /dev/null +++ b/basis/math/rectangles/prettyprint/prettyprint.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors math.rectangles kernel prettyprint.custom prettyprint.backend ; +IN: math.rectangles.prettyprint + +M: rect pprint* + \ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ; diff --git a/basis/math/rectangles/rectangles.factor b/basis/math/rectangles/rectangles.factor index 90174d144e..c8569dfdb9 100644 --- a/basis/math/rectangles/rectangles.factor +++ b/basis/math/rectangles/rectangles.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel arrays sequences math math.vectors accessors -parser prettyprint.custom prettyprint.backend ; +parser ; IN: math.rectangles TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ; @@ -10,9 +10,6 @@ TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ; SYNTAX: RECT: scan-object scan-object parsed ; -M: rect pprint* - \ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ; - : ( -- rect ) rect new ; inline : point>rect ( loc -- rect ) { 0 0 } ; inline @@ -21,6 +18,8 @@ M: rect pprint* : rect-extent ( rect -- loc ext ) rect-bounds over v+ ; +: rect-center ( rect -- center ) rect-bounds 2 v/n v+ ; + : with-rect-extents ( rect1 rect2 loc-quot: ( loc1 loc2 -- ) ext-quot: ( ext1 ext2 -- ) -- ) [ [ rect-extent ] bi@ ] 2dip bi-curry* bi* ; inline @@ -62,3 +61,7 @@ M: rect contains-point? [ [ loc>> ] dip (>>loc) ] [ [ dim>> ] dip (>>dim) ] 2bi ; inline + +USING: vocabs vocabs.loader ; + +"prettyprint" vocab [ "math.rectangles.prettyprint" require ] when \ No newline at end of file diff --git a/basis/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor index 589876184f..4cd8c5b888 100644 --- a/basis/math/statistics/statistics.factor +++ b/basis/math/statistics/statistics.factor @@ -15,7 +15,7 @@ IN: math.statistics : median ( seq -- n ) natural-sort dup length even? [ - [ midpoint@ dup 1- 2array ] keep nths mean + [ midpoint@ dup 1 - 2array ] keep nths mean ] [ [ midpoint@ ] keep nth ] if ; @@ -33,7 +33,7 @@ IN: math.statistics drop 0 ] [ [ [ mean ] keep [ - sq ] with sigma ] keep - length 1- / + length 1 - / ] if ; : std ( seq -- x ) @@ -47,7 +47,7 @@ IN: math.statistics 0 [ [ [ pick ] dip swap - ] bi@ * + ] 2reduce 2nip ; : (r) ( mean(x) mean(y) {x} {y} sx sy -- r ) - * recip [ [ ((r)) ] keep length 1- / ] dip * ; + * recip [ [ ((r)) ] keep length 1 - / ] dip * ; : [r] ( {{x,y}...} -- mean(x) mean(y) {x} {y} sx sy ) first2 [ [ [ mean ] bi@ ] 2keep ] 2keep [ std ] bi@ ; diff --git a/basis/math/vectors/vectors-tests.factor b/basis/math/vectors/vectors-tests.factor index aef4ade877..968af6a3aa 100644 --- a/basis/math/vectors/vectors-tests.factor +++ b/basis/math/vectors/vectors-tests.factor @@ -9,3 +9,10 @@ USING: math.vectors tools.test ; [ 5 ] [ { 1 2 } norm-sq ] unit-test [ 13 ] [ { 2 3 } norm-sq ] unit-test +[ { 1.0 2.5 } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.0 vnlerp ] unit-test +[ { 2.5 1.0 } ] [ { 1.0 2.5 } { 2.5 1.0 } 1.0 vnlerp ] unit-test +[ { 1.75 1.75 } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.5 vnlerp ] unit-test + +[ { 1.75 2.125 } ] [ { 1.0 2.5 } { 2.5 1.0 } { 0.5 0.25 } vlerp ] unit-test + +[ 1.125 ] [ 0.0 1.0 2.0 4.0 { 0.5 0.25 } bilerp ] unit-test diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index eb5fa7b970..bad2733bbf 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -6,6 +6,11 @@ IN: math.vectors : vneg ( u -- v ) [ neg ] map ; +: v+n ( u n -- v ) [ + ] curry map ; +: n+v ( n u -- v ) [ + ] with map ; +: v-n ( u n -- v ) [ - ] curry map ; +: n-v ( n u -- v ) [ - ] with map ; + : v*n ( u n -- v ) [ * ] curry map ; : n*v ( n u -- v ) [ * ] with map ; : v/n ( u n -- v ) [ / ] curry map ; @@ -19,6 +24,10 @@ IN: math.vectors : vmax ( u v -- w ) [ max ] 2map ; : vmin ( u v -- w ) [ min ] 2map ; +: vfloor ( v -- _v_ ) [ floor ] map ; +: vceiling ( v -- ^v^ ) [ ceiling ] map ; +: vtruncate ( v -- -v- ) [ truncate ] map ; + : vsupremum ( seq -- vmax ) [ ] [ vmax ] map-reduce ; : vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ; @@ -32,6 +41,23 @@ IN: math.vectors : set-axis ( u v axis -- w ) [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ; +: 2tetra@ ( p q r s t u v w quot -- ) + dup [ [ 2bi@ ] curry 4dip ] dip 2bi@ ; inline + +: trilerp ( aaa baa aba bba aab bab abb bbb {t,u,v} -- a_tuv ) + [ first lerp ] [ second lerp ] [ third lerp ] tri-curry + [ 2tetra@ ] [ 2bi@ ] [ call ] tri* ; + +: bilerp ( aa ba ab bb {t,u} -- a_tu ) + [ first lerp ] [ second lerp ] bi-curry + [ 2bi@ ] [ call ] bi* ; + +: vlerp ( a b t -- a_t ) + [ lerp ] 3map ; + +: vnlerp ( a b t -- a_t ) + [ lerp ] curry 2map ; + HINTS: vneg { array } ; HINTS: norm-sq { array } ; HINTS: norm { array } ; @@ -50,3 +76,9 @@ HINTS: v/ { array array } ; HINTS: vmax { array array } ; HINTS: vmin { array array } ; HINTS: v. { array array } ; + +HINTS: vlerp { array array array } ; +HINTS: vnlerp { array array object } ; + +HINTS: bilerp { object object object object array } ; +HINTS: trilerp { object object object object object object object object array } ; 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/shaders/shaders.factor b/basis/opengl/shaders/shaders.factor index a77d29da2f..15fab1aae0 100755 --- a/basis/opengl/shaders/shaders.factor +++ b/basis/opengl/shaders/shaders.factor @@ -92,11 +92,16 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ; : gl-program-shaders-length ( program -- shaders-length ) GL_ATTACHED_SHADERS gl-program-get-int ; inline +! On some macosx-x86-64 graphics drivers, glGetAttachedShaders tries to treat the +! shaders parameter as a ulonglong array rather than a GLuint array as documented. +! We hack around this by allocating a buffer twice the size and sifting out the zero +! values + : gl-program-shaders ( program -- shaders ) - dup gl-program-shaders-length + dup gl-program-shaders-length 2 * 0 over - [ glGetAttachedShaders ] keep ; + [ glGetAttachedShaders ] keep [ zero? not ] filter ; : delete-gl-program-only ( program -- ) glDeleteProgram ; inline diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index d103e90bee..49725d2242 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -39,6 +39,8 @@ SLOT: display-list GENERIC: draw-scaled-texture ( dim texture -- ) +DEFER: make-texture + > first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri glTexSubImage2D ; -: make-texture ( image -- id ) - #! We use glTexSubImage2D to work around the power of 2 texture size - #! limitation - gen-texture [ - GL_TEXTURE_BIT [ - GL_TEXTURE_2D swap glBindTexture - non-power-of-2-textures? get - [ dup bitmap>> (tex-image) ] - [ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if - ] do-attribs - ] keep ; - : init-texture ( -- ) GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri @@ -176,6 +166,18 @@ CONSTANT: max-texture-size { 512 512 } PRIVATE> +: make-texture ( image -- id ) + #! We use glTexSubImage2D to work around the power of 2 texture size + #! limitation + gen-texture [ + GL_TEXTURE_BIT [ + GL_TEXTURE_2D swap glBindTexture + non-power-of-2-textures? get + [ dup bitmap>> (tex-image) ] + [ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if + ] do-attribs + ] keep ; + : ( image loc -- texture ) over dim>> max-texture-size [ <= ] 2all? [ ] 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/present/present-tests.factor b/basis/present/present-tests.factor index 559b9ac01d..e908fd8147 100644 --- a/basis/present/present-tests.factor +++ b/basis/present/present-tests.factor @@ -1,5 +1,5 @@ IN: present.tests -USING: tools.test present math vocabs sequences kernel ; +USING: tools.test vocabs.hierarchy present math vocabs sequences kernel ; [ "3" ] [ 3 present ] unit-test [ "Hi" ] [ "Hi" present ] unit-test diff --git a/basis/random/mersenne-twister/mersenne-twister-tests.factor b/basis/random/mersenne-twister/mersenne-twister-tests.factor index c35d7488ac..651e43ef5b 100644 --- a/basis/random/mersenne-twister/mersenne-twister-tests.factor +++ b/basis/random/mersenne-twister/mersenne-twister-tests.factor @@ -11,7 +11,7 @@ IN: random.mersenne-twister.tests 100 [ 100 random ] replicate ; : test-rng ( seed quot -- ) - [ ] dip with-random ; inline + [ ] dip with-random ; inline [ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test diff --git a/basis/random/random-docs.factor b/basis/random/random-docs.factor index c7600a731f..222ecaf935 100755 --- a/basis/random/random-docs.factor +++ b/basis/random/random-docs.factor @@ -40,9 +40,17 @@ HELP: random-bytes } ; HELP: random-bits -{ $values { "n" "an integer" } { "r" "a random integer" } } +{ $values { "numbits" integer } { "r" "a random integer" } } { $description "Outputs an random integer n bits in length." } ; +HELP: random-bits* +{ $values + { "numbits" integer } + { "n" integer } +} +{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ; + + HELP: with-random { $values { "tuple" "a random generator" } { "quot" "a quotation" } } { $description "Calls the quotation with the random generator in a dynamic variable. All random numbers will be generated using this random generator." } ; @@ -93,6 +101,9 @@ $nl "Randomizing a sequence:" { $subsection randomize } "Deleting a random element from a sequence:" -{ $subsection delete-random } ; +{ $subsection delete-random } +"Random numbers with " { $snippet "n" } " bits:" +{ $subsection random-bits } +{ $subsection random-bits* } ; ABOUT: "random" diff --git a/basis/random/random-tests.factor b/basis/random/random-tests.factor index 9607627b3d..2b6ac9b1b8 100644 --- a/basis/random/random-tests.factor +++ b/basis/random/random-tests.factor @@ -23,3 +23,5 @@ IN: random.tests [ f ] [ 100 [ { 0 1 } random ] replicate all-equal? ] unit-test + +[ 49 ] [ 50 random-bits* log2 ] unit-test diff --git a/basis/random/random.factor b/basis/random/random.factor index d972e1e7ac..661e771258 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -3,7 +3,7 @@ USING: alien.c-types kernel math namespaces sequences io.backend io.binary combinators system vocabs.loader summary math.bitwise byte-vectors fry byte-arrays -math.ranges ; +math.ranges math.constants math.functions accessors ; IN: random SYMBOL: system-random-generator @@ -45,7 +45,10 @@ M: f random-32* ( obj -- * ) no-random-number-generator ; PRIVATE> -: random-bits ( n -- r ) 2^ random-integer ; +: random-bits ( numbits -- r ) 2^ random-integer ; + +: random-bits* ( numbits -- n ) + 1 - [ random-bits ] keep set-bit ; : random ( seq -- elt ) [ f ] [ @@ -69,6 +72,20 @@ PRIVATE> : with-secure-random ( quot -- ) secure-random-generator get swap with-random ; inline +: uniform-random-float ( min max -- n ) + 4 random-bytes underlying>> *uint >float + 4 random-bytes underlying>> *uint >float + 2.0 32 ^ * + + [ over - 2.0 -64 ^ * ] dip + * + ; inline + +: normal-random-float ( mean sigma -- n ) + 0.0 1.0 uniform-random-float + 0.0 1.0 uniform-random-float + [ 2 pi * * cos ] + [ 1.0 swap - log -2.0 * sqrt ] + bi* * * + ; + USE: vocabs.loader { diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor index 73e719b806..1e470b699a 100644 --- a/basis/specialized-arrays/specialized-arrays-tests.factor +++ b/basis/specialized-arrays/specialized-arrays-tests.factor @@ -2,7 +2,8 @@ IN: specialized-arrays.tests USING: tools.test specialized-arrays sequences specialized-arrays.int specialized-arrays.bool specialized-arrays.ushort alien.c-types accessors kernel -specialized-arrays.direct.int arrays ; +specialized-arrays.direct.int specialized-arrays.char +specialized-arrays.uint arrays combinators ; [ t ] [ { 1 2 3 } >int-array int-array? ] unit-test @@ -10,7 +11,13 @@ specialized-arrays.direct.int arrays ; [ 2 ] [ int-array{ 1 2 3 } second ] unit-test -[ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >int-array underlying>> = ] unit-test +[ t ] [ + { t f t } >bool-array underlying>> + { 1 0 1 } "bool" heap-size { + { 1 [ >char-array ] } + { 4 [ >uint-array ] } + } case underlying>> = +] unit-test [ ushort-array{ 1234 } ] [ little-endian? B{ 210 4 } B{ 4 210 } ? byte-array>ushort-array diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index f6f94bf20d..56ef67d2a8 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -95,15 +95,6 @@ M: composed infer-call* M: object infer-call* "literal quotation" literal-expected ; -: infer-nslip ( n -- ) - [ infer->r infer-call ] [ infer-r> ] bi ; - -: infer-slip ( -- ) 1 infer-nslip ; - -: infer-2slip ( -- ) 2 infer-nslip ; - -: infer-3slip ( -- ) 3 infer-nslip ; - : infer-ndip ( word n -- ) [ literals get ] 2dip [ '[ _ def>> infer-quot-here ] ] @@ -180,9 +171,6 @@ M: object infer-call* { \ declare [ infer-declare ] } { \ call [ infer-call ] } { \ (call) [ infer-call ] } - { \ slip [ infer-slip ] } - { \ 2slip [ infer-2slip ] } - { \ 3slip [ infer-3slip ] } { \ dip [ infer-dip ] } { \ 2dip [ infer-2dip ] } { \ 3dip [ infer-3dip ] } @@ -216,7 +204,7 @@ M: object infer-call* "local-word-def" word-prop infer-quot-here ; { - declare call (call) slip 2slip 3slip dip 2dip 3dip curry compose + declare call (call) dip 2dip 3dip curry compose execute (execute) call-effect-unsafe execute-effect-unsafe if dispatch exit load-local load-locals get-local drop-locals do-primitive alien-invoke alien-indirect @@ -651,7 +639,7 @@ M: object infer-call* \ become { array array } { } define-primitive -\ innermost-frame-quot { callstack } { quotation } define-primitive +\ innermost-frame-executing { callstack } { object } define-primitive \ innermost-frame-scan { callstack } { fixnum } define-primitive diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 919cd098f6..201f3ce30b 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -180,7 +180,7 @@ DEFER: blah4 over [ 2drop ] [ - [ swap slip ] keep swap bad-combinator + [ dip ] keep swap bad-combinator ] if ; inline recursive [ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail 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/continuations/continuations.factor b/basis/tools/continuations/continuations.factor index 8c572f4ae3..15fdb9f9b5 100644 --- a/basis/tools/continuations/continuations.factor +++ b/basis/tools/continuations/continuations.factor @@ -4,7 +4,7 @@ USING: threads kernel namespaces continuations combinators sequences math namespaces.private continuations.private concurrency.messaging quotations kernel.private words sequences.private assocs models models.arrow arrays accessors -generic generic.single definitions make sbufs tools.crossref ; +generic generic.single definitions make sbufs tools.crossref fry ; IN: tools.continuations > +: >innermost-frame< ( callstack -- n quot ) + [ innermost-frame-scan 1 + ] [ innermost-frame-executing ] bi ; + +: (change-frame) ( callstack quot -- callstack' ) + [ dup innermost-frame-executing quotation? ] dip '[ + clone [ >innermost-frame< @ ] [ set-innermost-frame-quot ] [ ] tri + ] when ; inline + : change-frame ( continuation quot -- continuation' ) #! Applies quot to innermost call frame of the #! continuation. - [ clone ] dip [ - [ clone ] dip - [ - [ - [ innermost-frame-scan 1+ ] - [ innermost-frame-quot ] bi - ] dip call - ] - [ drop set-innermost-frame-quot ] - [ drop ] - 2tri - ] curry change-call ; inline + [ clone ] dip '[ _ (change-frame) ] change-call ; inline PRIVATE> @@ -101,7 +98,7 @@ PRIVATE> [ 2dup length = [ nip [ break ] append ] [ 2dup nth \ break = [ nip ] [ - swap 1+ cut [ break ] glue + swap 1 + cut [ break ] glue ] if ] if ] change-frame ; @@ -109,7 +106,6 @@ PRIVATE> : continuation-step-out ( continuation -- continuation' ) [ nip \ break suffix ] change-frame ; - { { call [ (step-into-quot) ] } { dip [ (step-into-dip) ] } @@ -124,7 +120,7 @@ PRIVATE> ! Never step into these words : don't-step-into ( word -- ) - dup [ execute break ] curry "step-into" set-word-prop ; + dup '[ _ execute break ] "step-into" set-word-prop ; { >n ndrop >c c> @@ -151,6 +147,4 @@ PRIVATE> ] change-frame ; : continuation-current ( continuation -- obj ) - call>> - [ innermost-frame-scan 1+ ] - [ innermost-frame-quot ] bi ?nth ; + call>> >innermost-frame< ?nth ; 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 fd43d1ccc9..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 @@ -23,7 +23,13 @@ IN: tools.deploy.shaker : strip-init-hooks ( -- ) "Stripping startup hooks" show - { "cpu.x86" "command-line" "libc" "system" "environment" } + { + "command-line" + "cpu.x86" + "environment" + "libc" + "alien.strings" + } [ init-hooks get delete-at ] each deploy-threads? get [ "threads" init-hooks get delete-at @@ -34,10 +40,15 @@ 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" init-hooks get delete-at - "vocabs.cache" init-hooks get delete-at + { + ! "compiler.units" + "vocabs" + "vocabs.cache" + "source-files.errors" + } [ init-hooks get delete-at ] each ] when ; : strip-debugger ( -- ) @@ -183,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 @@ -245,36 +264,35 @@ 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 - layouts:num-tags - layouts:num-types - layouts:tag-mask - layouts:tag-numbers - layouts:type-numbers lexer-factory print-use-hook root-cache source-files.errors:error-types + source-files.errors:error-observers vocabs:dictionary vocabs:load-vocab-hook + vocabs:vocab-observers word parser-notes } % + { } { "layouts" } strip-vocab-globals % + { } { "math.partial-dispatch" } strip-vocab-globals % { } { "peg" } strip-vocab-globals % @@ -289,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 ; @@ -313,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 ; @@ -340,19 +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 ; - -: finish-deploy ( final-image -- ) - "Finishing up" show - V{ } set-namestack - V{ } set-catchstack - "Saving final image" show - save-image-and-exit ; - SYMBOL: deploy-vocab : [:c] ( -- word ) ":c" "debugger" lookup ; @@ -383,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 @@ -402,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 -- ) [ @@ -430,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 @@ -437,7 +483,8 @@ SYMBOL: deploy-vocab "Vocabulary has no MAIN: word." print flush 1 exit ] unless strip - finish-deploy + "Saving final image" show + save-image-and-exit ] deploy-error-handler ] bind ; 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/disassembler/udis/udis-tests.factor b/basis/tools/disassembler/udis/udis-tests.factor new file mode 100644 index 0000000000..9ad3dbbcc2 --- /dev/null +++ b/basis/tools/disassembler/udis/udis-tests.factor @@ -0,0 +1,9 @@ +IN: tools.disassembler.udis.tests +USING: tools.disassembler.udis tools.test alien.c-types system combinators kernel ; + +{ + { [ os linux? cpu x86.64? and ] [ [ 656 ] [ "ud" heap-size ] unit-test ] } + { [ os macosx? cpu x86.32? and ] [ [ 592 ] [ "ud" heap-size ] unit-test ] } + { [ os macosx? cpu x86.64? and ] [ [ 656 ] [ "ud" heap-size ] unit-test ] } + [ ] +} cond \ No newline at end of file diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor index cd9dd9cf4b..df624cab28 100755 --- a/basis/tools/disassembler/udis/udis.factor +++ b/basis/tools/disassembler/udis/udis.factor @@ -16,7 +16,57 @@ IN: tools.disassembler.udis LIBRARY: libudis86 -TYPEDEF: char[592] ud +C-STRUCT: ud_operand + { "int" "type" } + { "uchar" "size" } + { "ulonglong" "lval" } + { "int" "base" } + { "int" "index" } + { "uchar" "offset" } + { "uchar" "scale" } ; + +C-STRUCT: ud + { "void*" "inp_hook" } + { "uchar" "inp_curr" } + { "uchar" "inp_fill" } + { "FILE*" "inp_file" } + { "uchar" "inp_ctr" } + { "uchar*" "inp_buff" } + { "uchar*" "inp_buff_end" } + { "uchar" "inp_end" } + { "void*" "translator" } + { "ulonglong" "insn_offset" } + { "char[32]" "insn_hexcode" } + { "char[64]" "insn_buffer" } + { "uint" "insn_fill" } + { "uchar" "dis_mode" } + { "ulonglong" "pc" } + { "uchar" "vendor" } + { "struct map_entry*" "mapen" } + { "int" "mnemonic" } + { "ud_operand[3]" "operand" } + { "uchar" "error" } + { "uchar" "pfx_rex" } + { "uchar" "pfx_seg" } + { "uchar" "pfx_opr" } + { "uchar" "pfx_adr" } + { "uchar" "pfx_lock" } + { "uchar" "pfx_rep" } + { "uchar" "pfx_repe" } + { "uchar" "pfx_repne" } + { "uchar" "pfx_insn" } + { "uchar" "default64" } + { "uchar" "opr_mode" } + { "uchar" "adr_mode" } + { "uchar" "br_far" } + { "uchar" "br_near" } + { "uchar" "implicit_addr" } + { "uchar" "c1" } + { "uchar" "c2" } + { "uchar" "c3" } + { "uchar[256]" "inp_cache" } + { "uchar[64]" "inp_sess" } + { "ud_itab_entry*" "itab_entry" } ; FUNCTION: void ud_translate_intel ( ud* u ) ; FUNCTION: void ud_translate_att ( ud* u ) ; diff --git a/basis/tools/time/time.factor b/basis/tools/time/time.factor index 65e87f976f..948c0d482d 100644 --- a/basis/tools/time/time.factor +++ b/basis/tools/time/time.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.vectors memory io io.styles prettyprint +USING: kernel math memory io io.styles prettyprint namespaces system sequences splitting grouping assocs strings generic.single combinators ; IN: tools.time diff --git a/basis/tools/trace/trace-tests.factor b/basis/tools/trace/trace-tests.factor index 74f7c40943..06511c7ada 100644 --- a/basis/tools/trace/trace-tests.factor +++ b/basis/tools/trace/trace-tests.factor @@ -1,4 +1,30 @@ IN: tools.trace.tests -USING: tools.trace tools.test sequences ; +USING: tools.trace tools.test tools.continuations kernel math combinators +sequences ; -[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test \ No newline at end of file +[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test + +GENERIC: method-breakpoint-test ( x -- y ) + +TUPLE: method-breakpoint-tuple ; + +M: method-breakpoint-tuple method-breakpoint-test break drop 1 2 + ; + +\ method-breakpoint-test don't-step-into + +[ 3 ] +[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] trace ] unit-test + +: case-breakpoint-test ( -- x ) + 5 { [ break 1 + ] } case ; + +\ case-breakpoint-test don't-step-into + +[ 6 ] [ [ case-breakpoint-test ] trace ] unit-test + +: call(-breakpoint-test ( -- x ) + [ break 1 ] call( -- x ) 2 + ; + +\ call(-breakpoint-test don't-step-into + +[ 3 ] [ [ call(-breakpoint-test ] trace ] unit-test diff --git a/basis/tools/trace/trace.factor b/basis/tools/trace/trace.factor index e2c6bf864b..f7f0ae4a69 100644 --- a/basis/tools/trace/trace.factor +++ b/basis/tools/trace/trace.factor @@ -4,19 +4,21 @@ USING: concurrency.promises models tools.continuations kernel sequences concurrency.messaging locals continuations threads namespaces namespaces.private make assocs accessors io strings prettyprint math math.parser words effects summary io.styles classes -generic.math combinators.short-circuit ; +generic.math combinators.short-circuit kernel.private quotations ; IN: tools.trace -: callstack-depth ( callstack -- n ) - callstack>array length 2/ ; - -SYMBOL: end - SYMBOL: exclude-vocabs SYMBOL: include-vocabs exclude-vocabs { "math" "accessors" } swap set-global +array length 2/ ; + +SYMBOL: end + : include? ( vocab -- ? ) include-vocabs get dup [ member? ] [ 2drop t ] if ; @@ -65,15 +67,20 @@ M: trace-step summary [ CHAR: \s write ] [ number>string write ": " write ] bi ; +: trace-into? ( continuation -- ? ) + continuation-current into? ; + : trace-step ( continuation -- continuation' ) - dup continuation-current end eq? [ - [ print-depth ] - [ print-step ] - [ - dup continuation-current into? - [ continuation-step-into ] [ continuation-step ] if - ] tri - ] unless ; + dup call>> innermost-frame-executing quotation? [ + dup continuation-current end eq? [ + [ print-depth ] + [ print-step ] + [ dup trace-into? [ continuation-step-into ] [ continuation-step ] if ] + tri + ] unless + ] when ; + +PRIVATE> : trace ( quot -- data ) [ [ trace-step ] break-hook ] dip diff --git a/basis/tools/walker/walker-tests.factor b/basis/tools/walker/walker-tests.factor index 6f87792faa..b6094d7d7e 100644 --- a/basis/tools/walker/walker-tests.factor +++ b/basis/tools/walker/walker-tests.factor @@ -2,7 +2,7 @@ USING: tools.walker io io.streams.string kernel math math.private namespaces prettyprint sequences tools.test continuations math.parser threads arrays tools.walker.debug generic.single sequences.private kernel.private -tools.continuations accessors words ; +tools.continuations accessors words combinators ; IN: tools.walker.tests [ { } ] [ @@ -131,4 +131,18 @@ M: method-breakpoint-tuple method-breakpoint-test break drop 1 2 + ; \ method-breakpoint-test don't-step-into [ { 3 } ] -[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] test-walker ] unit-test \ No newline at end of file +[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] test-walker ] unit-test + +: case-breakpoint-test ( -- x ) + 5 { [ break 1 + ] } case ; + +\ case-breakpoint-test don't-step-into + +[ { 6 } ] [ [ case-breakpoint-test ] test-walker ] unit-test + +: call(-breakpoint-test ( -- x ) + [ break 1 ] call( -- x ) 2 + ; + +\ call(-breakpoint-test don't-step-into + +[ { 3 } ] [ [ call(-breakpoint-test ] test-walker ] unit-test diff --git a/basis/ui/backend/backend.factor b/basis/ui/backend/backend.factor index 9c844d3663..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 -- ) @@ -31,4 +31,8 @@ HOOK: offscreen-pixels ui-backend ( world -- alien w h ) '[ select-gl-context @ ] [ flush-gl-context gl-error ] bi ; inline -HOOK: (with-ui) ui-backend ( quot -- ) \ No newline at end of file +HOOK: (with-ui) ui-backend ( quot -- ) + +HOOK: (grab-input) ui-backend ( handle -- ) + +HOOK: (ungrab-input) ui-backend ( handle -- ) diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index 5b1b4b0c2a..73eff25240 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -29,7 +29,7 @@ PIXEL-FORMAT-ATTRIBUTE-TABLE: NSOpenGLPFA { } H{ { fullscreen { $ NSOpenGLPFAFullScreen } } { windowed { $ NSOpenGLPFAWindow } } { accelerated { $ NSOpenGLPFAAccelerated } } - { software-rendered { $ NSOpenGLPFASingleRenderer $ kCGLRendererGenericFloatID } } + { software-rendered { $ NSOpenGLPFARendererID $ kCGLRendererGenericFloatID } } { backing-store { $ NSOpenGLPFABackingStore } } { multisampled { $ NSOpenGLPFAMultisample } } { supersampled { $ NSOpenGLPFASupersample } } @@ -101,10 +101,10 @@ M: cocoa-ui-backend set-title ( string world -- ) : exit-fullscreen ( world -- ) handle>> view>> f -> exitFullScreenModeWithOptions: ; -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 -- ) @@ -122,6 +122,20 @@ M:: cocoa-ui-backend (open-window) ( world -- ) M: cocoa-ui-backend (close-window) ( handle -- ) window>> -> release ; +M: cocoa-ui-backend (grab-input) ( handle -- ) + 0 CGAssociateMouseAndMouseCursorPosition drop + CGMainDisplayID CGDisplayHideCursor drop + window>> -> frame CGRect>rect rect-center + 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 + CGMainDisplayID CGDisplayShowCursor drop + 1 CGAssociateMouseAndMouseCursorPosition drop ; + M: cocoa-ui-backend close-window ( gadget -- ) find-world [ handle>> [ diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 24ae72740f..1ca3e85232 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -11,7 +11,7 @@ threads libc combinators fry combinators.short-circuit continuations command-line shuffle opengl ui.render ascii math.bitwise locals accessors math.rectangles math.order ascii calendar io.encodings.utf16n windows.errors literals ui.pixel-formats -ui.pixel-formats.private memoize classes ; +ui.pixel-formats.private memoize classes struct-arrays ; IN: ui.backend.windows SINGLETON: windows-ui-backend @@ -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,24 +616,22 @@ 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 get-global [ dup f UnregisterClass drop free ] when* - msg-obj get-global [ free ] when* - f class-name-ptr set-global - f msg-obj set-global ; + 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 ; +: get-dc ( world -- ) + handle>> dup hWnd>> GetDC dup win32-error=0/f >>hDC drop ; : get-rc ( world -- ) handle>> dup hDC>> dup wglCreateContext dup win32-error=0/f [ wglMakeCurrent win32-error=0/f ] keep >>hRC drop ; : set-pixel-format ( pixel-format hdc -- ) - swap handle>> "PIXELFORMATDESCRIPTOR" SetPixelFormat win32-error=0/f ; + swap handle>> + "PIXELFORMATDESCRIPTOR" SetPixelFormat win32-error=0/f ; : setup-gl ( world -- ) [ get-dc ] keep @@ -703,9 +706,24 @@ M: windows-ui-backend beep ( -- ) "MONITORINFOEX" dup length over set-MONITORINFOEX-cbSize [ GetMonitorInfo win32-error=0/f ] keep MONITORINFOEX-rcMonitor ; +: client-area>RECT ( hwnd -- RECT ) + "RECT" + [ GetClientRect win32-error=0/f ] + [ "POINT" byte-array>struct-array [ ClientToScreen drop ] with each ] + [ nip ] 2tri ; + : hwnd>RECT ( hwnd -- RECT ) "RECT" [ GetWindowRect win32-error=0/f ] keep ; +M: windows-ui-backend (grab-input) ( handle -- ) + 0 ShowCursor drop + hWnd>> client-area>RECT ClipCursor drop ; + +M: windows-ui-backend (ungrab-input) ( handle -- ) + drop + f ClipCursor drop + 1 ShowCursor drop ; + : fullscreen-flags ( -- n ) { WS_CAPTION WS_BORDER WS_THICKFRAME } flags ; inline @@ -743,8 +761,13 @@ M: windows-ui-backend beep ( -- ) [ 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/gadgets.factor b/basis/ui/gadgets/gadgets.factor index f9f397d46f..5dd1710cdd 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -3,8 +3,7 @@ USING: accessors arrays hashtables kernel models math namespaces make sequences quotations math.vectors combinators sorting binary-search vectors dlists deques models threads -concurrency.flags math.order math.rectangles fry locals -prettyprint.backend prettyprint.custom ; +concurrency.flags math.order math.rectangles fry locals ; IN: ui.gadgets ! Values for orientation slot @@ -28,9 +27,6 @@ interior boundary model ; -! Don't print gadgets with RECT: syntax -M: gadget pprint* pprint-tuple ; - M: gadget equal? 2drop f ; M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ; @@ -397,3 +393,7 @@ M: f request-focus-on 2drop ; : focus-path ( gadget -- seq ) [ focus>> ] follow ; + +USING: vocabs vocabs.loader ; + +"prettyprint" vocab [ "ui.gadgets.prettyprint" require ] when \ No newline at end of file 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/prettyprint/authors.txt b/basis/ui/gadgets/prettyprint/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/ui/gadgets/prettyprint/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/ui/gadgets/prettyprint/prettyprint.factor b/basis/ui/gadgets/prettyprint/prettyprint.factor new file mode 100644 index 0000000000..82a89eda11 --- /dev/null +++ b/basis/ui/gadgets/prettyprint/prettyprint.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: ui.gadgets prettyprint.backend prettyprint.custom ; +IN: ui.gadgets.prettyprint + +! Don't print gadgets with RECT: syntax +M: gadget pprint* pprint-tuple ; \ No newline at end of file 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 3568559eac..38fb220c69 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -4,14 +4,14 @@ 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 { windowed double-buffered T{ depth-bits { value 16 } } } TUPLE: world < track - active? focused? + active? focused? grab-input? layers title status status-owner text-handle handle images @@ -20,7 +20,8 @@ TUPLE: world < track TUPLE: world-attributes { world-class initial: world } - title + grab-input? + { title string initial: "Factor Window" } status gadgets { pixel-format-attributes initial: $ default-world-pixel-format-attributes } ; @@ -30,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>> [ @@ -62,14 +77,16 @@ M: world request-focus-on ( child gadget -- ) : new-world ( class -- world ) vertical swap new-track t >>root? - t >>active? - { 0 0 } >>window-loc ; + f >>active? + { 0 0 } >>window-loc + f >>grab-input? ; : apply-world-attributes ( world attributes -- world ) { [ title>> >>title ] [ status>> >>status ] [ pixel-format-attributes>> >>pixel-format-attributes ] + [ grab-input?>> >>grab-input? ] [ gadgets>> [ 1 track-add ] each ] } cleave ; @@ -84,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:"