keccak-small.fs 3.28 KB
Newer Older
bernd's avatar
bernd committed
1 2
\ Keccak: Forth version by Bernd Paysan
\ derived from "readable keccak"
bernd's avatar
bernd committed
3 4 5 6
\ 19-Nov-11  Markku-Juhani O. Saarinen <mjos@iki.fi>
\ A baseline Keccak (3rd round) implementation.

24 Value keccak-rounds
7 8
5 cells constant kcol#
25 cells constant kkey#
bernd's avatar
bernd committed
9

10 11 12 13
: carray  Create  DOES> + c@ ;
: array   Create  DOES> swap cells + @ ;

array keccakf-rndc
bernd's avatar
bernd committed
14 15 16 17 18 19 20 21 22 23 24 25
$0000000000000001 , $0000000000008082 ,
$800000000000808a , $8000000080008000 ,
$000000000000808b , $0000000080000001 ,
$8000000080008081 , $8000000000008009 ,
$000000000000008a , $0000000000000088 ,
$0000000080008009 , $000000008000000a ,
$000000008000808b , $800000000000008b ,
$8000000000008089 , $8000000000008003 ,
$8000000000008002 , $8000000000000080 , 
$000000000000800a , $800000008000000a ,
$8000000080008081 , $8000000000008080 ,
$0000000080000001 , $8000000080008008 ,
bernd's avatar
bernd committed
26

27
carray keccakf-rotc
bernd's avatar
bernd committed
28 29 30 31
1 c,  3 c,  6 c,  10 c, 15 c, 21 c,
28 c, 36 c, 45 c, 55 c, 2 c,  14 c, 
27 c, 41 c, 56 c, 8 c,  25 c, 43 c,
62 c, 18 c, 39 c, 61 c, 20 c, 44 c,
bernd's avatar
bernd committed
32

33 34 35
: cc,  cells c, ;

carray keccakf-piln
bernd's avatar
bernd committed
36 37 38 39
10 cc, 7 cc,  11 cc, 17 cc, 18 cc, 3 cc,
5 cc,  16 cc, 8 cc,  21 cc, 24 cc, 4 cc,
15 cc, 23 cc, 19 cc, 13 cc, 12 cc, 2 cc,
20 cc, 14 cc, 22 cc, 9 cc,  6 cc,  1 cc,
40 41

carray mod5
bernd's avatar
bernd committed
42 43
0 cc, 1 cc, 2 cc, 3 cc, 4 cc,
0 cc, 1 cc, 2 cc, 3 cc, 4 cc,
bernd's avatar
bernd committed
44 45 46

\ update the state with given number of rounds

47 48
kcol# buffer: bc
kkey# buffer: st
bernd's avatar
bernd committed
49 50

: lrot1 ( x1 -- x2 )  dup 2* swap 0< - ;
bernd's avatar
bernd committed
51 52
: lrot ( x1 n -- x2 )  2dup lshift >r
    64 swap - rshift r> or ;
bernd's avatar
bernd committed
53 54 55 56
: xor! ( x addr -- )  dup >r @ xor r> ! ;

: theta1 ( -- )
    5 0 DO
bernd's avatar
bernd committed
57 58
	0 st i cells + kkey# bounds DO
	I @ xor  kcol# +LOOP
bernd's avatar
bernd committed
59 60 61 62 63
	bc i cells + !
    LOOP ;

: theta2 ( -- )
    5 0 DO
64 65
	bc I 4 + mod5 + @
	bc I 1 + mod5 + @ lrot1 xor
bernd's avatar
bernd committed
66 67
	st i cells + kkey# bounds DO
	dup I xor!  kcol# +LOOP
bernd's avatar
bernd committed
68 69 70 71 72 73
	drop
    LOOP ;

: rhopi ( -- )
    st cell+ @
    24 0 DO
74 75
	I keccakf-piln st + dup @
	rot I keccakf-rotc lrot
bernd's avatar
bernd committed
76 77 78 79
	rot !
    LOOP drop ;

: chi ( -- )
80 81
    st kkey# bounds DO
	I bc kcol# move
bernd's avatar
bernd committed
82
	5 0 DO
bernd's avatar
bernd committed
83 84
	    bc I 1+ mod5 + @ invert
	    bc I 2 + mod5 + @ and
bernd's avatar
bernd committed
85 86
	    J I cells + xor!
	LOOP
87
    kcol# +LOOP ;
bernd's avatar
bernd committed
88 89

: iota ( round -- )
90 91 92 93
    keccakf-rndc st xor! ;

: oneround ( round -- )
    theta1  theta2  rhopi  chi  iota ;
bernd's avatar
bernd committed
94 95

: keccakf ( -- )
96
    keccak-rounds 0 ?DO  I oneround  LOOP ;
bernd's avatar
bernd committed
97

98
: st0 ( -- )  st kkey# erase ;
bernd's avatar
bernd committed
99 100 101

: >sponge ( addr u -- )
    \ fill in sponge function
bernd's avatar
bernd committed
102 103 104
    st swap bounds DO
	dup @ I xor!  cell+
    cell +LOOP  drop ;
bernd's avatar
bernd committed
105

106 107
: >duplex ( addr u -- )
    \ duplex in sponge function: encrypt
bernd's avatar
bernd committed
108 109 110
    st swap bounds DO
	dup @ I @ xor dup I ! over !  cell+
    cell +LOOP drop ;
111 112 113

: duplex> ( addr u -- )
    \ duplex out sponge function: decrypt
bernd's avatar
bernd committed
114 115 116
    st swap bounds DO
	dup @ I @ xor over @ I ! over !  cell+
    cell +LOOP drop ;
117 118 119

\ for test, we pad with Keccak's padding function

bernd's avatar
bernd committed
120 121 122 123 124 125 126
144 buffer: kpad

: padded>sponge ( addr u1 u2 -- )  >r
    \ pad last round
    kpad r@ erase  tuck kpad swap move
    kpad + 1 swap c!
    kpad r@ + 1- dup c@ $80 or swap c!
127 128
    kpad r> >sponge  ;

bernd's avatar
bernd committed
129
0 [IF]    ." Test "
130 131 132 133 134 135 136 137 138
    \ tests - we check only for the first 64 bit
    \ but repeat keccakf 4 times. The input pattern is
    \ from an official Keccak test, the output as well.
    st0 s" SX{9" $80 padded>sponge 0 st 4 + c!
    keccakf st @ $466624B803BF072F =
    keccakf st @ $993340D7F9153F02 = and
    keccakf st @ $6EAAAE36BE8E36D3 = and
    keccakf st @ $1B4AEC08DA6A8BA6 = and
    [IF] ." succeeded" [ELSE] ." failed" [THEN] cr
bernd's avatar
bernd committed
139
[THEN]