source: project/release/5/message-digest-primitive/trunk/message-digest-primitive.scm @ 35915

Last change on this file since 35915 was 35915, checked in by kon, 9 months ago

make-message-digest-primitive-context should take mdp

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