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

Last change on this file since 36725 was 36725, checked in by Kon Lovett, 11 months ago

reflow, more specific types, shorten type alias names

File size: 6.6 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  (chicken foreign)
37  (only (chicken memory) allocate free)
38  (only type-checks define-check+error-type check-positive-fixnum check-procedure)
39  (only type-errors error-argument-type))
40
41;;; Support
42
43;;
44
45(define (positive-fixnum? obj) (and (fixnum? obj) (positive? obj)))
46
47(define (primitive-context-info? obj) (or (procedure? obj) (positive-fixnum? obj)))
48
49(define (primitive-name? obj) (or (symbol? obj) (string? obj)))
50
51;;; Message Digest Algorithm API
52
53;;
54
55(define-type primitive-name (or symbol string))
56
57(define-type data-type (not immediate))
58
59(define-type init-procedure (data-type -> *))
60;(foreign-lambda void ***Update     c-pointer   scheme-pointer  unsigned-int)
61;(foreign-lambda void ***RawUpdate  c-pointer   c-pointer       unsigned-int)
62(define-type update-procedure (data-type data-type fixnum -> *))
63(define-type final-procedure (data-type data-type -> *))
64
65(define-type context-info (or fixnum procedure))
66
67(define-type raw-update-value (or boolean update-procedure))
68
69(define-type message-digest-primitive (struct message-digest-primitive))
70
71;;
72
73;assignment of value of type `(procedure
74;message-digest-primitive#*make-message-digest-primitive (* * * * * * * *)
75;(struct message-digest-primitive#message-digest-primitive))' to toplevel
76;variable `message-digest-primitive#*make-message-digest-primitive' does not
77;match declared type `(procedure
78;message-digest-primitive#*make-message-digest-primitive ((or fixnum procedure)
79;fixnum procedure procedure procedure fixnum (or symbol string) (or boolean
80;procedure)) (struct message-digest-primitive))'
81(: *make-message-digest-primitive (context-info fixnum init-procedure update-procedure final-procedure fixnum primitive-name raw-update-value -> message-digest-primitive))
82(: message-digest-primitive? (* -> boolean : message-digest-primitive))
83(: message-digest-primitive-context-info (message-digest-primitive --> context-info))
84(: message-digest-primitive-digest-length (message-digest-primitive --> fixnum))
85(: message-digest-primitive-init (message-digest-primitive --> init-procedure))
86(: message-digest-primitive-update (message-digest-primitive --> update-procedure))
87(: message-digest-primitive-final (message-digest-primitive --> final-procedure))
88(: message-digest-primitive-block-length (message-digest-primitive --> fixnum))
89(: message-digest-primitive-name (message-digest-primitive --> primitive-name))
90(: message-digest-primitive-raw-update (message-digest-primitive --> raw-update-value))
91;
92(define-record-type message-digest-primitive
93  (*make-message-digest-primitive ctxi digest-len init update final block-len name raw-update)
94  message-digest-primitive?
95  (ctxi message-digest-primitive-context-info)
96  (digest-len message-digest-primitive-digest-length)
97  (init message-digest-primitive-init)
98  (update message-digest-primitive-update)
99  (final message-digest-primitive-final)
100  (block-len message-digest-primitive-block-length)
101  (name message-digest-primitive-name)
102  (raw-update message-digest-primitive-raw-update) )
103
104(define-check+error-type message-digest-primitive)
105
106;;
107
108(define-inline (check-message-digest-arguments loc ctx-info digest-len init update final block-len name raw-update)
109  (unless (primitive-context-info? ctx-info)
110    (error-argument-type loc ctx-info "positive-fixnum or procedure" 'context-info) )
111  (check-positive-fixnum loc digest-len 'digest-length)
112  (check-procedure loc init 'digest-initializer)
113  (when update
114    (check-procedure loc update 'digest-updater) )
115  (check-procedure loc final 'digest-finalizer)
116  (check-positive-fixnum loc block-len 'block-length)
117  (unless (primitive-name? name)
118    (error-argument-type loc name "symbol or string" 'name) )
119  (when raw-update
120    (check-procedure loc raw-update 'digest-raw-updater) ) )
121
122;;
123
124(: scheme-object-data-pointer (data-type -> pointer))
125;
126(define scheme-object-data-pointer
127  (foreign-lambda* c-pointer ((scheme-pointer psrc)) "C_return( psrc );"))
128
129;;
130
131(: make-scheme-object-updater (update-procedure -> update-procedure))
132;
133(define ((make-scheme-object-updater raw-update) ctx-info obj len)
134  (raw-update ctx-info (scheme-object-data-pointer obj) len) )
135
136;;
137
138;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))'
139(: make-message-digest-primitive (context-info fixnum init-procedure (or boolean update-procedure) final-procedure #!rest -> message-digest-primitive))
140;
141(define (make-message-digest-primitive ctx-info digest-len init update final
142            #!key (block-length 4) (name (gensym 'mdp)) (raw-update #f))
143  (check-message-digest-arguments 'make-message-digest-primitive
144    ctx-info digest-len init update final block-length name raw-update)
145  (let (
146    (update (or update (and raw-update (make-scheme-object-updater raw-update)))) )
147    ;we know about raw -> cooked
148    (unless update
149      (error 'make-message-digest-primitive "missing update & raw-update") )
150    (*make-message-digest-primitive
151      ctx-info digest-len init update final block-length name raw-update) ) )
152
153;;
154
155(: make-message-digest-primitive-context (message-digest-primitive -> *))
156;
157(define (make-message-digest-primitive-context mdp)
158  (let (
159    (ctx-info
160      (message-digest-primitive-context-info
161        (check-message-digest-primitive 'make-message-digest-primitive-context mdp))) )
162    (if (procedure? ctx-info)
163      (ctx-info)
164      (set-finalizer! (allocate ctx-info) free) ) ) )
165
166) ;module message-digest-primitive
Note: See TracBrowser for help on using the repository browser.