Import Upstream version 3a1upstream/3a1

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