source: project/release/5/stack/trunk/inline-type-checks.scm @ 35980

Last change on this file since 35980 was 35980, checked in by Kon Lovett, 3 years ago

C5 initial

File size: 4.8 KB
Line 
1;;;; inline-type-checks.scm
2;;;; Kon Lovett, Apr '09
3
4;; Issues
5;;
6;; - Needs "chicken-primitive-object-inlines.scm"
7;;
8;; - This source is to be included only!
9
10(import (chicken syntax))
11
12; maybe a problem with expansion environment namespace pollution
13(define-for-syntax (symbolize . elts)
14  (string->symbol (apply conc (map strip-syntax elts))) )
15
16;just in case older inlines
17(define-inline (%natural? n) (%<= 0 n))
18(define-inline (%fxnatural? fx) (%fx<= 0 fx))
19
20(cond-expand
21
22  (unsafe
23
24    (define-syntax define-inline-check-type
25      (er-macro-transformer
26        (lambda (frm rnm cmp)
27          (let ((_define-inline (rnm 'define-inline)))
28            (let* ((typ (cadr frm))
29                   (typstr (symbol->string typ))
30                   (nam (string->symbol (string-append "%check-" typstr))) )
31              `(,_define-inline (,nam loc obj . _) obj) ) ) ) ) )
32
33    (define-inline (%check-positive-fixnum . _) (begin))
34    (define-inline (%check-natural-fixnum . _) (begin))
35    (define-inline (%check-positive-integer . _) (begin))
36    (define-inline (%check-natural-integer . _) (begin))
37    (define-inline (%check-positive-number . _) (begin))
38    (define-inline (%check-natural-number . _) (begin))
39    (define-inline (%check-structure . _) (begin))
40    (define-inline (%check-minimum-argument-count . _) (begin))
41    (define-inline (%check-argument-count . _) (begin)) )
42
43  (else
44
45    (define-inline (%alist? obj)
46      (or (%null? obj)
47          (and (%pair? obj) (%list-every/1 (lambda (x) (%pair? x)) obj))) )
48
49    ;;
50
51    (define-syntax define-inline-check-type
52      (er-macro-transformer
53        (lambda (frm rnm cmp)
54          (let ((_define-inline (rnm 'define-inline))
55                (_unless (rnm 'unless))
56                (_optional (rnm 'optional)) )
57            (let* ((typ (cadr frm))
58                   (typstr (symbol->string typ))
59                   (pred (if (not (null? (cddr frm))) (caddr frm)
60                           (string->symbol (string-append "%" typstr "?"))))
61                   (nam (string->symbol (string-append "%check-" typstr)))
62                   (errnam (string->symbol (string-append "error-" typstr))) )
63              `(,_define-inline (,nam loc obj . args)
64                 (,_unless (,pred obj)
65                   (,errnam loc obj (,_optional args)))
66                 obj ) ) ) ) ) )
67
68    ;;
69
70    (define-inline (%check-positive-fixnum loc obj . args)
71      (unless (and (%fixnum? obj) (%fxpositive? obj))
72        (error-positive-fixnum loc obj (optional args)))
73      obj )
74
75    (define-inline (%check-natural-fixnum loc obj . args)
76      (unless (and (%fixnum? obj) (%fxnatural? obj))
77        (error-natural-fixnum loc obj (optional args)))
78      obj )
79
80    ;;
81
82    (define-inline (%check-positive-integer loc obj . args)
83      (unless (and (%integer? obj) (%positive? obj))
84        (error-positive-integer loc obj (optional args)))
85      obj )
86
87    (define-inline (%check-natural-integer loc obj . args)
88      (unless (and (%integer? obj) (%natural? obj))
89        (error-natural-integer loc obj (optional args)))
90      obj )
91
92    ;;
93
94    (define-inline (%check-positive-number loc obj . args)
95      (unless (and (%number? obj) (%positive? obj))
96        (error-positive-number loc obj (optional args)))
97      obj )
98
99    (define-inline (%check-natural-number loc obj . args)
100      (unless (and (%number? obj) (%natural? obj))
101        (error-natural-number loc obj (optional args)))
102      obj )
103
104    ;;
105
106    (define-inline (%check-structure loc obj tag . args)
107      (unless (%structure-instance? obj tag)
108        (error-structure loc obj tag (optional args)))
109      obj )
110
111    ;;
112
113    (define-inline (%check-minimum-argument-count loc argc minargc)
114      (unless (%fx<= minargc argc)
115        (error-minimum-argument-count loc argc minargc))
116      argc )
117
118    (define-inline (%check-argument-count loc argc maxargc)
119      (unless (%fx<= argc maxargc)
120        (error-argument-count loc argc maxargc))
121      argc ) ) )
122
123;;
124
125(define-inline-check-type fixnum)
126(define-inline-check-type flonum)
127(define-inline-check-type integer)
128(define-inline-check-type number)
129(define-inline-check-type symbol)
130(define-inline-check-type keyword)
131(define-inline-check-type string)
132(define-inline-check-type char)
133(define-inline-check-type boolean)
134(define-inline-check-type procedure)
135(define-inline-check-type closure)
136(define-inline-check-type input-port)
137(define-inline-check-type output-port)
138(define-inline-check-type list)
139(define-inline-check-type pair)
140(define-inline-check-type blob)
141(define-inline-check-type vector)
142(define-inline-check-type alist)
143
144(define-inline (%check-cardinal-fixnum loc obj . args)
145  (%check-natural-fixnum loc obj (optional args)))
146(define-inline (%check-cardinal-integer loc obj . args)
147  (%check-natural-integer loc obj (optional args)))
148(define-inline (%check-cardinal-number loc obj . args)
149  (%check-natural-number loc obj (optional args)))
Note: See TracBrowser for help on using the repository browser.