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

Last change on this file since 35826 was 35826, checked in by Kon Lovett, 2 years ago

C5 initial

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 chicken)
29(use
30  (only type-checks
31    define-check+error-type
32    check-positive-fixnum
33    check-procedure)
34  (only type-errors
35    error-argument-type)
36  typed-define)
37
38;;; Support
39
40(define-type message-digest-primitive (struct message-digest-primitive))
41
42;;
43
44(define (positive-fixnum? obj)
45  (and (fixnum? obj) (positive? obj)) )
46
47(define (primitive-ctx-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-inline (check-message-digest-arguments loc ctx-info digest-len init update final block-len name raw-update)
58  (unless (primitive-ctx-info? ctx-info)
59    (error-argument-type loc ctx-info "positive-fixnum or procedure" 'context-info) )
60  (check-positive-fixnum loc digest-len 'digest-length)
61  (check-procedure loc init 'digest-initializer)
62  (check-procedure loc update 'digest-updater)
63  (check-procedure loc final 'digest-finalizer)
64  (check-positive-fixnum loc block-len 'block-length)
65  (unless (primitive-name? name)
66    (error-argument-type loc name "symbol or string" 'name) )
67  (when raw-update
68    (check-procedure loc raw-update 'digest-raw-updater) ) )
69
70;;
71
72(define:-record-type message-digest-primitive
73  (*make-message-digest-primitive ctxi digest-len init update final block-len name raw-update)
74  message-digest-primitive?
75  (ctxi (or fixnum procedure) message-digest-primitive-context-info)
76  (digest-len fixnum message-digest-primitive-digest-length)
77  (init procedure message-digest-primitive-init)
78  (update procedure message-digest-primitive-update)
79  (final procedure message-digest-primitive-final)
80  (block-len fixnum message-digest-primitive-block-length)
81  (name (or symbol string) message-digest-primitive-name)
82  (raw-update procedure message-digest-primitive-raw-update) )
83
84(define-check+error-type message-digest-primitive)
85
86(define: (make-message-digest-primitive
87            (ctx-info (or fixnum procedure)) (digest-len fixnum)
88            (init procedure) (update procedure) (final procedure)
89            . (opts (list-of *))) -> message-digest-primitive
90  ;
91  (define (pull-arg args pred defprc)
92    (if (and (not (null? args)) (pred (car args)))
93      (values (car args) (cdr args))
94      (values (defprc) args) ) )
95  ;
96  (let*-values (
97    ((block-len opts)
98      (pull-arg opts number? (lambda () 4)))
99    ((name opts)
100      (pull-arg opts (lambda (x) (not (procedure? x))) (lambda () (gensym 'mdp))))
101    ((raw-update opts)
102      (pull-arg opts procedure? (lambda () #f))) )
103    (check-message-digest-arguments 'make-message-digest-primitive
104      ctx-info digest-len init update final block-len name raw-update)
105    (*make-message-digest-primitive
106      ctx-info 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.