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

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

use parameters, add res typ param, mv chks into 1st use

File size: 2.7 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
23(import scheme)
24
25(import chicken)
26
27(import
28  (only type-checks
29    define-check+error-type
30    check-positive-fixnum
31    check-procedure)
32  (only type-errors
33    error-argument-type))
34(require-library
35  type-checks
36  type-errors)
37
38;;; Support
39
40;;
41
42(define (positive-fixnum? obj)
43  (and (fixnum? obj) (positive? obj)) )
44
45;;; Message Digest Algorithm API
46
47;;
48
49(define (check-message-digest-arguments loc ctx-info digest-len init update final block-len name)
50  (unless (or (procedure? ctx-info) (positive-fixnum? ctx-info))
51    (error-argument-type loc ctx-info "positive-fixnum or procedure" 'context-info) )
52  (check-positive-fixnum loc digest-len 'digest-length)
53  (check-procedure loc init 'digest-initializer)
54  (check-procedure loc update 'digest-updater)
55  (check-procedure loc final 'digest-finalizer)
56  (check-positive-fixnum loc block-len 'block-length)
57  (unless (or (symbol? name) (string? name))
58    (error-argument-type loc name "symbol or string" 'name) ) )
59
60;;
61
62(define-record-type message-digest-primitive
63  (*make-message-digest-primitive ctxi digest-len init update final block-len name)
64  message-digest-primitive?
65  (ctxi message-digest-primitive-context-info)
66  (digest-len message-digest-primitive-digest-length)
67  (init message-digest-primitive-init)
68  (update message-digest-primitive-update)
69  (final message-digest-primitive-final)
70  (block-len message-digest-primitive-block-length)
71  (name message-digest-primitive-name) )
72
73(define-check+error-type message-digest-primitive)
74
75(define (make-message-digest-primitive ctx-info digest-len init update final . rest)
76  (let-values (((block-len rest)
77                (if (and (not (null? rest)) (number? (car rest)))
78                  (values (car rest) (cdr rest))
79                  (values 4 rest) ) ) )
80    (let ((name (if (null? rest) (gensym "mdp") (car rest) ) ) )
81      (check-message-digest-arguments 'make-message-digest-primitive
82        ctx-info digest-len init update final block-len name)
83      (*make-message-digest-primitive
84        ctx-info
85        digest-len
86        init update final
87        block-len
88        name) ) ) )
89
90) ;module message-digest-primitive
Note: See TracBrowser for help on using the repository browser.