\ MD5 routine in ANS Forth, Marcel Hendrix, December 13, 2000
\ Parts by Fredrick W. Warren <xfwarrenx@efn.org>
\ Little/BigEndian patches aren't implemented.

\ Uses ROL . 
\ [DEFINED] is from Wil's Toolbelt

[DEFINED] -work [IF] -work [THEN] MARKER -work

 DECIMAL

\ Constants for MD5Transform routine. 

 7 CONSTANT S11  12 CONSTANT S12  17 CONSTANT S13  22 CONSTANT S14
 5 CONSTANT S21	  9 CONSTANT S22  14 CONSTANT S23  20 CONSTANT S24
 4 CONSTANT S31	 11 CONSTANT S32  16 CONSTANT S33  23 CONSTANT S34
 6 CONSTANT S41	 10 CONSTANT S42  15 CONSTANT S43  21 CONSTANT S44

1 [IF]  \ This is slow. A good Forth will have the "ROL/ROR" intrinsic.
	\ With MPE's VFX this is FASTER than using inline CODE!
	32 CONSTANT BITS/CELL
	: ROL ( n #  --  u )  
	  S" 2DUP  LSHIFT  -ROT BITS/CELL -  NEGATE RSHIFT OR "
	  EVALUATE ; IMMEDIATE
[THEN]

 0 VALUE a
 0 VALUE b
 0 VALUE c
 0 VALUE d
 0 VALUE md5len
-1 VALUE md5int?

CREATE buf[]  16 CELLS ALLOT
CREATE part[] 16 CELLS ALLOT
CREATE md5pad 16 CELLS ALLOT	 md5pad 16 CELLS ERASE  128 md5pad C!

: <X>	CREATE  IMMEDIATE , 
	DOES>   @ POSTPONE LITERAL 
		S" @ + " EVALUATE ;

: +X[]=	16 0 DO  I CELLS buf[] + <X>  LOOP ;

  +X[]= +x[0] +x[1] +x[2] +x[3] +x[4] +x[5] +x[6] +x[7] +x[8] +x[9] +x[10] +x[11] +x[12] +x[13] +x[14] +x[15]

: F()  S" INVERT AND OR + + " EVALUATE ; IMMEDIATE
: G()  S" INVERT AND OR + + " EVALUATE ; IMMEDIATE
: H()  S" XOR XOR + + "       EVALUATE ; IMMEDIATE
: I()  S" INVERT OR XOR + + " EVALUATE ; IMMEDIATE

HEX
: Transform ( -- )

  a b c d  

\ ROUND1 	       F(x, y, z) = (x & y) | (~x & z) 

  D76AA478 +x[0]   a  b c AND d b F()  S11 ROL  b +  TO a
  E8C7B756 +x[1]   d  a b AND c a F()  S12 ROL  a +  TO d
  242070DB +x[2]   c  d a AND b d F()  S13 ROL  d +  TO c
  C1BDCEEE +x[3]   b  c d AND a c F()  S14 ROL  c +  TO b
  F57C0FAF +x[4]   a  b c AND d b F()  S11 ROL  b +  TO a
  4787C62A +x[5]   d  a b AND c a F()  S12 ROL  a +  TO d
  A8304613 +x[6]   c  d a AND b d F()  S13 ROL  d +  TO c
  FD469501 +x[7]   b  c d AND a c F()  S14 ROL  c +  TO b
  698098D8 +x[8]   a  b c AND d b F()  S11 ROL  b +  TO a
  8B44F7AF +x[9]   d  a b AND c a F()  S12 ROL  a +  TO d
  FFFF5BB1 +x[10]  c  d a AND b d F()  S13 ROL  d +  TO c
  895CD7BE +x[11]  b  c d AND a c F()  S14 ROL  c +  TO b
  6B901122 +x[12]  a  b c AND d b F()  S11 ROL  b +  TO a
  FD987193 +x[13]  d  a b AND c a F()  S12 ROL  a +  TO d
  A679438E +x[14]  c  d a AND b d F()  S13 ROL  d +  TO c
  49B40821 +x[15]  b  c d AND a c F()  S14 ROL  c +  TO b 

\ ROUND2 	       G(x, y, z) = (x & z) | (y & ~z)

  F61E2562 +x[1]   a  b d AND c d G()  S21 ROL  b +  TO a
  C040B340 +x[6]   d  a c AND b c G()  S22 ROL  a +  TO d
  265E5A51 +x[11]  c  d b AND a b G()  S23 ROL  d +  TO c
  E9B6C7AA +x[0]   b  c a AND d a G()  S24 ROL  c +  TO b
  D62F105D +x[5]   a  b d AND c d G()  S21 ROL  b +  TO a
  02441453 +x[10]  d  a c AND b c G()  S22 ROL  a +  TO d
  D8A1E681 +x[15]  c  d b AND a b G()  S23 ROL  d +  TO c
  E7D3FBC8 +x[4]   b  c a AND d a G()  S24 ROL  c +  TO b
  21E1CDE6 +x[9]   a  b d AND c d G()  S21 ROL  b +  TO a
  C33707D6 +x[14]  d  a c AND b c G()  S22 ROL  a +  TO d
  F4D50D87 +x[3]   c  d b AND a b G()  S23 ROL  d +  TO c
  455A14ED +x[8]   b  c a AND d a G()  S24 ROL  c +  TO b
  A9E3E905 +x[13]  a  b d AND c d G()  S21 ROL  b +  TO a
  FCEFA3F8 +x[2]   d  a c AND b c G()  S22 ROL  a +  TO d
  676F02D9 +x[7]   c  d b AND a b G()  S23 ROL  d +  TO c
  8D2A4C8A +x[12]  b  c a AND d a G()  S24 ROL  c +  TO b 

\ ROUND3 	       H(x, y, z) = x ^ y ^ z

  FFFA3942 +x[5]   a  b c d H()  S31 ROL  b +  TO a
  8771F681 +x[8]   d  a b c H()  S32 ROL  a +  TO d
  6D9D6122 +x[11]  c  d a b H()  S33 ROL  d +  TO c
  FDE5380C +x[14]  b  c d a H()  S34 ROL  c +  TO b
  A4BEEA44 +x[1]   a  b c d H()  S31 ROL  b +  TO a
  4BDECFA9 +x[4]   d  a b c H()  S32 ROL  a +  TO d
  F6BB4B60 +x[7]   c  d a b H()  S33 ROL  d +  TO c
  BEBFBC70 +x[10]  b  c d a H()  S34 ROL  c +  TO b
  289B7EC6 +x[13]  a  b c d H()  S31 ROL  b +  TO a
  EAA127FA +x[0]   d  a b c H()  S32 ROL  a +  TO d
  D4EF3085 +x[3]   c  d a b H()  S33 ROL  d +  TO c
  04881D05 +x[6]   b  c d a H()  S34 ROL  c +  TO b
  D9D4D039 +x[9]   a  b c d H()  S31 ROL  b +  TO a
  E6DB99E5 +x[12]  d  a b c H()  S32 ROL  a +  TO d
  1FA27CF8 +x[15]  c  d a b H()  S33 ROL  d +  TO c
  C4AC5665 +x[2]   b  c d a H()  S34 ROL  c +  TO b 

\ ROUND4 	       I(x, y, z) = y ^ (x | ~z)

  F4292244 +x[0]   a  c b d I()  S41 ROL  b +  TO a
  432AFF97 +x[7]   d  b a c I()  S42 ROL  a +  TO d
  AB9423A7 +x[14]  c  a d b I()  S43 ROL  d +  TO c
  FC93A039 +x[5]   b  d c a I()  S44 ROL  c +  TO b
  655B59C3 +x[12]  a  c b d I()  S41 ROL  b +  TO a
  8F0CCC92 +x[3]   d  b a c I()  S42 ROL  a +  TO d
  FFEFF47D +x[10]  c  a d b I()  S43 ROL  d +  TO c
  85845DD1 +x[1]   b  d c a I()  S44 ROL  c +  TO b
  6FA87E4F +x[8]   a  c b d I()  S41 ROL  b +  TO a
  FE2CE6E0 +x[15]  d  b a c I()  S42 ROL  a +  TO d
  A3014314 +x[6]   c  a d b I()  S43 ROL  d +  TO c
  4E0811A1 +x[13]  b  d c a I()  S44 ROL  c +  TO b
  F7537E82 +x[4]   a  c b d I()  S41 ROL  b +  TO a
  BD3AF235 +x[11]  d  b a c I()  S42 ROL  a +  TO d
  2AD7D2BB +x[2]   c  a d b I()  S43 ROL  d +  TO c
  EB86D391 +x[9]   b  d c a I()  S44 ROL  c +  TO b 

  d + TO d  c + TO c  b + TO b  a + TO a ;

: MD5INIT ( -- )
	67452301 TO a   EFCDAB89 TO b 
	98BADCFE TO c   10325476 TO d 
	0 TO md5len ;

DECIMAL

\ ------------------------------------------------------------*
\							      *
\ Didn't look at this yet. Could become important bottleneck. *
\							      *
\ ------------------------------------------------------------/
: SETLEN ( -- )	md5len 8 M*  buf[] 60 + ! buf[] 56 + ! ;

\ Do all 64 byte blocks leaving remainder block
: DOFULLBLOCKS ( addr1 count1 --  addr2 count2 )
	BEGIN  DUP 63 >
	WHILE  64 - SWAP DUP buf[] 64 CMOVE
               64 + SWAP Transform
	REPEAT ;

: MOVEPARTIAL ( addr count -- )
	SWAP   OVER buf[] SWAP CMOVE
	md5pad OVER buf[] + ROT 64 SWAP - CMOVE ;

: DOFINAL ( addr count -- )
	2DUP MOVEPARTIAL DUP 55 >  
	IF  Transform  buf[] 64 0 FILL  THEN
	2DROP SETLEN Transform  ;

\ compute MD5 from a counted buffer of text
: MD5Full ( addr count -- )
	MD5INIT DUP md5len + TO md5len  DOFULLBLOCKS DOFINAL ;

: SAVEPART ( addr count -- ) 
	md5len 64 MOD IF  part[] SWAP CMOVE  ELSE  2DROP  THEN  ;

: MOVEPART ( addr1 count1 partindex -- addr2 count2 ) \ add to part[]
	2DUP 64 SWAP - MIN >R  part[] + >R OVER R> R@ CMOVE
	SWAP R@ + SWAP R> - ;

: MD5Update ( adr count -- ) 
	md5int? IF  MD5INIT FALSE TO md5int?  THEN
	md5len 64 MOD OVER md5len + TO md5len ( addr count partindex -- )
	DUP IF 2DUP + 63 >
		  IF  MOVEPART part[] 64 DOFULLBLOCKS  DOFULLBLOCKS SAVEPART CR
                ELSE  MOVEPART 2DROP 
	        THEN
	  ELSE DROP DOFULLBLOCKS SAVEPART 
	  THEN ;

: MD5Final ( adr count -- ) 
	md5int? IF  MD5INIT FALSE TO md5int?  THEN
	md5len 64 MOD OVER md5len + TO md5len ( addr count partindex -- )
	DUP IF 2DUP + 63 >
                 IF  MOVEPART part[] 64 DOFULLBLOCKS  DOFULLBLOCKS DOFINAL
               ELSE  MOVEPART 2DROP part[] md5len 64 MOD DOFINAL 
	       THEN
	 ELSE DROP DOFULLBLOCKS DOFINAL 
	 THEN ;

\ Functions for creating output string
: >DIGIT ( ix -- char )	CHARS S" 0123456789abcdef" DROP + C@ ;	

: initdigits ( -- )   0 PAD C! ;
: savedigit  ( c -- ) PAD C@ 1+ DUP PAD C!  CHARS PAD + C! ;
: bytedigits ( n -- ) DUP 4 RSHIFT >DIGIT savedigit  15 AND >DIGIT savedigit ;
: celldigits ( n -- ) 4 0 DO  DUP 255 AND bytedigits  8 RSHIFT  LOOP DROP ;

: MD5string  ( -- addr count ) \ return address of counted MD5 string
	initdigits 
	a celldigits  b celldigits  c celldigits  d celldigits 
	PAD COUNT  TRUE TO md5int? ;

\ Test Suite
: QuoteString ( addr count -- )	[CHAR] " EMIT  TYPE  [CHAR] " EMIT ;
: .MD5	      ( addr count -- )	CR 2DUP MD5Full MD5string TYPE SPACE QuoteString ;

: .###	( -- )
	BASE @ >R DECIMAL
	MS? 0
	 <#  # # # [CHAR] . HOLD  #S  #>
	R> BASE ! TYPE ;

CREATE testspace 10000 ALLOT  testspace 10000 BL FILL

\ System-dependent timer words.
: SPEED-TEST
	CR ." 1000 times 10,000 spaces ... " TIMER-RESET 
	  1000 0 DO  testspace 10000 MD5Full  LOOP
	.### ."  ms/iteration, result: " MD5string TYPE ;

: MD5Test ( -- )
  ." MD5 test suite results:"
  CR
  CR ." ( d41d8cd98f00b204e9800998ecf8427e ''"
  CR ."   0cc175b9c0f1b6a831c399e269772661 'a'"
  CR ."   900150983cd24fb0d6963f7d28e17f72 'abc'"
  CR ."   c3fcd3d76192e4007dfb496cca67e13b 'abcdefghijklmnopqrstuvwxyz'"
  CR ."   d174ab98d277d9f5a5611c2c9f419d9f 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789'"
  CR ."   57edf4a22be3c955ac49da2e2107b67a '12345678901234567890123456789012345678901234567890123456789012345678901234567890' )"
  CR
  S" " .MD5
  S" a" .MD5
  S" abc" .MD5
  S" abcdefghijklmnopqrstuvwxyz" .MD5
  S" ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" .MD5
  S" 12345678901234567890123456789012345678901234567890123456789012345678901234567890" .MD5 
  SPEED-TEST 
  CR CR ;

: ABOUT CR ." Try: MD5Test" 
	CR ."      SPEED-TEST" ;

\ FORTH> speed-test ( P54C 166 MHz, iForth 1.11d ) 
\ 1000 times 10,000 spaces ... 1.351 ms/iteration, result: f38898bb69bb02bccb9594dfe471c5c0

\ speed-test ( P54C 166 MHz, VFX ) 
\ 1000 times 10,000 spaces ... 1.132 ms/iteration, result: f38898bb69bb02bccb9594dfe471c5c0

\ FORTH> speed-test ( Athlon 900 MHz, iForth ) 
\ 1000 times 10,000 spaces ... 0.250 ms/iteration, result: f38898bb69bb02bccb9594dfe471c5c0

\ speed-test ( Athlon 900 MHz, VFX ) 
\ 1000 times 10,000 spaces ... 0.160 ms/iteration, result: f38898bb69bb02bccb9594dfe471c5c0

\ End of file


