Changeset 34562 in project


Ignore:
Timestamp:
09/16/17 17:16:32 (5 weeks ago)
Author:
kon
Message:

add compile test

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

Legend:

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

    r34434 r34562  
    55(verify-extension-name "message-digest")
    66
    7 (setup-shared+static-extension-module 'message-digest-primitive (extension-version "3.7.0")
     7(define *md-csc-optn* '(
     8  -optimize-level 3 -debug-level 1
     9  -no-procedure-checks-for-toplevel-bindings))
     10
     11(setup-shared+static-extension-module 'message-digest-primitive (extension-version "3.7.1")
    812  #:inline? #t
    913        #:types? #t
    10   #:compile-options '(
    11     -optimize-level 3 -debug-level 1
    12     -no-procedure-checks-for-toplevel-bindings))
     14  #:compile-options *md-csc-optn*)
    1315
    14 (setup-shared+static-extension-module 'message-digest-type (extension-version "3.7.0")
     16(setup-shared+static-extension-module 'message-digest-type (extension-version "3.7.1")
    1517  #:inline? #t
    1618        #:types? #t
    17   #:compile-options '(
    18     -optimize-level 3 -debug-level 1
    19     -no-procedure-checks-for-toplevel-bindings))
     19  #:compile-options *md-csc-optn*)
    2020
    21 (setup-shared+static-extension-module 'message-digest-chunk (extension-version "3.7.0")
     21(setup-shared+static-extension-module 'message-digest-chunk (extension-version "3.7.1")
    2222  #:inline? #t
    2323        #:types? #t
    24   #:compile-options '(
    25     -optimize-level 3 -debug-level 1
    26     -no-procedure-checks-for-toplevel-bindings))
     24  #:compile-options *md-csc-optn*)
    2725
    28 (setup-shared+static-extension-module 'message-digest-parameters (extension-version "3.7.0")
     26(setup-shared+static-extension-module 'message-digest-parameters (extension-version "3.7.1")
    2927  #:inline? #t
    3028        #:types? #t
    31   #:compile-options '(
    32     -optimize-level 3 -debug-level 1
    33     -no-procedure-checks-for-toplevel-bindings))
     29  #:compile-options *md-csc-optn*)
    3430
    35 (setup-shared+static-extension-module 'message-digest-support (extension-version "3.7.0")
     31(setup-shared+static-extension-module 'message-digest-support (extension-version "3.7.1")
    3632  #:inline? #t
    3733        #:types? #t
    38   #:compile-options '(
    39     -optimize-level 3 -debug-level 1
    40     -no-procedure-checks-for-toplevel-bindings))
     34  #:compile-options *md-csc-optn*)
    4135
    42 (setup-shared+static-extension-module 'message-digest-bv (extension-version "3.7.0")
     36(setup-shared+static-extension-module 'message-digest-bv (extension-version "3.7.1")
    4337  #:inline? #t
    4438        #:types? #t
    45   #:compile-options '(
    46     -optimize-level 3 -debug-level 1
    47     -no-procedure-checks-for-toplevel-bindings))
     39  #:compile-options *md-csc-optn*)
    4840
    49 (setup-shared+static-extension-module 'message-digest-int (extension-version "3.7.0")
     41(setup-shared+static-extension-module 'message-digest-int (extension-version "3.7.1")
    5042  #:inline? #t
    5143        #:types? #t
    52   #:compile-options '(
    53     -optimize-level 3 -debug-level 1
    54     -no-procedure-checks-for-toplevel-bindings))
     44  #:compile-options *md-csc-optn*)
    5545
    56 (setup-shared+static-extension-module 'message-digest-srfi-4 (extension-version "3.7.0")
     46(setup-shared+static-extension-module 'message-digest-srfi-4 (extension-version "3.7.1")
    5747  #:inline? #t
    5848        #:types? #t
    59   #:compile-options '(
    60     -optimize-level 3 -debug-level 1
    61     -no-procedure-checks-for-toplevel-bindings))
     49  #:compile-options *md-csc-optn*)
    6250
    63 (setup-shared+static-extension-module 'message-digest-update-item (extension-version "3.7.0")
     51(setup-shared+static-extension-module 'message-digest-update-item (extension-version "3.7.1")
    6452  #:inline? #t
    6553        #:types? #t
    66   #:compile-options '(
    67     -optimize-level 3 -debug-level 1
    68     -no-procedure-checks-for-toplevel-bindings))
     54  #:compile-options *md-csc-optn*)
    6955
    70 (setup-shared+static-extension-module 'message-digest-item (extension-version "3.7.0")
     56(setup-shared+static-extension-module 'message-digest-item (extension-version "3.7.1")
    7157  #:inline? #t
    7258        #:types? #t
    73   #:compile-options '(
    74     -optimize-level 3 -debug-level 1
    75     -no-procedure-checks-for-toplevel-bindings))
     59  #:compile-options *md-csc-optn*)
    7660
    77 (setup-shared+static-extension-module 'message-digest-port (extension-version "3.7.0")
     61(setup-shared+static-extension-module 'message-digest-port (extension-version "3.7.1")
    7862  #:inline? #t
    7963        #:types? #t
    80   #:compile-options '(
    81     -optimize-level 3 -debug-level 1
    82     -no-procedure-checks-for-toplevel-bindings))
     64  #:compile-options *md-csc-optn*)
    8365
    84 (setup-shared+static-extension-module 'message-digest-basic (extension-version "3.7.0")
     66(setup-shared+static-extension-module 'message-digest-basic (extension-version "3.7.1")
    8567  #:inline? #t
    8668        #:types? #t
    87   #:compile-options '(
    88     -optimize-level 3 -debug-level 1
    89     -no-procedure-checks-for-toplevel-bindings))
     69  #:compile-options *md-csc-optn*)
    9070
    91 (setup-shared+static-extension-module 'message-digest (extension-version "3.7.0")
     71(setup-shared+static-extension-module 'message-digest (extension-version "3.7.1")
    9272  #:inline? #t
    9373        #:types? #t
    94   #:compile-options '(
    95     -optimize-level 3 -debug-level 1
    96     -no-procedure-checks-for-toplevel-bindings))
     74  #:compile-options *md-csc-optn*)
  • release/4/message-digest/trunk/tests/run.scm

    r34396 r34562  
    1 ;;;; message-digest-test.scm
    21
    3 ;; Issues
    4 ;;
    5 ;; - Needs many more tests, especially the entire input-port & procedure source stuff.
     2(print "*** csi ***")
     3(system "csi -s message-digest-test.scm")
    64
    7 (use test)
    8 (use message-digest message-digest-port)
    9 (use files lolevel srfi-4)
    10 (use setup-api)
    11 
    12 ;;
    13 
    14 (define (ashexstr s)
    15         (apply string-append
    16                 (map
    17                         (lambda (c) (number->string (char->integer c) 16))
    18                         (string->list s))) )
    19 
    20 (define simple-src "ab cd")
    21 (define simple-res (ashexstr simple-src))
    22 
    23 (define digest-length 5)
    24 (define context-size 10)
    25 (define block-length 64)
    26 
    27 (define-constant BLOCK-LENGTH-DEFAULT 4)
    28 
    29 (define short-test-filename "alpha.txt")
    30 
    31 ;;
    32 
    33 (test-begin "Message Digest")
    34 
    35 ;
    36 (test 'hex-string (message-digest-result-form 'hex))
    37 
    38 ;Tests defaults
    39 (test-group "Chunk Read (port)"
    40   (let ((siz (message-digest-chunk-size))
    41         (in (open-input-file short-test-filename)))
    42     (let ((rdr ((message-digest-chunk-port-read-maker) in)))
    43       (let ((res (rdr)))
    44         (test-assert "First chunk type" (blob? res))
    45         (test "First chunk size" 26 (blob-size res)) )
    46       (test-assert "No more chunk" (not (rdr))) )
    47     (close-input-port in) )
    48 )
    49 
    50 (test-group "Make Primitive"
    51 
    52   (define (init ctx) (void))
    53   (define (update ctx bytes count) (void))
    54   (define (final ctx result) (void))
    55 
    56   (let ((mdp (make-message-digest-primitive context-size digest-length init update final)))
    57     (test-assert (message-digest-primitive? mdp))
    58     (test context-size (message-digest-primitive-context-info mdp))
    59     (test digest-length (message-digest-primitive-digest-length mdp))
    60     (test init (message-digest-primitive-init mdp))
    61     (test update (message-digest-primitive-update mdp))
    62     (test final (message-digest-primitive-final mdp))
    63     (test BLOCK-LENGTH-DEFAULT (message-digest-primitive-block-length mdp))
    64     (test-assert (symbol? (message-digest-primitive-name mdp))) )
    65 
    66   ;; don't bother testing the non-optional arguments again
    67 
    68   (let ((mdp (make-message-digest-primitive context-size digest-length init update final 'foo)))
    69     (test BLOCK-LENGTH-DEFAULT (message-digest-primitive-block-length mdp))
    70     (test 'foo (message-digest-primitive-name mdp)) )
    71 
    72   (let ((mdp (make-message-digest-primitive context-size digest-length init update final block-length)))
    73     (test block-length (message-digest-primitive-block-length mdp))
    74     (test-assert (symbol? (message-digest-primitive-name mdp))) )
    75 
    76   (let ((mdp (make-message-digest-primitive context-size digest-length init update final block-length 'foo)))
    77     (test block-length (message-digest-primitive-block-length mdp))
    78     (test 'foo (message-digest-primitive-name mdp)) )
    79 )
    80 
    81 ;These also test the update-string proc
    82 (test-group "Proper Phase Arguments (Def Alloc)"
    83 
    84         (define the-ctx #f)
    85 
    86   (define (init ctx)
    87     ;(printf "  Init Ctx: ~S~%" ctx)
    88     (assert (pointer? ctx))
    89     (set! the-ctx ctx) )
    90 
    91   (define (update ctx bytes count)
    92         ;(printf "Update Ctx: ~S Bytes: ~S Count: ~S~%" ctx bytes count)
    93     (assert (pointer? ctx))
    94     (assert (eq? ctx the-ctx))
    95     (assert (blob? bytes))
    96     (assert (<= count (blob-size bytes)))
    97     (assert (>= context-size count))  ; So no mem overflow
    98     (move-memory! bytes ctx count) )
    99 
    100   (define (final ctx result)
    101     ;(printf " Final Ctx: ~S Result: ~S~%" ctx result)
    102     (assert (pointer? ctx))
    103     (assert (eq? ctx the-ctx))
    104     (assert (or (blob? result) (string? result)))
    105     ; So no mem overflow
    106     (assert (<= digest-length (if (blob? result) (blob-size result) (string-length result))))
    107     (move-memory! ctx result digest-length) )
    108 
    109   (let ((mdp (make-message-digest-primitive context-size digest-length init update final)))
    110     (let ((md (initialize-message-digest mdp)))
    111       (test-assert (message-digest? md))
    112       (test-assert (message-digest-update-string md simple-src))
    113       (test simple-res (finalize-message-digest md)) )
    114     (let ((md (initialize-message-digest mdp))
    115           (blb (make-blob 100)) )
    116       (message-digest-update-string md simple-src)
    117       (test-assert (finalize-message-digest! md blb))
    118       (print "result = " blb) )
    119     (let ((md (initialize-message-digest mdp))
    120           (str (make-string 100 #\space)) )
    121       (message-digest-update-string md simple-src)
    122       (test-assert (finalize-message-digest! md str))
    123       (print "result = " #\" str #\") )
    124     (let ((md (initialize-message-digest mdp))
    125           (vec (make-u8vector 100 0)) )
    126       (message-digest-update-string md simple-src)
    127       (test-assert (finalize-message-digest! md vec))
    128       (print "result = " vec) ) )
    129 )
    130 
    131 (test-group "Proper Phase Arguments (Own Alloc)"
    132 
    133         (define the-ctx #f)
    134 
    135   (define (make-context) (make-blob context-size))
    136 
    137   (define (init ctx)
    138     #;(printf "  Init Ctx: ~S~%" ctx)
    139     (assert (blob? ctx))
    140     (set! the-ctx ctx) )
    141 
    142   (define (update ctx bytes count)
    143     ;(printf "Update Ctx: ~S Bytes: ~S Count: ~S~%" ctx bytes count) (flush-output)
    144     (assert (blob? ctx))
    145     (assert (eq? ctx the-ctx))
    146     (assert (blob? bytes))
    147     (assert (<= count (blob-size bytes)))
    148     (assert (>= context-size count))  ; So no mem overflow
    149     (move-memory! bytes ctx count) )
    150 
    151   (define (final ctx result)
    152     ;(printf " Final Result Size: ~S Ctx: ~S Result: ~S~%" (blob-size result) ctx result) (flush-output)
    153     (assert (blob? ctx))
    154     (assert (eq? ctx the-ctx))
    155     (assert (blob? result))
    156     (assert (= digest-length (blob-size result)))  ; So no mem overflow
    157     (move-memory! ctx result digest-length) )
    158 
    159   (let ((mdp (make-message-digest-primitive make-context digest-length init update final)))
    160     (let ((md (initialize-message-digest mdp)))
    161       (test-assert (message-digest? md))
    162       (test-assert (message-digest-update-string md simple-src))
    163       (test simple-res (finalize-message-digest md)) ) )
    164 )
    165 
    166 (let ()
    167 
    168   (define (make-context)
    169     ;Init to 0 necessary since digest-length is possibly > than
    170     ;the input size! (Actually just needs to be a known value,
    171     ;`(integer->char #xff)' would work as well.)
    172     (string->blob (make-string context-size #\nul)) )
    173 
    174   (define (init ctx) (void))
    175 
    176   (define (update ctx bytes count)
    177     ;(printf "Update Ctx: ~S Bytes: ~S Count: ~S~%" ctx bytes count) (flush-output)
    178     (assert (>= context-size count))  ; So no mem overflow
    179     (move-memory! bytes ctx count) )
    180 
    181   (define (final ctx result)
    182     ;(printf " Final Result Size: ~S Ctx: ~S Result: ~S~%" (blob-size result) ctx result) (flush-output)
    183     (assert (= digest-length (blob-size result)))  ; So no mem overflow
    184     (move-memory! ctx result digest-length) )
    185 
    186   (define mdp (make-message-digest-primitive make-context digest-length init update final))
    187 
    188   (test-group "u8vector Source"
    189     (let ((md (initialize-message-digest mdp)))
    190       (test-assert (message-digest-update-u8vector md (u8vector 1 2 3 4 5)))
    191       (test "0102030405" (finalize-message-digest md)) )
    192   )
    193 
    194   (test-group "u8 Source"
    195     (let ((md (initialize-message-digest mdp)))
    196       (test-assert (message-digest-update-u8 md #xA2))
    197       (test "a200000000" (finalize-message-digest md)) )
    198   )
    199 
    200   (test-group "u16-le Source"
    201     (let ((md (initialize-message-digest mdp)))
    202       (test-assert (message-digest-update-u16-le md #xA2B2))
    203       (test "b2a2000000" (finalize-message-digest md)) )
    204   )
    205 
    206   (test-group "u32-be Source"
    207     (let ((md (initialize-message-digest mdp)))
    208       (test-assert (message-digest-update-u32-be md 1073741823))
    209       (test "3fffffff00" (finalize-message-digest md)) )
    210   )
    211 
    212   (when (version>=? (chicken-version) "4.6.4")
    213           (test-group "u32-be Source"
    214                         (let ((md (initialize-message-digest mdp)))
    215                                 (test-assert (message-digest-update-u32-be md #xA2B2C2D2))
    216                                 (test "a2b2c2d200" (finalize-message-digest md)) )
    217                 ) )
    218 
    219   (when (version>=? (chicken-version) "4.8.1")
    220                 (test-group "u64-be Source"
    221                         (let ((md (initialize-message-digest mdp)))
    222                                 (test-assert (message-digest-update-u64-be md #xAB54A98CEB1F0AD2))
    223                                 (test
    224                                   (substring "ab54a98ceb1f0ad2" 0 (fx* 2 (fxmin 8 digest-length)))
    225                                   (finalize-message-digest md)) )
    226                 ) )
    227 
    228   (test-group "char-u8 Source"
    229     (let ((md (initialize-message-digest mdp)))
    230       (test-assert (message-digest-update-char-u8 md #\space))
    231       (test "2000000000" (finalize-message-digest md)) )
    232   )
    233 
    234   (test-group "char-be Source"
    235     (let ((md (initialize-message-digest mdp)))
    236       (test-assert (message-digest-update-char-be md #\u0003BB))
    237       (test "000003bb00" (finalize-message-digest md)) )
    238   )
    239 
    240   (test-group "char-le Source"
    241     (let ((md (initialize-message-digest mdp)))
    242       (test-assert (message-digest-update-char-le md #\u0003BB))
    243       (test "bb03000000" (finalize-message-digest md)) )
    244   )
    245 
    246   (test-group "Procedure Source"
    247     (define just-once
    248       (let ((x #t))
    249         (lambda ()
    250           (let ((res (and x simple-src)))
    251             (set! x #f)
    252             res ) ) ) )
    253     (let ((md (initialize-message-digest mdp)))
    254       (test-assert (message-digest-update-procedure md just-once))
    255       (test simple-res (finalize-message-digest md)) )
    256   )
    257 
    258   (test-group "Port"
    259     (let ((port (open-output-digest mdp)))
    260       (test-assert (output-port? port))
    261       (display simple-src port) ;cannot be readable!
    262       (test simple-res (get-output-digest port))
    263       (test-assert (port-closed? port)) )
    264   )
    265 )
    266 
    267 #; ;REMOVED
    268 (begin
    269         (use message-digest-old)
    270 
    271   (define (make-context)
    272     (string->blob (make-string context-size #\nul)) )
    273 
    274   (define (init ctx) (void))
    275 
    276   (define (update ctx bytes count)
    277     (assert (>= context-size count))  ; So no mem overflow
    278     (move-memory! bytes ctx count) )
    279 
    280   (define (final ctx result)
    281     (assert (= digest-length (blob-size result)))  ; So no mem overflow
    282     (move-memory! ctx result digest-length) )
    283 
    284   (test-group "Primitive Apply (DEPRECATED)"
    285     (let ((mdp (make-message-digest-primitive context-size digest-length init update final)))
    286       (let ((res (message-digest-primitive-apply mdp simple-src)))
    287         (test-assert (string? res))
    288         (test simple-res (byte-string->hexadecimal res)) ) )
    289   )
    290 
    291   (test-group "Make (DEPRECATED)"
    292     (test simple-src (make-binary-message-digest simple-src make-context digest-length init update final))
    293     (test simple-res (make-message-digest simple-src make-context digest-length init update final))
    294   )
    295 )
    296 
    297 ;
    298 (test-group "Chunk Read (fileno)"
    299 
    300   (define (init ctx)
    301     ;(printf "  Init Ctx: ~S~%" ctx)
    302     (assert (pointer? ctx)) )
    303 
    304   (define (update ctx bytes count)
    305         ;(printf "Update Ctx: ~S Count: ~S Bytes: ~S~%" ctx count bytes)
    306     (assert (pointer? ctx))
    307     (assert (not (not bytes)))
    308     (assert (<= context-size count))
    309     (move-memory! bytes ctx (min context-size count)) )
    310 
    311   (define (raw-update ctx bytes count)
    312         ;(printf "Raw-Update Ctx: ~S Count: ~S Bytes: ~S~%" ctx count bytes)
    313     (assert (pointer? ctx))
    314     (assert (not (not bytes)))
    315     (assert (<= context-size count))
    316     (move-memory! bytes ctx (min context-size count)) )
    317 
    318   (define (final ctx result)
    319     ;(printf " Final Ctx: ~S Length: ~S Result: ~S~%" ctx digest-length result)
    320     (assert (pointer? ctx))
    321     (assert (not (not result)))
    322     (assert (<= 0 digest-length))
    323     (move-memory! ctx result digest-length) )
    324 
    325   (let ((mdp (make-message-digest-primitive context-size digest-length init update final raw-update)))
    326     (test "6162636465" (message-digest-file mdp short-test-filename 'hex-string)) )
    327 )
    328 
    329 (test-end)
    330 
    331 (test-exit)
     5;no -disable-interrupts
     6(define *csc-options* "-inline-global -scrutinize -optimize-leaf-routines -local -inline -specialize -unsafe -no-trace -no-lambda-info -clustering -lfa2")
     7(print "*** csc (" *csc-options* ") ***")
     8(system (string-append "csc" " " *csc-options* " " "message-digest-test.scm"))
     9(system "./message-digest-test")
Note: See TracChangeset for help on using the changeset viewer.