source: project/release/4/check-errors/tags/1.0.0/inline-type-checks.scm @ 14139

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

Added syntax. Release.

File size: 3.2 KB
Line 
1;;;; inline-type-checks.scm
2;;;; Kon Lovett, Apr '09
3
4;;
5
6(include "chicken-primitive-object-inlines")
7
8;;
9
10(cond-expand
11  (unsafe
12 
13    (define-syntax define-inline-check-type
14      (lambda (form r c)
15        (let (($define-inline (r 'define-inline)))
16          (let* ((typ (cadr form))
17                 (nam (string->symbol (string-append "check-" (symbol->string typ)))) )
18            `(,$define-inline (,nam . _) (begin) ) ) ) ) )
19
20    (define-inline (%check-positive-fixnum . _) (begin))
21    (define-inline (%check-cardinal-fixnum . _) (begin))
22    (define-inline (%check-positive-integer . _) (begin))
23    (define-inline (%check-cardinal-integer . _) (begin))
24    (define-inline (%check-positive-number . _) (begin))
25    (define-inline (%check-cardinal-number . _) (begin))
26    (define-inline (%check-structure . _) (begin)) )
27
28  (else
29
30    ;;
31
32    (define-syntax define-inline-check-type
33      (lambda (form r c)
34        (let (($define-inline (r 'define-inline))
35              ($#!optional (r '#!optional)) )
36          (let* ((typ (cadr form))
37                 (typstr (symbol->string typ))
38                 (pred (if (not (null? (cddr form))) (caddr form) (string->symbol (string-append "%" typstr "?"))))
39                 (nam (string->symbol (string-append "%check-" typstr)))
40                 (errnam (string->symbol (string-append "error-" typstr))) )
41            `(,$define-inline (,nam loc obj ,$#!optional argnam)
42               (unless (,pred obj)
43                 (,errnam loc obj argnam) ) ) ) ) ) )
44
45    ;;
46
47    (define-inline (%check-positive-fixnum loc obj #!optional argnam)
48      (unless (and (%fixnum? obj) (%fxpositive? obj))
49        (error-positive-fixnum loc obj argnam) ) )
50
51    (define-inline (%check-cardinal-fixnum loc obj #!optional argnam)
52      (unless (and (%fixnum? obj) (%fxcardinal? obj))
53        (error-cardinal-fixnum loc obj argnam) ) )
54
55    ;;
56
57    (define-inline (%check-positive-integer loc obj #!optional argnam)
58      (unless (and (%integer? obj) (%positive? obj))
59        (error-positive-integer loc obj argnam) ) )
60
61    (define-inline (%check-cardinal-integer loc obj #!optional argnam)
62      (unless (and (%integer? obj) (%cardinal? obj))
63        (error-cardinal-integer loc obj argnam) ) )
64
65    ;;
66
67    (define-inline (%check-positive-number loc obj #!optional argnam)
68      (unless (%positive? obj)
69        (error-positive-number loc obj argnam) ) )
70
71    (define-inline (%check-cardinal-number loc obj #!optional argnam)
72      (unless (%cardinal? obj)
73        (error-cardinal-number loc obj argnam) ) )
74
75    ;;
76
77    (define-inline (%check-structure loc obj tag #!optional argnam)
78      (unless (%structure-instance? obj tag)
79        (error-structure loc obj tag argnam) ) ) ) )
80
81;;
82
83(define-inline-check-type fixnum)
84(define-inline-check-type flonum)
85(define-inline-check-type integer)
86(define-inline-check-type number)
87(define-inline-check-type symbol)
88(define-inline-check-type keyword)
89(define-inline-check-type string)
90(define-inline-check-type char)
91(define-inline-check-type boolean)
92(define-inline-check-type procedure)
93(define-inline-check-type input-port)
94(define-inline-check-type output-port)
95(define-inline-check-type list)
96(define-inline-check-type pair)
97(define-inline-check-type blob)
98(define-inline-check-type vector)
Note: See TracBrowser for help on using the repository browser.