! Copyright (C) 2006, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types 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 accessors
-checksums.common checksums.stream combinators combinators.smart
-specialized-arrays literals hints ;
+USING: accessors alien.c-types alien.data byte-arrays checksums
+checksums.common combinators grouping hints kernel
+kernel.private literals math math.bitwise
+math.functions sequences sequences.private specialized-arrays ;
SPECIALIZED-ARRAY: uint
IN: checksums.md5
SINGLETON: md5
-INSTANCE: md5 stream-checksum
+INSTANCE: md5 block-checksum
-TUPLE: md5-state < checksum-state state old-state ;
+TUPLE: md5-state < block-checksum-state
+{ state uint-array }
+{ old-state uint-array } ;
: <md5-state> ( -- md5 )
md5-state new-checksum-state
64 >>block-size
- uint-array{ HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 }
+ uint-array{ 0x67452301 0xefcdab89 0x98badcfe 0x10325476 }
[ clone >>state ] [ >>old-state ] bi ;
M: md5 initialize-checksum-state drop <md5-state> ;
<PRIVATE
-: v-w+ ( v1 v2 -- v3 ) [ w+ ] 2map ;
-
: update-md5 ( md5 -- )
- [ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri
- [ old-state<< ] [ state<< ] bi ;
+ [ state>> ] [ old-state>> [ w+ ] 2map dup clone ] [ ] tri
+ [ old-state<< ] [ state<< ] bi ; inline
-CONSTANT: T
- $[
- 80 iota [ sin abs 32 2^ * >integer ] uint-array{ } map-as
- ]
+CONSTANT: T $[
+ 80 <iota> [ sin abs 32 2^ * >integer ] uint-array{ } map-as
+]
:: F ( X Y Z -- FXYZ )
- #! F(X,Y,Z) = XY v not(X) Z
+ ! F(X,Y,Z) = XY v not(X) Z
X Y bitand X bitnot Z bitand bitor ; inline
:: G ( X Y Z -- GXYZ )
- #! G(X,Y,Z) = XZ v Y not(Z)
+ ! G(X,Y,Z) = XZ v Y not(Z)
X Z bitand Y Z bitnot bitand bitor ; inline
: H ( X Y Z -- HXYZ )
- #! H(X,Y,Z) = X xor Y xor Z
+ ! H(X,Y,Z) = X xor Y xor Z
bitxor bitxor ; inline
:: I ( X Y Z -- IXYZ )
- #! I(X,Y,Z) = Y xor (X v not(Z))
+ ! I(X,Y,Z) = Y xor (X v not(Z))
Z bitnot X bitor Y bitxor ; inline
CONSTANT: S11 7
CONSTANT: d 3
:: (ABCD) ( x state a b c d k s i quot -- )
- #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
+ ! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
a state [
b state nth-unsafe
c state nth-unsafe
k x nth-unsafe w+
i T nth-unsafe w+
s bitroll-32
- b state nth-unsafe w+ 32 bits
+ b state nth-unsafe w+
] change-nth-unsafe ; inline
-MACRO: with-md5-round ( ops quot -- )
+MACRO: with-md5-round ( ops quot -- quot )
'[ [ _ (ABCD) ] compose ] map '[ _ 2cleave ] ;
: (process-md5-block-F) ( block state -- )
- {
+ { uint-array uint-array } declare {
[ a b c d 0 S11 1 ]
[ d a b c 1 S12 2 ]
[ c d a b 2 S13 3 ]
} [ F ] with-md5-round ;
: (process-md5-block-G) ( block state -- )
- {
+ { uint-array uint-array } declare {
[ a b c d 1 S21 17 ]
[ d a b c 6 S22 18 ]
[ c d a b 11 S23 19 ]
} [ G ] with-md5-round ;
: (process-md5-block-H) ( block state -- )
- {
+ { uint-array uint-array } declare {
[ a b c d 5 S31 33 ]
[ d a b c 8 S32 34 ]
[ c d a b 11 S33 35 ]
} [ H ] with-md5-round ;
: (process-md5-block-I) ( block state -- )
- {
+ { uint-array uint-array } declare {
[ a b c d 0 S41 49 ]
[ d a b c 7 S42 50 ]
[ c d a b 14 S43 51 ]
[ b c d a 9 S44 64 ]
} [ I ] with-md5-round ;
-HINTS: (process-md5-block-F) { uint-array md5-state } ;
-HINTS: (process-md5-block-G) { uint-array md5-state } ;
-HINTS: (process-md5-block-H) { uint-array md5-state } ;
-HINTS: (process-md5-block-I) { uint-array md5-state } ;
-
: byte-array>le ( byte-array -- byte-array )
little-endian? [
- dup 4 <sliced-groups> [
+ dup 4 <groups> [
[ [ 1 2 ] dip exchange-unsafe ]
[ [ 0 3 ] dip exchange-unsafe ] bi
] each
] unless ;
-: uint-array-cast-le ( byte-array -- uint-array )
- byte-array>le uint-array-cast ;
-
-HINTS: uint-array-cast-le byte-array ;
+HINTS: byte-array>le byte-array ;
-: uint-array>byte-array-le ( uint-array -- byte-array )
- underlying>> byte-array>le ;
-
-HINTS: uint-array>byte-array-le uint-array ;
-
-M: md5-state checksum-block ( block state -- )
+M: md5-state checksum-block
[
- [ uint-array-cast-le ] [ state>> ] bi* {
+ [ byte-array>le uint cast-array ] [ state>> ] bi* {
[ (process-md5-block-F) ]
[ (process-md5-block-G) ]
[ (process-md5-block-H) ]
[ (process-md5-block-I) ]
} 2cleave
] [
- nip update-md5
- ] 2bi ;
+ update-md5
+ ] bi ;
-: md5>checksum ( md5 -- bytes ) state>> uint-array>byte-array-le ;
+: md5>checksum ( md5 -- bytes )
+ state>> underlying>> byte-array>le ;
-M: md5-state clone ( md5 -- new-md5 )
+M: md5-state clone
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
+M: md5-state get-checksum
+ 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
- [ <md5-state> ] dip add-checksum-stream get-checksum ;
-
PRIVATE>