source: project/release/5/mailbox/tags/3.2.0/inline-type-checks.scm @ 36567

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