Add Ironclad to the repository.

Ignore-this: b593d6a88f692903b98053c1142a6290

darcs-hash:c2e554362d9434a1cc8a0be9e8952d61f6cd4bb4

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)
+