summaryrefslogtreecommitdiff
path: root/ironclad
diff options
context:
space:
mode:
Diffstat (limited to 'ironclad')
-rw-r--r--ironclad/LICENSE31
-rw-r--r--ironclad/common.lisp372
-rw-r--r--ironclad/digest.lisp420
-rw-r--r--ironclad/package.lisp61
-rw-r--r--ironclad/sha1.lisp237
5 files changed, 1121 insertions, 0 deletions
diff --git a/ironclad/LICENSE b/ironclad/LICENSE
new file mode 100644
index 0000000..13203f8
--- /dev/null
+++ b/ironclad/LICENSE
@@ -0,0 +1,31 @@
+Copyright (c) 2004-2008, Nathan Froyd
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+* Redistributions of source code must retain the above copyright notice,
+ this list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+* Neither the name of the copyright holders nor the names of
+ contributors to this software may be used to endorse or promote
+ products derived from this software without specific prior written
+ permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
+IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/ironclad/common.lisp b/ironclad/common.lisp
new file mode 100644
index 0000000..4753ad7
--- /dev/null
+++ b/ironclad/common.lisp
@@ -0,0 +1,372 @@
+;;;; common.lisp -- efficient implementations of mod32 arithmetic and macros
+
+;;; Functions in this file are intended to be fast
+(in-package :crypto)
+
+(defmacro defconst (name value)
+ `(defconstant ,name
+ (if (boundp ',name)
+ (symbol-value ',name)
+ ,value)))
+
+;;; CMUCL and SBCL both have an internal type for this, but we'd like to
+;;; be portable, so we define our own.
+
+(deftype index () '(mod #.array-dimension-limit))
+(deftype index+1 () `(mod ,(1+ array-dimension-limit)))
+
+;;; We write something like this all over the place.
+
+(deftype simple-octet-vector (&optional length)
+ (let ((length (or length '*)))
+ `(simple-array (unsigned-byte 8) (,length))))
+
+
+;;; a global specification of optimization settings
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defun burn-baby-burn ()
+ '(optimize (speed 3) (safety 0) (space 0)
+ (debug 0) (compilation-speed 0)))
+
+(defun hold-me-back ()
+ '(declare (optimize (speed 3) (space 0) (compilation-speed 0)
+ #-cmu (safety 1) #-cmu (debug 1)
+ #+cmu (safety 0) #+cmu (debug 0))
+ #+cmu (ext:optimize-interface (safety 1) (debug 1))))
+) ; EVAL-WHEN
+
+
+;;; extracting individual bytes from integers
+
+;;; We used to declare these functions with much stricter types (e.g.
+;;; (UNSIGNED-BYTE 32) as the lone argument), but we need to access
+;;; bytes of both 32-bit and 64-bit words and the types would just get
+;;; in our way. We declare these functions as inline; a good Common
+;;; Lisp compiler should be able to generate efficient code from the
+;;; declarations at the point of the call.
+
+;;; These functions are named according to big-endian conventions. The
+;;; comment is here because I always forget and need to be reminded.
+#.(loop for i from 1 to 8
+ collect (let ((name (intern (format nil "~:@(~:R~)-BYTE" i))))
+ `(progn
+ (declaim (inline ,name))
+ (declaim (ftype (function (unsigned-byte) (unsigned-byte 8)) ,name))
+ (defun ,name (ub)
+ (declare (type unsigned-byte ub))
+ (ldb (byte 8 ,(* 8 (1- i))) ub)))) into forms
+ finally (return `(progn ,@forms)))
+
+
+;;; fetching/storing appropriately-sized integers from octet vectors
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defun ubref-fun-name (bitsize big-endian-p)
+ (intern (format nil "UB~DREF/~:[LE~;BE~]" bitsize big-endian-p)))
+) ; EVAL-WHEN
+
+(macrolet ((define-fetcher (bitsize &optional big-endian)
+ (let ((name (ubref-fun-name bitsize big-endian))
+ (bytes (truncate bitsize 8)))
+ `(progn
+ (declaim (inline ,name))
+ (defun ,name (buffer index)
+ (declare (type simple-octet-vector buffer))
+ (declare (type (integer 0 ,(- array-dimension-limit bytes)) index))
+ (logand ,(1- (ash 1 bitsize))
+ ,(loop for i from 0 below bytes
+ collect (let* ((offset (if big-endian
+ i
+ (- bytes i 1)))
+ (shift (if big-endian
+ (* (- bytes i 1) 8)
+ (* offset 8))))
+ `(ash (aref buffer (+ index ,offset)) ,shift)) into forms
+ finally (return `(logior ,@forms))))))))
+ (define-storer (bitsize &optional big-endian)
+ (let ((name (ubref-fun-name bitsize big-endian))
+ (bytes (truncate bitsize 8)))
+ `(progn
+ (declaim (inline (setf ,name)))
+ (defun (setf ,name) (value buffer index)
+ (declare (type simple-octet-vector buffer))
+ (declare (type (integer 0 ,(- array-dimension-limit bytes)) index))
+ (declare (type (unsigned-byte ,bitsize) value))
+ ,@(loop for i from 1 to bytes
+ collect (let ((offset (if big-endian
+ (- bytes i)
+ (1- i))))
+ `(setf (aref buffer (+ index ,offset))
+ (,(intern (format nil "~:@(~:R~)-BYTE" i)) value))))
+ (values)))))
+ (define-fetchers-and-storers (bitsize)
+ `(progn
+ (define-fetcher ,bitsize) (define-fetcher ,bitsize t)
+ (define-storer ,bitsize) (define-storer ,bitsize t))))
+ (define-fetchers-and-storers 16)
+ (define-fetchers-and-storers 32)
+ (define-fetchers-and-storers 64))
+
+
+;;; efficient 32-bit arithmetic, which a lot of algorithms require
+
+(declaim (inline mod32+)
+ (ftype (function ((unsigned-byte 32) (unsigned-byte 32)) (unsigned-byte 32)) mod32+))
+(defun mod32+ (a b)
+ (declare (type (unsigned-byte 32) a b))
+ (ldb (byte 32 0) (+ a b)))
+
+#+cmu
+(define-compiler-macro mod32+ (a b)
+ `(ext:truly-the (unsigned-byte 32) (+ ,a ,b)))
+
+#+sbcl
+(define-compiler-macro mod32+ (a b)
+ `(ldb (byte 32 0) (+ ,a ,b)))
+
+;;; mostly needed for CAST*
+(declaim (inline mod32-)
+ (ftype (function ((unsigned-byte 32) (unsigned-byte 32)) (unsigned-byte 32)) mod32-))
+
+(defun mod32- (a b)
+ (declare (type (unsigned-byte 32) a b))
+ (ldb (byte 32 0) (- a b)))
+
+#+cmu
+(define-compiler-macro mod32- (a b)
+ `(ext:truly-the (unsigned-byte 32) (- ,a ,b)))
+
+#+sbcl
+(define-compiler-macro mod32- (a b)
+ `(ldb (byte 32 0) (- ,a ,b)))
+
+;;; mostly needed for RC6
+(declaim (inline mod32*)
+ (ftype (function ((unsigned-byte 32) (unsigned-byte 32)) (unsigned-byte 32)) mod32*))
+
+(defun mod32* (a b)
+ (declare (type (unsigned-byte 32) a b))
+ (ldb (byte 32 0) (* a b)))
+
+#+cmu
+(define-compiler-macro mod32* (a b)
+ `(ext:truly-the (unsigned-byte 32) (* ,a ,b)))
+
+#+sbcl
+(define-compiler-macro mod32* (a b)
+ `(ldb (byte 32 0) (* ,a ,b)))
+
+(declaim (inline mod32ash)
+ (ftype (function ((unsigned-byte 32) (integer -31 31)) (unsigned-byte 32)) mod32ash))
+
+(defun mod32ash (num count)
+ (declare (type (unsigned-byte 32) num))
+ (declare (type (integer -31 31) count))
+ (ldb (byte 32 0) (ash num count)))
+
+#+sbcl
+(define-compiler-macro mod32ash (num count)
+ ;; work around SBCL optimizing bug as described by APD:
+ ;; http://www.caddr.com/macho/archives/sbcl-devel/2004-8/3877.html
+ `(logand #xffffffff (ash ,num ,count)))
+
+(declaim (inline mod32lognot)
+ (ftype (function ((unsigned-byte 32)) (unsigned-byte 32)) mod32lognot))
+
+(defun mod32lognot (num)
+ (ldb (byte 32 0) (lognot num)))
+
+#+sbcl
+(define-compiler-macro mod32lognot (num)
+ `(ldb (byte 32 0) (lognot ,num)))
+
+(declaim (inline rol32 ror32)
+ (ftype (function ((unsigned-byte 32) (unsigned-byte 5)) (unsigned-byte 32)) rol32 ror32))
+
+(defun rol32 (a s)
+ (declare (type (unsigned-byte 32) a) (type (integer 0 32) s))
+ #+cmu
+ (kernel:32bit-logical-or #+little-endian (kernel:shift-towards-end a s)
+ #+big-endian (kernel:shift-towards-start a s)
+ (ash a (- s 32)))
+ #+sbcl
+ (sb-rotate-byte:rotate-byte s (byte 32 0) a)
+ #-(or sbcl cmu)
+ (logior (ldb (byte 32 0) (ash a s)) (ash a (- s 32))))
+
+(defun ror32 (a s)
+ (declare (type (unsigned-byte 32) a) (type (integer 0 32) s))
+ #+sbcl
+ (sb-rotate-byte:rotate-byte (- s) (byte 32 0) a)
+ #-sbcl
+ (rol32 a (- 32 s)))
+
+(declaim (inline mod64+)
+ (ftype (function ((unsigned-byte 64) (unsigned-byte 64)) (unsigned-byte 64)) mod64+))
+(defun mod64+ (a b)
+ (declare (type (unsigned-byte 64) a b))
+ (ldb (byte 64 0) (+ a b)))
+
+#+sbcl
+(define-compiler-macro mod64+ (a b)
+ `(ldb (byte 64 0) (+ ,a ,b)))
+
+(defun rol64 (a s)
+ (declare (type (unsigned-byte 64) a) (type (integer 0 64) s))
+ (logior (ldb (byte 64 0) (ash a s)) (ash a (- s 64))))
+
+(defun ror64 (a s)
+ (declare (type (unsigned-byte 64) a) (type (integer 0 64) s))
+ (rol64 a (- 64 s)))
+
+
+;;; 64-bit utilities
+
+(declaim (inline %add-with-carry %subtract-with-borrow))
+
+;;; The names are taken from sbcl and cmucl's bignum routines.
+;;; Naturally, they work the same way (which means %SUBTRACT-WITH-BORROW
+;;; is a little weird).
+(defun %add-with-carry (x y carry)
+ (declare (type (unsigned-byte 32) x y)
+ (type (mod 2) carry))
+ #+(and sbcl 32-bit)
+ (sb-bignum:%add-with-carry x y carry)
+ #+(and cmucl 32-bit)
+ (bignum:%add-with-carry x y carry)
+ #-(or (and sbcl 32-bit)
+ (and cmucl 32-bit))
+ (let* ((temp (mod32+ x y))
+ (temp-carry (if (< temp x) 1 0))
+ (result (mod32+ temp carry)))
+ (values result (logior temp-carry (if (< result temp) 1 0)))))
+
+(defun %subtract-with-borrow (x y borrow)
+ (declare (type (unsigned-byte 32) x y)
+ (type (mod 2) borrow))
+ #+(and sbcl 32-bit)
+ (sb-bignum:%subtract-with-borrow x y borrow)
+ #+(and cmucl 32-bit)
+ (bignum:%subtract-with-borrow x y borrow)
+ #-(or (and sbcl 32-bit)
+ (and cmucl 32-bit))
+ (let ((temp (mod32- x y)))
+ (cond
+ ((zerop borrow)
+ (values (mod32- temp 1) (if (< y x) 1 0)))
+ (t
+ (values temp (logxor (if (< x y) 1 0) 1))))))
+
+;;; efficient 8-byte -> 32-byte buffer copy routines, mostly used by
+;;; the hash functions. we provide big-endian and little-endian
+;;; versions.
+
+(declaim (inline fill-block-le-ub8 fill-block-be-ub8))
+
+(declaim (inline copy-to-buffer))
+(defun copy-to-buffer (from from-offset count buffer buffer-offset)
+ "Copy a partial segment from input vector from starting at
+from-offset and copying count elements into the 64 byte buffer
+starting at buffer-offset."
+ (declare (type index from-offset)
+ (type (integer 0 127) count buffer-offset)
+ (type simple-octet-vector from)
+ (type simple-octet-vector buffer)
+ #.(burn-baby-burn))
+ #+cmu
+ (kernel:bit-bash-copy
+ from (+ (* vm:vector-data-offset vm:word-bits) (* from-offset vm:byte-bits))
+ buffer (+ (* vm:vector-data-offset vm:word-bits)
+ (* buffer-offset vm:byte-bits))
+ (* count vm:byte-bits))
+ #+sbcl
+ (sb-kernel:ub8-bash-copy from from-offset buffer buffer-offset count)
+ #-(or cmu sbcl)
+ (loop for buffer-index of-type (integer 0 64) from buffer-offset
+ for from-index of-type fixnum from from-offset
+ below (+ from-offset count)
+ do
+ (setf (aref buffer buffer-index) (aref from from-index))))
+
+(defun fill-block-ub8-le (block buffer offset)
+ "Convert a complete 64 (UNSIGNED-BYTE 8) input BUFFER starting from
+OFFSET into the given (UNSIGNED-BYTE 32) BLOCK."
+ (declare (type (integer 0 #.(- array-dimension-limit 64)) offset)
+ (type (simple-array (unsigned-byte 32) (16)) block)
+ (type simple-octet-vector buffer))
+ #+(and :cmu :little-endian)
+ (kernel:bit-bash-copy
+ buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits))
+ block (* vm:vector-data-offset vm:word-bits)
+ (* 64 vm:byte-bits))
+ #+(and :sbcl :little-endian)
+ (sb-kernel:ub8-bash-copy buffer offset block 0 64)
+ #-(or (and :sbcl :little-endian) (and :cmu :little-endian))
+ (loop for i of-type (integer 0 16) from 0
+ for j of-type (integer 0 #.array-dimension-limit)
+ from offset to (+ offset 63) by 4
+ do
+ (setf (aref block i) (ub32ref/le buffer j))))
+
+(defun fill-block-ub8-be (block buffer offset)
+ "Convert a complete 64 (unsigned-byte 8) input vector segment
+starting from offset into the given 16 word SHA1 block. Calling this function
+without subsequently calling EXPAND-BLOCK results in undefined behavior."
+ (declare (type (integer 0 #.(- array-dimension-limit 64)) offset)
+ (type (simple-array (unsigned-byte 32) (*)) block)
+ (type simple-octet-vector buffer))
+ ;; convert to 32-bit words
+ #+(and :cmu :big-endian)
+ (kernel:bit-bash-copy
+ buffer (+ (* vm:vector-data-offset vm:word-bits)
+ (* offset vm:byte-bits))
+ block (* vm:vector-data-offset vm:word-bits)
+ (* 64 vm:byte-bits))
+ #+(and :sbcl :big-endian)
+ (sb-kernel:ub8-bash-copy buffer offset block 0 64)
+ #-(or (and :sbcl :big-endian) (and :cmu :big-endian))
+ (loop for i of-type (integer 0 16) from 0
+ for j of-type (integer 0 #.array-dimension-limit)
+ from offset to (+ offset 63) by 4
+ do (setf (aref block i) (ub32ref/be buffer j))))
+
+(defun fill-block-ub8-be/64 (block buffer offset)
+ "Convert a complete 128 (unsigned-byte 8) input vector segment
+starting from offset into the given 16 qword SHA1 block. Calling this
+function without subsequently calling EXPAND-BLOCK results in undefined
+behavior."
+ (declare (type (integer 0 #.(- array-dimension-limit 128)) offset)
+ (type (simple-array (unsigned-byte 64) (*)) block)
+ (type simple-octet-vector buffer)
+ #.(burn-baby-burn))
+ ;; convert to 32-bit words
+ #+(and :cmu :big-endian)
+ (kernel:bit-bash-copy
+ buffer (+ (* vm:vector-data-offset vm:word-bits)
+ (* offset vm:byte-bits))
+ block (* vm:vector-data-offset vm:word-bits)
+ (* 128 vm:byte-bits))
+ #+(and :sbcl :big-endian)
+ (sb-kernel:ub8-bash-copy buffer offset block 0 128)
+ #-(or (and :sbcl :big-endian) (and :cmu :big-endian))
+ (loop for i of-type (integer 0 16) from 0
+ for j of-type (integer 0 #.array-dimension-limit)
+ from offset to (+ offset 127) by 8
+ do (setf (aref block i) (ub64ref/be buffer j))))
+
+;;; a few functions that are useful during compilation
+
+(defun make-circular-list (&rest elements)
+ (let ((list (copy-seq elements)))
+ (setf (cdr (last list)) list)))
+
+;;; SUBSEQ is defined to error on circular lists, so we define our own
+(defun circular-list-subseq (list start end)
+ (let* ((length (- end start))
+ (subseq (make-list length)))
+ (do ((i 0 (1+ i))
+ (list (nthcdr start list) (cdr list))
+ (xsubseq subseq (cdr xsubseq)))
+ ((>= i length) subseq)
+ (setf (first xsubseq) (first list))))) \ No newline at end of file
diff --git a/ironclad/digest.lisp b/ironclad/digest.lisp
new file mode 100644
index 0000000..acf4e95
--- /dev/null
+++ b/ironclad/digest.lisp
@@ -0,0 +1,420 @@
+;;;; digest.lisp -- common functions for hashing
+
+(in-package :crypto)
+
+
+;;; defining digest (hash) functions
+
+(eval-when (:compile-toplevel :load-toplevel)
+(defconstant +buffer-size+ (* 128 1024))
+) ; EVAL-WHEN
+
+(deftype buffer-index () `(integer 0 (,+buffer-size+)))
+
+(defun update-digest-from-stream (digest stream &key buffer (start 0) end)
+ (cond
+ ((let ((element-type (stream-element-type stream)))
+ (or (equal element-type '(unsigned-byte 8))
+ (equal element-type '(integer 0 255))))
+ (flet ((frob (read-buffer start end)
+ (loop for last-updated = (read-sequence read-buffer stream
+ :start start :end end)
+ do (update-digest digest read-buffer
+ :start start :end last-updated)
+ until (< last-updated end)
+ finally (return digest))))
+ (if buffer
+ (frob buffer start (or end (length buffer)))
+ (let ((buffer (make-array +buffer-size+
+ :element-type '(unsigned-byte 8))))
+ (declare (dynamic-extent buffer))
+ (frob buffer 0 +buffer-size+)))))
+ (t
+ (error "Unsupported stream element-type ~S for stream ~S."
+ (stream-element-type stream) stream))))
+
+;;; Storing a length at the end of the hashed data is very common and
+;;; can be a small bottleneck when generating lots of hashes over small
+;;; quantities of data. We assume that the appropriate locations have
+;;; already been zeroed if necessary. LENGTH is also assumed to be an
+;;; (effectively) 64-bit quantity.
+(declaim (inline store-data-length))
+(defun store-data-length (block length offset &optional big-endian-p)
+ (let ((lo (if big-endian-p (1+ offset) offset))
+ (hi (if big-endian-p offset (1+ offset))))
+ #+(and sbcl 32-bit)
+ (cond
+ ((sb-int:fixnump length)
+ (setf (aref block lo) length))
+ ;; Otherwise, we have a bignum.
+ (t
+ (locally (declare (optimize (safety 0))
+ (type sb-bignum:bignum-type length))
+ (cond
+ ((= (sb-bignum:%bignum-length length) 1)
+ (setf (aref block lo) (sb-bignum:%bignum-ref length 0)))
+ (t
+ (setf (aref block lo) (sb-bignum:%bignum-ref length 0)
+ (aref block hi) (sb-bignum:%bignum-ref length 1)))))))
+ #+(and cmu 32-bit)
+ (cond
+ ((ext:fixnump length)
+ (setf (aref block lo) length))
+ ;; Otherwise, we have a bignum.
+ (t
+ (locally (declare (optimize (safety 0))
+ (type bignum:bignum-type length))
+ (cond
+ ((= (bignum:%bignum-length length) 1)
+ (setf (aref block lo) (bignum:%bignum-ref length 0)))
+ (t
+ (setf (aref block lo) (bignum:%bignum-ref length 0)
+ (aref block hi) (bignum:%bignum-ref length 1)))))))
+ #-(or (and sbcl 32-bit)
+ (and cmu 32-bit))
+ (setf (aref block lo) (ldb (byte 32 0) length)
+ (aref block hi) (ldb (byte 32 32) length))))
+
+;;; macros for "mid-level" functions
+
+(defmacro define-digest-registers ((digest-name &key (endian :big) (size 4) (digest-registers nil)) &rest registers)
+ (let* ((struct-name (intern (format nil "~A-REGS" digest-name)))
+ (constructor (intern (format nil "INITIAL-~A" struct-name)))
+ (copier (intern (format nil "%COPY-~A" struct-name)))
+ (digest-fun (intern (format nil "~AREGS-DIGEST" digest-name)))
+ (register-bit-size (* size 8))
+ (digest-size (* size (or digest-registers
+ (length registers))))
+ (ref-fun (ubref-fun-name register-bit-size (eq endian :big))))
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (defstruct (,struct-name
+ (:type (vector (unsigned-byte ,register-bit-size)))
+ (:constructor ,constructor ())
+ (:copier ,copier))
+ ,@registers)
+ ;; Some versions of LispWorks incorrectly define STRUCT-NAME as
+ ;; a type with DEFSTRUCT, so avoid gratuitous warnings.
+ #-(and lispworks lispworks5.0)
+ (deftype ,struct-name ()
+ '(simple-array (unsigned-byte ,register-bit-size) (,(length registers)))))
+ (defun ,digest-fun (regs buffer start)
+ (declare (type ,struct-name regs)
+ (type (simple-array (unsigned-byte 8) (*)) buffer)
+ (type (integer 0 ,(- array-dimension-limit digest-size)) start)
+ ,(burn-baby-burn))
+ ,(let ((inlined-unpacking
+ `(setf ,@(loop for (reg value) in registers
+ for index from 0 below digest-size by size
+ nconc `((,ref-fun buffer (+ start ,index))
+ (,(intern (format nil "~A-REGS-~A" digest-name reg)) regs))))))
+ (cond
+ #+(and sbcl :little-endian)
+ ((eq endian :little)
+ `(if (= start 0)
+ (sb-kernel:ub8-bash-copy regs 0 buffer 0 ,digest-size)
+ ,inlined-unpacking))
+ #+(and sbcl :big-endian)
+ ((eq endian :big)
+ `(if (= start 0)
+ (sb-kernel:ub8-bash-copy regs 0 buffer 0 ,digest-size)
+ ,inlined-unpacking))
+ (t inlined-unpacking)))
+ buffer))))
+
+(defmacro define-digest-updater (digest-name &body body)
+ (destructuring-bind (maybe-doc-string &rest rest) body
+ `(defmethod update-digest ((state ,digest-name) (sequence vector) &key (start 0) (end (length sequence)))
+ ,@(when (stringp maybe-doc-string)
+ `(,maybe-doc-string))
+ (declare (type (simple-array (unsigned-byte 8) (*)) sequence))
+ (declare (type index start end))
+ ,(hold-me-back)
+ ,@(if (stringp maybe-doc-string)
+ rest
+ body))))
+
+;;; SPECS is either (DIGEST-NAME DIGEST-BYTES) or a list of the same.
+;;; The latter spelling is for digests that are related, but have
+;;; different output sizes (e.g. SHA2-512 and SHA2-384). In that case,
+;;; the first list is expected to be for the "major" variant of the
+;;; pair; its digest type is expected to be the supertype of the
+;;; variants.
+(defmacro define-digest-finalizer (specs &body body)
+ (let* ((single-digest-p (not (consp (car specs))))
+ (specs (if single-digest-p (list specs) specs))
+ (inner-fun-name (intern (format nil "%FINALIZE-~A-STATE" (caar specs)))))
+ (destructuring-bind (maybe-doc-string &rest rest) body
+ (loop for (digest-name digest-size) in specs
+ for regs-digest-fun = (intern (format nil "~AREGS-DIGEST" digest-name))
+ collect `(defmethod finalize-digest ((state ,digest-name)
+ &optional buffer buffer-start)
+ ,@(when (stringp maybe-doc-string)
+ `(,maybe-doc-string))
+ (declare (type (or (simple-array (unsigned-byte 8) (*)) cl:null) buffer))
+ (cond
+ (buffer
+ ;; verify that the buffer is large enough
+ (let ((buffer-start (or buffer-start 0)))
+ (if (<= ,digest-size (- (length buffer) buffer-start))
+ (,inner-fun-name state buffer buffer-start
+ ,@(unless single-digest-p
+ `(#',regs-digest-fun)))
+ (error 'insufficient-buffer-space
+ :buffer buffer :start buffer-start
+ :length ,digest-size))))
+ (t
+ (,inner-fun-name state
+ (make-array ,digest-size
+ :element-type '(unsigned-byte 8))
+ 0
+ ,@(unless single-digest-p
+ `(#',regs-digest-fun)))))) into finalizers
+ finally
+ (return
+ `(progn
+ ,@finalizers
+ (defun ,inner-fun-name (state %buffer buffer-start ,@(unless single-digest-p
+ '(reg-digest-fun)))
+ ,(hold-me-back)
+ (macrolet ((finalize-registers (state regs)
+ (declare (ignore state))
+ ,(if single-digest-p
+ ``(,',(intern (format nil "~AREGS-DIGEST" (caar specs))) ,regs %buffer buffer-start)
+ ``(funcall reg-digest-fun ,regs %buffer buffer-start))))
+ ,@(if (stringp maybe-doc-string)
+ rest
+ body)))))))))
+
+;;; high-level generic function drivers
+
+;;; These three functions are intended to be one-shot ways to digest
+;;; an object of some kind. You could write these in terms of the more
+;;; familiar digest interface below, but these are likely to be slightly
+;;; more efficient, as well as more obvious about what you're trying to
+;;; do.
+(defgeneric digest-file (digest-spec pathname &rest args
+ &key buffer start end
+ digest digest-start)
+ (:documentation "Return the digest of the contents of the file named by PATHNAME using
+the algorithm DIGEST-NAME.
+
+If DIGEST is provided, the digest will be placed into DIGEST starting at
+DIGEST-START. DIGEST must be a (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*)).
+An error will be signaled if there is insufficient room in DIGEST.
+
+If BUFFER is provided, the portion of BUFFER between START and END will
+be used to hold data read from the stream."))
+
+(defmethod digest-file ((digest-name symbol) pathname &rest kwargs)
+ (apply #'digest-file (make-digest digest-name) pathname kwargs))
+
+(defmethod digest-file (state pathname &key buffer (start 0) end
+ digest (digest-start 0))
+ (with-open-file (stream pathname :element-type '(unsigned-byte 8)
+ :direction :input
+ :if-does-not-exist :error)
+ (update-digest-from-stream state stream
+ :buffer buffer :start start :end end)
+ (produce-digest state :digest digest :digest-start digest-start)))
+
+(defgeneric digest-stream (digest-spec stream &rest args
+ &key buffer start end
+ digest digest-start)
+ (:documentation "Return the digest of the contents of STREAM using the algorithm
+DIGEST-NAME. STREAM-ELEMENT-TYPE of STREAM should be (UNSIGNED-BYTE 8).
+
+If DIGEST is provided, the digest will be placed into DIGEST starting at
+DIGEST-START. DIGEST must be a (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*)).
+An error will be signaled if there is insufficient room in DIGEST.
+
+If BUFFER is provided, the portion of BUFFER between START and END will
+be used to hold data read from the stream."))
+
+(defmethod digest-stream ((digest-name symbol) stream &rest kwargs)
+ (apply #'digest-stream (make-digest digest-name) stream kwargs))
+
+(defmethod digest-stream (state stream &key buffer (start 0) end
+ digest (digest-start 0))
+ (update-digest-from-stream state stream
+ :buffer buffer :start start :end end)
+ (produce-digest state :digest digest :digest-start digest-start))
+
+(defgeneric digest-sequence (digest-spec sequence &rest args
+ &key start end digest digest-start)
+ (:documentation "Return the digest of the subsequence of SEQUENCE
+specified by START and END using the algorithm DIGEST-NAME. For CMUCL
+and SBCL, SEQUENCE can be any vector with an element-type
+of (UNSIGNED-BYTE 8); for other implementations, SEQUENCE must be a
+(SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*)).
+
+If DIGEST is provided, the digest will be placed into DIGEST starting at
+DIGEST-START. DIGEST must be a (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*)).
+An error will be signaled if there is insufficient room in DIGEST."))
+
+(defmethod digest-sequence ((digest-name symbol) sequence &rest kwargs)
+ (apply #'digest-sequence (make-digest digest-name) sequence kwargs))
+
+(defmethod digest-sequence (state sequence &key (start 0) end
+ digest (digest-start 0))
+ (declare (type (vector (unsigned-byte 8)) sequence) (type index start))
+ #+cmu
+ ;; respect the fill-pointer
+ (let ((end (or end (length sequence))))
+ (declare (type index end))
+ (lisp::with-array-data ((data sequence) (real-start start) (real-end end))
+ (declare (ignore real-end))
+ (update-digest state data
+ :start real-start :end (+ real-start (- end start)))))
+ #+sbcl
+ ;; respect the fill-pointer
+ (let ((end (or end (length sequence))))
+ (sb-kernel:with-array-data ((data sequence) (real-start start) (real-end end))
+ (declare (ignore real-end))
+ (update-digest state data
+ :start real-start :end (+ real-start (- end start)))))
+ #-(or cmu sbcl)
+ (let ((real-end (or end (length sequence))))
+ (declare (type index real-end))
+ (update-digest state sequence
+ :start start :end (or real-end (length sequence))))
+ (produce-digest state :digest digest :digest-start digest-start))
+
+;;; These four functions represent the common interface for digests in
+;;; other crypto toolkits (OpenSSL, Botan, Python, etc.). You obtain
+;;; some state object for a particular digest, you update it with some
+;;; data, and then you get the actual digest. Flexibility is the name
+;;; of the game with these functions.
+(defun make-digest (digest-name)
+ "Return a digest object which uses the algorithm DIGEST-NAME."
+ (typecase digest-name
+ (symbol
+ (let ((name (massage-symbol digest-name)))
+ (if (digestp name)
+ (funcall (the function (get name '%make-digest)))
+ (error 'unsupported-digest :name digest-name))))
+ (t
+ (error 'type-error :datum digest-name :expected-type 'symbol))))
+
+(defgeneric copy-digest (digester &optional copy)
+ (:documentation "Return a copy of DIGESTER. If COPY is not NIL, it
+should be of the same type as DIGESTER and will receive the copied data,
+rather than creating a new object. The copy is a deep copy, not a
+shallow copy as might be returned by COPY-STRUCTURE."))
+
+(defgeneric update-digest (digester thing &key &allow-other-keys)
+ (:documentation "Update the internal state of DIGESTER with THING.
+The exact method is determined by the type of THING."))
+
+(defgeneric produce-digest (digester &key digest digest-start)
+ (:documentation "Return the hash of the data processed by
+DIGESTER so far. This function modifies the internal state of DIGESTER.
+
+If DIGEST is provided, the hash will be placed into DIGEST starting at
+DIGEST-START. DIGEST must be a (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*)).
+An error will be signaled if there is insufficient room in DIGEST."))
+
+(defmethod produce-digest (digester &key digest (digest-start 0))
+ (finalize-digest digester digest digest-start))
+
+
+;;; the digest-defining macro
+
+(defclass digest ()
+ ((amount :accessor amount-processed :type (unsigned-byte 64)
+ :initform 0)
+ (buffer-index :accessor buffer-index :initform 0)
+ (finalized-p :accessor finalized-p :initform nil)))
+
+(defun digestp (sym)
+ (get sym '%digest-length))
+
+(defun list-all-digests ()
+ (loop for symbol being each external-symbol of (find-package :ironclad)
+ if (digestp symbol)
+ collect symbol))
+
+(defun digest-supported-p (name)
+ "Return T if the digest NAME is a valid digest name."
+ (and (symbolp name)
+ (not (cl:null (digestp name)))))
+
+(defgeneric digest-length (digest)
+ (:documentation "Return the number of bytes in a digest generated by DIGEST."))
+
+(defun massage-symbol (symbol)
+ (let ((package (symbol-package symbol))
+ (ironclad (load-time-value (find-package :ironclad))))
+ (cond
+ ((eq package ironclad) symbol)
+ ((eq package (load-time-value (find-package :keyword)))
+ (find-symbol (symbol-name symbol) ironclad))
+ (t nil))))
+
+(defmethod digest-length ((digest-name symbol))
+ (or (digestp (massage-symbol digest-name))
+ (error 'unsupported-digest :name digest-name)))
+
+(defmethod digest-length (digest-name)
+ (error 'unsupported-digest :name digest-name))
+
+(defmethod update-digest (digester (stream stream) &key buffer (start 0) end
+ &allow-other-keys)
+ (update-digest-from-stream digester stream
+ :buffer buffer :start start :end end))
+
+(defun optimized-maker-name (name)
+ (let ((*package* (find-package :ironclad)))
+ (intern (format nil "%MAKE-~A-DIGEST" name))))
+
+(defmacro defdigest (name &key digest-length block-length)
+ (let ((optimized-maker-name (optimized-maker-name name)))
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel)
+ (export ',name :ironclad))
+ (setf (get ',name '%digest-length) ,digest-length)
+ (setf (get ',name '%make-digest) (symbol-function ',optimized-maker-name))
+ (defmethod digest-length ((digest ,name))
+ ,digest-length)
+ (defmethod block-length ((digest ,name))
+ ,block-length))))
+
+;;; If we pass a constant argument to MAKE-DIGEST, convert the
+;;; MAKE-DIGEST call to a direct call to the state creation function.
+(define-compiler-macro make-digest (&whole form &environment env
+ name)
+ (declare (ignore env))
+ (cond
+ ((or (keywordp name)
+ (and (quotationp name) (symbolp name)))
+ (let ((name (massage-symbol (unquote name))))
+ (if (digestp name)
+ `(,(optimized-maker-name name))
+ form)))
+ (t form)))
+
+;;; And do the same for various one-shot digest functions.
+(defun maybe-expand-one-shot-call (form funname name 2nd-arg keys)
+ (cond
+ ((or (keywordp name)
+ (and (quotationp name) (symbolp name)))
+ (let ((name (massage-symbol (unquote name))))
+ (if (digestp name)
+ `(,funname (,(optimized-maker-name name)) ,2nd-arg ,@keys)
+ form)))
+ (t form)))
+
+(define-compiler-macro digest-sequence (&whole form &environment env
+ name sequence &rest keys)
+ (declare (ignore env))
+ (maybe-expand-one-shot-call form 'digest-sequence name sequence keys))
+
+(define-compiler-macro digest-stream (&whole form &environment env
+ name stream &rest keys)
+ (declare (ignore env))
+ (maybe-expand-one-shot-call form 'digest-stream name stream keys))
+
+(define-compiler-macro digest-file (&whole form &environment env
+ name file &rest keys)
+ (declare (ignore env))
+ (maybe-expand-one-shot-call form 'digest-file name file keys))
diff --git a/ironclad/package.lisp b/ironclad/package.lisp
new file mode 100644
index 0000000..d2f8814
--- /dev/null
+++ b/ironclad/package.lisp
@@ -0,0 +1,61 @@
+(cl:defpackage :ironclad
+ (:use :cl)
+ (:nicknames :crypto)
+ (:shadow null)
+ (:export
+ ;; referencing multiple-octet values in an octet vector (SETF-able)
+ #:ub16ref/be #:ub16ref/le #:ub32ref/be #:ub32ref/le #:ub64ref/le #:ub64ref/be
+
+ ;; hash functions
+ #:digest-sequence #:digest-stream #:digest-file
+ #:make-digest #:copy-digest #:update-digest #:produce-digest
+
+ ;; HMACs
+ #:make-hmac #:update-hmac #:hmac-digest
+ ;; CMACs
+ #:make-cmac #:update-cmac #:cmac-digest
+
+ ;; introspection
+ #:cipher-supported-p #:list-all-ciphers
+ #:digest-supported-p #:list-all-digests
+ #:mode-supported-p #:list-all-modes
+ #:block-length #:digest-length #:key-lengths
+
+ ;; high-level block cipher operators
+ #:make-cipher #:encrypt #:decrypt #:encrypt-in-place #:decrypt-in-place
+
+ ;; arguments to (MAKE-CIPHER ... :MODE X)
+ #:ecb #:cbc #:ctr #:ofb #:cfb #:stream
+
+ ;; KDFs
+ #:pbkdf1 #:pbkdf2
+ #:make-kdf #:derive-key
+
+ ;; public-key encryption operations
+ #:make-public-key #:make-private-key
+ #:sign-message #:verify-signature
+ #:encrypt-message #:decrypt-message
+
+ ;; signatures
+ #:make-dsa-signature
+
+ ;; public-key slot readers
+ #:dsa-key-p #:dsa-key-q #:dsa-key-g #:dsa-key-y #:dsa-key-x
+ #:dsa-signature-r #:dsa-signature-s
+
+ ;; conditions
+ #:ironclad-error #:initialization-vector-not-supplied
+ #:invalid-initialization-vector #:invalid-key-length
+ #:unsupported-cipher #:unsupported-mode #:unsupported-digest
+ #:insufficient-buffer-space #:invalid-padding
+ #:key-not-supplied
+
+ ;; utilities
+ #:ascii-string-to-byte-array #:byte-array-to-hex-string
+ #:octets-to-integer #:integer-to-octets #:expt-mod
+
+ ;; streams
+ #:make-octet-input-stream #:make-octet-output-stream
+ #:get-output-stream-octets
+
+ #:make-digesting-stream))
diff --git a/ironclad/sha1.lisp b/ironclad/sha1.lisp
new file mode 100644
index 0000000..712cce8
--- /dev/null
+++ b/ironclad/sha1.lisp
@@ -0,0 +1,237 @@
+;;;; This is an implementation of the US Secure Hash Algorithm 1 (SHA1),
+;;;; defined in RFC 3174, written by D. Eastlake and P. Jones, September
+;;;; 2001. The RFC was based on the document "Secure Hash Standard",
+;;;; United States of America, National Institute of Science and Technology,
+;;;; Federal Information Processing Standard (FIPS) 180-1, April 1993.
+;;;;
+;;;; It was written by Nathan J. Froyd, with many of the main ideas and
+;;;; functions grabbed from Pierre R. Mai's CL implementation of MD5,
+;;;; available at http://www.pmsf.de/pmai/MD5.html.
+;;;;
+;;;; This implementation should work on any conforming Common Lisp
+;;;; implementation, but it has been optimized for CMU CL and SBCL.
+;;;;
+;;;; The implementation makes heavy use of (UNSIGNED-BYTE 32) arithmetic;
+;;;; if your CL implementation does not implement unboxed arithmetic on
+;;;; such numbers, performance will likely be greater in a 16-bit
+;;;; implementation.
+;;;;
+;;;; This software is "as is", and has no warranty of any kind. The
+;;;; authors assume no responsibility for the consequences of any use
+;;;; of this software.
+
+(in-package :crypto)
+
+;;; nonlinear functions
+
+(defconstant +k1+ #x5a827999)
+(defconstant +k2+ #x6ed9eba1)
+(defconstant +k3+ #x8f1bbcdc)
+(defconstant +k4+ #xca62c1d6)
+
+;;; working set
+
+(define-digest-registers (sha1 :endian :big)
+ (a #x67452301)
+ (b #xefcdab89)
+ (c #x98badcfe)
+ (d #x10325476)
+ (e #xc3d2e1f0))
+
+(defconst +pristine-sha1-registers+ (initial-sha1-regs))
+
+(macrolet ((sha1-rounds (block func constant low high &rest initial-order)
+ ;; Yay for "implementation-dependent" behavior (6.1.1.4).
+ (let ((xvars (apply #'make-circular-list initial-order)))
+ (loop for i from low upto high
+ for vars on xvars by #'cddddr
+ collect (let ((a-var (first vars))
+ (b-var (second vars))
+ (c-var (third vars))
+ (d-var (fourth vars))
+ (e-var (fifth vars)))
+ `(setf ,e-var
+ (mod32+ (rol32 ,a-var 5)
+ (mod32+ (mod32+ (,func ,b-var ,c-var ,d-var) ,e-var)
+ (mod32+ (aref ,block ,i) ,constant)))
+ ,b-var (rol32 ,b-var 30))) into forms
+ finally (return `(progn ,@forms))))))
+(defun update-sha1-block (regs block)
+ (declare (type sha1-regs regs)
+ (type (simple-array (unsigned-byte 32) (80)) block)
+ #.(burn-baby-burn))
+ (let ((a (sha1-regs-a regs)) (b (sha1-regs-b regs))
+ (c (sha1-regs-c regs)) (d (sha1-regs-d regs))
+ (e (sha1-regs-e regs)))
+ (flet ((f1 (x y z)
+ (declare (type (unsigned-byte 32) x y z))
+ #+cmu
+ (kernel:32bit-logical-xor z
+ (kernel:32bit-logical-and x
+ (kernel:32bit-logical-xor y z)))
+ #-cmu
+ (logxor z (logand x (logxor y z))))
+ (f2 (x y z)
+ (declare (type (unsigned-byte 32) x y z))
+ #+cmu
+ (kernel:32bit-logical-xor x (kernel:32bit-logical-xor y z))
+ #-cmu
+ (ldb (byte 32 0) (logxor x y z)))
+ (f3 (x y z)
+ (declare (type (unsigned-byte 32) x y z))
+ #+cmu
+ (kernel:32bit-logical-or (kernel:32bit-logical-or
+ (kernel:32bit-logical-and x y)
+ (kernel:32bit-logical-and x z))
+ (kernel:32bit-logical-and y z))
+ #-cmu
+ (ldb (byte 32 0)
+ (logior (logand x y) (logand x z) (logand y z)))))
+ (declare (inline f1 f2 f3))
+ ;; core of the algorithm
+ (sha1-rounds block f1 +k1+ 0 19 a b c d e)
+ (sha1-rounds block f2 +k2+ 20 39 a b c d e)
+ (sha1-rounds block f3 +k3+ 40 59 a b c d e)
+ (sha1-rounds block f2 +k4+ 60 79 a b c d e)
+ ;; update and return
+ (setf (sha1-regs-a regs) (mod32+ (sha1-regs-a regs) a)
+ (sha1-regs-b regs) (mod32+ (sha1-regs-b regs) b)
+ (sha1-regs-c regs) (mod32+ (sha1-regs-c regs) c)
+ (sha1-regs-d regs) (mod32+ (sha1-regs-d regs) d)
+ (sha1-regs-e regs) (mod32+ (sha1-regs-e regs) e))
+ regs)))
+) ; MACROLET
+
+(declaim (inline expand-block))
+(defun expand-block (block)
+ "Expand the first 16 words in BLOCK to fill the entire 80 word space
+available."
+ (declare (type (simple-array (unsigned-byte 32) (80)) block)
+ #.(burn-baby-burn))
+ (loop for i of-type (integer 16 80) from 16 below 80
+ do (setf (aref block i)
+ (rol32 #+cmu
+ (kernel:32bit-logical-xor
+ (kernel:32bit-logical-xor (aref block (- i 3))
+ (aref block (- i 8)))
+ (kernel:32bit-logical-xor (aref block (- i 14))
+ (aref block (- i 16))))
+ #-cmu
+ (ldb (byte 32 0)
+ (logxor (aref block (- i 3))
+ (aref block (- i 8))
+ (aref block (- i 14))
+ (aref block (- i 16))))
+ 1))))
+
+;;; mid-level
+
+(defstruct (sha1
+ (:constructor %make-sha1-digest)
+ (:constructor %make-sha1-state (regs amount block buffer buffer-index))
+ (:copier nil))
+ (regs (initial-sha1-regs) :type sha1-regs :read-only t)
+ (amount 0 :type (unsigned-byte 64))
+ (block (make-array 80 :element-type '(unsigned-byte 32))
+ :type (simple-array (unsigned-byte 32) (80)) :read-only t)
+ (buffer (make-array 64 :element-type '(unsigned-byte 8))
+ :type (simple-array (unsigned-byte 8) (64)) :read-only t)
+ (buffer-index 0 :type (integer 0 63)))
+
+(defmethod reinitialize-instance ((state sha1) &rest initargs)
+ (declare (ignore initargs))
+ (replace (sha1-regs state) +pristine-sha1-registers+)
+ (setf (sha1-amount state) 0
+ (sha1-buffer-index state) 0)
+ state)
+
+(defmethod copy-digest ((state sha1) &optional copy)
+ (declare (type (or cl:null sha1) copy))
+ (cond
+ (copy
+ (replace (sha1-regs copy) (sha1-regs state))
+ (replace (sha1-buffer copy) (sha1-buffer state))
+ (setf (sha1-amount copy) (sha1-amount state)
+ (sha1-buffer-index copy) (sha1-buffer-index state))
+ copy)
+ (t
+ (%make-sha1-state (copy-seq (sha1-regs state))
+ (sha1-amount state)
+ (copy-seq (sha1-block state))
+ (copy-seq (sha1-buffer state))
+ (sha1-buffer-index state)))))
+
+(define-digest-updater sha1
+ (let ((regs (sha1-regs state))
+ (block (sha1-block state))
+ (buffer (sha1-buffer state))
+ (buffer-index (sha1-buffer-index state))
+ (length (- end start)))
+ (declare (type sha1-regs regs) (type fixnum length)
+ (type (integer 0 63) buffer-index)
+ (type (simple-array (unsigned-byte 32) (80)) block)
+ (type (simple-array (unsigned-byte 8) (64)) buffer))
+ ;; Handle old rest
+ (unless (zerop buffer-index)
+ (let ((amount (min (- 64 buffer-index) length)))
+ (declare (type (integer 0 63) amount))
+ (copy-to-buffer sequence start amount buffer buffer-index)
+ (setq start (the fixnum (+ start amount)))
+ (let ((new-index (mod (+ buffer-index amount) 64)))
+ (when (zerop new-index)
+ (fill-block-ub8-be block buffer 0)
+ (expand-block block)
+ (update-sha1-block regs block))
+ (when (>= start end)
+ (setf (sha1-buffer-index state) new-index)
+ (incf (sha1-amount state) length)
+ (return-from update-digest state)))))
+ (loop for offset of-type index from start below end by 64
+ until (< (- end offset) 64)
+ do
+ (fill-block-ub8-be block sequence offset)
+ (expand-block block)
+ (update-sha1-block regs block)
+ finally
+ (let ((amount (- end offset)))
+ (unless (zerop amount)
+ (copy-to-buffer sequence offset amount buffer 0))
+ (setf (sha1-buffer-index state) amount)))
+ (incf (sha1-amount state) length)
+ state))
+
+(define-digest-finalizer (sha1 20)
+ (let ((regs (sha1-regs state))
+ (block (sha1-block state))
+ (buffer (sha1-buffer state))
+ (buffer-index (sha1-buffer-index state))
+ (total-length (* 8 (sha1-amount state))))
+ (declare (type sha1-regs regs)
+ (type (integer 0 63) buffer-index)
+ (type (simple-array (unsigned-byte 32) (80)) block)
+ (type (simple-array (unsigned-byte 8) (64)) buffer))
+ (setf (aref buffer buffer-index) #x80)
+ (when (> buffer-index 55)
+ (loop for index of-type (integer 0 64)
+ from (1+ buffer-index) below 64
+ do (setf (aref buffer index) #x00))
+ (fill-block-ub8-be block buffer 0)
+ (expand-block block)
+ (update-sha1-block regs block)
+ (loop for index of-type (integer 0 16)
+ from 0 below 16
+ do (setf (aref block index) #x00000000)))
+ (when (<= buffer-index 55)
+ (loop for index of-type (integer 0 64)
+ from (1+ buffer-index) below 64
+ do (setf (aref buffer index) #x00))
+ ;; copy the data to BLOCK prematurely
+ (fill-block-ub8-be block buffer 0))
+ ;; fill in the remaining block data
+ (store-data-length block total-length 14 t)
+ (expand-block block)
+ (update-sha1-block regs block)
+ (finalize-registers state regs)))
+
+(defdigest sha1 :digest-length 20 :block-length 64)
+