Changeset 38965 in project


Ignore:
Timestamp:
08/30/20 22:03:39 (4 weeks ago)
Author:
Kon Lovett
Message:

add -strict-types, remove redudant -local, update test runner, type is interface

Location:
release/5/condition-utils/trunk
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • release/5/condition-utils/trunk/condition-utils-support.scm

    r35972 r38965  
    2525  (only type-errors error-argument-type))
    2626
    27 ;;;
     27;;
     28
     29(: expand-property-conditions ((list-of (or condition symbol pair)) -> (list-of condition)))
     30(: write-call-chain (list output-port string -> void))
     31(: write-condition-list ((list-of pair) output-port string -> string))
    2832
    2933;; Interpret condition expression
     
    3539;; (<symbol> [<symbol> <object>]...)
    3640
    37 (: expand-property-conditions ((list-of (or condition symbol pair)) -> (list-of condition)))
    38 ;
    3941(define (expand-property-conditions cnds)
    4042  (map
     
    5557;;
    5658
    57 (: write-call-chain (list output-port string -> void))
    58 ;
    5959(define (write-call-chain chain port header)
    6060  (##sys#really-print-call-chain port chain header) )
     
    7777;;
    7878
    79 (: write-condition-list ((list-of pair) output-port string -> string))
    80 ;
    8179(define (write-condition-list cnds port header)
    8280  (let (
  • release/5/condition-utils/trunk/condition-utils.egg

    r35972 r38965  
    77 (author "[[kon lovett]]")
    88 (license "BSD")
    9  (dependencies
    10   (srfi-1 "0.1")
    11   (srfi-69 "0.1")
    12   (check-errors "3.1.0"))
     9 (dependencies srfi-1 srfi-69 check-errors)
    1310 (test-dependencies test)
    1411 (components
    1512  (extension condition-utils-support
    16     #;(inline-file)
    1713    (types-file)
    1814    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks") )
    1915  (extension condition-utils
    20     #;(inline-file)
    2116    (types-file)
    2217    (component-dependencies condition-utils-support)
    23     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks") )
     18    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks") )
    2419  (extension exn-condition
    25     #;(inline-file)
    2620    (types-file)
    2721    (component-dependencies condition-utils-support condition-utils)
    28     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks") )
     22    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks") )
    2923  (extension standard-conditions
    30     #;(inline-file)
    3124    (types-file)
    3225    (component-dependencies condition-utils)
    33     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks") )
     26    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks") )
    3427  (extension http-client-conditions
    35     #;(inline-file)
    3628    (types-file)
    3729    (component-dependencies condition-utils)
    38     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks") )
     30    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks") )
    3931  (extension intarweb-conditions
    40     #;(inline-file)
    4132    (types-file)
    4233    (component-dependencies condition-utils)
    43     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks") ) ) )
     34    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks") ) ) )
  • release/5/condition-utils/trunk/condition-utils.scm

    r38466 r38965  
    2828(import scheme)
    2929(import (chicken base))
    30 (import (chicken fixnum))
    3130(import (chicken condition))
    3231(import (chicken syntax))
     
    3938(import condition-utils-support)
    4039
    41 ;;;
     40;;
     41
     42(: condition-irritants (condition --> list))
     43(: make-condition+ (#!rest --> condition))
     44(: condition-predicate* (symbol -> (* -> boolean : condition)))
     45(: condition-property-accessor* (symbol symbol #!optional * -> (procedure (condition) *)))
     46(: call-chain? (* -> boolean : (list-of vector)))
     47(: write-condition (condition #!optional output-port string -> void))
     48(: condition-property->string (condition symbol symbol * -> string))
     49
     50;;
    4251
    4352; Symbols are convention. Any object supported.
     
    6069;; All condition properties
    6170
    62 (: condition-irritants (condition --> list))
    63 ;
    6471;((exn (arguments (test)) (message "test") (location test)) (test) (extra (test 23)))
    6572;=>
     
    7380;; Condition from condition expression; composite when indicated
    7481
    75 (: make-condition+ (#!rest --> condition))
    76 ;
    7782(define (make-condition+ . cnds)
    7883  (let (
     
    8489;; memeoized condition-predicate ctor
    8590
    86 (: condition-predicate* (symbol -> (* -> boolean : condition)))
    87 ;
    8891(define condition-predicate*
    8992  (let ((+preds+ (make-hash-table eq?)))
     
    112115;; memeoized condition-property-accessor ctor
    113116
    114 (: condition-property-accessor* (symbol symbol #!optional * -> (procedure (condition) *)))
    115 ;
    116117(define condition-property-accessor*
    117118  (let (
     
    142143;;
    143144
    144 (: call-chain? (* -> boolean : (list-of vector)))
    145 ;
    146145(define (call-chain? x)
    147146  ;(or (null? x) (and (proper-list? x) (every vector? x)))
     
    150149    (and (pair? x) (vector? (car x)))) )
    151150
    152 (: write-condition (condition #!optional output-port string -> void))
    153 ;
    154151(define (write-condition cnd #!optional (port (current-output-port)) (header "Error"))
    155152  (format port "~A: ~A"
     
    162159;;
    163160
    164 (: condition-property->string (condition symbol symbol * -> string))
    165 ;
    166161(define (condition-property->string cnd kind prop #!optional (def ""))
    167162  (->string ((condition-property-accessor kind prop def) cnd)) )
     
    183178;;
    184179
     180#; ;UNUSED
    185181(define (subheader-string header)
    186   (string-append (make-string (fx- (string-length header) 1) #\space) "+") )
     182  (string-append (make-string (- (string-length header) 1) #\space) "+") )
    187183
    188184) ;module condition-utils
  • release/5/condition-utils/trunk/exn-condition.scm

    r35972 r38965  
    2828  condition-utils)
    2929
    30 ;;;
     30;;
     31
     32(: make-exn-condition (#!optional (or boolean symbol) (or boolean string) (or boolean list) (or boolean list) --> condition))
     33(: make-exn-condition+ ((or boolean symbol) (or boolean string) #!rest -> condition))
     34(: write-exn-condition (condition #!optional output-port string string -> void))
    3135
    3236;;
     
    4246;;
    4347
    44 (: make-exn-condition (#!optional (or boolean symbol) (or boolean string) (or boolean list) (or boolean list) --> condition))
    45 ;
    4648(define (make-exn-condition #!optional (loc #f) (msg "unknown") (args #f) (chain #f))
    4749  (let (
     
    5658;;
    5759
    58 (: make-exn-condition+ ((or boolean symbol) (or boolean string) #!rest -> condition))
    59 ;
    6060(define (make-exn-condition+ loc msg args . cnds)
    6161  (let* (
     
    6868;;
    6969
    70 (: write-exn-condition (condition #!optional output-port string string -> void))
    71 ;
    7270;from 'write-exception' of https://github.com/dleslie/geiser/blob/master/scheme/chicken/geiser/emacs.scm
    7371(define (write-exn-condition cnd
  • release/5/condition-utils/trunk/tests/run.scm

    r38466 r38965  
    99;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    1010
    11 (import (only (chicken pathname) make-pathname))
     11(import (only (chicken pathname)
     12  make-pathname pathname-file pathname-replace-directory pathname-strip-extension))
    1213(import (only (chicken process) system))
    1314(import (only (chicken process-context) argv))
    1415(import (only (chicken format) format))
     16(import (only (chicken file) file-exists? find-files))
     17(import (only (chicken irregex) irregex irregex-match?))
    1518
    16 (define (test-filename test-name)
    17   (string-append test-name "-test") )
     19(define *args* (argv))
    1820
    1921(define (egg-name args #!optional (def EGG-NAME))
    2022  (cond
    21     ((<= 4 (length *args*))
    22       (cadddr *args*) )
    23     (def
    24       def )
     23    ((<= 4 (length *args*)) (cadddr *args*) )
     24    (def                    def )
    2525    (else
    26       (error 'test "cannot determine egg-name") ) ) )
    27 
    28 ;;
    29 
    30 (define *args* (argv))
    31 (define *egg* (egg-name *args*))
    32 (define *tests* `(,*egg*))
     26      (error 'run "cannot determine egg-name") ) ) )
    3327
    3428(define *current-directory* (cond-expand (unix "./") (else #f)))
     29(define *egg* (egg-name *args*))
    3530
    3631;no -disable-interrupts or -no-lambda-info
    3732(define *csc-options* "-inline-global -local -inline \
    3833  -specialize -optimize-leaf-routines -clustering -lfa2 \
    39   -no-trace -unsafe")
     34  -no-trace -unsafe \
     35  -strict-types")
    4036
    41 (define (run-test-evaluated test-name test-source)
    42   (format #t "*** ~A - csi ***~%" test-name)
    43   (system (string-append "csi -s " test-source)) )
     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))
    4440
    45 (define (run-test-compiled test-name test-source csc-options)
    46   (format #t "*** ~A - csc ~A ***~%" test-name csc-options)
     41(define (ensure-test-source-name name)
     42  (if (irregex-match? *test-files-rx* name)
     43    name
     44    (make-pathname *current-directory* (test-filename name) "scm") ) )
     45
     46(define (run-test-evaluated source)
     47  (format #t "*** ~A - csi ***~%" (pathname-file source))
     48  (system (string-append "csi -s " source)) )
     49
     50(define (run-test-compiled source csc-options)
     51  (format #t "*** ~A - csc ~A ***~%" (pathname-file source) csc-options)
    4752  ;csc output is in current directory
    48   (system (string-append "csc" " " csc-options " " test-source))
    49   (system (make-pathname *current-directory* (test-filename test-name))) )
     53  (system (string-append "csc" " " csc-options " " source))
     54  (system (pathname-replace-directory (pathname-strip-extension source) *current-directory*)) )
    5055
    5156;;;
    5257
    53 (define (run-test #!optional (test-name *egg*) (csc-options *csc-options*))
    54   (let ((test-source (make-pathname #f (test-filename test-name) "scm")))
    55     (run-test-evaluated test-name test-source)
     58(define (run-test #!optional (name *egg*) (csc-options *csc-options*))
     59  (let (
     60    (source (ensure-test-source-name name)) )
     61    (unless (file-exists? source)
     62      (error 'run "no such file" source) )
     63    (run-test-evaluated source)
    5664    (newline)
    57     (run-test-compiled test-name test-source csc-options) ) )
     65    (run-test-compiled source csc-options) ) )
    5866
    59 (define (run-tests #!optional (test-names *tests*) (csc-options *csc-options*))
    60   (for-each (cut run-test <> csc-options) test-names) )
     67(define (run-tests #!optional (tests (test-files)) (csc-options *csc-options*))
     68  (for-each (cut run-test <> csc-options) tests) )
    6169
    6270;;; Do Test
Note: See TracChangeset for help on using the changeset viewer.