sha256-lf94.f

\ Here lies a true exercise for my Forth studies.
\ Translated from pseudo-code data:text/plain;base64,Tm90ZSAxOiBBbGwgdmFyaWFibGVzIGFyZSAzMiBiaXQgdW5zaWduZWQgaW50ZWdlcnMgYW5kIGFkZGl0aW9uIGlzIGNhbGN1bGF0ZWQgbW9kdWxvIDIzMgpOb3RlIDI6IEZvciBlYWNoIHJvdW5kLCB0aGVyZSBpcyBvbmUgcm91bmQgY29uc3RhbnQga1tpXSBhbmQgb25lIGVudHJ5IGluIHRoZSBtZXNzYWdlIHNjaGVkdWxlIGFycmF5IHdbaV0sIDAg4omkIGkg4omkIDYzCk5vdGUgMzogVGhlIGNvbXByZXNzaW9uIGZ1bmN0aW9uIHVzZXMgOCB3b3JraW5nIHZhcmlhYmxlcywgYSB0aHJvdWdoIGgKTm90ZSA0OiBCaWctZW5kaWFuIGNvbnZlbnRpb24gaXMgdXNlZCB3aGVuIGV4cHJlc3NpbmcgdGhlIGNvbnN0YW50cyBpbiB0aGlzIHBzZXVkb2NvZGUsCiAgICBhbmQgd2hlbiBwYXJzaW5nIG1lc3NhZ2UgYmxvY2sgZGF0YSBmcm9tIGJ5dGVzIHRvIHdvcmRzLCBmb3IgZXhhbXBsZSwKICAgIHRoZSBmaXJzdCB3b3JkIG9mIHRoZSBpbnB1dCBtZXNzYWdlICJhYmMiIGFmdGVyIHBhZGRpbmcgaXMgMHg2MTYyNjM4MAoKSW5pdGlhbGl6ZSBoYXNoIHZhbHVlczoKKGZpcnN0IDMyIGJpdHMgb2YgdGhlIGZyYWN0aW9uYWwgcGFydHMgb2YgdGhlIHNxdWFyZSByb290cyBvZiB0aGUgZmlyc3QgOCBwcmltZXMgMi4uMTkpOgpoMCA6PSAweDZhMDllNjY3CmgxIDo9IDB4YmI2N2FlODUKaDIgOj0gMHgzYzZlZjM3MgpoMyA6PSAweGE1NGZmNTNhCmg0IDo9IDB4NTEwZTUyN2YKaDUgOj0gMHg5YjA1Njg4YwpoNiA6PSAweDFmODNkOWFiCmg3IDo9IDB4NWJlMGNkMTkKCkluaXRpYWxpemUgYXJyYXkgb2Ygcm91bmQgY29uc3RhbnRzOgooZmlyc3QgMzIgYml0cyBvZiB0aGUgZnJhY3Rpb25hbCBwYXJ0cyBvZiB0aGUgY3ViZSByb290cyBvZiB0aGUgZmlyc3QgNjQgcHJpbWVzIDIuLjMxMSk6CmtbMC4uNjNdIDo9CiAgIDB4NDI4YTJmOTgsIDB4NzEzNzQ0OTEsIDB4YjVjMGZiY2YsIDB4ZTliNWRiYTUsIDB4Mzk1NmMyNWIsIDB4NTlmMTExZjEsIDB4OTIzZjgyYTQsIDB4YWIxYzVlZDUsCiAgIDB4ZDgwN2FhOTgsIDB4MTI4MzViMDEsIDB4MjQzMTg1YmUsIDB4NTUwYzdkYzMsIDB4NzJiZTVkNzQsIDB4ODBkZWIxZmUsIDB4OWJkYzA2YTcsIDB4YzE5YmYxNzQsCiAgIDB4ZTQ5YjY5YzEsIDB4ZWZiZTQ3ODYsIDB4MGZjMTlkYzYsIDB4MjQwY2ExY2MsIDB4MmRlOTJjNmYsIDB4NGE3NDg0YWEsIDB4NWNiMGE5ZGMsIDB4NzZmOTg4ZGEsCiAgIDB4OTgzZTUxNTIsIDB4YTgzMWM2NmQsIDB4YjAwMzI3YzgsIDB4YmY1OTdmYzcsIDB4YzZlMDBiZjMsIDB4ZDVhNzkxNDcsIDB4MDZjYTYzNTEsIDB4MTQyOTI5NjcsCiAgIDB4MjdiNzBhODUsIDB4MmUxYjIxMzgsIDB4NGQyYzZkZmMsIDB4NTMzODBkMTMsIDB4NjUwYTczNTQsIDB4NzY2YTBhYmIsIDB4ODFjMmM5MmUsIDB4OTI3MjJjODUsCiAgIDB4YTJiZmU4YTEsIDB4YTgxYTY2NGIsIDB4YzI0YjhiNzAsIDB4Yzc2YzUxYTMsIDB4ZDE5MmU4MTksIDB4ZDY5OTA2MjQsIDB4ZjQwZTM1ODUsIDB4MTA2YWEwNzAsCiAgIDB4MTlhNGMxMTYsIDB4MWUzNzZjMDgsIDB4Mjc0ODc3NGMsIDB4MzRiMGJjYjUsIDB4MzkxYzBjYjMsIDB4NGVkOGFhNGEsIDB4NWI5Y2NhNGYsIDB4NjgyZTZmZjMsCiAgIDB4NzQ4ZjgyZWUsIDB4NzhhNTYzNmYsIDB4ODRjODc4MTQsIDB4OGNjNzAyMDgsIDB4OTBiZWZmZmEsIDB4YTQ1MDZjZWIsIDB4YmVmOWEzZjcsIDB4YzY3MTc4ZjIKClByZS1wcm9jZXNzaW5nIChQYWRkaW5nKToKYmVnaW4gd2l0aCB0aGUgb3JpZ2luYWwgbWVzc2FnZSBvZiBsZW5ndGggTCBiaXRzCmFwcGVuZCBhIHNpbmdsZSAnMScgYml0CmFwcGVuZCBLICcwJyBiaXRzLCB3aGVyZSBLIGlzIHRoZSBtaW5pbXVtIG51bWJlciA+PSAwIHN1Y2ggdGhhdCAoTCArIDEgKyBLICsgNjQpIGlzIGEgbXVsdGlwbGUgb2YgNTEyCmFwcGVuZCBMIGFzIGEgNjQtYml0IGJpZy1lbmRpYW4gaW50ZWdlciwgbWFraW5nIHRoZSB0b3RhbCBwb3N0LXByb2Nlc3NlZCBsZW5ndGggYSBtdWx0aXBsZSBvZiA1MTIgYml0cwpzdWNoIHRoYXQgdGhlIGJpdHMgaW4gdGhlIG1lc3NhZ2UgYXJlOiA8b3JpZ2luYWwgbWVzc2FnZSBvZiBsZW5ndGggTD4gMSA8SyB6ZXJvcz4gPEwgYXMgNjQgYml0IGludGVnZXI+ICwgKHRoZSBudW1iZXIgb2YgYml0cyB3aWxsIGJlIGEgbXVsdGlwbGUgb2YgNTEyKQoKUHJvY2VzcyB0aGUgbWVzc2FnZSBpbiBzdWNjZXNzaXZlIDUxMi1iaXQgY2h1bmtzOgpicmVhayBtZXNzYWdlIGludG8gNTEyLWJpdCBjaHVua3MKZm9yIGVhY2ggY2h1bmsKICAgIGNyZWF0ZSBhIDY0LWVudHJ5IG1lc3NhZ2Ugc2NoZWR1bGUgYXJyYXkgd1swLi42M10gb2YgMzItYml0IHdvcmRzCiAgICAoVGhlIGluaXRpYWwgdmFsdWVzIGluIHdbMC4uNjNdIGRvbid0IG1hdHRlciwgc28gbWFueSBpbXBsZW1lbnRhdGlvbnMgemVybyB0aGVtIGhlcmUpCiAgICBjb3B5IGNodW5rIGludG8gZmlyc3QgMTYgd29yZHMgd1swLi4xNV0gb2YgdGhlIG1lc3NhZ2Ugc2NoZWR1bGUgYXJyYXkKCiAgICBFeHRlbmQgdGhlIGZpcnN0IDE2IHdvcmRzIGludG8gdGhlIHJlbWFpbmluZyA0OCB3b3JkcyB3WzE2Li42M10gb2YgdGhlIG1lc3NhZ2Ugc2NoZWR1bGUgYXJyYXk6CiAgICBmb3IgaSBmcm9tIDE2IHRvIDYzCiAgICAgICAgczAgOj0gKHdbaS0xNV0gcmlnaHRyb3RhdGUgIDcpIHhvciAod1tpLTE1XSByaWdodHJvdGF0ZSAxOCkgeG9yICh3W2ktMTVdIHJpZ2h0c2hpZnQgIDMpCiAgICAgICAgczEgOj0gKHdbaS0yXSByaWdodHJvdGF0ZSAxNykgeG9yICh3W2ktMl0gcmlnaHRyb3RhdGUgMTkpIHhvciAod1tpLTJdIHJpZ2h0c2hpZnQgMTApCiAgICAgICAgd1tpXSA6PSB3W2ktMTZdICsgczAgKyB3W2ktN10gKyBzMQoKICAgIEluaXRpYWxpemUgd29ya2luZyB2YXJpYWJsZXMgdG8gY3VycmVudCBoYXNoIHZhbHVlOgogICAgYSA6PSBoMAogICAgYiA6PSBoMQogICAgYyA6PSBoMgogICAgZCA6PSBoMwogICAgZSA6PSBoNAogICAgZiA6PSBoNQogICAgZyA6PSBoNgogICAgaCA6PSBoNwoKICAgIENvbXByZXNzaW9uIGZ1bmN0aW9uIG1haW4gbG9vcDoKICAgIGZvciBpIGZyb20gMCB0byA2MwogICAgICAgIFMxIDo9IChlIHJpZ2h0cm90YXRlIDYpIHhvciAoZSByaWdodHJvdGF0ZSAxMSkgeG9yIChlIHJpZ2h0cm90YXRlIDI1KQogICAgICAgIGNoIDo9IChlIGFuZCBmKSB4b3IgKChub3QgZSkgYW5kIGcpCiAgICAgICAgdGVtcDEgOj0gaCArIFMxICsgY2ggKyBrW2ldICsgd1tpXQogICAgICAgIFMwIDo9IChhIHJpZ2h0cm90YXRlIDIpIHhvciAoYSByaWdodHJvdGF0ZSAxMykgeG9yIChhIHJpZ2h0cm90YXRlIDIyKQogICAgICAgIG1haiA6PSAoYSBhbmQgYikgeG9yIChhIGFuZCBjKSB4b3IgKGIgYW5kIGMpCiAgICAgICAgdGVtcDIgOj0gUzAgKyBtYWoKIAogICAgICAgIGggOj0gZwogICAgICAgIGcgOj0gZgogICAgICAgIGYgOj0gZQogICAgICAgIGUgOj0gZCArIHRlbXAxCiAgICAgICAgZCA6PSBjCiAgICAgICAgYyA6PSBiCiAgICAgICAgYiA6PSBhCiAgICAgICAgYSA6PSB0ZW1wMSArIHRlbXAyCgogICAgQWRkIHRoZSBjb21wcmVzc2VkIGNodW5rIHRvIHRoZSBjdXJyZW50IGhhc2ggdmFsdWU6CiAgICBoMCA6PSBoMCArIGEKICAgIGgxIDo9IGgxICsgYgogICAgaDIgOj0gaDIgKyBjCiAgICBoMyA6PSBoMyArIGQKICAgIGg0IDo9IGg0ICsgZQogICAgaDUgOj0gaDUgKyBmCiAgICBoNiA6PSBoNiArIGcKICAgIGg3IDo9IGg3ICsgaAoKUHJvZHVjZSB0aGUgZmluYWwgaGFzaCB2YWx1ZSAoYmlnLWVuZGlhbik6CmRpZ2VzdCA6PSBoYXNoIDo9IGgwIGFwcGVuZCBoMSBhcHBlbmQgaDIgYXBwZW5kIGgzIGFwcGVuZCBoNCBhcHBlbmQgaDUgYXBwZW5kIGg2IGFwcGVuZCBoNw==

