-
Notifications
You must be signed in to change notification settings - Fork 6
/
common.lisp
executable file
·202 lines (180 loc) · 7.22 KB
/
common.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
;;;; SHA3 --- Secure Hash Algorithm 3 (Keccak) Implementation
;;;;
;;;; Copyright (C) 2012 -- 2018 PMSF IT Consulting Pierre R. Mai.
;;;;
;;;; Permission is hereby granted, free of charge, to any person obtaining
;;;; a copy of this software and associated documentation files (the
;;;; "Software"), to deal in the Software without restriction, including
;;;; without limitation the rights to use, copy, modify, merge, publish,
;;;; distribute, sublicense, and/or sell copies of the Software, and to
;;;; permit persons to whom the Software is furnished to do so, subject to
;;;; the following conditions:
;;;;
;;;; The above copyright notice and this permission notice shall be
;;;; included in all copies or substantial portions of the Software.
;;;;
;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
;;;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR
;;;; OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
;;;; ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
;;;; OTHER DEALINGS IN THE SOFTWARE.
;;;;
;;;; Except as contained in this notice, the name of the author shall
;;;; not be used in advertising or otherwise to promote the sale, use or
;;;; other dealings in this Software without prior written authorization
;;;; from the author.
;;;;
;;;; $Id$
(cl:in-package #:sha3)
;;;; %File Description:
;;;;
;;;; This file contains common definitions and utility macros/functions
;;;; used in the specifically optimized implementations of keccak.
;;;;
;;;
;;; Optimization
;;;
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *optimize-declaration*
'(optimize (speed 3) (space 0) (safety 0) (debug 0))
"Global optimize declaration used for performance critical functions.
This can be changed prior to compiling the package for debugging/testing
purposes."))
;;;
;;; LOGXOR Reduction Hack for certain lisps
;;;
#+(or lispworks ccl)
(defun logxor (&rest args)
(apply #'cl:logxor args))
#+(or lispworks ccl)
(define-compiler-macro logxor (&whole form &rest args)
(labels ((binarify (list)
(if (rest list)
`(cl:logxor ,(car list) ,(binarify (rest list)))
(first list))))
(if (null args)
form
(binarify args))))
;;;
;;; Partial Evaluation Helpers
;;;
(defun trivial-macroexpand-all (form env)
"Trivial and very restricted code-walker used in partial evaluation macros.
Only supports atoms and function forms, no special forms."
(let ((real-form (macroexpand form env)))
(cond
((atom real-form)
real-form)
(t
(list* (car real-form)
(mapcar #'(lambda (x) (trivial-macroexpand-all x env))
(cdr real-form)))))))
(defmacro dotimes-unrolled ((var limit) &body body &environment env)
"Unroll the loop body at compile-time."
(loop for x from 0 below (eval (trivial-macroexpand-all limit env))
collect
`(symbol-macrolet ((,var ,x)) ,@body)
into forms
finally
(return `(progn ,@forms))))
;;;
;;; Keccak-f-1600 definitions
;;;
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant +keccak-state-columns+ 5
"Width of Keccak state in the x axis")
(defconstant +keccak-state-rows+ 5
"Width of Keccak state in the y axis")
(defconstant +keccak-state-lanes+ (* +keccak-state-columns+ +keccak-state-rows+)
"Total number of lanes in Keccak state")
(defconstant +keccak-1600-lane-width+ 64
"Lane width for Keccak-1600.")
(defconstant +keccak-1600-lane-byte-width+ (truncate +keccak-1600-lane-width+ 8)
"Lane width in bytes for Keccak-1600."))
(deftype keccak-1600-lane ()
"Type of a keccak lane for Keccak-1600."
`(unsigned-byte ,+keccak-1600-lane-width+))
;;;
;;; Keccak Constants
;;;
(defparameter *keccak-f-round-constants*
(make-array '(24) :element-type 'keccak-1600-lane
:initial-contents
#-sha3-fixed-constants
(loop with lfrstate = #x01
for i from 0 below 24
collect
(loop with const = 0
for j from 0 below 7
for bit-position = (1- (ash 1 j))
when (logbitp 0 lfrstate)
do (setq const (logxor const (ash 1 bit-position)))
do (setq lfrstate (if (logbitp 7 lfrstate)
(logxor (ldb (byte 8 0) (ash lfrstate 1))
#x71)
(ash lfrstate 1)))
finally (return const)))
#+sha3-fixed-constants
'(#x0000000000000001
#x0000000000008082
#x800000000000808a
#x8000000080008000
#x000000000000808b
#x0000000080000001
#x8000000080008081
#x8000000000008009
#x000000000000008a
#x0000000000000088
#x0000000080008009
#x000000008000000a
#x000000008000808b
#x800000000000008b
#x8000000000008089
#x8000000000008003
#x8000000000008002
#x8000000000000080
#x000000000000800a
#x800000008000000a
#x8000000080008081
#x8000000000008080
#x0000000080000001
#x8000000080008008))
"Keccak Round Constants")
(defparameter *keccak-f-rotate-offsets*
(make-array (list +keccak-state-columns+ +keccak-state-rows+)
:element-type '(unsigned-byte 8)
:initial-contents
'(( 0 36 3 41 18)
( 1 44 10 45 2)
(62 6 43 15 61)
(28 55 25 21 56)
(27 20 39 8 14)))
"Keccak Rotate Offsets")
(defmacro get-rotate-offset (x y &environment env)
(aref *keccak-f-rotate-offsets*
(eval (trivial-macroexpand-all x env))
(eval (trivial-macroexpand-all y env))))
;;;
;;; Message Padding for last block
;;;
(defun pad-message-to-width (message bit-width add-fips-202-suffix-p)
"Destructively pad the given message to the given bit-width according to
the Keccak 10*1 padding rules, optionally appending the FIPS 202/SHA-3
mandated 01 suffix first, and return the padded message."
(let* ((message-byte-length (length message))
(width-bytes (truncate bit-width 8))
(padded (make-array width-bytes
:element-type '(unsigned-byte 8))))
(replace padded message)
;; FIPS 202 SHA-3 mandates the appending of a 01 suffix prior to the
;; final Keccak padding so that the first byte following the message
;; will be #b00000101 instead of #b00000001 for raw Keccak.
(setf (aref padded message-byte-length) (if add-fips-202-suffix-p #x06 #x01))
(loop for index from (1+ message-byte-length) below width-bytes
do (setf (aref padded index) #x00)
finally
(setf (aref padded (1- width-bytes))
(logior #x80 (aref padded (1- width-bytes)))))
padded))