OSCL/sha3
2
0
Fork 0
mirror of https://github.com/pmai/sha3.git synced 2025-12-21 15:24:28 +01:00
Code Issues Packages Projects Releases Wiki Activity

Add initial version of project.

Browse Source
This commit is contained in:
Pierre R. Mai
2012-11-02 20:47:39 +01:00
commit 618df43b2d
11 changed files with 1899 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored Normal file
View File

@ -0,0 +1,2 @@
/*.lisp ident
/*.asd ident

12
.gitignore vendored Normal file
View File

@ -0,0 +1,12 @@
# FASLs
*.fas
*.fasl
*.ofasl
*.nfasl
*.xfasl
*.dx32fsl
*.dx64fsl
*.abcl
*.sse2f
# Backup files
*~

25
COPYING Normal file
View File

@ -0,0 +1,25 @@
Copyright (C) 2012 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.

96
README Normal file
View File

@ -0,0 +1,96 @@
This library is an implementation of the Secure Hash Algorithm 3
(SHA-3), also known as Keccak. The implementation is constrained to
messages with an integral number of octets, i.e. sub-byte length
messages are not supported.
The implementation should be portable across nearly all ANSI compliant
CL with specialized implementations tuned for implementations that
offer unboxed 64bit arithmetic, unboxed 32bit arithmetic and for
implementations with efficient fixnum arithmetic (requiring fixnums
that can represent (unsigned-byte 16)). Especially the 64 and 32bit
implementations have been mostly optimized for SBCL and CMU CL. For
those implementations, digests with a 1024 bit-rate (and 288 bit
digest output) can be generated in between 30 (64bit SBCL) to around
100 (32bit CMU CL) cycles/byte on an i7-640M; whereas optimized
C/assembler implementations reach around 12 to 50 cycles/byte on 64/32
bit Intel hardware. The reason for the discrepancy probably lies in
missing peephole and dependency optimizations in the SBCL/CMU CL
compiler backend.
The mid-level interfaces to the digest routines are the functions
- sha3:sha3-init &key output-bit-length bit-rate
Create and return a new SHA-3 state. If `output-bit-length' is
specified then the state will run at the bit rate specified for the
given output bit length. If `output-bit-length' is unspecified,
`bit-rate' can be specified to select a suitable bit rate. If both
are left unspecified then a default bit rate of 1024 bits is
selected, which is suitable for arbitrary output bit lengths of up
to 288 bits.
- sha3:sha3-copy state
Return an independent copy of the SHA-3 state `state'.
- sha3:sha3-state-p state
Test whether a given object is a SHA-3 state, i.e. is an instance of
the class sha3:sha3-state.
- sha3:sha3-update state vector &key (start 0) (end (length vector))
Update the given SHA-3 state `state' from `vector', which must be a
simple-array with element-type (unsigned-byte 8), bounded by `start'
and `end', which must be numeric bounding-indices.
- sha3:sha3-final state &key output-bit-length
If the given SHA-3 state `state' has not already been finalized,
finalize it by processing any remaining input in its buffer, with
suitable padding as specified by the SHA-3 standard. Returns the
message digest as a simple-array of (unsigned-byte 8). The length
of the returned digest is determined either by the output bit length
or bit rate specified on state creation, or for the special case of
default parameters being used, by the optional keyword argument
`output-bit-length'. If the state has previously been finalized,
the function will return the digest again.
For convenience the following high-level functions produce digests in
one step from 1d simple-arrays and streams with element-type
(unsigned-byte 8), as well as files:
- sha3:sha3-digest-vector vector &key (start 0) end (output-bit-length 512)
Calculate an SHA-3 message-digest of data in `vector', which should
be a 1d simple-array with element type (unsigned-byte 8), bounded by
`start' and `end'. The bit length of the message digest produced is
controlled by `output-bit-length', which can take on the values 224,
256, 288, 384 and 512, which is the default value.
- sha3:sha3-digest-stream stream &key (output-bit-length 512)
Calculate an SHA-3 message-digest of data read from `stream', which
should be a stream with element type (unsigned-byte 8). The bit
length of the message digest produced is controlled by
`output-bit-length', which can take on the values 224, 256, 288, 384
and 512, which is the default value.
- sha3:sha3-digest-file pathname &key (output-bit-length 512)
Calculate an SHA-3 message-digest of the file specified by
`pathname'. The bit length of the message digest produced is
controlled by `output-bit-length', which can take on the values 224,
256, 288, 384 and 512, which is the default value.
Note that in order to generate a message digest of a string it will
have to be converted to a simple-array with element-type
(unsigned-byte 8) in the proper output-encoding. This will have to
rely on implementation-specific functions and is not part of the SHA3
library.
The implementation is licensed under the MIT-style license contained
in the file COPYING and the header of each source file.
Please direct any feedback to pmai@pmsf.de. A git repository of this
library is available under git://github.com/pmai/sha3.git

196
common.lisp Normal file
View File

@ -0,0 +1,196 @@
;;;; SHA3 --- Secure Hash Algorithm 3 (Keccak) Implementation
;;;;
;;;; Copyright (C) 2012 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)
"Destructively pad the given message to the given bit-width according to
Keccak padding rules and return the padded message."
(let ((message-byte-length (length message))
(width-bytes (truncate bit-width 8)))
(setq message (adjust-array message (list width-bytes)))
(setf (aref message message-byte-length) #x01)
(loop for index from (1+ message-byte-length) below width-bytes
do (setf (aref message index) #x00)
finally
(setf (aref message (1- width-bytes))
(logior #x80 (aref message (1- width-bytes))))))
message)

510
keccak-16bit.lisp Normal file
View File

@ -0,0 +1,510 @@
;;;; SHA3 --- Secure Hash Algorithm 3 (Keccak) Implementation
;;;;
;;;; Copyright (C) 2012 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 an implementation of Keccak 1600 tuned to
;;;; implementations that support efficient arithmetic on fixnums
;;;; which are assumed to be able to represent (unsigned-byte 16)
;;;; numbers. NOTE that the ANSI CL standard only guarantees
;;;; (signed-byte 16), which would also be sufficient but would
;;;; complicate the code somewhat. Since none of the currently useful
;;;; implementations have quite so limited fixnums, the assumption
;;;; should hold sufficiently well.
;;;;
;;;; Implementation Choices:
;;;;
;;;; This is a fairly straightforward implementation of Keccak 1600.
;;;; It employs a bit of loop unrolling at compile-time, and splits
;;;; the 64bit Keccak 1600 lanes into four 16 bit words with bit
;;;; interleaving. It might make sense to test if not using bit
;;;; interleaving makes much of a difference, since we do not use
;;;; hardware rotate instructions in any case.
;;;;
#+cmu
(eval-when (:compile-toplevel)
(defparameter *old-expansion-limit* ext:*inline-expansion-limit*)
(setq ext:*inline-expansion-limit* (max ext:*inline-expansion-limit* 1000)))
#+sbcl
(eval-when (:compile-toplevel)
(defparameter *old-expansion-limit* sb-ext:*inline-expansion-limit*)
(setq sb-ext:*inline-expansion-limit* (max sb-ext:*inline-expansion-limit* 1000)))
;;;
;;; Additional Keccak-f-1600 definitions
;;;
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant +keccak-state-splits+ 4
"Number of lane splits")
(defconstant +keccak-state-parts+ (* +keccak-state-lanes+ +keccak-state-splits+)
"Total number of partial lanes in Keccak state")
(defconstant +keccak-1600-part-width+ 16
"Partial lane width for Keccak-1600.")
(defconstant +keccak-1600-part-byte-width+ (truncate +keccak-1600-part-width+ 8)
"Partial lane width in bytes for Keccak-1600."))
(deftype keccak-1600-part ()
"Type of a partial keccak lane for Keccak-1600."
'fixnum)
(deftype keccak-1600-state ()
"Type of a keccak working state object for Keccak-1600."
`(simple-array keccak-1600-part
(,+keccak-state-parts+)))
(declaim (inline make-keccak-1600-state)
(ftype (function () keccak-1600-state) make-keccak-1600-state))
(defun make-keccak-1600-state ()
(declare #.*optimize-declaration*)
(make-array '(#.+keccak-state-parts+)
:element-type 'keccak-1600-part
:initial-element 0))
;;;
;;; De/Interleaving of bytes
;;;
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun make-interleave-table ()
(loop with result = (make-array 256 :element-type '(unsigned-byte 8))
for value from 0 to 255
for entry = 0
do
(loop for bit-index from 0 to 7
do
(setf (ldb (byte 1 (+ (truncate bit-index 4) (* 2 (mod bit-index 4))))
entry)
(ldb (byte 1 bit-index) value)))
(setf (aref result value) entry)
finally
(return result)))
(defun make-deinterleave-table ()
(loop with result = (make-array 256 :element-type '(unsigned-byte 8))
for value from 0 to 255
for entry = 0
do
(loop for bit-index from 0 to 7
do
(setf (ldb (byte 1 (+ (truncate bit-index 4) (* 2 (mod bit-index 4))))
entry)
(ldb (byte 1 bit-index) value)))
(setf (aref result entry) value)
finally
(return result))))
;;;
;;; Transforming linear input/output to state array
;;;
(defun keccak-state-merge-input (state bit-rate input start)
(declare (type keccak-1600-state state) (type (integer 0 1600) bit-rate)
(type (simple-array (unsigned-byte 8) (*)) input)
(type fixnum start)
#.*optimize-declaration*)
(let ((rate-bytes (truncate bit-rate 8))
(interleave-lookup (load-time-value (make-interleave-table) t)))
(declare (type (integer 0 200) rate-bytes)
(type (simple-array (unsigned-byte 8) (256)) interleave-lookup))
(dotimes (y #.+keccak-state-rows+)
(declare (fixnum y))
(dotimes (x #.+keccak-state-columns+)
(declare (fixnum x))
(let* ((element (+ (* y +keccak-state-columns+) x))
(part (* element +keccak-state-splits+))
(offset (* element +keccak-1600-lane-byte-width+))
(index (the fixnum (+ start offset))))
(declare (fixnum element part offset index))
(when (>= offset rate-bytes)
(return-from keccak-state-merge-input))
(setf (aref state part)
(logxor
(aref state part)
.
#.(loop for byte-index from 0
below +keccak-1600-lane-byte-width+
collect
`(the keccak-1600-part
(ash (ldb (byte 2 0)
(aref interleave-lookup
(aref input (+ index ,byte-index))))
,(* byte-index 2)))))
(aref state (1+ part))
(logxor
(aref state (1+ part))
.
#.(loop for byte-index from 0
below +keccak-1600-lane-byte-width+
collect
`(the keccak-1600-part
(ash (ldb (byte 2 2)
(aref interleave-lookup
(aref input (+ index ,byte-index))))
,(* byte-index 2)))))
(aref state (+ part 2))
(logxor
(aref state (+ part 2))
.
#.(loop for byte-index from 0
below +keccak-1600-lane-byte-width+
collect
`(the keccak-1600-part
(ash (ldb (byte 2 4)
(aref interleave-lookup
(aref input (+ index ,byte-index))))
,(* byte-index 2)))))
(aref state (+ part 3))
(logxor
(aref state (+ part 3))
.
#.(loop for byte-index from 0
below +keccak-1600-lane-byte-width+
collect
`(the keccak-1600-part
(ash (ldb (byte 2 6)
(aref interleave-lookup
(aref input (+ index ,byte-index))))
,(* byte-index 2)))))))))))
(defun keccak-state-extract-output (state output-bits)
(let* ((output-bytes (truncate output-bits 8))
(digest (make-array (list output-bytes) :element-type '(unsigned-byte 8)))
(deinterleave-lookup (load-time-value (make-deinterleave-table) t)))
(dotimes (x +keccak-state-columns+)
(dotimes (y +keccak-state-rows+)
(let* ((element (+ (* y +keccak-state-columns+) x))
(part (* element +keccak-state-splits+))
(offset (* element +keccak-1600-lane-byte-width+)))
(unless (>= offset output-bytes)
(loop with value-even = (aref state part)
with value-odd1 = (aref state (1+ part))
with value-odd2 = (aref state (+ part 2))
with value-odd3 = (aref state (+ part 3))
for index from offset
below (min (+ offset +keccak-1600-lane-byte-width+) output-bytes)
do
(setf (aref digest index)
(aref deinterleave-lookup
(dpb (ldb (byte 2 0) value-odd3) (byte 2 6)
(dpb (ldb (byte 2 0) value-odd2) (byte 2 4)
(dpb (ldb (byte 2 0) value-odd1) (byte 2 2)
(ldb (byte 2 0) value-even)))))
value-even (ash value-even -2)
value-odd1 (ash value-odd1 -2)
value-odd2 (ash value-odd2 -2)
value-odd3 (ash value-odd3 -2)))))))
digest))
;;;
;;; Keccak Constants
;;;
(declaim (inline keccak-f-round-constant)
(ftype (function ((integer 0 23) (integer 0 3)) keccak-1600-part)
keccak-f-round-constant))
(defun keccak-f-round-constant (i p)
(declare (type (integer 0 23) i) (type (integer 0 3) p)
#.*optimize-declaration*)
(let ((constants
(load-time-value
(make-array #.(* 24 +keccak-state-splits+)
:element-type 'keccak-1600-part
:initial-contents
(loop with itable = (make-interleave-table)
for rc across *keccak-f-round-constants*
nconc
(loop with even = 0
with odd1 = 0
with odd2 = 0
with odd3 = 0
for bit-offset from 0 below 64 by 8
for value = (aref itable
(ldb (byte 8 bit-offset) rc))
do
(setf (ldb (byte 2 (truncate bit-offset 4)) even)
(ldb (byte 2 0) value)
(ldb (byte 2 (truncate bit-offset 4)) odd1)
(ldb (byte 2 2) value)
(ldb (byte 2 (truncate bit-offset 4)) odd2)
(ldb (byte 2 4) value)
(ldb (byte 2 (truncate bit-offset 4)) odd3)
(ldb (byte 2 6) value))
finally
(return (list even odd1 odd2 odd3)))))
t)))
(declare (type (simple-array keccak-1600-part (#.(* 24 +keccak-state-splits+)))
constants))
(aref constants (+ (* i +keccak-state-splits+) p))))
;;;
;;; Helper: Rotation
;;;
(declaim (inline keccak-f-rot-part)
(ftype (function (keccak-1600-part (integer 0 16)) keccak-1600-part)
keccak-f-rot-part))
(defun keccak-f-rot-part (value offset)
(declare (type (integer 0 16) offset)
(type keccak-1600-part value)
#.*optimize-declaration*
#+sbcl
(sb-ext:muffle-conditions sb-ext:code-deletion-note))
#+(and xxx sbcl)
(if (or (zerop offset) (= offset 16))
value
(sb-rotate-byte:rotate-byte offset (byte 16 0) value))
#-(and xxx sbcl)
(if (or (zerop offset) (= offset 16))
value
(logior (the keccak-1600-part (ash (ldb (byte (- 16 offset) 0) value) offset))
(ash value (- offset 16)))))
(declaim (inline keccak-f-rot)
(ftype (function (keccak-1600-part keccak-1600-part
keccak-1600-part keccak-1600-part (integer 0 63))
(values keccak-1600-part keccak-1600-part
keccak-1600-part keccak-1600-part))
keccak-f-rot))
(defun keccak-f-rot (value-even value-odd1 value-odd2 value-odd3 offset)
(declare (type (integer 0 63) offset)
(type keccak-1600-part value-even value-odd1 value-odd2 value-odd3)
#.*optimize-declaration*
#+sbcl
(sb-ext:muffle-conditions sb-ext:code-deletion-note))
(case (mod offset 4)
(0
(values
(keccak-f-rot-part value-even (truncate offset 4))
(keccak-f-rot-part value-odd1 (truncate offset 4))
(keccak-f-rot-part value-odd2 (truncate offset 4))
(keccak-f-rot-part value-odd3 (truncate offset 4))))
(1
(values
(keccak-f-rot-part value-odd3 (1+ (truncate offset 4)))
(keccak-f-rot-part value-even (truncate offset 4))
(keccak-f-rot-part value-odd1 (truncate offset 4))
(keccak-f-rot-part value-odd2 (truncate offset 4))))
(2
(values
(keccak-f-rot-part value-odd2 (1+ (truncate offset 4)))
(keccak-f-rot-part value-odd3 (1+ (truncate offset 4)))
(keccak-f-rot-part value-even (truncate offset 4))
(keccak-f-rot-part value-odd1 (truncate offset 4))))
(3
(values
(keccak-f-rot-part value-odd1 (1+ (truncate offset 4)))
(keccak-f-rot-part value-odd2 (1+ (truncate offset 4)))
(keccak-f-rot-part value-odd3 (1+ (truncate offset 4)))
(keccak-f-rot-part value-even (truncate offset 4))))))
;;;
;;; State and Temporary Variable Accessors
;;;
(defmacro with-state-accessors ((&rest states) &body body)
"Bind the contents of the state(s) array(s) to local variables, and save
the content on normal form exit."
(let ((bindings nil) (mappings nil) (save-forms nil))
(loop for state in states
for map = (make-array '(#.+keccak-state-columns+ #.+keccak-state-rows+
#.+keccak-state-splits+))
do
(dotimes (y +keccak-state-rows+)
(dotimes (x +keccak-state-columns+)
(dotimes (p +keccak-state-splits+)
(let ((sym (make-symbol (format nil "~A-~D-~D-~D" state x y p))))
(setf (aref map x y p) sym)
(push `(,sym (aref ,state ,(+ p (* (+ x (* y +keccak-state-columns+))
+keccak-state-splits+))))
bindings)
(push `(setf (aref ,state ,(+ p (* (+ x (* y +keccak-state-columns+))
+keccak-state-splits+)))
,sym)
save-forms)))))
(push (cons state map) mappings))
`(let (,@bindings)
(declare (ignorable ,@(mapcar #'car bindings))
(type keccak-1600-part ,@(mapcar #'car bindings)))
(macrolet ((state-aref (state x y p &environment env)
(let ((entry (assoc state ',mappings)))
(unless entry (error "Strange: ~S!" state))
(aref (cdr entry)
(eval (trivial-macroexpand-all x env))
(eval (trivial-macroexpand-all y env))
(eval (trivial-macroexpand-all p env))))))
(multiple-value-prog1 (progn ,@body)
,@save-forms)))))
(defmacro with-temp-state ((&rest temps) &body body)
"Bind local variables for each temporary state."
(let ((bindings nil) (mappings nil))
(loop for temp in temps
for map = (make-array '(#.+keccak-state-columns+ #.+keccak-state-rows+
#.+keccak-state-splits+))
do
(dotimes (y +keccak-state-rows+)
(dotimes (x +keccak-state-columns+)
(dotimes (p +keccak-state-splits+)
(let ((sym (make-symbol (format nil "~A-~D-~D-~D" temp x y p))))
(setf (aref map x y p) sym)
(push `(,sym 0) bindings)))))
(push (cons temp map) mappings))
`(let (,@bindings)
(declare (ignorable ,@(mapcar #'car bindings))
(type keccak-1600-part ,@(mapcar #'car bindings)))
(macrolet ((temp-state-aref (temp x y p &environment env)
(let ((entry (assoc temp ',mappings)))
(unless entry (error "Strange: ~S!" temp))
(aref (cdr entry)
(eval (trivial-macroexpand-all x env))
(eval (trivial-macroexpand-all y env))
(eval (trivial-macroexpand-all p env))))))
,@body))))
(defmacro with-temp-rows ((&rest rows) &body body)
"Bind local variables for each temporary row."
(let ((bindings nil) (mappings nil))
(loop for row in rows
for map = (make-array '(#.+keccak-state-columns+ #.+keccak-state-splits+))
do
(dotimes (x +keccak-state-columns+)
(dotimes (p +keccak-state-splits+)
(let ((sym (make-symbol (format nil "~A-~D-~D" row x p))))
(setf (aref map x p) sym)
(push `(,sym 0) bindings))))
(push (cons row map) mappings))
`(let (,@bindings)
(declare (ignorable ,@(mapcar #'car bindings))
(type keccak-1600-part ,@(mapcar #'car bindings)))
(macrolet ((temp-row-aref (row x p &environment env)
(let ((entry (assoc row ',mappings)))
(unless entry (error "Strange: ~S!" row))
(aref (cdr entry)
(eval (trivial-macroexpand-all x env))
(eval (trivial-macroexpand-all p env))))))
,@body))))
;;;
;;; Keccak-f permutation
;;;
(declaim (ftype (function (keccak-1600-state) keccak-1600-state) keccak-f))
(defun keccak-f (a)
(declare (type keccak-1600-state a)
#.*optimize-declaration*)
(with-state-accessors (a)
(with-temp-state (b)
(with-temp-rows (c d)
(dotimes (i #.(+ 12 (* 2 (truncate (log +keccak-1600-lane-width+ 2)))))
(dotimes-unrolled (x +keccak-state-columns+)
(dotimes-unrolled (p +keccak-state-splits+)
(setf (temp-row-aref c x p)
(logxor (state-aref a x 0 p)
(state-aref a x 1 p)
(state-aref a x 2 p)
(state-aref a x 3 p)
(state-aref a x 4 p)))))
(dotimes-unrolled (x +keccak-state-columns+)
(setf (temp-row-aref d x 0)
(logxor (temp-row-aref c (mod (+ +keccak-state-columns+ (1- x))
+keccak-state-columns+)
0)
(keccak-f-rot-part
(temp-row-aref c (mod (1+ x) +keccak-state-columns+) 3)
1))
(temp-row-aref d x 1)
(logxor (temp-row-aref c (mod (+ +keccak-state-columns+ (1- x))
+keccak-state-columns+)
1)
(temp-row-aref c (mod (1+ x) +keccak-state-columns+) 0))
(temp-row-aref d x 2)
(logxor (temp-row-aref c (mod (+ +keccak-state-columns+ (1- x))
+keccak-state-columns+)
2)
(temp-row-aref c (mod (1+ x) +keccak-state-columns+) 1))
(temp-row-aref d x 3)
(logxor (temp-row-aref c (mod (+ +keccak-state-columns+ (1- x))
+keccak-state-columns+)
3)
(temp-row-aref c (mod (1+ x) +keccak-state-columns+) 2))))
(dotimes-unrolled (x +keccak-state-columns+)
(dotimes-unrolled (y +keccak-state-rows+)
(dotimes-unrolled (p +keccak-state-splits+)
(setf (state-aref a x y p)
(logxor (state-aref a x y p) (temp-row-aref d x p))))))
(dotimes-unrolled (x +keccak-state-columns+)
(dotimes-unrolled (y +keccak-state-rows+)
(setf (values
(temp-state-aref b y
(mod (+ (* 2 x) (* 3 y)) +keccak-state-rows+)
0)
(temp-state-aref b y
(mod (+ (* 2 x) (* 3 y)) +keccak-state-rows+)
1)
(temp-state-aref b y
(mod (+ (* 2 x) (* 3 y)) +keccak-state-rows+)
2)
(temp-state-aref b y
(mod (+ (* 2 x) (* 3 y)) +keccak-state-rows+)
3))
(keccak-f-rot (state-aref a x y 0) (state-aref a x y 1)
(state-aref a x y 2) (state-aref a x y 3)
(get-rotate-offset x y)))))
(dotimes-unrolled (x +keccak-state-columns+)
(dotimes-unrolled (y +keccak-state-rows+)
(dotimes-unrolled (p +keccak-state-splits+)
(setf (state-aref a x y p)
(logxor (temp-state-aref b x y p)
(logandc1
(temp-state-aref b (mod (1+ x) +keccak-state-columns+)
y p)
(temp-state-aref b (mod (+ x 2) +keccak-state-columns+)
y p)))))))
(dotimes-unrolled (p +keccak-state-splits+)
(setf (state-aref a 0 0 p)
(logxor (state-aref a 0 0 p)
(keccak-f-round-constant i p)))))))
a))
#+cmu
(eval-when (:compile-toplevel)
(setq ext:*inline-expansion-limit* *old-expansion-limit*))
#+sbcl
(eval-when (:compile-toplevel)
(setq sb-ext:*inline-expansion-limit* *old-expansion-limit*))

431
keccak-32bit.lisp Normal file
View File

@ -0,0 +1,431 @@
;;;; SHA3 --- Secure Hash Algorithm 3 (Keccak) Implementation
;;;;
;;;; Copyright (C) 2012 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 an implementation of Keccak 1600 tuned to
;;;; implementations that support unboxed arithmetic on (unsigned-byte
;;;; 32).
;;;;
;;;; Implementation Choices:
;;;;
;;;; This is a fairly straightforward implementation of Keccak 1600,
;;;; mostly tuned to sbcl for x86, and to some degree to cmucl for
;;;; x86. It employs a bit of loop unrolling at compile-time, and
;;;; splits the 64bit Keccak 1600 lanes into two 32 bit words with bit
;;;; interleaving, thereby being able to still use hardware rotate
;;;; support where possible. More advanced implementation techniques
;;;; like plane-per-plane processing, lane complementing and early
;;;; parity (c.f. the Keccak implementation overview) did not seem to
;;;; work well with SBCL's compiler, resulting in slower, less
;;;; readable code.
;;;;
#+cmu
(eval-when (:compile-toplevel)
(defparameter *old-expansion-limit* ext:*inline-expansion-limit*)
(setq ext:*inline-expansion-limit* (max ext:*inline-expansion-limit* 1000)))
;;;
;;; Additional Keccak-f-1600 definitions
;;;
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant +keccak-state-splits+ 2
"Number of lane splits")
(defconstant +keccak-state-parts+ (* +keccak-state-lanes+ +keccak-state-splits+)
"Total number of partial lanes in Keccak state")
(defconstant +keccak-1600-part-width+ 32
"Partial lane width for Keccak-1600.")
(defconstant +keccak-1600-part-byte-width+ (truncate +keccak-1600-part-width+ 8)
"Partial lane width in bytes for Keccak-1600."))
(deftype keccak-1600-part ()
"Type of a partial keccak lane for Keccak-1600."
`(unsigned-byte ,+keccak-1600-part-width+))
(deftype keccak-1600-state ()
"Type of a keccak working state object for Keccak-1600."
`(simple-array keccak-1600-part
(,+keccak-state-parts+)))
(declaim (inline make-keccak-1600-state)
(ftype (function () keccak-1600-state) make-keccak-1600-state))
(defun make-keccak-1600-state ()
(declare #.*optimize-declaration*)
(make-array '(#.+keccak-state-parts+)
:element-type 'keccak-1600-part
:initial-element 0))
;;;
;;; De/Interleaving of bytes
;;;
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun make-interleave-table ()
(loop with result = (make-array 256 :element-type '(unsigned-byte 8))
for value from 0 to 255
for entry = 0
do
(loop for bit-index from 0 to 7
do
(setf (ldb (byte 1 (+ (truncate bit-index 2) (* 4 (mod bit-index 2))))
entry)
(ldb (byte 1 bit-index) value)))
(setf (aref result value) entry)
finally
(return result)))
(defun make-deinterleave-table ()
(loop with result = (make-array 256 :element-type '(unsigned-byte 8))
for value from 0 to 255
for entry = 0
do
(loop for bit-index from 0 to 7
do
(setf (ldb (byte 1 (+ (truncate bit-index 2) (* 4 (mod bit-index 2))))
entry)
(ldb (byte 1 bit-index) value)))
(setf (aref result entry) value)
finally
(return result))))
;;;
;;; Transforming linear input/output to state array
;;;
(defun keccak-state-merge-input (state bit-rate input start)
(declare (type keccak-1600-state state) (type (integer 0 1600) bit-rate)
(type (simple-array (unsigned-byte 8) (*)) input)
(type fixnum start)
#.*optimize-declaration*)
(let ((rate-bytes (truncate bit-rate 8))
(interleave-lookup (load-time-value (make-interleave-table) t)))
(declare (type (integer 0 200) rate-bytes)
(type (simple-array (unsigned-byte 8) (256)) interleave-lookup))
(dotimes (y #.+keccak-state-rows+)
(declare (fixnum y))
(dotimes (x #.+keccak-state-columns+)
(declare (fixnum x))
(let* ((element (+ (* y +keccak-state-columns+) x))
(part (* element +keccak-state-splits+))
(offset (* element +keccak-1600-lane-byte-width+))
(index (the fixnum (+ start offset))))
(declare (fixnum element part offset index))
(when (>= offset rate-bytes)
(return-from keccak-state-merge-input))
(setf (aref state part)
(logxor
(aref state part)
.
#.(loop for byte-index from 0
below +keccak-1600-lane-byte-width+
collect
`(the keccak-1600-part
(ash (ldb (byte 4 0)
(aref interleave-lookup
(aref input (+ index ,byte-index))))
,(* byte-index 4)))))
(aref state (1+ part))
(logxor
(aref state (1+ part))
.
#.(loop for byte-index from 0
below +keccak-1600-lane-byte-width+
collect
`(the keccak-1600-part
(ash (ldb (byte 4 4)
(aref interleave-lookup
(aref input (+ index ,byte-index))))
,(* byte-index 4)))))))))))
(defun keccak-state-extract-output (state output-bits)
(let* ((output-bytes (truncate output-bits 8))
(digest (make-array (list output-bytes) :element-type '(unsigned-byte 8)))
(deinterleave-lookup (load-time-value (make-deinterleave-table) t)))
(dotimes (x +keccak-state-columns+)
(dotimes (y +keccak-state-rows+)
(let* ((element (+ (* y +keccak-state-columns+) x))
(part (* element +keccak-state-splits+))
(offset (* element +keccak-1600-lane-byte-width+)))
(unless (>= offset output-bytes)
(loop with value-even = (aref state part)
with value-odd = (aref state (1+ part))
for index from offset
below (min (+ offset +keccak-1600-lane-byte-width+) output-bytes)
do
(setf (aref digest index)
(aref deinterleave-lookup (dpb (ldb (byte 4 0) value-odd)
(byte 4 4)
(ldb (byte 4 0) value-even)))
value-even (ash value-even -4)
value-odd (ash value-odd -4)))))))
digest))
;;;
;;; Keccak Constants
;;;
(declaim (inline keccak-f-round-constant)
(ftype (function ((integer 0 23) (integer 0 1)) keccak-1600-part)
keccak-f-round-constant))
(defun keccak-f-round-constant (i p)
(declare (type (integer 0 23) i) (type (integer 0 1) p)
#.*optimize-declaration*)
(let ((constants
(load-time-value
(make-array #.(* 24 +keccak-state-splits+)
:element-type 'keccak-1600-part
:initial-contents
(loop with itable = (make-interleave-table)
for rc across *keccak-f-round-constants*
nconc
(loop with even = 0
with odd = 0
for bit-offset from 0 below 64 by 8
for value = (aref itable
(ldb (byte 8 bit-offset) rc))
do
(setf (ldb (byte 4 (truncate bit-offset 2)) even)
(ldb (byte 4 0) value)
(ldb (byte 4 (truncate bit-offset 2)) odd)
(ldb (byte 4 4) value))
finally
(return (list even odd)))))
t)))
(declare (type (simple-array keccak-1600-part (#.(* 24 +keccak-state-splits+)))
constants))
(aref constants (+ (* i +keccak-state-splits+) p))))
;;;
;;; Helper: Rotation
;;;
(declaim (inline keccak-f-rot-part)
(ftype (function (keccak-1600-part (integer 0 32)) keccak-1600-part)
keccak-f-rot-part))
(defun keccak-f-rot-part (value offset)
(declare (type (integer 0 32) offset)
(type keccak-1600-part value)
#.*optimize-declaration*
#+sbcl
(sb-ext:muffle-conditions sb-ext:code-deletion-note))
#+sbcl
(if (or (zerop offset) (= offset 32))
value
(sb-rotate-byte:rotate-byte offset (byte 32 0) value))
#-sbcl
(if (or (zerop offset) (= offset 32))
value
#+ccl
(logior (the keccak-1600-part (ash (ldb (byte (- 32 offset) 0) value) offset))
(ash value (- offset 32)))
#-ccl
(logior (ldb (byte 32 0) (ash value offset))
(ash value (- offset 32)))))
(declaim (inline keccak-f-rot)
(ftype (function (keccak-1600-part keccak-1600-part (integer 0 63))
(values keccak-1600-part keccak-1600-part))
keccak-f-rot))
(defun keccak-f-rot (value-even value-odd offset)
(declare (type (integer 0 63) offset)
(type keccak-1600-part value-even value-odd)
#.*optimize-declaration*
#+sbcl
(sb-ext:muffle-conditions sb-ext:code-deletion-note))
(if (evenp offset)
(values
(keccak-f-rot-part value-even (truncate offset 2))
(keccak-f-rot-part value-odd (truncate offset 2)))
(values
(keccak-f-rot-part value-odd (1+ (truncate offset 2)))
(keccak-f-rot-part value-even (truncate offset 2)))))
;;;
;;; State and Temporary Variable Accessors
;;;
(defmacro with-state-accessors ((&rest states) &body body)
"Bind the contents of the state(s) array(s) to local variables, and save
the content on normal form exit."
(let ((bindings nil) (mappings nil) (save-forms nil))
(loop for state in states
for map = (make-array '(#.+keccak-state-columns+ #.+keccak-state-rows+
#.+keccak-state-splits+))
do
(dotimes (y +keccak-state-rows+)
(dotimes (x +keccak-state-columns+)
(dotimes (p +keccak-state-splits+)
(let ((sym (make-symbol (format nil "~A-~D-~D-~D" state x y p))))
(setf (aref map x y p) sym)
(push `(,sym (aref ,state ,(+ p (* (+ x (* y +keccak-state-columns+))
+keccak-state-splits+))))
bindings)
(push `(setf (aref ,state ,(+ p (* (+ x (* y +keccak-state-columns+))
+keccak-state-splits+)))
,sym)
save-forms)))))
(push (cons state map) mappings))
`(let (,@bindings)
(declare (ignorable ,@(mapcar #'car bindings))
(type keccak-1600-part ,@(mapcar #'car bindings)))
(macrolet ((state-aref (state x y p &environment env)
(let ((entry (assoc state ',mappings)))
(unless entry (error "Strange: ~S!" state))
(aref (cdr entry)
(eval (trivial-macroexpand-all x env))
(eval (trivial-macroexpand-all y env))
(eval (trivial-macroexpand-all p env))))))
(multiple-value-prog1 (progn ,@body)
,@save-forms)))))
(defmacro with-temp-state ((&rest temps) &body body)
"Bind local variables for each temporary state."
(let ((bindings nil) (mappings nil))
(loop for temp in temps
for map = (make-array '(#.+keccak-state-columns+ #.+keccak-state-rows+
#.+keccak-state-splits+))
do
(dotimes (y +keccak-state-rows+)
(dotimes (x +keccak-state-columns+)
(dotimes (p +keccak-state-splits+)
(let ((sym (make-symbol (format nil "~A-~D-~D-~D" temp x y p))))
(setf (aref map x y p) sym)
(push `(,sym 0) bindings)))))
(push (cons temp map) mappings))
`(let (,@bindings)
(declare (ignorable ,@(mapcar #'car bindings))
(type keccak-1600-part ,@(mapcar #'car bindings)))
(macrolet ((temp-state-aref (temp x y p &environment env)
(let ((entry (assoc temp ',mappings)))
(unless entry (error "Strange: ~S!" temp))
(aref (cdr entry)
(eval (trivial-macroexpand-all x env))
(eval (trivial-macroexpand-all y env))
(eval (trivial-macroexpand-all p env))))))
,@body))))
(defmacro with-temp-rows ((&rest rows) &body body)
"Bind local variables for each temporary row."
(let ((bindings nil) (mappings nil))
(loop for row in rows
for map = (make-array '(#.+keccak-state-columns+ #.+keccak-state-splits+))
do
(dotimes (x +keccak-state-columns+)
(dotimes (p +keccak-state-splits+)
(let ((sym (make-symbol (format nil "~A-~D-~D" row x p))))
(setf (aref map x p) sym)
(push `(,sym 0) bindings))))
(push (cons row map) mappings))
`(let (,@bindings)
(declare (ignorable ,@(mapcar #'car bindings))
(type keccak-1600-part ,@(mapcar #'car bindings)))
(macrolet ((temp-row-aref (row x p &environment env)
(let ((entry (assoc row ',mappings)))
(unless entry (error "Strange: ~S!" row))
(aref (cdr entry)
(eval (trivial-macroexpand-all x env))
(eval (trivial-macroexpand-all p env))))))
,@body))))
;;;
;;; Keccak-f permutation
;;;
(declaim (ftype (function (keccak-1600-state) keccak-1600-state) keccak-f))
(defun keccak-f (a)
(declare (type keccak-1600-state a)
#.*optimize-declaration*)
(with-state-accessors (a)
(with-temp-state (b)
(with-temp-rows (c d)
(dotimes (i #.(+ 12 (* 2 (truncate (log +keccak-1600-lane-width+ 2)))))
(dotimes-unrolled (x +keccak-state-columns+)
(dotimes-unrolled (p +keccak-state-splits+)
(setf (temp-row-aref c x p)
(logxor (state-aref a x 0 p)
(state-aref a x 1 p)
(state-aref a x 2 p)
(state-aref a x 3 p)
(state-aref a x 4 p)))))
(dotimes-unrolled (x +keccak-state-columns+)
(setf (temp-row-aref d x 0)
(logxor (temp-row-aref c (mod (+ +keccak-state-columns+ (1- x))
+keccak-state-columns+)
0)
(keccak-f-rot-part
(temp-row-aref c (mod (1+ x) +keccak-state-columns+) 1)
1))
(temp-row-aref d x 1)
(logxor (temp-row-aref c (mod (+ +keccak-state-columns+ (1- x))
+keccak-state-columns+)
1)
(temp-row-aref c (mod (1+ x) +keccak-state-columns+) 0))))
(dotimes-unrolled (x +keccak-state-columns+)
(dotimes-unrolled (y +keccak-state-rows+)
(dotimes-unrolled (p +keccak-state-splits+)
(setf (state-aref a x y p)
(logxor (state-aref a x y p) (temp-row-aref d x p))))))
(dotimes-unrolled (x +keccak-state-columns+)
(dotimes-unrolled (y +keccak-state-rows+)
(setf (values
(temp-state-aref b y
(mod (+ (* 2 x) (* 3 y)) +keccak-state-rows+)
0)
(temp-state-aref b y
(mod (+ (* 2 x) (* 3 y)) +keccak-state-rows+)
1))
(keccak-f-rot (state-aref a x y 0) (state-aref a x y 1)
(get-rotate-offset x y)))))
(dotimes-unrolled (x +keccak-state-columns+)
(dotimes-unrolled (y +keccak-state-rows+)
(dotimes-unrolled (p +keccak-state-splits+)
(setf (state-aref a x y p)
(logxor (temp-state-aref b x y p)
(logandc1
(temp-state-aref b (mod (1+ x) +keccak-state-columns+)
y p)
(temp-state-aref b (mod (+ x 2) +keccak-state-columns+)
y p)))))))
(dotimes-unrolled (p +keccak-state-splits+)
(setf (state-aref a 0 0 p)
(logxor (state-aref a 0 0 p)
(keccak-f-round-constant i p)))))))
a))
#+cmu
(eval-when (:compile-toplevel)
(setq ext:*inline-expansion-limit* *old-expansion-limit*))

266
keccak-64bit.lisp Normal file
View File

@ -0,0 +1,266 @@
;;;; SHA3 --- Secure Hash Algorithm 3 (Keccak) Implementation
;;;;
;;;; Copyright (C) 2012 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 an implementation of Keccak 1600 tuned to
;;;; implementations that support unboxed arithmetic on (unsigned-byte
;;;; 64).
;;;;
;;;; Implementation Choices:
;;;;
;;;; This is a fairly straightforward implementation of Keccak 1600,
;;;; mostly tuned to sbcl for x86-64. It employs a bit of loop
;;;; unrolling at compile-time. More advanced implementation
;;;; techniques like plane-per-plane processing, lane complementing
;;;; and early parity (c.f. the Keccak implementation overview) did
;;;; not seem to work well with SBCL's compiler, resulting in slower,
;;;; less readable code.
;;;;
;;;
;;; Additional Keccak-f-1600 definitions
;;;
(deftype keccak-1600-state ()
"Type of a keccak working state object for Keccak-1600."
`(simple-array keccak-1600-lane
(,+keccak-state-lanes+)))
(declaim (inline make-keccak-1600-state)
(ftype (function () keccak-1600-state) make-keccak-1600-state))
(defun make-keccak-1600-state ()
(declare #.*optimize-declaration*)
(make-array '(#.+keccak-state-lanes+)
:element-type 'keccak-1600-lane
:initial-element 0))
;;;
;;; Transforming linear input/output to state array
;;;
(defun keccak-state-merge-input (state bit-rate input start)
(declare (type keccak-1600-state state) (type (integer 0 1600) bit-rate)
(type (simple-array (unsigned-byte 8) (*)) input)
(type fixnum start)
#.*optimize-declaration*)
(let ((rate-bytes (truncate bit-rate 8)))
(declare (type (integer 0 200) rate-bytes))
(dotimes (y +keccak-state-rows+)
(dotimes (x +keccak-state-columns+)
(let* ((element (+ (* y +keccak-state-columns+) x))
(offset (* element +keccak-1600-lane-byte-width+))
(index (the fixnum (+ start offset))))
(when (>= offset rate-bytes)
(return-from keccak-state-merge-input))
(setf (aref state element)
(logxor
(aref state element)
.
#.(loop for byte-index from 0
below +keccak-1600-lane-byte-width+
collect
`(the keccak-1600-lane
(ash (aref input (+ index ,byte-index))
,(* byte-index 8)))))))))))
(defun keccak-state-extract-output (state output-bits)
(let* ((output-bytes (truncate output-bits 8))
(digest (make-array (list output-bytes) :element-type '(unsigned-byte 8))))
(dotimes (x +keccak-state-columns+)
(dotimes (y +keccak-state-rows+)
(let* ((element (+ (* y +keccak-state-columns+) x))
(offset (* element +keccak-1600-lane-byte-width+)))
(unless (>= offset output-bytes)
(loop with value = (aref state element)
for index from offset
below (min (+ offset +keccak-1600-lane-byte-width+) output-bytes)
do
(setf (aref digest index) (ldb (byte 8 0) value)
value (ash value -8)))))))
digest))
;;;
;;; Keccak Constants
;;;
(declaim (inline keccak-f-round-constant)
(ftype (function ((integer 0 23)) keccak-1600-lane) keccak-f-round-constant))
(defun keccak-f-round-constant (i)
(declare (type (integer 0 23) i)
#.*optimize-declaration*)
(let ((constants (load-time-value *keccak-f-round-constants* t)))
(declare (type (simple-array keccak-1600-lane (24)) constants))
(aref constants i)))
;;;
;;; Helper: Rotation
;;;
(declaim (inline keccak-f-rot)
(ftype (function (keccak-1600-lane (integer 0 63)) keccak-1600-lane)
keccak-f-rot))
(defun keccak-f-rot (value offset)
(declare (type (integer 0 63) offset)
(type keccak-1600-lane value)
#.*optimize-declaration*)
#+sbcl
(sb-rotate-byte:rotate-byte offset (byte 64 0) value)
#-sbcl
(if (zerop offset)
value
(logior (ldb (byte 64 0) (ash value offset))
(ash value (- offset 64)))))
;;;
;;; State and Temporary Variable Accessors
;;;
(defmacro with-state-accessors ((&rest states) &body body)
"Bind the contents of the state(s) array(s) to local variables, and save
the content on normal form exit."
(let ((bindings nil) (mappings nil) (save-forms nil))
(loop for state in states
for map = (make-array '(#.+keccak-state-columns+ #.+keccak-state-rows+))
do
(dotimes (y +keccak-state-rows+)
(dotimes (x +keccak-state-columns+)
(let ((sym (make-symbol (format nil "~A-~D-~D" state x y))))
(setf (aref map x y) sym)
(push `(,sym (aref ,state ,(+ x (* y +keccak-state-columns+))))
bindings)
(push `(setf (aref ,state ,(+ x (* y +keccak-state-columns+))) ,sym)
save-forms))))
(push (cons state map) mappings))
`(let (,@bindings)
(declare (ignorable ,@(mapcar #'car bindings))
(type keccak-1600-lane ,@(mapcar #'car bindings)))
(macrolet ((state-aref (state x y &environment env)
(let ((entry (assoc state ',mappings)))
(unless entry (error "Strange: ~S!" state))
(aref (cdr entry)
(eval (trivial-macroexpand-all x env))
(eval (trivial-macroexpand-all y env))))))
(multiple-value-prog1 (progn ,@body)
,@save-forms)))))
(defmacro with-temp-state ((&rest temps) &body body)
"Bind local variables for each temporary state."
(let ((bindings nil) (mappings nil))
(loop for temp in temps
for map = (make-array '(#.+keccak-state-columns+ #.+keccak-state-rows+))
do
(dotimes (y +keccak-state-rows+)
(dotimes (x +keccak-state-columns+)
(let ((sym (make-symbol (format nil "~A-~D-~D" temp x y))))
(setf (aref map x y) sym)
(push `(,sym 0) bindings))))
(push (cons temp map) mappings))
`(let (,@bindings)
(declare (ignorable ,@(mapcar #'car bindings))
(type keccak-1600-lane ,@(mapcar #'car bindings)))
(macrolet ((temp-state-aref (temp x y &environment env)
(let ((entry (assoc temp ',mappings)))
(unless entry (error "Strange: ~S!" temp))
(aref (cdr entry)
(eval (trivial-macroexpand-all x env))
(eval (trivial-macroexpand-all y env))))))
,@body))))
(defmacro with-temp-rows ((&rest rows) &body body)
"Bind local variables for each temporary row."
(let ((bindings nil) (mappings nil))
(loop for row in rows
for map = (make-array '(#.+keccak-state-columns+))
do
(dotimes (x +keccak-state-columns+)
(let ((sym (make-symbol (format nil "~A-~D" row x))))
(setf (aref map x) sym)
(push `(,sym 0) bindings)))
(push (cons row map) mappings))
`(let (,@bindings)
(declare (ignorable ,@(mapcar #'car bindings))
(type keccak-1600-lane ,@(mapcar #'car bindings)))
(macrolet ((temp-row-aref (row x &environment env)
(let ((entry (assoc row ',mappings)))
(unless entry (error "Strange: ~S!" row))
(aref (cdr entry)
(eval (trivial-macroexpand-all x env))))))
,@body))))
;;;
;;; Keccak-f permutation
;;;
(declaim (ftype (function (keccak-1600-state) keccak-1600-state) keccak-f))
(defun keccak-f (a)
(declare (type keccak-1600-state a)
#.*optimize-declaration*)
(with-state-accessors (a)
(with-temp-state (b)
(with-temp-rows (c d)
(dotimes (i #.(+ 12 (* 2 (truncate (log +keccak-1600-lane-width+ 2)))))
(dotimes-unrolled (x +keccak-state-columns+)
(setf (temp-row-aref c x)
(logxor (state-aref a x 0)
(state-aref a x 1)
(state-aref a x 2)
(state-aref a x 3)
(state-aref a x 4))))
(dotimes-unrolled (x +keccak-state-columns+)
(setf (temp-row-aref d x)
(logxor (temp-row-aref c (mod (+ +keccak-state-columns+ (1- x))
+keccak-state-columns+))
(keccak-f-rot
(temp-row-aref c (mod (1+ x) +keccak-state-columns+))
1))))
(dotimes-unrolled (x +keccak-state-columns+)
(dotimes-unrolled (y +keccak-state-rows+)
(setf (state-aref a x y)
(logxor (state-aref a x y) (temp-row-aref d x)))))
(dotimes-unrolled (x +keccak-state-columns+)
(dotimes-unrolled (y +keccak-state-rows+)
(setf (temp-state-aref b y
(mod (+ (* 2 x) (* 3 y)) +keccak-state-rows+))
(keccak-f-rot (state-aref a x y)
(get-rotate-offset x y)))))
(dotimes-unrolled (x +keccak-state-columns+)
(dotimes-unrolled (y +keccak-state-rows+)
(setf (state-aref a x y)
(logxor (temp-state-aref b x y)
(logandc1
(temp-state-aref b (mod (1+ x) +keccak-state-columns+) y)
(temp-state-aref b (mod (+ x 2) +keccak-state-columns+)
y))))))
(setf (state-aref a 0 0) (logxor (state-aref a 0 0)
(keccak-f-round-constant i))))))
a))

46
pkgdef.lisp Normal file
View File

@ -0,0 +1,46 @@
;;;; SHA3 --- Secure Hash Algorithm 3 (Keccak) Implementation
;;;;
;;;; Copyright (C) 2012 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$
;;;; %File Description:
;;;;
;;;; This file contains the package definition
;;;;
(cl:defpackage #:sha3
(:use #:common-lisp)
#+(or lispworks ccl)
(:shadow #:logxor)
(:export
;; Mid-Level
#:sha3-state #:sha3-state-p
#:sha3-init #:sha3-copy #:sha3-update #:sha3-final
;; High-Level
#:sha3-digest-vector #:sha3-digest-stream #:sha3-digest-file
))

67
sha3.asd Normal file
View File

@ -0,0 +1,67 @@
;;;; SHA3 --- Secure Hash Algorithm 3 (Keccak) Implementation
;;;;
;;;; Copyright (C) 2012 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 #:cl-user)
;;;; %File Description:
;;;;
;;;; This file contains the system definition form for the SHA3
;;;; Library. System definitions use the ASDF system definition
;;;; facility.
;;;;
(asdf:defsystem "sha3"
:description "Secure Hash Algorithm 3 (Keccak) Implementation"
:author "Pierre R. Mai <pmai@pmsf.de>"
:maintainer "Pierre R. Mai <pmai@pmsf.de>"
:licence "MIT/X11"
:version "1.0.0"
#+sbcl :depends-on #+sbcl ("sb-rotate-byte")
:components ((:file "pkgdef")
(:file "common" :depends-on ("pkgdef"))
#+(and :sbcl (or :x86-64 :alpha))
(:file "keccak-64bit" :depends-on ("pkgdef" "common"))
#+(or (and :sbcl (not (or :x86-64 :alpha)))
:cmucl
(and :ccl :64-bit-target))
(:file "keccak-32bit" :depends-on ("pkgdef" "common"))
#-(or :sbcl :cmucl (and :ccl :64-bit-target))
(:file "keccak-16bit" :depends-on ("pkgdef" "common"))
(:file "sha3"
:depends-on ("pkgdef"
"common"
#+(and :sbcl (or :x86-64 :alpha))
"keccak-64bit"
#+(or (and :sbcl (not (or :x86-64 :alpha)))
:cmucl
(and :ccl :64-bit-target))
"keccak-32bit"
#-(or :sbcl :cmucl (and :ccl :64-bit-target))
"keccak-16bit"))))

248
sha3.lisp Normal file
View File

@ -0,0 +1,248 @@
;;;; SHA3 --- Secure Hash Algorithm 3 (Keccak) Implementation
;;;;
;;;; Copyright (C) 2012 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 the implementation of mid- and high-level
;;;; SHA-3 functions based on the optimized Keccak implementations.
;;;;
;;;; The main entry points are the mid-level functions sha3-init,
;;;; sha3-update and sha3-final to initialize, update and finalize an
;;;; sha3 hash, and sha3-copy in order to copy a sha3 state.
;;;;
;;;; For convenience high-level functions to hash a given vector,
;;;; stream or file are provided as sha3-digest-vector,
;;;; sha3-digest-stream and sha3-digest-vector.
;;;;
;;;
;;; Mid-Level Routines
;;;
(defstruct (sha3-state
(:constructor make-sha3-state (bit-rate))
(:copier))
(state (make-keccak-1600-state) :type keccak-1600-state :read-only t)
(bit-rate 1024 :type (integer 0 1600) :read-only t)
(buffer (make-array 200 :element-type '(unsigned-byte 8)) :read-only t
:type (simple-array (unsigned-byte 8) (200)))
(buffer-index 0 :type (integer 0 199))
(finalized-p nil))
(defun sha3-init (&key (output-bit-length nil output-bit-length-p)
(bit-rate (if (and output-bit-length-p
output-bit-length)
(- 1600 (* 2 output-bit-length))
1024)))
"Create and return a new SHA-3 state. If `output-bit-length' is specified
then the state will run at the bit rate specified for the given output bit
length. If `output-bit-length' is unspecified, `bit-rate' can be specified
to select a suitable bit rate. If both are left unspecified then a default
bit rate of 1024 bits is selected, which is suitable for arbitrary output
bit lengths of up to 288 bits."
(check-type output-bit-length (member nil 224 256 288 384 512)
"Legal output-bit-length specifier for SHA-3/Keccak-1600")
(check-type bit-rate (member 576 832 1024 1088 1152)
"Legal bit-rate for SHA-3/Keccak-1600")
(if (or (null output-bit-length)
(= bit-rate (- 1600 (* 2 output-bit-length)))
(= bit-rate 1024))
(make-sha3-state bit-rate)
(error "Illegal combination of output-bit-length ~D and bit-rate ~D."
output-bit-length bit-rate)))
(defun sha3-copy (state)
"Return an independent copy of the SHA-3 state `state'."
(let ((result (make-sha3-state (sha3-state-bit-rate state))))
(setf (sha3-state-buffer-index result) (sha3-state-buffer-index state)
(sha3-state-finalized-p result) (sha3-state-finalized-p state))
(replace (sha3-state-buffer result) (sha3-state-buffer state))
(replace (sha3-state-state result) (sha3-state-state state))
result))
(defun sha3-update (state vector &key (start 0) (end (length vector)))
"Update the given SHA-3 state `state' from `vector', which must be
a simple-array with element-type (unsigned-byte 8), bounded by `start'
and `end', which must be numeric bounding-indices."
(declare (type sha3-state state)
(type (simple-array (unsigned-byte 8) (*)) vector)
(type fixnum start end)
(optimize (speed 3) (safety 1) (space 0) (debug 1)))
(let* ((keccak-state (sha3-state-state state))
(buffer (sha3-state-buffer state))
(buffer-index (sha3-state-buffer-index state))
(bit-rate (sha3-state-bit-rate state))
(rate-bytes (truncate bit-rate 8)))
(declare (type keccak-1600-state keccak-state)
(type (simple-array (unsigned-byte 8) (200)) buffer)
(type (integer 0 199) buffer-index)
(type (integer 0 1600) bit-rate)
(type (integer 0 200) rate-bytes)
#.*optimize-declaration*)
;; Handle potential remaining bytes
(unless (zerop buffer-index)
(let ((remainder (- (length buffer) buffer-index)))
(declare (type fixnum remainder))
(replace buffer vector :start1 buffer-index :start2 start :end2 end)
(when (>= (- end start) remainder)
(keccak-state-merge-input keccak-state bit-rate buffer 0)
(keccak-f keccak-state))
(setf (sha3-state-buffer-index state) 0
start (min (+ start remainder) end))))
;; Now handle full blocks, stuff any remainder into buffer
(loop for block-offset of-type fixnum from start to end by rate-bytes
do
(cond
((<= (+ block-offset rate-bytes) end)
(keccak-state-merge-input keccak-state bit-rate vector block-offset)
(keccak-f keccak-state))
(t
(replace buffer vector :start1 0 :start2 block-offset)
(setf (sha3-state-buffer-index state) (- end block-offset)))))))
(defun sha3-final (state &key (output-bit-length nil output-bit-length-p))
"If the given SHA-3 state `state' has not already been finalized,
finalize it by processing any remaining input in its buffer, with
suitable padding as specified by the SHA-3 standard. Returns the
message digest as a simple-array of (unsigned-byte 8). The length
of the returned digest is determined either by the output bit length
or bit rate specified on state creation, or for the special case of
default parameters being used, by the optional keyword argument
`output-bit-length'. If the state has previously been finalized,
the function will return the digest again."
(declare (type sha3-state state)
(type (or null (integer 0 1600)) output-bit-length)
(optimize (speed 3) (safety 1) (space 0) (debug 1)))
(let ((keccak-state (sha3-state-state state))
(buffer (sha3-state-buffer state))
(buffer-index (sha3-state-buffer-index state))
(bit-rate (sha3-state-bit-rate state))
(finalized-p (sha3-state-finalized-p state)))
(declare (type keccak-1600-state keccak-state)
(type (simple-array (unsigned-byte 8) (200)) buffer)
(type (integer 0 199) buffer-index)
(type (integer 0 1600) bit-rate)
(type (or null (simple-array (unsigned-byte 8) (*))) finalized-p)
#.*optimize-declaration*)
;; Determine output-bit-length
(if output-bit-length-p
(unless (or (= bit-rate 1024)
(= (* 2 output-bit-length) (- 1600 bit-rate)))
(error "Illegal output-bit-length ~D specified!" output-bit-length))
(setq output-bit-length (truncate (- 1600 bit-rate) 2)))
(cond
;; Check if already finalized
(finalized-p
(unless (= (* (length finalized-p) 8) output-bit-length)
(error "Mismatch in output-bit-length ~D in repeated call to sha3-final! ~
Should be: ~D!"
output-bit-length (* (length finalized-p) 8)))
finalized-p)
;; Finalize
(t
(keccak-state-merge-input keccak-state bit-rate
(pad-message-to-width
(subseq buffer 0 buffer-index)
bit-rate)
0)
(keccak-f keccak-state)
(setf (sha3-state-buffer-index state) 0
(sha3-state-finalized-p state)
(keccak-state-extract-output keccak-state output-bit-length))))))
;;;
;;; High-Level Routines
;;;
(defun sha3-digest-vector (vector &key (start 0) end
(output-bit-length 512))
"Calculate an SHA-3 message-digest of data in `vector', which should
be a 1d simple-array with element type (unsigned-byte 8), bounded by
`start' and `end'. The bit length of the message digest produced is
controlled by `output-bit-length', which can take on the values 224,
256, 288, 384 and 512, which is the default value."
(declare (optimize (speed 3) (safety 3) (space 0) (debug 1))
(type (simple-array (unsigned-byte 8) (*)) vector)
(type fixnum start)
(type (or null fixnum) end)
(type (integer 0 1600) output-bit-length))
(locally
(declare (optimize (safety 1) (debug 0)))
(let ((state (sha3-init :output-bit-length output-bit-length)))
(declare (type sha3-state state))
(let ((real-end (or end (length vector))))
(declare (type fixnum real-end))
(sha3-update state vector :start start :end real-end))
(sha3-final state))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant +buffer-size+ (* 128 1024)
"Size of internal buffer to use for `sha3-digest-stream' and
`sha3-digest-file' operations."))
(deftype buffer-index () `(integer 0 ,+buffer-size+))
(defun sha3-digest-stream (stream &key (output-bit-length 512))
"Calculate an SHA-3 message-digest of data read from `stream', which
should be a stream with element type (unsigned-byte 8). The bit
length of the message digest produced is controlled by
`output-bit-length', which can take on the values 224, 256, 288, 384
and 512, which is the default value."
(declare (optimize (speed 3) (safety 3) (space 0) (debug 1))
(type stream stream)
(type (integer 0 1600) output-bit-length))
(locally
(declare (optimize (safety 1) (debug 0)))
(unless (equal (stream-element-type stream) '(unsigned-byte 8))
(error "Illegal stream-element-type ~S, must be ~S."
(stream-element-type stream) '(unsigned-byte 8)))
(let ((buffer (make-array '(#.+buffer-size+) :element-type '(unsigned-byte 8)))
(state (sha3-init :output-bit-length output-bit-length)))
(declare (type sha3-state state)
(type (simple-array (unsigned-byte 8) (#.+buffer-size+)) buffer))
(loop for bytes of-type buffer-index = (read-sequence buffer stream)
do (sha3-update state buffer :end bytes)
until (< bytes +buffer-size+)
finally
(return (sha3-final state))))))
(defun sha3-digest-file (pathname &key (output-bit-length 512))
"Calculate an SHA-3 message-digest of the file specified by
`pathname'. The bit length of the message digest produced is
controlled by `output-bit-length', which can take on the values 224,
256, 288, 384 and 512, which is the default value."
(declare (optimize (speed 3) (safety 3) (space 0) (debug 1))
(type (integer 0 1600) output-bit-length))
(locally
(declare (optimize (safety 1) (debug 0)))
(with-open-file (stream pathname :element-type '(unsigned-byte 8))
(sha3-digest-stream stream :output-bit-length output-bit-length))))