This revision uses the variables A B C D and gets rid of an embarrasing
gaffe.

Leo Wong hello_at_albany.net
http://www.albany.net/~hello/

\ md5v02.f Leo Wong 22 Dec 2000 +
\ md5 routine in ans forth after Fredrick W. Warren 02nov2000
\ Unofficial MD5 Homepage by Mordechai T. Abzug:
\ http://userpages.umbc.edu/~mabzug1/cs/md5/md5.html

\ tools

: 4dup ( n1 n2 n3 n4 -- n1 n2 n3 n4 n1 n2 n3 n4 ) 2OVER 2OVER ;
: variables 0 ?DO VARIABLE LOOP ;

\ MD5
5 VARIABLES A B C D message-length

\ Debugging words
: h? ( a -- ) HEX @ 8 U.R SPACE DECIMAL ;
: .ABCD ( -- ) CR A h? B h? C h? D h? ;

\ : f() ( b c d -- e ) >R OVER AND SWAP INVERT R> AND OR ;
: g() ( b c d -- e ) TUCK INVERT AND >R AND R> OR ;
: f() ( b c d -- e ) ROT g() ;
: h() ( b c d -- e ) XOR XOR ;
: i() ( b c d -- e ) INVERT ROT OR XOR ;

CREATE buf[] 64 allot

