1 | ;;;; message-digest-support.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 | ;; - Uses 'context-info' to determine whether active context is "own" allocation or |
---|
10 | ;; callers. Again, a kludge. |
---|
11 | ;; |
---|
12 | ;; - Passes u8vector to update phase as a blob. |
---|
13 | |
---|
14 | (module message-digest-support |
---|
15 | |
---|
16 | (;export |
---|
17 | ; Support |
---|
18 | packed-vector->blob/shared |
---|
19 | ; |
---|
20 | u8vector/slice blob/slice string/slice |
---|
21 | ; |
---|
22 | *message-digest-update-blob |
---|
23 | *message-digest-update-string) |
---|
24 | |
---|
25 | (import scheme chicken) |
---|
26 | |
---|
27 | (use |
---|
28 | (only lolevel number-of-bytes) |
---|
29 | (only srfi-4 |
---|
30 | s8vector? |
---|
31 | u8vector? |
---|
32 | s16vector? |
---|
33 | u16vector? |
---|
34 | s32vector? |
---|
35 | u32vector? |
---|
36 | #;u64vector? |
---|
37 | #;u64vector? |
---|
38 | f32vector? |
---|
39 | f64vector? |
---|
40 | u8vector->blob/shared |
---|
41 | s8vector->blob/shared |
---|
42 | s16vector->blob/shared |
---|
43 | u16vector->blob/shared |
---|
44 | s32vector->blob/shared |
---|
45 | u32vector->blob/shared |
---|
46 | #;s64vector->blob/shared |
---|
47 | #;u64vector->blob/shared |
---|
48 | f32vector->blob/shared |
---|
49 | f64vector->blob/shared |
---|
50 | subu8vector u8vector-length) |
---|
51 | message-digest-primitive |
---|
52 | message-digest-type |
---|
53 | fx-utils) |
---|
54 | |
---|
55 | ;;; Support |
---|
56 | |
---|
57 | ;; |
---|
58 | |
---|
59 | ;Used by update-item & srfi-4 modules |
---|
60 | (define (packed-vector->blob/shared obj) |
---|
61 | (cond |
---|
62 | ((u8vector? obj) (u8vector->blob/shared obj)) |
---|
63 | ((s8vector? obj) (s8vector->blob/shared obj)) |
---|
64 | ((u16vector? obj) (u16vector->blob/shared obj)) |
---|
65 | ((s16vector? obj) (s16vector->blob/shared obj)) |
---|
66 | ((u32vector? obj) (u32vector->blob/shared obj)) |
---|
67 | ((s32vector? obj) (s32vector->blob/shared obj)) |
---|
68 | #;((u64vector? obj) (u64vector->blob/shared obj)) |
---|
69 | #;((s64vector? obj) (s64vector->blob/shared obj)) |
---|
70 | ((f32vector? obj) (f32vector->blob/shared obj)) |
---|
71 | ((f64vector? obj) (f64vector->blob/shared obj)) |
---|
72 | (else #f ) ) ) |
---|
73 | |
---|
74 | ;; |
---|
75 | |
---|
76 | (define (u8vector/slice u8vec start end) |
---|
77 | (let ((end (or end (u8vector-length u8vec)))) |
---|
78 | (if (and (fxzero? start) (fx= end (u8vector-length u8vec))) |
---|
79 | u8vec |
---|
80 | (subu8vector u8vec start end) ) ) ) |
---|
81 | |
---|
82 | (define (blob/slice blb start end) |
---|
83 | (let ((end (or end (blob-size blb)))) |
---|
84 | (if (and (fxzero? start) (fx= end (blob-size blb))) |
---|
85 | blb |
---|
86 | (string->blob (##sys#substring (blob->string blb) start end)) ) ) ) |
---|
87 | |
---|
88 | (define (string/slice str start end) |
---|
89 | (let ((end (or end (string-length str)))) |
---|
90 | (if (and (fxzero? start) (fx= end (string-length str))) |
---|
91 | str |
---|
92 | (##sys#substring str start end) ) ) ) |
---|
93 | |
---|
94 | ;; |
---|
95 | |
---|
96 | (define (*message-digest-update-blob md blb #!optional (siz (blob-size blb))) |
---|
97 | ((message-digest-algorithm-update md) |
---|
98 | (message-digest-context md) |
---|
99 | blb |
---|
100 | siz) ) |
---|
101 | |
---|
102 | (define (*message-digest-update-string md str) |
---|
103 | (*message-digest-update-blob md (string->blob str)) ) |
---|
104 | |
---|
105 | (define (message-digest-algorithm-update md) |
---|
106 | (message-digest-primitive-update (message-digest-algorithm md)) ) |
---|
107 | |
---|
108 | ) ;module message-digest-support |
---|