Changeset 34396 in project


Ignore:
Timestamp:
08/27/17 01:21:34 (3 months ago)
Author:
kon
Message:

add finalize-message-digest!, use let*-optionals

Location:
release/4/message-digest/trunk
Files:
4 edited

Legend:

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

    r34375 r34396  
    8888
    8989(define (make-message-digest-primitive ctx-info digest-len init update final . rest)
    90   (let-values (((block-len rest)
    91                 (if (and (not (null? rest)) (number? (car rest)))
    92                   (values (car rest) (cdr rest))
    93                   (values 4 rest) ) ) )
    94     (let-values (((name rest)
    95                   (if (and (not (null? rest)) (primitive-name? (car rest)))
    96                     (values (car rest) (cdr rest))
    97                     (values (gensym 'message-digest-primitive) rest) ) ) )
    98       (let-values (((raw-update rest)
    99                     (if (and (not (null? rest)) (procedure? (car rest)))
    100                       (values (car rest) (cdr rest))
    101                       (values #f rest) ) ) )
    102         (check-message-digest-arguments 'make-message-digest-primitive
    103           ctx-info digest-len init update final block-len name raw-update)
    104         (*make-message-digest-primitive
    105           ctx-info
    106           digest-len
    107           init update final
    108           block-len
    109           name
    110           raw-update) ) ) ) )
     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 (((block-len rest) (pull-arg rest number? (lambda () 4)))
     97                ((name rest) (pull-arg rest primitive-name? (lambda () (gensym 'message-digest-primitive))))
     98                ((raw-update rest) (pull-arg rest procedure? (lambda () #f))) )
     99    (check-message-digest-arguments 'make-message-digest-primitive
     100      ctx-info digest-len init update final block-len name raw-update)
     101    (*make-message-digest-primitive
     102      ctx-info digest-len
     103      init update final
     104      block-len
     105      name
     106      raw-update) ) )
    111107
    112108) ;module message-digest-primitive
  • release/4/message-digest/trunk/message-digest-type.scm

    r34302 r34396  
    1919  message-digest-algorithm message-digest-context
    2020  initialize-message-digest
    21   finalize-message-digest
     21  finalize-message-digest finalize-message-digest!
    2222  setup-message-digest-buffer!)
    2323
     
    2727  chicken
    2828  (only lolevel allocate free number-of-bytes)
    29   (only srfi-4 blob->u8vector/shared))
     29  (only srfi-4 blob->u8vector/shared u8vector-length u8vector?))
    3030(require-library
    3131  lolevel
     
    4848  miscmacros
    4949  message-digest-primitive)
     50
     51(declare
     52  (bound-to-procedure ##sys#slot) )
    5053
    5154;;; Support
     
    100103      #f ) ) )
    101104
     105(define (check-result-type loc mdp obj)
     106  (let ((siz
     107        (cond
     108          ((string? obj)
     109            (string-length obj))
     110          ((blob? obj)
     111            (blob-size obj))
     112          ((u8vector? obj)
     113            (u8vector-length obj))
     114          (else
     115            (error loc "unsupported result buffer" obj) ) ) )
     116        (rqr (message-digest-primitive-digest-length mdp)) )
     117    (unless (<= rqr siz)
     118      (error loc "result buffer too small" rqr obj) ) )
     119  obj )
     120
    102121;;; Message Digest API
    103122
     
    151170         (res
    152171          (make-blob (message-digest-primitive-digest-length mdp))) )
    153       ((message-digest-primitive-final mdp) (message-digest-context md) res)  ;side-effects res
     172      ;side-effects res
     173      ((message-digest-primitive-final mdp) (message-digest-context md) res)
    154174      (get-result-form 'finalize-message-digest res result-type) ) )
     175
     176(define (finalize-message-digest! md result-buffer)
     177  (let* ((mdp
     178          (message-digest-algorithm (check-message-digest 'finalize-message-digest md)))
     179         (res
     180          (check-result-type 'finalize-message-digest mdp result-buffer)) )
     181    ;side-effects res
     182    (let ((buf (if (u8vector? res) (##sys#slot res 1) res)))
     183      ((message-digest-primitive-final mdp) (message-digest-context md) buf) )
     184    res ) )
    155185
    156186;;
  • release/4/message-digest/trunk/message-digest.setup

    r34373 r34396  
    55(verify-extension-name "message-digest")
    66
    7 (setup-shared+static-extension-module 'message-digest-primitive (extension-version "3.4.0")
     7(setup-shared+static-extension-module 'message-digest-primitive (extension-version "3.5.0")
    88  #:inline? #t
    99        #:types? #t
     
    1212    -no-procedure-checks-for-toplevel-bindings))
    1313
    14 (setup-shared+static-extension-module 'message-digest-type (extension-version "3.4.0")
     14(setup-shared+static-extension-module 'message-digest-type (extension-version "3.5.0")
    1515  #:inline? #t
    1616        #:types? #t
     
    1919    -no-procedure-checks-for-toplevel-bindings))
    2020
    21 (setup-shared+static-extension-module 'message-digest-chunk (extension-version "3.4.0")
     21(setup-shared+static-extension-module 'message-digest-chunk (extension-version "3.5.0")
    2222  #:inline? #t
    2323        #:types? #t
     
    2626    -no-procedure-checks-for-toplevel-bindings))
    2727
    28 (setup-shared+static-extension-module 'message-digest-parameters (extension-version "3.4.0")
     28(setup-shared+static-extension-module 'message-digest-parameters (extension-version "3.5.0")
    2929  #:inline? #t
    3030        #:types? #t
     
    3333    -no-procedure-checks-for-toplevel-bindings))
    3434
    35 (setup-shared+static-extension-module 'message-digest-support (extension-version "3.4.0")
     35(setup-shared+static-extension-module 'message-digest-support (extension-version "3.5.0")
    3636  #:inline? #t
    3737        #:types? #t
     
    4040    -no-procedure-checks-for-toplevel-bindings))
    4141
    42 (setup-shared+static-extension-module 'message-digest-bv (extension-version "3.4.0")
     42(setup-shared+static-extension-module 'message-digest-bv (extension-version "3.5.0")
    4343  #:inline? #t
    4444        #:types? #t
     
    4747    -no-procedure-checks-for-toplevel-bindings))
    4848
    49 (setup-shared+static-extension-module 'message-digest-int (extension-version "3.4.0")
     49(setup-shared+static-extension-module 'message-digest-int (extension-version "3.5.0")
    5050  #:inline? #t
    5151        #:types? #t
     
    5454    -no-procedure-checks-for-toplevel-bindings))
    5555
    56 (setup-shared+static-extension-module 'message-digest-srfi-4 (extension-version "3.4.0")
     56(setup-shared+static-extension-module 'message-digest-srfi-4 (extension-version "3.5.0")
    5757  #:inline? #t
    5858        #:types? #t
     
    6161    -no-procedure-checks-for-toplevel-bindings))
    6262
    63 (setup-shared+static-extension-module 'message-digest-update-item (extension-version "3.4.0")
     63(setup-shared+static-extension-module 'message-digest-update-item (extension-version "3.5.0")
    6464  #:inline? #t
    6565        #:types? #t
     
    6868    -no-procedure-checks-for-toplevel-bindings))
    6969
    70 (setup-shared+static-extension-module 'message-digest-item (extension-version "3.4.0")
     70(setup-shared+static-extension-module 'message-digest-item (extension-version "3.5.0")
    7171  #:inline? #t
    7272        #:types? #t
     
    7575    -no-procedure-checks-for-toplevel-bindings))
    7676
    77 (setup-shared+static-extension-module 'message-digest-port (extension-version "3.4.0")
     77(setup-shared+static-extension-module 'message-digest-port (extension-version "3.5.0")
    7878  #:inline? #t
    7979        #:types? #t
     
    8282    -no-procedure-checks-for-toplevel-bindings))
    8383
    84 (setup-shared+static-extension-module 'message-digest-basic (extension-version "3.4.0")
     84(setup-shared+static-extension-module 'message-digest-basic (extension-version "3.5.0")
    8585  #:inline? #t
    8686        #:types? #t
     
    8989    -no-procedure-checks-for-toplevel-bindings))
    9090
    91 (setup-shared+static-extension-module 'message-digest (extension-version "3.4.0")
     91(setup-shared+static-extension-module 'message-digest (extension-version "3.5.0")
    9292  #:inline? #t
    9393        #:types? #t
  • release/4/message-digest/trunk/tests/run.scm

    r34373 r34396  
    102102    (assert (pointer? ctx))
    103103    (assert (eq? ctx the-ctx))
    104     (assert (blob? result))
    105     (assert (= digest-length (blob-size result)))  ; So no mem overflow
     104    (assert (or (blob? result) (string? result)))
     105    ; So no mem overflow
     106    (assert (<= digest-length (if (blob? result) (blob-size result) (string-length result))))
    106107    (move-memory! ctx result digest-length) )
    107108
     
    110111      (test-assert (message-digest? md))
    111112      (test-assert (message-digest-update-string md simple-src))
    112       (test simple-res (finalize-message-digest md)) ) )
     113      (test simple-res (finalize-message-digest md)) )
     114    (let ((md (initialize-message-digest mdp))
     115          (blb (make-blob 100)) )
     116      (message-digest-update-string md simple-src)
     117      (test-assert (finalize-message-digest! md blb))
     118      (print "result = " blb) )
     119    (let ((md (initialize-message-digest mdp))
     120          (str (make-string 100 #\space)) )
     121      (message-digest-update-string md simple-src)
     122      (test-assert (finalize-message-digest! md str))
     123      (print "result = " #\" str #\") )
     124    (let ((md (initialize-message-digest mdp))
     125          (vec (make-u8vector 100 0)) )
     126      (message-digest-update-string md simple-src)
     127      (test-assert (finalize-message-digest! md vec))
     128      (print "result = " vec) ) )
    113129)
    114130
Note: See TracChangeset for help on using the changeset viewer.