Changeset 35339 in project for release/4/message-digest


Ignore:
Timestamp:
03/25/18 07:42:09 (3 years ago)
Author:
Kon Lovett
Message:

add define-types include, add types, reflow

Location:
release/4/message-digest/trunk
Files:
1 added
10 edited

Legend:

Unmodified
Added
Removed

  • release/4/message-digest/trunk/message-digest-bv.scm

    r35044 r35339  
    2121
    2222(import scheme chicken)
    23 
    2423(use
    2524  (only srfi-13 substring/shared)
    … …  
    2827  message-digest-primitive
    2928  message-digest-type
    30   message-digest-support)
     29  message-digest-support
     30  typed-define)
    3131
    32 (declare
    33   (bound-to-procedure ##sys#substring))
     32;;; Support
     33
     34;;
     35
     36(include "message-digest-types")
    3437
    3538;;; Message Digest API
    … …  
    6568            (result-type (message-digest-result-form))
    6669            (start 0) (end (blob-size blb)))
    67   (let ((md (initialize-message-digest mdp)))
     70  (let (
     71    (md (initialize-message-digest mdp)) )
    6872    (message-digest-update-blob md blb start end)
    6973    (finalize-message-digest md result-type) ) )
    … …  
    7377            (result-type (message-digest-result-form))
    7478            (start 0) (end (string-length str)))
    75   (let ((md (initialize-message-digest mdp)))
     79  (let (
     80    (md (initialize-message-digest mdp)) )
    7681    (message-digest-update-string md str start end)
    7782    (finalize-message-digest md result-type) ) )
    … …  
    8085            #!optional
    8186            (start 0) (end (blob-size blb)))
    82   (let ((md (initialize-message-digest mdp)))
     87  (let (
     88    (md (initialize-message-digest mdp)) )
    8389    (message-digest-update-blob md blb start end)
    8490    (finalize-message-digest! md result-buffer) ) )
    … …  
    8793            #!optional
    8894            (start 0) (end (string-length str)))
    89   (let ((md (initialize-message-digest mdp)))
     95  (let (
     96    (md (initialize-message-digest mdp)) )
    9097    (message-digest-update-string md str start end)
    9198    (finalize-message-digest! md result-buffer) ) )
    … …  
    94101
    95102(define (check-blob/slice loc blb start end)
    96   (check-blob loc blb)
    97103  (check-fixnum-range loc start end)
    98   (blob/slice blb start end) )
     104  (blob/slice (check-blob loc blb) start end) )
    99105
    100106(define (check-string/slice loc str start end)
    101   (check-string loc str)
    102107  (check-fixnum-range loc start end)
    103   (string/slice str start end) )
     108  (string/slice (check-string loc str) start end) )
    104109
    105110(define (check-fixnum-range loc start end)

  • release/4/message-digest/trunk/message-digest-chunk.scm

    r35044 r35339  
    2424
    2525(import scheme chicken)
    26 
    2726(use
    2827  (only posix file-size)
    … …  
    3029    u8vector->blob/shared subu8vector
    3130    read-u8vector! make-u8vector)
    32   miscmacros)
     31  miscmacros
     32  fx-utils
     33  typed-define)
     34
     35;;; Support
     36
     37;;
     38
     39(include "message-digest-types")
    3340
    3441;;; Update Phase Helpers
    3542
    36 ;;
    37 
    38 (define (positive-fixnum? obj)
    39   (and (fixnum? obj) (positive? obj)) )
    40 
    41 ;;
    42 
    4343(define (default-chunk-port-read-maker in #!optional (size (message-digest-chunk-size)))
    44   (let ((u8buf (make-u8vector size)))
     44  (let (
     45    (u8buf (make-u8vector size)) )
    4546    (lambda ()
    46       (let ((len (read-u8vector! size u8buf in)))
     47      (let (
     48        (len (read-u8vector! size u8buf in)) )
    4749        (and
    4850          (positive? len)
    49           (let ((u8buf (if (fx= len size) u8buf (subu8vector u8buf 0 len))))
     51          (let (
     52            (u8buf
     53              (if (fx= len size)
     54                u8buf
     55                (subu8vector u8buf 0 len))) )
    5056            (u8vector->blob/shared u8buf) ) ) ) ) ) )
    5157
    … …  
    6167    (lambda ()
    6268      #f )
    63     (let-values (((buffer cleanup)
    64                   (mapped-buffer 'default-chunk-fileno-read-maker fd size)))
    65       (let ((chunk (make-message-digest-raw-chunk buffer size 0)))
     69    (let-values (
     70      ((buffer cleanup)
     71        (mapped-buffer 'default-chunk-fileno-read-maker fd size)) )
     72      (let (
     73        (chunk (make-message-digest-raw-chunk buffer size 0)) )
    6674        (lambda ()
    6775          (if buffer
    … …  
    7482
    7583(cond-expand
     84
    7685  ((and windows (not cygwin))
     86
    7787    (import (only lolevel allocate free))
    7888    (require-library lolevel)
     89
    7990    (begin
     91
    8092      (define read-into-buffer
    8193        (foreign-lambda* bool ((int fd) (c-pointer buffer) (integer size))
    8294          "C_return(read(fd, buffer, size) == size);") )
     95
    8396      (define (mapped-buffer loc fd size)
    84         (let* ((buffer (allocate size))
    85                (finalize (cut free buffer)) )
     97        (let* (
     98          (buffer (allocate size))
     99          (finalize (cut free buffer)) )
    86100          (unless (read-into-buffer fd buffer size)
    87101            (finalize)
    88102            (error loc "cannot read file") )
    89103          (values buffer finalize) ) ) ) )
     104
    90105  (else
     106
    91107    (import
    92108      (only posix
    … …  
    96112        prot/read))
    97113    (require-library posix)
     114
    98115    (define (mapped-buffer loc fd size)
    99       (let* ((mmap (map-file-to-memory #f size prot/read map/shared fd))
    100              (ptr (memory-mapped-file-pointer mmap))
    101              (finalize (cut unmap-file-from-memory mmap)) )
     116      (let* (
     117        (mmap (map-file-to-memory #f size prot/read map/shared fd))
     118        (ptr (memory-mapped-file-pointer mmap))
     119        (finalize (cut unmap-file-from-memory mmap)) )
    102120        (values ptr finalize) ) ) ) )
    103121
    … …  
    113131  (lambda (x)
    114132    (cond
    115       ((positive-fixnum? x)   x )
    116       ((not x)                DEFAULT-CHUNK-SIZE )
     133      ((fxpositive? x)  x)
     134      ((not x)          DEFAULT-CHUNK-SIZE)
    117135      (else
    118136        (warning 'message-digest-chunk-size "invalid positive-fixnum" x)
    … …  
    124142  (lambda (x)
    125143    (cond
    126       ((procedure? x)   x )
    127       ((not x)          default-chunk-port-read-maker )
     144      ((procedure? x)   x)
     145      ((not x)          default-chunk-port-read-maker)
    128146      (else
    129147        (warning 'message-digest-chunk-port-read-maker "invalid procedure" x)
    … …  
    137155  (lambda (x)
    138156    (cond
    139       ((procedure? x)   x )
    140       ((not x)          default-chunk-fileno-read-maker )
     157      ((procedure? x)   x)
     158      ((not x)          default-chunk-fileno-read-maker)
    141159      (else
    142160        (warning 'message-digest-chunk-fileno-read-maker "invalid procedure" x)

  • release/4/message-digest/trunk/message-digest-int.scm

    r35338 r35339  
    2626
    2727(import scheme chicken)
    28 
    2928(use
    3029  (only type-checks
    … …  
    4140;;
    4241
    43 (define-type message-digest (struct message-digest))
     42(include "message-digest-types")
    4443
    4544;;

  • release/4/message-digest/trunk/message-digest-item.scm

    r35338 r35339  
    2727;;;
    2828
    29 (define-type pathname string)
     29;;
    3030
    31 (define-type message-digest-primitive (struct message-digest-primitive))
    32 
    33 (define-type message-digest-buffer (or string blob u8vector))
    34 
    35 (define-type message-digest-result-form (or string blob u8vector))
     31(include "message-digest-types")
    3632
    3733;;; Single Source API

  • release/4/message-digest/trunk/message-digest-old.scm

    r35044 r35339  
    1919
    2020(import scheme chicken)
    21 
    2221(use
    2322  (only string-hexadecimal string->hex)
    … …  
    3130;;; Old API
    3231
    33 ;;
     32;;DEPRECATED
    3433
    35 ;DEPRECATED
     34(: message-digest-primitive-apply deprecated)
    3635(define (message-digest-primitive-apply mdp src . args)
    3736  (message-digest-object mdp src 'string) )
    3837
    39 ;;
    40 
    41 ;DEPRECATED
     38(: make-binary-message-digest deprecated)
    4239(define (make-binary-message-digest src ctx-info digest-len init update final
    43                                     #!optional (name 'make-binary-message-digest))
     40            #!optional (name 'make-binary-message-digest))
    4441  (message-digest-object
    4542    (make-message-digest-primitive ctx-info digest-len init update final name)
    … …  
    4744    'string) )
    4845
    49 ;;
    50 
    51 ;DEPRECATED
     46(: make-message-digest deprecated)
    5247(define (make-message-digest src ctx-info digest-len init update final
    53                              #!optional (name 'make-message-digest))
     48            #!optional (name 'make-message-digest))
    5449  (message-digest-object
    5550    (make-message-digest-primitive ctx-info digest-len init update final name)

  • release/4/message-digest/trunk/message-digest-port.scm

    r35044 r35339  
    1818
    1919(import scheme chicken)
    20 
    2120(use
    2221  (only data-structures ->string)
    … …  
    2726  message-digest-primitive
    2827  message-digest-type
    29   message-digest-bv)
     28  message-digest-bv
     29  fx-utils
     30  typed-define)
    3031
    31 ;;; Message Digest Output Port API
     32(declare
     33  (bound-to-procedure ##sys#slot ##sys#setslot))
    3234
    33 ;
    34 (define (%port-type p) (##sys#slot p 7))
    35 (define (%port-type-set! p t) (##sys#setslot p 7 t))
     35;;; Support
    3636
    37 ;
    38 (define (%port-name p) (##sys#slot p 3))
    39 (define (%port-name-set! p s) (##sys#setslot p 3 s))
     37;;
    4038
    41 ;
     39(include "message-digest-types")
     40
     41;;
     42
     43(define (%port-type p)
     44  (##sys#slot p 7) )
     45
     46(define (%port-type-set! p t)
     47  (##sys#setslot p 7 t) )
     48
     49(define (%port-name p)
     50  (##sys#slot p 3) )
     51
     52(define (%port-name-set! p s)
     53  (##sys#setslot p 3 s) )
     54
    4255(define (check-open-port loc obj #!optional argnam)
    4356  (if (port-closed? obj)
    … …  
    4558    obj ) )
    4659
    47 ;
    4860(define (check-open-digest-output-port loc obj #!optional argnam)
    49   (let ((pt (%port-type (check-open-port loc (check-output-port loc obj argnam) argnam))))
     61  (let (
     62    (pt (%port-type (check-open-port loc (check-output-port loc obj argnam) argnam))) )
    5063    (unless (eq? 'digest pt)
    5164      (signal-type-error loc (make-error-type-message 'digest-output-port) obj argnam) ) )
    … …  
    5467; Synthesize a port-name from a primitive-name
    5568(define (make-digest-port-name mdp)
    56   (let* ((nam (->string (or (message-digest-primitive-name mdp) 'digest)) )
    57          (remlen (string-suffix-length-ci nam "-primitive") ) )
     69  (let* (
     70    (nam (->string (or (message-digest-primitive-name mdp) 'md)))
     71    ;strip trailing (why ?)
     72    (remlen (string-suffix-length-ci nam "-primitive"))
     73    (remlen (if (fxpositive? remlen) remlen (string-suffix-length-ci nam "p"))) )
    5874    (string-append
    5975      "("
    60         (if (positive? remlen)
     76        (if (fxpositive? remlen)
    6177          (substring nam 0 (fx- (string-length nam) remlen))
    6278          nam )
    6379      ")") ) )
    6480
     81;;; Message Digest Output Port API
     82
    6583;; Returns a digest-output-port for the MDP
    6684
    6785(define (open-output-digest mdp)
    68   (let* ((md (initialize-message-digest mdp) )
    69          (writer
    70           (lambda (obj)
    71             ;it will only ever be a string for now
    72             (if (string? obj)
    73               (message-digest-update-string md obj)
    74               (message-digest-update-blob md obj))) )
    75          (port (make-output-port writer void) ) ) ;use default close behavior
     86  (let* (
     87    (md
     88      (initialize-message-digest mdp))
     89    (writer
     90      (lambda (obj)
     91        ;it will only ever be a string for now
     92        (if (string? obj)
     93          (message-digest-update-string md obj)
     94          (message-digest-update-blob md obj))))
     95      ;use default close behavior
     96      (port
     97        (make-output-port writer void)) )
    7698    (##sys#set-port-data! port md)
    7799    (%port-type-set! port 'digest)
    … …  
    92114
    93115(define (*close-output-digest loc digest-port result-type)
    94   (let ((res
    95           (finalize-message-digest
    96             (##sys#port-data (check-open-digest-output-port loc digest-port 'digest-port))
    97             result-type)))
     116  (let (
     117    (res
     118      (finalize-message-digest
     119        (##sys#port-data (check-open-digest-output-port loc digest-port 'digest-port))
     120        result-type)) )
    98121    (close-output-port digest-port)
    99122    res ) )
    … …  
    108131
    109132(define (call-with-output-digest mdp proc #!optional (result-type (message-digest-result-form)))
    110   (let ((port (open-output-digest mdp)))
     133  (let (
     134    (port (open-output-digest mdp)) )
    111135    (proc port)
    112136    (*close-output-digest 'call-with-output-digest port result-type) ) )

  • release/4/message-digest/trunk/message-digest-srfi-4.scm

    r35044 r35339  
    2121
    2222(import scheme chicken)
    23 
    2423(use
    2524  data-structures
    … …  
    3130  message-digest-type
    3231  message-digest-support
    33   message-digest-bv)
     32  message-digest-bv
     33  typed-define)
    3434
    3535;;; Support
    … …  
    3737;;
    3838
    39 (define (get-bytevector-object loc obj)
     39(include "message-digest-types")
     40
     41;;
     42
     43(define: (get-bytevector-object (loc symbol) (obj *)) -> blob
    4044        (cond
    4145                ((string? obj)
    … …  
    4347                ((blob? obj)
    4448                  obj )
    45                 ((packed-vector->blob/shared obj)
    46                   )
     49                ((packed-vector->blob/shared obj) )
    4750                (else
    4851        (error-argument-type loc obj "string, blob, or SRFI 4 vector" obj) ) ) )
    … …  
    5255;;
    5356
    54 (define (message-digest-update-u8vector md u8vec
    55             #!optional
    56             (start 0) (end (u8vector-length u8vec)))
    57   (message-digest-update-blob md
    58     (u8vector->blob/shared (u8vector/slice u8vec start end))) )
     57(define: (message-digest-update-u8vector (md message-digest) (u8vec u8vector) . (opts list)) -> void
     58  (let-optionals* opts (
     59    (start 0)
     60    (end (u8vector-length u8vec)) )
     61    (message-digest-update-blob md
     62      (u8vector->blob/shared (u8vector/slice u8vec start end))) ) )
    5963
    6064;;; Single Source API
    6165
    62 (define (message-digest-u8vector mdp u8vec
    63             #!optional
    64             (result-type (message-digest-result-form))
    65             (start 0) (end (u8vector-length u8vec)))
    66   (let ((md (initialize-message-digest mdp)))
    67     (message-digest-update-u8vector md u8vec start end)
    68     (finalize-message-digest md result-type) ) )
     66(define: (message-digest-u8vector (mdp message-digest-primitive) (u8vec u8vector) . (opts list)) -> message-digest-result-form
     67  (let-optionals* opts (
     68    (result-type (message-digest-result-form))
     69    (start 0)
     70    (end (u8vector-length u8vec)) )
     71    (let ((md (initialize-message-digest mdp)))
     72      (message-digest-update-u8vector md u8vec start end)
     73      (finalize-message-digest md result-type) ) ) )
    6974
    70 (define (message-digest-u8vector! mdp u8vec buffer
    71             #!optional
    72             (start 0) (end (u8vector-length u8vec)))
    73   (let ((md (initialize-message-digest mdp)))
    74     (message-digest-update-u8vector md u8vec start end)
    75     (finalize-message-digest! md buffer) ) )
     75(define: (message-digest-u8vector! (mdp message-digest-primitive) (u8vec u8vector) (buffer message-digest-buffer) . (opts list)) -> message-digest-result-form
     76  (let-optionals* opts (
     77    (start 0)
     78    (end (u8vector-length u8vec)) )
     79    (let ((md (initialize-message-digest mdp)))
     80      (message-digest-update-u8vector md u8vec start end)
     81      (finalize-message-digest! md buffer) ) ) )
    7682
    77 ;;;
     83;;DEPRECATED
    7884
    79 ;;
    80 
    81 ;DEPRECATED
     85(: message-digest-update-subu8vector deprecated)
    8286(define (message-digest-update-subu8vector md u8vec start end)
    8387  (message-digest-update-blob md (u8vector->blob/shared (subu8vector u8vec start end))) )
    8488
    85 ;;
    86 
    87 ;DEPRECATED
     89(: message-digest-update-packed-vector deprecated)
    8890(define (message-digest-update-packed-vector md pkdvec)
    8991  (let ((blb (packed-vector->blob/shared pkdvec)))
    … …  
    9294      (error-argument-type 'message-digest-update-packed-vector pkdvec "SRFI 4 vector") ) ) )
    9395
    94 ;;
    95 
    96 ;DEPRECATED
     96(: message-digest-update-bytevector deprecated)
    9797(define (message-digest-update-bytevector md bv #!optional (len (number-of-bytes bv)))
    9898  (check-message-digest 'message-digest-update-bytevector md)

  • release/4/message-digest/trunk/message-digest-support.scm

    r35338 r35339  
    2424
    2525(import scheme chicken)
    26 
    2726(use
    2827  (only lolevel number-of-bytes)
    … …  
    5857;;
    5958
    60 (define-type srfi4vector (or u8vector s8vector u16vector s16vector u32vector s32vector f32vector f64vector))
    61 
    62 (define-type message-digest (struct message-digest))
     59(include "message-digest-types")
    6360
    6461;;

  • release/4/message-digest/trunk/message-digest-type.scm

    r35338 r35339  
    4242;;; Support
    4343
     44;;
     45
     46(include "message-digest-types")
     47
     48;;
     49
    4450(define-constant MINIMUM-BUFFER-SIZE 8)
    4551
    … …  
    4753(define-constant DEFAULT-RESULT-TYPE 'hex-string)
    4854
     55;-> *
    4956(define (error-result-form loc obj)
    5057  (error-argument-type loc obj "symbol in {string hex blob u8vector}" 'result-form) )
    … …  
    5259;perform any conversion necessary for final result representation
    5360;assumes blob 'res' may not be of result size
     61
     62(define: (get-result-form (loc symbol) (res blob) (rt symbol)) -> message-digest-result-form
     63  (case (canonical-result-name rt)
     64    ((blob)           res )
     65    ((byte-string)    (blob->string res) )
     66    ((hex-string)     (blob->hex res) )
     67    ((u8vector)       (blob->u8vector/shared res) )
     68    (else
     69      (error-result-form loc rt) ) ) )
     70
    5471#;
    55 (define (get-result-form loc res rt len)
     72(define: (get-result-form (loc symbol) (res blob) (rt symbol)) -> message-digest-result-form
    5673  (case rt
    5774    ((blob)
    … …  
    7188      (error-result-form loc rt) ) ) )
    7289
    73 ;perform any conversion necessary for final result representation
    74 ;assumes blob 'res' is of result size
    75 (define (get-result-form loc res rt)
    76   (case (canonical-result-name rt)
    77     ((blob)           res )
    78     ((byte-string)    (blob->string res) )
    79     ((hex-string)     (blob->hex res) )
    80     ((u8vector)       (blob->u8vector/shared res) )
    81     (else
    82       (error-result-form loc rt) ) ) )
    83 
    84 (define (canonical-result-name x)
     90(define: (canonical-result-name (x symbol)) -> (or boolean symbol)
    8591  (case x
    8692    ((blob)                       'blob )
    … …  
    9197      #f ) ) )
    9298
    93 (define (check-result-type loc mdp obj)
     99(define: (check-result-type (loc symbol) (mdp message-digest-primitive) (obj message-digest-result-form)) -> message-digest-result-form
    94100  (let (
    95101    (siz
    … …  
    113119;;
    114120
     121(: message-digest-result-form (#!optional symbol -> symbol))
     122;
    115123(define-parameter message-digest-result-form #;DEFAULT-RESULT-TYPE 'hex-string
    116124  (lambda (x)
    … …  
    123131
    124132;;
    125 
    126 (define-type srfi4vector (or u8vector s8vector u16vector s16vector u32vector s32vector f32vector f64vector))
    127 
    128 ;(define-type message-digest-buffer (or string blob srfi4vector procedure input-port pointer))
    129 (define-type message-digest-buffer (or string blob u8vector))
    130 
    131 (define-type message-digest-result-form (or string blob u8vector))
    132 
    133 (define-type message-digest-context (or fixnum procedure))
    134 
    135 (define-type message-digest-primitive (struct message-digest-primitive))
    136133
    137134(define:-record-type message-digest

  • release/4/message-digest/trunk/message-digest.meta

    r35338 r35339  
    1717 (test-depends test)
    1818 (files
     19        "message-digest.meta" "message-digest.setup" "message-digest.release-info"
     20        "message-digest-types.scm"
    1921        "message-digest.scm"
    2022        "message-digest-basic.scm"
    … …  
    2931        "message-digest-item.scm"
    3032        "message-digest-srfi-4.scm"
    31         "message-digest.meta" "message-digest.setup" "message-digest.release-info"
    32         "tests/run.scm" "tests/alpha.txt"
     33        "tests/run.scm" "tests/message-digest-test.scm" "tests/alpha.txt"
    3334        ;DEPRECATED
    3435        "message-digest-parameters.scm") )
Note: See TracChangeset for help on using the changeset viewer.