;;;; "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)))))))