diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 6067c90f2d..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,8 +410,8 @@ CONSTANT: primitive-types "uchar" define-primitive-type - [ alien-unsigned-1 zero? not ] >>getter - [ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter + [ alien-unsigned-1 c-bool> ] >>getter + [ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter 1 >>size 1 >>align "box_boolean" >>boxer 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/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/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/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 47593878fa..c7b67b72b4 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -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/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/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/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/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 442dd8e7ea..dc7108b3a1 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -2,11 +2,11 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs sequences kernel combinators make math math.order math.ranges system namespaces locals layouts words -alien alien.c-types literals cpu.architecture cpu.ppc.assembler -cpu.ppc.assembler.backend literals compiler.cfg.registers +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.cfg.stack-frame compiler.units ; IN: cpu.ppc ! PowerPC register assignments: @@ -713,4 +713,14 @@ USE: vocabs.loader } cond "complex-double" c-type t >>return-in-registers? drop -"bool" c-type 4 >>size 4 >>align drop \ No newline at end of file + +[ + + [ 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/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/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/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/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/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index 73d111f91e..ff4806348b 100755 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -35,6 +35,11 @@ IN: math.bitwise : w- ( int int -- int ) - 32 bits ; inline : w* ( int int -- int ) * 32 bits ; inline +! 64-bit arithmetic +: W+ ( int int -- int ) + 64 bits ; inline +: W- ( int int -- int ) - 64 bits ; inline +: W* ( int int -- int ) * 64 bits ; inline + ! flags MACRO: flags ( values -- ) [ 0 ] [ [ ?execute bitor ] curry compose ] reduce ; @@ -106,3 +111,10 @@ PRIVATE> : >signed ( x n -- y ) 2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ; +: >odd ( n -- int ) 0 set-bit ; foldable + +: >even ( n -- int ) 0 clear-bit ; foldable + +: next-even ( m -- n ) >even 2 + ; foldable + +: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; foldable diff --git a/basis/math/miller-rabin/miller-rabin-docs.factor b/basis/math/miller-rabin/miller-rabin-docs.factor deleted file mode 100644 index 4aa318f674..0000000000 --- a/basis/math/miller-rabin/miller-rabin-docs.factor +++ /dev/null @@ -1,100 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax kernel sequences math ; -IN: math.miller-rabin - -HELP: find-relative-prime -{ $values - { "n" integer } - { "p" integer } -} -{ $description "Returns a number that is relatively prime to " { $snippet "n" } "." } ; - -HELP: find-relative-prime* -{ $values - { "n" integer } { "guess" integer } - { "p" integer } -} -{ $description "Returns a number that is relatively prime to " { $snippet "n" } ", starting by trying " { $snippet "guess" } "." } ; - -HELP: miller-rabin -{ $values - { "n" integer } - { "?" "a boolean" } -} -{ $description "Returns true if the number is a prime. Calls " { $link miller-rabin* } " with a default of 10 Miller-Rabin tests." } ; - -{ miller-rabin miller-rabin* } related-words - -HELP: miller-rabin* -{ $values - { "n" integer } { "numtrials" integer } - { "?" "a boolean" } -} -{ $description "Performs " { $snippet "numtrials" } " trials of the Miller-Rabin probabilistic primality test algorithm and returns true if prime." } ; - -HELP: next-prime -{ $values - { "n" integer } - { "p" integer } -} -{ $description "Tests consecutive numbers for primality with " { $link miller-rabin } " and returns the next prime." } ; - -HELP: next-safe-prime -{ $values - { "n" integer } - { "q" integer } -} -{ $description "Tests consecutive numbers and returns the next safe prime. A safe prime is desirable in cryptography applications such as Diffie-Hellman and SRP6." } ; - -HELP: random-bits* -{ $values - { "numbits" integer } - { "n" integer } -} -{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ; - -HELP: random-prime -{ $values - { "numbits" integer } - { "p" integer } -} -{ $description "Returns a prime number exactly " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ; - -HELP: random-safe-prime -{ $values - { "numbits" integer } - { "p" integer } -} -{ $description "Returns a safe prime number " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ; - -HELP: safe-prime? -{ $values - { "q" integer } - { "?" "a boolean" } -} -{ $description "Tests whether the number is a safe prime. A safe prime " { $snippet "p" } " must be prime, as must " { $snippet "(p - 1) / 2" } "." } ; - -HELP: unique-primes -{ $values - { "numbits" integer } { "n" integer } - { "seq" sequence } -} -{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ; - -ARTICLE: "math.miller-rabin" "Miller-Rabin probabilistic primality test" -"The " { $vocab-link "math.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl -"The Miller-Rabin probabilistic primality test:" -{ $subsection miller-rabin } -{ $subsection miller-rabin* } -"Generating relative prime numbers:" -{ $subsection find-relative-prime } -{ $subsection find-relative-prime* } -"Generating prime numbers:" -{ $subsection next-prime } -{ $subsection random-prime } -"Generating safe prime numbers:" -{ $subsection next-safe-prime } -{ $subsection random-safe-prime } ; - -ABOUT: "math.miller-rabin" diff --git a/basis/math/miller-rabin/miller-rabin-tests.factor b/basis/math/miller-rabin/miller-rabin-tests.factor deleted file mode 100644 index 9981064ec0..0000000000 --- a/basis/math/miller-rabin/miller-rabin-tests.factor +++ /dev/null @@ -1,29 +0,0 @@ -USING: math.miller-rabin tools.test kernel sequences -math.miller-rabin.private math ; -IN: math.miller-rabin.tests - -[ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test -[ t ] [ 2 miller-rabin ] unit-test -[ t ] [ 3 miller-rabin ] unit-test -[ f ] [ 36 miller-rabin ] unit-test -[ t ] [ 37 miller-rabin ] unit-test -[ 2 ] [ 1 next-prime ] unit-test -[ 3 ] [ 2 next-prime ] unit-test -[ 5 ] [ 3 next-prime ] unit-test -[ 101 ] [ 100 next-prime ] unit-test -[ t ] [ 2135623355842621559 miller-rabin ] unit-test -[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test - -[ 863 ] [ 862 next-safe-prime ] unit-test -[ f ] [ 862 safe-prime? ] unit-test -[ t ] [ 7 safe-prime? ] unit-test -[ f ] [ 31 safe-prime? ] unit-test -[ t ] [ 47 safe-prime-candidate? ] unit-test -[ t ] [ 47 safe-prime? ] unit-test -[ t ] [ 863 safe-prime? ] unit-test - -[ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test - -[ 47 ] [ 31 next-safe-prime ] unit-test -[ 49 ] [ 50 random-prime log2 ] unit-test -[ 49 ] [ 50 random-bits* log2 ] unit-test diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/miller-rabin/miller-rabin.factor deleted file mode 100755 index 991924dfe4..0000000000 --- a/basis/math/miller-rabin/miller-rabin.factor +++ /dev/null @@ -1,114 +0,0 @@ -! Copyright (c) 2008-2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel locals math math.functions math.ranges -random sequences sets combinators.short-circuit math.bitwise -math math.order ; -IN: math.miller-rabin - -: >odd ( n -- int ) 0 set-bit ; foldable - -: >even ( n -- int ) 0 clear-bit ; foldable - -: next-even ( m -- n ) >even 2 + ; - -: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; - - n-1 - n-1 factor-2s :> s :> r - 0 :> a! - trials [ - drop - 2 n 2 - [a,b] random a! - a s n ^mod 1 = [ - f - ] [ - r iota [ - 2^ s * a swap n ^mod n - -1 = - ] any? not - ] if - ] any? not ; - -PRIVATE> - -: miller-rabin* ( n numtrials -- ? ) - over { - { [ dup 1 <= ] [ 3drop f ] } - { [ dup 2 = ] [ 3drop t ] } - { [ dup even? ] [ 3drop f ] } - [ drop (miller-rabin) ] - } cond ; - -: miller-rabin ( n -- ? ) 10 miller-rabin* ; - -ERROR: prime-range-error n ; - -: next-prime ( n -- p ) - dup 1 < [ prime-range-error ] when - dup 1 = [ - drop 2 - ] [ - next-odd dup miller-rabin [ next-prime ] unless - ] if ; - -: random-bits* ( numbits -- n ) - 1 - [ random-bits ] keep set-bit ; - -: random-prime ( numbits -- p ) - random-bits* next-prime ; - -ERROR: no-relative-prime n ; - - [ 2 + (find-relative-prime) ] [ nip ] if ; - -PRIVATE> - -: find-relative-prime* ( n guess -- p ) - #! find a prime relative to n with initial guess - >odd (find-relative-prime) ; - -: find-relative-prime ( n -- p ) - dup random find-relative-prime* ; - -ERROR: too-few-primes ; - -: unique-primes ( numbits n -- seq ) - #! generate two primes - swap - dup 5 < [ too-few-primes ] when - 2dup [ random-prime ] curry replicate - dup all-unique? [ 2nip ] [ drop unique-primes ] if ; - -! Safe primes are of the form p = 2q + 1, p,q are prime -! See http://en.wikipedia.org/wiki/Safe_prime - - - -: safe-prime? ( q -- ? ) - { - [ 1 - 2 / dup integer? [ miller-rabin ] [ drop f ] if ] - [ miller-rabin ] - } 1&& ; - -: next-safe-prime ( n -- q ) - next-safe-prime-candidate - dup safe-prime? [ next-safe-prime ] unless ; - -: random-safe-prime ( numbits -- p ) - random-bits* next-safe-prime ; 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/primes/miller-rabin/miller-rabin-tests.factor b/basis/math/primes/miller-rabin/miller-rabin-tests.factor new file mode 100644 index 0000000000..d201abfef8 --- /dev/null +++ b/basis/math/primes/miller-rabin/miller-rabin-tests.factor @@ -0,0 +1,11 @@ +USING: kernel math.primes.miller-rabin sequences tools.test ; +IN: math.primes.miller-rabin.tests + +[ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test +[ t ] [ 2 miller-rabin ] unit-test +[ t ] [ 3 miller-rabin ] unit-test +[ f ] [ 36 miller-rabin ] unit-test +[ t ] [ 37 miller-rabin ] unit-test +[ t ] [ 2135623355842621559 miller-rabin ] unit-test + +[ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test 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/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/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 6b02c8a3e8..661e771258 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -45,7 +45,10 @@ M: f random-32* ( obj -- * ) no-random-number-generator ; PRIVATE> -: random-bits ( n -- r ) 2^ random-integer ; +: random-bits ( numbits -- r ) 2^ random-integer ; + +: random-bits* ( numbits -- n ) + 1 - [ random-bits ] keep set-bit ; : random ( seq -- elt ) [ f ] [ diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 7603324200..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 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/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 816dbb7979..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 @@ -193,6 +191,11 @@ IN: tools.deploy.shaker strip-word-names? [ dup strip-word-names ] when 2drop ; +: strip-compiler-classes ( -- ) + "Stripping compiler classes" show + "compiler" child-vocabs [ words ] map concat [ class? ] filter + [ dup implementors [ "methods" word-prop delete-at ] with each ] each ; + : strip-default-methods ( -- ) strip-debugger? [ "Stripping default methods" show @@ -255,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 @@ -334,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 @@ -349,12 +361,6 @@ IN: tools.deploy.shaker [ quotation? ] [ remain-compiled ] "quotations" compress [ quotation? ] instances [ f >>cached-effect f >>cache-counter drop ] each ; -: compress-strings ( -- ) - [ string? ] [ ] "strings" compress ; - -: compress-wrappers ( -- ) - [ wrapper? ] [ ] "wrappers" compress ; - SYMBOL: deploy-vocab : [:c] ( -- word ) ":c" "debugger" lookup ; @@ -385,18 +391,23 @@ SYMBOL: deploy-vocab t "quiet" set-global f output-stream set-global ; +: unsafe-next-method-quot ( method -- quot ) + [ "method-class" word-prop ] + [ "method-generic" word-prop ] bi + next-method 1quotation ; + : compute-next-methods ( -- ) [ standard-generic? ] instances [ "methods" word-prop [ - nip - 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 @@ -404,14 +415,14 @@ SYMBOL: deploy-vocab compute-next-methods strip-init-hooks strip-c-io + strip-compiler-classes + strip-default-methods f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore deploy-vocab get vocab-main deploy-boot-quot stripped-word-props stripped-globals strip-globals - compress-byte-arrays + compress-objects compress-quotations - compress-strings - compress-wrappers strip-words ; : deploy-error-handler ( quot -- ) 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/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index ba4926d97e..2cf4091937 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -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 @@ -715,6 +717,7 @@ M: windows-ui-backend beep ( -- ) M: windows-ui-backend (grab-input) ( handle -- ) 0 ShowCursor drop hWnd>> client-area>RECT ClipCursor drop ; + M: windows-ui-backend (ungrab-input) ( handle -- ) drop f ClipCursor drop 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:"