Changeset 39779 in project


Ignore:
Timestamp:
04/04/21 02:05:48 (6 weeks ago)
Author:
Kon Lovett
Message:

fix test runner fail exit pass-thru, add test runner config

Location:
release/5/apropos/trunk
Files:
1 added
6 edited

Legend:

Unmodified
Added
Removed
  • release/5/apropos/trunk/apropos-api.scm

    r38992 r39779  
    241241      ((eq? #:module split)
    242242        (lambda (sym)
    243           (let-values (((mod nam) (split-prefixed-symbol sym)))
    244             (check? mod) ) ) )
     243          (check? (let-values (((mod nam) (split-prefixed-symbol sym))) mod)) ) )
    245244      ((eq? #:name split)
    246245        (lambda (sym)
    247           (let-values (((mod nam) (split-prefixed-symbol sym)))
    248             (check? nam) ) ) )
    249         (else
    250           (error loc "unknown symbol split" split patt) ) ) )
     246          (check? (let-values (((mod nam) (split-prefixed-symbol sym))) nam)) ) )
     247      (else
     248        (error loc "unknown symbol split" split patt) ) ) )
    251249  ;
    252250  (define (string-matcher str)
     
    713711    (+ bias (- maxsymlen maxlen)) ) )
    714712
     713#; ;
     714(define (display/cols vals wids #!key (tab-width *tab-width*))
     715  )
     716
    715717;FIXME need to know if ANY mods, then no mod pad needed (has +2)
    716718(define (display-apropos isyms macenv sort-key raw?)
     
    729731        (kwd? (eq? 'keyword dets))
    730732        (sym (information-name info) )
    731         (sym-padlen (symbol-pad-length sym maxsymlen (if kwd? -1 0)) ) )
     733        (sym-padlen (symbol-pad-length sym maxsymlen #;(if kwd? -1 0)) ) )
    732734        (display (if kwd? (symbol->keyword sym) sym))
    733735        (display (make-string+ (+ *tab-width* sym-padlen))) )
     
    736738        (mod (information-module info) )
    737739        (mod-padlen (symbol-pad-length mod maxmodlen) ) )
    738         ;
    739740        (if (eq? (toplevel-module-symbol) mod)
    740741          (display (make-string+ (+ *tab-width* mod-padlen)))
  • release/5/apropos/trunk/apropos-csi.scm

    r39043 r39779  
    6363  '(PATT . _)     synonym for `PATT split module`.
    6464  '(_ . PATT)     synonym for `PATT split name`.
    65   '(_ . _)        synonym for `(: (* any))` or match any.
     65  '(_ . _)        synonym for '.* | ".*" | `(: (* any))` ;match any.
    6666
    6767  '<atom>         interpret `<atom>` as an irregex.
  • release/5/apropos/trunk/apropos.egg

    r38992 r39779  
    33
    44((synopsis "CHICKEN apropos")
    5  (version "3.6.0")
     5 (version "3.6.1")
    66 (category misc)
    7  (author "[[kon lovett]]")
     7 (author "Kon Lovett")
    88 (license "BSD")
    99 (dependencies srfi-1 srfi-13 check-errors string-utils symbol-utils)
  • release/5/apropos/trunk/symbol-environment-access.scm

    r38992 r39779  
    2121  ;
    2222  search-interaction-environment-symbols
    23   search-list-environment-symbols)
     23  search-list-environment-symbols
     24  ;
     25  search-environments-symbols)
    2426
    25 (import scheme)
    26 (import (chicken base))
    27 (import (chicken type))
    28 (import symbol-table-access)
     27(import scheme
     28  (chicken base)
     29  (chicken type)
     30  (only (srfi 1) append!)
     31  symbol-table-access)
    2932
    3033;;;
     
    3942(: search-interaction-environment-symbols ((* -> boolean) -> list))
    4043(: search-macro-environment-symbols ((* -> boolean) (list-of (pair symbol *)) --> list))
    41 (: search-system-environment-symbols ((* -> boolean) (or (list-of (pair symbol *)) boolean) -> list))
     44(: search-system-environment-symbols ((* -> boolean) #!optional (or (list-of (pair symbol *)) boolean) -> list))
     45(: search-environments-symbols ((* -> boolean) -> list))
    4246
    4347;;
     
    4953(define system-current-environment ##sys#current-environment)
    5054(define system-macro-environment ##sys#macro-environment)
     55
    5156(define macro-symbol-in-environment? ##sys#macro?)
    5257
     
    7479    (search-interaction-environment-symbols test?) ) )
    7580
     81;;
     82
     83(define (search-environments-symbols test?)
     84  (append!
     85    (search-system-environment-symbols test? (system-current-environment))
     86    (search-system-environment-symbols test? (system-macro-environment))
     87    (search-system-environment-symbols test?)) )
     88
    7689) ;module symbol-environment-access
  • release/5/apropos/trunk/tests/apropos-test.scm

    r38628 r39779  
    167167(test-group "Information List"
    168168  (apropos-information-list-test
    169     '(
    170       ((|| . foobarmacro1) . macro)
     169    '(((|| . foobarmacro1) . macro)
    171170      ((|| . foobarmacro2) . macro)
    172171      ((|| . foobarproc0) procedure)
     
    176175      ((|| . foobarprocx) procedure a b c)
    177176      ((|| . foobarvar1) . variable)
    178       ((|| . foobarvar2) . variable) )
     177      ((|| . foobarvar2) . variable))
    179178    (apropos-information-list 'foobar #:macros? #t #:internal? #t))
    180179
  • release/5/apropos/trunk/tests/run.scm

    r38527 r39779  
    1 ;;;; run.scm -*- Scheme -*-
     1;;;; run.scm  -*- Scheme -*-
    22
    3 (import scheme)
     3;chicken-install invokes as "<csi> -s run.scm <eggnam>"
    44
    5 ;;; Create Egg Const
     5(import scheme
     6  (only (chicken pathname)
     7    make-pathname pathname-file pathname-replace-directory pathname-strip-extension)
     8  (only (chicken process) system)
     9  (only (chicken process-context) command-line-arguments)
     10  (only (chicken format) format)
     11  (only (chicken file) file-exists? find-files)
     12  (only (chicken irregex) irregex irregex-match?))
    613
    7 (define EGG-NAME "apropos")
     14;; Globals
    815
    9 ;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
     16(define *csc-init-options* '(
     17  ;"-disable-interrupts"
     18  "-inline-global" "-inline" "-local"
     19  "-specialize" "-strict-types"
     20  "-optimize-leaf-routines" "-clustering" "-lfa2"
     21  "-no-trace" "-no-lambda-info" "-unsafe"))
    1022
    11 (import (only (chicken pathname)
    12   make-pathname pathname-file pathname-replace-directory pathname-strip-extension))
    13 (import (only (chicken process) system))
    14 (import (only (chicken process-context) argv))
    15 (import (only (chicken format) format))
    16 (import (only (chicken file) file-exists? find-files))
    17 (import (only (chicken irregex) irregex irregex-match?))
     23(define *test-directory* ".")
     24(define *test-extension* "scm")
     25(define *test-files-rx* (irregex `(: (+ graph) #\- "test" #\. ,*test-extension*)))
    1826
    19 (define *args* (argv))
     27(include-relative "run-ident")
    2028
    21 (define (egg-name args #!optional (def EGG-NAME))
     29;; Support
     30
     31(define (system-must cmd)
     32  (let ((stat (system cmd)))
     33    (if (zero? stat) 0
     34      ;failed, actual code irrelevant
     35      (exit 1) ) ) )
     36
     37(define (remove rmv? ls)
     38  (let loop ((ls ls) (os '()))
     39    (cond
     40      ((null? ls)       (reverse os))
     41      ((rmv? (car ls))  (loop (cdr ls) os))
     42      (else             (loop (cdr ls) (cons (car ls) os))) ) ) )
     43
     44(define (remove/list os ls) (remove (cut member <> os) ls))
     45
     46;; Test Run Support
     47
     48(define (egg-name #!optional (args (command-line-arguments)) (def EGG-NAME))
    2249  (cond
    23     ((<= 4 (length *args*)) (cadddr *args*) )
    24     (def                    def )
     50    ((not (null? args)) (car args))
     51    (def                def)
    2552    (else
    26       (error 'run "cannot determine egg-name") ) ) )
     53      (error 'run "cannot determine egg-name")) ) )
    2754
    28 (define *current-directory* (cond-expand (unix "./") (else #f)))
    29 (define *egg* (egg-name *args*))
     55(define (csc-options)
     56  (append *csc-incl-options* (remove/list *csc-excl-options* *csc-init-options*)) )
    3057
    31 ;no -disable-interrupts or -no-lambda-info
    32 (define *csc-options* "-inline-global -local -inline \
    33   -specialize -optimize-leaf-routines -clustering -lfa2 \
    34   -no-trace -unsafe \
    35   -strict-types")
     58(define (test-filename name) (string-append name "-test"))
    3659
    37 (define *test-files-rx* (irregex '(: (+ graph) #\- "test" #\. "scm")))
    38 (define (test-filename name) (string-append name "-test"))
    39 (define (test-files) (find-files "." #:test *test-files-rx* #:limit 1))
     60(define (make-test-pathname name)
     61  (make-pathname *test-directory* (test-filename name) *test-extension*) )
    4062
    41 (define (ensure-test-source-name name)
     63(define (matching-test-file? x #!optional (remvs '()))
     64  (and (irregex-match? *test-files-rx* x) (not (member x remvs))) )
     65
     66(define (test-files)
     67  (let ((remvs (map make-test-pathname *test-excl-names*)))
     68    (find-files
     69      *test-directory*
     70      #:test (cut matching-test-file? <> remvs)
     71      #:limit 0) ) )
     72
     73(define (ensure-test-pathname name)
    4274  (if (irregex-match? *test-files-rx* name)
    4375    name
    44     (make-pathname *current-directory* (test-filename name) "scm") ) )
     76    (make-test-pathname name)) )
     77
     78;; Run Tests
    4579
    4680(define (run-test-evaluated source)
    47   (format #t "*** ~A - csi ***~%" (pathname-file source))
    48   (system (string-append "csi -s " source)) )
     81  (format #t "*** csi ~A ***~%" (pathname-file source))
     82  (system-must (string-append "csi -s " source)) )
    4983
    5084(define (run-test-compiled source csc-options)
    51   (format #t "*** ~A - csc ~A ***~%" (pathname-file source) csc-options)
    52   ;csc output is in current directory
    53   (system (string-append "csc" " " csc-options " " source))
    54   (system (pathname-replace-directory (pathname-strip-extension source) *current-directory*)) )
     85  (let ((optstr (apply string-append (intersperse csc-options " "))))
     86    (format #t "*** csc ~A ~A ***~%" (pathname-file source) optstr)
     87    ;csc output is in current directory
     88    (system-must (string-append "csc" " " optstr " " source)) )
     89  (system-must (pathname-replace-directory (pathname-strip-extension source) *test-directory*)) )
    5590
    56 ;;;
    57 
    58 (define (run-test #!optional (name *egg*) (csc-options *csc-options*))
    59   (let (
    60     (source (ensure-test-source-name name)) )
     91(define (run-test #!optional (name (egg-name)) (csc-options (csc-options)))
     92  (let ((source (ensure-test-pathname name)))
    6193    (unless (file-exists? source)
    6294      (error 'run "no such file" source) )
     
    6597    (run-test-compiled source csc-options) ) )
    6698
    67 (define (run-tests #!optional (tests (test-files)) (csc-options *csc-options*))
     99(define (run-tests #!optional (tests (test-files)) (csc-options (csc-options)))
    68100  (for-each (cut run-test <> csc-options) tests) )
    69101
    70 ;;; Do Test
     102;; Do Tests
    71103
    72104(run-tests)
Note: See TracChangeset for help on using the changeset viewer.