Changeset 38970 in project


Ignore:
Timestamp:
08/31/20 00:16:24 (4 weeks ago)
Author:
Kon Lovett
Message:

add -strict-types, remove redundant -local, type is interface, note about -strict-types & union return type

Location:
release/5/message-digest-utils/trunk
Files:
11 edited

Legend:

Unmodified
Added
Removed
  • release/5/message-digest-utils/trunk/message-digest-byte-vector.scm

    r38513 r38970  
    2727(import message-digest-support)
    2828
    29 ;;; Support
     29;; Support
    3030
    3131;;
    3232
    3333(include "message-digest.types")
     34
     35(: message-digest-update-blob (message-digest blob #!rest -> void))
     36(: message-digest-update-string (message-digest string #!rest -> void))
    3437
    3538;;
     
    5154;FIXME using & then checking !
    5255
    53 (: message-digest-update-blob (message-digest blob #!rest -> void))
    54 ;
    5556(define (message-digest-update-blob md blb . opts)
    5657  (let-optionals* opts (
     
    6465;;
    6566
    66 (: message-digest-update-string (message-digest string #!rest -> void))
    67 ;
    6867(define (message-digest-update-string md str . opts)
    6968  (let-optionals* opts (
  • release/5/message-digest-utils/trunk/message-digest-chunk.scm

    r38800 r38970  
    3232(import (only (srfi 4) u8vector->blob/shared subu8vector read-u8vector! make-u8vector))
    3333
    34 ;;; Support
     34;; Support
    3535
    3636;;
     
    3838(include "message-digest.types")
    3939
     40(: default-chunk-port-read-maker (input-port #!rest -> procedure))
     41(: make-message-digest-raw-chunk (* fixnum fixnum --> message-digest-raw-chunk))
     42(: message-digest-raw-chunk? (* -> boolean : message-digest-raw-chunk))
     43(: message-digest-raw-chunk-object (message-digest-raw-chunk --> *))
     44(: message-digest-raw-chunk-size (message-digest-raw-chunk --> fixnum))
     45(: message-digest-raw-chunk-start (message-digest-raw-chunk --> fixnum))
     46(: default-chunk-fileno-read-maker (fixnum #!rest -> procedure))
     47(: mapped-buffer (symbol fixnum fixnum fixnum -> pointer procedure boolean))
     48(: message-digest-chunk-size (#!optional fixnum -> fixnum))
     49(: message-digest-chunk-port-read-maker (#!optional (or boolean procedure) -> procedure))
     50(: message-digest-chunk-fileno-read-maker (#!optional (or boolean procedure) -> procedure))
     51(: message-digest-chunk-converter (#!optional (or boolean procedure) -> (or boolean procedure)))
     52
    4053;;
    4154
     
    4457;;; Update Phase Helpers
    4558
    46 (: default-chunk-port-read-maker (input-port #!rest -> procedure))
    47 ;
    4859(define (default-chunk-port-read-maker port . opts)
    4960  (let* (
     
    6980;type `(procedure message-digest-chunk#make-message-digest-raw-chunk (* fixnum
    7081;fixnum) (struct message-digest-raw-chunk))'
    71 (: make-message-digest-raw-chunk (* fixnum fixnum --> message-digest-raw-chunk))
    72 (: message-digest-raw-chunk? (* -> boolean : message-digest-raw-chunk))
    73 (: message-digest-raw-chunk-object (message-digest-raw-chunk --> *))
    74 (: message-digest-raw-chunk-size (message-digest-raw-chunk --> fixnum))
    75 (: message-digest-raw-chunk-start (message-digest-raw-chunk --> fixnum))
    7682;
    7783(define-record-type message-digest-raw-chunk
     
    8288  (beg message-digest-raw-chunk-start) )
    8389
    84 (: default-chunk-fileno-read-maker (fixnum #!rest -> procedure))
    85 ;
    8690(define (default-chunk-fileno-read-maker fd . opts)
    8791  (let-optionals* opts (
     
    121125
    122126(cond-expand
    123 
    124127  ((or windows unix)
    125 
    126     (import
    127       (only memory-mapped-files
    128         map-file-to-memory unmap-file-from-memory
    129         memory-mapped-file-pointer map/shared prot/read))
    130 
    131     (: mapped-buffer (symbol fixnum fixnum fixnum -> pointer procedure boolean))
    132     ;
    133128    (define (mapped-buffer loc fd siz chk)
     129      (import
     130        (only memory-mapped-files
     131          map-file-to-memory unmap-file-from-memory
     132          memory-mapped-file-pointer map/shared prot/read))
    134133      (let* (
    135134        (mmap (map-file-to-memory #f siz prot/read map/shared fd))
     
    137136        (finalize (cut unmap-file-from-memory mmap)) )
    138137        (values ptr finalize #f) ) ) )
    139 
    140138  (else
    141 
    142139    ;tested w/ macosx (replaced mmap version)
    143 
    144     (import (only (chicken memory) allocate free))
    145 
    146     (: read-into-buffer (fixnum pointer fixnum -> boolean))
    147     ;
    148     (define read-into-buffer
    149       (foreign-lambda* bool ((int fd) (c-pointer buffer) (integer size))
    150         "return( read( fd, buffer, size ) == size );") )
    151 
    152     (: mapped-buffer (symbol fixnum fixnum fixnum -> pointer procedure boolean))
    153     ;
    154140    (define (mapped-buffer loc fd siz chk)
     141      (import (only (chicken memory) allocate free))
     142      (define read-into-buffer
     143        (foreign-lambda* bool ((int fd) (c-pointer buffer) (integer size))
     144          "return( read( fd, buffer, size ) == size );") )
    155145      (let* (
    156146        (ptr
     
    183173        (values ptr finalize updater) ) ) ) )
    184174
    185 ;;; Message Digest "chunk"
    186 
    187 ;;
    188 
    189 (: message-digest-chunk-size (#!optional fixnum -> fixnum))
    190 ;
     175;; Message Digest "chunk"
     176
     177;;
     178
    191179(define message-digest-chunk-size (make-parameter DEFAULT-CHUNK-SIZE
    192180  (lambda (x)
     
    200188;;
    201189
    202 (: message-digest-chunk-port-read-maker (#!optional (or boolean procedure) -> procedure))
    203 ;
    204190(define message-digest-chunk-port-read-maker (make-parameter default-chunk-port-read-maker
    205191  (lambda (x)
     
    213199;;
    214200
    215 (: message-digest-chunk-fileno-read-maker (#!optional (or boolean procedure) -> procedure))
    216 ;
    217201(define message-digest-chunk-fileno-read-maker (make-parameter default-chunk-fileno-read-maker
    218202  (lambda (x)
     
    226210;;
    227211
    228 (: message-digest-chunk-converter (#!optional (or boolean procedure) -> (or boolean procedure)))
    229 ;
    230212(define message-digest-chunk-converter (make-parameter #f
    231213  (lambda (x)
  • release/5/message-digest-utils/trunk/message-digest-int.scm

    r38513 r38970  
    3434(import (only type-errors error-argument-type))
    3535
    36 ;;; Support
     36;; Support
    3737
    3838;;
     
    4040(include "message-digest.types")
    4141
     42(: get-byte-order (symbol * --> message-digest-byte-order))
     43(: *message-digest-update-uint (symbol message-digest number fixnum procedure -> void))
     44(: message-digest-update-char-u8 (message-digest char -> void))
     45(: message-digest-update-char-be (message-digest char -> void))
     46(: message-digest-update-char-le (message-digest char -> void))
     47(: message-digest-update-u8 (message-digest number -> void))
     48(: message-digest-update-u16-be (message-digest number -> void))
     49(: message-digest-update-u16-le (message-digest number -> void))
     50(: message-digest-update-u32-be (message-digest number -> void))
     51(: message-digest-update-u32-le (message-digest number -> void))
     52(: message-digest-update-u64-be (message-digest number -> void))
     53(: message-digest-update-u64-le (message-digest number -> void))
     54(: message-digest-update-char (message-digest char #!rest -> void))
     55(: message-digest-update-u16 (message-digest number #!rest -> void))
     56(: message-digest-update-u32 (message-digest number #!rest -> void))
     57(: message-digest-update-u64 (message-digest number #!rest -> void))
     58
    4259;;
    4360
    44 (: get-byte-order (symbol * --> message-digest-byte-order))
    45 ;
    4661(define (get-byte-order loc obj)
    4762  (case obj
     
    5368;;
    5469
    55 (: *message-digest-update-uint (symbol message-digest number fixnum procedure -> void))
    56 ;
    5770(define (*message-digest-update-uint loc md n size setter)
    5871  (let (
     
    6578;; Char
    6679
    67 (: message-digest-update-char-u8 (message-digest char -> void))
    68 ;
    6980(define (message-digest-update-char-u8 md ch)
    7081        (*message-digest-update-uint 'message-digest-update-char-u8
     
    7485          *blob-set-u8!) )
    7586
    76 (: message-digest-update-char-be (message-digest char -> void))
    77 ;
    7887(define (message-digest-update-char-be md ch)
    7988        (*message-digest-update-uint 'message-digest-update-char-be
     
    8392          *blob-set-u32-be!) )
    8493
    85 (: message-digest-update-char-le (message-digest char -> void))
    86 ;
    8794(define (message-digest-update-char-le md ch)
    8895        (*message-digest-update-uint 'message-digest-update-char-le
     
    94101;; Unsigned Integer 8, 16, 32, & 64 bits
    95102
    96 (: message-digest-update-u8 (message-digest number -> void))
    97103;
    98104(define (message-digest-update-u8 md n)
    99105        (*message-digest-update-uint 'message-digest-update-u8 md n 1 *blob-set-u8!) )
    100106
    101 (: message-digest-update-u16-be (message-digest number -> void))
    102 ;
    103107(define (message-digest-update-u16-be md n)
    104108        (*message-digest-update-uint 'message-digest-update-u16-be md n 2 *blob-set-u16-be!) )
    105109
    106 (: message-digest-update-u16-le (message-digest number -> void))
    107 ;
    108110(define (message-digest-update-u16-le md n)
    109111        (*message-digest-update-uint 'message-digest-update-u16-le md n 2 *blob-set-u16-le!) )
    110112
    111 (: message-digest-update-u32-be (message-digest number -> void))
    112 ;
    113113(define (message-digest-update-u32-be md n)
    114114        (*message-digest-update-uint 'message-digest-update-u32-be md n 4 *blob-set-u32-be!) )
    115115
    116 (: message-digest-update-u32-le (message-digest number -> void))
    117 ;
    118116(define (message-digest-update-u32-le md n)
    119117        (*message-digest-update-uint 'message-digest-update-u32-le md n 4 *blob-set-u32-le!) )
    120118
    121 (: message-digest-update-u64-be (message-digest number -> void))
    122 ;
    123119(define (message-digest-update-u64-be md n)
    124120        (*message-digest-update-uint 'message-digest-update-u64-be md n 8 *blob-set-u64-be!) )
    125121
    126 (: message-digest-update-u64-le (message-digest number -> void))
    127 ;
    128122(define (message-digest-update-u64-le md n)
    129123        (*message-digest-update-uint 'message-digest-update-u64-le md n 8 *blob-set-u64-le!) )
     
    131125;; Machine Byte Order w/ Char & Unsigned Integer
    132126
    133 (: message-digest-update-char (message-digest char #!rest -> void))
    134 ;
    135127(define (message-digest-update-char md ch . opts)
    136128  (let (
     
    140132      ((big-endian)                     (message-digest-update-char-be md ch) ) ) ) )
    141133
    142 (: message-digest-update-u16 (message-digest number #!rest -> void))
    143 ;
    144134(define (message-digest-update-u16 md n . opts)
    145135  (let (
     
    149139      ((big-endian)                     (message-digest-update-u16-be md n) ) ) ) )
    150140
    151 (: message-digest-update-u32 (message-digest number #!rest -> void))
    152 ;
    153141(define (message-digest-update-u32 md n . opts)
    154142  (let (
     
    158146      ((big-endian)                     (message-digest-update-u32-be md n) ) ) ) )
    159147
    160 (: message-digest-update-u64 (message-digest number #!rest -> void))
    161 ;
    162148(define (message-digest-update-u64 md n . opts)
    163149  (let (
  • release/5/message-digest-utils/trunk/message-digest-item.scm

    r38513 r38970  
    3232(define-type pathname string)
    3333
     34(: message-digest-object (message-digest-primitive * #!rest -> message-digest-result-type))
     35(: message-digest-file (message-digest-primitive pathname #!rest -> message-digest-result-type))
     36(: message-digest-port (message-digest-primitive output-port #!rest -> message-digest-result-type))
     37(: message-digest-object! (message-digest-primitive * message-digest-buffer #!rest -> message-digest-result-type))
     38(: message-digest-file! (message-digest-primitive pathname message-digest-buffer -> message-digest-result-type))
     39(: message-digest-port! (message-digest-primitive output-port message-digest-buffer -> message-digest-result-type))
    3440
    35 ;;; Single Source API
     41;; Single Source API
    3642
    3743;;
    3844
    39 (: message-digest-object (message-digest-primitive * #!rest -> message-digest-result-type))
    40 ;
    4145(define (message-digest-object mdp obj . opts)
    4246  (let-optionals* opts (
     
    4852      (finalize-message-digest md restyp) ) ) )
    4953
    50 (: message-digest-file (message-digest-primitive pathname #!rest -> message-digest-result-type))
    51 ;
    5254(define (message-digest-file mdp flnm . opts)
    5355  (let-optionals* opts (
     
    5860      (finalize-message-digest md restyp) ) ) )
    5961
    60 (: message-digest-port (message-digest-primitive output-port #!rest -> message-digest-result-type))
    61 ;
    6262(define (message-digest-port mdp port . opts)
    6363  (let-optionals* opts (
     
    7070;;
    7171
    72 (: message-digest-object! (message-digest-primitive * message-digest-buffer #!rest -> message-digest-result-type))
    73 ;
    7472(define (message-digest-object! mdp obj buf . opts)
    7573  (let-optionals* opts (
     
    8179      (finalize-message-digest! md buf) ) ) )
    8280
    83 (: message-digest-file! (message-digest-primitive pathname message-digest-buffer -> message-digest-result-type))
    84 ;
    8581(define (message-digest-file! mdp flnm buf)
    8682  (let (
     
    8985    (finalize-message-digest! md buf) ) )
    9086
    91 (: message-digest-port! (message-digest-primitive output-port message-digest-buffer -> message-digest-result-type))
    92 ;
    9387(define (message-digest-port! mdp port buf)
    9488  (let (
  • release/5/message-digest-utils/trunk/message-digest-port.scm

    r38513 r38970  
    3939(import message-digest-byte-vector)
    4040
    41 ;;; Support
     41;; Support
    4242
    4343;;
    4444
    4545(include "message-digest.types")
     46
     47(: make-digest-port-name (message-digest-primitive --> string))
     48(: open-output-digest (message-digest-primitive -> digest-output-port))
     49(: digest-output-port? (* -> boolean : digest-output-port))
     50(: digest-output-port-name (digest-output-port --> string))
     51(: *close-output-digest (symbol digest-output-port message-digest-result-form -> message-digest-result-type))
     52(: get-output-digest (digest-output-port #!rest -> message-digest-result-type))
     53(: call-with-output-digest (message-digest-primitive procedure #!rest -> message-digest-result-type))
     54(: with-output-to-digest (message-digest-primitive procedure #!rest -> message-digest-result-type))
    4655
    4756;;
     
    8695
    8796;Synthesize a port-name from a primitive-name
    88 (: make-digest-port-name (message-digest-primitive --> string))
    8997;
    9098(define make-digest-port-name
     
    111119;;; Message Digest Output Port API
    112120
    113 (: open-output-digest (message-digest-primitive -> digest-output-port))
    114 ;
    115121(define (open-output-digest mdp)
    116122  (check-message-digest-primitive 'open-output-digest mdp)
     
    132138    port ) )
    133139
    134 (: digest-output-port? (* -> boolean : digest-output-port))
    135140;
    136141(define (digest-output-port? obj)
     
    141146(define-check+error-type digest-output-port)
    142147
    143 (: digest-output-port-name (digest-output-port --> string))
    144 ;
    145148(define (digest-output-port-name port)
    146149  (%port-name (check-digest-output-port 'digest-output-port-name port)) )
    147150
    148 (: *close-output-digest (symbol digest-output-port message-digest-result-form -> message-digest-result-type))
    149 ;
    150151(define (*close-output-digest loc port restyp)
    151152  (check-open-digest-output-port loc port 'digest-port)
     
    158159      (lambda () (close-output-port port))) ) )
    159160
    160 (: get-output-digest (digest-output-port #!rest -> message-digest-result-type))
    161 ;
    162161(define (get-output-digest port . opts)
    163162  (let (
     
    165164    (*close-output-digest 'get-output-digest port restyp) ) )
    166165
    167 ;;;
     166;;
    168167
    169 (: call-with-output-digest (message-digest-primitive procedure #!rest -> message-digest-result-type))
    170 ;
    171168(define (call-with-output-digest mdp proc . opts)
    172169  (check-procedure 'call-with-output-digest proc)
     
    175172    (restyp (optional opts (message-digest-result-form))) )
    176173    (let (
    177       (port #f) )
     174      (port (open-output-digest mdp)) )
    178175      (dynamic-wind
    179         (lambda () (set! port (open-output-digest mdp)))
     176        void
    180177        (lambda () (proc port))
    181178        (lambda () (*close-output-digest 'call-with-output-digest port restyp))) ) ) )
    182179
    183 (: with-output-to-digest (message-digest-primitive procedure #!rest -> message-digest-result-type))
    184 ;
    185180(define (with-output-to-digest mdp thunk . opts)
    186181  (let (
  • release/5/message-digest-utils/trunk/message-digest-srfi-4.scm

    r38513 r38970  
    2929(import message-digest-byte-vector)
    3030
    31 ;;; Support
     31;; Support
    3232
    3333;;
     
    3535(include "message-digest.types")
    3636
     37(: get-bytevector-object (symbol * --> blob))
     38(: message-digest-update-u8vector (message-digest u8vector #!rest -> void))
     39(: message-digest-u8vector (message-digest-primitive u8vector #!rest -> message-digest-result-type))
     40(: message-digest-u8vector! (message-digest-primitive u8vector message-digest-buffer #!rest -> message-digest-result-type))
     41
    3742;;
    3843
    39 (: get-bytevector-object (symbol * --> blob))
    40 ;
    4144(define (get-bytevector-object loc obj)
    4245        (cond
     
    5356;;
    5457
    55 (: message-digest-update-u8vector (message-digest u8vector #!rest -> void))
    56 ;
    5758(define (message-digest-update-u8vector md u8vec . opts)
    5859  (let-optionals* opts (
     
    6465;;; Single Source API
    6566
    66 (: message-digest-u8vector (message-digest-primitive u8vector #!rest -> message-digest-result-type))
    67 ;
    6867(define (message-digest-u8vector mdp u8vec . opts)
    6968  (let-optionals* opts (
     
    7574      (finalize-message-digest md restyp) ) ) )
    7675
    77 (: message-digest-u8vector! (message-digest-primitive u8vector message-digest-buffer #!rest -> message-digest-result-type))
    78 ;
    7976(define (message-digest-u8vector! mdp u8vec buffer . opts)
    8077  (let-optionals* opts (
  • release/5/message-digest-utils/trunk/message-digest-support.scm

    r38513 r38970  
    4343(import message-digest-type)
    4444
    45 ;;; Support
     45;; Support
    4646
    4747;;
     
    4949(include "message-digest.types")
    5050
    51 ;;
    52 
    5351(define-type start-index fixnum)
    5452(define-type end-index (or boolean fixnum))
     53
     54(: packed-vector->blob/shared (srfi4vector -> (or boolean blob)))
     55(: u8vector/slice (u8vector start-index end-index --> u8vector))
     56(: blob/slice (blob start-index end-index --> blob))
     57(: string/slice (string start-index end-index --> string))
     58(: *message-digest-update-blob (message-digest blob #!rest -> void))
     59(: *message-digest-update-string (message-digest string -> void))
     60(: message-digest-algorithm-update (message-digest -> procedure))
    5561
    5662;;
     
    5864;Used by update-item & srfi-4 modules
    5965
    60 (: packed-vector->blob/shared (srfi4vector -> (or boolean blob)))
    61 ;
    6266(define (packed-vector->blob/shared obj)
    6367  (cond
     
    7781;;
    7882
    79 (: u8vector/slice (u8vector start-index end-index --> u8vector))
    80 ;
    8183(define (u8vector/slice u8vec start end)
    8284   (let (
     
    8688      (subu8vector u8vec start end) ) ) )
    8789
    88 (: blob/slice (blob start-index end-index --> blob))
    89 ;
    9090(define blob/slice
    9191  ;need byte-oriented semantics
     
    9898          (string->blob (substring (blob->string blb) start end)) ) ) ) ) )
    9999
    100 (: string/slice (string start-index end-index --> string))
    101 ;
    102100(define (string/slice str start end)
    103101  (let (
     
    109107;;
    110108
    111 (: *message-digest-update-blob (message-digest blob #!rest -> void))
    112 ;
    113109(define (*message-digest-update-blob md blb . opts)
    114110  (let (
     
    116112    ((message-digest-algorithm-update md) (message-digest-context md) blb siz) ) )
    117113
    118 (: *message-digest-update-string (message-digest string -> void))
    119 ;
    120114(define (*message-digest-update-string md str)
    121115        (*message-digest-update-blob md (string->blob str)) )
    122116
    123 (: message-digest-algorithm-update (message-digest -> procedure))
    124 ;
    125117(define (message-digest-algorithm-update md)
    126118  (message-digest-primitive-update (message-digest-algorithm md)) )
  • release/5/message-digest-utils/trunk/message-digest-update-item.scm

    r38513 r38970  
    2929(import type-errors)
    3030
    31 ;;; Support
     31;; Support
    3232
    3333;;
     
    3636
    3737(define-type pathname string)
    38 
    39 ;;
    4038
    4139(define-type converted-chunk (or blob string message-digest-raw-chunk))
     
    4442(define-type end-index (or boolean fixnum))
    4543
    46 (define-type source-update procedure)
    47 (define-type raw-update procedure)
     44(define-type source-update (message-digest-primitive-context * fixnum -> void))
     45(define-type raw-update (message-digest-primitive-context * fixnum -> void))
     46
     47(define-type data-generator (-> *))
     48
     49(: chunk-convert (* -> converted-chunk))
     50(: get-port-chunk-reader (input-port -> procedure))
     51(: get-fileno-chunk-reader (fixnum -> procedure))
     52(: updater (message-digest --> source-update))
     53(: raw-updater (message-digest --> raw-update))
     54(: do-object-update (symbol message-digest * start-index end-index -> void))
     55(: do-port-update (symbol message-digest input-port start-index end-index -> void))
     56(: do-procedure-update (symbol message-digest data-generator start-index end-index -> void))
     57(: do-bytes-update (symbol message-digest * start-index end-index -> void))
     58(: *do-bytes-update (symbol message-digest-primitive-context * source-update raw-update start-index end-index -> void))
     59(: object->bytevector-like (* -> converted-chunk))
     60(: *message-digest-update-file/fileno (symbol message-digest pathname -> void))
     61(: *message-digest-update-file/port (symbol message-digest pathname -> void))
     62(: message-digest-update-object (message-digest * #!rest -> void))
     63(: message-digest-update-procedure (message-digest data-generator -> void))
     64(: message-digest-update-port (message-digest input-port -> void))
     65(: message-digest-update-file (message-digest pathname -> void))
    4866
    4967;;
    5068
    5169;=> #f or converted-chunk
    52 (: chunk-convert (* -> converted-chunk))
    53 ;
    5470(define (chunk-convert obj)
    5571  (and-let* (
     
    5773    (cnv obj) ) )
    5874
    59 (: get-port-chunk-reader (input-port -> procedure))
    60 ;
    6175(define (get-port-chunk-reader port)
    6276  ((message-digest-chunk-port-read-maker) port) )
    6377
    64 (: get-fileno-chunk-reader (fixnum -> procedure))
    65 ;
    6678(define (get-fileno-chunk-reader fd)
    6779  ((message-digest-chunk-fileno-read-maker) fd) )
    6880
    69 (: get-update (message-digest --> source-update))
    70 ;
    71 (define (get-update md)
     81(define (updater md)
    7282  (message-digest-primitive-update (message-digest-algorithm md)) )
    7383
    74 (: get-raw-update (message-digest --> raw-update))
    75 ;
    76 (define (get-raw-update md)
     84(define (raw-updater md)
    7785  (message-digest-primitive-raw-update (message-digest-algorithm md)) )
    7886
    7987;;
    8088
    81 (: do-object-update (symbol message-digest * start-index end-index -> void))
    82 ;
     89(define (object->bytevector-like obj)
     90  (or
     91    (packed-vector->blob/shared obj)
     92    (chunk-convert obj)) )
     93
     94;;
     95
    8396(define (do-object-update loc md src start end)
    8497  (cond
     
    87100    (else                 (do-bytes-update loc md src start end) ) ) )
    88101
    89 (: do-port-update (symbol message-digest input-port start-index end-index -> void))
    90 ;
    91102(define (do-port-update loc md port start end)
    92103  (do-procedure-update loc md (get-port-chunk-reader port) start end) )
    93104
    94 (: do-procedure-update (symbol message-digest procedure start-index end-index -> void))
    95 ;
    96 (define (do-procedure-update loc md proc start end)
    97   (let (
    98     (src-updt (get-update md))
    99     (raw-updt (get-raw-update md))
     105(define (do-procedure-update loc md next start end)
     106  (let (
     107    (src-updt (updater md))
     108    (raw-updt (raw-updater md))
    100109    (ctx (message-digest-context md)) )
    101110    ;note the 'src' object (return of proc) may or may not be unique!
    102111    (let loop ()
    103       (and-let* ((dat (proc)))
     112      (and-let* ((dat (next)))
    104113        (*do-bytes-update loc ctx dat src-updt raw-updt start end)
    105114        (loop) ) )
     
    107116    (void) ) )
    108117
    109 (: do-bytes-update (symbol message-digest * start-index end-index -> void))
    110 ;
    111118(define (do-bytes-update loc md src start end)
    112119  (*do-bytes-update
     
    114121    (message-digest-context md)
    115122    src
    116     (get-update md)
    117     (get-raw-update md)
     123    (updater md)
     124    (raw-updater md)
    118125    start end) )
    119126
    120 (: *do-bytes-update (symbol message-digest-primitive-context * source-update raw-update start-index end-index -> void))
    121 ;
    122127(define (*do-bytes-update loc ctx src src-updt raw-updt start end)
    123128  (cond
     
    147152      (signal-type-error loc "indigestible object" src start end) ) ) )
    148153
    149 (: object->bytevector-like (* -> converted-chunk))
    150 ;
    151 (define (object->bytevector-like obj)
    152   (or
    153     (packed-vector->blob/shared obj)
    154     (chunk-convert obj)) )
    155 
    156 ;;
    157 
    158 (: *message-digest-update-file/fileno (symbol message-digest pathname -> void))
    159 ;
     154;;
     155
    160156(define (*message-digest-update-file/fileno loc md flnm)
    161   (let ((fd #f))
     157  (let (
     158    (fd (file-open flnm open/rdonly)) )
    162159    (dynamic-wind
    163       (lambda () (set! fd (file-open flnm open/rdonly)) )
     160      void
    164161      (lambda () (do-procedure-update loc md (get-fileno-chunk-reader fd) 0 #f) )
    165162      (lambda () (file-close fd) ) ) )
     
    174171    (file-close fd) ) )
    175172
    176 (: *message-digest-update-file/port (symbol message-digest pathname -> void))
    177 ;
    178173(define (*message-digest-update-file/port loc md flnm)
    179   (let ((in #f))
     174  (let (
     175   (in (open-input-file flnm)) )
    180176    (dynamic-wind
    181       (lambda () (set! in (open-input-file flnm)) )
     177      void
    182178      (lambda () (do-port-update loc md in 0 #f) )
    183179      (lambda () (close-input-port in) ) ) )
     
    192188    (close-input-port in) ) )
    193189
    194 ;;; Update Operation
    195 
    196 ;;
    197 
    198 (: message-digest-update-object (message-digest * #!rest -> void))
    199 ;
     190;; Update Operation
     191
     192;;
     193
    200194(define (message-digest-update-object md obj . opts)
    201195  (let-optionals* opts (
     
    210204;;
    211205
    212 (: message-digest-update-procedure (message-digest procedure -> void))
    213 ;
    214206(define (message-digest-update-procedure md proc)
    215207  (do-procedure-update
     
    221213;;
    222214
    223 (: message-digest-update-port (message-digest input-port -> void))
    224 ;
    225215(define (message-digest-update-port md port)
    226216  (do-port-update
     
    232222;;
    233223
    234 (: message-digest-update-file (message-digest pathname -> void))
    235 ;
    236224(define (message-digest-update-file md flnm)
    237225  ;
     
    243231    (error 'message-digest-update-file "file is a directory" flnm) )
    244232  ;
    245   (if (get-raw-update (check-message-digest 'message-digest-update-file md))
     233  (if (raw-updater (check-message-digest 'message-digest-update-file md))
    246234    (*message-digest-update-file/fileno 'message-digest-update-file md flnm)
    247235    (*message-digest-update-file/port 'message-digest-update-file md flnm) ) )
  • release/5/message-digest-utils/trunk/message-digest-utils.egg

    r38513 r38970  
    88 (license "BSD")
    99 (dependencies
    10         (check-errors "3.1.0")
    11         (blob-utils "2.0.0")
    12         (string-utils "2.0.5")
    13         ;FIXME only true 4 unix & windows
    14         (memory-mapped-files "0.2")
    15         (message-digest-primitive "4.3.0")
    16         (message-digest-type "4.2.0"))
     10  check-errors blob-utils string-utils memory-mapped-files
     11  message-digest-primitive message-digest-type)
    1712 (test-dependencies test)
    1813 (components
     
    2116  (extension message-digest-chunk
    2217    (types-file)
    23     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks"))
     18    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks"))
    2419  (extension message-digest-support
    2520    (types-file)
    26     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks"))
     21    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks"))
    2722  (extension message-digest-byte-vector
    2823    (types-file)
    2924    (component-dependencies message-digest-support)
    30     (csc-options "-O3" "-d1" "-local"  "-no-procedure-checks" "-no-bound-checks"))
     25    (csc-options "-O3" "-d1" "-strict-types"  "-no-procedure-checks" "-no-bound-checks"))
    3126  (extension message-digest-int
    3227    (types-file)
    3328    (component-dependencies message-digest-support)
    34     (csc-options "-O3" "-d1" "-local"  "-no-procedure-checks" "-no-bound-checks"))
     29    (csc-options "-O3" "-d1" "-strict-types"  "-no-procedure-checks" "-no-bound-checks"))
    3530  (extension message-digest-srfi-4
    3631    (types-file)
    3732    (component-dependencies message-digest-byte-vector message-digest-support)
    38     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks"))
     33    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks"))
    3934  (extension message-digest-update-item
    4035    (types-file)
    4136    (component-dependencies message-digest-chunk message-digest-support)
    42     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks"))
     37    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks"))
    4338  (extension message-digest-item
    4439    (types-file)
    4540    (component-dependencies message-digest-update-item)
    46     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks-for-toplevel-bindings"))
     41    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
    4742  (extension message-digest-port
    4843    (types-file)
    4944    (component-dependencies message-digest-byte-vector)
    50     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks")) ) )
     45    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks")) ) )
  • release/5/message-digest-utils/trunk/tests/message-digest-utils-test.scm

    r38493 r38970  
    1414(import scheme)
    1515(import (chicken base))
     16(import (chicken type))
    1617;(import (chicken format))
    1718(import (chicken fixnum))
     
    4849(define SHORT-TEST-FILE-LENGTH 26)
    4950
     51;FIXME -strict-types no like union return type
     52(: just-once (-> (or string false)))
    5053(define just-once
    51   (let ((x #t))
     54  (let ((flag #t))
    5255    (lambda ()
    53       (let (
    54         (res (and x simple-src)) )
    55         (set! x #f)
    56         res ) ) ) )
     56      (and flag (begin (set! flag #f) simple-src)))))
    5757
    5858;FIXME add (mock-*-primitive ...) that wraps the supplied phase procedures
     
    173173  )
    174174
    175   (test-group "Procedure Source"
    176     (let (
    177       (md (initialize-message-digest mdp)) )
    178       (test-assert (message-digest-update-procedure md just-once))
    179       (test simple-res (finalize-message-digest md)) )
    180   )
    181 
    182175  (test-group "Port"
    183176    (let (
     
    188181      (test-assert (port-closed? port)) )
    189182  )
     183
     184  (test-group "Procedure Source"
     185    (let (
     186      (md (initialize-message-digest mdp)) )
     187      (test-assert (message-digest-update-procedure md just-once))
     188      (test simple-res (finalize-message-digest md)) )
     189  )
    190190)
    191191
  • release/5/message-digest-utils/trunk/tests/run.scm

    r38498 r38970  
    3030
    3131;no -disable-interrupts or -no-lambda-info
     32#; ;FIXME -strict-types doesn't like union return type; ex: (or string false)
     33(define *csc-options* "-inline-global -local -inline \
     34  -specialize -optimize-leaf-routines -clustering -lfa2 \
     35  -no-trace -unsafe \
     36  -strict-types")
    3237(define *csc-options* "-inline-global -local -inline \
    3338  -specialize -optimize-leaf-routines -clustering -lfa2 \
Note: See TracChangeset for help on using the changeset viewer.