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

Last change on this file since 15588 was 15588, checked in by Kon Lovett, 10 years ago

Added 'make-error-type-message' & fixed 'define-check+error-type'.

File size: 4.3 KB
Line 
1;;;; type-checks.scm
2;;;; Kon Lovett, Apr '09
3
4(declare
5  (usual-integrations)
6  (generic)
7  (inline)
8  (local)
9  (no-procedure-checks)
10  (no-bound-checks)
11  (bound-to-procedure
12    ##sys#structure?) )
13
14;;;
15
16(module type-checks (;export
17  check-fixnum
18  check-positive-fixnum
19  check-cardinal-fixnum
20  check-flonum
21  check-integer
22  check-positive-integer
23  check-cardinal-integer
24  check-number
25  check-positive-number
26  check-cardinal-number
27  check-procedure
28  check-input-port
29  check-output-port
30  check-list
31  check-pair
32  check-blob
33  check-vector
34  check-structure
35  check-symbol
36  check-keyword
37  check-string
38  check-char
39  check-boolean
40  ;;
41  define-check-type define-check+error-type)
42
43(import chicken scheme type-errors)
44(require-library type-errors)
45
46;;
47
48(cond-expand
49  (unsafe
50 
51    (define-syntax define-check-type
52      (lambda (form r c)
53        (let (($define (r 'define)))
54          (let* ((typ (cadr form))
55                 (nam (string->symbol (string-append "check-" (symbol->string typ)))) )
56            `(,$define (,nam . _) (begin) ) ) ) ) )
57
58    (define (check-positive-fixnum . _) (begin))
59    (define (check-cardinal-fixnum . _) (begin))
60    (define (check-positive-integer . _) (begin))
61    (define (check-cardinal-integer . _) (begin))
62    (define (check-positive-number . _) (begin))
63    (define (check-cardinal-number . _) (begin))
64    (define (check-structure . _) (begin)) )
65
66  (else
67
68    ;;
69
70    ; <symbol>          : <pred> is '<symbol>?'
71    ; <symbol> <symbol> : <pred> is <symbol>
72    ; ->
73    ; (define (check-<symbol> loc obj #!optional argnam)
74    ;   (unless (<pred> obj)
75    ;     (error-<symbol> loc obj argnam) ) )
76
77    (define-syntax define-check-type
78      (lambda (form r c)
79        (let (($define (r 'define))
80              ($#!optional (r '#!optional)) )
81          (let* ((typ (cadr form))
82                 (typstr (symbol->string typ))
83                 (pred (if (not (null? (cddr form))) (caddr form) (string->symbol (string-append typstr "?"))))
84                 (nam (string->symbol (string-append "check-" typstr)))
85                 (errnam (string->symbol (string-append "error-" typstr))) )
86            `(,$define (,nam loc obj ,$#!optional argnam)
87               (unless (,pred obj)
88                 (,errnam loc obj argnam) ) ) ) ) ) )
89    ;;
90
91    (define (check-positive-fixnum loc obj #!optional argnam)
92      (unless (and (fixnum? obj) (fx< 0 obj))
93        (error-positive-fixnum loc obj argnam) ) )
94
95    (define (check-cardinal-fixnum loc obj #!optional argnam)
96      (unless (and (fixnum? obj) (fx<= 0 obj))
97        (error-cardinal-fixnum loc obj argnam) ) )
98
99    ;;
100
101    (define (check-positive-integer loc obj #!optional argnam)
102      (unless (and (integer? obj) (positive? obj))
103        (error-positive-integer loc obj argnam) ) )
104
105    (define (check-cardinal-integer loc obj #!optional argnam)
106      (unless (and (integer? obj) (<= 0 obj))
107        (error-cardinal-integer loc obj argnam) ) )
108
109    ;;
110
111    (define (check-positive-number loc obj #!optional argnam)
112      (unless (positive? obj)
113        (error-positive-number loc obj argnam) ) )
114
115    (define (check-cardinal-number loc obj #!optional argnam)
116      (unless (<= 0 obj)
117        (error-cardinal-number loc obj argnam) ) )
118
119    ;;
120
121    (define (check-structure loc obj tag #!optional argnam)
122      (unless (##sys#structure? obj tag)
123        (error-structure loc obj tag argnam) ) ) ) )
124
125;;
126
127(define-check-type fixnum)
128(define-check-type flonum)
129(define-check-type integer)
130(define-check-type number)
131(define-check-type symbol)
132(define-check-type keyword)
133(define-check-type string)
134(define-check-type char)
135(define-check-type boolean)
136(define-check-type procedure)
137(define-check-type input-port)
138(define-check-type output-port)
139(define-check-type list)
140(define-check-type pair)
141(define-check-type blob)
142(define-check-type vector)
143
144;;
145
146; <type-symbol> [<type-predicate> [<message-string>]]
147
148(define-syntax define-check+error-type
149  (lambda (form r c)
150    (let (($define-check-type (r 'define-check-type))
151          ($define-error-type (r 'define-error-type)) )
152      (let* ((typ (cadr form))
153             (pred (and (not (null? (cddr form))) (caddr form))) 
154             (mesg (and pred (not (null? (cdddr form))) (cadddr form))) )
155        `(begin
156           (,$define-error-type ,typ ,@(if mesg `(,mesg) '()))
157           (,$define-check-type ,typ ,@(if pred `(,pred) '())) ) ) ) ) )
158
159) ;module type-checks
Note: See TracBrowser for help on using the repository browser.