Changeset 35827 in project


Ignore:
Timestamp:
07/09/18 19:09:54 (10 days ago)
Author:
kon
Message:

C5 fixes

Location:
release/5/message-digest-primitive/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/5/message-digest-primitive/trunk/message-digest-primitive.egg

    r35826 r35827  
    1 ;;;; message-digest.meta  -*- Hen -*-
     1;;;; message-digest-primitive.egg  -*- Scheme -*-
     2;;;; Kon Lovett, Jul '18
    23
    3 ((egg "message-digest.egg")
     4((synopsis "Message Digest Primitive")
     5 (version "4.0.0")
    46 (category crypt)
    57 (author "[[kon lovett]]")
    68 (license "BSD")
    7  (doc-from-wiki)
    8  (synopsis "Message Digest Support")
    9  (depends
    10         (setup-helper "1.5.2")
    11         (miscmacros "2.91")
    12         (check-errors "2.1.0")
    13         (blob-utils "1.0.0")
    14         (string-utils "1.2.1")
    15         (dsssl-utils "2.2.2"))
    16  (test-depends test)
    17 
    18 (define *md-csc-optn* '(
    19   -optimize-level 3 -debug-level 1
    20   -no-procedure-checks-for-toplevel-bindings))
    21 
    22 (setup-shared+static-extension-module 'message-digest-primitive (extension-version "3.9.0")
    23   #:inline? #t
    24         #:types? #t
    25   #:compile-options *md-csc-optn*)
     9 (dependencies
     10        (check-errors "3.1.0"))
     11 (test-dependencies test)
     12 (components
     13  (extension message-digest-primitive
     14    #;(inline-file)
     15    (types-file)
     16    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks-for-toplevel-bindings") ) ) )
  • release/5/message-digest-primitive/trunk/message-digest-primitive.scm

    r35826 r35827  
    1 ;;;; message-digest-primitive.scm
     1;;;; message-digest-primitive.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
     
    1415
    1516(;export
     17  ;
     18  make-message-digest-primitive-context
    1619  ; Algorithm API
    1720  make-message-digest-primitive
     
    2629  message-digest-primitive-raw-update)
    2730
    28 (import scheme chicken)
    29 (use
    30   (only type-checks
    31     define-check+error-type
    32     check-positive-fixnum
    33     check-procedure)
    34   (only type-errors
    35     error-argument-type)
    36   typed-define)
     31(import scheme
     32  (chicken base)
     33  (chicken fixnum)
     34  (chicken gc)
     35  (chicken type)
     36  (only (chicken memory) allocate free)
     37  (only type-checks define-check+error-type check-positive-fixnum check-procedure)
     38  (only type-errors error-argument-type))
    3739
    3840;;; Support
    39 
    40 (define-type message-digest-primitive (struct message-digest-primitive))
    4141
    4242;;
     
    4545  (and (fixnum? obj) (positive? obj)) )
    4646
    47 (define (primitive-ctx-info? obj)
     47(define (primitive-context-info? obj)
    4848  (or (procedure? obj) (positive-fixnum? obj)) )
    4949
     
    5555;;
    5656
     57(define-type message-digest-primitive-name (or symbol string))
     58
     59(define-type message-digest-primitive-context-info (or fixnum procedure))
     60
     61(define-type message-digest-primitive-raw-update (or boolean procedure))
     62
     63(define-type message-digest-primitive (struct message-digest-primitive))
     64;assignment of value of type `(procedure message-digest-primitive#*make-message-digest-primitive (* * * * * * * *) (struct message-digest-primitive#message-digest-primitive))' to toplevel variable `message-digest-primitive#*make-message-digest-primitive' does not match declared type `(procedure message-digest-primitive#*make-message-digest-primitive ((or fixnum procedure) fixnum procedure procedure procedure fixnum (or symbol string) (or boolean procedure)) (struct message-digest-primitive))'
     65(: *make-message-digest-primitive (message-digest-primitive-context-info fixnum procedure procedure procedure fixnum message-digest-primitive-name message-digest-primitive-raw-update --> message-digest-primitive))
     66(: message-digest-primitive? (* -> boolean : message-digest-primitive))
     67(: message-digest-primitive-context-info (message-digest-primitive --> message-digest-primitive-context-info))
     68(: message-digest-primitive-digest-length (message-digest-primitive --> fixnum))
     69(: message-digest-primitive-init (message-digest-primitive --> procedure))
     70(: message-digest-primitive-update (message-digest-primitive --> procedure))
     71(: message-digest-primitive-final (message-digest-primitive --> procedure))
     72(: message-digest-primitive-block-length (message-digest-primitive --> fixnum))
     73(: message-digest-primitive-name (message-digest-primitive --> message-digest-primitive-name))
     74(: message-digest-primitive-raw-update (message-digest-primitive --> message-digest-primitive-raw-update))
     75;
     76(define-record-type message-digest-primitive
     77  (*make-message-digest-primitive ctxi digest-len init update final block-len name raw-update)
     78  message-digest-primitive?
     79  (ctxi message-digest-primitive-context-info)
     80  (digest-len message-digest-primitive-digest-length)
     81  (init message-digest-primitive-init)
     82  (update message-digest-primitive-update)
     83  (final message-digest-primitive-final)
     84  (block-len message-digest-primitive-block-length)
     85  (name message-digest-primitive-name)
     86  (raw-update message-digest-primitive-raw-update) )
     87
     88(define-check+error-type message-digest-primitive)
     89
     90;;
     91
    5792(define-inline (check-message-digest-arguments loc ctx-info digest-len init update final block-len name raw-update)
    58   (unless (primitive-ctx-info? ctx-info)
     93  (unless (primitive-context-info? ctx-info)
    5994    (error-argument-type loc ctx-info "positive-fixnum or procedure" 'context-info) )
    6095  (check-positive-fixnum loc digest-len 'digest-length)
     
    70105;;
    71106
    72 (define:-record-type message-digest-primitive
    73   (*make-message-digest-primitive ctxi digest-len init update final block-len name raw-update)
    74   message-digest-primitive?
    75   (ctxi (or fixnum procedure) message-digest-primitive-context-info)
    76   (digest-len fixnum message-digest-primitive-digest-length)
    77   (init procedure message-digest-primitive-init)
    78   (update procedure message-digest-primitive-update)
    79   (final procedure message-digest-primitive-final)
    80   (block-len fixnum message-digest-primitive-block-length)
    81   (name (or symbol string) message-digest-primitive-name)
    82   (raw-update procedure message-digest-primitive-raw-update) )
     107;assignment of value of type `(procedure message-digest-primitive#make-message-digest-primitive (* * * * * #!rest) (struct message-digest-primitive#message-digest-primitive))' to toplevel variable `message-digest-primitive#make-message-digest-primitive' does not match declared type `(procedure message-digest-primitive#make-message-digest-primitive ((or fixnum procedure) fixnum procedure procedure procedure #!rest *) (struct message-digest-primitive))'
     108(: make-message-digest-primitive (message-digest-primitive-context-info fixnum procedure procedure procedure #!rest -> message-digest-primitive))
     109;
     110(define (make-message-digest-primitive ctx-info digest-len init update final
     111            #!key (block-length 4) (name (gensym 'mdp)) (raw-update #f))
     112  (check-message-digest-arguments 'make-message-digest-primitive
     113    ctx-info digest-len init update final
     114    block-length name raw-update)
     115  (*make-message-digest-primitive
     116    ctx-info digest-len init update final
     117    block-length name raw-update) )
    83118
    84 (define-check+error-type message-digest-primitive)
     119;;
    85120
    86 (define: (make-message-digest-primitive
    87             (ctx-info (or fixnum procedure)) (digest-len fixnum)
    88             (init procedure) (update procedure) (final procedure)
    89             . (opts (list-of *))) -> message-digest-primitive
    90   ;
    91   (define (pull-arg args pred defprc)
    92     (if (and (not (null? args)) (pred (car args)))
    93       (values (car args) (cdr args))
    94       (values (defprc) args) ) )
    95   ;
    96   (let*-values (
    97     ((block-len opts)
    98       (pull-arg opts number? (lambda () 4)))
    99     ((name opts)
    100       (pull-arg opts (lambda (x) (not (procedure? x))) (lambda () (gensym 'mdp))))
    101     ((raw-update opts)
    102       (pull-arg opts procedure? (lambda () #f))) )
    103     (check-message-digest-arguments 'make-message-digest-primitive
    104       ctx-info digest-len init update final block-len name raw-update)
    105     (*make-message-digest-primitive
    106       ctx-info digest-len
    107       init update final
    108       block-len
    109       name
    110       raw-update) ) )
     121(: make-message-digest-primitive-context (message-digest-primitive-context-info -> *))
     122;
     123(define (make-message-digest-primitive-context ctx-info)
     124  (if (procedure? ctx-info)
     125    (ctx-info)
     126    (set-finalizer! (allocate ctx-info) free) ) )
    111127
    112128) ;module message-digest-primitive
  • release/5/message-digest-primitive/trunk/tests/message-digest-primitive-test.scm

    r35826 r35827  
    1 ;;;; message-digest-test.scm
     1;;;; message-digest-primitive-test.scm  -*- Scheme -*-
     2;;;; Kon Lovett, Jul '18
    23
    3 ;; Issues
    4 ;;
    5 ;; - Needs many more tests, especially the entire input-port & procedure source stuff.
     4(import test)
    65
    7 (use test)
    8 (use message-digest message-digest-port)
    9 (use files lolevel srfi-4)
    10 (use setup-api)
     6(test-begin "Message Digest Primitive")
     7
     8;;;
     9
     10(import (chicken blob) message-digest-primitive)
    1111
    1212;;
     
    4141
    4242;;
    43 
    44 (test-begin "Message Digest")
    45 
    46 (test 'hex-string (message-digest-result-form 'hex))
    47 
    48 ;Tests defaults
    49 (test-group "Chunk Read (port)"
    50   (let (
    51     (siz (message-digest-chunk-size))
    52     (in (open-input-file SHORT-TEST-FILE-NAME)) )
    53     (let* (
    54       (rdr ((message-digest-chunk-port-read-maker) in))
    55       (res (rdr)) )
    56       (test-assert "First chunk type" (blob? res))
    57       (test "First chunk size" SHORT-TEST-FILE-LENGTH (blob-size res))
    58       (test-assert "No more chunk" (not (rdr))) )
    59     (close-input-port in) )
    60 )
    6143
    6244(test-group "Make Primitive"
     
    9375  (let (
    9476    (mdp
    95       (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final 'foo)) )
     77      (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final #:name 'foo)) )
    9678    (test BLOCK-LENGTH-DEFAULT (message-digest-primitive-block-length mdp))
    9779    (test 'foo (message-digest-primitive-name mdp)) )
     
    9981  (let (
    10082    (mdp
    101       (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final BLOCK-LENGTH)) )
     83      (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final #:block-length BLOCK-LENGTH)) )
    10284    (test BLOCK-LENGTH (message-digest-primitive-block-length mdp))
    10385    (test-assert (symbol? (message-digest-primitive-name mdp))) )
     
    10587  (let (
    10688    (mdp
    107       (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final BLOCK-LENGTH 'foo)) )
     89      (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final #:block-length BLOCK-LENGTH #:name 'foo)) )
    10890    (test BLOCK-LENGTH (message-digest-primitive-block-length mdp))
    10991    (test 'foo (message-digest-primitive-name mdp)) )
     
    141123    (move-memory! ctx result DIGEST-LENGTH) )
    142124
    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) ) )
     125  (let* (
     126    (mdp (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final))
     127    (ctx (make-message-digest-primitive-context (message-digest-primitive-context-info mdp))) )
     128    (test-assert "allocated context" ctx)
     129    ;FIXME Add Life-Cycle Tests
     130    )
    168131)
    169132
     
    202165  (let* (
    203166    (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)) )
     167    (ctx (make-message-digest-primitive-context (message-digest-primitive-context-info mdp))) )
     168    (test-assert "allocated context" ctx)
     169    ;FIXME Add Life-Cycle Tests
     170    )
    208171)
    209172
    210 (let ()
     173;;;
    211174
    212         (define the-ctx #f)
    213 
    214   (define (make-context)
    215     ;Init to 0 necessary since DIGEST-LENGTH is possibly > than
    216     ;the input size! (Actually just needs to be a known value,
    217     ;`(integer->char #xff)' would work as well.)
    218     (string->blob (make-string CONTEXT-SIZE #\nul)) )
    219 
    220   (define (init ctx)
    221     (set! the-ctx ctx) )
    222 
    223   (define (update ctx bytes count)
    224     ;(printf "Update Ctx: ~S Bytes: ~S Count: ~S~%" ctx bytes count) (flush-output)
    225     (assert (eq? ctx the-ctx))
    226     (assert (not (not bytes)))
    227     (assert (< 0 count))
    228     (assert (<= count CONTEXT-SIZE))  ; So no mem overflow
    229     (assert (blob? ctx))
    230     (move-memory! bytes ctx count) )
    231 
    232   (define (final ctx result)
    233     ;(printf " Final Result Size: ~S Ctx: ~S Result: ~S~%" (blob-size result) ctx result) (flush-output)
    234     (assert (eq? ctx the-ctx))
    235     (assert (not (not result)))
    236     (assert (blob? ctx))
    237     (assert (<= (blob-size result) DIGEST-LENGTH))  ; So no mem overflow
    238     (move-memory! ctx result DIGEST-LENGTH) )
    239 
    240   (define mdp (make-message-digest-primitive make-context DIGEST-LENGTH init update final))
    241 
    242   (test-group "u8vector Source"
    243     (let (
    244       (md (initialize-message-digest mdp)) )
    245       (test-assert (message-digest-update-u8vector md (u8vector 1 2 3 4 5)))
    246       (test "0102030405" (finalize-message-digest md)) )
    247   )
    248 
    249   (test-group "u8 Source"
    250     (let (
    251       (md (initialize-message-digest mdp)) )
    252       (test-assert (message-digest-update-u8 md #xA2))
    253       (test "a200000000" (finalize-message-digest md)) )
    254   )
    255 
    256   (test-group "u16-le Source"
    257     (let (
    258       (md (initialize-message-digest mdp)) )
    259       (test-assert (message-digest-update-u16-le md #xA2B2))
    260       (test "b2a2000000" (finalize-message-digest md)) )
    261   )
    262 
    263   (test-group "u32-be Source"
    264     (let (
    265       (md (initialize-message-digest mdp)) )
    266       (test-assert (message-digest-update-u32-be md 1073741823))
    267       (test "3fffffff00" (finalize-message-digest md)) )
    268   )
    269 
    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                 ) )
    287 
    288   (test-group "char-u8 Source"
    289     (let (
    290       (md (initialize-message-digest mdp)) )
    291       (test-assert (message-digest-update-char-u8 md #\space))
    292       (test "2000000000" (finalize-message-digest md)) )
    293   )
    294 
    295   (test-group "char-be Source"
    296     (let (
    297       (md (initialize-message-digest mdp)) )
    298       (test-assert (message-digest-update-char-be md #\u0003BB))
    299       (test "000003bb00" (finalize-message-digest md)) )
    300   )
    301 
    302   (test-group "char-le Source"
    303     (let (
    304       (md (initialize-message-digest mdp)) )
    305       (test-assert (message-digest-update-char-le md #\u0003BB))
    306       (test "bb03000000" (finalize-message-digest md)) )
    307   )
    308 
    309   (test-group "Procedure Source"
    310     (let (
    311       (md (initialize-message-digest mdp)) )
    312       (test-assert (message-digest-update-procedure md just-once))
    313       (test simple-res (finalize-message-digest md)) )
    314   )
    315 
    316   (test-group "Port"
    317     (let (
    318       (port (open-output-digest mdp)) )
    319       (test-assert (output-port? port))
    320       (display simple-src port) ;cannot be readable!
    321       (test simple-res (get-output-digest port))
    322       (test-assert (port-closed? port)) )
    323   )
    324 )
    325 
    326 #; ;REMOVED
    327 (begin
    328         (use message-digest-old)
    329 
    330         (define the-ctx #f)
    331 
    332   (define (make-context)
    333     (string->blob (make-string CONTEXT-SIZE #\nul)) )
    334 
    335   (define (init ctx)
    336     (set! the-ctx ctx) )
    337 
    338   (define (update ctx bytes count)
    339     (assert (eq? ctx the-ctx))
    340     (assert (not (not bytes)))
    341     (assert (< 0 count))
    342     (assert (<= count CONTEXT-SIZE))  ; So no mem overflow
    343     (assert (blob? ctx))
    344     (move-memory! bytes ctx count) )
    345 
    346   (define (final ctx result)
    347     (assert (eq? ctx the-ctx))
    348     (assert (not (not result)))
    349     (assert (blob? ctx))
    350     (assert (<= (blob-size result)  DIGEST-LENGTH))  ; So no mem overflow
    351     (move-memory! ctx result DIGEST-LENGTH) )
    352 
    353   (test-group "Primitive Apply (DEPRECATED)"
    354     (let* (
    355       (mdp
    356         (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final))
    357       (res (message-digest-primitive-apply mdp simple-src)) )
    358       (test-assert (string? res))
    359       (test simple-res (byte-string->hexadecimal res)) )
    360   )
    361 
    362   (test-group "Make (DEPRECATED)"
    363     (test simple-src (make-binary-message-digest simple-src make-context DIGEST-LENGTH init update final))
    364     (test simple-res (make-message-digest simple-src make-context DIGEST-LENGTH init update final))
    365   )
    366 )
    367 
    368 ;
    369 (test-group "Chunk Read (fileno)"
    370 
    371         (define the-ctx #f)
    372 
    373   (define (init ctx)
    374     ;(printf "  Init Ctx: ~S~%" ctx)
    375     (assert (pointer? ctx))
    376     (set! the-ctx ctx) )
    377 
    378   (define (update ctx bytes count)
    379         ;(printf "Update Ctx: ~S Count: ~S Bytes: ~S~%" ctx count bytes)
    380     (assert (eq? ctx the-ctx))
    381     (assert (not (not bytes)))
    382     (assert (< 0 count))
    383     (assert (<= count CONTEXT-SIZE))
    384     (assert (pointer? ctx))
    385     (move-memory! bytes ctx count) )
    386 
    387   (define (raw-update ctx bytes count)
    388         ;(printf "Raw-Update Ctx: ~S Count: ~S Bytes: ~S~%" ctx count bytes)
    389     (assert (eq? ctx the-ctx))
    390     (assert (not (not bytes)))
    391     (assert (< 0 count))
    392     (assert (= SHORT-TEST-FILE-LENGTH count))
    393     (assert (pointer? ctx))
    394     (move-memory! bytes ctx (min CONTEXT-SIZE count)) )
    395 
    396   (define (final ctx result)
    397     ;(printf " Final Ctx: ~S Length: ~S Result: ~S~%" ctx DIGEST-LENGTH result)
    398     (assert (eq? ctx the-ctx))
    399     (assert (not (not result)))
    400     (assert (pointer? ctx))
    401     ;(assert (<= 0 DIGEST-LENGTH))
    402     (move-memory! ctx result DIGEST-LENGTH) )
    403 
    404   (let (
    405     (mdp
    406       (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final raw-update)) )
    407     (test "6162636465" (message-digest-file mdp SHORT-TEST-FILE-NAME 'hex-string)) )
    408 )
    409 
    410 (test-end)
     175(test-end "Message Digest Primitive")
    411176
    412177(test-exit)
  • release/5/message-digest-primitive/trunk/tests/run.scm

    r35826 r35827  
    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.