Coverage report: /home/ellis/comp/core/lib/cry/crc64.lisp

Kind	Covered	All	%
expression	85	196	43.4
branch	2	4	50.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

2

3

;;; Redistribution and use in source and binary forms, with or without

4

;;; modification, are permitted provided that the following conditions

5

;;; are met:

6

7

;;; * Redistributions of source code must retain the above copyright

8

;;; notice, this list of conditions and the following disclaimer.

9

10

;;; * Redistributions in binary form must reproduce the above

11

;;; copyright notice, this list of conditions and the following

12

;;; disclaimer in the documentation and/or other materials

13

;;; provided with the distribution.

14

15

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED

16

;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED

17

;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE

18

;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY

19

;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL

20

;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE

21

;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS

22

;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,

23

;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING

24

;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS

25

;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

26

(in-package :cry/crc64)

27

28

;; The polynomial used in the original SWISS / PROT.

29

(declaim (type (unsigned-byte 64) +polynomial+ +improved-polynomial+))

30

(defconstant +polynomial+ #xd800000000000000)

31

32

;; Improved calculation of CRC-64 values for protein sequences

33

;; By David T. Jones (dtj@cs.ucl.ac.uk)

34

(defconstant +improved-polynomial+ #x95AC9329AC4BC9B)

35

36

;; Lookup tables.

37

;; We store high and low order bytes separately to benefit from

38

;; 32 bit arithmentic performance.

39

40

(declaim (type (array (unsigned-byte 32) (256)) *crc-table-h* *crc-table-l*))

41

(defvar *crc-table-h* (make-array 256 :element-type '(unsigned-byte 32)))

42

(defvar *crc-table-l* (make-array 256 :element-type '(unsigned-byte 32)))

43

44

(defun init-crc64 (polynomial)

45

"Computes lookup tables of CRC values for byte values 0 thru 255. Don't

46

forget to call this before calling the library functions."

47

(dotimes (i 256)

48

(let ((part i))

49

(dotimes (j 8)

50

(if (eql (logand part 1) 1)

51

(setf part (logxor (ash part -1) polynomial))

52

(setf part (ash part -1))))

53

(setf (aref *crc-table-h* i) (ash (logand part #xFFFFFFFF00000000) -32))

54

(setf (aref *crc-table-l* i) (logand part #xFFFFFFFF)))))

55

56

(defun crc64-file (pathname)

57

"Calculates the CRC64 of the file specified by pathname."

58

(declare (optimize (speed 3) (space 0) (debug 0)))

59

(with-open-file (stream pathname :element-type '(unsigned-byte 8))

60

(crc64-stream stream)))

61

62

(defun crc64-sequence (sequence &key (initial-crc 0) (start 0)

63

(end (length sequence)))

64

"Calculates the CRC64 from sequence, which is either a

65

simple-string or a simple-array with element-type \(unsigned-byte 8)"

66

(declare (type (simple-array * (*)) sequence)

67

(type fixnum start end initial-crc)

68

(optimize (speed 3) (space 0) (debug 0)))

69

70

(let ((crch (logand (ash initial-crc -32) #xFFFFFFFF))

71

(crcl (logand initial-crc #xFF))

72

(table-index 0))

73

(declare (type (unsigned-byte 32) crch)

74

(type (unsigned-byte 32) crcl)

75

(type (unsigned-byte 8) table-index))

76

77

(etypecase sequence

78

79

((simple-array (unsigned-byte 8) (*))

80

(locally

81

(declare (type (simple-array (unsigned-byte 8) (*)) sequence))

82

(loop for n from start below end do

83

(setf table-index (logand (logxor crcl (aref sequence n)) #xFF))

84

(setf crcl (logxor (logior (ash crcl -8)

85

(ash (logand crch #xFF) 24))

86

(the (unsigned-byte 32)

87

(aref *crc-table-l* table-index))))

88

(setf crch (logxor (ash crch -8)

89

(the (unsigned-byte 32)

90

(aref *crc-table-h* table-index)))))))

91

92

(simple-string

93

(locally

94

(declare (type simple-string sequence))

95

(loop for n from start below end do

96

(setf table-index (logand (logxor crcl

97

                                                 (char-code (aref sequence n)))

98

#xFF))

99

(setf crcl (logxor (logior (ash crcl -8)

100

                                          (ash (logand crch #xFF) 24))

101

(the (unsigned-byte 32)

102

(aref *crc-table-l* table-index))))

103

(setf crch (logxor (ash crch -8)

104

(the (unsigned-byte 32)

105

(aref *crc-table-h* table-index))))))))

106

107

(+ (ash crch 32) crcl)))

108

109

(defun crc64-stream (stream &key (initial-crc 0))

110

"Calculates the CRC64 on the given stream."

111

(declare (optimize (speed 3) (space 0) (debug 0))

112

(type (unsigned-byte 64) initial-crc))

113

(let ((crch (logand (ash initial-crc -32) #xFFFFFFFF))

114

(crcl (logand initial-crc #xFF))

115

(table-index 0)

116

(b 0))

117

(declare (type (unsigned-byte 32) crch)

118

(type (unsigned-byte 32) crcl)

119

(type (unsigned-byte 8) table-index))

120

(loop while (setf b (read-byte stream nil nil)) do

121

(setf table-index (logand (logxor crcl b) #xFF))

122

(setf crcl (logxor (logior (ash crcl -8)

123

(ash (logand crch #xFF) 24))

124

(the (unsigned-byte 32)

125

(aref *crc-table-l* table-index))))

126

(setf crch (logxor (ash crch -8)

127

(the (unsigned-byte 32)

128

(aref *crc-table-h* table-index)))))

129

130

(+ (ash crch 32) crcl)))