: b+ ( n -- ) CELLS buf[] + POSTPONE LITERAL ; IMMEDIATE
: op ( a e ac 'x -- a' a' ) @ + + + DUP ;
: ss ( s -- )
   32 OVER - POSTPONE LITERAL POSTPONE LITERAL ; IMMEDIATE
\ rotate a' left s bits
: lrotate ( a' a' 32-s s -- a'' ) >R RSHIFT SWAP R> LSHIFT OR ;

: out ( a b c d -- a b c d ) ( r: -- c b d )
   S" DUP 2OVER >R >R >R" EVALUATE ; IMMEDIATE
: back ( a'' -- d a''' b c ) ( r: c b d -- )
   S" R> SWAP R@ + R> R>" EVALUATE ; IMMEDIATE

HEX
: md-init ( -- )
   067452301 A ! 0efcdab89 B ! 098badcfe C ! 010325476 D !
   0 message-length ! ;

: round1 ( A B C D -- A' B' C' D' )
\ ac 'x s
   out f() 0d76aa478 [ 00 ] b+ op [ 07 ] ss lrotate back \ 1
   out f() 0e8c7b756 [ 01 ] b+ op [ 0c ] ss lrotate back \ 2
   out f() 0242070db [ 02 ] b+ op [ 11 ] ss lrotate back \ 3
   out f() 0c1bdceee [ 03 ] b+ op [ 16 ] ss lrotate back \ 4
   out f() 0f57c0faf [ 04 ] b+ op [ 07 ] ss lrotate back \ 5
   out f() 04787c62a [ 05 ] b+ op [ 0c ] ss lrotate back \ 6
   out f() 0a8304613 [ 06 ] b+ op [ 11 ] ss lrotate back \ 7
   out f() 0fd469501 [ 07 ] b+ op [ 16 ] ss lrotate back \ 8
   out f() 0698098d8 [ 08 ] b+ op [ 07 ] ss lrotate back \ 9
   out f() 08b44f7af [ 09 ] b+ op [ 0c ] ss lrotate back \ 10
   out f() 0ffff5bb1 [ 0a ] b+ op [ 11 ] ss lrotate back \ 11
   out f() 0895cd7be [ 0b ] b+ op [ 16 ] ss lrotate back \ 12
   out f() 06b901122 [ 0c ] b+ op [ 07 ] ss lrotate back \ 13
   out f() 0fd987193 [ 0d ] b+ op [ 0c ] ss lrotate back \ 14
   out f() 0a679438e [ 0e ] b+ op [ 11 ] ss lrotate back \ 15
   out f() 049b40821 [ 0f ] b+ op [ 16 ] ss lrotate back \ 16
  ;

: round2 ( A B C D -- A' B' C' D' )
   out g() 0f61e2562 [ 01 ] b+ op [ 05 ] ss lrotate back \ 1
   out g() 0c040b340 [ 06 ] b+ op [ 09 ] ss lrotate back \ 2
   out g() 0265e5a51 [ 0b ] b+ op [ 0e ] ss lrotate back \ 3
   out g() 0e9b6c7aa [ 00 ] b+ op [ 14 ] ss lrotate back \ 4
   out g() 0d62f105d [ 05 ] b+ op [ 05 ] ss lrotate back \ 5
   out g() 002441453 [ 0a ] b+ op [ 09 ] ss lrotate back \ 6
   out g() 0d8a1e681 [ 0f ] b+ op [ 0e ] ss lrotate back \ 7
   out g() 0e7d3fbc8 [ 04 ] b+ op [ 14 ] ss lrotate back \ 8
   out g() 021e1cde6 [ 09 ] b+ op [ 05 ] ss lrotate back \ 9
   out g() 0c33707d6 [ 0e ] b+ op [ 09 ] ss lrotate back \ 10
   out g() 0f4d50d87 [ 03 ] b+ op [ 0e ] ss lrotate back \ 11
   out g() 0455a14ed [ 08 ] b+ op [ 14 ] ss lrotate back \ 12
   out g() 0a9e3e905 [ 0d ] b+ op [ 05 ] ss lrotate back \ 13
   out g() 0fcefa3f8 [ 02 ] b+ op [ 09 ] ss lrotate back \ 14
   out g() 0676f02d9 [ 07 ] b+ op [ 0e ] ss lrotate back \ 15
   out g() 08d2a4c8a [ 0c ] b+ op [ 14 ] ss lrotate back \ 16
  ;

: round3 ( A B C D -- A' B' C' D' )
   out h() 0fffa3942 [ 05 ] b+ op [ 04 ] ss lrotate back \ 1
   out h() 08771f681 [ 08 ] b+ op [ 0b ] ss lrotate back \ 2
   out h() 06d9d6122 [ 0b ] b+ op [ 10 ] ss lrotate back \ 3
   out h() 0fde5380c [ 0e ] b+ op [ 17 ] ss lrotate back \ 4
   out h() 0a4beea44 [ 01 ] b+ op [ 04 ] ss lrotate back \ 5
   out h() 04bdecfa9 [ 04 ] b+ op [ 0b ] ss lrotate back \ 6
   out h() 0f6bb4b60 [ 07 ] b+ op [ 10 ] ss lrotate back \ 7
   out h() 0bebfbc70 [ 0a ] b+ op [ 17 ] ss lrotate back \ 8
   out h() 0289b7ec6 [ 0d ] b+ op [ 04 ] ss lrotate back \ 9
   out h() 0eaa127fa [ 00 ] b+ op [ 0b ] ss lrotate back \ 10
   out h() 0d4ef3085 [ 03 ] b+ op [ 10 ] ss lrotate back \ 11
   out h() 004881d05 [ 06 ] b+ op [ 17 ] ss lrotate back \ 12
   out h() 0d9d4d039 [ 09 ] b+ op [ 04 ] ss lrotate back \ 13
   out h() 0e6db99e5 [ 0c ] b+ op [ 0b ] ss lrotate back \ 14
   out h() 01fa27cf8 [ 0f ] b+ op [ 10 ] ss lrotate back \ 15
   out h() 0c4ac5665 [ 02 ] b+ op [ 17 ] ss lrotate back \ 16
  ;

: round4 ( A B C D -- A' B' C' D' )
   out i() 0f4292244 [ 00 ] b+ op [ 06 ] ss lrotate back \ 1
   out i() 0432aff97 [ 07 ] b+ op [ 0a ] ss lrotate back \ 2
   out i() 0ab9423a7 [ 0e ] b+ op [ 0f ] ss lrotate back \ 3
   out i() 0fc93a039 [ 05 ] b+ op [ 15 ] ss lrotate back \ 4
   out i() 0655b59c3 [ 0c ] b+ op [ 06 ] ss lrotate back \ 5
   out i() 08f0ccc92 [ 03 ] b+ op [ 0a ] ss lrotate back \ 6
   out i() 0ffeff47d [ 0a ] b+ op [ 0f ] ss lrotate back \ 7
   out i() 085845dd1 [ 01 ] b+ op [ 15 ] ss lrotate back \ 8
   out i() 06fa87e4f [ 08 ] b+ op [ 06 ] ss lrotate back \ 9
   out i() 0fe2ce6e0 [ 0f ] b+ op [ 0a ] ss lrotate back \ 10
   out i() 0a3014314 [ 06 ] b+ op [ 0f ] ss lrotate back \ 11
   out i() 04e0811a1 [ 0d ] b+ op [ 15 ] ss lrotate back \ 12
   out i() 0f7537e82 [ 04 ] b+ op [ 06 ] ss lrotate back \ 13
   out i() 0bd3af235 [ 0b ] b+ op [ 0a ] ss lrotate back \ 14
   out i() 02ad7d2bb [ 02 ] b+ op [ 0f ] ss lrotate back \ 15
   out i() 0eb86d391 [ 09 ] b+ op [ 15 ] ss lrotate back \ 16
  ;

DECIMAL
: transform ( -- )
   A @ B @ C @ D @
   round1 round2 round3 round4
   D +! C +! B +! A +! ;

\ Courtesy of Jean Grezel
: append-length ( -- )
   message-length @ 8 m* buf[] 60 + ! buf[] 56 + ! ;

\ do all 64 byte blocks leaving remainder block
: dofullblocks ( addr count -- addr' count' )
   BEGIN 2DUP 63 U>
   WHILE buf[] 64 CMOVE transform 64 /STRING REPEAT DROP ;

CREATE padding 64 allot padding 64 ERASE 128 padding c!
: movepartial ( addr count -- )
>R buf[] R@ CMOVE padding R@ buf[] + 64 R> - CMOVE ;

: dofinal ( addr count -- )
   TUCK movepartial 55 >
   IF transform buf[] 64 ERASE THEN
   append-length transform ;

\ compute md5 from a counted buffer of text
: md5full ( addr count -- )
  md-init dup message-length +!
  dofullblocks dofinal ;

\ functions for creating output string
create digit$
  48 c, 49 c, 50 c, 51 c, 52 c, 53 c, 54 c, 55 c, 56 c, 57 c,
  97 c, 98 c, 99 c, 100 c, 101 c, 102 c,

: savedigit ( n -- ) \ output digit at pad
   pad c@ 1+ dup pad c! pad + c! ;
: bytedigits ( n1 -- )
   dup 4 rshift digit$ + c@ savedigit 15 and digit$ + c@ savedigit ;

  : celldigits ( a1 -- ) 4 0 DO COUNT bytedigits LOOP DROP ;

: md5string ( -- addr count ) \ return address of counted md5 string
   0 PAD !
   A celldigits B celldigits C celldigits D celldigits
   PAD COUNT
;

\ test suite
: quotestring ( adr count -- )
  34 emit type 34 emit ;

: .md5 ( adr count -- )
  cr cr 2dup md5full md5string type space quotestring ;

: test s" message digest" .md5 ;

0 [IF]
\ MD5 for a file
\ Not tested by me. LW
TRUE VALUE md-init?
CREATE part[] 64 allot
: savepart ( adr count -- )
   message-length @ 63 AND if part[] swap CMOVE else 2drop then ;

: movepart ( adr1 count1 partindex -- adr2 count2 ) \ add to part[]
   2>R DUP part[] 64 R> /STRING R@ MIN >R R@ CMOVE 2R> /STRING ;

: md5update ( adr count -- )
  md-init? if md-init false to md-init? then
  message-length @ 63 AND over message-length +! ( a # partindex -- )
  dup if 2dup + 63 U>
         if movepart part[] 64 dofullblocks dofullblocks
             savepart cr
         else movepart 2drop then
      else drop dofullblocks savepart then ;

: md5final ( adr count -- )
  md-init? if md-init false to md-init? then
  message-length @ 63 AND over message-length +! ( a # partindex -- )
  dup if 2dup + 63 >
         if movepart part[] 64 dofullblocks dofullblocks dofinal
            else movepart 2drop part[] message-length @ 63 AND
                  dofinal then
      else drop dofullblocks dofinal then ;

 : foo ( -- )
  true to md-init?
  s" foo" r/o open-file 0=
  if begin dup pad 1024 rot read-file drop dup 1024 =
      while pad swap md5update
      repeat pad swap md5final
      close-file drop cr cr md5string type ." foo"
  else drop
  then ;

[THEN]

: md5test ( -- )
  ." md5 test suite results:"
  s" a" .md5
  s" abc" .md5
  s" message digest" .md5
  s" abcdefghijklmnopqrstuvwxyz" .md5
  s" abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz0123456789"
.md5
s"
1234567890123456789012345678901234567890123456789012345678901234567890123456
7890" .md5
  ( foo ) cr cr ;

\ SwiftForth specific performance test
\ On 233 MHz Pentium Win98 SwiftForth 1.50.4.21 Jan 1999:
\ 3525514 microseconds
\ Hash is: f38898bb69bb02bccb9594dfe471c5c0

 CREATE testspace 10000 ALLOT testspace 10000 BL FILL

: SPEED-TEST
   cr ." MD5 test: buffer of 10,000 spaces done 1000 times is "
   ucounter 1000 0 DO testspace 10000 MD5Full LOOP utimer
   ." microseconds "
   cr ." Hash is: " MD5string TYPE cr
;
Received on Fri Dec 22 2000 - 06:41:47 PST