1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
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)))))))
|
