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

Last change on this file since 35044 was 35044, checked in by kon, 8 months ago

why did i care ?

File size: 3.2 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
30(use
31  (only type-checks
32    define-check+error-type
33    check-positive-fixnum
34    check-procedure)
35  (only type-errors
36    error-argument-type))
37
38;;; Support
39
40;;
41
42(define (positive-fixnum? obj)
43  (and (fixnum? obj) (positive? obj)) )
44
45(define (primitive-ctx-info? obj)
46  (or (procedure? obj) (positive-fixnum? obj)) )
47
48(define (primitive-name? obj)
49  #t )
50
51;;; Message Digest Algorithm API
52
53;;
54
55(define (check-message-digest-arguments loc ctx-info digest-len init update final block-len name raw-update)
56  (unless (primitive-ctx-info? ctx-info)
57    (error-argument-type loc ctx-info "positive-fixnum or procedure" 'context-info) )
58  (check-positive-fixnum loc digest-len 'digest-length)
59  (check-procedure loc init 'digest-initializer)
60  (check-procedure loc update 'digest-updater)
61  (check-procedure loc final 'digest-finalizer)
62  (check-positive-fixnum loc block-len 'block-length)
63  (unless (primitive-name? name)
64    (error-argument-type loc name "symbol or string" 'name) )
65  (when raw-update
66    (check-procedure loc raw-update 'digest-raw-updater) ) )
67
68;;
69
70(define-record-type message-digest-primitive
71  (*make-message-digest-primitive ctxi digest-len init update final block-len name raw-update)
72  message-digest-primitive?
73  (ctxi message-digest-primitive-context-info)
74  (digest-len message-digest-primitive-digest-length)
75  (init message-digest-primitive-init)
76  (update message-digest-primitive-update)
77  (final message-digest-primitive-final)
78  (block-len message-digest-primitive-block-length)
79  (name message-digest-primitive-name)
80  (raw-update message-digest-primitive-raw-update) )
81
82(define-check+error-type message-digest-primitive)
83
84(define (make-message-digest-primitive ctx-info digest-len init update final . rest)
85  ;
86  (define (pull-arg args pred defprc)
87    (if (and (not (null? args)) (pred (car args)))
88      (values (car args) (cdr args))
89      (values (defprc) args) ) )
90  ;
91  (let*-values (((block-len rest) (pull-arg rest number? (lambda () 4)))
92                ((name rest) (pull-arg rest primitive-name? (lambda () (gensym 'message-digest-primitive))))
93                ((raw-update rest) (pull-arg rest procedure? (lambda () #f))) )
94    (check-message-digest-arguments 'make-message-digest-primitive
95      ctx-info digest-len init update final block-len name raw-update)
96    (*make-message-digest-primitive
97      ctx-info digest-len
98      init update final
99      block-len
100      name
101      raw-update) ) )
102
103) ;module message-digest-primitive
Note: See TracBrowser for help on using the repository browser.