source: project/release/4/message-digest/trunk/message-digest-primitive.scm @ 34374

Last change on this file since 34374 was 34374, checked in by kon, 7 weeks ago

comment, fix

File size: 3.5 KB
Line 
1;;;; message-digest-primitive.scm
2;;;; Kon Lovett, Jan '06 (message-digest.scm)
3;;;; Kon Lovett, May '10 (message-digest.scm)
4;;;; Kon Lovett, Apr '12
5;;;; Kon Lovett, Aug '17
6
7;; Issues
8;;
9;; - see tiger-hash , sha2 , sha1 , ripemd , md5 , hashes
10;;
11;; - synthesize raw-update from update
12
13(module message-digest-primitive
14
15(;export
16  ; Algorithm API
17  make-message-digest-primitive
18  message-digest-primitive? check-message-digest-primitive error-message-digest-primitive
19  message-digest-primitive-name
20  message-digest-primitive-block-length
21  message-digest-primitive-context-info
22  message-digest-primitive-digest-length
23  message-digest-primitive-init
24  message-digest-primitive-update
25  message-digest-primitive-final
26  message-digest-primitive-raw-update)
27
28(import scheme)
29
30(import chicken)
31
32(import
33  (only type-checks
34    define-check+error-type
35    check-positive-fixnum
36    check-procedure)
37  (only type-errors
38    error-argument-type))
39(require-library
40  type-checks
41  type-errors)
42
43;;; Support
44
45;;
46
47(define (positive-fixnum? obj)
48  (and (fixnum? obj) (positive? obj)) )
49
50(define (primitive-ctx-info? obj)
51  (or (procedure? obj) (positive-fixnum? obj)) )
52
53(define (primitive-name? obj)
54  (or (symbol? obj) (string? obj)) )
55
56;;; Message Digest Algorithm API
57
58;;
59
60(define (check-message-digest-arguments loc ctx-info digest-len init update final block-len name raw-update)
61  (unless (primitive-ctx-info? ctx-info)
62    (error-argument-type loc ctx-info "positive-fixnum or procedure" 'context-info) )
63  (check-positive-fixnum loc digest-len 'digest-length)
64  (check-procedure loc init 'digest-initializer)
65  (check-procedure loc update 'digest-updater)
66  (check-procedure loc final 'digest-finalizer)
67  (check-positive-fixnum loc block-len 'block-length)
68  (unless (primitive-name? name)
69    (error-argument-type loc name "symbol or string" 'name) )
70  (when raw-update
71    (check-procedure loc raw-update 'digest-raw-updater) ) )
72
73;;
74
75(define-record-type message-digest-primitive
76  (*make-message-digest-primitive ctxi digest-len init update final block-len name raw-update)
77  message-digest-primitive?
78  (ctxi message-digest-primitive-context-info)
79  (digest-len message-digest-primitive-digest-length)
80  (init message-digest-primitive-init)
81  (update message-digest-primitive-update)
82  (final message-digest-primitive-final)
83  (block-len message-digest-primitive-block-length)
84  (name message-digest-primitive-name)
85  (raw-update message-digest-primitive-raw-update) )
86
87(define-check+error-type message-digest-primitive)
88
89(define (make-message-digest-primitive ctx-info digest-len init update final . rest)
90  (let-values (((block-len rest)
91                (if (and (not (null? rest)) (number? (car rest)))
92                  (values (car rest) (cdr rest))
93                  (values 4 rest) ) ) )
94    (let-values (((name rest)
95                  (if (and (not (null? rest)) (primitive-name? (car rest)))
96                    (values (car rest) (cdr rest))
97                    (values (gensym 'mdp) rest) ) ) )
98      (let-values (((raw-update rest)
99                    (if (and (not (null? rest)) (procedure? (car rest)))
100                      (values (car rest) (cdr rest))
101                      (values #f rest) ) ) )
102        (check-message-digest-arguments 'make-message-digest-primitive
103          ctx-info digest-len init update final block-len name raw-update)
104        (*make-message-digest-primitive
105          ctx-info
106          digest-len
107          init update final
108          block-len
109          name
110          raw-update) ) ) ) )
111
112) ;module message-digest-primitive
Note: See TracBrowser for help on using the repository browser.