diff --git a/basis/checksums/adler-32/adler-32.factor b/basis/checksums/adler-32/adler-32.factor index d5e153ba99..f66860dc63 100644 --- a/basis/checksums/adler-32/adler-32.factor +++ b/basis/checksums/adler-32/adler-32.factor @@ -10,6 +10,6 @@ CONSTANT: adler-32-modulus 65521 M: adler-32 checksum-bytes ( bytes checksum -- value ) drop - [ sum 1+ ] + [ sum 1 + ] [ [ dup length [1,b] v. ] [ length ] bi + ] bi [ adler-32-modulus mod ] bi@ 16 shift bitor ; diff --git a/basis/checksums/sha1/authors.txt b/basis/checksums/hmac/authors.txt similarity index 100% rename from basis/checksums/sha1/authors.txt rename to basis/checksums/hmac/authors.txt diff --git a/basis/checksums/hmac/hmac-tests.factor b/basis/checksums/hmac/hmac-tests.factor new file mode 100755 index 0000000000..ffae146614 --- /dev/null +++ b/basis/checksums/hmac/hmac-tests.factor @@ -0,0 +1,48 @@ +USING: kernel io strings byte-arrays sequences namespaces math +parser checksums.hmac tools.test checksums.md5 checksums.sha +checksums ; +IN: checksums.hmac.tests + +[ + "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" +] [ + 16 11 "Hi There" md5 hmac-bytes >string ] unit-test + +[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] +[ "Jefe" "what do ya want for nothing?" md5 hmac-bytes >string ] unit-test + +[ + "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" +] +[ + 16 HEX: aa + 50 HEX: dd md5 hmac-bytes >string +] unit-test + +[ + "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" +] [ + 16 11 "Hi There" sha1 hmac-bytes >string +] unit-test + +[ + "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" +] [ + "Jefe" "what do ya want for nothing?" sha1 hmac-bytes >string +] unit-test + +[ + "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" +] [ + 16 HEX: aa + 50 HEX: dd sha1 hmac-bytes >string +] unit-test + +[ "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7" ] +[ 20 HEX: b "Hi There" sha-256 hmac-bytes hex-string ] unit-test + +[ "167f928588c5cc2eef8e3093caa0e87c9ff566a14794aa61648d81621a2a40c6" ] +[ + "JefeJefeJefeJefeJefeJefeJefeJefe" + "what do ya want for nothing?" sha-256 hmac-bytes hex-string +] unit-test diff --git a/basis/checksums/hmac/hmac.factor b/basis/checksums/hmac/hmac.factor new file mode 100755 index 0000000000..b163766016 --- /dev/null +++ b/basis/checksums/hmac/hmac.factor @@ -0,0 +1,39 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays checksums combinators fry io io.binary +io.encodings.binary io.files io.streams.byte-array kernel +locals math math.vectors memoize sequences ; +IN: checksums.hmac + +> HEX: 5c ; + +: ipad ( checksum-state -- seq ) block-size>> HEX: 36 ; + +:: init-K ( K checksum checksum-state -- o i ) + checksum-state block-size>> K length < + [ K checksum checksum-bytes ] [ K ] if + checksum-state block-size>> 0 pad-tail + [ checksum-state opad seq-bitxor ] + [ checksum-state ipad seq-bitxor ] bi ; + +PRIVATE> + +:: hmac-stream ( K stream checksum -- value ) + K checksum dup initialize-checksum-state + dup :> checksum-state + init-K :> Ki :> Ko + checksum-state Ki add-checksum-bytes + stream add-checksum-stream get-checksum + checksum initialize-checksum-state + Ko add-checksum-bytes swap add-checksum-bytes + get-checksum ; + +: hmac-file ( K path checksum -- value ) + [ binary ] dip hmac-stream ; + +: hmac-bytes ( K seq checksum -- value ) + [ binary ] dip hmac-stream ; diff --git a/basis/checksums/interleave/authors.txt b/basis/checksums/interleave/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/checksums/interleave/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/checksums/interleave/interleave-tests.factor b/basis/checksums/interleave/interleave-tests.factor new file mode 100644 index 0000000000..9a66e5e316 --- /dev/null +++ b/basis/checksums/interleave/interleave-tests.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test checksums.interleave checksums.sha ; +IN: checksums.interleave.tests + +[ + B{ + 59 155 253 205 75 163 94 115 208 42 227 92 181 19 60 232 + 119 65 178 131 210 48 241 230 204 216 30 156 4 215 80 84 93 + 206 44 1 18 128 150 153 + } +] [ + B{ + 102 83 241 12 26 250 181 76 97 200 37 117 168 74 254 48 216 + 170 26 58 150 150 179 24 153 146 191 225 203 127 166 167 + } + sha1 interleaved-checksum +] unit-test + diff --git a/basis/checksums/interleave/interleave.factor b/basis/checksums/interleave/interleave.factor new file mode 100644 index 0000000000..caef033ec6 --- /dev/null +++ b/basis/checksums/interleave/interleave.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs checksums grouping kernel locals math sequences ; +IN: checksums.interleave + +: seq>2seq ( seq -- seq1 seq2 ) + #! { abcdefgh } -> { aceg } { bdfh } + 2 group flip [ { } { } ] [ first2 ] if-empty ; + +: 2seq>seq ( seq1 seq2 -- seq ) + #! { aceg } { bdfh } -> { abcdefgh } + [ zip concat ] keep like ; + +:: interleaved-checksum ( bytes checksum -- seq ) + bytes [ zero? ] trim-head + dup length odd? [ rest-slice ] when + seq>2seq [ checksum checksum-bytes ] bi@ 2seq>seq ; diff --git a/basis/checksums/md5/md5-tests.factor b/basis/checksums/md5/md5-tests.factor index 8e314f7c28..b7f388c002 100644 --- a/basis/checksums/md5/md5-tests.factor +++ b/basis/checksums/md5/md5-tests.factor @@ -1,4 +1,6 @@ -USING: kernel math namespaces checksums checksums.md5 tools.test byte-arrays ; +USING: byte-arrays checksums checksums.md5 io.encodings.binary +io.streams.byte-array kernel math namespaces tools.test ; + [ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test [ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array md5 checksum-bytes hex-string ] unit-test @@ -8,3 +10,24 @@ USING: kernel math namespaces checksums checksums.md5 tools.test byte-arrays ; [ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" >byte-array md5 checksum-bytes hex-string ] unit-test [ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" >byte-array md5 checksum-bytes hex-string ] unit-test + +[ + t +] [ + "asdf" add-checksum-bytes + [ get-checksum ] [ get-checksum ] bi = +] unit-test + +[ + t +] [ + "" add-checksum-bytes + [ get-checksum ] [ get-checksum ] bi = +] unit-test + +[ + t +] [ + "asdf" binary add-checksum-stream + [ get-checksum ] [ get-checksum ] bi = +] unit-test diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index 29620b089d..89ff5d46a2 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -3,57 +3,53 @@ USING: kernel io io.binary io.files io.streams.byte-array math math.functions math.parser namespaces splitting grouping strings sequences byte-arrays locals sequences.private macros fry -io.encodings.binary math.bitwise checksums -checksums.common checksums.stream combinators ; +io.encodings.binary math.bitwise checksums accessors +checksums.common checksums.stream combinators combinators.smart +specialized-arrays.uint literals ; IN: checksums.md5 -! See http://www.faqs.org/rfcs/rfc1321.html +SINGLETON: md5 + +INSTANCE: md5 stream-checksum + +TUPLE: md5-state < checksum-state state old-state ; + +: ( -- md5 ) + md5-state new-checksum-state + 64 >>block-size + uint-array{ HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 } + [ clone >>state ] [ >>old-state ] bi ; + +M: md5 initialize-checksum-state drop ; integer ; foldable +: update-md5 ( md5 -- ) + [ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri + [ (>>old-state) ] [ (>>state) ] bi ; inline -: initialize-md5 ( -- ) - 0 bytes-read set - HEX: 67452301 dup a set old-a set - HEX: efcdab89 dup b set old-b set - HEX: 98badcfe dup c set old-c set - HEX: 10325476 dup d set old-d set ; +CONSTANT: T + $[ + 80 iota [ sin abs 32 2^ * >integer ] uint-array{ } map-as + ] -: update-md ( -- ) - old-a a update-old-new - old-b b update-old-new - old-c c update-old-new - old-d d update-old-new ; - -:: (ABCD) ( x a b c d k s i func -- ) - #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s) - a [ - b get c get d get func call w+ - k x nth-unsafe w+ - i T w+ - s bitroll-32 - b get w+ - ] change ; inline - -: F ( X Y Z -- FXYZ ) +:: F ( X Y Z -- FXYZ ) #! F(X,Y,Z) = XY v not(X) Z - pick bitnot bitand [ bitand ] [ bitor ] bi* ; + X Y bitand X bitnot Z bitand bitor ; inline -: G ( X Y Z -- GXYZ ) +:: G ( X Y Z -- GXYZ ) #! G(X,Y,Z) = XZ v Y not(Z) - dup bitnot rot bitand [ bitand ] [ bitor ] bi* ; + X Z bitand Y Z bitnot bitand bitor ; inline : H ( X Y Z -- HXYZ ) #! H(X,Y,Z) = X xor Y xor Z - bitxor bitxor ; + bitxor bitxor ; inline -: I ( X Y Z -- IXYZ ) +:: I ( X Y Z -- IXYZ ) #! I(X,Y,Z) = Y xor (X v not(Z)) - rot swap bitnot bitor bitxor ; + Z bitnot X bitor Y bitxor ; inline CONSTANT: S11 7 CONSTANT: S12 12 @@ -72,10 +68,27 @@ CONSTANT: S42 10 CONSTANT: S43 15 CONSTANT: S44 21 -MACRO: with-md5-round ( ops func -- ) - '[ [ _ (ABCD) ] compose ] map '[ _ cleave ] ; +CONSTANT: a 0 +CONSTANT: b 1 +CONSTANT: c 2 +CONSTANT: d 3 -: (process-md5-block-F) ( block -- ) +:: (ABCD) ( x state a b c d k s i quot -- ) + #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s) + a state [ + b state nth-unsafe + c state nth-unsafe + d state nth-unsafe quot call w+ + k x nth-unsafe w+ + i T nth-unsafe w+ + s bitroll-32 + b state nth-unsafe w+ 32 bits + ] change-nth-unsafe ; inline + +MACRO: with-md5-round ( ops quot -- ) + '[ [ _ (ABCD) ] compose ] map '[ _ 2cleave ] ; + +: (process-md5-block-F) ( block state -- ) { [ a b c d 0 S11 1 ] [ d a b c 1 S12 2 ] @@ -93,9 +106,9 @@ MACRO: with-md5-round ( ops func -- ) [ d a b c 13 S12 14 ] [ c d a b 14 S13 15 ] [ b c d a 15 S14 16 ] - } [ F ] with-md5-round ; + } [ F ] with-md5-round ; inline -: (process-md5-block-G) ( block -- ) +: (process-md5-block-G) ( block state -- ) { [ a b c d 1 S21 17 ] [ d a b c 6 S22 18 ] @@ -113,9 +126,9 @@ MACRO: with-md5-round ( ops func -- ) [ d a b c 2 S22 30 ] [ c d a b 7 S23 31 ] [ b c d a 12 S24 32 ] - } [ G ] with-md5-round ; + } [ G ] with-md5-round ; inline -: (process-md5-block-H) ( block -- ) +: (process-md5-block-H) ( block state -- ) { [ a b c d 5 S31 33 ] [ d a b c 8 S32 34 ] @@ -133,9 +146,9 @@ MACRO: with-md5-round ( ops func -- ) [ d a b c 12 S32 46 ] [ c d a b 15 S33 47 ] [ b c d a 2 S34 48 ] - } [ H ] with-md5-round ; + } [ H ] with-md5-round ; inline -: (process-md5-block-I) ( block -- ) +: (process-md5-block-I) ( block state -- ) { [ a b c d 0 S41 49 ] [ d a b c 7 S42 50 ] @@ -153,38 +166,33 @@ MACRO: with-md5-round ( ops func -- ) [ d a b c 11 S42 62 ] [ c d a b 2 S43 63 ] [ b c d a 9 S44 64 ] - } [ I ] with-md5-round ; + } [ I ] with-md5-round ; inline -: (process-md5-block) ( block -- ) - 4 [ le> ] map { - [ (process-md5-block-F) ] - [ (process-md5-block-G) ] - [ (process-md5-block-H) ] - [ (process-md5-block-I) ] - } cleave - - update-md ; - -: process-md5-block ( str -- ) - dup length [ bytes-read [ + ] change ] keep 64 = [ - (process-md5-block) +M: md5-state checksum-block ( block state -- ) + [ + [ byte-array>uint-array ] [ state>> ] bi* { + [ (process-md5-block-F) ] + [ (process-md5-block-G) ] + [ (process-md5-block-H) ] + [ (process-md5-block-I) ] + } 2cleave ] [ - f bytes-read get pad-last-block - [ (process-md5-block) ] each - ] if ; - -: stream>md5 ( -- ) - 64 read [ process-md5-block ] keep - length 64 = [ stream>md5 ] when ; + nip update-md5 + ] 2bi ; -: get-md5 ( -- str ) - [ a b c d ] [ get 4 >le ] map concat >byte-array ; +: md5>checksum ( md5 -- bytes ) state>> underlying>> ; + +M: md5-state clone ( md5 -- new-md5 ) + call-next-method + [ clone ] change-state + [ clone ] change-old-state ; + +M: md5-state get-checksum ( md5 -- bytes ) + clone [ bytes>> f ] [ bytes-read>> pad-last-block ] [ ] tri + [ [ checksum-block ] curry each ] [ md5>checksum ] bi ; + +M: md5 checksum-stream ( stream checksum -- byte-array ) + drop + [ ] dip add-checksum-stream get-checksum ; PRIVATE> - -SINGLETON: md5 - -INSTANCE: md5 stream-checksum - -M: md5 checksum-stream ( stream -- byte-array ) - drop [ initialize-md5 stream>md5 get-md5 ] with-input-stream ; diff --git a/basis/checksums/openssl/openssl-docs.factor b/basis/checksums/openssl/openssl-docs.factor index b0cc8f9e53..27df72c4ea 100644 --- a/basis/checksums/openssl/openssl-docs.factor +++ b/basis/checksums/openssl/openssl-docs.factor @@ -32,6 +32,6 @@ ARTICLE: "checksums.openssl" "OpenSSL checksums" "An example where we compute the SHA1 checksum of a string using the OpenSSL implementation of SHA1:" { $example "USING: byte-arrays checksums checksums.openssl ;" "\"hello world\" >byte-array openssl-sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } "If we use the Factor implementation, we get the same result, just slightly slower:" -{ $example "USING: byte-arrays checksums checksums.sha1 ;" "\"hello world\" >byte-array sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } ; +{ $example "USING: byte-arrays checksums checksums.sha ;" "\"hello world\" >byte-array sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } ; ABOUT: "checksums.openssl" diff --git a/basis/checksums/openssl/openssl-tests.factor b/basis/checksums/openssl/openssl-tests.factor index 253069c952..2a160e1486 100644 --- a/basis/checksums/openssl/openssl-tests.factor +++ b/basis/checksums/openssl/openssl-tests.factor @@ -1,6 +1,6 @@ +USING: accessors byte-arrays checksums checksums.openssl +combinators.short-circuit kernel system tools.test ; IN: checksums.openssl.tests -USING: byte-arrays checksums.openssl checksums tools.test -accessors kernel system ; [ B{ 201 238 222 100 92 200 182 188 138 255 129 163 115 88 240 136 } @@ -22,7 +22,7 @@ accessors kernel system ; "Bad checksum test" >byte-array "no such checksum" checksum-bytes -] [ [ unknown-digest? ] [ name>> "no such checksum" = ] bi and ] +] [ { [ unknown-digest? ] [ name>> "no such checksum" = ] } 1&& ] must-fail-with [ ] [ image openssl-sha1 checksum-file drop ] unit-test diff --git a/basis/checksums/sha2/authors.txt b/basis/checksums/sha/authors.txt similarity index 100% rename from basis/checksums/sha2/authors.txt rename to basis/checksums/sha/authors.txt diff --git a/basis/checksums/sha/sha-docs.factor b/basis/checksums/sha/sha-docs.factor new file mode 100644 index 0000000000..780c2b39d8 --- /dev/null +++ b/basis/checksums/sha/sha-docs.factor @@ -0,0 +1,18 @@ +USING: help.markup help.syntax ; +IN: checksums.sha + +HELP: sha-224 +{ $class-description "SHA-224 checksum algorithm." } ; + +HELP: sha-256 +{ $class-description "SHA-256 checksum algorithm." } ; + +ARTICLE: "checksums.sha" "SHA-2 checksum" +"The SHA family of checksum algorithms are one-way hashes useful for checksumming data. SHA-1 is considered insecure, while SHA-2 It is generally considered to be pretty strong." $nl +"SHA-2 checksums:" +{ $subsection sha-224 } +{ $subsection sha-256 } +"SHA-1 checksum:" +{ $subsection sha1 } ; + +ABOUT: "checksums.sha" diff --git a/basis/checksums/sha2/sha2-tests.factor b/basis/checksums/sha/sha-tests.factor similarity index 55% rename from basis/checksums/sha2/sha2-tests.factor rename to basis/checksums/sha/sha-tests.factor index c14ea5a98d..be431af311 100644 --- a/basis/checksums/sha2/sha2-tests.factor +++ b/basis/checksums/sha/sha-tests.factor @@ -1,10 +1,18 @@ -USING: arrays kernel math namespaces sequences tools.test -checksums.sha2 checksums ; -IN: checksums.sha2.tests +USING: arrays checksums checksums.sha checksums.sha.private +io.encodings.binary io.streams.byte-array kernel math +namespaces sequences tools.test ; +IN: checksums.sha.tests : test-checksum ( text identifier -- checksum ) checksum-bytes hex-string ; +[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" sha1 checksum-bytes hex-string ] unit-test +[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" sha1 checksum-bytes hex-string ] unit-test +! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time... +[ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567" +10 swap concat sha1 checksum-bytes hex-string ] unit-test + + [ "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" @@ -36,7 +44,27 @@ IN: checksums.sha2.tests ] unit-test - - ! [ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ] ! [ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test + +[ + t +] [ + "asdf" binary add-checksum-stream + [ get-checksum ] [ get-checksum ] bi = +] unit-test + +[ + t +] [ + "asdf" binary add-checksum-stream + [ get-checksum ] [ get-checksum ] bi = +] unit-test + +[ + t +] [ + "asdf" binary add-checksum-stream + [ get-checksum ] [ get-checksum ] bi = +] unit-test + diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha/sha.factor similarity index 66% rename from basis/checksums/sha2/sha2.factor rename to basis/checksums/sha/sha.factor index 12e32f6c69..287c39b2a1 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha/sha.factor @@ -3,16 +3,40 @@ USING: kernel splitting grouping math sequences namespaces make io.binary math.bitwise checksums checksums.common sbufs strings combinators.smart math.ranges fry combinators -accessors locals ; -IN: checksums.sha2 +accessors locals checksums.stream multiline literals +generalizations ; +IN: checksums.sha + +SINGLETON: sha1 +INSTANCE: sha1 stream-checksum SINGLETON: sha-224 SINGLETON: sha-256 -INSTANCE: sha-224 checksum -INSTANCE: sha-256 checksum +INSTANCE: sha-224 stream-checksum +INSTANCE: sha-256 stream-checksum -TUPLE: sha2-state K H word-size block-size ; +TUPLE: sha1-state < checksum-state K H W word-size ; + +CONSTANT: initial-H-sha1 + { + HEX: 67452301 + HEX: efcdab89 + HEX: 98badcfe + HEX: 10325476 + HEX: c3d2e1f0 + } + +CONSTANT: K-sha1 + $[ + 20 HEX: 5a827999 + 20 HEX: 6ed9eba1 + 20 HEX: 8f1bbcdc + 20 HEX: ca62c1d6 + 4 { } nappend-as + ] + +TUPLE: sha2-state < checksum-state K H word-size ; TUPLE: sha2-short < sha2-state ; @@ -22,6 +46,11 @@ TUPLE: sha-224-state < sha2-short ; TUPLE: sha-256-state < sha2-short ; +M: sha2-state clone + call-next-method + [ clone ] change-H + [ clone ] change-K ; + ( -- sha1-state ) + sha1-state new-checksum-state + 64 >>block-size + K-sha1 >>K + initial-H-sha1 >>H + 4 >>word-size ; + +: ( -- sha2-state ) + sha-224-state new-checksum-state + 64 >>block-size + K-256 >>K + initial-H-224 >>H + 4 >>word-size ; + +: ( -- sha2-state ) + sha-256-state new-checksum-state + 64 >>block-size + K-256 >>K + initial-H-256 >>H + 4 >>word-size ; + +M: sha1 initialize-checksum-state drop ; + +M: sha-224 initialize-checksum-state drop ; + +M: sha-256 initialize-checksum-state drop ; + : s0-256 ( x -- x' ) [ [ -7 bitroll-32 ] @@ -172,7 +228,7 @@ ALIAS: K-512 K-384 [ -41 bitroll-64 ] tri ] [ bitxor ] reduce-outputs ; inline -: process-M-256 ( n seq -- ) +: prepare-M-256 ( n seq -- ) { [ [ 16 - ] dip nth ] [ [ 15 - ] dip nth s0-256 ] @@ -181,7 +237,7 @@ ALIAS: K-512 K-384 [ ] } 2cleave set-nth ; inline -: process-M-512 ( n seq -- ) +: prepare-M-512 ( n seq -- ) { [ [ 16 - ] dip nth ] [ [ 15 - ] dip nth s0-512 ] @@ -201,26 +257,6 @@ ALIAS: K-512 K-384 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 + @@ -257,7 +293,7 @@ M: sha2-long pad-initial-bytes ( string sha2 -- padded-string ) [ word-size>> [ be> ] map ] [ block-size>> [ 0 pad-tail 16 ] keep [a,b) over - '[ _ process-M-256 ] each + '[ _ prepare-M-256 ] each ] bi ; inline :: process-chunk ( M block-size cloned-H sha2 -- ) @@ -266,41 +302,110 @@ M: sha2-long pad-initial-bytes ( string sha2 -- padded-string ) cloned-H T2-256 cloned-H update-H ] each - cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline + sha2 [ cloned-H [ w+ ] 2map ] change-H drop ; inline -: sha2-steps ( sliced-groups state -- ) - '[ - _ - [ prepare-message-schedule ] - [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi - ] each ; +M: sha2-short checksum-block + [ prepare-message-schedule ] + [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ; -: byte-array>sha2 ( bytes state -- ) - [ [ pad-initial-bytes ] [ nip block-size>> ] 2bi ] - [ sha2-steps ] bi ; +: seq>byte-array ( seq n -- string ) + '[ _ >be ] map B{ } join ; -: ( -- sha2-state ) - sha-224-state new - K-256 >>K - initial-H-224 >>H - 4 >>word-size - 64 >>block-size ; +: sha1>checksum ( sha2 -- bytes ) + H>> 4 seq>byte-array ; -: ( -- sha2-state ) - sha-256-state new - K-256 >>K - initial-H-256 >>H - 4 >>word-size - 64 >>block-size ; +: sha-224>checksum ( sha2 -- bytes ) + H>> 7 head 4 seq>byte-array ; + +: sha-256>checksum ( sha2 -- bytes ) + H>> 4 seq>byte-array ; + +: pad-last-short-block ( state -- ) + [ bytes>> t ] [ bytes-read>> pad-last-block ] [ ] tri + [ checksum-block ] curry each ; PRIVATE> -M: sha-224 checksum-bytes - drop - [ byte-array>sha2 ] - [ H>> 7 head 4 seq>byte-array ] bi ; +M: sha-224-state get-checksum + clone + [ pad-last-short-block ] [ sha-224>checksum ] bi ; -M: sha-256 checksum-bytes - drop - [ byte-array>sha2 ] - [ H>> 4 seq>byte-array ] bi ; +M: sha-256-state get-checksum + clone + [ pad-last-short-block ] [ sha-256>checksum ] bi ; + +M: sha-224 checksum-stream ( stream checksum -- byte-array ) + drop + [ ] dip add-checksum-stream get-checksum ; + +M: sha-256 checksum-stream ( stream checksum -- byte-array ) + drop + [ ] dip add-checksum-stream get-checksum ; + + + +: sha1-W ( t seq -- ) + { + [ [ 3 - ] dip nth ] + [ [ 8 - ] dip nth bitxor ] + [ [ 14 - ] dip nth bitxor ] + [ [ 16 - ] dip nth bitxor 1 bitroll-32 ] + [ ] + } 2cleave set-nth ; + +: prepare-sha1-message-schedule ( seq -- w-seq ) + 4 [ be> ] map + 80 0 pad-tail 16 80 [a,b) over + '[ _ sha1-W ] each ; inline + +: sha1-f ( B C D n -- f_nbcd ) + 20 /i + { + { 0 [ [ over bitnot ] dip bitand [ bitand ] dip bitor ] } + { 1 [ bitxor bitxor ] } + { 2 [ 2dup bitand [ pick bitand [ bitand ] dip ] dip bitor bitor ] } + { 3 [ bitxor bitxor ] } + } case ; + +:: inner-loop ( n H W K -- temp ) + a H nth :> A + b H nth :> B + c H nth :> C + d H nth :> D + e H nth :> E + [ + A 5 bitroll-32 + + B C D n sha1-f + + E + + n K nth + + n W nth + ] sum-outputs 32 bits ; + +:: process-sha1-chunk ( bytes H W K state -- ) + 80 [ + H W K inner-loop + d H nth e H set-nth + c H nth d H set-nth + b H nth 30 bitroll-32 c H set-nth + a H nth b H set-nth + a H set-nth + ] each + state [ H [ w+ ] 2map ] change-H drop ; inline + +M:: sha1-state checksum-block ( bytes state -- ) + bytes prepare-sha1-message-schedule state (>>W) + + bytes + state [ H>> clone ] [ W>> ] [ K>> ] tri state process-sha1-chunk ; + +M: sha1-state get-checksum + clone + [ pad-last-short-block ] [ sha-256>checksum ] bi ; + +M: sha1 checksum-stream ( stream checksum -- byte-array ) + drop + [ ] dip add-checksum-stream get-checksum ; diff --git a/basis/checksums/sha/summary.txt b/basis/checksums/sha/summary.txt new file mode 100644 index 0000000000..2dd351af0b --- /dev/null +++ b/basis/checksums/sha/summary.txt @@ -0,0 +1 @@ +SHA checksum algorithms diff --git a/basis/checksums/sha1/sha1-docs.factor b/basis/checksums/sha1/sha1-docs.factor deleted file mode 100644 index 2c9093865f..0000000000 --- a/basis/checksums/sha1/sha1-docs.factor +++ /dev/null @@ -1,11 +0,0 @@ -USING: help.markup help.syntax ; -IN: checksums.sha1 - -HELP: sha1 -{ $class-description "SHA1 checksum algorithm." } ; - -ARTICLE: "checksums.sha1" "SHA1 checksum" -"The SHA1 checksum algorithm implements a one-way hash function. It is generally considered to be stronger than MD5, however there is a known algorithm for finding collisions more effectively than a brute-force search (" { $url "http://www.schneier.com/blog/archives/2005/02/sha1_broken.html" } ")." -{ $subsection sha1 } ; - -ABOUT: "checksums.sha1" diff --git a/basis/checksums/sha1/sha1-tests.factor b/basis/checksums/sha1/sha1-tests.factor deleted file mode 100644 index 808d37d1e4..0000000000 --- a/basis/checksums/sha1/sha1-tests.factor +++ /dev/null @@ -1,14 +0,0 @@ -USING: arrays kernel math namespaces sequences tools.test checksums checksums.sha1 ; - -[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" sha1 checksum-bytes hex-string ] unit-test -[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" sha1 checksum-bytes hex-string ] unit-test -! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time... -[ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567" -10 swap concat sha1 checksum-bytes hex-string ] unit-test - -[ - ";\u00009b\u0000fd\u0000cdK\u0000a3^s\u0000d0*\u0000e3\\\u0000b5\u000013<\u0000e8wA\u0000b2\u000083\u0000d20\u0000f1\u0000e6\u0000cc\u0000d8\u00001e\u00009c\u000004\u0000d7PT]\u0000ce,\u000001\u000012\u000080\u000096\u000099" -] [ - "\u000066\u000053\u0000f1\u00000c\u00001a\u0000fa\u0000b5\u00004c\u000061\u0000c8\u000025\u000075\u0000a8\u00004a\u0000fe\u000030\u0000d8\u0000aa\u00001a\u00003a\u000096\u000096\u0000b3\u000018\u000099\u000092\u0000bf\u0000e1\u0000cb\u00007f\u0000a6\u0000a7" - sha1-interleave -] unit-test diff --git a/basis/checksums/sha1/sha1.factor b/basis/checksums/sha1/sha1.factor deleted file mode 100644 index 707aa66ba6..0000000000 --- a/basis/checksums/sha1/sha1.factor +++ /dev/null @@ -1,134 +0,0 @@ -! Copyright (C) 2006, 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays combinators kernel io io.encodings.binary io.files -io.streams.byte-array math.vectors strings namespaces -make math parser sequences assocs grouping vectors io.binary -hashtables math.bitwise checksums checksums.common -checksums.stream ; -IN: checksums.sha1 - -! Implemented according to RFC 3174. - -SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ; - -: get-wth ( n -- wth ) w get nth ; inline -: shift-wth ( n -- x ) get-wth 1 bitroll-32 ; inline - -: initialize-sha1 ( -- ) - 0 bytes-read set - HEX: 67452301 dup h0 set A set - HEX: efcdab89 dup h1 set B set - HEX: 98badcfe dup h2 set C set - HEX: 10325476 dup h3 set D set - HEX: c3d2e1f0 dup h4 set E set - [ - 20 HEX: 5a827999 % - 20 HEX: 6ed9eba1 % - 20 HEX: 8f1bbcdc % - 20 HEX: ca62c1d6 % - ] { } make K set ; - -! W(t) = S^1(W(t-3) XOR W(t-8) XOR W(t-14) XOR W(t-16)) -: sha1-W ( t -- W_t ) - dup 3 - get-wth - over 8 - get-wth bitxor - over 14 - get-wth bitxor - swap 16 - get-wth bitxor 1 bitroll-32 ; - -! f(t;B,C,D) = (B AND C) OR ((NOT B) AND D) ( 0 <= t <= 19) -! f(t;B,C,D) = B XOR C XOR D (20 <= t <= 39) -! f(t;B,C,D) = (B AND C) OR (B AND D) OR (C AND D) (40 <= t <= 59) -! f(t;B,C,D) = B XOR C XOR D (60 <= t <= 79) -: sha1-f ( B C D t -- f_tbcd ) - 20 /i - { - { 0 [ [ over bitnot ] dip bitand [ bitand ] dip bitor ] } - { 1 [ bitxor bitxor ] } - { 2 [ 2dup bitand [ pick bitand [ bitand ] dip ] dip bitor bitor ] } - { 3 [ bitxor bitxor ] } - } case ; - -: nth-int-be ( string n -- int ) - 4 * dup 4 + rot be> ; inline - -: make-w ( str -- ) - #! compute w, steps a-b of RFC 3174, section 6.1 - 16 [ nth-int-be w get push ] with each - 16 80 dup [ sha1-W w get push ] each ; - -: init-letters ( -- ) - ! step c of RFC 3174, section 6.1 - h0 get A set - h1 get B set - h2 get C set - h3 get D set - h4 get E set ; - -: inner-loop ( n -- temp ) - ! TEMP = S^5(A) + f(t;B,C,D) + E + W(t) + K(t); - [ - [ B get C get D get ] keep sha1-f , - dup get-wth , - K get nth , - A get 5 bitroll-32 , - E get , - ] { } make sum 32 bits ; inline - -: set-vars ( temp -- ) - ! E = D; D = C; C = S^30(B); B = A; A = TEMP; - D get E set - C get D set - B get 30 bitroll-32 C set - A get B set - A set ; - -: calculate-letters ( -- ) - ! step d of RFC 3174, section 6.1 - 80 [ inner-loop set-vars ] each ; - -: update-hs ( -- ) - ! step e of RFC 3174, section 6.1 - A h0 update-old-new - B h1 update-old-new - C h2 update-old-new - D h3 update-old-new - E h4 update-old-new ; - -: (process-sha1-block) ( str -- ) - 80 w set make-w init-letters calculate-letters update-hs ; - -: process-sha1-block ( str -- ) - dup length [ bytes-read [ + ] change ] keep 64 = [ - (process-sha1-block) - ] [ - t bytes-read get pad-last-block - [ (process-sha1-block) ] each - ] if ; - -: stream>sha1 ( -- ) - 64 read [ process-sha1-block ] keep - length 64 = [ stream>sha1 ] when ; - -: get-sha1 ( -- str ) - [ [ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each ] "" make ; - -SINGLETON: sha1 - -INSTANCE: sha1 stream-checksum - -M: sha1 checksum-stream ( stream -- sha1 ) - drop [ initialize-sha1 stream>sha1 get-sha1 ] with-input-stream ; - -: seq>2seq ( seq -- seq1 seq2 ) - #! { abcdefgh } -> { aceg } { bdfh } - 2 group flip [ { } { } ] [ first2 ] if-empty ; - -: 2seq>seq ( seq1 seq2 -- seq ) - #! { aceg } { bdfh } -> { abcdefgh } - [ zip concat ] keep like ; - -: sha1-interleave ( string -- seq ) - [ zero? ] trim-head - dup length odd? [ rest ] when - seq>2seq [ sha1 checksum-bytes ] bi@ - 2seq>seq ; diff --git a/basis/checksums/sha1/summary.txt b/basis/checksums/sha1/summary.txt deleted file mode 100644 index d8da1df0aa..0000000000 --- a/basis/checksums/sha1/summary.txt +++ /dev/null @@ -1 +0,0 @@ -SHA1 checksum algorithm diff --git a/basis/checksums/sha2/sha2-docs.factor b/basis/checksums/sha2/sha2-docs.factor deleted file mode 100644 index 6a128552fd..0000000000 --- a/basis/checksums/sha2/sha2-docs.factor +++ /dev/null @@ -1,11 +0,0 @@ -USING: help.markup help.syntax ; -IN: checksums.sha2 - -HELP: sha-256 -{ $class-description "SHA-256 checksum algorithm." } ; - -ARTICLE: "checksums.sha2" "SHA2 checksum" -"The SHA2 checksum algorithm implements a one-way hash function. It is generally considered to be pretty strong." -{ $subsection sha-256 } ; - -ABOUT: "checksums.sha2" diff --git a/basis/checksums/sha2/summary.txt b/basis/checksums/sha2/summary.txt deleted file mode 100644 index 04365d439f..0000000000 --- a/basis/checksums/sha2/summary.txt +++ /dev/null @@ -1 +0,0 @@ -SHA2 checksum algorithm diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor index 3e67b11cc7..7cb43ac68f 100755 --- a/basis/compression/inflate/inflate.factor +++ b/basis/compression/inflate/inflate.factor @@ -75,18 +75,20 @@ CONSTANT: length-table 19 23 27 31 35 43 51 59 67 83 99 115 - 131 163 195 227 + 131 163 195 227 258 } CONSTANT: dist-table - { 1 2 3 4 - 5 7 9 13 - 17 25 33 49 - 65 97 129 193 - 257 385 513 769 - 1025 1537 2049 3073 - 4097 6145 8193 12289 - 16385 24577 } + { + 1 2 3 4 + 5 7 9 13 + 17 25 33 49 + 65 97 129 193 + 257 385 513 769 + 1025 1537 2049 3073 + 4097 6145 8193 12289 + 16385 24577 + } : nth* ( n seq -- elt ) [ length 1- swap - ] [ nth ] bi ; @@ -156,7 +158,7 @@ CONSTANT: dist-table [ 1 bitstream bs:read 0 = ] [ bitstream - 2 bitstream bs:read ! B + 2 bitstream bs:read { { 0 [ inflate-raw ] } { 1 [ inflate-static ] } @@ -200,10 +202,11 @@ PRIVATE> : reverse-png-filter ( lines -- filtered ) dup first [ 0 ] replicate prefix [ { 0 0 } prepend ] map - 2 clump [ first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line ] map concat ; + 2 clump [ + first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line + ] map concat ; : zlib-inflate ( bytes -- bytes ) bs: - [ check-zlib-header ] - [ inflate-loop ] bi + [ check-zlib-header ] [ inflate-loop ] bi inflate-lz77 ; diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index ad1b487e44..b77539b7e7 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays kernel math namespaces make sequences system layouts alien alien.c-types alien.accessors alien.structs -slots splitting assocs combinators make locals cpu.x86.assembler +slots splitting assocs combinators locals cpu.x86.assembler cpu.x86 cpu.architecture compiler.constants compiler.codegen compiler.codegen.fixup compiler.cfg.instructions compiler.cfg.builder diff --git a/basis/furnace/auth/auth-docs.factor b/basis/furnace/auth/auth-docs.factor index 3f1bcb6085..efd6a52ef0 100644 --- a/basis/furnace/auth/auth-docs.factor +++ b/basis/furnace/auth/auth-docs.factor @@ -1,6 +1,6 @@ USING: assocs classes help.markup help.syntax kernel quotations strings words words.symbol furnace.auth.providers.db -checksums.sha2 furnace.auth.providers math byte-arrays +checksums.sha furnace.auth.providers math byte-arrays http multiline ; IN: furnace.auth diff --git a/basis/furnace/auth/auth.factor b/basis/furnace/auth/auth.factor index b9c961941c..831ec7f8fc 100644 --- a/basis/furnace/auth/auth.factor +++ b/basis/furnace/auth/auth.factor @@ -3,7 +3,7 @@ USING: accessors assocs namespaces kernel sequences sets destructors combinators fry logging io.encodings.utf8 io.encodings.string io.binary random -checksums checksums.sha2 urls +checksums checksums.sha urls html.forms http.server http.server.filters diff --git a/basis/images/bitmap/bitmap-tests.factor b/basis/images/bitmap/bitmap-tests.factor index 29ba3b9b80..ea8b0d4c0c 100644 --- a/basis/images/bitmap/bitmap-tests.factor +++ b/basis/images/bitmap/bitmap-tests.factor @@ -17,9 +17,9 @@ CONSTANT: test-41 "vocab:images/test-images/41red24bit.bmp" CONSTANT: test-42 "vocab:images/test-images/42red24bit.bmp" CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp" -{ - $ test-bitmap8 - $ test-bitmap24 +${ + test-bitmap8 + test-bitmap24 "vocab:ui/render/test/reference.bmp" } [ [ ] swap [ load-image drop ] curry unit-test ] each @@ -34,11 +34,11 @@ CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp" [ t ] [ - { - $ test-40 - $ test-41 - $ test-42 - $ test-43 - $ test-bitmap24 + ${ + test-40 + test-41 + test-42 + test-43 + test-bitmap24 } [ test-bitmap-save ] all? ] unit-test diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index bf13c43546..c5b84de221 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -65,14 +65,42 @@ ERROR: bad-checksum ; : zlib-data ( png-image -- bytes ) chunks>> [ type>> "IDAT" = ] find nip data>> ; -: decode-png ( image -- image ) +ERROR: unknown-color-type n ; +ERROR: unimplemented-color-type image ; + +: inflate-data ( image -- bytes ) + zlib-data zlib-inflate ; + +: decode-greyscale ( image -- image ) + unimplemented-color-type ; + +: decode-truecolor ( image -- image ) { - [ zlib-data zlib-inflate ] + [ inflate-data ] [ dim>> first 3 * 1 + group reverse-png-filter ] [ swap >byte-array >>bitmap drop ] [ RGB >>component-order drop ] [ ] } cleave ; + +: decode-indexed-color ( image -- image ) + unimplemented-color-type ; + +: decode-greyscale-alpha ( image -- image ) + unimplemented-color-type ; + +: decode-truecolor-alpha ( image -- image ) + unimplemented-color-type ; + +: decode-png ( image -- image ) + dup color-type>> { + { 0 [ decode-greyscale ] } + { 2 [ decode-truecolor ] } + { 3 [ decode-indexed-color ] } + { 4 [ decode-greyscale-alpha ] } + { 6 [ decode-truecolor-alpha ] } + [ unknown-color-type ] + } case ; : load-png ( path -- image ) [ binary ] [ file-info size>> ] bi diff --git a/basis/io/backend/windows/windows.factor b/basis/io/backend/windows/windows.factor index 9f5c00cc5f..2e9aac2ac9 100755 --- a/basis/io/backend/windows/windows.factor +++ b/basis/io/backend/windows/windows.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays destructors io io.backend io.buffers io.files io.ports io.binary io.timeouts system -windows.errors strings kernel math namespaces sequences -windows.errors windows.kernel32 windows.shell32 windows.types -windows.winsock splitting continuations math.bitwise accessors ; +strings kernel math namespaces sequences windows.errors +windows.kernel32 windows.shell32 windows.types windows.winsock +splitting continuations math.bitwise accessors ; IN: io.backend.windows : set-inherit ( handle ? -- ) diff --git a/basis/math/statistics/statistics-docs.factor b/basis/math/statistics/statistics-docs.factor index 7a7eb70dd2..1a29d611f9 100644 --- a/basis/math/statistics/statistics-docs.factor +++ b/basis/math/statistics/statistics-docs.factor @@ -2,26 +2,26 @@ USING: help.markup help.syntax debugger ; IN: math.statistics HELP: geometric-mean -{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } +{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } { $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set that minimizes the effects of extreme values." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } geometric-mean ." "1.81712059283214" } } { $errors "Throws a " { $link signal-error. } " (square-root of 0) if the sequence is empty." } ; HELP: harmonic-mean -{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } +{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } { $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." } { $notes "Positive reals only." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } harmonic-mean ." "6/11" } } { $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ; HELP: mean -{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } +{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } { $description "Computes the arithmetic mean of all elements in " { $snippet "seq" } "." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } mean ." "2" } } { $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ; HELP: median -{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } +{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } { $description "Computes the median of " { $snippet "seq" } " by sorting the sequence from lowest value to highest and outputting the middle one. If there is an even number of elements in the sequence, the median is not unique, so the mean of the two middle values is outputted." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } median ." "2" } @@ -29,7 +29,7 @@ HELP: median { $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ; HELP: range -{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } +{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } { $description "Computes the distance of the maximum and minimum values in " { $snippet "seq" } "." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } range ." "2" } diff --git a/basis/math/statistics/statistics-tests.factor b/basis/math/statistics/statistics-tests.factor index b6ff421956..c160d57db7 100644 --- a/basis/math/statistics/statistics-tests.factor +++ b/basis/math/statistics/statistics-tests.factor @@ -13,6 +13,24 @@ IN: math.statistics.tests [ 2 ] [ { 1 2 3 } median ] unit-test [ 5/2 ] [ { 1 2 3 4 } median ] unit-test +[ { } median ] must-fail +[ { } upper-median ] must-fail +[ { } lower-median ] must-fail + +[ 2 ] [ { 1 2 3 4 } lower-median ] unit-test +[ 3 ] [ { 1 2 3 4 } upper-median ] unit-test +[ 3 ] [ { 1 2 3 4 5 } lower-median ] unit-test +[ 3 ] [ { 1 2 3 4 5 } upper-median ] unit-test + + +[ 1 ] [ { 1 } lower-median ] unit-test +[ 1 ] [ { 1 } upper-median ] unit-test +[ 1 ] [ { 1 } median ] unit-test + +[ 1 ] [ { 1 2 } lower-median ] unit-test +[ 2 ] [ { 1 2 } upper-median ] unit-test +[ 3/2 ] [ { 1 2 } median ] unit-test + [ 1 ] [ { 1 2 3 } var ] unit-test [ 1.0 ] [ { 1 2 3 } std ] unit-test [ t ] [ { 1 2 3 4 } ste 0.6454972243679028 - .0001 < ] unit-test diff --git a/basis/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor index 4cd8c5b888..3812e79ec5 100644 --- a/basis/math/statistics/statistics.factor +++ b/basis/math/statistics/statistics.factor @@ -1,30 +1,66 @@ ! Copyright (C) 2008 Doug Coleman, Michael Judge. ! See http://factorcode.org/license.txt for BSD license. USING: arrays combinators kernel math math.analysis -math.functions math.order sequences sorting ; +math.functions math.order sequences sorting locals +sequences.private ; IN: math.statistics -: mean ( seq -- n ) +: mean ( seq -- x ) [ sum ] [ length ] bi / ; -: geometric-mean ( seq -- n ) +: geometric-mean ( seq -- x ) [ length ] [ product ] bi nth-root ; -: harmonic-mean ( seq -- n ) +: harmonic-mean ( seq -- x ) [ recip ] sigma recip ; -: median ( seq -- n ) - natural-sort dup length even? [ - [ midpoint@ dup 1 - 2array ] keep nths mean - ] [ - [ midpoint@ ] keep nth - ] if ; +:: kth-smallest ( seq k -- elt ) + #! Wirth's method, Algorithm's + Data structues = Programs p. 84 + #! The algorithm modifiers seq, so we clone it + seq clone :> seq + 0 :> i! + 0 :> j! + 0 :> l! + 0 :> x! + seq length 1 - :> m! + [ l m < ] + [ + k seq nth x! + l i! + m j! + [ i j <= ] + [ + [ i seq nth-unsafe x < ] [ i 1 + i! ] while + [ x j seq nth-unsafe < ] [ j 1 - j! ] while + i j <= [ + i j seq exchange + i 1 + i! + j 1 - j! + ] when + ] do while + + j k < [ i l! ] when + k i < [ j m! ] when + ] while + k seq nth ; inline + +: lower-median ( seq -- elt ) + dup dup length odd? [ midpoint@ ] [ midpoint@ 1 - ] if kth-smallest ; + +: upper-median ( seq -- elt ) + dup midpoint@ kth-smallest ; + +: medians ( seq -- lower upper ) + [ lower-median ] [ upper-median ] bi ; + +: median ( seq -- x ) + dup length odd? [ lower-median ] [ medians + 2 / ] if ; : minmax ( seq -- min max ) #! find the min and max of a seq in one pass [ 1/0. -1/0. ] dip [ [ min ] [ max ] bi-curry bi* ] each ; -: range ( seq -- n ) +: range ( seq -- x ) minmax swap - ; : var ( seq -- x ) @@ -32,15 +68,13 @@ IN: math.statistics dup length 1 <= [ drop 0 ] [ - [ [ mean ] keep [ - sq ] with sigma ] keep - length 1 - / + [ [ mean ] keep [ - sq ] with sigma ] + [ length 1 - ] bi / ] if ; -: std ( seq -- x ) - var sqrt ; +: std ( seq -- x ) var sqrt ; -: ste ( seq -- x ) - [ std ] [ length ] bi sqrt / ; +: ste ( seq -- x ) [ std ] [ length ] bi sqrt / ; : ((r)) ( mean(x) mean(y) {x} {y} -- (r) ) ! finds sigma((xi-mean(x))(yi-mean(y)) @@ -64,4 +98,3 @@ IN: math.statistics [ (r) ] 2keep ! stack is mean(x) mean(y) r sx sy swap / * ! stack is mean(x) mean(y) beta [ swapd * - ] keep ; - diff --git a/basis/tools/disassembler/gdb/gdb.factor b/basis/tools/disassembler/gdb/gdb.factor index 9076b67606..c4c724b696 100755 --- a/basis/tools/disassembler/gdb/gdb.factor +++ b/basis/tools/disassembler/gdb/gdb.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov, Jorge Acereda Macia. ! See http://factorcode.org/license.txt for BSD license. USING: io.files io.files.temp io words alien kernel math.parser -alien.syntax io.launcher system assocs arrays sequences +alien.syntax io.launcher assocs arrays sequences namespaces make system math io.encodings.ascii accessors tools.disassembler ; IN: tools.disassembler.gdb diff --git a/basis/uuid/uuid.factor b/basis/uuid/uuid.factor index 2fd6ffdaec..4d284a1a40 100644 --- a/basis/uuid/uuid.factor +++ b/basis/uuid/uuid.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2008 John Benediktsson ! See http://factorcode.org/license.txt for BSD license - -USING: byte-arrays checksums checksums.md5 checksums.sha1 +USING: byte-arrays checksums checksums.md5 checksums.sha kernel math math.parser math.ranges random unicode.case sequences strings system io.binary ; diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 088a8a6320..c7be17e38d 100644 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays debugger generic hashtables io assocs kernel.private -kernel math memory namespaces make parser prettyprint sequences -vectors words system splitting init io.files vocabs vocabs.loader -debugger continuations ; +USING: arrays assocs continuations debugger generic hashtables +init io io.files kernel kernel.private make math memory +namespaces parser prettyprint sequences splitting system +vectors vocabs vocabs.loader words ; QUALIFIED: bootstrap.image.private IN: bootstrap.stage1 diff --git a/core/checksums/checksums-docs.factor b/core/checksums/checksums-docs.factor index 6ef0e85025..a05bf3a685 100644 --- a/core/checksums/checksums-docs.factor +++ b/core/checksums/checksums-docs.factor @@ -47,8 +47,7 @@ $nl "Checksum implementations:" { $subsection "checksums.crc32" } { $vocab-subsection "MD5 checksum" "checksums.md5" } -{ $vocab-subsection "SHA1 checksum" "checksums.sha1" } -{ $vocab-subsection "SHA2 checksum" "checksums.sha2" } +{ $vocab-subsection "SHA checksums" "checksums.sha" } { $vocab-subsection "Adler-32 checksum" "checksums.adler-32" } { $vocab-subsection "OpenSSL checksums" "checksums.openssl" } ; diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor index 82918b6f81..0dd808c722 100644 --- a/core/checksums/checksums.factor +++ b/core/checksums/checksums.factor @@ -1,11 +1,48 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: sequences math.parser io io.backend io.files -kernel ; +USING: accessors io io.backend io.files kernel math math.parser +sequences byte-arrays byte-vectors quotations ; IN: checksums MIXIN: checksum +TUPLE: checksum-state + { bytes-read integer } { block-size integer } { bytes byte-vector } ; + +: new-checksum-state ( class -- checksum-state ) + new + BV{ } clone >>bytes ; inline + +M: checksum-state clone + call-next-method + [ clone ] change-bytes ; + +GENERIC: initialize-checksum-state ( class -- checksum-state ) + +GENERIC: checksum-block ( bytes checksum -- ) + +GENERIC: get-checksum ( checksum -- value ) + +: add-checksum-bytes ( checksum-state data -- checksum-state ) + over bytes>> [ push-all ] keep + [ dup length pick block-size>> >= ] + [ + 64 cut-slice [ >byte-array ] dip [ + over [ checksum-block ] + [ [ 64 + ] change-bytes-read drop ] bi + ] dip + ] while + >byte-vector + [ >>bytes ] [ length [ + ] curry change-bytes-read ] bi ; + +: add-checksum-stream ( checksum-state stream -- checksum-state ) + [ + [ [ swap add-checksum-bytes drop ] curry each-block ] keep + ] with-input-stream ; + +: add-checksum-file ( checksum-state path -- checksum-state ) + normalize-path (file-reader) add-checksum-stream ; + GENERIC: checksum-bytes ( bytes checksum -- value ) GENERIC: checksum-stream ( stream checksum -- value ) diff --git a/core/classes/predicate/predicate-docs.factor b/core/classes/predicate/predicate-docs.factor index 3ea0a24674..552ff209b8 100644 --- a/core/classes/predicate/predicate-docs.factor +++ b/core/classes/predicate/predicate-docs.factor @@ -1,6 +1,6 @@ USING: generic help.markup help.syntax kernel kernel.private namespaces sequences words arrays layouts help effects math -layouts classes.private classes compiler.units ; +classes.private classes compiler.units ; IN: classes.predicate ARTICLE: "predicates" "Predicate classes" diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 99dddb8aed..9b0f4c1530 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -88,6 +88,9 @@ M: sequence set-nth bounds-check set-nth-unsafe ; M: sequence nth-unsafe nth ; M: sequence set-nth-unsafe set-nth ; +: change-nth-unsafe ( i seq quot -- ) + [ [ nth-unsafe ] dip call ] 3keep drop set-nth-unsafe ; inline + ! The f object supports the sequence protocol trivially M: f length drop 0 ; M: f nth-unsafe nip ; diff --git a/extra/benchmark/sha1/sha1.factor b/extra/benchmark/sha1/sha1.factor index c1a7af2966..481bc31eb2 100644 --- a/extra/benchmark/sha1/sha1.factor +++ b/extra/benchmark/sha1/sha1.factor @@ -1,4 +1,4 @@ -USING: checksums checksums.sha1 sequences byte-arrays kernel ; +USING: checksums checksums.sha sequences byte-arrays kernel ; IN: benchmark.sha1 : sha1-file ( -- ) diff --git a/extra/crypto/hmac/authors.txt b/extra/crypto/hmac/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/extra/crypto/hmac/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/extra/crypto/hmac/hmac-tests.factor b/extra/crypto/hmac/hmac-tests.factor deleted file mode 100755 index 274e99d2f6..0000000000 --- a/extra/crypto/hmac/hmac-tests.factor +++ /dev/null @@ -1,38 +0,0 @@ -USING: kernel io strings byte-arrays sequences namespaces math -parser crypto.hmac tools.test ; -IN: crypto.hmac.tests - -[ - "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" -] [ - 16 11 "Hi There" sequence>md5-hmac >string ] unit-test - -[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] -[ "Jefe" "what do ya want for nothing?" sequence>md5-hmac >string ] unit-test - -[ - "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" -] -[ - 16 HEX: aa - 50 HEX: dd sequence>md5-hmac >string -] unit-test - -[ - "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" -] [ - 16 11 "Hi There" sequence>sha1-hmac >string -] unit-test - -[ - "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" -] [ - "Jefe" "what do ya want for nothing?" sequence>sha1-hmac >string -] unit-test - -[ - "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" -] [ - 16 HEX: aa - 50 HEX: dd sequence>sha1-hmac >string -] unit-test diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor deleted file mode 100755 index 9a668aa23a..0000000000 --- a/extra/crypto/hmac/hmac.factor +++ /dev/null @@ -1,55 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays combinators checksums checksums.md5 -checksums.sha1 checksums.md5.private io io.binary io.files -io.streams.byte-array kernel math math.vectors memoize sequences -io.encodings.binary ; -IN: crypto.hmac - -sha1 get-sha1 - initialize-sha1 - [ process-sha1-block ] - [ process-sha1-block ] bi* get-sha1 ; - -: md5-hmac ( Ko Ki -- hmac ) - initialize-md5 process-md5-block - stream>md5 get-md5 - initialize-md5 - [ process-md5-block ] - [ process-md5-block ] bi* get-md5 ; - -: seq-bitxor ( seq seq -- seq ) - [ bitxor ] 2map ; - -MEMO: ipad ( -- seq ) 64 HEX: 36 ; - -MEMO: opad ( -- seq ) 64 HEX: 5c ; - -: init-hmac ( K -- o i ) - 64 0 pad-tail - [ opad seq-bitxor ] - [ ipad seq-bitxor ] bi ; - -PRIVATE> - -: stream>sha1-hmac ( K stream -- hmac ) - [ init-hmac sha1-hmac ] with-input-stream ; - -: file>sha1-hmac ( K path -- hmac ) - binary stream>sha1-hmac ; - -: sequence>sha1-hmac ( K sequence -- hmac ) - binary stream>sha1-hmac ; - -: stream>md5-hmac ( K stream -- hmac ) - [ init-hmac md5-hmac ] with-input-stream ; - -: file>md5-hmac ( K path -- hmac ) - binary stream>md5-hmac ; - -: sequence>md5-hmac ( K sequence -- hmac ) - binary stream>md5-hmac ; diff --git a/extra/ecdsa/ecdsa-tests.factor b/extra/ecdsa/ecdsa-tests.factor index b319fa297b..2d9cda1460 100644 --- a/extra/ecdsa/ecdsa-tests.factor +++ b/extra/ecdsa/ecdsa-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Maxim Savchenko ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces ecdsa tools.test checksums checksums.sha2 ; +USING: namespaces ecdsa tools.test checksums checksums.sha ; IN: ecdsa.tests SYMBOLS: priv-key pub-key signature ; @@ -27,4 +27,4 @@ SYMBOLS: priv-key pub-key signature ; message sha-256 checksum-bytes signature get pub-key get "prime256v1" [ set-public-key ecdsa-verify ] with-ec -] unit-test \ No newline at end of file +] unit-test diff --git a/vm/callstack.cpp b/vm/callstack.cpp index 4ef6db10bd..608a5c39e5 100755 --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -92,7 +92,9 @@ cell frame_executing(stack_frame *frame) else { array *literals = untag(compiled->literals); - return array_nth(literals,0); + cell executing = array_nth(literals,0); + check_data_pointer((object *)executing); + return executing; } } @@ -102,6 +104,7 @@ stack_frame *frame_successor(stack_frame *frame) return (stack_frame *)((cell)frame - frame->size); } +/* Allocates memory */ cell frame_scan(stack_frame *frame) { if(frame_type(frame) == QUOTATION_TYPE) @@ -133,12 +136,12 @@ struct stack_frame_counter { struct stack_frame_accumulator { cell index; - array *frames; - stack_frame_accumulator(cell count) : index(0), frames(allot_array_internal(count)) {} + gc_root frames; + stack_frame_accumulator(cell count) : index(0), frames(allot_array(count,F)) {} void operator()(stack_frame *frame) { - set_array_nth(frames,index++,frame_executing(frame)); - set_array_nth(frames,index++,frame_scan(frame)); + set_array_nth(frames.untagged(),index++,frame_executing(frame)); + set_array_nth(frames.untagged(),index++,frame_scan(frame)); } }; @@ -154,7 +157,7 @@ PRIMITIVE(callstack_to_array) stack_frame_accumulator accum(counter.count); iterate_callstack_object(callstack.untagged(),accum); - dpush(tag(accum.frames)); + dpush(accum.frames.value()); } stack_frame *innermost_stack_frame(callstack *stack) diff --git a/vm/local_roots.hpp b/vm/local_roots.hpp index e074d999e7..4cee1c8e09 100644 --- a/vm/local_roots.hpp +++ b/vm/local_roots.hpp @@ -12,7 +12,7 @@ DEFPUSHPOP(gc_local_,gc_locals) template struct gc_root : public tagged { - void push() { gc_local_push((cell)this); } + void push() { check_tagged_pointer(tagged::value()); gc_local_push((cell)this); } explicit gc_root(cell value_) : tagged(value_) { push(); } explicit gc_root(T *value_) : tagged(value_) { push(); }