Commit | Line | Data |
---|---|---|
9ddacf86 KN |
1 | ;;;; "makcrc.scm" Compute Cyclic Checksums |
2 | ;;; Copyright (C) 1995, 1996, 1997, 2001 Aubrey Jaffer. | |
3 | ; | |
4 | ;Permission to copy this software, to redistribute it, and to use it | |
5 | ;for any purpose is granted, subject to the following restrictions and | |
6 | ;understandings. | |
7 | ; | |
8 | ;1. Any copy made of this software must include this copyright notice | |
9 | ;in full. | |
10 | ; | |
11 | ;2. I have made no warrantee or representation that the operation of | |
12 | ;this software will be error-free, and I am under no obligation to | |
13 | ;provide any services, by way of maintenance, update, or otherwise. | |
14 | ; | |
15 | ;3. In conjunction with products arising from the use of this | |
16 | ;material, there shall be no use of my name in any advertising, | |
17 | ;promotional, or sales literature without prior written consent in | |
18 | ;each case. | |
19 | ||
20 | (require 'byte) | |
21 | (require 'logical) | |
22 | ||
23 | (define (make-port-crc . margs) | |
24 | (define (make-mask hibit) | |
25 | (+ (ash (+ -1 (ash 1 (+ 1 (- hibit 2)))) 1) 1)) | |
26 | (define chunk-bits (integer-length (+ -1 char-code-limit))) | |
27 | (define accum-bits #f) | |
28 | (define generator #f) | |
29 | (case (length margs) | |
30 | ((0) #t) | |
31 | ((1) (if (< (car margs) 128) | |
32 | (set! accum-bits (car margs)) | |
33 | (set! generator (car margs)))) | |
34 | ((2) | |
35 | (set! accum-bits (car margs)) | |
36 | (set! generator (cadr margs))) | |
37 | (else (slib:error 'make-port-crc 'args margs))) | |
38 | (cond ((not generator) | |
39 | (case accum-bits | |
40 | ((#f 32) (set! accum-bits 32) | |
41 | (set! generator #b00000100110000010001110110110111)) ; CRC-32 | |
42 | ((16) (set! generator #b0001000000001011)) ; CRC-16 | |
43 | ;;((16) (set! generator #b0001000000100001)) ; CRC-CCIT | |
44 | ;;((08) (set! generator #b101011)) | |
45 | (else (slib:error 'make-port-crc "no default polynomial for" | |
46 | accum-bits "bits")))) | |
47 | ((not accum-bits) | |
48 | (set! accum-bits (+ -1 (integer-length generator))))) | |
49 | (set! generator (logand generator (lognot (ash 1 accum-bits)))) | |
50 | (cond ((>= (integer-length generator) accum-bits) | |
51 | (slib:error 'make-port-crc | |
52 | "generator longer than" accum-bits "bits"))) | |
53 | (let* ((chunk-mask (make-mask chunk-bits)) | |
54 | (crctab (make-vector (+ 1 chunk-mask)))) | |
55 | (define (accum src) | |
56 | `(set! | |
57 | crc | |
58 | (logxor (ash (logand ,(make-mask (- accum-bits chunk-bits)) crc) | |
59 | ,chunk-bits) | |
60 | (vector-ref crctab | |
61 | (logand ,chunk-mask | |
62 | (logxor | |
63 | (ash crc ,(- chunk-bits accum-bits)) | |
64 | ,src)))))) | |
65 | (define (make-crc-table) | |
66 | (letrec ((r (make-vector chunk-bits)) | |
67 | (remd (lambda (m) | |
68 | (define rem 0) | |
69 | (do ((i 0 (+ 1 i))) | |
70 | ((>= i chunk-bits) rem) | |
71 | (if (logbit? i m) | |
72 | (set! rem (logxor rem (vector-ref r i)))))))) | |
73 | (vector-set! r 0 generator) | |
74 | (do ((i 1 (+ 1 i))) | |
75 | ((>= i chunk-bits)) | |
76 | (let ((r-1 (vector-ref r (+ -1 i))) | |
77 | (m-1 (make-mask (+ -1 accum-bits)))) | |
78 | (vector-set! r i (if (logbit? (+ -1 accum-bits) r-1) | |
79 | (logxor (ash (logand m-1 r-1) 1) generator) | |
80 | (ash (logand m-1 r-1) 1))))) | |
81 | (do ((i 0 (+ 1 i))) | |
82 | ((> i chunk-mask)) | |
83 | (vector-set! crctab i (remd i))))) | |
84 | (make-crc-table) | |
85 | `(lambda (port) | |
86 | (define crc 0) | |
87 | (define byte-count 0) | |
88 | (define crctab ',crctab) | |
89 | (do ((ci (read-byte port) (read-byte port))) | |
90 | ((eof-object? ci)) | |
91 | ,(accum 'ci) | |
92 | (set! byte-count (+ 1 byte-count))) | |
93 | (do ((byte-count byte-count (ash byte-count ,(- chunk-bits)))) | |
94 | ((zero? byte-count)) | |
95 | ,(accum 'byte-count)) | |
96 | (logxor ,(make-mask accum-bits) crc)))) |