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

Last change on this file since 14087 was 14087, checked in by Kon Lovett, 11 years ago

Not all fixnum!

File size: 5.0 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(import chicken scheme type-errors)
42(require-library type-errors)
43
44;;
45
46(cond-expand
47  (unsafe
48
49    (define (check-fixnum . _) (begin))
50    (define (check-positive-fixnum . _) (begin))
51    (define (check-cardinal-fixnum . _) (begin))
52    (define (check-flonum . _) (begin))
53    (define (check-integer . _) (begin))
54    (define (check-positive-integer . _) (begin))
55    (define (check-cardinal-integer . _) (begin))
56    (define (check-number . _) (begin))
57    (define (check-positive-number . _) (begin))
58    (define (check-cardinal-number . _) (begin))
59    (define (check-procedure . _) (begin))
60    (define (check-input-port . _) (begin))
61    (define (check-output-port . _) (begin))
62    (define (check-list . _) (begin))
63    (define (check-pair . _) (begin))
64    (define (check-blob . _) (begin))
65    (define (check-vector . _) (begin))
66    (define (check-structure . _) (begin))
67    (define (check-symbol . _) (begin))
68    (define (check-keyword . _) (begin))
69    (define (check-string . _) (begin))
70    (define (check-char . _) (begin))
71    (define (check-boolean . _) (begin)) )
72
73  (else
74
75    (define (cardinal? obj) (<= 0 obj))
76
77    ;;
78
79    (define (check-fixnum loc obj #!optional argnam)
80      (unless (fixnum? obj)
81        (error-type-fixnum loc obj argnam) ) )
82
83    (define (check-positive-fixnum loc obj #!optional argnam)
84      (unless (and (fixnum? obj) (positive? obj))
85        (error-type-positive-fixnum loc obj argnam) ) )
86
87    (define (check-cardinal-fixnum loc obj #!optional argnam)
88      (unless (and (fixnum? obj) (cardinal? obj))
89        (error-type-cardinal-fixnum loc obj argnam) ) )
90
91    ;;
92
93    (define (check-flonum loc obj #!optional argnam)
94      (unless (flonum? obj)
95        (error-type-flonum loc obj argnam) ) )
96
97    ;;
98
99    (define (check-integer loc obj #!optional argnam)
100      (unless (integer? obj)
101        (error-type-integer loc obj argnam) ) )
102
103    (define (check-positive-integer loc obj #!optional argnam)
104      (unless (and (integer? obj) (positive? obj))
105        (error-type-positive-integer loc obj argnam) ) )
106
107    (define (check-cardinal-integer loc obj #!optional argnam)
108      (unless (and (integer? obj) (cardinal? obj))
109        (error-type-cardinal-integer loc obj argnam) ) )
110
111    ;;
112
113    (define (check-number loc obj #!optional argnam)
114      (unless (number? obj)
115        (error-type-number loc obj argnam) ) )
116
117    (define (check-positive-number loc obj #!optional argnam)
118      (unless (positive? obj)
119        (error-type-positive-number loc obj argnam) ) )
120
121    (define (check-cardinal-number loc obj #!optional argnam)
122      (unless (cardinal? obj)
123        (error-type-cardinal-number loc obj argnam) ) )
124
125    ;;
126
127    (define (check-procedure loc obj #!optional argnam)
128      (unless (procedure? obj)
129        (error-type-procedure loc obj argnam) ) )
130
131    ;;
132
133    (define (check-input-port loc obj #!optional argnam)
134      (unless (input-port? obj)
135        (error-type-input-port loc obj argnam) ) )
136
137    (define (check-output-port loc obj #!optional argnam)
138      (unless (output-port? obj)
139        (error-type-output-port loc obj argnam) ) )
140
141    ;;
142
143    (define (check-list loc obj #!optional argnam)
144      (unless (list? obj)
145        (error-type-list loc obj argnam) ) )
146
147    (define (check-pair loc obj #!optional argnam)
148      (unless (pair? obj)
149        (error-type-pair loc  obj argnam) ) )
150
151    ;;
152
153    (define (check-blob loc obj #!optional argnam)
154      (unless (blob? obj)
155        (error-type-blob loc obj argnam) ) )
156
157    ;;
158
159    (define (check-vector loc obj #!optional argnam)
160      (unless (vector? obj)
161        (error-type-vector loc obj argnam) ) )
162
163    ;;
164
165    (define (check-structure loc obj tag #!optional argnam)
166      (unless (##sys#structure? obj tag)
167        (error-type-structure loc obj tag argnam) ) )
168
169    ;;
170
171    (define (check-symbol loc obj #!optional argnam)
172      (unless (symbol? obj)
173        (error-type-symbol loc obj argnam) ) )
174
175    ;;
176
177    (define (check-keyword loc obj #!optional argnam)
178      (unless (keyword? obj)
179        (error-type-keyword loc obj argnam) ) )
180
181    ;;
182
183    (define (check-string loc obj #!optional argnam)
184      (unless (string? obj)
185        (error-type-string loc obj argnam) ) )
186
187    ;;
188
189    (define (check-char loc obj #!optional argnam)
190      (unless (char? obj)
191        (error-type-char loc obj argnam) ) )
192
193    ;;
194
195    (define (check-boolean loc obj #!optional argnam)
196      (unless (boolean? obj)
197        (error-type-boolean loc obj argnam) ) ) ) )
198
199) ;module type-checks
Note: See TracBrowser for help on using the repository browser.