\ Use for tests.
: assert= ( a b ) over over <> if .s abort then drop drop ;

\ Return stack operations over lists
: >r.. ( x .. n -- )
  r> swap \ We need the return address.
  ( x ... ret n )
  begin dup 0 > while
    rot ( x1 x2 n x3 .. ) >r
    1 -
  repeat drop
  >r \ Push the return address back to the return stack
;
: swap.. ( x .. n -- x4 x1 x2 x3 .. )
  dup
  begin dup 0 > while
    >r >r
    swap
    r> r>
    rot
    >r
    1 -
  repeat drop
  begin dup 0 > while
    r>
    swap
    1 -
  repeat drop
;
1 2 3 4 3 swap..
3 assert=
2 assert=
1 assert=
4 assert=
1 2 3 4 0 swap..
4 assert=
3 assert=
2 assert=
1 assert=
depth 0 assert=

: rev.. ( x .. y n  -- y .. x )
  1 - >r
  begin r@ 0 > while
    r@ swap..
  r> 1 - >r
  repeat r> drop
;
1 2 3 4 4 rev..
1 assert=
2 assert=
3 assert=
4 assert=
depth 0 assert=

: assert=.. ( a b .. n )
  dup >r
  rev..
  r>
  dup
  begin dup 0 > while
   rot >r
   1 -
  repeat drop
  begin dup 0 > while
   swap r> assert=
   1 -
  repeat drop
