Changeset 18776 in project


Ignore:
Timestamp:
07/10/10 05:09:44 (11 years ago)
Author:
Kon Lovett
Message:

Save.

File:
1 edited

Legend:

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

    r18775 r18776  
    1414        (;export
    1515          ; Aux
    16                 byte-string->hexadecimal
     16                byte-string->hexadecimal    ;FIXME this doesn't belong here
    1717                ; Parameters
    1818                message-digest-chunk-size
     
    2828                message-digest-primitive-update
    2929                message-digest-primitive-final
    30                 ;
     30                ; MD API
    3131                begin-message-digest    ;start-message-digest ?
    3232                message-digest? check-message-digest error-message-digest
    3333                end-message-digest      ;finish-message-digest ?
    34                 message-digest-update
     34                message-digest-update-object
    3535                message-digest-update-string
    3636                message-digest-update-blob
     
    4444                message-digest-update-file
    4545                ;
    46                 message-digest
     46                message-digest-object
    4747                message-digest-string
    4848                message-digest-blob
     
    5252                make-binary-message-digest
    5353                make-message-digest
    54                 message-digest-primitive-apply
    55                 )
     54                message-digest-primitive-apply)
    5655
    5756  (import
     
    137136  (check-procedure loc final 'digest-finalizer) )
    138137
    139 #| ;UNUSED
    140 
    141 (define (allocate-message-digest-context ctx-info)
    142   (if (procedure? ctx-info) (ctx-info)
    143       (allocate ctx-info) ) )
    144 
    145 (define (free-message-digest-context ctx ctx-info)
    146   (when (and ctx (number? ctx-info))
    147     (free ctx) ) )
    148 
    149 (define-syntax with-mpd-n-ctx
    150   (er-macro-transformer
    151     (lambda (frm rnm cmp)
    152       (let ((_let* (rnm 'let*))
    153             (_call-with-current-continuation (rnm 'call-with-current-continuation))
    154             (_lambda (rnm 'lambda))
    155             (_with-exception-handler (rnm 'with-exception-handler))
    156             (_free-message-digest-context (rnm 'free-message-digest-context))
    157             (_message-digest-primitive-context-info (rnm 'message-digest-primitive-context-info))
    158             (_abort (rnm 'abort))
    159             (mdp-exp (cadr frm))
    160             (ctx-exp (caddr frm))
    161             (body (cdddr frm)) )
    162       `(,_let* ((mdp ,mdp-exp)
    163                 (ctx ,ctx-exp))
    164         ; "hand-rolled" 'handle-exceptions'
    165         (
    166           (,_call-with-current-continuation
    167             (,_lambda (k)
    168               (,_with-exception-handler
    169                 (,_lambda (exn)
    170                   (k
    171                     (_lambda ()
    172                       (,_free-message-digest-context ctx (,_message-digest-primitive-context-info mdp))
    173                       (,_abort exn))))
    174                 (,_lambda ()
    175                   (_lambda () ,@body))))))) ) ) ) )
    176 |#
    177 
    178 (define (allocate-message-digest-context ctx-info)
     138(define-inline (allocate-message-digest-context ctx-info)
    179139  (if (procedure? ctx-info) (ctx-info)
    180140      (let ((mem (allocate ctx-info)))
    181141        (set-finalizer! mem free)
    182142        mem ) ) )
    183 
    184 (define-syntax with-mpd-n-ctx
    185   (er-macro-transformer
    186     (lambda (frm rnm cmp)
    187       (let ((_let* (rnm 'let*))
    188             (mdp-exp (cadr frm))
    189             (ctx-exp (caddr frm))
    190             (body (cdddr frm)) )
    191       `(,_let* ((mdp ,mdp-exp)
    192                 (ctx ,ctx-exp) )
    193           ,@body ) ) ) ) )
    194143
    195144(define (XXXvector->blob obj)
     
    284233(define (begin-message-digest mdp)
    285234  (check-message-digest-primitive 'begin-message-digest mdp)
    286   (with-mpd-n-ctx
    287       mdp (allocate-message-digest-context (message-digest-primitive-context-info mdp))
     235  (let ((ctx (allocate-message-digest-context (message-digest-primitive-context-info mdp))))
    288236    ((message-digest-primitive-init mdp) ctx)
    289237    (*make-message-digest mdp ctx) ) )
     
    291239(define (end-message-digest md #optional (result-type 'hex))
    292240  (check-message-digest 'end-message-digest md)
    293   (with-mpd-n-ctx
    294       (message-digest-primitive md) (message-digest-context md)
     241  (let ((mdp (message-digest-primitive md))
     242        (ctx (message-digest-context md)) )
    295243    (let ((res (make-byte-string (message-digest-primitive-digest-length mdp))))
    296244      ((message-digest-primitive-final mdp) ctx res)
    297       (get-result-as-type loc res result-type)
    298       #; ;UNUSED
    299       (let ((ret (get-result-as-type loc res result-type)))
    300         (free-message-digest-context ctx (message-digest-primitive-context-info mdp))
    301         ret ) ) ) )
    302 
    303 (define (message-digest-update md src)
    304   (check-message-digest 'message-digest-update md)
    305   (with-mpd-n-ctx
    306       (message-digest-primitive md) (message-digest-context md)
    307     (update-from-source
    308       'message-digest-update
    309       ctx src (message-digest-primitive-update mdp)) ) )
     245      (get-result-as-type loc res result-type) ) ) )
     246
     247(define (message-digest-update-object md src)
     248  (check-message-digest 'message-digest-update-object md)
     249  (let ((mdp (message-digest-primitive md))
     250        (ctx (message-digest-context md)) )
     251    (update-from-source 'message-digest-update ctx src (message-digest-primitive-update mdp)) ) )
     252
     253(define-inline (*message-digest-update-string md src)
     254  (let ((mdp (message-digest-primitive md))
     255        (ctx (message-digest-context md)) )
     256    ((message-digest-primitive-update mdp) ctx src (byte-string-length src)) ) )
    310257
    311258(define (message-digest-update-string md src)
    312259  (check-message-digest 'message-digest-update-string md)
    313260  (check-string 'message-digest-update-string src)
    314   (with-mpd-n-ctx
    315       (message-digest-primitive md) (message-digest-context md)
    316     ((message-digest-primitive-update mdp) ctx src (byte-string-length src)) ) )
    317 
    318 (define (*message-digest-update-blob md src)
    319   (with-mpd-n-ctx
    320       (message-digest-primitive md) (message-digest-context md)
     261  (*message-digest-update-string md src) )
     262
     263(define-inline (*message-digest-update-blob md src)
     264  (let ((mdp (message-digest-primitive md))
     265        (ctx (message-digest-context md)) )
    321266    ((message-digest-primitive-update mdp) ctx src (blob-size src)) ) )
    322267
     
    341286  (check-message-digest 'message-digest-update-substring md)
    342287  (check-u8vector 'message-digest-update-substring src)
    343   )
     288  (*message-digest-update-string md (substring/shared src start end)) )
    344289
    345290#; ;NOT YET
     
    390335  (*message-digest-update-u64 'message-digest-update-u64-le md n 'le 8) )
    391336
    392 #|
     337#| ; Inline version of above
    393338(define (message-digest-update-u16 md n #!optional (endian (machine-byte-order)))
    394339  (check-message-digest 'message-digest-update-u16 md)
     
    480425  (check-message-digest 'message-digest-update-procedure md)
    481426  (check-procedure 'message-digest-update-procedure src)
    482   (with-mpd-n-ctx
    483       (message-digest-primitive md) (message-digest-context md)
     427  (let ((mdp (message-digest-primitive md))
     428        (ctx (message-digest-context md)) )
    484429    (update-while-procedure
    485430      'message-digest-update-procedure
     
    489434  (check-message-digest 'message-digest-update-port md)
    490435  (check-input-port 'message-digest-update-port src)
    491   (with-mpd-n-ctx
    492       (message-digest-primitive md) (message-digest-context md)
     436  (let ((mdp (message-digest-primitive md))
     437        (ctx (message-digest-context md)) )
    493438    (update-while-procedure
    494439      'message-digest-update-port
     
    501446    (handle-exceptions exn
    502447        (begin (close-input-port in) (abort exn))
    503       (with-mpd-n-ctx
    504           (message-digest-primitive md) (message-digest-context md)
     448      (let ((mdp (message-digest-primitive md))
     449            (ctx (message-digest-context md)) )
    505450        (update-while-procedure
    506451          'message-digest-update-port
     
    510455;;; Till completion API
    511456
    512 ;FIXME - I do not like this name, conflicts w/ the, potential, type descriptor binding
    513 (define (message-digest mdp src #optional (result-type 'hex))
     457(define (message-digest-object mdp src #optional (result-type 'hex))
    514458  (let ((md (begin-message-digest mdp)))
    515     (message-digest-update md src)
     459    (message-digest-update-object md src)
    516460    (end-message-digest md result-type) ) )
    517461
     
    540484;;
    541485
    542 (define (message-digest-primitive-apply mdp src . args) (message-digest mdp src 'string))
     486(define (message-digest-primitive-apply mdp src . args)
     487  (message-digest-object mdp src 'string) )
    543488
    544489;;
    545490
    546491(define (make-binary-message-digest src ctx-info digest-len init update final
    547                                     #!optional (loc 'make-binary-message-digest))
    548   (message-digest-primitive-apply
    549     (make-message-digest-primitive ctx-info digest-len init update final loc)
    550     src) )
     492                                    #!optional (name 'make-binary-message-digest))
     493  (message-digest-object
     494    (make-message-digest-primitive ctx-info digest-len init update final name)
     495    src
     496    'string) )
    551497
    552498;;
    553499
    554500(define (make-message-digest src ctx-info digest-len init update final
    555                              #!optional (loc 'make-message-digest))
    556   (byte-string->hexadecimal
    557     (make-binary-message-digest src ctx-info digest-len init update final loc)) )
     501                             #!optional (name 'make-message-digest))
     502  (message-digest-object
     503    (make-message-digest-primitive ctx-info digest-len init update final name)
     504    src
     505    'hex) )
    558506
    559507) ;module message-digest
Note: See TracChangeset for help on using the changeset viewer.