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

Add support for LispWorks 7.0, fix supplied by Martin Simmons.

Browse Source
This commit is contained in:
Pierre R. Mai
2015-05-20 10:53:12 +02:00
parent 9d6f82f712
commit 4af543b3d3
2 changed files with 33 additions and 20 deletions
Download Patch File Download Diff File Expand all files Collapse all files

9
NEWS Normal file → Executable file
View File

@ -1,3 +1,12 @@
Release 2.0.2
=============
* This release adds support for LispWorks 7.0, reworking the fixes
for 64-bit implementations of Lispworks in 2.0.1 and incorrect
use of the sys:simple-int32-vector type. Patch supplied by
Martin Simmons from LispWorks.
Release 2.0.1 Release 2.0.1
============= =============

44
md5.lisp
View File

@ -87,7 +87,14 @@
#+(and :lispworks (or (not :lispworks4) :lispworks4.4)) #+(and :lispworks (or (not :lispworks4) :lispworks4.4))
(eval-when (:compile-toplevel :execute) (eval-when (:compile-toplevel :execute)
(defparameter *old-features* *features*) (defparameter *old-features* *features*)
(pushnew :lw-int32 *features*)) (pushnew :lw-int32 *features*)
(defmacro lw-int32-no-overflow (value)
;; Prevent overflow in 64-bit prior to LispWorks 7.0.
#+(and :lispworks-64bit (or :lispworks5 :lispworks6))
`(sys:int32>> (sys:int32<< ,value #.(sys:integer-to-int32 32))
#.(sys:integer-to-int32 32))
#-(and :lispworks-64bit (or :lispworks5 :lispworks6))
value))
;;; Section 2: Basic Datatypes ;;; Section 2: Basic Datatypes
@ -101,14 +108,16 @@
"Assemble an ub32 value from the given (unsigned-byte 8) values, "Assemble an ub32 value from the given (unsigned-byte 8) values,
where a is the intended low-order byte and d the high-order byte." where a is the intended low-order byte and d the high-order byte."
#+lw-int32 #+lw-int32
`(sys:int32-logior (sys:int32<< ,d 24) `(lw-int32-no-overflow
(sys:int32-logior (sys:int32<< ,c 16) (sys:int32-logior (sys:int32<< ,d 24)
(sys:int32-logior (sys:int32<< ,b 8) ,a))) (sys:int32-logior (sys:int32<< ,c 16)
(sys:int32-logior (sys:int32<< ,b 8) ,a))))
#-lw-int32 #-lw-int32
`(the ub32 (logior (ash ,d 24) (ash ,c 16) (ash ,b 8) ,a)))) `(the ub32 (logior (ash ,d 24) (ash ,c 16) (ash ,b 8) ,a))))
(deftype ub32-vector (length) (deftype ub32-vector (length)
#+lw-int32 `(sys:simple-int32-vector ,length) #+lw-int32 (declare (ignore length))
#+lw-int32 'sys:simple-int32-vector
#-lw-int32 `(simple-array (unsigned-byte 32) (,length))) #-lw-int32 `(simple-array (unsigned-byte 32) (,length)))
(defmacro make-ub32-vector (length &rest args) (defmacro make-ub32-vector (length &rest args)
@ -163,11 +172,8 @@ where a is the intended low-order byte and d the high-order byte."
(optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0))) (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0)))
#+cmu #+cmu
(kernel:32bit-logical-xor y (kernel:32bit-logical-orc2 x z)) (kernel:32bit-logical-xor y (kernel:32bit-logical-orc2 x z))
#+(and :lw-int32 (not :lispworks-64bit)) #+lw-int32
(sys:int32-logxor y (sys:int32-logorc2 x z)) (lw-int32-no-overflow (sys:int32-logxor y (sys:int32-logorc2 x z)))
#+(and :lw-int32 :lispworks-64bit)
(sys:int32-logand #.(sys:int32-1+ (sys:int32<< (sys:integer-to-int32 #x7FFFFFFF) 1))
(sys:int32-logxor y (sys:int32-logorc2 x z)))
#-(or :cmu :lw-int32) #-(or :cmu :lw-int32)
(ldb (byte 32 0) (logxor y (logorc2 x z)))) (ldb (byte 32 0) (logxor y (logorc2 x z))))
@ -176,11 +182,8 @@ where a is the intended low-order byte and d the high-order byte."
(defun mod32+ (a b) (defun mod32+ (a b)
(declare (type ub32 a b) (declare (type ub32 a b)
(optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0))) (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0)))
#+(and :lw-int32 (not :lispworks-64bit)) #+lw-int32
(sys:int32+ a b) (lw-int32-no-overflow (sys:int32+ a b))
#+(and :lw-int32 :lispworks-64bit)
(sys:int32-logand #.(sys:int32-1+ (sys:int32<< (sys:integer-to-int32 #x7FFFFFFF) 1))
(sys:int32+ a b))
#-lw-int32 #-lw-int32
(ldb (byte 32 0) (+ a b))) (ldb (byte 32 0) (+ a b)))
@ -216,11 +219,8 @@ where a is the intended low-order byte and d the high-order byte."
(ash a (- s 32))) (ash a (- s 32)))
#+sbcl #+sbcl
(sb-rotate-byte:rotate-byte s (byte 32 0) a) (sb-rotate-byte:rotate-byte s (byte 32 0) a)
#+(and :lw-int32 (not :lispworks-64bit)) #+lw-int32
(sys:int32-logior (sys:int32<< a s) (int32>>logical a (- 32 s))) (sys:int32-logior (lw-int32-no-overflow (sys:int32<< a s))
#+(and :lw-int32 :lispworks-64bit)
(sys:int32-logior (sys:int32-logand #.(sys:int32-1+ (sys:int32<< (sys:integer-to-int32 #x7FFFFFFF) 1))
(sys:int32<< a s))
(int32>>logical a (- 32 s))) (int32>>logical a (- 32 s)))
#-(or :cmu :sbcl :lw-int32) #-(or :cmu :sbcl :lw-int32)
(logior (ldb (byte 32 0) (ash a s)) (ash a (- s 32)))) (logior (ldb (byte 32 0) (ash a s)) (ash a (- s 32))))
@ -456,6 +456,9 @@ in `regs'. Returns a (simple-array (unsigned-byte 8) (16))."
;;; Mid-Level Drivers ;;; Mid-Level Drivers
(locally
(declare (optimize (speed 3) (safety 1) (space 0) (debug 1)
#+lw-int32 (float 0)))
(defstruct (md5-state (defstruct (md5-state
(:constructor make-md5-state ()) (:constructor make-md5-state ())
(:copier)) (:copier))
@ -468,6 +471,7 @@ in `regs'. Returns a (simple-array (unsigned-byte 8) (16))."
:type (simple-array (unsigned-byte 8) (64))) :type (simple-array (unsigned-byte 8) (64)))
(buffer-index 0 :type (integer 0 63)) (buffer-index 0 :type (integer 0 63))
(finalized-p nil)) (finalized-p nil))
)
(declaim (inline copy-to-buffer)) (declaim (inline copy-to-buffer))
(defun copy-to-buffer (from from-offset count buffer buffer-offset) (defun copy-to-buffer (from from-offset count buffer buffer-offset)