First draft of SHA3-256 with minimal tests.

Probably full of fenceposts but this is all I have energy for at the
moment.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 36973f43ac2fa14cdf8b4ba612f4d734f9613e9d..ce5cac9bef620cbba20f726949cd9f6d90c1bf21 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -589,6 +589,15 @@ USA.
          quick-sort
          quick-sort!))
 
+(define-package (runtime sha3)
+  (files "sha3")
+  (parent (runtime))
+  (export ()
+         sha3256
+         sha3256-final
+         sha3256-init
+         sha3256-update))
+
 (define-package (runtime simple-queue)
   (files "queue")
   (parent (runtime))

diff --git a/src/runtime/sha3.scm b/src/runtime/sha3.scm
new file mode 100644 (file)
index 0000000..7427e02
--- /dev/null
+++ b/src/runtime/sha3.scm
@@ -0,0 +1,130 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; SHA-3: FIPS-202, Permutation-Based Hash and Extendable-Output Functions
+;;; package: (runtime sha3)
+
+(declare (usual-integrations))
+\f
+(define-primitives
+  (bytevector-keccak-f1600 1))
+
+(define-structure sha3
+  (state #f read-only #t)
+  nb)
+
+(define-integrable (sha3-rate-bytes db)
+  (- 200 (* 2 db)))
+
+(define-integrable (sha3-init rb)
+  (make-sha3 (make-bytevector 200 0) rb))
+
+(declare (integrate-operator sha3-update))
+(define (sha3-update sha3 bv start end rb)
+  (assert (< 0 (sha3-nb sha3)))
+  (let ((i (- rb (sha3-nb sha3)))
+        (ni (min (- end start) (sha3-nb sha3))))
+    ;; If there's a partial buffer, try to fill it.
+    (assert (<= 0 i))
+    (assert (< i rb))
+    (assert (<= 0 ni))
+    (assert (< ni rb))
+    (bytevector-xor! (sha3-state sha3) i bv start ni)
+    ;; If we couldn't fill the buffer, we're done.
+    (if (< ni (sha3-nb sha3))
+        (set-sha3-nb! sha3 (- (sha3-nb sha3) ni))
+        ;; Otherwise, permute and go on.
+        (begin
+          (bytevector-keccak-f1600 (sha3-state sha3))
+          ;; If we filled a buffer, permute now.
+          (let loop ((start (+ start ni)))
+            (if (<= start (- end rb))
+                ;; Xor a buffer's worth of input and permute.
+                (begin
+                  (bytevector-xor! (sha3-state sha3) 0 bv start rb)
+                  (bytevector-keccak-f1600 (sha3-state sha3))
+                  (loop (+ start rb)))
+                ;; Partially fill the buffer with as many bytes as we can.
+                (let ((nf (- end start)))
+                  (assert (< nf rb))
+                  (bytevector-xor! (sha3-state sha3) 0 bv start nf)
+                  (set-sha3-nb! sha3 (- rb nf)))))))))
+
+(define-integrable (sha3-final sha3 h hstart db rb)
+  (assert (<= db (* 8 25)))
+  (assert (< 0 (sha3-nb sha3)))
+  ;; Append 01, pad with 10*1 up to buffer boundary, LSB first.
+  (bytevector-u8-xor! (sha3-state sha3) (- rb (sha3-nb sha3)) #x06)
+  (bytevector-u8-xor! (sha3-state sha3) (- rb 1) #x80)
+  (bytevector-keccak-f1600 (sha3-state sha3))
+  ;; Reveal the first db bytes of states.
+  (bytevector-copy! h hstart (sha3-state sha3) 0 db)
+  ;; Forget the rest.  XXX Prevent optimizing away.
+  (bytevector-fill! (sha3-state sha3) 0)
+  (set-sha3-nb! sha3 0))
+
+(define-integrable (sha3256-rate-bytes) (sha3-rate-bytes 32))
+\f
+(define (sha3256 bv)
+  (let ((s (sha3256-init))
+        (h (make-bytevector 32)))
+    (sha3256-update s bv 0 (bytevector-length bv))
+    (sha3256-final s h 0 32)
+    h))
+
+(define (sha3256-init)
+  (sha3-init (sha3256-rate-bytes)))
+
+(define (sha3256-update sha3256 bv start end)
+  (sha3-update sha3256 bv start end (sha3256-rate-bytes)))
+
+(define (sha3256-final sha3256 bv start end)
+  (sha3-final sha3256 bv start (- end start) (sha3256-rate-bytes)))
+
+(define (bytevector-u8-xor! bv i x)
+  ;;(declare (no-type-checks) (no-range-checks))
+  (guarantee bytevector? bv 'BYTEVECTOR-U8-XOR!)
+  (guarantee index-fixnum? i 'BYTEVECTOR-U8-XOR!)
+  (if (not (fix:< i (bytevector-length bv)))
+      (error:bad-range-argument i 'BYTEVECTOR-U8-XOR!))
+  (guarantee u8? x 'BYTEVECTOR-U8-XOR)
+  (bytevector-u8-set! bv i (fix:xor x (bytevector-u8-ref bv i))))
+
+(define (bytevector-xor! t ts f fs n)
+  ;;(declare (no-type-checks) (no-range-checks))
+  (guarantee bytevector? f 'BYTEVECTOR-XOR!)
+  (guarantee bytevector? t 'BYTEVECTOR-XOR!)
+  (guarantee index-fixnum? ts 'BYTEVECTOR-XOR!)
+  (guarantee index-fixnum? fs 'BYTEVECTOR-XOR!)
+  (if (not (fix:<= n (fix:- (bytevector-length t) ts)))
+      (error:bad-range-argument ts 'BYTEVECTOR-XOR!))
+  (if (not (fix:<= n (fix:- (bytevector-length f) fs)))
+      (error:bad-range-argument fs 'BYTEVECTOR-XOR!))
+  (do ((i 0 (fix:+ i 1))) ((fix:>= i n))
+    (let ((ti (bytevector-u8-ref t (fix:+ ts i)))
+          (fi (bytevector-u8-ref f (fix:+ fs i))))
+      (declare (integrate ti fi))
+      (bytevector-u8-set! t (fix:+ ts i) (fix:xor ti fi)))))

diff --git a/tests/check.scm b/tests/check.scm
index 224eb04401c551dc6157597d8dfe6097d8799500..23976a39f77e13f45590d341de8561624969e854 100644 (file)
--- a/tests/check.scm
+++ b/tests/check.scm
@@ -70,6 +70,7 @@ USA.
     "runtime/test-readwrite"
     "runtime/test-regsexp"
     "runtime/test-rgxcmp"
+    "runtime/test-sha3"
     "runtime/test-string"
     "runtime/test-string-normalization"
     "runtime/test-string-search"

diff --git a/tests/runtime/test-sha3.scm b/tests/runtime/test-sha3.scm
new file mode 100644 (file)
index 0000000..bd4553f
--- /dev/null
+++ b/tests/runtime/test-sha3.scm
@@ -0,0 +1,47 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Tests of SHA-3 functions
+
+(define-test 'SHA3-256-EMPTY
+  (lambda ()
+    (assert-equal (sha3256 #u8())
+                  #u8(
+                      #xa7 #xff #xc6 #xf8 #xbf #x1e #xd7 #x66
+                      #x51 #xc1 #x47 #x56 #xa0 #x61 #xd6 #x62
+                      #xf5 #x80 #xff #x4d #xe4 #x3b #x49 #xfa
+                      #x82 #xd8 #x0a #x4b #x80 #xf8 #x43 #x4a
+                      ))))
+
+(define-test 'SHA3-256-HELLOWORLD
+  (lambda ()
+    (assert-equal (sha3256 (string->utf8 "hello world"))
+                  #u8(
+                      #x64 #x4b #xcc #x7e #x56 #x43 #x73 #x04
+                      #x09 #x99 #xaa #xc8 #x9e #x76 #x22 #xf3
+                      #xca #x71 #xfb #xa1 #xd9 #x72 #xfd #x94
+                      #xa3 #x1c #x3b #xfb #xf2 #x4e #x39 #x38
+                      ))))
\ No newline at end of file