Changeset 13937 in project


Ignore:
Timestamp:
03/26/09 03:29:13 (11 years ago)
Author:
Kon Lovett
Message:

Save.

File:
1 edited

Legend:

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

    r5683 r13937  
    55;;
    66;; - Caches the bindings of R5RS & SRFI-13 string procedures so byte-oriented!
    7 
    8 (use extras srfi-1 srfi-4 srfi-9 srfi-13 srfi-69 lolevel)
    9 (use mathh-int miscmacros)
     7;;
     8;; - The ->fixnum/blob/... is approximate at best!
     9
    1010
    1111(eval-when (compile)
    1212        (declare
    1313                (not usual-integrations
    14                         inexact->exact integer? round number? modulo)
     14      inexact->exact integer? round number? modulo)
    1515                (fixnum)
    1616                (inline)
    1717                (no-procedure-checks)
    18                 (no-bound-checks)
    1918                (constant
     19                  int->hex
    2020                        ->fixnum
    2121                        ->blob
    2222                        ->blob/shared
    2323                        byte-string->hexadecimal)
     24    (bound-to-procedure
     25      message-digest-primitive?)
    2426                (export
    25                   ; Deperecated
    26                         string->substring-list/shared
    27                         string->substring-list
    28                         string->hexadecimal
    29                         ->byte-vector
    30                         ;
    3127                        byte-string->substring-list/shared
    3228                        byte-string->substring-list
     
    4743                        message-digest-primitive-apply) ) )
    4844
    49 ;;;
    50 
    51 (define (check-procedure obj loc)
     45(require-extension extras srfi-1 srfi-4 srfi-9 srfi-13 srfi-69 lolevel mathh-int miscmacros)
     46
     47;;;
     48
     49(define (check-procedure loc obj')
    5250  (unless (procedure? obj)
    53     (error loc "invalid procedure" obj) ) )
    54 
    55 ;;;
    56 
    57 (define byte-string->substring-list/shared
    58         (let ([byte-string-length string-length]
    59                                 [byte-substring/shared substring/shared])
    60                 (lambda (str chunk-size #!optional (start 0) (end (byte-string-length str)))
    61                         (let* (
    62                                         [rem (remainder (- end start) chunk-size)]
    63                                         [len (- end rem)]
    64                                         [sublst
    65                                                 (let loop ([pos start] [lst '()])
    66                                                         (if (>= pos len)
    67                   (reverse! lst)
    68                   (let ([npos (+ pos chunk-size)])
    69                     (loop npos (cons (byte-substring/shared str pos npos) lst)))))])
    70                                         (or (and (zero? rem) sublst)
    71                                                         (append sublst (list (byte-substring/shared str len end))) ) ) ) ) )
    72 
    73 (define byte-string->substring-list
    74         (let ([byte-string-length string-length])
    75                 (lambda (str chunk-size #!optional (start 0) (end (byte-string-length str)))
    76                         (map! string-copy (byte-string->substring-list/shared str chunk-size start end)) ) ) )
    77 
    78 (define byte-string->hexadecimal
    79         (let ([byte-string-length string-length]
    80                                 [byte-string-for-each string-for-each])
    81                 (lambda (str . len)
    82                         (with-output-to-string
    83                                 (lambda ()
    84                                         (byte-string-for-each
    85                                                 (lambda (char)
    86                                                         (let ([int (char->integer char)])
    87                                                                 (printf (if (>= int 16) "~X" "0~X") int)))
    88                                                 str
    89                                                 0 (optional len (byte-string-length str))))) ) ) )
    90 
    91 ;;;
    92 
    93 ;; This is approximate at best!
     51    (error loc "bad argument type - expected a procedure" obj) ) )
     52
     53(define (check-message-digest-primitive loc obj)
     54  (unless (message-digest-primitive? obj)
     55    (error loc "bad argument type - expected a message-digest-primitive" obj) ) )
     56
     57(define (check-context-info loc obj)
     58  (unless (or (fixnum? obj) (procedure? obj))
     59    (error loc "bad argument type - expected a fixnum or procedure" ctx-info) ) )
     60
     61;;; Cache
     62
     63(define byte-string-length string-length)
     64(define byte-substring/shared substring/shared)
     65(define byte-string-copy string-copy)
     66(define byte-string-for-each string-for-each)
     67(define list->byte-string list->string)
     68(define make-byte-string make-string)
     69
     70;;;
     71
     72(define (byte-string->substring-list/shared str chunk-size #!optional (start 0) (end (byte-string-length str)))
     73  (let* ((rem (remainder (- end start) chunk-size))
     74         (len (- end rem))
     75         (sublst
     76          (let loop ((pos start) (lst '()))
     77            (if (>= pos len) (reverse! lst)
     78                (let ((npos (+ pos chunk-size)))
     79                  (loop npos (cons (byte-substring/shared str pos npos) lst)))))))
     80      (if (zero? rem) sublst
     81          (append sublst (list (byte-substring/shared str len end))) ) ) )
     82
     83(define (byte-string->substring-list str chunk-size #!optional (start 0) (end (byte-string-length str)))
     84  (map! byte-string-copy (byte-string->substring-list/shared str chunk-size start end)) )
     85
     86(define (int->hex ch)
     87  (let* ((int (char->integer ch))
     88         (str (number->string int 16)))
     89    (if (< int 16) (conc #\0 str) str) ) )
     90
     91(define (byte-string->hexadecimal str #!optional (len (byte-string-length str)))
     92  (with-output-to-string (lambda () (byte-string-for-each int->hex str 0 len) ) ) )
     93
     94;;;
    9495
    9596(define (->fixnum obj)
    96         (let (
    97                         [->integer
    98                                 (lambda (obj)
    99                                         (cond [(integer? obj)   obj]
    100                 [(number? obj)    (round obj)]
    101                 [else             (hash obj most-positive-fixnum)]) )])
    102                 (cond [(fixnum? obj)    obj]
    103           [(char? obj)      (char->integer obj)]
    104           [(boolean? obj)   (or (and obj 1) 0)]
    105           [else
    106             (let ([i (->integer obj)])
    107               (inexact->exact
    108                 (cond [(< i most-negative-fixnum)   (modulo i most-negative-fixnum)]
    109                       [(< most-positive-fixnum i)   (modulo i most-positive-fixnum)]
    110                       [else                         i ] ) ) ) ]) ) )
    111 
    112 (define ->blob
    113   (let ([list->byte-string list->string])
    114     (lambda (obj)
    115       (cond [(blob? obj)            obj]
    116             [(string? obj)          (string->blob obj)]
    117             [(list? obj)            (->blob (list->byte-string (map ->fixnum obj)))]
    118             [(vector? obj)          (->blob (vector->list obj))]
    119             [(u8vector? obj)        (u8vector->blob obj)]
    120             [(s8vector? obj)        (s8vector->blob obj)]
    121             [(u16vector? obj)       (u16vector->blob obj)]
    122             [(s16vector? obj)       (s16vector->blob obj)]
    123             [(u32vector? obj)       (u32vector->blob obj)]
    124             [(s32vector? obj)       (s32vector->blob obj)]
    125             [(f32vector? obj)       (f32vector->blob obj)]
    126             [(f64vector? obj)       (f64vector->blob obj)]
    127             [else                   #f ] ) ) ) )
     97        (let ((->integer
     98         (lambda (obj)
     99                                   (cond ((integer? obj)   obj)
     100                 ((number? obj)    (round obj))
     101                 (else             (hash obj most-positive-fixnum) ) ) ) ) )
     102                (cond ((fixnum? obj)    obj)
     103          ((char? obj)      (char->integer obj))
     104          ((boolean? obj)   (if obj 1 0))
     105          (else
     106           (let ((i (->integer obj)))
     107             (inexact->exact
     108              (cond ((< i most-negative-fixnum)   (modulo i most-negative-fixnum))
     109                    ((< most-positive-fixnum i)   (modulo i most-positive-fixnum))
     110                    (else                         i ) ) ) ) ) ) ) )
     111
     112(define (->blob obj)
     113  (cond ((blob? obj)            obj)
     114        ((string? obj)          (string->blob obj))
     115        ((list? obj)            (->blob (list->byte-string (map ->fixnum obj))))
     116        ((vector? obj)          (->blob (vector->list obj)))
     117        ((u8vector? obj)        (u8vector->blob obj))
     118        ((s8vector? obj)        (s8vector->blob obj))
     119        ((u16vector? obj)       (u16vector->blob obj))
     120        ((s16vector? obj)       (s16vector->blob obj))
     121        ((u32vector? obj)       (u32vector->blob obj))
     122        ((s32vector? obj)       (s32vector->blob obj))
     123        ((f32vector? obj)       (f32vector->blob obj))
     124        ((f64vector? obj)       (f64vector->blob obj))
     125        ((or (number? obj) (char? obj) (boolean? obj)) (->fixnum obj))
     126        (else                   (->blob (->string obj)) ) ) )
    128127
    129128(define (->blob/shared obj)
    130   (cond [(u8vector? obj)        (u8vector->blob/shared obj)]
    131         [(s8vector? obj)        (s8vector->blob/shared obj)]
    132         [(u16vector? obj)       (u16vector->blob/shared obj)]
    133         [(s16vector? obj)       (s16vector->blob/shared obj)]
    134         [(u32vector? obj)       (u32vector->blob/shared obj)]
    135         [(s32vector? obj)       (s32vector->blob/shared obj)]
    136         [(f32vector? obj)       (f32vector->blob/shared obj)]
    137         [(f64vector? obj)       (f64vector->blob/shared obj)]
    138         [else                   (->blob obj) ] ) )
     129  (cond ((u8vector? obj)        (u8vector->blob/shared obj))
     130        ((s8vector? obj)        (s8vector->blob/shared obj))
     131        ((u16vector? obj)       (u16vector->blob/shared obj))
     132        ((s16vector? obj)       (s16vector->blob/shared obj))
     133        ((u32vector? obj)       (u32vector->blob/shared obj))
     134        ((s32vector? obj)       (s32vector->blob/shared obj))
     135        ((f32vector? obj)       (f32vector->blob/shared obj))
     136        ((f64vector? obj)       (f64vector->blob/shared obj))
     137        (else                   (->blob obj) ) ) )
    139138
    140139;;;
     
    144143(define-parameter message-digest-chunk-size CHUNK-SIZE
    145144  (lambda (x)
    146     (if (and (fixnum? x) (positive? x))
    147         x
    148         (begin
    149           (warning "invalid message-digest chunk-size" x)
    150           (message-digest-chunk-size) ) ) ) )
     145    (cond ((and (fixnum? x) (positive? x)) x)
     146          (else
     147           (warning 'message-digest-chunk-size "bad argument type - expected a positive fixnum" x)
     148           (message-digest-chunk-size) ) ) ) )
    151149
    152150(define-record-type message-digest-primitive
     
    160158        (name message-digest-primitive-name) )
    161159
    162 (define-inline (*read-u8vector! siz buf obj)
    163   (let ([len (read-u8vector! siz buf obj)])
     160(define-inline (%read-u8vector! siz buf obj)
     161  (let ((len (read-u8vector! siz buf obj)))
    164162    (and (positive? len)
    165163         len ) ) )
    166164
    167 (define make-binary-message-digest
    168         (let ([byte-string-length string-length]
    169                                 [make-byte-string make-string])
    170                 (lambda (obj ctx-info digest-len init update final . caller)
    171       (check-procedure init 'make-binary-message-digest)
    172       (check-procedure update 'make-binary-message-digest)
    173       (check-procedure final 'make-binary-message-digest)
    174                         (let ([loc (optional caller 'make-binary-message-digest)]
    175                                                 [ctx #f])
    176                                 (dynamic-wind
    177                                         (lambda ()
    178                                                 (set! ctx
    179                                                         (cond [(fixnum? ctx-info)     (allocate ctx-info)]
    180                     [(procedure? ctx-info)  (ctx-info)]
    181                     [else
    182                       (error loc "invalid context information" ctx-info)])))
    183                                         (lambda ()
    184                                                 (init ctx)
    185                                                 (cond [(string? obj)
    186                     (update ctx obj (byte-string-length obj))]
    187                   [(input-port? obj)
    188                    (let* ([siz (message-digest-chunk-size)]
    189                           [buf (make-u8vector siz)])
    190                      (while* (*read-u8vector! siz buf obj)
    191                        (update ctx buf it) ) ) ]
    192                   [else
    193                     (if* (->blob/shared obj)
    194                         (update ctx it (blob-size it))
    195                         (error loc "cannot convert to blob" obj))])
    196                                                 (let ([result (make-byte-string digest-len)])
    197                                                         (final ctx result)
    198                                                         result))
    199                                         (lambda ()
    200                                                 (when (fixnum? ctx-info)
    201                                                         (free ctx) ) ) ) ) ) ) )
     165(define (make-binary-message-digest obj ctx-info digest-len init update final #!optional (loc 'make-binary-message-digest))
     166        (check-procedure 'make-binary-message-digest init)
     167  (check-procedure 'make-binary-message-digest update)
     168  (check-procedure 'make-binary-message-digest final)
     169  (check-context-info loc ctx-info)
     170  (let ((ctx #f))
     171    (dynamic-wind
     172      (lambda () (set! ctx (if (fixnum? ctx-info) (allocate ctx-info) (ctx-info))) )
     173      (lambda ()
     174        (init ctx)
     175        (cond ((string? obj)
     176               (update ctx obj (byte-string-length obj)) )
     177              ((input-port? obj)
     178               (let* ((siz (message-digest-chunk-size))
     179                      (buf (make-u8vector siz)))
     180                 (while* (%read-u8vector! siz buf obj) (update ctx buf it)) ) )
     181              (else
     182               (let ((blb (->blob/shared obj)))
     183                (update ctx blb (blob-size blb)) ) ) )
     184        (let ((result (make-byte-string digest-len)))
     185          (final ctx result)
     186          result ) )
     187      (lambda () (when (fixnum? ctx-info) (free ctx)) ) ) ) )
    202188
    203189(define (make-message-digest obj ctx-info digest-len init update final . caller)
    204190        (string->hexadecimal
    205                 (make-binary-message-digest obj
    206                         ctx-info digest-len
    207                         init update final
    208                         (optional caller 'make-message-digest))
    209                 digest-len) )
     191   (make-binary-message-digest obj
     192    ctx-info digest-len
     193    init update final
     194    (optional caller 'make-message-digest))
     195   digest-len) )
    210196
    211197(define (make-message-digest-primitive ctx-info digest-len init update final . name)
    212198        (%make-message-digest-primitive
    213                 ctx-info digest-len
    214                 init update final
    215                 (optional name (gensym "mdp"))) )
     199   ctx-info digest-len
     200   init update final
     201   (optional name (gensym "mdp"))) )
    216202
    217203(define (message-digest-primitive-apply md-prim obj . caller)
    218         (unless (message-digest-primitive? md-prim)
    219                 (error 'message-digest-primitive-apply "not a message-digest-primitive" md-prim))
     204  (check-message-digest-primitive 'message-digest-primitive-apply md-prim)
    220205        (make-binary-message-digest obj
    221                 (message-digest-primitive-context-info md-prim)
    222                 (message-digest-primitive-digest-length md-prim)
    223                 (message-digest-primitive-init md-prim)
    224                 (message-digest-primitive-update md-prim)
    225                 (message-digest-primitive-final md-prim)
    226                 (optional caller 'message-digest-primitive-apply)) )
    227 
    228 ;;;
    229 
    230 (define string->substring-list/shared byte-string->substring-list/shared)
    231 (define string->substring-list byte-string->substring-list)
    232 (define string->hexadecimal byte-string->hexadecimal)
    233 (define ->byte-vector ->blob)
     206         (message-digest-primitive-context-info md-prim)
     207         (message-digest-primitive-digest-length md-prim)
     208         (message-digest-primitive-init md-prim)
     209         (message-digest-primitive-update md-prim)
     210         (message-digest-primitive-final md-prim)
     211         (optional caller 'message-digest-primitive-apply)) )
Note: See TracChangeset for help on using the changeset viewer.