source: project/release/4/check-errors/trunk/type-checks.scm @ 35474

Last change on this file since 35474 was 35474, checked in by kon, 15 months ago

hum, working again - what i get for using ##core

File size: 10.5 KB
RevLine 
[14084]1;;;; type-checks.scm
[34403]2;;;; Kon Lovett, Apr '09
[34206]3;;;; Kon Lovett, Jun '17
[14084]4
[34403]5;; Issues
6;;
7;; - Chicken Generic Arithmetic!
8;;
9;; - check-negative-* (< X 0), check-non-positive-* (<= X 0)
[17344]10
[19111]11(module type-checks
[14084]12
[34206]13(;export
[34403]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
[34425]49  check-range
[34403]50  ;
51  check-cardinal-fixnum
52  check-cardinal-integer
53  check-cardinal-number)
[19111]54
[35238]55(import chicken scheme)
56(use type-errors)
[14084]57
[34206]58(declare (bound-to-procedure ##sys#structure?))
[15995]59
[14084]60;;
61
[35238]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)) ) ) )
76
77;;
78
[34425]79;maybe a problem with expansion environment namespace pollution
[19227]80(define-for-syntax (symbolize . elts)
81  (string->symbol (apply conc (map strip-syntax elts))) )
82
83;;
84
[14084]85(cond-expand
[16021]86
[14084]87  (unsafe
[16021]88
[14139]89    (define-syntax define-check-type
[16201]90      (er-macro-transformer
91        (lambda (frm rnm cmp)
92          (let ((_define (rnm 'define)))
[35238]93            (let* (
94              (typ (cadr frm))
95              (nam (string->symbol (string-append "check-" (symbol->string typ)))) )
[19111]96              `(,_define (,nam loc obj . _) obj) ) ) ) ) )
[14084]97
[34425]98    ;;Backwards
[34206]99    (define (check-cardinal-fixnum loc obj . _) obj)
100    (define (check-cardinal-integer loc obj . _) obj)
101    (define (check-cardinal-number loc obj . _) obj)
[19889]102
[34206]103    (define (check-positive-fixnum loc obj . _) obj)
104    (define (check-natural-fixnum loc obj . _) obj)
[34403]105    (define (check-negative-fixnum loc obj . _) obj)
106    (define (check-non-positive-fixnum loc obj . _) obj)
[34206]107    (define (check-positive-integer loc obj . _) obj)
108    (define (check-natural-integer loc obj . _) obj)
[34403]109    (define (check-negative-integer loc obj . _) obj)
110    (define (check-non-positive-integer loc obj . _) obj)
[34206]111    (define (check-positive-number loc obj . _) obj)
112    (define (check-natural-number loc obj . _) obj)
[34403]113    (define (check-negative-number loc obj . _) obj)
114    (define (check-non-positive-number loc obj . _) obj)
[34206]115    (define (check-structure loc obj . _) obj)
116    (define (check-record loc obj . _) obj)
117    (define (check-record-type loc obj . _) obj)
118    (define (check-minimum-argument-count loc obj . _) obj)
119    (define (check-argument-count loc obj . _) obj)
120    (define (check-closed-interval loc obj . _) obj)
121    (define (check-open-interval loc obj . _) obj)
122    (define (check-half-closed-interval loc obj . _) obj)
123    (define (check-half-open-interval loc obj . _) obj) )
[14084]124
125  (else
126
[34425]127    ;;These are weak predicates. Only check for structure.
[19889]128
[19227]129    (export alist? plist?)
[16201]130
[16021]131    (define (alist? obj)
[34403]132      (or
133        (null? obj)
134        (and
135          (pair? obj)
136          (let loop ((ls obj))
137            (or
138              (null? ls)
[35238]139              (and
140                ;since anything can be a key no stronger check possible
141                (pair? (car ls))
142                (loop (cdr ls) ) ) ) ) ) ) )
[16021]143
[19227]144    (define (plist? obj)
[19889]145      ;since anything can be a key no stronger check possible
146      (and (list? obj) (even? (length obj))) )
[19227]147
[14139]148    ;;
[14084]149
[34425]150    ;<symbol>          : <pred> is '<symbol>?'
151    ;<symbol> <symbol> : <pred> is <symbol>
152    ;->
153    ;(define (check-<symbol> loc obj . args)
154    ;  (unless (<pred> obj)
155    ;    (error-<symbol> loc obj (optional args)))
156    ;  obj )
[14139]157
158    (define-syntax define-check-type
[16201]159      (er-macro-transformer
160        (lambda (frm rnm cmp)
[35238]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))) )
[22412]174              `(,_define (,nam loc obj . args)
175                 (,_unless (,pred obj)
176                   (,errnam loc obj (,_optional args)))
[19111]177                 obj ) ) ) ) ) )
[16201]178
[34425]179    ;;Is the object non-void?
[19114]180
[35238]181    (define (defined-value? obj)
182      (not (eq? (void) obj)) )
[19114]183
[34425]184    ;;Is the object bound to value?
[19227]185
[34425]186    ;is obj the value from the de-ref of an unbound variable.
187    ;could only occur in a rather unsafe calling environnment.
[19227]188
[35238]189    (define (bound-value? obj)
[35474]190      (##core#inline "C_unboundvaluep" obj) )
[19227]191
[14084]192    ;;
193
[22412]194    (define (check-positive-fixnum loc obj . args)
[14139]195      (unless (and (fixnum? obj) (fx< 0 obj))
[22412]196        (error-positive-fixnum loc obj (optional args)))
[19111]197      obj )
[14084]198
[22412]199    (define (check-natural-fixnum loc obj . args)
[14139]200      (unless (and (fixnum? obj) (fx<= 0 obj))
[22412]201        (error-natural-fixnum loc obj (optional args)))
[19111]202      obj )
[14084]203
[34403]204    (define (check-negative-fixnum loc obj . args)
205      (unless (and (fixnum? obj) (fx> 0 obj))
206        (error-negative-fixnum loc obj (optional args)))
207      obj )
208
209    (define (check-non-positive-fixnum loc obj . args)
210      (unless (and (fixnum? obj) (fx>= 0 obj))
211        (error-non-positive-fixnum loc obj (optional args)))
212      obj )
213
[14084]214    ;;
215
[22412]216    (define (check-positive-integer loc obj . args)
[14084]217      (unless (and (integer? obj) (positive? obj))
[22412]218        (error-positive-integer loc obj (optional args)))
[19111]219      obj )
[14084]220
[22412]221    (define (check-natural-integer loc obj . args)
[14139]222      (unless (and (integer? obj) (<= 0 obj))
[22412]223        (error-natural-integer loc obj (optional args)))
[19111]224      obj )
[14084]225
[34403]226    (define (check-negative-integer loc obj . args)
227      (unless (and (integer? obj) (negative? obj))
228        (error-negative-integer loc obj (optional args)))
229      obj )
230
231    (define (check-non-positive-integer loc obj . args)
232      (unless (and (integer? obj) (>= 0 obj))
233        (error-non-positive-integer loc obj (optional args)))
234      obj )
235
[14084]236    ;;
237
[22412]238    (define (check-positive-number loc obj . args)
[19889]239      (unless (and (number? obj) (positive? obj))
[22412]240        (error-positive-number loc obj (optional args)))
[19111]241      obj )
[14084]242
[22412]243    (define (check-natural-number loc obj . args)
[19889]244      (unless (and (number? obj) (<= 0 obj))
[22412]245        (error-natural-number loc obj (optional args)))
[19111]246      obj )
[14084]247
[34403]248    (define (check-negative-number loc obj . args)
249      (unless (and (number? obj) (negative? obj))
250        (error-negative-number loc obj (optional args)))
251      obj )
252
253    (define (check-non-positive-number loc obj . args)
254      (unless (and (number? obj) (>= 0 obj))
255        (error-non-positive-number loc obj (optional args)))
256      obj )
257
[14084]258    ;;
259
[22412]260    (define (check-structure loc obj tag . args)
[14084]261      (unless (##sys#structure? obj tag)
[22412]262        (error-structure loc obj tag (optional args)))
[19111]263      obj )
[14084]264
[22412]265    (define (check-record loc obj tag . args)
[16021]266      (unless (##sys#structure? obj tag)
[22412]267        (error-record loc obj tag (optional args)))
[19111]268      obj )
[16021]269
[22412]270    (define (check-record-type loc obj tag . args)
[16021]271      (unless (##sys#structure? obj tag)
[22412]272        (error-record-type loc obj tag (optional args)))
[19111]273      obj ) ) )
[16021]274
[14139]275;;
[14084]276
[19114]277(define-check-type defined-value)
[19227]278(define-check-type bound-value)
[19114]279
[14139]280(define-check-type fixnum)
281(define-check-type flonum)
282(define-check-type integer)
[16201]283(define-check-type real)
284(define-check-type complex)
285(define-check-type rational)
286(define-check-type exact)
287(define-check-type inexact)
[14139]288(define-check-type number)
289(define-check-type symbol)
290(define-check-type keyword)
291(define-check-type string)
292(define-check-type char)
293(define-check-type boolean)
294(define-check-type procedure)
[19227]295(define check-closure check-procedure)
[14139]296(define-check-type input-port)
297(define-check-type output-port)
298(define-check-type list)
299(define-check-type pair)
300(define-check-type blob)
301(define-check-type vector)
[19227]302(define-check-type plist)
[15995]303(define-check-type alist)
304
[34425]305;closed interval
[22412]306(define (check-closed-interval loc num min max . args)
[16021]307  (unless (and (<= min num) (<= num max))
[22412]308    (error-closed-interval loc num min max (optional args)))
[19111]309  num )
[16021]310
[34425]311;open interval
[22412]312(define (check-open-interval loc num min max . args)
[16021]313  (unless (and (< min num) (< num max))
[22412]314    (error-open-interval loc num min max (optional args)))
[19111]315  num )
[16021]316
[34425]317;closed+open interval
[22412]318(define (check-half-open-interval loc num min max . args)
[16021]319  (unless (and (< min num) (<= num max))
[22412]320    (error-half-open-interval loc num min max (optional args)))
[19111]321  num )
[16021]322
[34425]323;open+closed interval
[22412]324(define (check-half-closed-interval loc num min max . args)
[16021]325  (unless (and (<= min num) (< num max))
[34206]326    (error-half-closed-interval loc num min max (optional args)))
[19111]327  num)
[16021]328
[34425]329;check half-closed-interval itself
330(define (check-range loc start end . args)
331  (unless (<= start end)
332    (apply error-range loc start end args) )
[35238]333  (values start end) )
[34425]334
[17344]335(define (check-minimum-argument-count loc argc minargc)
336  (unless (fx<= minargc argc)
[19111]337    (error-minimum-argument-count loc argc minargc))
338  argc )
[17344]339
340(define (check-argument-count loc argc maxargc)
341  (unless (fx<= argc maxargc)
[19111]342    (error-argument-count loc argc maxargc))
343  argc )
[17344]344
[14139]345;;
[14084]346
[34425]347;<type-symbol> [<type-predicate> [<message-string>]]
[15588]348
[14139]349(define-syntax define-check+error-type
[16201]350  (er-macro-transformer
351    (lambda (frm rnm cmp)
[35238]352      (let (
353        (_define-check-type (rnm 'define-check-type))
354        (_define-error-type (rnm 'define-error-type)) )
355        (let* (
356          (typ (cadr frm))
357          (pred (and (not (null? (cddr frm))) (caddr frm)))
358          (mesg (and pred (not (null? (cdddr frm))) (cadddr frm))) )
[16201]359          `(begin
360             (,_define-error-type ,typ ,@(if mesg `(,mesg) '()))
361             (,_define-check-type ,typ ,@(if pred `(,pred) '())) ) ) ) ) ) )
[14084]362
[19889]363;; Backwards
364
365(define check-cardinal-fixnum check-natural-fixnum)
366(define check-cardinal-integer check-natural-integer)
367(define check-cardinal-number check-natural-number)
368
[16021]369) ;module type-checks
Note: See TracBrowser for help on using the repository browser.