Changeset 3957 in project


Ignore:
Timestamp:
04/27/07 19:18:07 (13 years ago)
Author:
Kon Lovett
Message:

Setup w/ tests.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • fpfz/setup-header.scm

    r3415 r3957  
    22;;;; Kon Lovett, May '06
    33
     4(required-chicken-version 2.5)
     5
    46;;; Constants & Procedures
    57
    6 (define has-exports? (string>=? (chicken-version) "2.310"))
    7 (define needs-easyffi? (string>=? (chicken-version) "2.424"))
    8 (define needs-dollar? (string>=? (chicken-version) "2.424"))
    9 
    108(define REPOSITORY-DIRECTORY (repository-path))
    119
     10;; These must be kept in synch w/ testbase-results.scm!
     11
     12(define TESTBASE-DIRECTORY (make-pathname REPOSITORY-DIRECTORY "testbase"))
     13(define TESTBASE-TESTS-DIRECTORY (make-pathname TESTBASE-DIRECTORY "tests"))
     14
    1215(define (->symbol obj)
    13   (if (string? obj) (string->symbol obj) obj) )
    14 
    15 ;; Test Constants
    16 
    17 (define TESTBASE-DIRECTORY (make-pathname `(,REPOSITORY-DIRECTORY "testbase") #f))
    18 (define TESTBASE-TESTS-DIRECTORY (make-pathname `(,TESTBASE-DIRECTORY "tests") #f))
    19 (define-constant DEFAULT-TESTS-GLOB "*-test.scm")
     16  (cond
     17    [(symbol? obj)  obj]
     18    [(string? obj)  (string->symbol obj)]
     19    [else           (string->symbol (->string obj))]) )
    2020
    2121;; Pathname Constructors
     
    4242
    4343(define (copy-to-repository fn)
    44   (copy-file (->string fn) (repository-path)) )
     44  (copy-file (->string fn) REPOSITORY-DIRECTORY) )
    4545
    4646(define (copy-to-shared fn)
     
    5050  (copy-file (->string fn) TESTBASE-TESTS-DIRECTORY) )
    5151
    52 ;; Test Operations
    53 
    54 (define test-glob-patterns
    55   (make-parameter
    56     (list DEFAULT-TESTS-GLOB)
    57     (lambda (x)
    58       (if (list? x)
    59         x
    60         (begin
    61           (warning "invalid glob pattern list" x)
    62           (test-glob-patterns))))))
    63 
    64 (define (install-tests)
    65   (for-each
    66     (lambda (glob-patt)
     52;; Install & Run Test(s)
     53
     54(define test-driver-arguments
     55  (make-parameter (if (setup-verbose-flag) "--indent 2 -v" "--indent 2")
     56    (lambda (x) (if (string? x) x (test-driver-arguments)))))
     57
     58(define (install-test . flnms)
     59  (when (setup-verbose-flag)
     60    (newline)
     61    (print "* Installing test files in " TESTBASE-TESTS-DIRECTORY #\:) )
     62  (unless (file-exists? TESTBASE-TESTS-DIRECTORY)
     63    (create-directory TESTBASE-TESTS-DIRECTORY) )
     64  (let ([tsts
     65          (map
     66            (lambda (x)
     67              (if (list? x)
     68                (begin
     69                  (for-each (cut copy-test-file-to-repository <>) x)
     70                  (car x))
     71                (begin
     72                  (copy-test-file-to-repository x)
     73                  x)))
     74            flnms)])
     75  (if (or (file-exists? (make-pathname (program-path) "testbase-driver"))
     76          (file-exists? (make-pathname (installation-prefix) "testbase-driver")))
     77    (begin
     78      (when (setup-verbose-flag)
     79        (newline)
     80        (print "* Running test files" #\:) )
    6781      (for-each
    68         (cut copy-test-file-to-repository <>)
    69         (glob glob-patt)) )
    70     (test-glob-patterns)) )
     82        (cute system* "testbase-driver ~A ~A" (test-driver-arguments) <>)
     83        tsts) )
     84    (begin
     85      (newline)
     86      (print "* TestBase is not installed. Cannot perform testing.") ) ) ) )
    7187
    7288;; Options Parsing
    7389
    7490(define (parse-optionals opt)
    75 
    76   #;(define (string-drop-first str)
    77     (list->string (cdr (string->list str))) )
    78 
    79   #;(define (symbol-drop-first sym)
    80     (string->symbol (string-drop-first (symbol->string sym))) )
    81 
    8291  (let ([cmp-args '()] [rqr@run '()] [opt-args '()])
    8392    (let loop ([lst opt])
     
    91100                (set! opt-args (cons itm opt-args)) )]
    92101            [(symbol? itm)
    93               (if (char=? #\+ (string-ref (symbol->string itm) 0))
    94                 (switch itm
    95                   ['+easyffi
    96                     (when needs-easyffi?
    97                       (set! cmp-args (append '(easyffi -extend) cmp-args)) )]
    98                   ['+dollar
    99                     (when needs-dollar?
    100                       (set! cmp-args (append '(dollar -extend) cmp-args)) )]
    101                   #;[else
    102                     (set! cmp-args (append `(,(symbol-drop-first itm) -extend) cmp-args))] )
    103                 (set! cmp-args (cons itm cmp-args)) )]
     102              (let ([str (symbol->string itm)])
     103                (if (char=? #\+ (string-ref str 0))
     104                  (set! cmp-args
     105                    (append
     106                      `(,(string->symbol (substring str 1)) -extend)
     107                      cmp-args))
     108                  (set! cmp-args (cons itm cmp-args)) ) )]
    104109            [(atom? itm)
    105110              (set! cmp-args (cons itm cmp-args))]
     
    118123    ,(make-source-filename DYN)
    119124    -o ,(make-dynld-filename DYN)
    120     ,@(if has-exports? `(-check-imports -emit-exports ,(make-exports-filename DYN)) '())
     125    -check-imports -emit-exports ,(make-exports-filename DYN)
    121126    ,@OPT) )
    122127
     
    127132    ,(make-source-filename SDYN)
    128133    -o ,(make-dynld-filename ODYN)
    129     ,@(if has-exports? `(-check-imports -emit-exports ,(make-exports-filename ODYN)) '())
     134    -check-imports -emit-exports ,(make-exports-filename ODYN)
    130135    ,@OPT) )
    131136
     
    141146          ,@(if (null? RQR@RUN) '() `((require-at-runtime ,@RQR@RUN)))
    142147          (version ,VER)
    143           ,@(if has-exports? `((exports ,(make-exports-filename DYN))) '()) ) ) ) ) )
     148          (exports ,(make-exports-filename DYN)) ) ) ) ) )
    144149
    145150(define-macro (install-dynld+docu DYN VER . OPT)
     
    154159          (documentation ,(make-docu-filename DYN))
    155160          (version ,VER)
    156           ,@(if has-exports? `((exports ,(make-exports-filename DYN))) '()) ) ) ) ) )
     161          (exports ,(make-exports-filename DYN)) ) ) ) ) )
    157162
    158163(define-macro (install-syntax SYN VER . OPT)
     
    187192          (require-at-runtime ,(->symbol DYN) ,@RQR@RUN)
    188193          (version ,VER)
    189           ,@(if has-exports? `((exports ,(make-exports-filename DYN))) '()) ) ) ) ) )
     194          (exports ,(make-exports-filename DYN)) ) ) ) ) )
    190195
    191196(define-macro (install-dynld+syntax+docu SYN DYN VER . OPT)
     
    202207          (require-at-runtime ,(->symbol DYN) ,@RQR@RUN)
    203208          (version ,VER)
    204           ,@(if has-exports? `((exports ,(make-exports-filename DYN))) '()) ) ) ) ) )
     209          (exports ,(make-exports-filename DYN)) ) ) ) ) )
Note: See TracChangeset for help on using the changeset viewer.