Changeset 35238 in project


Ignore:
Timestamp:
03/04/18 06:27:36 (7 months ago)
Author:
kon
Message:

re-flow, check range has multi-value return

Location:
release/4/check-errors/trunk
Files:
1 added
9 edited

Legend:

Unmodified
Added
Removed
  • release/4/check-errors/trunk/check-errors.meta

    r33623 r35238  
    99 (depends (setup-helper "1.5.2"))
    1010 (test-depends test)
    11  (files "check-errors.meta" "check-errors.scm" "type-errors.scm" "check-errors.setup" "srfi-4-errors.scm" "srfi-4-checks.scm" "inline-type-checks.scm" "type-checks.scm" "tests/run.scm") )
     11 (files
     12  "check-errors.meta" "check-errors.setup"
     13  "check-errors.scm" "type-errors.scm"
     14  "srfi-4-errors.scm" "srfi-4-checks.scm"
     15  "inline-type-checks.scm"
     16  "type-checks.scm"
     17  "tests/run.scm" "tests/check-errors-test.scm") )
  • release/4/check-errors/trunk/check-errors.scm

    r34212 r35238  
    55(module check-errors ()
    66
    7 (import scheme)
    8 
    9 (import chicken foreign)
     7(import scheme chicken foreign)
    108
    119(reexport type-checks type-errors srfi-4-checks srfi-4-errors)
  • release/4/check-errors/trunk/check-errors.setup

    r34407 r35238  
    77; Do not use -local with error modules so error & warning can be rebound.
    88
    9 (setup-shared+static-extension-module 'type-errors (extension-version "2.1.0")
     9(setup-shared+static-extension-module 'type-errors (extension-version "2.2.0")
    1010  #:inline? #t
    1111  #:types? #t
    1212  #:compile-options '(-fixnum-arithmetic -no-procedure-checks -no-bound-checks))
    1313
    14 (setup-shared+static-extension-module 'srfi-4-errors (extension-version "2.1.0")
     14(setup-shared+static-extension-module 'srfi-4-errors (extension-version "2.2.0")
    1515  #:inline? #t
    1616  #:types? #t
    1717  #:compile-options '(-fixnum-arithmetic -no-procedure-checks -no-bound-checks))
    1818
    19 (setup-shared+static-extension-module 'type-checks (extension-version "2.1.0")
     19(setup-shared+static-extension-module 'type-checks (extension-version "2.2.0")
    2020  #:inline? #t
    2121  #:types? #t
     
    2323  #:files '("inline-type-checks.scm"))
    2424
    25 (setup-shared+static-extension-module 'srfi-4-checks (extension-version "2.1.0")
     25(setup-shared+static-extension-module 'srfi-4-checks (extension-version "2.2.0")
    2626  #:inline? #t
    2727  #:types? #t
    2828  #:compile-options '(-optimize-level 3 -debug-level 1 -no-procedure-checks -no-bound-checks))
    2929
    30 (install-extension 'check-errors '() `((version ,(extension-version "2.1.0"))))
     30(install-extension 'check-errors '() `((version ,(extension-version "2.2.0"))))
    3131
    32 (setup-shared+static-extension-module 'check-errors (extension-version "2.1.0")
     32(setup-shared+static-extension-module 'check-errors (extension-version "2.2.0")
    3333  #:inline? #t
    3434  #:types? #t
  • release/4/check-errors/trunk/inline-type-checks.scm

    r34206 r35238  
    2929        (lambda (frm rnm cmp)
    3030          (let ((_define-inline (rnm 'define-inline)))
    31             (let* ((typ (cadr frm))
    32                    (typstr (symbol->string typ))
    33                    (nam (string->symbol (string-append "%check-" typstr))) )
     31            (let* (
     32              (typ (cadr frm))
     33              (typstr (symbol->string typ))
     34              (nam (string->symbol (string-append "%check-" typstr))) )
    3435              `(,_define-inline (,nam loc obj . _) obj) ) ) ) ) )
    3536
     
    5960      (er-macro-transformer
    6061        (lambda (frm rnm cmp)
    61           (let ((_define-inline (rnm 'define-inline))
    62                 (_unless (rnm 'unless))
    63                 (_optional (rnm 'optional)) )
    64             (let* ((typ (cadr frm))
    65                    (typstr (symbol->string typ))
    66                    (pred (if (not (null? (cddr frm)))
    67                            (caddr frm)
    68                            (string->symbol (string-append "%" typstr "?"))))
    69                    (nam (string->symbol (string-append "%check-" typstr)))
    70                    (errnam (string->symbol (string-append "error-" typstr))) )
     62          (let (
     63            (_define-inline (rnm 'define-inline))
     64            (_unless (rnm 'unless))
     65            (_optional (rnm 'optional)) )
     66            (let* (
     67              (typ (cadr frm))
     68              (typstr (symbol->string typ))
     69              (pred
     70                (if (not (null? (cddr frm)))
     71                  (caddr frm)
     72                  (string->symbol (string-append "%" typstr "?"))))
     73              (nam (string->symbol (string-append "%check-" typstr)))
     74              (errnam (string->symbol (string-append "error-" typstr))) )
    7175              `(,_define-inline (,nam loc obj . args)
    7276                 (,_unless (,pred obj)
  • release/4/check-errors/trunk/srfi-4-checks.scm

    r34206 r35238  
    1616  check-f64vector)
    1717
    18 (import scheme)
    19 
    20 (import chicken)
    21 
    22 (require-extension srfi-4)
    23 
    24 (import (only data-structures any?))
    25 (require-library data-structures)
    26 
    27 (import (only type-checks define-check-type))
    28 (require-library type-checks)
    29 
    30 (require-extension srfi-4-errors)
     18(import scheme chicken)
     19(use
     20  srfi-4
     21  (only data-structures any?)
     22  (only type-checks define-check-type)
     23  srfi-4-errors)
    3124
    3225(define-check-type s8vector)
  • release/4/check-errors/trunk/srfi-4-errors.scm

    r34206 r35238  
    1616  error-f64vector)
    1717
    18 (import scheme)
    19 
    20 (import chicken)
    21 
    22 (require-extension srfi-4)
    23 
    24 (import (only type-errors define-error-type))
    25 (require-library type-errors)
     18(import scheme chicken)
     19(use
     20  srfi-4
     21  (only type-errors define-error-type))
    2622
    2723(define-error-type s8vector)
  • release/4/check-errors/trunk/tests/run.scm

    r34425 r35238  
    1 ;;;; check-errors Test
    21
    3 (use test)
    4 (use srfi-4)
    5 (use check-errors)
     2(define EGG-NAME "check-errors")
    63
    7 ;;; Basic
     4;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    85
    9 (test-group "check for failure"
    10   (test-error (check-fixnum 'test 1.0))
    11   (test-error (check-positive-fixnum 'test 0))
    12   (test-error (check-negative-fixnum 'test 0))
    13   (test-error (check-natural-fixnum 'test -1))
    14   (test-error (check-non-positive-fixnum 'test 1))
    15   (test-error (check-flonum 'test 1))
    16   (test-error (check-integer 'test 0.1))
    17   (test-error (check-positive-integer 'test 0.0))
    18   (test-error (check-natural-integer 'test -1.0))
    19   (test-error (check-number 'test 'x))
    20   (test-error (check-positive-number 'test -0.1))
    21   (test-error (check-natural-number 'test -0.1))
    22   (test-error (check-procedure 'test 'x))
    23   (test-error (check-input-port 'test 'x))
    24   (test-error (check-output-port 'test 'x))
    25   (test-error (check-list 'test 'x))
    26   (test-error (check-pair 'test 'x))
    27   (test-error (check-blob 'test 'x))
    28   (test-error (check-vector 'test 'x))
    29   (test-error (check-structure 'test 'x))
    30   (test-error (check-symbol 'test 1))
    31   (test-error (check-keyword 'test 'x))
    32   (test-error (check-string 'test 'x))
    33   (test-error (check-char 'test 'x))
    34   (test-error (check-boolean 'test 'x))
    35   (test-error (check-alist 'test 'x))
    36   (test-error (check-alist 'test '(23)))
    37   (test-error (check-alist 'test '((a . 1) ())))
    38   (test-error (check-minimum-argument-count 'test 0 1))
    39   (test-error (check-argument-count 'test 1 0))
    40   (test-error (check-open-interval 'test 1.1 1.1 1.2))
    41   (test-error (check-open-interval 'test 1.2 1.1 1.2))
    42   (test-error (check-closed-interval 'test 1.0 1.1 1.2))
    43   (test-error (check-closed-interval 'test 1.3 1.1 1.2))
    44   (test-error (check-half-open-interval 'test 1.1 1.1 1.2))
    45   (test-error (check-half-open-interval 'test 1.3 1.1 1.2))
    46   (test-error (check-half-closed-interval 'test 1.2 1.1 1.2))
    47   (test-error (check-half-closed-interval 'test 1.3 1.1 1.2))
    48   (test-error (check-range 'test 0 -1))
    49 )
     6(use files)
    507
    51 ;should produce no output
    52 (check-fixnum 'test 1)
    53 (check-positive-fixnum 'test 1)
    54 (check-negative-fixnum 'test -1)
    55 (check-natural-fixnum 'test 0)
    56 (check-non-positive-fixnum 'test 0)
    57 (check-flonum 'test 1.0)
    58 (check-integer 'test 1.0)
    59 (check-integer 'test 1)
    60 (check-positive-integer 'test 1.0)
    61 (check-positive-integer 'test 1)
    62 (check-natural-integer 'test 0.0)
    63 (check-natural-integer 'test 0)
    64 (check-number 'test 1.0)
    65 (check-number 'test 1)
    66 (check-positive-number 'test 1.0)
    67 (check-positive-number 'test 1)
    68 (check-natural-number 'test 0.0)
    69 (check-natural-number 'test 0)
    70 (check-procedure 'test check-procedure)
    71 (check-input-port 'test (current-input-port))
    72 (check-output-port 'test (current-output-port))
    73 (check-list 'test '(x))
    74 (check-pair 'test '(x . y))
    75 (check-blob 'test (string->blob "x"))
    76 (check-vector 'test '#(x))
    77 (check-structure 'test (##sys#make-structure 'x) 'x)
    78 (check-symbol 'test 'x)
    79 (check-keyword 'test #:x)
    80 (check-string 'test "x")
    81 (check-char 'test #\x)
    82 (check-boolean 'test #t)
    83 (check-alist 'test '())
    84 (check-alist 'test '((a . 1)))
    85 (check-alist 'test '((a . 1) (b . 2)))
    86 (check-minimum-argument-count 'test 1 1)
    87 (check-argument-count 'test 1 1)
    88 (check-open-interval 'test 1.11 1.1 1.2)
    89 (check-closed-interval 'test 1.1 1.1 1.2)
    90 (check-half-open-interval 'test 1.11 1.1 1.2)
    91 (check-half-closed-interval 'test 1.11 1.1 1.2)
    92 (check-range 'test 0 1)
     8;no -disable-interrupts
     9(define *csc-options* "-inline-global -scrutinize -optimize-leaf-routines -local -inline -specialize -unsafe -no-trace -no-lambda-info -clustering -lfa2")
    9310
    94 (define-syntax capture-error
    95         (syntax-rules ()
    96                 ((capture-error ?expr)
    97                         (handle-exceptions exp
    98                                 (let ((loc ((condition-property-accessor 'exn 'location) exp))
    99                                                         (msg ((condition-property-accessor 'exn 'message) exp))
    100                                                         (args ((condition-property-accessor 'exn 'arguments) exp)) )
    101                                                 (list loc msg args) )
    102                                 ?expr ) ) ) )
     11(define *args* (argv))
    10312
    104 (test "Literal Message 1"
    105         '(test "bad argument type - not a fixnum" (#f))
    106         (capture-error (check-fixnum 'test #f)) )
    107 (test "Literal Message 2"
    108         '(test "bad `num' argument type - not a fixnum" (#f))
    109         (capture-error (check-fixnum 'test #f 'num)) )
     13(define (test-name #!optional (eggnam EGG-NAME))
     14  (string-append eggnam "-test") )
    11015
    111 (test-group "define-check+error-type"
    112   (define (foo? obj) #t)
    113   (define-check+error-type foo)
    114   (test-assert error-foo)
    115   (test-assert check-foo)
    116   (define-check+error-type foo1 foo?)
    117   (test-assert error-foo1)
    118   (test-assert check-foo1)
    119   (define-check+error-type foo2 foo? "foodie")
    120   (test-assert error-foo2)
    121   (test-assert check-foo2)
    122 )
     16(define (egg-name #!optional (def EGG-NAME))
     17  (cond
     18    ((<= 4 (length *args*))
     19      (cadddr *args*) )
     20    (def
     21      def )
     22    (else
     23      (error 'test "cannot determine egg-name") ) ) )
    12324
    124 ;;; SRFI 4
     25;;;
    12526
    126 (test-group "srfi-4-checks"
    127   (test-error (check-u16vector 'test 23))
     27(set! EGG-NAME (egg-name))
    12828
    129   ;no output is good
    130   (let ((tv (make-s8vector 2)))
    131     (check-s8vector 'test tv) )
    132 )
     29(define (run-test #!optional (eggnam EGG-NAME) (cscopts *csc-options*))
     30  (let ((tstnam (test-name eggnam)))
     31    (print "*** csi ***")
     32    (system (string-append "csi -s " (make-pathname #f tstnam "scm")))
     33    (newline)
     34    (print "*** csc (" cscopts ") ***")
     35    (system (string-append "csc" " " cscopts " " (make-pathname #f tstnam "scm")))
     36    (system (make-pathname (cond-expand (unix "./") (else #f)) tstnam)) ) )
    13337
    134 (test-exit)
     38(define (run-tests eggnams #!optional (cscopts *csc-options*))
     39  (for-each (cut run-test <> cscopts) eggnams) )
     40
     41;;;
     42
     43(run-test)
  • release/4/check-errors/trunk/type-checks.scm

    r34425 r35238  
    5353  check-cardinal-number)
    5454
    55 (import chicken scheme type-errors)
    56 
    57 (require-library type-errors)
     55(import chicken scheme)
     56(use type-errors)
    5857
    5958(declare (bound-to-procedure ##sys#structure?))
     59
     60;;
     61
     62(define-syntax unbound-value
     63        (syntax-rules ()
     64                ((_)
     65                        (##sys#slot '##sys#arbitrary-unbound-symbol 0) ) ) )
     66
     67(define-syntax unbound-value?
     68        (syntax-rules ()
     69                ((_ ?val)
     70                        (eq? (unbound-value) ?val) ) ) )
     71
     72(define-syntax unbound?
     73        (syntax-rules ()
     74                ((_ ?sym)
     75                        (unbound-value? (##sys#slot ?sym 0)) ) ) )
    6076
    6177;;
     
    7591        (lambda (frm rnm cmp)
    7692          (let ((_define (rnm 'define)))
    77             (let* ((typ (cadr frm))
    78                    (nam (string->symbol (string-append "check-" (symbol->string typ)))) )
     93            (let* (
     94              (typ (cadr frm))
     95              (nam (string->symbol (string-append "check-" (symbol->string typ)))) )
    7996              `(,_define (,nam loc obj . _) obj) ) ) ) ) )
    8097
     
    120137            (or
    121138              (null? ls)
    122               (and (pair? (car ls)) (loop (cdr ls) ) ) ) ) ) ) )
     139              (and
     140                ;since anything can be a key no stronger check possible
     141                (pair? (car ls))
     142                (loop (cdr ls) ) ) ) ) ) ) )
    123143
    124144    (define (plist? obj)
     
    139159      (er-macro-transformer
    140160        (lambda (frm rnm cmp)
    141           (let ((_define (rnm 'define))
    142                 (_unless (rnm 'unless))
    143                 (_optional (rnm 'optional)) )
    144             (let* ((typ (cadr frm))
    145                    (typstr (symbol->string typ))
    146                    (pred (if (not (null? (cddr frm))) (caddr frm)
    147                             (string->symbol (string-append typstr "?"))))
    148                    (nam (string->symbol (string-append "check-" typstr)))
    149                    (errnam (string->symbol (string-append "error-" typstr))) )
     161          (let (
     162            (_define (rnm 'define))
     163            (_unless (rnm 'unless))
     164            (_optional (rnm 'optional)) )
     165            (let* (
     166              (typ (cadr frm))
     167              (typstr (symbol->string typ))
     168              (pred
     169                (if (not (null? (cddr frm)))
     170                  (caddr frm)
     171                  (string->symbol (string-append typstr "?"))))
     172              (nam (string->symbol (string-append "check-" typstr)))
     173              (errnam (string->symbol (string-append "error-" typstr))) )
    150174              `(,_define (,nam loc obj . args)
    151175                 (,_unless (,pred obj)
     
    155179    ;;Is the object non-void?
    156180
    157     (define (defined-value? obj) (not (eq? (void) obj)))
     181    (define (defined-value? obj)
     182      (not (eq? (void) obj)) )
    158183
    159184    ;;Is the object bound to value?
     
    162187    ;could only occur in a rather unsafe calling environnment.
    163188
    164     (define (bound-value? obj) (##core#inline "C_unboundvaluep" obj))
     189    (define (bound-value? obj)
     190      (unbound? obj)
     191      #;
     192      ((##core#inline "C_unboundvaluep" n) obj) )
    165193
    166194    ;;
     
    305333  (unless (<= start end)
    306334    (apply error-range loc start end args) )
    307   (void) )
     335  (values start end) )
    308336
    309337(define (check-minimum-argument-count loc argc minargc)
     
    324352  (er-macro-transformer
    325353    (lambda (frm rnm cmp)
    326       (let ((_define-check-type (rnm 'define-check-type))
    327             (_define-error-type (rnm 'define-error-type)) )
    328         (let* ((typ (cadr frm))
    329                (pred (and (not (null? (cddr frm))) (caddr frm)))
    330                (mesg (and pred (not (null? (cdddr frm))) (cadddr frm))) )
     354      (let (
     355        (_define-check-type (rnm 'define-check-type))
     356        (_define-error-type (rnm 'define-error-type)) )
     357        (let* (
     358          (typ (cadr frm))
     359          (pred (and (not (null? (cddr frm))) (caddr frm)))
     360          (mesg (and pred (not (null? (cdddr frm))) (cadddr frm))) )
    331361          `(begin
    332362             (,_define-error-type ,typ ,@(if mesg `(,mesg) '()))
  • release/4/check-errors/trunk/type-errors.scm

    r34425 r35238  
    6969  error-cardinal-number)
    7070
    71 (import scheme)
    72 
    73 (import chicken foreign)
    74 
    75 (import (only data-structures ->string conc))
    76 (require-library data-structures)
     71(import scheme chicken foreign)
     72(use
     73  (only data-structures ->string conc))
    7774
    7875(declare
    79   (pure
    80     vowel? appropriate-indefinite-article
    81     make-error-type-message make-type-name-message
    82     make-bad-argument-message)
    8376  (bound-to-procedure
    8477    ##sys#signal-hook ##sys#error-hook) )
     
    8780
    8881(define (->boolean obj)
    89   (and obj #t ) )
     82  (and
     83    obj
     84    #t ) )
    9085
    9186;(maybe a problem with expansion environment namespace pollution)
     
    127122
    128123(define (warning-argument-type loc obj typnam #!optional argnam)
    129   (let ((typ-msg (conc (make-error-type-message typnam argnam) #\: #\space) )
    130         (obj-str (->string obj) ) )
    131     (let* ((wrn-msg (string-append typ-msg obj-str) )
    132            (wrn-msg
    133             (if loc
    134               (string-append (location-message loc) wrn-msg)
    135               wrn-msg ) ) )
     124  (let (
     125    (typ-msg (conc (make-error-type-message typnam argnam) #\: #\space))
     126    (obj-str (->string obj)) )
     127    (let* (
     128      (wrn-msg (string-append typ-msg obj-str))
     129      (wrn-msg
     130        (if loc
     131          (string-append (location-message loc) wrn-msg)
     132          wrn-msg)) )
    136133      (warning wrn-msg) ) ) )
    137134
     
    150147  (er-macro-transformer
    151148    (lambda (frm rnm cmp)
    152       (let ((_define (rnm 'define))
    153             (_#!optional (rnm '#!optional))
    154             (_error-argument-type (rnm 'error-argument-type)) )
    155         (let* ((typ (cadr frm))
    156                (typstr (symbol->string typ))
    157                (typnam (if (null? (cddr frm)) typstr (caddr frm)))
    158                (nam (string->symbol (string-append "error-" typstr))) )
     149      (let (
     150        (_define (rnm 'define))
     151        (_#!optional (rnm '#!optional))
     152        (_error-argument-type (rnm 'error-argument-type)) )
     153        (let* (
     154          (typ (cadr frm))
     155          (typstr (symbol->string typ))
     156          (typnam (if (null? (cddr frm)) typstr (caddr frm)))
     157          (nam (string->symbol (string-append "error-" typstr))) )
    159158          `(,_define (,nam loc obj ,_#!optional argnam)
    160159             (,_error-argument-type loc obj ,typnam argnam) ) ) ) ) ) )
     
    218217
    219218(define (error-range loc start end #!optional argnam)
    220   (signal-bounds-error loc
     219  (signal-bounds-error
     220    loc
    221221    (make-bad-argument-message argnam)
    222222    start end) )
    223223
    224224(define (error-interval loc num lft min max rgt #!optional argnam)
    225   (signal-bounds-error loc
     225  (signal-bounds-error
     226    loc
    226227    (conc (make-bad-argument-message argnam) " must be in " lft min #\space max rgt)
    227228    num) )
Note: See TracChangeset for help on using the changeset viewer.