Changeset 35914 in project


Ignore:
Timestamp:
07/15/18 21:33:03 (14 months ago)
Author:
Kon Lovett
Message:

C5 wip

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

Legend:

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

    r35898 r35914  
    1 ;;;; message-digest-byte-vector.scm
     1;;;; message-digest-byte-vector.scm  -*- Scheme -*-
     2;;;; Kon Lovett, Jul '18
    23;;;; Kon Lovett, Aug '17
    34;;;; Kon Lovett, Apr '12
    45;;;; Kon Lovett, May '10 (message-digest.scm)
    56;;;; Kon Lovett, Jan '06 (message-digest.scm)
    6 
    7 ;; Issues
    87
    98(module message-digest-byte-vector
     
    1817  message-digest-string!)
    1918
    20 (import scheme chicken)
    21 (use
    22   (only srfi-13 substring/shared)
    23   (only type-checks
    24     check-blob check-string check-natural-fixnum check-range)
     19(import scheme
     20  (chicken base)
     21  (chicken blob)
     22  (chicken type)
     23  (only (srfi 13) substring/shared)
     24  (only type-checks check-blob check-string check-natural-fixnum check-range)
    2525  message-digest-primitive
    2626  message-digest-type
     
    5151;FIXME using & then checking !
    5252
    53 (: message-digest-update-blob (md message-digest) (blb blob) . (opts list))
     53(: message-digest-update-blob (message-digest blob #!rest -> void))
    5454;
    55 (define (message-digest-update-blob (md message-digest) (blb blob) . (opts list))
     55(define (message-digest-update-blob md blb . opts)
    5656  (let-optionals* opts (
    5757    (start 0)
     
    6464;;
    6565
    66 (: message-digest-update-string (md message-digest) (str string) . (opts list))
     66(: message-digest-update-string (message-digest string #!rest -> void))
    6767;
    68 (define (message-digest-update-string (md message-digest) (str string) . (opts list))
     68(define (message-digest-update-string md str . opts)
    6969  (let-optionals* opts (
    7070    (start 0)
     
    7979;; Single Source API
    8080
    81 (: message-digest-blob (mdp message-digest-primitive) (blb blob) . (opts list)) --> message-digest-result-type
     81(: message-digest-blob (message-digest-primitive blob #!rest -> message-digest-result-type))
    8282;
    83 (define (message-digest-blob (mdp message-digest-primitive) (blb blob) . (opts list)) --> message-digest-result-type
     83(define (message-digest-blob mdp blb . opts)
    8484  (let-optionals* opts (
    8585    (restyp (message-digest-result-form))
     
    9292      (finalize-message-digest md restyp) ) ) )
    9393
    94 (: message-digest-string (mdp message-digest-primitive) (str string) . (opts list)) --> message-digest-result-type
     94(: message-digest-string (message-digest-primitive string #!rest -> message-digest-result-type))
    9595;
    96 (define (message-digest-string (mdp message-digest-primitive) (str string) . (opts list)) --> message-digest-result-type
     96(define (message-digest-string mdp str . opts)
    9797  (let-optionals* opts (
    9898    (restyp (message-digest-result-form))
     
    105105      (finalize-message-digest md restyp) ) ) )
    106106
    107 (: message-digest-blob! (mdp message-digest-primitive) (blb blob) (buf message-digest-buffer) . (opts list)) -> message-digest-result-type
     107(: message-digest-blob! (message-digest-primitive blob message-digest-buffer #!rest -> message-digest-result-type))
    108108;
    109 (define (message-digest-blob! (mdp message-digest-primitive) (blb blob) (buf message-digest-buffer) . (opts list)) -> message-digest-result-type
     109(define (message-digest-blob! mdp blb buf . opts)
    110110  (let-optionals* opts (
    111111    (start 0)
     
    117117      (finalize-message-digest! md buf) ) ) )
    118118
    119 (: message-digest-string! (mdp message-digest-primitive) (str string) (buf message-digest-buffer) . (opts list)) -> message-digest-result-type
     119(: message-digest-string! (message-digest-primitive string message-digest-buffer #!rest -> message-digest-result-type))
    120120;
    121 (define (message-digest-string! (mdp message-digest-primitive) (str string) (buf message-digest-buffer) . (opts list)) -> message-digest-result-type
     121(define (message-digest-string! mdp str buf . opts)
    122122  (let-optionals* opts (
    123123    (start 0)
  • release/5/message-digest-utils/trunk/message-digest-chunk.scm

    r35898 r35914  
    1 ;;;;message-digest-chunk.scm
     1;;;;message-digest-chunk.scm  -*- Scheme -*-
     2;;;;Kon Lovett, Jul '18
    23;;;;Kon Lovett, Aug '17  (message-digest-parameters.scm)
    34
     
    2021  message-digest-chunk-port-read-maker
    2122  message-digest-chunk-fileno-read-maker
    22   message-digest-chunk-read-maker ;DEPRECATED
    2323  message-digest-chunk-converter)
    2424
    25 (import scheme chicken foreign)
    26 (use
    27   (only posix file-size)
    28   (only srfi-4
    29     u8vector->blob/shared subu8vector
    30     read-u8vector! make-u8vector))
     25(import scheme
     26  (chicken base)
     27  (chicken fixnum)
     28  (chicken foreign)
     29  (only (chicken file posix) file-size)
     30  (chicken type)
     31  (only (srfi 4) u8vector->blob/shared subu8vector read-u8vector! make-u8vector))
    3132
    3233;;; Support
    3334
    3435;;fx-utils
     36
     37(: fxzero? (fixnum --> boolean))
     38;
     39(define (fxzero? n)
     40  (fx= 0 n) )
    3541
    3642(: fxpositive? (fixnum --> boolean))
     
    4551;;; Update Phase Helpers
    4652
    47 (: default-chunk-port-read-maker (port input-port) . (opts (list fixnum))) -> procedure
    48 ;
    49 (define (default-chunk-port-read-maker (port input-port) . (opts (list fixnum))) -> procedure
     53(: default-chunk-port-read-maker (input-port #!rest (list fixnum) -> procedure))
     54;
     55(define (default-chunk-port-read-maker port . opts)
    5056  (let* (
    5157    (siz (optional opts (message-digest-chunk-size)))
     
    6369            (u8vector->blob/shared u8buf) ) ) ) ) ) )
    6470
    65 (define:-record-type message-digest-raw-chunk
     71;(define-type message-digest-raw-chunk (struct message-digest-raw-chunk))
     72;assignment of value of type `(procedure message-digest-chunk#make-message-digest-raw-chunk (* * *) (struct message-digest-chunk#message-digest-raw-chunk))' to toplevel variable `message-digest-chunk#make-message-digest-raw-chunk' does not match declared type `(procedure message-digest-chunk#make-message-digest-raw-chunk (* fixnum fixnum) (struct message-digest-raw-chunk))'
     73(: make-message-digest-raw-chunk (* fixnum fixnum --> message-digest-raw-chunk))
     74(: message-digest-raw-chunk? (* -> boolean : message-digest-raw-chunk))
     75(: message-digest-raw-chunk-object (message-digest-raw-chunk --> *))
     76(: message-digest-raw-chunk-size (message-digest-raw-chunk --> fixnum))
     77(: message-digest-raw-chunk-start (message-digest-raw-chunk --> fixnum))
     78;
     79(define-record-type message-digest-raw-chunk
    6680  (make-message-digest-raw-chunk obj siz beg)
    6781  message-digest-raw-chunk?
    68   (obj * message-digest-raw-chunk-object)
    69   (siz fixnum message-digest-raw-chunk-size)
    70   (beg fixnum message-digest-raw-chunk-start) )
    71 
    72 (: default-chunk-fileno-read-maker (fd fixnum) . (opts (list fixnum))) -> procedure
    73 ;
    74 (define (default-chunk-fileno-read-maker (fd fixnum) . (opts (list fixnum))) -> procedure
     82  (obj message-digest-raw-chunk-object)
     83  (siz message-digest-raw-chunk-size)
     84  (beg message-digest-raw-chunk-start) )
     85
     86(: default-chunk-fileno-read-maker (fixnum #!rest (list fixnum) -> procedure))
     87;
     88(define (default-chunk-fileno-read-maker fd . opts)
    7589  (let (
    7690    (siz (optional opts (file-size fd))) )
    77     (if (zero? siz)
    78       (lambda ()
    79         #f )
     91    (if (fxzero? siz)
     92      (lambda () #f)
    8093      (let-values (
    81         ((buffer cleanup)
    82           (mapped-buffer 'default-chunk-fileno-read-maker fd siz)) )
     94        ((buffer cleanup) (mapped-buffer 'default-chunk-fileno-read-maker fd siz)) )
    8395        (let (
    8496          (chunk (make-message-digest-raw-chunk buffer siz 0)) )
    8597          (lambda ()
    8698            (if buffer
    87               (begin0
    88                 chunk
    89                 (set! buffer #f))
     99              (begin
     100                (set! buffer #f)
     101                chunk)
    90102              (begin
    91103                (cleanup)
     
    98110    ;tested w/ macosx (replaced mmap version)
    99111
    100     (use (only lolevel allocate free))
     112    (import (only (chicken memory) allocate free))
    101113
    102114    (: read-into-buffer (fixnum pointer fixnum -> boolean))
     
    118130  (else ;assume unix
    119131
    120     (use
    121       (only posix
     132    (import
     133      (only memory-mapped-files
    122134        map-file-to-memory unmap-file-from-memory
    123         memory-mapped-file-pointer
    124         map/shared
    125         prot/read))
     135        memory-mapped-file-pointer map/shared prot/read))
    126136
    127137      (: mapped-buffer (symbol fixnum fixnum -> pointer procedure))
     
    166176        (message-digest-chunk-port-read-maker) ) ) ) ) )
    167177
    168 (define message-digest-chunk-read-maker message-digest-chunk-port-read-maker)
    169 
    170178;;
    171179
  • release/5/message-digest-utils/trunk/message-digest-int.scm

    r35898 r35914  
    1 ;;;; message-digest-int.scm
     1;;;; message-digest-int.scm  -*- Scheme -*-
     2;;;; Kon Lovett, Jul '18
     3;;;; Kon Lovett, Aug '17
     4;;;; Kon Lovett, Apr '12
     5;;;; Kon Lovett, May '10 (message-digest.scm)
    26;;;; Kon Lovett, Jan '06 (message-digest.scm)
    3 ;;;; Kon Lovett, May '10 (message-digest.scm)
    4 ;;;; Kon Lovett, Apr '12
    5 ;;;; Kon Lovett, Aug '17
    6 
    7 ;; Issues
    87
    98(module message-digest-int
     
    2524  message-digest-update-u64-le)
    2625
    27 (import scheme chicken)
    28 (use
     26(import scheme
     27  (chicken base)
     28  (chicken platform)
     29  (chicken type)
    2930  message-digest-type
    3031  message-digest-support
     
    4142;;
    4243
    43 (: get-byte-order (loc symbol) (obj *)) --> message-digest-byte-order
     44(: get-byte-order (symbol * --> message-digest-byte-order))
    4445;
    45 (define (get-byte-order (loc symbol) (obj *)) --> message-digest-byte-order
     46(define (get-byte-order loc obj)
    4647  (case obj
    4748        ((big-endian be big msb)                                'big-endian )
     
    5253;;
    5354
    54 (: *message-digest-update-uint (loc symbol) (md message-digest) (n number) (size fixnum) (setter procedure))
     55(: *message-digest-update-uint (symbol message-digest number fixnum procedure -> void))
    5556;
    56 (define (*message-digest-update-uint (loc symbol) (md message-digest) (n number) (size fixnum) (setter procedure))
     57(define (*message-digest-update-uint loc md n size setter)
    5758  (let (
    58     (blb (setup-message-digest-buffer! (check-message-digest loc md) size)) )
     59    (blb (ensure-message-digest-buffer! (check-message-digest loc md) size)) )
    5960        (setter blb (check-integer loc n) 0)
    6061        (*message-digest-update-blob md blb size) ) )
     
    6465;; Char
    6566
    66 (: message-digest-update-char-u8 (md message-digest) (ch char))
     67(: message-digest-update-char-u8 (message-digest char -> void))
    6768;
    68 (define (message-digest-update-char-u8 (md message-digest) (ch char))
     69(define (message-digest-update-char-u8 md ch)
    6970        (*message-digest-update-uint 'message-digest-update-char-u8
    7071          md
     
    7374          *blob-set-u8!) )
    7475
    75 (: message-digest-update-char-be (md message-digest) (ch char))
     76(: message-digest-update-char-be (message-digest char -> void))
    7677;
    77 (define (message-digest-update-char-be (md message-digest) (ch char))
     78(define (message-digest-update-char-be md ch)
    7879        (*message-digest-update-uint 'message-digest-update-char-be
    7980          md
     
    8283          *blob-set-u32-be!) )
    8384
    84 (: message-digest-update-char-le (md message-digest) (ch char))
     85(: message-digest-update-char-le (message-digest char -> void))
    8586;
    86 (define (message-digest-update-char-le (md message-digest) (ch char))
     87(define (message-digest-update-char-le md ch)
    8788        (*message-digest-update-uint 'message-digest-update-char-le
    8889          md
     
    9394;; Unsigned Integer 8, 16, 32, & 64 bits
    9495
    95 (: message-digest-update-u8 (md message-digest) (n number))
     96(: message-digest-update-u8 (message-digest number -> void))
    9697;
    97 (define (message-digest-update-u8 (md message-digest) (n number))
     98(define (message-digest-update-u8 md n)
    9899        (*message-digest-update-uint 'message-digest-update-u8 md n 1 *blob-set-u8!) )
    99100
    100 (: message-digest-update-u16-be (md message-digest) (n number))
     101(: message-digest-update-u16-be (message-digest number -> void))
    101102;
    102 (define (message-digest-update-u16-be (md message-digest) (n number))
     103(define (message-digest-update-u16-be md n)
    103104        (*message-digest-update-uint 'message-digest-update-u16-be md n 2 *blob-set-u16-be!) )
    104105
    105 (: message-digest-update-u16-le (md message-digest) (n number))
     106(: message-digest-update-u16-le (message-digest number -> void))
    106107;
    107 (define (message-digest-update-u16-le (md message-digest) (n number))
     108(define (message-digest-update-u16-le md n)
    108109        (*message-digest-update-uint 'message-digest-update-u16-le md n 2 *blob-set-u16-le!) )
    109110
    110 (: message-digest-update-u32-be (md message-digest) (n number))
     111(: message-digest-update-u32-be (message-digest number -> void))
    111112;
    112 (define (message-digest-update-u32-be (md message-digest) (n number))
     113(define (message-digest-update-u32-be md n)
    113114        (*message-digest-update-uint 'message-digest-update-u32-be md n 4 *blob-set-u32-be!) )
    114115
    115 (: message-digest-update-u32-le (md message-digest) (n number))
     116(: message-digest-update-u32-le (message-digest number -> void))
    116117;
    117 (define (message-digest-update-u32-le (md message-digest) (n number))
     118(define (message-digest-update-u32-le md n)
    118119        (*message-digest-update-uint 'message-digest-update-u32-le md n 4 *blob-set-u32-le!) )
    119120
    120 (: message-digest-update-u64-be (md message-digest) (n number))
     121(: message-digest-update-u64-be (message-digest number -> void))
    121122;
    122 (define (message-digest-update-u64-be (md message-digest) (n number))
     123(define (message-digest-update-u64-be md n)
    123124        (*message-digest-update-uint 'message-digest-update-u64-be md n 8 *blob-set-u64-be!) )
    124125
    125 (: message-digest-update-u64-le (md message-digest) (n number))
     126(: message-digest-update-u64-le (message-digest number -> void))
    126127;
    127 (define (message-digest-update-u64-le (md message-digest) (n number))
     128(define (message-digest-update-u64-le md n)
    128129        (*message-digest-update-uint 'message-digest-update-u64-le md n 8 *blob-set-u64-le!) )
    129130
    130131;; Machine Byte Order w/ Char & Unsigned Integer
    131132
    132 (: message-digest-update-char (md message-digest) (ch char) . (opts (list message-digest-byte-order)))
     133(: message-digest-update-char (message-digest char #!rest (list message-digest-byte-order) -> void))
    133134;
    134 (define (message-digest-update-char (md message-digest) (ch char) . (opts (list message-digest-byte-order)))
     135(define (message-digest-update-char md ch . opts)
    135136  (let (
    136137    (order (optional opts (machine-byte-order))) )
     
    139140      ((big-endian)                     (message-digest-update-char-be md ch) ) ) ) )
    140141
    141 (: message-digest-update-u16 (md message-digest) (n number) . (opts (list message-digest-byte-order)))
     142(: message-digest-update-u16 (message-digest number #!rest (list message-digest-byte-order) -> void))
    142143;
    143 (define (message-digest-update-u16 (md message-digest) (n number) . (opts (list message-digest-byte-order)))
     144(define (message-digest-update-u16 md n . opts)
    144145  (let (
    145146    (order (optional opts (machine-byte-order))) )
     
    148149      ((big-endian)                     (message-digest-update-u16-be md n) ) ) ) )
    149150
    150 (: message-digest-update-u32 (md message-digest) (n number) . (opts (list message-digest-byte-order)))
     151(: message-digest-update-u32 (message-digest number #!rest (list message-digest-byte-order) -> void))
    151152;
    152 (define (message-digest-update-u32 (md message-digest) (n number) . (opts (list message-digest-byte-order)))
     153(define (message-digest-update-u32 md n . opts)
    153154  (let (
    154155    (order (optional opts (machine-byte-order))) )
     
    157158      ((big-endian)                     (message-digest-update-u32-be md n) ) ) ) )
    158159
    159 (: message-digest-update-u64 (md message-digest) (n number) . (opts (list message-digest-byte-order)))
     160(: message-digest-update-u64 (message-digest number #!rest (list message-digest-byte-order) -> void))
    160161;
    161 (define (message-digest-update-u64 (md message-digest) (n number) . (opts (list message-digest-byte-order)))
     162(define (message-digest-update-u64 md n . opts)
    162163  (let (
    163164    (order (optional opts (machine-byte-order))) )
  • release/5/message-digest-utils/trunk/message-digest-item.scm

    r35898 r35914  
    1 ;;;; message-digest-item.scm
     1;;;; message-digest-item.scm  -*- Scheme -*-
     2;;;; Kon Lovett, Jul '18
     3;;;; Kon Lovett, Aug '17
     4;;;; Kon Lovett, Apr '12
     5;;;; Kon Lovett, May '10 (message-digest.scm)
    26;;;; Kon Lovett, Jan '06 (message-digest.scm)
    3 ;;;; Kon Lovett, may '10 (message-digest.scm)
    4 ;;;; Kon Lovett, Apr '12
    5 ;;;; Kon Lovett, Aug '17
    6 
    7 ;; Issues
    87
    98(module message-digest-item
     
    1918  message-digest-port!)
    2019
    21 (import scheme chicken)
    22 (use
     20(import scheme
     21  (chicken base)
     22  (chicken type)
    2323  message-digest-type
    2424  message-digest-update-item)
     
    3434;;
    3535
    36 (: message-digest-object (mdp message-digest-primitive) (obj *) . (opts list)) --> message-digest-result-type
     36(: message-digest-object (message-digest-primitive * #!rest list -> message-digest-result-type))
    3737;
    38 (define (message-digest-object (mdp message-digest-primitive) (obj *) . (opts list)) --> message-digest-result-type
     38(define (message-digest-object mdp obj . opts)
    3939  (let-optionals* opts (
    4040    (restyp (message-digest-result-form))
     
    4545      (finalize-message-digest md restyp) ) ) )
    4646
    47 (: message-digest-file (mdp message-digest-primitive) (flnm pathname) . (opts list)) --> message-digest-result-type
     47(: message-digest-file (message-digest-primitive pathname #!rest list -> message-digest-result-type))
    4848;
    49 (define (message-digest-file (mdp message-digest-primitive) (flnm pathname) . (opts list)) --> message-digest-result-type
     49(define (message-digest-file mdp flnm . opts)
    5050  (let (
    5151    (restyp (message-digest-result-form))
     
    5454    (finalize-message-digest md restyp) ) )
    5555
    56 (: message-digest-port (mdp message-digest-primitive) (port output-port) . (opts list)) --> message-digest-result-type
     56(: message-digest-port (message-digest-primitive output-port #!rest list -> message-digest-result-type))
    5757;
    58 (define (message-digest-port (mdp message-digest-primitive) (port output-port) . (opts list)) --> message-digest-result-type
     58(define (message-digest-port mdp port . opts)
    5959  (let (
    6060    (restyp (message-digest-result-form))
     
    6565;;
    6666
    67 (: message-digest-object! (mdp message-digest-primitive) (obj *) (buf message-digest-buffer) . (opts list)) -> message-digest-result-type
     67(: message-digest-object! (message-digest-primitive * message-digest-buffer #!rest list -> message-digest-result-type))
    6868;
    69 (define (message-digest-object! (mdp message-digest-primitive) (obj *) (buf message-digest-buffer) . (opts list)) -> message-digest-result-type
     69(define (message-digest-object! mdp obj buf . opts)
    7070  (let-optionals* opts (
    7171    (start 0)
     
    7676      (finalize-message-digest! md buf) ) ) )
    7777
    78 (: message-digest-file! (mdp message-digest-primitive) (flnm pathname) (buf message-digest-buffer)) -> message-digest-result-type
     78(: message-digest-file! (message-digest-primitive pathname message-digest-buffer -> message-digest-result-type))
    7979;
    80 (define (message-digest-file! (mdp message-digest-primitive) (flnm pathname) (buf message-digest-buffer)) -> message-digest-result-type
     80(define (message-digest-file! mdp flnm buf)
    8181  (let (
    8282    (md (initialize-message-digest mdp)) )
     
    8484    (finalize-message-digest! md buf) ) )
    8585
    86 (: message-digest-port! (mdp message-digest-primitive) (port output-port) (buf message-digest-buffer)) -> message-digest-result-type
     86(: message-digest-port! (message-digest-primitive output-port message-digest-buffer -> message-digest-result-type))
    8787;
    88 (define (message-digest-port! (mdp message-digest-primitive) (port output-port) (buf message-digest-buffer)) -> message-digest-result-type
     88(define (message-digest-port! mdp port buf)
    8989  (let (
    9090    (md (initialize-message-digest mdp)) )
  • release/5/message-digest-utils/trunk/message-digest-port.scm

    r35898 r35914  
    1 ;;;; message-digest-port.scm
     1;;;; message-digest-port.scm  -*- Scheme -*-
     2;;;; Kon Lovett, Jul '18
     3;;;; Kon Lovett, Aug '17
    24;;;; Kon Lovett, May '10
    3 ;;;; Kon Lovett, Aug '17
    45
    56;; Issues
    67;;
    78;; - Use of sys namespace routines.
     9
     10(declare
     11  (bound-to-procedure
     12    ##sys#slot ##sys#setslot
     13    ##sys#port-data ##sys#set-port-data!))
    814
    915(module message-digest-port
     
    1723  with-output-to-digest)
    1824
    19 (import scheme chicken)
    20 (use
    21   (only data-structures ->string)
    22   (only ports make-output-port with-input-from-port)
    23   (only srfi-13 string-suffix-length-ci)
     25(import scheme
     26  (chicken base)
     27  (chicken fixnum)
     28  (chicken type)
     29  (only (chicken string) ->string)
     30  (only (chicken port) make-output-port with-input-from-port)
     31  (only (srfi 13) string-suffix-length-ci)
    2432  (only type-checks define-check+error-type check-output-port)
    2533  (only type-errors error-argument-type make-error-type-message signal-type-error)
     
    2735  message-digest-type
    2836  message-digest-byte-vector)
    29 
    30 (declare
    31   (bound-to-procedure
    32     ##sys#slot ##sys#setslot))
    3337
    3438;;; Support
     
    5155(define PRIMITIVE-NAME-SUFFIXES '("p" "-primitive"))
    5256
    53 ;;
     57;;% for primitive
    5458
    5559(define (%port-type p)
     
    6266  (##sys#slot p 3) )
    6367
    64 (define (%port-name-set! p s)
     68(define (%set-port-name! p s)
    6569  (##sys#setslot p 3 s) )
     70
     71(define (%port-data p)
     72  (##sys#port-data p) )
     73
     74(define (%set-port-data! p s)
     75  (##sys#set-port-data! p s) )
    6676
    6777;;
     
    7484(define (check-open-digest-output-port loc obj #!optional argnam)
    7585  (let (
    76     (pt (%port-type (check-open-port loc (check-output-port loc obj argnam) argnam))) )
    77     (unless (eq? PORT-TAG pt)
     86    (port (%port-type (check-open-port loc (check-output-port loc obj argnam) argnam))) )
     87    (unless (eq? PORT-TAG port)
    7888      (signal-type-error loc (make-error-type-message 'digest-output-port) obj argnam) ) )
    7989  obj )
    8090
    8191;Synthesize a port-name from a primitive-name
    82 (: make-digest-port-name (mdp message-digest-primitive)) --> string
     92(: make-digest-port-name (message-digest-primitive --> string))
    8393;
    84 (define (make-digest-port-name (mdp message-digest-primitive)) --> string
    85   (let* (
    86     (nam
    87       (->string (or (message-digest-primitive-name mdp) 'md)))
    88     ;strip trailing (why ?)
    89     (remlen
    90       ;longest suffix length or negative
    91       (foldl
    92         (lambda (remlen suf)
    93           (fxmax remlen (string-suffix-length-ci nam suf)) )
    94         -1
    95         PRIMITIVE-NAME-SUFFIXES))
    96     (nam
    97       (if (fxpositive? remlen)
    98         (substring nam 0 (fx- (string-length nam) remlen))
    99         nam)) )
    100     (string-append "(" nam ")") ) )
     94(define make-digest-port-name
     95  ;need byte-oriented semantics
     96  (let ((substring substring))
     97    (lambda (mdp)
     98      (let* (
     99        (nam
     100          (->string (or (message-digest-primitive-name mdp) 'md)))
     101        ;strip trailing (why ?)
     102        (remlen
     103          ;longest suffix length or negative
     104          (foldl
     105            (lambda (remlen suf)
     106              (fxmax remlen (string-suffix-length-ci nam suf)) )
     107            -1
     108            PRIMITIVE-NAME-SUFFIXES))
     109        (nam
     110          (if (fxpositive? remlen)
     111            (substring nam 0 (fx- (string-length nam) remlen))
     112            nam)) )
     113        (string-append "(" nam ")") ) ) ) )
    101114
    102115;;; Message Digest Output Port API
    103116
    104 (: open-output-digest (mdp message-digest-primitive)) -> digest-output-port
     117(: open-output-digest (message-digest-primitive -> digest-output-port))
    105118;
    106 (define (open-output-digest (mdp message-digest-primitive)) -> digest-output-port
     119(define (open-output-digest mdp)
    107120  (let* (
    108121    (md
     
    117130      (port
    118131        (make-output-port writer void)) )
    119     (##sys#set-port-data! port md)
     132    (%set-port-data! port md)
    120133    (%port-type-set! port PORT-TAG)
    121     (%port-name-set! port (make-digest-port-name mdp))
     134    (%set-port-name! port (make-digest-port-name mdp))
    122135    port ) )
    123136
     
    131144(define-check+error-type digest-output-port)
    132145
    133 (: digest-output-port-name (port digest-output-port)) --> string
     146(: digest-output-port-name (digest-output-port --> string))
    134147;
    135 (define (digest-output-port-name (port digest-output-port)) --> string
    136   (%port-name
    137     (check-digest-output-port 'digest-output-port-name port)) )
     148(define (digest-output-port-name port)
     149  (%port-name (check-digest-output-port 'digest-output-port-name port)) )
    138150
    139 (: *close-output-digest (loc symbol) (port digest-output-port) (restyp message-digest-result-form)) -> message-digest-result-type
     151(: *close-output-digest (symbol digest-output-port message-digest-result-form -> message-digest-result-type))
    140152;
    141 (define (*close-output-digest (loc symbol) (port digest-output-port) (restyp message-digest-result-form)) -> message-digest-result-type
     153(define (*close-output-digest loc port restyp)
    142154  (let (
    143     (res
    144       (finalize-message-digest
    145         (##sys#port-data
    146           (check-open-digest-output-port loc port 'digest-port))
    147         restyp)) )
    148     (close-output-port port)
    149     res ) )
     155    ;must be restyp
     156    (res '||) )
     157    (dynamic-wind
     158      (lambda ()
     159        (set! res
     160          (finalize-message-digest
     161            (%port-data (check-open-digest-output-port loc port 'digest-port))
     162            restyp)))
     163      (lambda ()
     164        res)
     165      (lambda ()
     166        (close-output-port port))) ) )
    150167
    151 (: get-output-digest (port digest-output-port) . (opts (list message-digest-result-type))) -> message-digest-result-type
     168(: get-output-digest (digest-output-port #!rest (list message-digest-result-type) -> message-digest-result-type))
    152169;
    153 (define (get-output-digest (port digest-output-port) . (opts (list message-digest-result-type))) -> message-digest-result-type
     170(define (get-output-digest port . opts)
    154171  (let (
    155172    (restyp (optional opts (message-digest-result-form))) )
     
    158175;;;
    159176
    160 (: call-with-output-digest (mdp message-digest-primitive) (proc procedure) . (opts (list message-digest-result-type))) -> message-digest-result-type
     177(: call-with-output-digest (message-digest-primitive procedure #!rest (list message-digest-result-type) -> message-digest-result-type))
    161178;
    162 (define (call-with-output-digest (mdp message-digest-primitive) (proc procedure) . (opts (list message-digest-result-type))) -> message-digest-result-type
     179(define (call-with-output-digest mdp proc . opts)
    163180  (let (
    164     (restyp (optional opts (message-digest-result-form)))
    165     (port (open-output-digest mdp)) )
    166     (proc port)
    167     (*close-output-digest 'call-with-output-digest port restyp) ) )
     181    (restyp (optional opts (message-digest-result-form))) )
     182    (let (
     183      (port #f) )
     184      (dynamic-wind
     185        (lambda () (set! port (open-output-digest mdp)))
     186        (lambda () (proc port))
     187        (lambda () (*close-output-digest 'call-with-output-digest port restyp))) ) ) )
    168188
    169 (: with-output-to-digest (mdp message-digest-primitive) (thunk procedure) . (opts (list message-digest-result-type))) -> message-digest-result-type
     189(: with-output-to-digest (message-digest-primitive procedure #!rest (list message-digest-result-type) -> message-digest-result-type))
    170190;
    171 (define (with-output-to-digest (mdp message-digest-primitive) (thunk procedure) . (opts (list message-digest-result-type))) -> message-digest-result-type
     191(define (with-output-to-digest mdp thunk . opts)
    172192  (let (
    173193    (restyp (optional opts (message-digest-result-form))) )
  • release/5/message-digest-utils/trunk/message-digest-srfi-4.scm

    r35898 r35914  
    1 ;;;; message-digest-srfi-4.scm
     1;;;; message-digest-srfi-4.scm  -*- Scheme -*-
     2;;;; Kon Lovett, Jul '18
     3;;;; Kon Lovett, Aug '17
     4;;;; Kon Lovett, Apr '12
     5;;;; Kon Lovett, May '10 (message-digest.scm)
    26;;;; Kon Lovett, Jan '06 (message-digest.scm)
    3 ;;;; Kon Lovett, May '10 (message-digest.scm)
    4 ;;;; Kon Lovett, Apr '12
    5 ;;;; Kon Lovett, Aug '17
    67
    78;; Issues
     
    1314(;export
    1415  message-digest-update-u8vector
    15   message-digest-update-packed-vector
    1616  message-digest-u8vector message-digest-u8vector!)
    1717
    18 (import scheme chicken)
    19 (use
    20   data-structures
    21   srfi-4
    22   (only lolevel number-of-bytes)
     18(import scheme
     19  (chicken base)
     20  (chicken blob)
     21  (chicken type)
     22  (srfi 4)
     23  (only (chicken memory representation) number-of-bytes)
    2324  (only srfi-4-checks check-u8vector)
    2425  (only type-errors error-argument-type)
     
    3637;;
    3738
    38 (: get-bytevector-object (loc symbol) (obj *)) --> blob
     39(: get-bytevector-object (symbol * --> blob))
    3940;
    40 (define (get-bytevector-object (loc symbol) (obj *)) --> blob
     41(define (get-bytevector-object loc obj)
    4142        (cond
    4243                ((string? obj)
     
    5253;;
    5354
    54 (: message-digest-update-u8vector (md message-digest) (u8vec u8vector) . (opts list))
     55(: message-digest-update-u8vector (message-digest u8vector #!rest list -> void))
    5556;
    56 (define (message-digest-update-u8vector (md message-digest) (u8vec u8vector) . (opts list))
     57(define (message-digest-update-u8vector md u8vec . opts)
    5758  (let-optionals* opts (
    5859    (start 0)
     
    6364;;; Single Source API
    6465
    65 (: message-digest-u8vector (mdp message-digest-primitive) (u8vec u8vector) . (opts list)) --> message-digest-result-type
     66(: message-digest-u8vector (message-digest-primitive u8vector #!rest list -> message-digest-result-type))
    6667;
    67 (define (message-digest-u8vector (mdp message-digest-primitive) (u8vec u8vector) . (opts list)) --> message-digest-result-type
     68(define (message-digest-u8vector mdp u8vec . opts)
    6869  (let-optionals* opts (
    6970    (restyp (message-digest-result-form))
     
    7475      (finalize-message-digest md restyp) ) ) )
    7576
    76 (: message-digest-u8vector! (mdp message-digest-primitive) (u8vec u8vector) (buffer message-digest-buffer) . (opts list)) -> message-digest-result-type
     77(: message-digest-u8vector! (message-digest-primitive u8vector message-digest-buffer #!rest list -> message-digest-result-type))
    7778;
    78 (define (message-digest-u8vector! (mdp message-digest-primitive) (u8vec u8vector) (buffer message-digest-buffer) . (opts list)) -> message-digest-result-type
     79(define (message-digest-u8vector! mdp u8vec buffer . opts)
    7980  (let-optionals* opts (
    8081    (start 0)
  • release/5/message-digest-utils/trunk/message-digest-support.scm

    r35898 r35914  
    1 ;;;; message-digest-support.scm
     1;;;; message-digest-support.scm  -*- Scheme -*-
     2;;;; Kon Lovett, Jul '18
     3;;;; Kon Lovett, Aug '17
     4;;;; Kon Lovett, Apr '12
     5;;;; Kon Lovett, May '10 (message-digest.scm)
    26;;;; Kon Lovett, Jan '06 (message-digest.scm)
    3 ;;;; Kon Lovett, May '10 (message-digest.scm)
    4 ;;;; Kon Lovett, Apr '12
    5 ;;;; Kon Lovett, Aug '17
    67
    78;; Issues
     
    1516
    1617(;export
    17   ; Support
     18  ;Support
    1819  packed-vector->blob/shared
    1920  ;
     
    2324  *message-digest-update-string)
    2425
    25 (import scheme chicken)
    26 (use
    27   (only lolevel number-of-bytes)
     26(import scheme
     27  (chicken base)
     28  (chicken blob)
     29  (chicken fixnum)
     30  (chicken type)
     31  (only (chicken memory representation) number-of-bytes)
    2832  (only srfi-4
    29     s8vector?
    30     u8vector?
    31     s16vector?
    32     u16vector?
    33     s32vector?
    34     u32vector?
    35     #;u64vector?
    36     #;u64vector?
    37     f32vector?
    38     f64vector?
    39     u8vector->blob/shared
    40     s8vector->blob/shared
    41     s16vector->blob/shared
    42     u16vector->blob/shared
    43     s32vector->blob/shared
    44     u32vector->blob/shared
    45     #;s64vector->blob/shared
    46     #;u64vector->blob/shared
    47     f32vector->blob/shared
    48     f64vector->blob/shared
    49     subu8vector u8vector-length)
     33    s8vector? u8vector? subu8vector u8vector-length
     34    s16vector? u16vector?
     35    s32vector? u32vector?
     36    u64vector? s64vector?
     37    f32vector? f64vector?
     38    s8vector->blob/shared u8vector->blob/shared
     39    s16vector->blob/shared u16vector->blob/shared
     40    s32vector->blob/shared u32vector->blob/shared
     41    s64vector->blob/shared u64vector->blob/shared
     42    f32vector->blob/shared f64vector->blob/shared)
    5043  message-digest-primitive
    5144  message-digest-type)
     
    5649
    5750(include "message-digest-types")
     51
     52;;
     53
     54(define-type start-index fixnum)
     55(define-type end-index (or boolean fixnum))
    5856
    5957;;fx-utils
     
    6866;Used by update-item & srfi-4 modules
    6967
    70 (: packed-vector->blob/shared (obj srfi4vector)) -> (or boolean blob)
     68(: packed-vector->blob/shared (srfi4vector -> (or boolean blob)))
    7169;
    72 (define (packed-vector->blob/shared (obj srfi4vector)) -> (or boolean blob)
     70(define (packed-vector->blob/shared obj)
    7371  (cond
    7472    ((u8vector? obj)        (u8vector->blob/shared obj))
     
    7876    ((u32vector? obj)       (u32vector->blob/shared obj))
    7977    ((s32vector? obj)       (s32vector->blob/shared obj))
    80     #;((u64vector? obj)       (u64vector->blob/shared obj))
    81     #;((s64vector? obj)       (s64vector->blob/shared obj))
     78    ((u64vector? obj)       (u64vector->blob/shared obj))
     79    ((s64vector? obj)       (s64vector->blob/shared obj))
    8280    ((f32vector? obj)       (f32vector->blob/shared obj))
    8381    ((f64vector? obj)       (f64vector->blob/shared obj))
    84     (else                   #f ) ) )
     82    (else
     83      #f ) ) )
    8584
    8685;;
    8786
    88 (: u8vector/slice (u8vec u8vector) (start fixnum) (end (or boolean fixnum))) --> u8vector
     87(: u8vector/slice (u8vector start-index end-index --> u8vector))
    8988;
    90 (define (u8vector/slice (u8vec u8vector) (start fixnum) (end (or boolean fixnum))) --> u8vector
     89(define (u8vector/slice u8vec start end)
    9190   (let (
    9291    (end (or end (u8vector-length u8vec))) )
    93     (if (and (fxzero? start) (fx= end (u8vector-length u8vec)))
     92    (if (and (fx= end (u8vector-length u8vec)) (fxzero? start))
    9493      u8vec
    9594      (subu8vector u8vec start end) ) ) )
    9695
    97 (: blob/slice (blb blob) (start fixnum) (end (or boolean fixnum))) --> blob
     96(: blob/slice (blob start-index end-index --> blob))
    9897;
    99 (define (blob/slice (blb blob) (start fixnum) (end (or boolean fixnum))) --> blob
    100   (let (
    101     (end (or end (blob-size blb))) )
    102     (if (and (fxzero? start) (fx= end (blob-size blb)))
    103       blb
    104       (string->blob (##sys#substring (blob->string blb) start end)) ) ) )
     98(define blob/slice
     99  ;need byte-oriented semantics
     100  (let ((substring substring))
     101    (lambda (blb start end)
     102      (let (
     103        (end (or end (blob-size blb))) )
     104        (if (and (fx= end (blob-size blb)) (fxzero? start))
     105          blb
     106          (string->blob (substring (blob->string blb) start end)) ) ) ) ) )
    105107
    106 (: string/slice (str string) (start fixnum) (end (or boolean fixnum))) --> string
     108(: string/slice (string start-index end-index --> string))
    107109;
    108 (define (string/slice (str string) (start fixnum) (end (or boolean fixnum))) --> string
     110(define (string/slice str start end)
    109111  (let (
    110112    (end (or end (string-length str))) )
    111     (if (and (fxzero? start) (fx= end (string-length str)))
     113    (if (and (fx= end (string-length str)) (fxzero? start))
    112114      str
    113       (##sys#substring str start end) ) ) )
     115      (substring str start end) ) ) )
    114116
    115117;;
    116118
    117 (: *message-digest-update-blob (md message-digest) (blb blob) . (opts (list fixnum)))
     119(: *message-digest-update-blob (message-digest blob #!rest (list fixnum) -> void))
    118120;
    119 (define (*message-digest-update-blob (md message-digest) (blb blob) . (opts (list fixnum)))
     121(define (*message-digest-update-blob md blb . opts)
    120122  (let (
    121123    (siz (optional opts (blob-size blb))) )
    122     ((message-digest-algorithm-update md)
    123       (message-digest-context md)
    124       blb
    125       siz) ) )
     124    ((message-digest-algorithm-update md) (message-digest-context md) blb siz) ) )
    126125
    127 (: *message-digest-update-string (md message-digest) (str string))
     126(: *message-digest-update-string (message-digest string -> void))
    128127;
    129 (define (*message-digest-update-string (md message-digest) (str string))
     128(define (*message-digest-update-string md str)
    130129        (*message-digest-update-blob md (string->blob str)) )
    131130
    132 (: message-digest-algorithm-update (md message-digest)) -> procedure
     131(: message-digest-algorithm-update (message-digest -> procedure))
    133132;
    134 (define (message-digest-algorithm-update (md message-digest)) -> procedure
     133(define (message-digest-algorithm-update md)
    135134  (message-digest-primitive-update (message-digest-algorithm md)) )
    136135
  • release/5/message-digest-utils/trunk/message-digest-types.scm

    r35898 r35914  
    1 ;;;; message-digest-types.scm
     1;;;; message-digest-types.scm  -*- Scheme -*-
     2;;;; Kon Lovett, Jul '18
    23;;;; Kon Lovett, Mar '18
    34
    4 ;;include
     5;;Include File
    56
    67(define-type pathname string)
     
    910  (or u8vector s8vector u16vector s16vector u32vector s32vector f32vector f64vector))
    1011
     12;from message-digest-primitive
     13(define-type message-digest-primitive-name (or symbol string))
     14(define-type message-digest-primitive (struct message-digest-primitive))
     15
     16;from message-digest-type
     17(define-type message-digest (struct message-digest))
     18
    1119(define-type message-digest-raw-chunk (struct message-digest-raw-chunk))
    1220
    1321(define-type message-digest-buffer (or string blob u8vector))
    14 #; ;desired, bufpointer is (pointer + length)
     22#; ;desired, bufpointer is pointer+start+end
    1523(define-type message-digest-buffer (or string blob srfi4vector procedure input-port bufpointer))
    1624
     
    2331(define-type message-digest-context (or fixnum procedure))
    2432
    25 (define-type message-digest-primitive (struct message-digest-primitive))
    26 
    27 (define-type message-digest-primitive-name (or symbol string))
    28 
    29 (define-type message-digest (struct message-digest))
    30 
    3133(define-type digest-output-port output-port)
  • release/5/message-digest-utils/trunk/message-digest-update-item.scm

    r35898 r35914  
    1 ;;;; message-digest-update-item.scm
     1;;;; message-digest-update-item.scm  -*- Scheme -*-
     2;;;; Kon Lovett, Jul '18
     3;;;; Kon Lovett, Aug '17
     4;;;; Kon Lovett, Apr '12
     5;;;; Kon Lovett, May '10 (message-digest.scm)
    26;;;; Kon Lovett, Jan '06 (message-digest.scm)
    3 ;;;; Kon Lovett, May '10 (message-digest.scm)
    4 ;;;; Kon Lovett, Apr '12
    5 ;;;; Kon Lovett, Aug '17
    6 
    7 ;; Issues
    87
    98(module message-digest-update-item
     
    1514  message-digest-update-file)
    1615
    17 (import scheme chicken)
    18 (use
    19   (only lolevel number-of-bytes pointer?)
    20   (only posix
    21     file-open file-close
    22     open/rdonly
    23     directory?)
     16(import scheme
     17  (chicken file)
     18  (chicken base)
     19  (chicken blob)
     20  (only (chicken memory representation) number-of-bytes)
     21  (only (chicken memory) pointer?)
     22  (chicken type)
     23  (only (chicken file posix) file-open file-close open/rdonly directory?)
    2424  message-digest-primitive
    2525  message-digest-type
     
    3939(define-type converted-chunk (or blob string message-digest-raw-chunk))
    4040
     41(define-type start-index fixnum)
     42(define-type end-index (or boolean fixnum))
     43
     44(define-type source-update procedure)
     45(define-type raw-update procedure)
     46
    4147;;
    4248
    4349;=> #f or converted-chunk
    44 (: chunk-convert (obj *)) -> converted-chunk
    45 ;
    46 (define (chunk-convert (obj *)) -> converted-chunk
     50(: chunk-convert (* -> converted-chunk))
     51;
     52(define (chunk-convert obj)
    4753  (and-let* (
    4854    (cnv (message-digest-chunk-converter)) )
    4955    (cnv obj) ) )
    5056
    51 (: get-port-chunk-reader (port input-port)) -> procedure
    52 ;
    53 (define (get-port-chunk-reader (port input-port)) -> procedure
     57(: get-port-chunk-reader (input-port -> procedure))
     58;
     59(define (get-port-chunk-reader port)
    5460        ((message-digest-chunk-port-read-maker) port) )
    5561
    56 (: get-fileno-chunk-reader (fd fixnum)) -> procedure
    57 ;
    58 (define (get-fileno-chunk-reader (fd fixnum)) -> procedure
     62(: get-fileno-chunk-reader (fixnum -> procedure))
     63;
     64(define (get-fileno-chunk-reader fd)
    5965        ((message-digest-chunk-fileno-read-maker) fd) )
    6066
    61 (: get-update (md message-digest)) -> procedure
    62 ;
    63 (define (get-update (md message-digest)) -> procedure
     67(: get-update (message-digest --> source-update))
     68;
     69(define (get-update md)
    6470  (message-digest-primitive-update (message-digest-algorithm md)) )
    6571
    66 (: get-raw-update (md message-digest)) -> procedure
    67 ;
    68 (define (get-raw-update (md message-digest)) -> procedure
     72(: get-raw-update (message-digest --> raw-update))
     73;
     74(define (get-raw-update md)
    6975  (message-digest-primitive-raw-update (message-digest-algorithm md)) )
    7076
    7177;;
    7278
    73 (: do-object-update (loc symbol) (md message-digest) (src *) (start fixnum) (end (or boolean fixnum)))
    74 ;
    75 (define (do-object-update (loc symbol) (md message-digest) (src *) (start fixnum) (end (or boolean fixnum)))
     79(: do-object-update (symbol message-digest * start-index end-index -> void))
     80;
     81(define (do-object-update loc md src start end)
    7682  (cond
    7783    ((input-port? src)    (do-port-update loc md src start end) )
     
    7985    (else                 (do-bytes-update loc md src start end) ) ) )
    8086
    81 (: do-port-update (loc symbol) (md message-digest) (port input-port) (start fixnum) (end (or boolean fixnum)))
    82 ;
    83 (define (do-port-update (loc symbol) (md message-digest) (port input-port) (start fixnum) (end (or boolean fixnum)))
     87(: do-port-update (symbol message-digest input-port start-index end-index -> void))
     88;
     89(define (do-port-update loc md port start end)
    8490  (do-procedure-update loc md (get-port-chunk-reader port) start end) )
    8591
    86 (: do-procedure-update (loc symbol) (md message-digest) (proc procedure) (start fixnum) (end (or boolean fixnum)))
    87 ;
    88 (define (do-procedure-update (loc symbol) (md message-digest) (proc procedure) (start fixnum) (end (or boolean fixnum)))
     92(: do-procedure-update (symbol message-digest procedure start-index end-index -> void))
     93;
     94(define (do-procedure-update loc md proc start end)
    8995  (let (
    9096    (src-updt (get-update md))
     
    97103        (loop) ) ) ) )
    98104
    99 (: do-bytes-update (loc symbol) (md message-digest) (src *) (start fixnum) (end (or boolean fixnum)))
    100 ;
    101 (define (do-bytes-update (loc symbol) (md message-digest) (src *) (start fixnum) (end (or boolean fixnum)))
     105(: do-bytes-update (symbol message-digest * start-index end-index -> void))
     106;
     107(define (do-bytes-update loc md src start end)
    102108  (do-byte-source-update
    103109    loc
     
    108114    start end) )
    109115
    110 (: do-byte-source-update (loc symbol) (ctx *) (src *) (src-updt procedure) (raw-updt procedure) (start fixnum) (end (or boolean fixnum)))
    111 ;
    112 (define (do-byte-source-update (loc symbol) (ctx *) (src *) (src-updt procedure) (raw-updt procedure) (start fixnum) (end (or boolean fixnum)))
     116(: do-byte-source-update (symbol * * source-update raw-update start-index end-index -> void))
     117;
     118(define (do-byte-source-update loc ctx src src-updt raw-updt start end)
    113119  (cond
    114120    ;simple bytes
    115121    ((blob? src)
    116122      (let (
    117         (blb
    118           (blob/slice src start end)) )
    119           (src-updt ctx blb (blob-size blb)) ) )
     123        (blb (blob/slice src start end)))
     124          (src-updt ctx blb (blob-size blb))) )
    120125    ((string? src)
    121126      (let (
    122         (str
    123           (string/slice src start end)) )
    124           (src-updt ctx str (string-length str)) ) )
     127        (str (string/slice src start end)))
     128          (src-updt ctx str (string-length str))) )
    125129    ((message-digest-raw-chunk? src)
    126130      (let* (
    127131        (obj (message-digest-raw-chunk-object src))
    128         (updator (if (pointer? obj) raw-updt src-updt)) )
    129         (unless updator
     132        (updater (if (pointer? obj) raw-updt src-updt)) )
     133        (unless updater
     134          ;FIXME doesn't know which md primitive is providing the updater
    130135          (error loc "primitive does not support raw-update") )
    131136        ;FIXME xtra arg (message-digest-raw-chunk-start src)
    132         (updator ctx
    133           obj
    134           (message-digest-raw-chunk-size src)) ) )
     137        (updater ctx obj (message-digest-raw-chunk-size src)) ) )
    135138    ;more complicated bytes
    136139    ((object->bytevector-like src) =>
     
    140143      (signal-type-error loc "indigestible object" src start end) ) ) )
    141144
    142 (: object->bytevector-like (obj *)) -> converted-chunk
    143 ;
    144 (define (object->bytevector-like (obj *)) -> converted-chunk
     145(: object->bytevector-like (* -> converted-chunk))
     146;
     147(define (object->bytevector-like obj)
    145148  (or
    146149    (packed-vector->blob/shared obj)
     
    151154;;
    152155
    153 (: message-digest-update-object (md message-digest) (obj *) . (opts list))
    154 ;
    155 (define (message-digest-update-object (md message-digest) (obj *) . (opts list))
     156(: message-digest-update-object (message-digest * #!rest list -> void))
     157;
     158(define (message-digest-update-object md obj . opts)
    156159  (let-optionals* opts (
    157160    (start 0)
     
    165168;;
    166169
    167 (: message-digest-update-procedure (md message-digest) (proc procedure))
    168 ;
    169 (define (message-digest-update-procedure (md message-digest) (proc procedure))
     170(: message-digest-update-procedure (message-digest procedure -> void))
     171;
     172(define (message-digest-update-procedure md proc)
    170173  (do-procedure-update
    171174    'message-digest-update-procedure
     
    176179;;
    177180
    178 (: message-digest-update-port (md message-digest) (port input-port))
    179 ;
    180 (define (message-digest-update-port (md message-digest) (port input-port))
     181(: message-digest-update-port (message-digest input-port -> void))
     182;
     183(define (message-digest-update-port md port)
    181184  (do-port-update
    182185    'message-digest-update-port
     
    187190;;
    188191
    189 (: message-digest-update-file (md message-digest) (flnm pathname))
    190 ;
    191 (define (message-digest-update-file (md message-digest) (flnm pathname))
     192(: message-digest-update-file (message-digest pathname -> void))
     193;
     194(define (message-digest-update-file md flnm)
    192195  ;
    193196  (unless (file-exists? (check-string 'message-digest-update-file flnm))
     
    202205    (*message-digest-update-file/port 'message-digest-update-file md flnm) ) )
    203206
    204 (: *message-digest-update-file/fileno (loc symbol) (md message-digest) (flnm pathname))
    205 ;
    206 (define (*message-digest-update-file/fileno (loc symbol) (md message-digest) (flnm pathname))
     207;;
     208
     209(: *message-digest-update-file/fileno (symbol message-digest pathname -> void))
     210;
     211(define (*message-digest-update-file/fileno loc md flnm)
     212  (let ((fd #f))
     213        (dynamic-wind
     214                (lambda () (set! fd (file-open flnm open/rdonly)) )
     215                (lambda () (do-procedure-update loc md (get-fileno-chunk-reader fd) 0 #f) )
     216        (lambda () (file-close fd) ) ) )
     217  #; ;porta-potty
    207218  (let (
    208219    (fd (file-open flnm open/rdonly)) )
     
    214225    (file-close fd) ) )
    215226
    216 (: *message-digest-update-file/port (loc symbol) (md message-digest) (flnm pathname))
    217 ;
    218 (define (*message-digest-update-file/port (loc symbol) (md message-digest) (flnm pathname))
     227(: *message-digest-update-file/port (symbol message-digest pathname -> void))
     228;
     229(define (*message-digest-update-file/port loc md flnm)
     230  (let ((in #f))
     231        (dynamic-wind
     232                (lambda () (set! in (open-input-file flnm)) )
     233                (lambda () (do-port-update loc md in 0 #f) )
     234        (lambda () (close-input-port in) ) ) )
     235  #; ;porta-potty
    219236  (let (
    220237    (in (open-input-file flnm)) )
     
    226243    (close-input-port in) ) )
    227244
    228 #| ;book implementation
    229 (: message-digest-update-file (md message-digest) (flnm pathname))
    230 ;
    231 (define (message-digest-update-file (md message-digest) (flnm pathname))
    232   (let ((in #f))
    233         (dynamic-wind
    234                 (lambda () (set! in (open-input-file flnm)) )
    235                 (lambda () (do-port-update 'message-digest-update-file md in) )
    236         (lambda () (close-input-port in) ) ) ) )
    237 |#
    238 
    239245) ;module message-digest-update-item
  • release/5/message-digest-utils/trunk/message-digest-utils.egg

    r35898 r35914  
    1010        (check-errors "3.1.0")
    1111        (blob-utils "2.0.0")
    12         (string-utils "2.0.5"))
     12        (string-utils "2.0.5")
     13        (memory-mapped-files "0.1"))
    1314 (test-dependencies test)
    1415 (components
     
    2425    #;(inline-file)
    2526    (types-file)
     27    (component-dependencies message-digest-support)
    2628    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks-for-toplevel-bindings") )
    2729  (extension message-digest-int
  • release/5/message-digest-utils/trunk/tests/message-digest-utils-test.scm

    r35898 r35914  
    1 ;;;; message-digest-test.scm
     1;;;; message-digest-utils-test.scm  -*- Scheme -*-
     2;;;; Kon Lovett, Jul '18
    23
    34;; Issues
     
    56;; - Needs many more tests, especially the entire input-port & procedure source stuff.
    67
    7 (use test)
    8 (use message-digest message-digest-port)
    9 (use files lolevel srfi-4)
    10 (use setup-api)
     8(import test)
     9
     10(test-begin "Message Digest Utils")
     11
     12;;;
     13
     14(import
     15  (chicken base)
     16  (chicken fixnum)
     17  (chicken blob)
     18  message-digest-primitive
     19  message-digest-type
     20  message-digest-chunk message-digest-port)
    1121
    1222;;
     
    4151
    4252;;
    43 
    44 (test-begin "Message Digest")
    4553
    4654(test 'hex-string (message-digest-result-form 'hex))
     
    6068)
    6169
    62 (test-group "Make Primitive"
    63 
    64         (define the-ctx #f)
    65 
    66   (define (init ctx)
    67     (set! the-ctx ctx) )
    68 
    69   (define (update ctx bytes count)
    70     (assert (eq? ctx the-ctx))
    71     (assert (not (not bytes)))
    72     (assert (< 0 count))
    73     (void) )
    74 
    75   (define (final ctx result)
    76     (assert (eq? ctx the-ctx))
    77     (assert (not (not result)))
    78     (void) )
    79 
    80   (let (
    81     (mdp (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final)) )
    82     (test-assert (message-digest-primitive? mdp))
    83     (test CONTEXT-SIZE (message-digest-primitive-context-info mdp))
    84     (test DIGEST-LENGTH (message-digest-primitive-digest-length mdp))
    85     (test init (message-digest-primitive-init mdp))
    86     (test update (message-digest-primitive-update mdp))
    87     (test final (message-digest-primitive-final mdp))
    88     (test BLOCK-LENGTH-DEFAULT (message-digest-primitive-block-length mdp))
    89     (test-assert (symbol? (message-digest-primitive-name mdp))) )
    90 
    91   ;;don't bother testing the non-optional arguments again
    92 
    93   (let (
    94     (mdp
    95       (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final 'foo)) )
    96     (test BLOCK-LENGTH-DEFAULT (message-digest-primitive-block-length mdp))
    97     (test 'foo (message-digest-primitive-name mdp)) )
    98 
    99   (let (
    100     (mdp
    101       (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final BLOCK-LENGTH)) )
    102     (test BLOCK-LENGTH (message-digest-primitive-block-length mdp))
    103     (test-assert (symbol? (message-digest-primitive-name mdp))) )
    104 
    105   (let (
    106     (mdp
    107       (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final BLOCK-LENGTH 'foo)) )
    108     (test BLOCK-LENGTH (message-digest-primitive-block-length mdp))
    109     (test 'foo (message-digest-primitive-name mdp)) )
    110 )
    111 
    112 ;These also test the update-string proc
    113 (test-group "Proper Phase Arguments (Def Alloc)"
    114 
    115         (define the-ctx #f)
    116 
    117   (define (init ctx)
    118     ;(printf "  Init Ctx: ~S~%" ctx)
    119     (set! the-ctx ctx)
    120     (assert (pointer? ctx)) )
    121 
    122   (define (update ctx bytes count)
    123         ;(printf "Update Ctx: ~S Bytes: ~S Count: ~S~%" ctx bytes count)
    124     (assert (eq? ctx the-ctx))
    125     (assert (not (not bytes)))
    126     (assert (< 0 count))
    127     (assert (<= count CONTEXT-SIZE))  ; So no mem overflow
    128     (assert (pointer? ctx))
    129     (assert (blob? bytes))
    130     (assert (<= count (blob-size bytes)))
    131     (move-memory! bytes ctx count) )
    132 
    133   (define (final ctx result)
    134     ;(printf " Final Ctx: ~S Result: ~S~%" ctx result)
    135     (assert (eq? ctx the-ctx))
    136     (assert (not (not result)))
    137     (assert (pointer? ctx))
    138     (assert (or (blob? result) (string? result)))
    139     ; So no mem overflow
    140     (assert (<= DIGEST-LENGTH (if (blob? result) (blob-size result) (string-length result))))
    141     (move-memory! ctx result DIGEST-LENGTH) )
    142 
    143   (let (
    144     (mdp (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final)) )
    145     (let (
    146       (md (initialize-message-digest mdp)) )
    147       (test-assert (message-digest? md))
    148       (test-assert (message-digest-update-string md simple-src))
    149       (test simple-res (finalize-message-digest md)) )
    150     (let (
    151       (md (initialize-message-digest mdp))
    152       (blb (make-blob 100)) )
    153       (message-digest-update-string md simple-src)
    154       (test-assert (finalize-message-digest! md blb))
    155       (print "result = " blb) )
    156     (let (
    157       (md (initialize-message-digest mdp))
    158       (str (make-string 100 #\space)) )
    159       (message-digest-update-string md simple-src)
    160       (test-assert (finalize-message-digest! md str))
    161       (print "result = " #\" str #\") )
    162     (let (
    163       (md (initialize-message-digest mdp))
    164       (vec (make-u8vector 100 0)) )
    165       (message-digest-update-string md simple-src)
    166       (test-assert (finalize-message-digest! md vec))
    167       (print "result = " vec) ) )
    168 )
    169 
    170 (test-group "Proper Phase Arguments (Own Alloc)"
    171 
    172         (define the-ctx #f)
    173 
    174   (define (make-context)
    175     (make-blob CONTEXT-SIZE) )
    176 
    177   (define (init ctx)
    178     ;(printf "  Init Ctx: ~S~%" ctx)
    179     (set! the-ctx ctx)
    180     (assert (blob? ctx)) )
    181 
    182   (define (update ctx bytes count)
    183     ;(printf "Update Ctx: ~S Bytes: ~S Count: ~S~%" ctx bytes count) (flush-output)
    184     (assert (eq? ctx the-ctx))
    185     (assert (not (not bytes)))
    186     (assert (< 0 count))
    187     (assert (<= count CONTEXT-SIZE))  ; So no mem overflow
    188     (assert (blob? ctx))
    189     (assert (blob? bytes))
    190     (assert (<= count (blob-size bytes)))
    191     (move-memory! bytes ctx count) )
    192 
    193   (define (final ctx result)
    194     ;(printf " Final Result Size: ~S Ctx: ~S Result: ~S~%" (blob-size result) ctx result) (flush-output)
    195     (assert (eq? ctx the-ctx))
    196     (assert (not (not result)))
    197     (assert (blob? ctx))
    198     (assert (blob? result))
    199     (assert (<= (blob-size result) DIGEST-LENGTH))  ; So no mem overflow
    200     (move-memory! ctx result DIGEST-LENGTH) )
    201 
    202   (let* (
    203     (mdp (make-message-digest-primitive make-context DIGEST-LENGTH init update final))
    204     (md (initialize-message-digest mdp)) )
    205     (test-assert (message-digest? md))
    206     (test-assert (message-digest-update-string md simple-src))
    207     (test simple-res (finalize-message-digest md)) )
    208 )
    209 
    21070(let ()
    21171
     
    22282
    22383  (define (update ctx bytes count)
    224     ;(printf "Update Ctx: ~S Bytes: ~S Count: ~S~%" ctx bytes count) (flush-output)
     84    (printf "Update Ctx: ~S Bytes: ~S Count: ~S~%" ctx bytes count) (flush-output)
    22585    (assert (eq? ctx the-ctx))
    22686    (assert (not (not bytes)))
     
    23191
    23292  (define (final ctx result)
    233     ;(printf " Final Result Size: ~S Ctx: ~S Result: ~S~%" (blob-size result) ctx result) (flush-output)
     93    (printf "Final Result Size: ~S Ctx: ~S Result: ~S~%" (blob-size result) ctx result) (flush-output)
    23494    (assert (eq? ctx the-ctx))
    23595    (assert (not (not result)))
     
    268128  )
    269129
    270   (when (version>=? (chicken-version) "4.6.4")
    271           (test-group "u32-be Source"
    272                         (let (
    273         (md (initialize-message-digest mdp)) )
    274                                 (test-assert (message-digest-update-u32-be md #xA2B2C2D2))
    275                                 (test "a2b2c2d200" (finalize-message-digest md)) )
    276                 ) )
    277 
    278   (when (version>=? (chicken-version) "4.8.1")
    279                 (test-group "u64-be Source"
    280                         (let (
    281         (md (initialize-message-digest mdp)) )
    282                                 (test-assert (message-digest-update-u64-be md #xAB54A98CEB1F0AD2))
    283                                 (test
    284                                   (substring "ab54a98ceb1f0ad2" 0 (fx* 2 (fxmin 8 DIGEST-LENGTH)))
    285                                   (finalize-message-digest md)) )
    286                 ) )
     130  (test-group "u32-be Source"
     131    (let (
     132      (md (initialize-message-digest mdp)) )
     133      (test-assert (message-digest-update-u32-be md #xA2B2C2D2))
     134      (test "a2b2c2d200" (finalize-message-digest md)) )
     135  )
     136
     137  (test-group "u64-be Source"
     138    (let (
     139      (md (initialize-message-digest mdp)) )
     140      (test-assert (message-digest-update-u64-be md #xAB54A98CEB1F0AD2))
     141      (test
     142        (substring "ab54a98ceb1f0ad2" 0 (fx* 2 (fxmin 8 DIGEST-LENGTH)))
     143        (finalize-message-digest md)) )
     144  )
    287145
    288146  (test-group "char-u8 Source"
     
    408266)
    409267
    410 (test-end)
     268;;;
     269
     270(test-end "Message Digest Utils")
    411271
    412272(test-exit)
  • release/5/message-digest-utils/trunk/tests/run.scm

    r35898 r35914  
    11
    2 (define EGG-NAME "message-digest")
     2(define EGG-NAME "message-digest-utils")
    33
    44;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    55
    6 (use files)
     6(import
     7  (only (chicken pathname) make-pathname)
     8  (only (chicken process) system)
     9  (only (chicken process-context) argv)
     10  (only (chicken format) format))
     11
     12(define *args* (argv))
    713
    814;no -disable-interrupts
    9 (define *csc-options* "-inline-global -scrutinize -optimize-leaf-routines -local -inline -specialize -unsafe -no-trace -no-lambda-info -clustering -lfa2")
    10 
    11 (define *args* (argv))
     15(define *csc-options* "-inline-global \
     16  -specialize -optimize-leaf-routines -clustering -lfa2 \
     17  -local -inline \
     18  -no-trace -no-lambda-info \
     19  -unsafe")
    1220
    1321(define (test-name #!optional (eggnam EGG-NAME))
     
    2937(define (run-test #!optional (eggnam EGG-NAME) (cscopts *csc-options*))
    3038  (let ((tstnam (test-name eggnam)))
    31     (print "*** csi ***")
     39    (format #t "*** csi ***~%")
    3240    (system (string-append "csi -s " (make-pathname #f tstnam "scm")))
    3341    (newline)
    34     (print "*** csc (" cscopts ") ***")
     42    (format #t "*** csc ~s ***~%" cscopts)
    3543    (system (string-append "csc" " " cscopts " " (make-pathname #f tstnam "scm")))
    3644    (system (make-pathname (cond-expand (unix "./") (else #f)) tstnam)) ) )
Note: See TracChangeset for help on using the changeset viewer.