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/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..92d75604e0 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 @@ -510,11 +470,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 +480,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 +503,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/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/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/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..6b383388ef 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 +: word-xt-offset ( -- n ) 10 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-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..fa1248435b 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -389,4 +389,10 @@ 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 \ 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..ee9abf00ec 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -157,11 +157,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..924f7130f0 100644 --- a/basis/core-graphics/core-graphics.factor +++ b/basis/core-graphics/core-graphics.factor @@ -105,6 +105,15 @@ 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 CGAssociateMouseAndMouseCursorPosition ( boolean_t connected ) ; + +FUNCTION: CGError CGWarpMouseCursorPosition ( CGPoint newCursorPosition ) ; + 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/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/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/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/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/files/unique/unique.factor b/basis/io/files/unique/unique.factor index 0e4338e3e0..a7ae317668 100644 --- a/basis/io/files/unique/unique.factor +++ b/basis/io/files/unique/unique.factor @@ -35,6 +35,9 @@ SYMBOL: unique-retries : random-name ( -- string ) unique-length get [ random-ch ] "" replicate-as ; +: retry ( quot: ( -- ? ) n -- ) + swap [ drop ] prepose attempt-all ; inline + : (make-unique-file) ( path prefix suffix -- path ) '[ _ _ _ random-name glue append-path 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/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/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/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/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/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..842faba640 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" diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index fd43d1ccc9..d79326ddc4 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -1,13 +1,11 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors io.backend io.streams.c init fry -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 +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 combinators classes ; QUALIFIED: bootstrap.stage2 -QUALIFIED: classes QUALIFIED: command-line QUALIFIED: compiler.errors QUALIFIED: continuations @@ -23,7 +21,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 @@ -36,8 +40,12 @@ IN: tools.deploy.shaker "io.backend" 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 +191,11 @@ IN: tools.deploy.shaker strip-word-names? [ dup strip-word-names ] when 2drop ; +: strip-compiler-classes ( -- ) + "Stripping compiler classes" show + "compiler" child-vocabs [ words ] map concat [ class? ] filter + [ dup implementors [ "methods" word-prop delete-at ] with each ] each ; + : strip-default-methods ( -- ) strip-debugger? [ "Stripping default methods" show @@ -245,14 +258,14 @@ 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 @@ -260,21 +273,20 @@ IN: tools.deploy.shaker compiler.errors:compiler-errors 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 % @@ -325,8 +337,17 @@ IN: tools.deploy.shaker [ 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 @@ -340,19 +361,6 @@ IN: tools.deploy.shaker [ quotation? ] [ remain-compiled ] "quotations" compress [ quotation? ] instances [ f >>cached-effect f >>cache-counter drop ] each ; -: compress-strings ( -- ) - [ string? ] [ ] "strings" compress ; - -: compress-wrappers ( -- ) - [ wrapper? ] [ ] "wrappers" compress ; - -: 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 +391,23 @@ SYMBOL: deploy-vocab t "quiet" set-global f output-stream set-global ; +: unsafe-next-method-quot ( method -- quot ) + [ "method-class" word-prop ] + [ "method-generic" word-prop ] bi + next-method 1quotation ; + : compute-next-methods ( -- ) [ standard-generic? ] instances [ "methods" word-prop [ - nip - 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 ; : strip ( -- ) init-stripper - strip-default-methods strip-libc strip-call strip-cocoa @@ -402,14 +415,14 @@ SYMBOL: deploy-vocab compute-next-methods strip-init-hooks strip-c-io + strip-compiler-classes + strip-default-methods f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore deploy-vocab get vocab-main deploy-boot-quot stripped-word-props stripped-globals strip-globals - compress-byte-arrays + compress-objects compress-quotations - compress-strings - compress-wrappers strip-words ; : deploy-error-handler ( quot -- ) @@ -437,7 +450,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 deleted file mode 100644 index c495928bf2..0000000000 --- a/basis/tools/deploy/test/8/8.factor +++ /dev/null @@ -1,11 +0,0 @@ -USING: kernel ; -IN: tools.deploy.test.8 - -: literal-merge-test-1 ( -- x ) H{ { "lil" "wayne" } } ; -: literal-merge-test-2 ( -- x ) H{ { "lil" "wayne" } } ; - -: literal-merge-test ( -- ) - literal-merge-test-1 - literal-merge-test-2 eq? t assert= ; - -MAIN: literal-merge-test 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/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..63d551798c 100755 --- a/basis/ui/backend/backend.factor +++ b/basis/ui/backend/backend.factor @@ -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..47a3bfc1a6 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 } } @@ -122,6 +122,17 @@ 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 + first2 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..2cf4091937 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 @@ -616,19 +616,21 @@ M: windows-ui-backend do-events GetDoubleClickTime milliseconds double-click-timeout set-global ; : cleanup-win32-ui ( -- ) - class-name-ptr get-global [ dup f UnregisterClass drop free ] when* - 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 change-global [ [ free ] when* f ] ; -: 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 +705,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 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/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..d85bba9992 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.commands 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 ; 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/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/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:"