Although the following code was too slow for comp.lang.forth, it appears to
be SwiftForth friendly (v1.50.4). Optimizations are minimal. Note that I
have not tested
the "foo" section. If anyone verifies/corrects that section I should
appreciate knowing about it, as well as about other corrections/improvements
to the source and
additional timing reports.

\ md5sf.f Leo Wong 20 Dec 2000 +
\ md5 routine in ans forth by fredrick w warren comp.lang.forth 02nov2000
\ Most of Mr. Warren's code can be identified by not being indented on the
second line.
\ He also uses lower case throughout. I use upper case for ANS Standard
words.

\ tools
: 4dup ( a b c d -- a b c d a b c d ) 2OVER 2OVER ;
: @s ( a n -- x1 ... xn ) 0 ?DO DUP @ SWAP CELL+ LOOP DROP ;
: cell- ( a -- a' ) 1 CELLS - ;
: !s ( x1 ... xn a n -- )
   TUCK CELLS + SWAP 0 ?DO cell- TUCK ! LOOP DROP ;
: +!s ( x1 ... xn a n -- )
   TUCK CELLS + SWAP 0 ?DO cell- TUCK +! LOOP DROP ;

HEX
CREATE md5-buffer
  067452301 , 0efcdab89 , 098badcfe , 010325476 ,
DECIMAL

variable md5len

create buf[] 64 allot
create part[] 64 allot
create md5pad 64 allot md5pad 64 ERASE 128 md5pad c!

\ : f() ( a b c d - a e ) >R OVER AND SWAP INVERT R> AND OR ;
: g() TUCK INVERT AND >R AND R> OR ;
: f() ROT g() ;
: h() xor xor ;
: i() invert rot or xor ;

: b+ ( n -- a ) CELLS buf[] + POSTPONE LITERAL ; IMMEDIATE
: op ( e n1 a -- a' ) @ + + + ;
: lroll ( a' s1 -- res ) \ roll left with c/o to bit 0
>R DUP 32 R@ - RSHIFT SWAP R> LSHIFT OR ;

: out S" DUP 2OVER >R >R >R" EVALUATE ; IMMEDIATE
: back S" R> SWAP R@ + R> R>" EVALUATE ; IMMEDIATE

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

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

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

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

: md5int
   067452301 0efcdab89 098badcfe 010325476 md5-buffer 4 !s
   0 md5len ! ;
DECIMAL

: transform
   md5-buffer 4 @s
   4dup round1 round2 round3 round4
   md5-buffer 4 !s md5-buffer 4 +!s ;

TRUE VALUE md5int?

: setlen ( -- )
   md5len @ 8 m* buf[] 60 + ! buf[] 56 + ! ;

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

: movepartial ( addr count -- )
>R buf[] R@ CMOVE md5pad R@ buf[] + 64 R> - CMOVE ;

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

\ compute md5 from a counted buffer of text
: md5full ( addr count -- )
  md5int dup md5len +!
  dofullblocks
  dofinal ;

: savepart ( adr count -- )
   md5len @ 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 ;

\ 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,

: intdigits ( -- ) 0 pad ! ;
: 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 ( -- adr count ) \ return address of counted md5 string
   intdigits
   md5-buffer DUP celldigits
   CELL+ DUP celldigits
   CELL+ DUP celldigits
   CELL+ celldigits
   pad count
   true to md5int? ;

\ 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]
\ Not tested by me. LW
: md5update ( adr count -- )
  md5int? if md5int false to md5int? then
  md5len @ 63 AND over md5len +! ( adr count 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 -- )
  md5int? if md5int false to md5int? then
  md5len @ 63 AND over md5len +! ( adr count partindex -- )
  dup if 2dup + 63 >
         if movepart part[] 64 dofullblocks dofullblocks dofinal
            else movepart 2drop part[] md5len @ 63 AND dofinal then
      else drop dofullblocks dofinal then ;

 : foo ( -- )
  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
\ About 4000000 microseconds on 233 Mhz Pentium, 32M RAM
 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 Wed Dec 20 2000 - 08:27:42 PST