crc.scm

;;;; "crc.scm" Compute Cyclic Checksums
;;; Copyright (C) 1995, 1996, 1997, 2001, 2002 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
;granted, subject to the following restrictions and understandings.
;
;1.  Any copy made of this software must include this copyright notice
;in full.
;
;2.  I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3.  In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.

(require 'byte)
(require 'logical)

;;@ (define CRC-32-polynomial    "100000100100000010001110110110111") ; IEEE-802, FDDI
(define CRC-32-polynomial    "100000100110000010001110110110111") ; IEEE-802, AAL5
;@
(define CRC-CCITT-polynomial "10001000000100001")	; X25
;@
(define CRC-16-polynomial    "11000000000000101")	; IBM Bisync, HDLC, SDLC, USB-Data

;;@ (define CRC-12-polynomial    "1100000001101")
(define CRC-12-polynomial    "1100000001111")

;;@ (define CRC-10-polynomial   "11000110001")
(define CRC-10-polynomial   "11000110011")
;@
(define CRC-08-polynomial    "100000111")
;@
(define ATM-HEC-polynomial   "100000111")
;@
(define DOWCRC-polynomial    "100110001")
;@
(define USB-Token-polynomial "100101")

;;This procedure is careful not to use more than DEG bits in
;;computing (- (expt 2 DEG) 1).  It returns #f if the integer would
;;be larger than the implementation supports.
(define (crc:make-mask deg)
  (string->number (make-string deg #\1) 2))
;@
(define (crc:make-table str)
  (define deg (+ -1 (string-length str)))
  (define generator (string->number (substring str 1 (string-length str)) 2))
  (define crctab (make-vector 256))
  (if (not (eqv? #\1 (string-ref str 0)))
      (slib:error 'crc:make-table 'first-digit-of-polynomial-must-be-1 str))
  (if (< deg 8)
      (slib:error 'crc:make-table 'degree-must-be>7 deg str))
  (and
   generator
   (do ((i 0 (+ 1 i))
	(deg-1-mask (crc:make-mask (+ -1 deg)))
	(gen generator
	     (if (logbit? (+ -1 deg) gen)
		 (logxor (ash (logand deg-1-mask gen) 1) generator)
		 (ash (logand deg-1-mask gen) 1)))
	(gens '() (cons gen gens)))
       ((>= i 8) (set! gens (reverse gens))
	(do ((crc 0 0)
	     (m 0 (+ 1 m)))
	    ((> m 255) crctab)
	  (for-each (lambda (gen i)
		      (set! crc (if (logbit? i m) (logxor crc gen) crc)))
		    gens '(0 1 2 3 4 5 6 7))
	  (vector-set! crctab m crc))))))

(define crc-32-table (crc:make-table CRC-32-polynomial))

;;@ Computes the P1003.2/D11.2 (POSIX.2) 32-bit checksum.
(define (cksum file)
  (cond ((not crc-32-table) #f)
	((input-port? file) (cksum-port file))
	(else (call-with-input-file file cksum-port))))

(define cksum-port
  (let ((mask-24 (crc:make-mask 24))
	(mask-32 (crc:make-mask 32)))
    (lambda (port)
      (define crc 0)
      (define (accumulate-crc byt)
	(set! crc
	      (logxor (ash (logand mask-24 crc) 8)
		      (vector-ref crc-32-table (logxor (ash crc -24) byt)))))
      (do ((byt (read-byte port) (read-byte port))
	   (byte-count 0 (+ 1 byte-count)))
	  ((eof-object? byt)
	   (do ((byte-count byte-count (ash byte-count -8)))
	       ((zero? byte-count) (logxor mask-32 crc))
	     (accumulate-crc (logand #xff byte-count))))
	(accumulate-crc byt)))))
;@
(define (crc16 file)
  (cond ((not crc-16-table) #f)
	((input-port? file) (crc16-port file))
	(else (call-with-input-file file crc16-port))))

(define crc-16-table (crc:make-table CRC-16-polynomial))

(define crc16-port
  (let ((mask-8 (crc:make-mask 8))
	(mask-16 (crc:make-mask 16)))
    (lambda (port)
      (define crc mask-16)
      (define (accumulate-crc byt)
	(set! crc
	      (logxor (ash (logand mask-8 crc) 8)
		      (vector-ref crc-16-table (logxor (ash crc -8) byt)))))
      (do ((byt (read-byte port) (read-byte port)))
	  ((eof-object? byt) (logxor mask-16 crc))
	(accumulate-crc byt)))))
;@
(define (crc5 file)
  (cond ((input-port? file) (crc5-port file))
	(else (call-with-input-file file crc5-port))))

(define (crc5-port port)
  (define generator #b00101)
  (define crc #b11111)
  (do ((byt (read-byte port) (read-byte port)))
      ((eof-object? byt) (logxor #b11111 crc))
    (do ((data byt (ash data 1))
	 (len (+ -1 8) (+ -1 len)))
	((negative? len))
      (set! crc
	    (logand #b11111
		    (if (eqv? (logbit? 7 data) (logbit? 4 crc))
			(ash crc 1)
			(logxor (ash crc 1) generator)))))))