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

Last change on this file since 34373 was 34373, checked in by Kon Lovett, 3 years ago

add raw-update to prim, use raw-update for mmapped/in-mem file md

File size: 3.4 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(module message-digest-primitive
10
11(;export
12  ; Algorithm API
13  make-message-digest-primitive
14  message-digest-primitive? check-message-digest-primitive error-message-digest-primitive
15  message-digest-primitive-name
16  message-digest-primitive-block-length
17  message-digest-primitive-context-info
18  message-digest-primitive-digest-length
19  message-digest-primitive-init
20  message-digest-primitive-update
21  message-digest-primitive-final
22  message-digest-primitive-raw-update)
23
24(import scheme)
25
26(import chicken)
27
28(import
29  (only type-checks
30    define-check+error-type
31    check-positive-fixnum
32    check-procedure)
33  (only type-errors
34    error-argument-type))
35(require-library
36  type-checks
37  type-errors)
38
39;;; Support
40
41;;
42
43(define (positive-fixnum? obj)
44  (and (fixnum? obj) (positive? obj)) )
45
46(define (primitive-ctx-info? obj)
47  (or (procedure? obj) (positive-fixnum? obj)) )
48
49(define (primitive-name? obj)
50  (or (symbol? obj) (string? obj)) )
51
52;;; Message Digest Algorithm API
53
54;;
55
56(define (check-message-digest-arguments loc ctx-info digest-len init update final block-len name raw-update)
57  (unless (primitive-ctx-info? ctx-info)
58    (error-argument-type loc ctx-info "positive-fixnum or procedure" 'context-info) )
59  (check-positive-fixnum loc digest-len 'digest-length)
60  (check-procedure loc init 'digest-initializer)
61  (check-procedure loc update 'digest-updater)
62  (check-procedure loc final 'digest-finalizer)
63  (check-positive-fixnum loc block-len 'block-length)
64  (unless (primitive-name? name)
65    (error-argument-type loc name "symbol or string" 'name) )
66  (when raw-update
67    (check-procedure loc raw-update 'digest-raw-updater) ) )
68
69;;
70
71(define-record-type message-digest-primitive
72  (*make-message-digest-primitive ctxi digest-len init update final block-len name raw-update)
73  message-digest-primitive?
74  (ctxi message-digest-primitive-context-info)
75  (digest-len message-digest-primitive-digest-length)
76  (init message-digest-primitive-init)
77  (update message-digest-primitive-update)
78  (final message-digest-primitive-final)
79  (block-len message-digest-primitive-block-length)
80  (name message-digest-primitive-name)
81  (raw-update message-digest-primitive-raw-update) )
82
83(define-check+error-type message-digest-primitive)
84
85(define (make-message-digest-primitive ctx-info digest-len init update final . rest)
86  (let-values (((block-len rest)
87                (if (and (not (null? rest)) (number? (car rest)))
88                  (values (car rest) (cdr rest))
89                  (values 4 rest) ) ) )
90    (let-values (((name rest)
91                  (if (and (not (null? rest)) (primitive-name? (car rest)))
92                    (values (car rest) (cdr rest))
93                    (values (gensym 'mdp) rest) ) ) )
94      (let-values (((raw-update rest)
95                    (if (and (not (null? rest)) (procedure? (car rest)))
96                      (values (car rest) (cdr rest))
97                      (values #f rest) ) ) )
98        (check-message-digest-arguments 'make-message-digest-primitive
99          ctx-info digest-len init update final block-len name raw-update)
100        (*make-message-digest-primitive
101          ctx-info
102          digest-len
103          init update final
104          block-len
105          name
106          raw-update) ) ) ) )
107
108;;
109
110(define do-raw-update
111
112
113) ;module message-digest-primitive
Note: See TracBrowser for help on using the repository browser.