;
1 2 3 4 4 rev..
4 3 2 1 4 assert=..
depth 0 assert=

: bits 8 / ;
: bytes 8 * ;

: 8! c! ;
: 8@ c@ ;

: 32dup ( a b -- a b a b )
  over over
;

: 2cc! ( n1 n2 addr -- )
  >r
  dup r@ 3 + 8!
  8 rshift r@ 2 + 8!
  dup r@ 1 + 8!
  8 rshift r@ 8!
  r>
  drop
;
: 4c! ( b1 b2 b3 b4 addr -- )
  >r
  r@ 3 + 8!
  r@ 2 + 8!
  r@ 1 + 8!
  r@ 8!
  r>
  drop
;
: 32@ ( addr -- n1 n2 )
  >r
  r@ 8@ 8 lshift
  r@ 1 + 8@ or
  r@ 2 + 8@ 8 lshift
  r@ 3 + 8@ or
  r>
  drop
;

create 16a 1 cells allot
create 16b 1 cells allot
create 16c 1 cells allot
create 16d 1 cells allot

: 32rr ( a b n -- )
  >r
  16b !
  16a !
  begin r@ 0 > while
    16a @ %0000000000000001 and if %1000000000000000 else %0000000000000000 then
    16b @ %0000000000000001 and if %1000000000000000 else %0000000000000000 then
    16a @ 1 rshift or 16a !
    16b @ 1 rshift or 16b !
    r> 1 - >r
  repeat
  r> drop
  16a @
  16b @
