Changeset 35349 in project


Ignore:
Timestamp:
03/26/18 08:04:16 (6 months ago)
Author:
kon
Message:

add -chunk type, add types

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

Legend:

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

    r35344 r35349  
    1111(define-type srfi4vector
    1212  (or u8vector s8vector u16vector s16vector u32vector s32vector f32vector f64vector))
     13
     14(define-type message-digest-raw-chunk (struct message-digest-raw-chunk))
    1315
    1416#; ;desired, bufpointer is (pointer + length)
  • release/4/message-digest/trunk/message-digest-update-item.scm

    r35345 r35349  
    3535;;
    3636
     37(include "message-digest-types")
     38
     39;;
     40
     41(define-type converted-chunk (or blob string message-digest-raw-chunk))
     42
     43;;
     44
    3745;=> #f or converted-chunk
    38 (define (chunk-convert obj)
     46(define: (chunk-convert (obj *)) -> converted-chunk
    3947  (and-let* (
    4048    (cnv (message-digest-chunk-converter)) )
    4149    (cnv obj) ) )
    4250
    43 (define (get-port-chunk-reader in)
    44         ((message-digest-chunk-port-read-maker) in) )
    45 
    46 (define (get-fileno-chunk-reader fd)
     51(define: (get-port-chunk-reader (port input-port)) -> procedure
     52        ((message-digest-chunk-port-read-maker) port) )
     53
     54(define: (get-fileno-chunk-reader (fd fixnum)) -> procedure
    4755        ((message-digest-chunk-fileno-read-maker) fd) )
    4856
    49 (define (get-update md)
     57(define: (get-update (md message-digest)) -> procedure
    5058  (message-digest-primitive-update (message-digest-algorithm md)) )
    5159
    52 (define (get-raw-update md)
     60(define: (get-raw-update (md message-digest)) -> procedure
    5361  (message-digest-primitive-raw-update (message-digest-algorithm md)) )
    5462
    5563;;
    5664
    57 (define (do-object-update loc md src start end)
     65(define: (do-object-update (loc symbol) (md message-digest) (src *) (start fixnum) (end (or boolean fixnum)))
    5866  (cond
    5967    ((input-port? src)    (do-port-update loc md src start end) )
     
    6169    (else                 (do-bytes-update loc md src start end) ) ) )
    6270
    63 (define (do-port-update loc md in start end)
    64   (do-procedure-update loc md (get-port-chunk-reader in) start end) )
    65 
    66 (define (do-bytes-update loc md src start end)
     71(define: (do-port-update (loc symbol) (md message-digest) (port input-port) (start fixnum) (end (or boolean fixnum)))
     72  (do-procedure-update loc md (get-port-chunk-reader port) start end) )
     73
     74(define: (do-procedure-update (loc symbol) (md message-digest) (proc procedure) (start fixnum) (end (or boolean fixnum)))
     75  (let (
     76    (src-updt (get-update md))
     77    (raw-updt (get-raw-update md))
     78    (ctx (message-digest-context md)) )
     79    ;note the 'src' object (return of proc) may or may not be unique
     80    (while* (proc)
     81      (do-byte-source-update loc ctx it src-updt raw-updt start end) ) ) )
     82
     83(define: (do-bytes-update (loc symbol) (md message-digest) (src *) (start fixnum) (end (or boolean fixnum)))
    6784  (do-byte-source-update
    6885    loc
     
    7390    start end) )
    7491
    75 (define (do-procedure-update loc md proc start end)
    76   (let (
    77     (src-updt (get-update md))
    78     (raw-updt (get-raw-update md))
    79     (ctx (message-digest-context md)) )
    80     ;note the 'src' object (return of proc) may or may not be unique
    81     (while* (proc)
    82       (do-byte-source-update loc ctx it src-updt raw-updt start end) ) ) )
    83 
    84 (define (do-byte-source-update loc ctx src src-updt raw-updt start end)
     92(define: (do-byte-source-update (loc symbol) (ctx *) (src *) (src-updt procedure) (raw-updt procedure) (start fixnum) (end (or boolean fixnum)))
    8593  (cond
    86     ; simple bytes
     94    ;simple bytes
    8795    ((blob? src)
    88       (let ((src (blob/slice src start end)))
    89           (src-updt ctx src (blob-size src)) ) )
     96      (let (
     97        (blb
     98          (blob/slice src start end)) )
     99          (src-updt ctx blb (blob-size blb)) ) )
    90100    ((string? src)
    91       (let ((src (string/slice src start end)))
    92           (src-updt ctx src (string-length src)) ) )
     101      (let (
     102        (str
     103          (string/slice src start end)) )
     104          (src-updt ctx str (string-length str)) ) )
    93105    ((message-digest-raw-chunk? src)
    94       (let* ((obj (message-digest-raw-chunk-object src))
    95              (updtr (if (pointer? obj) raw-updt src-updt)))
    96         (unless updtr
     106      (let* (
     107        (obj (message-digest-raw-chunk-object src))
     108        (updator (if (pointer? obj) raw-updt src-updt)) )
     109        (unless updator
    97110          (error loc "primitive does not support raw-update") )
    98         (updtr ctx
     111        ;FIXME xtra arg (message-digest-raw-chunk-start src)
     112        (updator ctx
    99113          obj
    100           (message-digest-raw-chunk-size src)
    101           #;(message-digest-raw-chunk-start src)
    102           ) ) )
    103     ; more complicated bytes
     114          (message-digest-raw-chunk-size src)) ) )
     115    ;more complicated bytes
    104116    ((object->bytevector-like src) =>
    105117        (cut do-byte-source-update loc ctx <> src-updt raw-updt start end) )
    106     ; too complicated bytes
     118    ;too complicated bytes
    107119    (else
    108120      (signal-type-error loc "indigestible object" src start end) ) ) )
    109121
    110 ;;
    111 
    112 ;=> #f or bytevector-like
    113 (define (object->bytevector-like obj)
     122(define: (object->bytevector-like (obj *)) -> converted-chunk
    114123  (or
    115124    (packed-vector->blob/shared obj)
     
    120129;;
    121130
    122 (define (message-digest-update-object md obj #!optional (start 0) (end #f))
    123   (do-object-update
    124     'message-digest-update-object
    125     (check-message-digest 'message-digest-update-object md)
    126     obj
    127     start end) )
    128 
    129 ;;
    130 
    131 (define (message-digest-update-procedure md proc)
     131(define: (message-digest-update-object (md message-digest) (obj *) . (opts list))
     132  (let-optionals* opts (
     133    (start 0)
     134    (end #f) )
     135    (do-object-update
     136      'message-digest-update-object
     137      (check-message-digest 'message-digest-update-object md)
     138      obj
     139      start end) ) )
     140
     141;;
     142
     143(define: (message-digest-update-procedure (md message-digest) (proc procedure))
    132144  (do-procedure-update
    133145    'message-digest-update-procedure
     
    138150;;
    139151
    140 (define (message-digest-update-port md in)
     152(define: (message-digest-update-port (md message-digest) (port input-port))
    141153  (do-port-update
    142154    'message-digest-update-port
    143155    (check-message-digest 'message-digest-update-port md)
    144     (check-input-port 'message-digest-update-port in)
     156    (check-input-port 'message-digest-update-port port)
    145157    0 #f) )
    146158
    147159;;
    148160
    149 (define (message-digest-update-file md flnm)
     161(define: (message-digest-update-file (md message-digest) (flnm pathname))
    150162  ;
    151163  (unless (file-exists? (check-string 'message-digest-update-file flnm))
     
    160172    (*message-digest-update-file/port 'message-digest-update-file md flnm) ) )
    161173
    162 (define (*message-digest-update-file/fileno loc md flnm)
     174(define: (*message-digest-update-file/fileno (loc symbol) (md message-digest) (flnm pathname))
    163175  (let (
    164176    (fd (file-open flnm open/rdonly)) )
    165     (handle-exceptions
    166       ;as
    167       exn
    168       ;with
    169       (begin
    170         (file-close fd)
    171         (abort exn) )
    172       ;in
     177    (handle-exceptions exn
     178        (begin
     179          (file-close fd)
     180          (abort exn) )
    173181      (do-procedure-update loc md (get-fileno-chunk-reader fd) 0 #f) )
    174182    (file-close fd) ) )
    175183
    176 (define (*message-digest-update-file/port loc md flnm)
     184(define: (*message-digest-update-file/port (loc symbol) (md message-digest) (flnm pathname))
    177185  (let (
    178186    (in (open-input-file flnm)) )
    179     (handle-exceptions
    180       ;as
    181       exn
    182       ;with
    183       (begin
    184         (close-input-port in)
    185         (abort exn) )
    186       ;in
     187    (handle-exceptions exn
     188        (begin
     189          (close-input-port in)
     190          (abort exn) )
    187191      (do-port-update loc md in 0 #f) )
    188192    (close-input-port in) ) )
    189193
    190194#; ;book implementation
    191 (define (message-digest-update-file md flnm)
     195(define: (message-digest-update-file (md message-digest) (flnm pathname))
    192196  (let ((in #f))
    193197        (dynamic-wind
Note: See TracChangeset for help on using the changeset viewer.