Changeset 35342 in project


Ignore:
Timestamp:
03/25/18 21:06:15 (6 months ago)
Author:
kon
Message:

add types to -chunk, bix -bv use before -check, rmv fx-utils dep (in mathh), add typed-define dep (in dsssl-utils), rmv dup type

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

Legend:

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

    r35341 r35342  
    3838;;
    3939
    40 ;FIXME do not 'type' check-/error- procs
    41 
    42 (define (check-blob/slice loc blb start end)
    43   (check-fixnum-range loc start end)
    44   (blob/slice (check-blob loc blb) start end) )
    45 
    46 (define (check-string/slice loc str start end)
    47   (check-fixnum-range loc start end)
    48   (string/slice (check-string loc str) start end) )
    49 
    5040(define (check-fixnum-range loc start end)
    51   (check-range loc
    52     (check-natural-fixnum loc start 'start)
    53     (check-natural-fixnum loc end 'end)
    54     "end < start") )
     41  ;FIXME chicken does not like dropping a multi-valued result on the floor
     42  (receive
     43    (check-range loc
     44      (check-natural-fixnum loc start 'start)
     45      (check-natural-fixnum loc end 'end)
     46      "end < start")) )
    5547
    5648;;; Message Digest API
     
    6557  (let-optionals* opts (
    6658    (start 0)
    67     (end (blob-size blb)) )
     59    (end (blob-size (check-blob 'message-digest-update-blob blb))) )
     60    (check-fixnum-range 'message-digest-update-blob start end)
    6861    (*message-digest-update-blob
    6962      (check-message-digest 'message-digest-update-blob md)
    70       (check-blob/slice 'message-digest-update-blob blb start end)) ) )
     63      (blob/slice blb start end)) ) )
    7164
    7265;;
     
    7568  (let-optionals* opts (
    7669    (start 0)
    77     (end (string-length str)) )
     70    (end (string-length (check-string 'message-digest-update-string str))) )
     71    (check-fixnum-range 'message-digest-update-string start end)
    7872    (*message-digest-update-string
    7973      (check-message-digest 'message-digest-update-string md)
    80       (check-string/slice 'message-digest-update-string str start end)) ) )
     74      (string/slice str start end)) ) )
    8175
    8276;;
     
    8882    (restyp (message-digest-result-form))
    8983    (start 0)
    90     (end (blob-size blb)) )
     84    (end (blob-size (check-blob 'message-digest-blob blb))) )
    9185    (let (
    9286      (md (initialize-message-digest mdp)) )
     87      (check-fixnum-range 'message-digest-blob start end)
    9388      (message-digest-update-blob md blb start end)
    9489      (finalize-message-digest md restyp) ) ) )
     
    9893    (restyp (message-digest-result-form))
    9994    (start 0)
    100     (end (string-length str)) )
     95    (end (string-length (check-string 'message-digest-string str))) )
    10196    (let (
    10297      (md (initialize-message-digest mdp)) )
     98      (check-fixnum-range 'message-digest-string start end)
    10399      (message-digest-update-string md str start end)
    104100      (finalize-message-digest md restyp) ) ) )
     
    107103  (let-optionals* opts (
    108104    (start 0)
    109     (end (blob-size blb)) )
     105    (end (blob-size (check-blob 'message-digest-blob! blb))) )
    110106    (let (
    111107      (md (initialize-message-digest mdp)) )
     108      (check-fixnum-range 'message-digest-blob! start end)
    112109      (message-digest-update-blob md blb start end)
    113110      (finalize-message-digest! md buf) ) ) )
     
    116113  (let-optionals* opts (
    117114    (start 0)
    118     (end (string-length str)) )
     115    (end (string-length (check-string 'message-digest-string! str))) )
    119116    (let (
    120117      (md (initialize-message-digest mdp)) )
     118      (check-fixnum-range 'message-digest-string! start end)
    121119      (message-digest-update-string md str start end)
    122120      (finalize-message-digest! md buf) ) ) )
  • release/4/message-digest/trunk/message-digest-chunk.scm

    r35339 r35342  
    3030    read-u8vector! make-u8vector)
    3131  miscmacros
    32   fx-utils
    3332  typed-define)
    3433
    3534;;; Support
     35
     36;;fx-utils
     37
     38(: fxpositive? (fixnum --> boolean))
     39;
     40(define (fxpositive? n)
     41  (fx< 0 n) )
    3642
    3743;;
     
    4147;;; Update Phase Helpers
    4248
    43 (define (default-chunk-port-read-maker in #!optional (size (message-digest-chunk-size)))
    44   (let (
    45     (u8buf (make-u8vector size)) )
     49(define: (default-chunk-port-read-maker (port input-port) . (opts (list fixnum))) -> procedure
     50  (let* (
     51    (siz (optional opts (message-digest-chunk-size)))
     52    (u8buf (make-u8vector siz)) )
    4653    (lambda ()
    4754      (let (
    48         (len (read-u8vector! size u8buf in)) )
     55        (len (read-u8vector! siz u8buf port)) )
    4956        (and
    5057          (positive? len)
    5158          (let (
    5259            (u8buf
    53               (if (fx= len size)
     60              (if (fx= len siz)
    5461                u8buf
    5562                (subu8vector u8buf 0 len))) )
    5663            (u8vector->blob/shared u8buf) ) ) ) ) ) )
    5764
    58 (define-record-type message-digest-raw-chunk
     65(define:-record-type message-digest-raw-chunk
    5966  (make-message-digest-raw-chunk obj siz beg)
    6067  message-digest-raw-chunk?
    61   (obj message-digest-raw-chunk-object)
    62   (siz message-digest-raw-chunk-size)
    63   (beg message-digest-raw-chunk-start) )
     68  (obj * message-digest-raw-chunk-object)
     69  (siz fixnum message-digest-raw-chunk-size)
     70  (beg fixnum message-digest-raw-chunk-start) )
    6471
    65 (define (default-chunk-fileno-read-maker fd #!optional (size (file-size fd)))
    66   (if (zero? size)
    67     (lambda ()
    68       #f )
    69     (let-values (
    70       ((buffer cleanup)
    71         (mapped-buffer 'default-chunk-fileno-read-maker fd size)) )
    72       (let (
    73         (chunk (make-message-digest-raw-chunk buffer size 0)) )
    74         (lambda ()
    75           (if buffer
    76             (begin0
    77               chunk
    78               (set! buffer #f))
    79             (begin
    80               (cleanup)
    81               #f ) ) ) ) ) ) )
     72(define: (default-chunk-fileno-read-maker (fd fixnum) . (opts (list fixnum))) -> procedure
     73  (let (
     74    (siz (optional opts (file-size fd))) )
     75    (if (zero? siz)
     76      (lambda ()
     77        #f )
     78      (let-values (
     79        ((buffer cleanup)
     80          (mapped-buffer 'default-chunk-fileno-read-maker fd siz)) )
     81        (let (
     82          (chunk (make-message-digest-raw-chunk buffer siz 0)) )
     83          (lambda ()
     84            (if buffer
     85              (begin0
     86                chunk
     87                (set! buffer #f))
     88              (begin
     89                (cleanup)
     90                #f ) ) ) ) ) ) ) )
    8291
    8392(cond-expand
     
    8594  ((and windows (not cygwin))
    8695
    87     (import (only lolevel allocate free))
    88     (require-library lolevel)
     96    (use (only lolevel allocate free))
    8997
    90     (begin
     98    (: read-into-buffer (fixnum pointer fixnum -> boolean))
     99    (define read-into-buffer
     100      (foreign-lambda* bool ((int fd) (c-pointer buffer) (integer size))
     101        "C_return( read( fd, buffer, size ) == size );") )
    91102
    92       (define read-into-buffer
    93         (foreign-lambda* bool ((int fd) (c-pointer buffer) (integer size))
    94           "C_return(read(fd, buffer, size) == size);") )
    95 
    96       (define (mapped-buffer loc fd size)
    97         (let* (
    98           (buffer (allocate size))
    99           (finalize (cut free buffer)) )
    100           (unless (read-into-buffer fd buffer size)
    101             (finalize)
    102             (error loc "cannot read file") )
    103           (values buffer finalize) ) ) ) )
     103    ;(define: (mapped-buffer (loc symbol) (fd fixnum) (siz fixnum)) -> (pointer procedure)
     104    (: mapped-buffer (symbol fixnum fixnum -> pointer procedure))
     105    (define (mapped-buffer loc fd siz)
     106      (let* (
     107        (ptr (allocate siz))
     108        (finalize (cut free ptr)) )
     109        (unless (read-into-buffer fd ptr siz)
     110          (finalize)
     111          (error loc "cannot read file") )
     112        (values ptr finalize) ) ) )
    104113
    105114  (else
    106115
    107     (import
     116    (use
    108117      (only posix
    109118        map-file-to-memory unmap-file-from-memory
     
    111120        map/shared
    112121        prot/read))
    113     (require-library posix)
    114122
    115     (define (mapped-buffer loc fd size)
    116       (let* (
    117         (mmap (map-file-to-memory #f size prot/read map/shared fd))
    118         (ptr (memory-mapped-file-pointer mmap))
    119         (finalize (cut unmap-file-from-memory mmap)) )
    120         (values ptr finalize) ) ) ) )
     123      ;(define: (mapped-buffer (loc symbol) (fd fixnum) (siz fixnum)) -> (pointer procedure)
     124      (: mapped-buffer (symbol fixnum fixnum -> pointer procedure))
     125      (define (mapped-buffer loc fd siz)
     126        (let* (
     127          (mmap (map-file-to-memory #f siz prot/read map/shared fd))
     128          (ptr (memory-mapped-file-pointer mmap))
     129          (finalize (cut unmap-file-from-memory mmap)) )
     130          (values ptr finalize) ) ) ) )
    121131
    122132;;
     
    128138;;
    129139
     140(: message-digest-chunk-size (#!optional fixnum -> fixnum))
     141;
    130142(define-parameter message-digest-chunk-size DEFAULT-CHUNK-SIZE
    131143  (lambda (x)
     
    139151;;
    140152
     153(: message-digest-chunk-port-read-maker (#!optional (or boolean procedure) -> procedure))
     154;
    141155(define-parameter message-digest-chunk-port-read-maker default-chunk-port-read-maker
    142156  (lambda (x)
     
    152166;;
    153167
     168(: message-digest-chunk-fileno-read-maker (#!optional (or boolean procedure) -> procedure))
     169;
    154170(define-parameter message-digest-chunk-fileno-read-maker default-chunk-fileno-read-maker
    155171  (lambda (x)
     
    163179;;
    164180
     181(: message-digest-chunk-converter (#!optional (or boolean procedure) -> (or boolean procedure)))
     182;
    165183(define-parameter message-digest-chunk-converter #f
    166184  (lambda (x)
  • release/4/message-digest/trunk/message-digest-port.scm

    r35341 r35342  
    2727  message-digest-type
    2828  message-digest-bv
    29   fx-utils
    3029  typed-define)
    3130
     
    3534
    3635;;; Support
     36
     37;;fx-utils
     38
     39(: fxpositive? (fixnum --> boolean))
     40;
     41(define (fxpositive? n)
     42  (fx< 0 n) )
    3743
    3844;;
  • release/4/message-digest/trunk/message-digest-support.scm

    r35339 r35342  
    5050  message-digest-primitive
    5151  message-digest-type
    52   fx-utils
    5352  typed-define)
    5453
     
    5857
    5958(include "message-digest-types")
     59
     60;;fx-utils
     61
     62(: fxzero? (fixnum --> boolean))
     63;
     64(define (fxzero? n)
     65  (fx= 0 n) )
    6066
    6167;;
     
    101107;;
    102108
    103 (define: (*message-digest-update-blob (md message-digest) (blb blob) . (opts (list-of fixnum))) -> void
     109(define: (*message-digest-update-blob (md message-digest) (blb blob) . (opts (list fixnum))) -> void
    104110  (let (
    105111    (siz (optional opts (blob-size blb))) )
  • release/4/message-digest/trunk/message-digest-type.scm

    r35341 r35342  
    4545
    4646(include "message-digest-types")
     47
     48;;
     49
     50(define (%u8vector-blob u8vec)
     51  (##sys#slot u8vec 1) )
    4752
    4853;;
     
    178183      (check-result-type 'finalize-message-digest mdp result-buffer)) )
    179184    ;side-effects res
    180     (let ((buf (if (u8vector? res) (##sys#slot res 1) res)))
     185    (let (
     186      (buf (if (u8vector? res) (%u8vector-blob res) res)) )
    181187      ((message-digest-primitive-final mdp) (message-digest-context md) buf) )
    182188    res ) )
     
    184190;;
    185191
    186 (define: (setup-message-digest-buffer! (md message-digest) (sz fixnum)) -> message-digest-buffer
     192(define: (setup-message-digest-buffer! (md message-digest) (siz fixnum)) -> message-digest-buffer
    187193  (let (
    188194    (buf (message-digest-buffer md))
    189     (sz (fxmax sz MINIMUM-BUFFER-SIZE)) )
     195    (siz (fxmax siz MINIMUM-BUFFER-SIZE)) )
    190196    ;enough space? then reuse, otherwise new buffer
    191     (if (and buf (fx<= sz (number-of-bytes buf)))
     197    (if (and buf (fx<= siz (number-of-bytes buf)))
    192198      buf
    193       (new-message-digest-buffer! md sz) ) ) )
    194 
    195 (define: (new-message-digest-buffer! (md message-digest) (sz fixnum)) -> message-digest-buffer
    196   (let (
    197     (buf (make-blob sz)) )
     199      (new-message-digest-buffer! md siz) ) ) )
     200
     201(define: (new-message-digest-buffer! (md message-digest) (siz fixnum)) -> message-digest-buffer
     202  (let (
     203    (buf (make-blob siz)) )
    198204    (message-digest-buffer-set! md buf)
    199205    buf ) )
  • release/4/message-digest/trunk/message-digest-types.scm

    r35341 r35342  
    2323(define-type message-digest-result-type (or string blob u8vector))
    2424
    25 (define-type message-digest-buffer (or string blob u8vector))
    26 
    2725(define-type message-digest-context (or fixnum procedure))
    2826
  • release/4/message-digest/trunk/message-digest.meta

    r35339 r35342  
    1313        (blob-utils "1.0.0")
    1414        (string-utils "1.2.1")
    15         (mathh "3.2.0")
    16         (dsssl-utils "2.2.0"))
     15        (dsssl-utils "2.2.2"))
    1716 (test-depends test)
    1817 (files
Note: See TracChangeset for help on using the changeset viewer.