Changeset 34403 in project


Ignore:
Timestamp:
08/27/17 04:29:29 (4 weeks ago)
Author:
kon
Message:

re-flow, add neg & non-pos

Location:
release/4/check-errors/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/check-errors/trunk/tests/run.scm

    r27970 r34403  
    1010  (test-error (check-fixnum 'test 1.0))
    1111  (test-error (check-positive-fixnum 'test 0))
     12  (test-error (check-negative-fixnum 'test 0))
    1213  (test-error (check-natural-fixnum 'test -1))
     14  (test-error (check-non-positive-fixnum 'test 1))
    1315  (test-error (check-flonum 'test 1))
    1416  (test-error (check-integer 'test 0.1))
     
    4951(check-fixnum 'test 1)
    5052(check-positive-fixnum 'test 1)
     53(check-negative-fixnum 'test -1)
    5154(check-natural-fixnum 'test 0)
     55(check-non-positive-fixnum 'test 0)
    5256(check-flonum 'test 1.0)
    5357(check-integer 'test 1.0)
  • release/4/check-errors/trunk/type-checks.scm

    r34206 r34403  
    11;;;; type-checks.scm
     2;;;; Kon Lovett, Apr '09
    23;;;; Kon Lovett, Jun '17
    3 ;;;; Kon Lovett, Apr '09
    4 
    5 ; Chicken Generic Arithmetic!
     4
     5;; Issues
     6;;
     7;; - Chicken Generic Arithmetic!
     8;;
     9;; - check-negative-* (< X 0), check-non-positive-* (<= X 0)
    610
    711(module type-checks
    812
    913(;export
    10 define-check-type
    11 define-check+error-type
    12 check-defined-value
    13 check-bound-value
    14 check-number
    15 check-fixnum
    16 check-flonum
    17 check-integer
    18 check-real
    19 check-complex
    20 check-rational
    21 check-exact
    22 check-inexact
    23 check-positive-fixnum
    24 check-natural-fixnum
    25 check-positive-integer
    26 check-natural-integer
    27 check-positive-number
    28 check-natural-number
    29 check-procedure check-closure
    30 check-input-port
    31 check-output-port
    32 check-list
    33 check-pair
    34 check-blob
    35 check-vector
    36 check-structure
    37 check-record
    38 check-record-type
    39 check-symbol
    40 check-keyword
    41 check-string
    42 check-char
    43 check-boolean
    44 check-alist
    45 check-minimum-argument-count check-argument-count
    46 check-closed-interval check-open-interval
    47 check-half-closed-interval check-half-open-interval
    48 ;
    49 check-cardinal-fixnum
    50 check-cardinal-integer
    51 check-cardinal-number)
     14  define-check-type
     15  define-check+error-type
     16  check-defined-value
     17  check-bound-value
     18  check-number
     19  check-fixnum
     20  check-flonum
     21  check-integer
     22  check-real
     23  check-complex
     24  check-rational
     25  check-exact
     26  check-inexact
     27  check-positive-fixnum check-natural-fixnum check-negative-fixnum check-non-positive-fixnum
     28  check-positive-integer check-natural-integer check-negative-integer check-non-positive-integer
     29  check-positive-number check-natural-number check-negative-number check-non-positive-number
     30  check-procedure check-closure
     31  check-input-port
     32  check-output-port
     33  check-list
     34  check-pair
     35  check-blob
     36  check-vector
     37  check-structure
     38  check-record
     39  check-record-type
     40  check-symbol
     41  check-keyword
     42  check-string
     43  check-char
     44  check-boolean
     45  check-alist
     46  check-minimum-argument-count check-argument-count
     47  check-closed-interval check-open-interval
     48  check-half-closed-interval check-half-open-interval
     49  ;
     50  check-cardinal-fixnum
     51  check-cardinal-integer
     52  check-cardinal-number)
    5253
    5354(import chicken scheme type-errors)
     
    8485    (define (check-positive-fixnum loc obj . _) obj)
    8586    (define (check-natural-fixnum loc obj . _) obj)
     87    (define (check-negative-fixnum loc obj . _) obj)
     88    (define (check-non-positive-fixnum loc obj . _) obj)
    8689    (define (check-positive-integer loc obj . _) obj)
    8790    (define (check-natural-integer loc obj . _) obj)
     91    (define (check-negative-integer loc obj . _) obj)
     92    (define (check-non-positive-integer loc obj . _) obj)
    8893    (define (check-positive-number loc obj . _) obj)
    8994    (define (check-natural-number loc obj . _) obj)
     95    (define (check-negative-number loc obj . _) obj)
     96    (define (check-non-positive-number loc obj . _) obj)
    9097    (define (check-structure loc obj . _) obj)
    9198    (define (check-record loc obj . _) obj)
     
    105112
    106113    (define (alist? obj)
    107       (or (null? obj)
    108           (and (list? obj)
    109                (let loop ((ls obj))
    110                  (or (null? ls)
    111                      (and (pair? (car ls))
    112                           (loop (cdr ls) ) ) ) ) ) ) )
     114      (or
     115        (null? obj)
     116        (and
     117          (pair? obj)
     118          (let loop ((ls obj))
     119            (or
     120              (null? ls)
     121              (and (pair? (car ls)) (loop (cdr ls) ) ) ) ) ) ) )
    113122
    114123    (define (plist? obj)
     
    166175      obj )
    167176
     177    (define (check-negative-fixnum loc obj . args)
     178      (unless (and (fixnum? obj) (fx> 0 obj))
     179        (error-negative-fixnum loc obj (optional args)))
     180      obj )
     181
     182    (define (check-non-positive-fixnum loc obj . args)
     183      (unless (and (fixnum? obj) (fx>= 0 obj))
     184        (error-non-positive-fixnum loc obj (optional args)))
     185      obj )
     186
    168187    ;;
    169188
     
    178197      obj )
    179198
     199    (define (check-negative-integer loc obj . args)
     200      (unless (and (integer? obj) (negative? obj))
     201        (error-negative-integer loc obj (optional args)))
     202      obj )
     203
     204    (define (check-non-positive-integer loc obj . args)
     205      (unless (and (integer? obj) (>= 0 obj))
     206        (error-non-positive-integer loc obj (optional args)))
     207      obj )
     208
    180209    ;;
    181210
     
    188217      (unless (and (number? obj) (<= 0 obj))
    189218        (error-natural-number loc obj (optional args)))
     219      obj )
     220
     221    (define (check-negative-number loc obj . args)
     222      (unless (and (number? obj) (negative? obj))
     223        (error-negative-number loc obj (optional args)))
     224      obj )
     225
     226    (define (check-non-positive-number loc obj . args)
     227      (unless (and (number? obj) (>= 0 obj))
     228        (error-non-positive-number loc obj (optional args)))
    190229      obj )
    191230
  • release/4/check-errors/trunk/type-errors.scm

    r34212 r34403  
    3434  error-exact
    3535  error-inexact
    36   error-positive-number
    37   error-natural-number
    38   error-positive-fixnum
    39   error-natural-fixnum
    40   error-positive-integer
    41   error-natural-integer
     36  error-positive-number error-natural-number error-negative-number error-non-positive-number
     37  error-positive-fixnum error-natural-fixnum error-negative-fixnum error-non-positive-fixnum
     38  error-positive-integer error-natural-integer error-negative-integer error-non-positive-integer
    4239  error-procedure error-closure
    4340  error-input-port
     
    176173(define-error-type positive-number)
    177174(define-error-type natural-number)
     175(define-error-type negative-number)
     176(define-error-type non-positive-number)
    178177(define-error-type positive-fixnum)
    179178(define-error-type natural-fixnum)
     179(define-error-type negative-fixnum)
     180(define-error-type non-positive-fixnum)
    180181(define-error-type positive-integer)
    181182(define-error-type natural-integer)
     183(define-error-type negative-integer)
     184(define-error-type non-positive-integer)
    182185(define-error-type procedure)
    183186(define error-closure error-procedure)
Note: See TracChangeset for help on using the changeset viewer.