diff options
Diffstat (limited to 'makcrc.scm')
| -rw-r--r-- | makcrc.scm | 49 |
1 files changed, 29 insertions, 20 deletions
@@ -1,9 +1,9 @@ ;;;; "makcrc.scm" Compute Cyclic Checksums -;;; Copyright (C) 1995, 1996, 1997 Aubrey Jaffer. +;;; Copyright (C) 1995, 1996, 1997, 2001 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. +;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. @@ -17,27 +17,39 @@ ;promotional, or sales literature without prior written consent in ;each case. +(require 'byte) (require 'logical) -;;;(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 accum-bits #f) (define generator #f) - (cond ((pair? margs) - (set! accum-bits (car margs)) - (cond ((pair? (cdr margs)) - (set! generator (cadr margs)))))) + (case (length margs) + ((0) #t) + ((1) (if (< (car margs) 128) + (set! accum-bits (car margs)) + (set! generator (car margs)))) + ((2) + (set! accum-bits (car margs)) + (set! generator (cadr margs))) + (else (slib:error 'make-port-crc 'args margs))) (cond ((not generator) (case accum-bits - ((32) (set! generator #b00000100110000010001110110110111)) + ((#f 32) (set! accum-bits 32) + (set! generator #b00000100110000010001110110110111)) ; CRC-32 + ((16) (set! generator #b0001000000001011)) ; CRC-16 + ;;((16) (set! generator #b0001000000100001)) ; CRC-CCIT + ;;((08) (set! generator #b101011)) (else (slib:error 'make-port-crc "no default polynomial for" - accum-bits "bits"))))) + accum-bits "bits")))) + ((not accum-bits) + (set! accum-bits (+ -1 (integer-length generator))))) + (set! generator (logand generator (lognot (ash 1 accum-bits)))) + (cond ((>= (integer-length generator) accum-bits) + (slib:error 'make-port-crc + "generator longer than" accum-bits "bits"))) (let* ((chunk-mask (make-mask chunk-bits)) (crctab (make-vector (+ 1 chunk-mask)))) (define (accum src) @@ -69,17 +81,14 @@ (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))) + (do ((ci (read-byte port) (read-byte port))) ((eof-object? ci)) - ,(accum '(char->integer ci)) + ,(accum 'ci) (set! byte-count (+ 1 byte-count))) (do ((byte-count byte-count (ash byte-count ,(- chunk-bits)))) ((zero? byte-count)) |