;
\ full rotation
12 34 4 bytes 32rr
12 34 2 assert=..
\ half rotation
$1122 $3344 2 bytes 32rr
$3344 $1122 2 assert=..
\ byte rotation
$1122 $3344 1 bytes 32rr
$4411 $2233 2 assert=..
\ no rotation
12 34 0 bytes 32rr
12 34 2 assert=..
$165D $FFEB 2 32rr
$C597 $7FFA 2 assert=..
\ stack clear
depth 0 assert=

: 32rs ( a b n -- )
  >r
  16b !
  16a !
  begin r@ 0 > while
    16a @ %0000000000000001 and if %1000000000000000 else %0000000000000000 then
    16b @ 1 rshift or 16b !
    16a @ 1 rshift 16a !
    r> 1 - >r
  repeat
  r> drop
  16a @ 16b @
;
\ full shift
12 34 4 bytes 32rs
00 00 2 assert=..
\ half shift
12 34 2 bytes 32rs
00 12 2 assert=..
\ no shift
12 34 0 bytes 32rs
12 34 2 assert=..
\ stack clear
depth 0 assert=

: 32xor ( a b c d -- e f )
  16d !
  16c !
  16b !
  16a !
  16a @
  16c @
  xor
  16b @
  16d @
  xor
;
\ all 1 bits
$4654 $5656 $FFFF $FFFF 32xor
$B9AB $A9A9 2 assert=..
\ all 0 bits
$4654 $5656 $0000 $0000 32xor
$4654 $5656 2 assert=..

