OSCL/md5
2
0
Fork 0
mirror of https://github.com/pmai/md5.git synced 2025-12-21 14:34:29 +01:00
Code Issues Packages Projects Releases Wiki Activity

First release that works on big-endian CMU CL releases. Should also work

Browse Source 
on other ANSI CL implementations, but quite suboptimally, of course.
This commit is contained in:
Pierre R. Mai
2001-11-14 23:53:48 +01:00
parent 576ae1de32
commit c4a361dd23
1 changed files with 80 additions and 38 deletions
Download Patch File Download Diff File Expand all files Collapse all files

118
md5.lisp
View File

@ -14,10 +14,36 @@
(in-package :MD5) (in-package :MD5)
#+cmu
(eval-when (:compile-toplevel) (eval-when (:compile-toplevel)
(defparameter *old-expansion-limit* ext:*inline-expansion-limit*) (defparameter *old-expansion-limit* ext:*inline-expansion-limit*)
(setq ext:*inline-expansion-limit* (max ext:*inline-expansion-limit* 1000))) (setq ext:*inline-expansion-limit* (max ext:*inline-expansion-limit* 1000)))
;;; Big-Endian/Little-Endian stuff
#+cmu
(eval-when (:compile-toplevel :execute)
(defparameter *old-features* *features*)
(pushnew (c:backend-byte-order c:*target-backend*) *features*))
#+(and :cmu :big-endian)
(defmacro assemble-ub32 (a b c d)
`(ext:truly-the ub32 (logior (kernel:shift-towards-start ,d 24)
(kernel:shift-towards-start ,c 16)
(kernel:shift-towards-start ,b 8)
,a)))
#+(and :cmu :little-endian)
(defmacro assemble-ub32 (a b c d)
`(ext:truly-the ub32 (logior (kernel:shift-towards-end ,d 24)
(kernel:shift-towards-end ,c 16)
(kernel:shift-towards-end ,b 8)
,a)))
#-cmu
(defmacro assemble-ub32 (a b c d)
`(the ub32 (logior (ash ,d 24) (ash ,c 16) (ash ,b 8) ,a)))
;;; Section 3.4: Auxilliary functions ;;; Section 3.4: Auxilliary functions
(deftype ub32 () `(unsigned-byte 32)) (deftype ub32 () `(unsigned-byte 32))
@ -28,37 +54,57 @@
(defun f (x y z) (defun f (x y z)
(declare (type ub32 x y z) (declare (type ub32 x y z)
(optimize (speed 3) (safety 0) (space 0) (debug 0))) (optimize (speed 3) (safety 0) (space 0) (debug 0)))
#+cmu
(kernel:32bit-logical-or (kernel:32bit-logical-and x y) (kernel:32bit-logical-or (kernel:32bit-logical-and x y)
(kernel:32bit-logical-andc1 x z))) (kernel:32bit-logical-andc1 x z))
#-cmu
(logior (logand x y) (logandc1 x z)))
(defun g (x y z) (defun g (x y z)
(declare (type ub32 x y z) (declare (type ub32 x y z)
(optimize (speed 3) (safety 0) (space 0) (debug 0))) (optimize (speed 3) (safety 0) (space 0) (debug 0)))
#+cmu
(kernel:32bit-logical-or (kernel:32bit-logical-and x z) (kernel:32bit-logical-or (kernel:32bit-logical-and x z)
(kernel:32bit-logical-andc2 y z))) (kernel:32bit-logical-andc2 y z))
#-cmu
(logior (logand x z) (logandc2 y z)))
(defun h (x y z) (defun h (x y z)
(declare (type ub32 x y z) (declare (type ub32 x y z)
(optimize (speed 3) (safety 0) (space 0) (debug 0))) (optimize (speed 3) (safety 0) (space 0) (debug 0)))
(kernel:32bit-logical-xor x (kernel:32bit-logical-xor y z))) #+cmu
(kernel:32bit-logical-xor x (kernel:32bit-logical-xor y z))
#-cmu
(logxor x y z))
(defun i (x y z) (defun i (x y z)
(declare (type ub32 x y z) (declare (type ub32 x y z)
(optimize (speed 3) (safety 0) (space 0) (debug 0))) (optimize (speed 3) (safety 0) (space 0) (debug 0)))
(kernel:32bit-logical-xor y (kernel:32bit-logical-orc2 x z))) #+cmu
(kernel:32bit-logical-xor y (kernel:32bit-logical-orc2 x z))
#-cmu
(logxor y (logorc2 x z)))
(declaim (inline mod32+ rol32) (declaim (inline mod32+)
(ftype (function (ub32 ub32) ub32) mod32+)) (ftype (function (ub32 ub32) ub32) mod32+))
(defun mod32+ (a b) (defun mod32+ (a b)
(declare (type ub32 a b) (optimize (speed 3) (safety 0) (space 0) (debug 0))) (declare (type ub32 a b) (optimize (speed 3) (safety 0) (space 0) (debug 0)))
(ext:truly-the ub32 (+ a b))) #+cmu
(ext:truly-the ub32 (+ a b))
#-cmu
(ldb (byte 32 0) (+ a b)))
(declaim (ftype (function (ub32 (unsigned-byte 5)) ub32) rol32)) (declaim (inline rol32)
(ftype (function (ub32 (unsigned-byte 5)) ub32) rol32))
(defun rol32 (a s) (defun rol32 (a s)
(declare (type ub32 a) (type (unsigned-byte 5) s) (declare (type ub32 a) (type (unsigned-byte 5) s)
(optimize (speed 3) (safety 0) (space 0) (debug 0))) (optimize (speed 3) (safety 0) (space 0) (debug 0)))
(kernel:32bit-logical-or (kernel:shift-towards-end a s) #+cmu
(ash a (- s 32)))) (kernel:32bit-logical-or #+little-endian (kernel:shift-towards-end a s)
#+big-endian (kernel:shift-towards-start a s)
(ash a (- s 32)))
#-cmu
(logior (ldb (byte 32 0) (ash a s)) (ash a (- s 32))))
(eval-when (:compile-toplevel :load-toplevel :execute) (eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *t* (make-array 64 :element-type 'ub32 (defparameter *t* (make-array 64 :element-type 'ub32
@ -156,12 +202,12 @@
(type (simple-array ub32 (16)) block) (type (simple-array ub32 (16)) block)
(type (simple-array * (*)) buffer) (type (simple-array * (*)) buffer)
(optimize (speed 3) (safety 0) (space 0) (debug 0))) (optimize (speed 3) (safety 0) (space 0) (debug 0)))
#+(and cmu x86) #+(and :cmu :little-endian)
(kernel:bit-bash-copy (kernel:bit-bash-copy
buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits)) buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits))
block (* vm:vector-data-offset vm:word-bits) block (* vm:vector-data-offset vm:word-bits)
(* 64 vm:byte-bits)) (* 64 vm:byte-bits))
#-(and cmu x86) #-(and :cmu :little-endian)
(etypecase buffer (etypecase buffer
((simple-array (unsigned-byte 8) (*)) ((simple-array (unsigned-byte 8) (*))
(fill-block-ub8 block buffer offset)) (fill-block-ub8 block buffer offset))
@ -173,52 +219,42 @@
(type (simple-array ub32 (16)) block) (type (simple-array ub32 (16)) block)
(type (simple-array (unsigned-byte 8) (*)) buffer) (type (simple-array (unsigned-byte 8) (*)) buffer)
(optimize (speed 3) (safety 0) (space 0) (debug 0))) (optimize (speed 3) (safety 0) (space 0) (debug 0)))
#+(and cmu x86) #+(and :cmu :little-endian)
(kernel:bit-bash-copy (kernel:bit-bash-copy
buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits)) buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits))
block (* vm:vector-data-offset vm:word-bits) block (* vm:vector-data-offset vm:word-bits)
(* 64 vm:byte-bits)) (* 64 vm:byte-bits))
#-(and cmu x86) #-(and :cmu :little-endian)
(loop for i of-type (integer 0 16) from 0 (loop for i of-type (integer 0 16) from 0
for j of-type (integer 0 #.most-positive-fixnum) for j of-type (integer 0 #.most-positive-fixnum)
from offset to (+ offset 63) by 4 from offset to (+ offset 63) by 4
do do
(setf (aref block i) (setf (aref block i)
(ext:truly-the ub32 (assemble-ub32 (aref buffer j)
(logior (aref buffer (+ j 1))
(kernel:shift-towards-end (aref buffer (+ j 2))
(aref buffer (+ j 3)) 24) (aref buffer (+ j 3))))))
(kernel:shift-towards-end
(aref buffer (+ j 2)) 16)
(kernel:shift-towards-end
(aref buffer (+ j 1)) 8)
(aref buffer j))))))
(defun fill-block-char (block buffer offset) (defun fill-block-char (block buffer offset)
(declare (type (integer 0 #.(- most-positive-fixnum 64)) offset) (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset)
(type (simple-array ub32 (16)) block) (type (simple-array ub32 (16)) block)
(type simple-string buffer) (type simple-string buffer)
(optimize (speed 3) (safety 0) (space 0) (debug 0))) (optimize (speed 3) (safety 0) (space 0) (debug 0)))
#+(and cmu x86) #+(and :cmu :little-endian)
(kernel:bit-bash-copy (kernel:bit-bash-copy
buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits)) buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits))
block (* vm:vector-data-offset vm:word-bits) block (* vm:vector-data-offset vm:word-bits)
(* 64 vm:byte-bits)) (* 64 vm:byte-bits))
#-(and cmu x86) #-(and :cmu :little-endian)
(loop for i of-type (integer 0 16) from 0 (loop for i of-type (integer 0 16) from 0
for j of-type (integer 0 #.most-positive-fixnum) for j of-type (integer 0 #.most-positive-fixnum)
from offset to (+ offset 63) by 4 from offset to (+ offset 63) by 4
do do
(setf (aref block i) (setf (aref block i)
(ext:truly-the ub32 (assemble-ub32 (char-code (schar buffer j))
(logior (char-code (schar buffer (+ j 1)))
(kernel:shift-towards-end (char-code (schar buffer (+ j 2)))
(char-code (schar buffer (+ j 3))) 24) (char-code (schar buffer (+ j 3)))))))
(kernel:shift-towards-end
(char-code (schar buffer (+ j 2))) 16)
(kernel:shift-towards-end
(char-code (schar buffer (+ j 1))) 8)
(char-code (schar buffer j)))))))
(declaim (inline md5regs-checksum)) (declaim (inline md5regs-checksum))
(defun md5regs-checksum (regs) (defun md5regs-checksum (regs)
@ -261,13 +297,13 @@
(type (integer 0 63) count buffer-offset) (type (integer 0 63) count buffer-offset)
(type (simple-array * (*)) from) (type (simple-array * (*)) from)
(type (simple-array (unsigned-byte 8) (64)) buffer)) (type (simple-array (unsigned-byte 8) (64)) buffer))
#+(and cmu x86) #+cmu
(kernel:bit-bash-copy (kernel:bit-bash-copy
from (+ (* vm:vector-data-offset vm:word-bits) (* from-offset vm:byte-bits)) from (+ (* vm:vector-data-offset vm:word-bits) (* from-offset vm:byte-bits))
buffer (+ (* vm:vector-data-offset vm:word-bits) buffer (+ (* vm:vector-data-offset vm:word-bits)
(* buffer-offset vm:byte-bits)) (* buffer-offset vm:byte-bits))
(* count vm:byte-bits)) (* count vm:byte-bits))
#-(and cmu x86) #-cmu
(etypecase from (etypecase from
(simple-string (simple-string
(loop for buffer-index of-type (integer 0 64) from buffer-offset (loop for buffer-index of-type (integer 0 64) from buffer-offset
@ -381,8 +417,9 @@
(declare (type md5-state state)) (declare (type md5-state state))
(cond (cond
((equal (stream-element-type stream) '(unsigned-byte 8)) ((equal (stream-element-type stream) '(unsigned-byte 8))
(let ((buffer (make-array +buffer-size+ :element-type '(unsigned-byte 8)))) (let ((buffer (make-array +buffer-size+
(declare (type (simple-array (unsigned-byte 8) (#.md5::+buffer-size+)) :element-type '(unsigned-byte 8))))
(declare (type (simple-array (unsigned-byte 8) (#.+buffer-size+))
buffer)) buffer))
(loop for bytes of-type buffer-index = (read-sequence buffer stream) (loop for bytes of-type buffer-index = (read-sequence buffer stream)
do (update-md5-state state buffer :end bytes) do (update-md5-state state buffer :end bytes)
@ -391,7 +428,7 @@
(return (finalize-md5-state state))))) (return (finalize-md5-state state)))))
((equal (stream-element-type stream) 'character) ((equal (stream-element-type stream) 'character)
(let ((buffer (make-string +buffer-size+))) (let ((buffer (make-string +buffer-size+)))
(declare (type (simple-string #.md5::+buffer-size+) buffer)) (declare (type (simple-string #.+buffer-size+) buffer))
(loop for bytes of-type buffer-index = (read-sequence buffer stream) (loop for bytes of-type buffer-index = (read-sequence buffer stream)
do (update-md5-state state buffer :end bytes) do (update-md5-state state buffer :end bytes)
until (< bytes +buffer-size+) until (< bytes +buffer-size+)
@ -406,5 +443,10 @@
(with-open-file (stream pathname :element-type '(unsigned-byte 8)) (with-open-file (stream pathname :element-type '(unsigned-byte 8))
(md5sum-stream stream))) (md5sum-stream stream)))
#+cmu
(eval-when (:compile-toplevel) (eval-when (:compile-toplevel)
(setq ext:*inline-expansion-limit* *old-expansion-limit*)) (setq ext:*inline-expansion-limit* *old-expansion-limit*))
#+cmu
(eval-when (:compile-toplevel :execute)
(setq *features* *old-features*))