source: project/release/4/message-digest/trunk/message-digest-parameters.scm @ 34302

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

add message-digest-result-form, dep message-digest-default-result-type. per alvarom@… email Chicken 4.8.0.5 has prob w/ sym consts.

File size: 2.1 KB
Line 
1;;;; message-digest-parameters.scm
2;;;; Kon Lovett, Jan '06 (message-digest.scm)
3;;;; Kon Lovett, May '10 (message-digest.scm)
4;;;; Kon Lovett, Apr '12
5
6;; Issues
7;;
8;; - Uses 'context-info' to determine whether active context is "own" allocation or
9;; callers. Again, a kludge.
10;;
11;; - Passes u8vector to update phase as a blob.
12
13(module message-digest-parameters
14
15(;export
16  ; Parameters
17  message-digest-chunk-size
18  message-digest-chunk-read-maker
19  message-digest-chunk-converter)
20
21(import scheme)
22
23(import
24  chicken
25  (only srfi-4
26    u8vector->blob/shared subu8vector
27    read-u8vector! make-u8vector))
28(require-library
29  srfi-4)
30
31(require-extension
32  miscmacros)
33
34;;; Update Phase Helpers
35
36;;
37
38(define (positive-fixnum? obj)
39  (and (fixnum? obj) (positive? obj)) )
40
41;;
42
43(define (default-chunk-read-maker in #!optional (size (message-digest-chunk-size)))
44  (let ((u8buf (make-u8vector size)))
45    (lambda ()
46      (let ((len (read-u8vector! size u8buf in)))
47        (and
48          (positive? len)
49          (let ((u8buf (if (fx= len size) u8buf (subu8vector u8buf 0 len))))
50            (u8vector->blob/shared u8buf) ) ) ) ) ) )
51
52;;
53
54(define-constant DEFAULT-CHUNK-SIZE 1024)
55
56;;; Message Digest "Parameters"
57
58;;
59
60(define-parameter message-digest-chunk-size DEFAULT-CHUNK-SIZE
61  (lambda (x)
62    (cond
63      ((positive-fixnum? x)   x )
64      ((not x)                DEFAULT-CHUNK-SIZE )
65      (else
66        (warning 'message-digest-chunk-size "invalid positive-fixnum" x)
67        (message-digest-chunk-size) ) ) ) )
68
69;;
70
71(define-parameter message-digest-chunk-read-maker default-chunk-read-maker
72  (lambda (x)
73    (cond
74      ((procedure? x)   x )
75      ((not x)          default-chunk-read-maker )
76      (else
77        (warning 'message-digest-chunk-read-maker "invalid procedure" x)
78        (message-digest-chunk-read-maker) ) ) ) )
79
80;;
81
82(define-parameter message-digest-chunk-converter #f
83  (lambda (x)
84    (if (or (not x) (procedure? x))
85      x
86      (begin
87        (warning 'message-digest-chunk-converter "invalid procedure or #f" x)
88        (message-digest-chunk-converter) ) ) ) )
89
90) ;module message-digest-parameters
Note: See TracBrowser for help on using the repository browser.