1 | ;;;; message-digest-bv.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-bv |
---|
10 | |
---|
11 | (;export |
---|
12 | ; |
---|
13 | message-digest-update-blob |
---|
14 | message-digest-update-string |
---|
15 | message-digest-blob |
---|
16 | message-digest-string |
---|
17 | message-digest-blob! |
---|
18 | message-digest-string! |
---|
19 | ;DEPRECATED |
---|
20 | message-digest-update-substring) |
---|
21 | |
---|
22 | (import scheme chicken) |
---|
23 | (use |
---|
24 | (only srfi-13 substring/shared) |
---|
25 | (only type-checks |
---|
26 | check-blob check-string check-natural-fixnum check-range) |
---|
27 | message-digest-primitive |
---|
28 | message-digest-type |
---|
29 | message-digest-support |
---|
30 | typed-define) |
---|
31 | |
---|
32 | ;;; Support |
---|
33 | |
---|
34 | ;; |
---|
35 | |
---|
36 | (include "message-digest-types") |
---|
37 | |
---|
38 | ;;; Message Digest API |
---|
39 | |
---|
40 | ;; Update |
---|
41 | |
---|
42 | ;; |
---|
43 | |
---|
44 | (define (message-digest-update-blob md blb #!optional (start 0) (end (blob-size blb))) |
---|
45 | (*message-digest-update-blob |
---|
46 | (check-message-digest 'message-digest-update-blob md) |
---|
47 | (check-blob/slice 'message-digest-update-blob blb start end)) ) |
---|
48 | |
---|
49 | ;; |
---|
50 | |
---|
51 | (define (message-digest-update-string md str #!optional (start 0) (end (string-length str))) |
---|
52 | (*message-digest-update-string |
---|
53 | (check-message-digest 'message-digest-update-string md) |
---|
54 | (check-string/slice 'message-digest-update-string str start end)) ) |
---|
55 | |
---|
56 | ;; |
---|
57 | |
---|
58 | ;DEPRECATED |
---|
59 | (define (message-digest-update-substring md str start end) |
---|
60 | (*message-digest-update-string |
---|
61 | (check-message-digest 'message-digest-update-substring md) |
---|
62 | (substring/shared (check-string 'message-digest-update-substring str) start end)) ) |
---|
63 | |
---|
64 | ;; Single Source API |
---|
65 | |
---|
66 | (define (message-digest-blob mdp blb |
---|
67 | #!optional |
---|
68 | (result-type (message-digest-result-form)) |
---|
69 | (start 0) (end (blob-size blb))) |
---|
70 | (let ( |
---|
71 | (md (initialize-message-digest mdp)) ) |
---|
72 | (message-digest-update-blob md blb start end) |
---|
73 | (finalize-message-digest md result-type) ) ) |
---|
74 | |
---|
75 | (define (message-digest-string mdp str |
---|
76 | #!optional |
---|
77 | (result-type (message-digest-result-form)) |
---|
78 | (start 0) (end (string-length str))) |
---|
79 | (let ( |
---|
80 | (md (initialize-message-digest mdp)) ) |
---|
81 | (message-digest-update-string md str start end) |
---|
82 | (finalize-message-digest md result-type) ) ) |
---|
83 | |
---|
84 | (define (message-digest-blob! mdp blb result-buffer |
---|
85 | #!optional |
---|
86 | (start 0) (end (blob-size blb))) |
---|
87 | (let ( |
---|
88 | (md (initialize-message-digest mdp)) ) |
---|
89 | (message-digest-update-blob md blb start end) |
---|
90 | (finalize-message-digest! md result-buffer) ) ) |
---|
91 | |
---|
92 | (define (message-digest-string! mdp str result-buffer |
---|
93 | #!optional |
---|
94 | (start 0) (end (string-length str))) |
---|
95 | (let ( |
---|
96 | (md (initialize-message-digest mdp)) ) |
---|
97 | (message-digest-update-string md str start end) |
---|
98 | (finalize-message-digest! md result-buffer) ) ) |
---|
99 | |
---|
100 | ;;; |
---|
101 | |
---|
102 | (define (check-blob/slice loc blb start end) |
---|
103 | (check-fixnum-range loc start end) |
---|
104 | (blob/slice (check-blob loc blb) start end) ) |
---|
105 | |
---|
106 | (define (check-string/slice loc str start end) |
---|
107 | (check-fixnum-range loc start end) |
---|
108 | (string/slice (check-string loc str) start end) ) |
---|
109 | |
---|
110 | (define (check-fixnum-range loc start end) |
---|
111 | (check-range loc |
---|
112 | (check-natural-fixnum loc start 'start) |
---|
113 | (check-natural-fixnum loc end 'end) |
---|
114 | "end < start") ) |
---|
115 | |
---|
116 | ) ;module message-digest-bv |
---|