summaryrefslogtreecommitdiffstats
path: root/crc.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
commit8466d8cfa486fb30d1755c4261b781135083787b (patch)
treec8c12c67246f543c3cc4f64d1c07e003cb1d45ae /crc.scm
parent87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (diff)
downloadslib-8466d8cfa486fb30d1755c4261b781135083787b.tar.gz
slib-8466d8cfa486fb30d1755c4261b781135083787b.zip
Import Upstream version 3a1upstream/3a1
Diffstat (limited to 'crc.scm')
-rw-r--r--crc.scm137
1 files changed, 137 insertions, 0 deletions
diff --git a/crc.scm b/crc.scm
new file mode 100644
index 0000000..423622b
--- /dev/null
+++ b/crc.scm
@@ -0,0 +1,137 @@
+;;;; "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)))))))