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

Last change on this file was 38986, checked in by Kon Lovett, 3 months ago

export record id

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