depth 0 assert=

: 32and ( a b c d -- e f )
  16d !
  16c !
  16b !
  16a !
  16a @
  16c @
  and
  16b @
  16d @
  and
;
\ all 1 bits
$4654 $5656 $FFFF $FFFF 32and
$4654 $5656 2 assert=..
\ all 0 bits
$4654 $5656 $0000 $0000 32and
$0000 $0000 2 assert=..
depth 0 assert=

: 32not ( a b -- c d )
  $FFFF xor swap
  $FFFF xor swap
;
$0000 $0000 32not
$FFFF $FFFF 2 assert=..
$FFFF $FFFF 32not
$0000 $0000 2 assert=..

depth 0 assert=

: 16+>? ( a b -- n )
  65535 swap - > abs
;
: 16+ ( a b -- n )
  + 65536 mod
;

create carry 0 ,

: 32+ ( a b c d -- e f )
  >r 16c ! r>
  over over 16+>? carry !
  16+ >r
  16c @
  carry @ ( a c carry )
  over over 16+>? carry !
  16+ ( a k )
  over over 16+>? carry @ or carry !
  16+ ( f )
  r>
;
\ add two 0s
$0000 $0000 $0000 $0000 32+
$0000 $0000 2 assert=..
\ add two 1s
$0000 $0001 $0000 $0001 32+
$0000 $0002 2 assert=..
\ cause carry on first byte
$0000 $00FF $0000 $0001 32+
$0000 $0100 2 assert=..
\ carry over many
$00FF $FFFF $0000 $0001 32+
$0100 $0000 2 assert=..
\ overflow
$FFFF $FFFF $0000 $0001 32+
$0000 $0000 2 assert=..
\ carry caused by last
$00FF $80FF $0000 $7F01 32+
$0100 $0000 2 assert=..
\ carry and not
$00FF $0000 $0080 $0001 32+
$017F $0001 2 assert=..
\ random tests
$0263 $08A9 $13FA $F742 32+
$165D $FFEB 2 assert=..

depth 0 assert=

