Ignore:
Timestamp:
07/09/18 19:09:54 (2 years ago)
Author:
Kon Lovett
Message:

C5 fixes

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/5/message-digest-primitive/trunk/message-digest-primitive.scm

    r35826 r35827  
    1 ;;;; message-digest-primitive.scm
     1;;;; message-digest-primitive.scm  -*- Scheme -*-
     2;;;; Kon Lovett, Jul '18
     3;;;; Kon Lovett, Aug '17
     4;;;; Kon Lovett, Apr '12
     5;;;; Kon Lovett, May '10 (message-digest.scm)
    26;;;; 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
    67
    78;; Issues
     
    1415
    1516(;export
     17  ;
     18  make-message-digest-primitive-context
    1619  ; Algorithm API
    1720  make-message-digest-primitive
     
    2629  message-digest-primitive-raw-update)
    2730
    28 (import scheme chicken)
    29 (use
    30   (only type-checks
    31     define-check+error-type
    32     check-positive-fixnum
    33     check-procedure)
    34   (only type-errors
    35     error-argument-type)
    36   typed-define)
     31(import scheme
     32  (chicken base)
     33  (chicken fixnum)
     34  (chicken gc)
     35  (chicken type)
     36  (only (chicken memory) allocate free)
     37  (only type-checks define-check+error-type check-positive-fixnum check-procedure)
     38  (only type-errors error-argument-type))
    3739
    3840;;; Support
    39 
    40 (define-type message-digest-primitive (struct message-digest-primitive))
    4141
    4242;;
     
    4545  (and (fixnum? obj) (positive? obj)) )
    4646
    47 (define (primitive-ctx-info? obj)
     47(define (primitive-context-info? obj)
    4848  (or (procedure? obj) (positive-fixnum? obj)) )
    4949
     
    5555;;
    5656
     57(define-type message-digest-primitive-name (or symbol string))
     58
     59(define-type message-digest-primitive-context-info (or fixnum procedure))
     60
     61(define-type message-digest-primitive-raw-update (or boolean procedure))
     62
     63(define-type message-digest-primitive (struct message-digest-primitive))
     64;assignment of value of type `(procedure message-digest-primitive#*make-message-digest-primitive (* * * * * * * *) (struct message-digest-primitive#message-digest-primitive))' to toplevel variable `message-digest-primitive#*make-message-digest-primitive' does not match declared type `(procedure message-digest-primitive#*make-message-digest-primitive ((or fixnum procedure) fixnum procedure procedure procedure fixnum (or symbol string) (or boolean procedure)) (struct message-digest-primitive))'
     65(: *make-message-digest-primitive (message-digest-primitive-context-info fixnum procedure procedure procedure fixnum message-digest-primitive-name message-digest-primitive-raw-update --> message-digest-primitive))
     66(: message-digest-primitive? (* -> boolean : message-digest-primitive))
     67(: message-digest-primitive-context-info (message-digest-primitive --> message-digest-primitive-context-info))
     68(: message-digest-primitive-digest-length (message-digest-primitive --> fixnum))
     69(: message-digest-primitive-init (message-digest-primitive --> procedure))
     70(: message-digest-primitive-update (message-digest-primitive --> procedure))
     71(: message-digest-primitive-final (message-digest-primitive --> procedure))
     72(: message-digest-primitive-block-length (message-digest-primitive --> fixnum))
     73(: message-digest-primitive-name (message-digest-primitive --> message-digest-primitive-name))
     74(: message-digest-primitive-raw-update (message-digest-primitive --> message-digest-primitive-raw-update))
     75;
     76(define-record-type message-digest-primitive
     77  (*make-message-digest-primitive ctxi digest-len init update final block-len name raw-update)
     78  message-digest-primitive?
     79  (ctxi message-digest-primitive-context-info)
     80  (digest-len message-digest-primitive-digest-length)
     81  (init message-digest-primitive-init)
     82  (update message-digest-primitive-update)
     83  (final message-digest-primitive-final)
     84  (block-len message-digest-primitive-block-length)
     85  (name message-digest-primitive-name)
     86  (raw-update message-digest-primitive-raw-update) )
     87
     88(define-check+error-type message-digest-primitive)
     89
     90;;
     91
    5792(define-inline (check-message-digest-arguments loc ctx-info digest-len init update final block-len name raw-update)
    58   (unless (primitive-ctx-info? ctx-info)
     93  (unless (primitive-context-info? ctx-info)
    5994    (error-argument-type loc ctx-info "positive-fixnum or procedure" 'context-info) )
    6095  (check-positive-fixnum loc digest-len 'digest-length)
     
    70105;;
    71106
    72 (define:-record-type message-digest-primitive
    73   (*make-message-digest-primitive ctxi digest-len init update final block-len name raw-update)
    74   message-digest-primitive?
    75   (ctxi (or fixnum procedure) message-digest-primitive-context-info)
    76   (digest-len fixnum message-digest-primitive-digest-length)
    77   (init procedure message-digest-primitive-init)
    78   (update procedure message-digest-primitive-update)
    79   (final procedure message-digest-primitive-final)
    80   (block-len fixnum message-digest-primitive-block-length)
    81   (name (or symbol string) message-digest-primitive-name)
    82   (raw-update procedure message-digest-primitive-raw-update) )
     107;assignment of value of type `(procedure message-digest-primitive#make-message-digest-primitive (* * * * * #!rest) (struct message-digest-primitive#message-digest-primitive))' to toplevel variable `message-digest-primitive#make-message-digest-primitive' does not match declared type `(procedure message-digest-primitive#make-message-digest-primitive ((or fixnum procedure) fixnum procedure procedure procedure #!rest *) (struct message-digest-primitive))'
     108(: make-message-digest-primitive (message-digest-primitive-context-info fixnum procedure procedure procedure #!rest -> message-digest-primitive))
     109;
     110(define (make-message-digest-primitive ctx-info digest-len init update final
     111            #!key (block-length 4) (name (gensym 'mdp)) (raw-update #f))
     112  (check-message-digest-arguments 'make-message-digest-primitive
     113    ctx-info digest-len init update final
     114    block-length name raw-update)
     115  (*make-message-digest-primitive
     116    ctx-info digest-len init update final
     117    block-length name raw-update) )
    83118
    84 (define-check+error-type message-digest-primitive)
     119;;
    85120
    86 (define: (make-message-digest-primitive
    87             (ctx-info (or fixnum procedure)) (digest-len fixnum)
    88             (init procedure) (update procedure) (final procedure)
    89             . (opts (list-of *))) -> message-digest-primitive
    90   ;
    91   (define (pull-arg args pred defprc)
    92     (if (and (not (null? args)) (pred (car args)))
    93       (values (car args) (cdr args))
    94       (values (defprc) args) ) )
    95   ;
    96   (let*-values (
    97     ((block-len opts)
    98       (pull-arg opts number? (lambda () 4)))
    99     ((name opts)
    100       (pull-arg opts (lambda (x) (not (procedure? x))) (lambda () (gensym 'mdp))))
    101     ((raw-update opts)
    102       (pull-arg opts procedure? (lambda () #f))) )
    103     (check-message-digest-arguments 'make-message-digest-primitive
    104       ctx-info digest-len init update final block-len name raw-update)
    105     (*make-message-digest-primitive
    106       ctx-info digest-len
    107       init update final
    108       block-len
    109       name
    110       raw-update) ) )
     121(: make-message-digest-primitive-context (message-digest-primitive-context-info -> *))
     122;
     123(define (make-message-digest-primitive-context ctx-info)
     124  (if (procedure? ctx-info)
     125    (ctx-info)
     126    (set-finalizer! (allocate ctx-info) free) ) )
    111127
    112128) ;module message-digest-primitive
Note: See TracChangeset for help on using the changeset viewer.