diff options
Diffstat (limited to 'makcrc.scm')
-rw-r--r-- | makcrc.scm | 86 |
1 files changed, 86 insertions, 0 deletions
diff --git a/makcrc.scm b/makcrc.scm new file mode 100644 index 0000000..b11f80e --- /dev/null +++ b/makcrc.scm @@ -0,0 +1,86 @@ +;;;; "makcrc.scm" Compute Cyclic Checksums +;;; Copyright (C) 1995, 1996 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, 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 warrantee 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. + +;;;(define crc (eval (make-port-crc 16 #o010013))) +;;;(define crc (eval (make-port-crc 08 #o053))) + +(define (file-check-sum file) (call-with-input-file file crc32)) + +(define (make-port-crc . margs) + (define (make-mask hibit) + (+ (ash (+ -1 (ash 1 (+ 1 (- hibit 2)))) 1) 1)) + (define accum-bits 32) + (define chunk-bits (integer-length (+ -1 char-code-limit))) + (define generator #f) + (cond ((pair? margs) + (set! accum-bits (car margs)) + (cond ((pair? (cdr margs)) + (set! generator (cadr margs)))))) + (cond ((not generator) + (case accum-bits + ((32) (set! generator #b00000100110000010001110110110111)) + (else (slib:error 'make-port-crc "no default polynomial for" + accum-bits "bits"))))) + (let* ((chunk-mask (make-mask chunk-bits)) + (crctab (make-vector (+ 1 chunk-mask)))) + (define (accum src) + `(set! + crc + (logxor (ash (logand ,(make-mask (- accum-bits chunk-bits)) crc) + ,chunk-bits) + (vector-ref crctab + (logand ,chunk-mask + (logxor + (ash crc ,(- chunk-bits accum-bits)) + ,src)))))) + (define (make-crc-table) + (letrec ((r (make-vector chunk-bits)) + (remd (lambda (m) + (define rem 0) + (do ((i 0 (+ 1 i))) + ((>= i chunk-bits) rem) + (if (logbit? i m) + (set! rem (logxor rem (vector-ref r i)))))))) + (vector-set! r 0 generator) + (do ((i 1 (+ 1 i))) + ((>= i chunk-bits)) + (let ((r-1 (vector-ref r (+ -1 i))) + (m-1 (make-mask (+ -1 accum-bits)))) + (vector-set! r i (if (logbit? (+ -1 accum-bits) r-1) + (logxor (ash (logand m-1 r-1) 1) generator) + (ash (logand m-1 r-1) 1))))) + (do ((i 0 (+ 1 i))) + ((> i chunk-mask)) + (vector-set! crctab i (remd i))))) + (cond ((>= (integer-length generator) accum-bits) + (slib:error 'make-port-crc + "generator longer than" accum-bits "bits"))) + (make-crc-table) + `(lambda (port) + (define crc 0) + (define byte-count 0) + (define crctab ,crctab) + (do ((ci (read-char port) (read-char port))) + ((eof-object? ci)) + ,(accum '(char->integer ci)) + (set! byte-count (+ 1 byte-count))) + (do ((byte-count byte-count (ash byte-count ,(- chunk-bits)))) + ((zero? byte-count)) + ,(accum 'byte-count)) + (logxor ,(make-mask accum-bits) crc)))) |