create K[]
$42 c, $8a c, $2f c, $98 c,
$71 c, $37 c, $44 c, $91 c,
$b5 c, $c0 c, $fb c, $cf c,
$e9 c, $b5 c, $db c, $a5 c,
$39 c, $56 c, $c2 c, $5b c,
$59 c, $f1 c, $11 c, $f1 c,
$92 c, $3f c, $82 c, $a4 c,
$ab c, $1c c, $5e c, $d5 c,
$d8 c, $07 c, $aa c, $98 c,
$12 c, $83 c, $5b c, $01 c,
$24 c, $31 c, $85 c, $be c,
$55 c, $0c c, $7d c, $c3 c,
$72 c, $be c, $5d c, $74 c,
$80 c, $de c, $b1 c, $fe c,
$9b c, $dc c, $06 c, $a7 c,
$c1 c, $9b c, $f1 c, $74 c,
$e4 c, $9b c, $69 c, $c1 c,
$ef c, $be c, $47 c, $86 c,
$0f c, $c1 c, $9d c, $c6 c,
$24 c, $0c c, $a1 c, $cc c,
$2d c, $e9 c, $2c c, $6f c,
$4a c, $74 c, $84 c, $aa c,
$5c c, $b0 c, $a9 c, $dc c,
$76 c, $f9 c, $88 c, $da c,
$98 c, $3e c, $51 c, $52 c,
$a8 c, $31 c, $c6 c, $6d c,
$b0 c, $03 c, $27 c, $c8 c,
$bf c, $59 c, $7f c, $c7 c,
$c6 c, $e0 c, $0b c, $f3 c,
$d5 c, $a7 c, $91 c, $47 c,
$06 c, $ca c, $63 c, $51 c,
$14 c, $29 c, $29 c, $67 c,
$27 c, $b7 c, $0a c, $85 c,
$2e c, $1b c, $21 c, $38 c,
$4d c, $2c c, $6d c, $fc c,
$53 c, $38 c, $0d c, $13 c,
$65 c, $0a c, $73 c, $54 c,
$76 c, $6a c, $0a c, $bb c,
$81 c, $c2 c, $c9 c, $2e c,
$92 c, $72 c, $2c c, $85 c,
$a2 c, $bf c, $e8 c, $a1 c,
$a8 c, $1a c, $66 c, $4b c,
$c2 c, $4b c, $8b c, $70 c,
$c7 c, $6c c, $51 c, $a3 c,
$d1 c, $92 c, $e8 c, $19 c,
$d6 c, $99 c, $06 c, $24 c,
$f4 c, $0e c, $35 c, $85 c,
$10 c, $6a c, $a0 c, $70 c,
$19 c, $a4 c, $c1 c, $16 c,
$1e c, $37 c, $6c c, $08 c,
$27 c, $48 c, $77 c, $4c c,
$34 c, $b0 c, $bc c, $b5 c,
$39 c, $1c c, $0c c, $b3 c,
$4e c, $d8 c, $aa c, $4a c,
$5b c, $9c c, $ca c, $4f c,
$68 c, $2e c, $6f c, $f3 c,
$74 c, $8f c, $82 c, $ee c,
$78 c, $a5 c, $63 c, $6f c,
$84 c, $c8 c, $78 c, $14 c,
$8c c, $c7 c, $02 c, $08 c,
$90 c, $be c, $ff c, $fa c,
$a4 c, $50 c, $6c c, $eb c,
$be c, $f9 c, $a3 c, $f7 c,
$c6 c, $71 c, $78 c, $f2 c,

\ How many of something you need to pad to the target b.
: pad_to ( a b - c ) swap over mod over - abs swap drop ;
3 512 pad_to  512 3 -  assert=
3 512 +  512 pad_to  512 3 -  assert=

s" hello world" swap drop ( a ) bytes 512 pad_to
512 11 bytes -
assert=

: K_to_pad ( n:bits -- m:bits )
  8 + 64 + 512 pad_to
;
s" hello world" swap drop bytes K_to_pad bits  44  assert=

\ Pre-processing (Padding):
\ begin with the original message of length L bits
\ append a single '1' bit
\ append K '0' bits, where K is the minimum number >= 0 such that (L + 1 + K + 64) is a multiple of 512
\ append L as a 64-bit big-endian integer, making the total post-processed length a multiple of 512 bits
\ such that the bits in the message are: <original message of length L> 1 <K zeros> <L as 64 bit integer> , (the number of bits will be a multiple of 512)
: new_512_bits_aligned ( addr n -- addr n )
  here >r
  \ Calculate the new pre-processed message size
  ( n )
  dup bytes  dup K_to_pad  +
  1 +
  7 +
  64 +
  bits here 1 cells allot !           \ data size (multiple of 512 bits)
  here 1 cells + here 1 cells allot ! \ data pointer

  dup >r                     \ message length to append at end
  dup bytes K_to_pad bits >r \ calculate K bits to pad with

  here swap ( addr here n )  dup allot  cmove \ copy original message

  %10000000 here  1 allot  8! \ append %10000000 byte
  here r>  dup allot  0 fill  \ append K 0 bits

  \ adjust to len cell size
  here 7  dup allot  0 fill   \ append message length as 64-bit big-endian integer
  r> bytes here  1 allot  8!  \ the actual length (8-bit)

  \ Assert our new message length matches what we calculated
  \ here r> - 64 assert= 
  r@ 1 cells + @
  r@ @
  r> drop
;
: s0 ( w-addr -- a b c d )
  15 32 bits * - >r
  r@ 32@ 7 32rr
  r@ 32@ 18 32rr
  32xor
  r@ 32@ 3 32rs
  32xor 
  r> drop
