changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/lib/cry/crc64.lisp

changeset 698: 96958d3eb5b0
parent: 2596311106ae
author: Richard Westhaver <ellis@rwest.io>
date: Fri, 04 Oct 2024 22:04:59 -0400
permissions: -rw-r--r--
description: fixes 
     1 ;;; Copyright (c) 2008, Rob Blackwell.  All rights reserved.
     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)))