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

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

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

File size: 10.5 KB
Line 
1;;;; type-checks.scm
2;;;; Kon Lovett, Apr '09
3;;;; Kon Lovett, Jun '17
4
5;; Issues
6;;
7;; - Chicken Generic Arithmetic!
8;;
9;; - check-negative-* (< X 0), check-non-positive-* (<= X 0)
10
11(module type-checks
12
13(;export
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  check-range
50  ;
51  check-cardinal-fixnum
52  check-cardinal-integer
53  check-cardinal-number)
54
55(import chicken scheme)
56(use type-errors)
57
58(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)) ) ) )
76
77;;
78
79;maybe a problem with expansion environment namespace pollution
80(define-for-syntax (symbolize . elts)
81  (string->symbol (apply conc (map strip-syntax elts))) )
82
83;;
84
85(cond-expand
86
87  (unsafe
88
89    (define-syntax define-check-type
90      (er-macro-transformer
91        (lambda (frm rnm cmp)
92          (let ((_define (rnm 'define)))
93            (let* (
94              (typ (cadr frm))
95              (nam (string->symbol (string-append "check-" (symbol->string typ)))) )
96              `(,_define (,nam loc obj . _) obj) ) ) ) ) )
97
98    ;;Backwards
99    (define (check-cardinal-fixnum loc obj . _) obj)
100    (define (check-cardinal-integer loc obj . _) obj)
101    (define (check-cardinal-number loc obj . _) obj)
102
103    (define (check-positive-fixnum loc obj . _) obj)
104    (define (check-natural-fixnum loc obj . _) obj)
105    (define (check-negative-fixnum loc obj . _) obj)
106    (define (check-non-positive-fixnum loc obj . _) obj)
107    (define (check-positive-integer loc obj . _) obj)
108    (define (check-natural-integer loc obj . _) obj)
109    (define (check-negative-integer loc obj . _) obj)
110    (define (check-non-positive-integer loc obj . _) obj)
111    (define (check-positive-number loc obj . _) obj)
112    (define (check-natural-number loc obj . _) obj)
113    (define (check-negative-number loc obj . _) obj)
114    (define (check-non-positive-number loc obj . _) obj)
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) )
124
125  (else
126
127    ;;These are weak predicates. Only check for structure.
128
129    (export alist? plist?)
130
131    (define (alist? obj)
132      (or
133        (null? obj)
134        (and
135          (pair? obj)
136          (let loop ((ls obj))
137            (or
138              (null? ls)
139              (and
140                ;since anything can be a key no stronger check possible
141                (pair? (car ls))
142                (loop (cdr ls) ) ) ) ) ) ) )
143
144    (define (plist? obj)
145      ;since anything can be a key no stronger check possible
146      (and (list? obj) (even? (length obj))) )
147
148    ;;
149
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 )
157
158    (define-syntax define-check-type
159      (er-macro-transformer
160        (lambda (frm rnm cmp)
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))) )
174              `(,_define (,nam loc obj . args)
175                 (,_unless (,pred obj)
176                   (,errnam loc obj (,_optional args)))
177                 obj ) ) ) ) ) )
178
179    ;;Is the object non-void?
180
181    (define (defined-value? obj)
182      (not (eq? (void) obj)) )
183
184    ;;Is the object bound to value?
185
186    ;is obj the value from the de-ref of an unbound variable.
187    ;could only occur in a rather unsafe calling environnment.
188
189    (define (bound-value? obj)
190      (##core#inline "C_unboundvaluep" obj) )
191
192    ;;
193
194    (define (check-positive-fixnum loc obj . args)
195      (unless (and (fixnum? obj) (fx< 0 obj))
196        (error-positive-fixnum loc obj (optional args)))
197      obj )
198
199    (define (check-natural-fixnum loc obj . args)
200      (unless (and (fixnum? obj) (fx<= 0 obj))
201        (error-natural-fixnum loc obj (optional args)))
202      obj )
203
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
214    ;;
215
216    (define (check-positive-integer loc obj . args)
217      (unless (and (integer? obj) (positive? obj))
218        (error-positive-integer loc obj (optional args)))
219      obj )
220
221    (define (check-natural-integer loc obj . args)
222      (unless (and (integer? obj) (<= 0 obj))
223        (error-natural-integer loc obj (optional args)))
224      obj )
225
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
236    ;;
237
238    (define (check-positive-number loc obj . args)
239      (unless (and (number? obj) (positive? obj))
240        (error-positive-number loc obj (optional args)))
241      obj )
242
243    (define (check-natural-number loc obj . args)
244      (unless (and (number? obj) (<= 0 obj))
245        (error-natural-number loc obj (optional args)))
246      obj )
247
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
258    ;;
259
260    (define (check-structure loc obj tag . args)
261      (unless (##sys#structure? obj tag)
262        (error-structure loc obj tag (optional args)))
263      obj )
264
265    (define (check-record loc obj tag . args)
266      (unless (##sys#structure? obj tag)
267        (error-record loc obj tag (optional args)))
268      obj )
269
270    (define (check-record-type loc obj tag . args)
271      (unless (##sys#structure? obj tag)
272        (error-record-type loc obj tag (optional args)))
273      obj ) ) )
274
275;;
276
277(define-check-type defined-value)
278(define-check-type bound-value)
279
280(define-check-type fixnum)
281(define-check-type flonum)
282(define-check-type integer)
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)
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)
295(define check-closure check-procedure)
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)
302(define-check-type plist)
303(define-check-type alist)
304
305;closed interval
306(define (check-closed-interval loc num min max . args)
307  (unless (and (<= min num) (<= num max))
308    (error-closed-interval loc num min max (optional args)))
309  num )
310
311;open interval
312(define (check-open-interval loc num min max . args)
313  (unless (and (< min num) (< num max))
314    (error-open-interval loc num min max (optional args)))
315  num )
316
317;closed+open interval
318(define (check-half-open-interval loc num min max . args)
319  (unless (and (< min num) (<= num max))
320    (error-half-open-interval loc num min max (optional args)))
321  num )
322
323;open+closed interval
324(define (check-half-closed-interval loc num min max . args)
325  (unless (and (<= min num) (< num max))
326    (error-half-closed-interval loc num min max (optional args)))
327  num)
328
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) )
333  (values start end) )
334
335(define (check-minimum-argument-count loc argc minargc)
336  (unless (fx<= minargc argc)
337    (error-minimum-argument-count loc argc minargc))
338  argc )
339
340(define (check-argument-count loc argc maxargc)
341  (unless (fx<= argc maxargc)
342    (error-argument-count loc argc maxargc))
343  argc )
344
345;;
346
347;<type-symbol> [<type-predicate> [<message-string>]]
348
349(define-syntax define-check+error-type
350  (er-macro-transformer
351    (lambda (frm rnm cmp)
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))) )
359          `(begin
360             (,_define-error-type ,typ ,@(if mesg `(,mesg) '()))
361             (,_define-check-type ,typ ,@(if pred `(,pred) '())) ) ) ) ) ) )
362
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
369) ;module type-checks
Note: See TracBrowser for help on using the repository browser.