;
: s1 ( w-addr -- a b c d )
  2 32 bits * - >r
  r@ 32@ 17 32rr
  r@ 32@ 19 32rr 32xor
  r@ 32@ 10 32rs 32xor
  r> drop  
;

create w[] 64 32 bits * allot

: part1
16 begin dup 64 < while
  >r
  r@ 32 bits * w[] + s0
  r@ 16 - 32 bits * w[] + 32@ 32+
  r@ 32 bits * w[] + s1 32+
  r@ 7 - 32 bits * w[] + 32@ 32+
  r@ 32 bits * w[] + 2cc!
  r> 1 +  
repeat drop
;

create h0 32 bits allot
create h1 32 bits allot
create h2 32 bits allot
create h3 32 bits allot
create h4 32 bits allot
create h5 32 bits allot
create h6 32 bits allot
create h7 32 bits allot

create a 32 bits allot
create b 32 bits allot
create c 32 bits allot
create d 32 bits allot
create e 32 bits allot
create f 32 bits allot
create g 32 bits allot
create h 32 bits allot 

: z1
  e 32@ 6 32rr
  e 32@ 11 32rr 32xor
  e 32@ 25 32rr 32xor
;
: ch
  e 32@ f 32@ 32and
  e 32@ 32not g 32@ 32and
  32xor
;
: temp1 ( i -- a b c d )
  >r
  h 32@ z1 32+
  ch 32+
  K[] r@ 32 bits * + 32@ 32+
  w[] r@ 32 bits * + 32@ 32+
  r> drop
;

: z0
  a 32@ 2 32rr
  a 32@ 13 32rr 32xor
  a 32@ 22 32rr 32xor
;

: maj
  a 32@ b 32@ 32and
  a 32@ c 32@ 32and 32xor 
  b 32@ c 32@ 32and 32xor
;
: temp2 ( -- a b c d )
  z0 maj 32+
;
: part2
  h0 a 32 bits cmove
  h1 b 32 bits cmove
  h2 c 32 bits cmove
  h3 d 32 bits cmove
  h4 e 32 bits cmove
  h5 f 32 bits cmove
  h6 g 32 bits cmove
  h7 h 32 bits cmove
  0 begin dup 64 < while
    >r
    temp2
    r@ temp1
    32dup d 32@ 32+
    g h 32 bits cmove
    f g 32 bits cmove
    e f 32 bits cmove
    ( temp1 d 32+ ) e 2cc!
    c d 32 bits cmove
    b c 32 bits cmove
    a b 32 bits cmove
    ( temp2 temp1 ) 32+ a 2cc!
    r> 1 +
  repeat drop
;

create message 2 cells allot

: message.length message ;
: message.ptr message 1 cells + ;

\ process 512-bit chunks
: sha256 ( addr n -- 256 bits on stack )
  new_512_bits_aligned 
  message.length !
  message.ptr !

  $6a $09 $e6 $67 h0 4c!
  $bb $67 $ae $85 h1 4c!
  $3c $6e $f3 $72 h2 4c!
  $a5 $4f $f5 $3a h3 4c!
  $51 $0e $52 $7f h4 4c!
  $9b $05 $68 $8c h5 4c!
  $1f $83 $d9 $ab h6 4c!
  $5b $e0 $cd $19 h7 4c!

  0 begin dup message.length @ < while
    \ copy 16 32-bit words from message[i] to w[0..16]
    dup message.ptr @ +  w[] 16 32 bits *  cmove
    part1
    part2
    h0 32@ a 32@ 32+ h0 2cc!
    h1 32@ b 32@ 32+ h1 2cc!
    h2 32@ c 32@ 32+ h2 2cc!
    h3 32@ d 32@ 32+ h3 2cc!
    h4 32@ e 32@ 32+ h4 2cc!
    h5 32@ f 32@ 32+ h5 2cc!
    h6 32@ g 32@ 32+ h6 2cc!
    h7 32@ h 32@ 32+ h7 2cc!
    512 bits +
  repeat drop
;

s" hello world" sha256
h0 32@ h1 32@ h2 32@ h3 32@ h4 32@ h5 32@ h6 32@ h7 32@
hex .s