source: project/release/5/foreigners/trunk/foreigners.scm @ 36185

Last change on this file since 36185 was 36185, checked in by Kooda, 13 months ago

Port foreigners to CHICKEN 5

File size: 13.6 KB
Line 
1;;; foreigners module
2
3;;; renaming module
4
5;; Renaming helper macro for er-macros below.  Must be a module
6;; so we can import via (import-for-syntax renaming).
7
8(module renaming (with-renamed)
9  (import scheme)
10  ;; (with-renamed r (begin car cdr) body ...)
11  ;; -> (let ((%begin (r 'begin)) (%car (r 'car)) (%cdr (r 'cdr)))
12  ;;      body ...)
13  (define-syntax with-renamed
14    (er-macro-transformer
15    (lambda (f r c)
16      (##sys#check-syntax 'with-renamed f '(_ _ (_ . _) . _))
17      (let ((renamer (cadr f))
18            (identifiers (caddr f))
19            (body (cdddr f))
20            (munger (lambda (x) (string->symbol
21                            (string-append "%" (symbol->string x))))))
22        `(,(r 'let)
23          ,(map (lambda (x)
24                  `(,(munger x) (,renamer ',x)))
25                identifiers)
26          ,@body))))))
27
28;;; define-foreign-record-type
29
30(module foreigners
31  (define-foreign-record-type define-foreign-enum-type)
32
33  (import scheme (chicken bitwise))
34  (import-for-syntax (chicken format)
35                     (chicken keyword)
36                     (chicken string))
37
38  (define-syntax define-foreign-record-type
39    (er-macro-transformer
40    (lambda (f r c)
41      (##sys#check-syntax 'define-foreign-record-type f '(_ _ . _))
42
43      (let ((name (cadr f))
44            (slots (cddr f)))
45        (let ([fname (if (pair? name) (->string (cadr name))
46                         (sprintf "struct ~A" name))]
47              [tname (if (pair? name) (car name) name)]
48              [ctor #f]
49              [dtor #f])
50          (define (stype type)
51            (cond [(not (pair? type)) type]
52                  [(memq (car type) '(struct union)) `(c-pointer ,type)]
53                  [else type] ) )
54          (define (strtype type)
55            (or (eq? type tname)
56                (and (pair? type)
57                     (memq (car type) '(struct union))  ) ) ) ; handle instances?
58
59          ;; Process special declarations, which must occur first.
60          (do ((slts slots (cdr slts)))
61              ((or (null? slts) (not (pair? (car slts)))
62                   (not (keyword? (caar slts))) (pair? (caar slts)))
63               (set! slots slts) )
64            (let ((decl (caar slts)))
65              (cond ((c decl (r #:constructor)) (set! ctor (cadar slts)))
66                    ((c decl (r #:destructor)) (set! dtor (cadar slts)))
67                    (else (syntax-error 'define-foreign-record-type
68                                        "invalid foreign record-type declaration" (car slts))) )) )
69       
70          (chicken.compiler.support#register-foreign-type! tname `(c-pointer ,fname))
71
72          (let ((%void 'void)  ; foreign-lambda* recognizes renamed type identifiers now,
73                (%int 'int))   ; but we keep this temporarily for BC
74            (with-renamed r
75                (declare foreign-declare begin define foreign-lambda*
76                 if let lambda syntax-error and fx>= fx<)
77              `(,%begin
78                 ,@(if (pair? name)
79                       '()
80                       `((,%declare
81                          (,%foreign-declare
82                           ,(string-intersperse
83                             (append
84                              (cons
85                               (string-append "struct " (->string name) " { ")
86                               (map (lambda (slot)
87                                      (##sys#check-syntax 'define-foreign-record-type
88                                                          slot '(_ _ _ . _))
89                                      (if (pair? (cadr slot)) ; (type (name size) ...)
90                                          (sprintf "~A[~A];"
91                                                   (chicken.compiler.c-backend#foreign-type-declaration
92                                                    (car slot)
93                                                    (->string (caadr slot)) )
94                                                   (cadadr slot) )
95                                          (sprintf "~A;" ; (type name ...)
96                                                   (chicken.compiler.c-backend#foreign-type-declaration
97                                                    (car slot)
98                                                    (->string (cadr slot)) ) ) )
99                                      ;; [else (syntax-error 'define-foreign-record
100                                      ;;                     "bad slot spec" slot)]
101                                      )
102                                    slots) )
103                              (list "};") )
104                             "\n") ) ) ) )
105                 ,@(if (not ctor)
106                       '()
107                       `((,%define ,ctor
108                           (,%foreign-lambda* ,tname ()
109                             ,(sprintf "return((~a *)C_malloc(sizeof(~a)));" fname fname)))))
110                 ,@(if (not dtor)
111                       '()
112                       (let ((ptr (gensym)))
113                         `((,%define (,dtor ,ptr)
114                             (and ,ptr (##core#inline "C_qfree" ,ptr))))))
115                 ,@(map (lambda (slot)
116                          (##sys#check-syntax 'define-foreign-record-type slot '(_ _ _ . _))
117                          (let* ((type (car slot))
118                                 (namesz (cadr slot))
119                                 (type2 (stype type))
120                                 (getr (caddr slot))
121                                 (setr (cdddr slot)))
122                            (if (pair? namesz)
123                                (let ((sname (car namesz))
124                                      (size (cadr namesz))
125                                      (var (gensym))
126                                      (cvar (gensym))
127                                      (svar (gensym))
128                                      (xvar (gensym)))
129                                  `(,%begin
130                                     (,%define ,getr
131                                       (,%let ([,cvar
132                                                (,%foreign-lambda* ,type2 ([,tname ,var] [,%int ,svar])
133                                                  ,(sprintf "return(~A~A->~A[~A]);"
134                                                            (if (not (strtype type)) "" "&")
135                                                            var sname svar) ) ] )
136                                         (,%lambda (,var ,svar)
137                                           (,%if (##core#check (,%and (,%fx>= ,svar 0)
138                                                                      (,%fx< ,svar ,size)))
139                                                 (,cvar ,var ,svar)
140                                                 ;; this should signal a range exn...
141                                                 (,%syntax-error 'define-foreign-record
142                                                                 "array access out of range"
143                                                                 ',tname ',svar ,size)))))
144                                     ,@(if (null? setr)
145                                           '()
146                                           (if (eq? type type2)
147                                               `((,%define ,(car setr)
148                                                   (,%let ([,cvar
149                                                            (,%foreign-lambda* ,%void
150                                                                ([,tname ,var] [,%int ,svar] [,type ,xvar])
151                                                              ,(sprintf "~A->~A[~A] = ~A;"
152                                                                        var sname svar xvar))])
153                                                     (,%lambda (,var ,svar ,xvar)
154                                                       (,%if (##core#check (,%and (,%fx>= ,svar 0)
155                                                                                  (,%fx< ,svar ,size)))
156                                                             (,cvar ,var ,svar ,xvar)
157                                                             (,%syntax-error
158                                                              'define-foreign-record
159                                                              "array access out of range"
160                                                              ',tname ',svar ,size))))))
161                                               '() ))))
162                             
163                                (let ([sname (cadr slot)]
164                                      [var (gensym)]
165                                      [xvar (gensym)])
166                                  `(,%begin
167                                     (,%define ,getr
168                                       (,%foreign-lambda* ,type2 ([,tname ,var])
169                                         ,(sprintf "return(~A~A->~A);"
170                                                   (if (not (strtype type)) "" "&")
171                                                   var sname) ) )
172                                     ,@(if (null? setr)
173                                           '()
174                                           (if (eq? type type2)
175                                               `((,%define ,(car setr)
176                                                   (,%foreign-lambda* ,%void ([,tname ,var] [,type ,xvar])
177                                                     ,(sprintf "~A->~A = ~A;" var sname xvar))))
178                                               '() ))))
179                                ;; [else (syntax-error 'define-foreign-record
180                                ;;                     "bad slot spec" slot)]
181                                )))
182                        slots)))))))))
183
184;;; define-foreign-enum-type
185
186(import-for-syntax matchable)
187(import-syntax-for-syntax renaming)
188
189;; Ignored case where typename is a symbol, for now.
190;; Permit string or symbol as REALTYPE in ENUMSPEC.
191(define-syntax define-foreign-enum-type
192  (er-macro-transformer
193  (lambda (f r c)
194    (match
195     f
196     ((_ (type-name native-type default-value)
197         (to-native from-native)
198         enumspecs ...)
199      (let ((enums (map (lambda (spec)
200                          (match spec
201                                 (((s v) n d) spec)
202                                 (((s v) n)   `((,s ,v) ,n ',s))
203                                 (((s) n d)   `((,s ,(gensym)) ,n ,d))
204                                 (((s) n)     `((,s ,(gensym)) ,n ',s))
205                                 ((s n d)     `((,s ,s) ,n ,d))
206                                 ((s n)       `((,s ,s) ,n ',s))
207                                 ((s ...)     (error 'define-foreign-enum-type
208                                                     "error in enum spec" spec))
209                                 (s          `((,s ,s) ,s ',s))
210                                 (else
211                                  (syntax-error 'default-foreign-enum-type
212                                         "error in enum spec" spec))))
213                        enumspecs)))
214        (with-renamed
215         r (begin define cond else if let symbol? list null?
216                  car cdr case bitwise-ior error =
217                  define-foreign-type define-foreign-variable)
218
219         `(,%begin
220           ,@(map (lambda (e)
221                    (match-let ([ ((s var) name d) e ])
222                      `(,%define-foreign-variable ,var ,native-type
223                         ,(if (symbol? name) (symbol->string name) name))))
224                  enums)
225
226           (,%define (,from-native val)
227             (,%cond
228              ,@(map (lambda (e)
229                       (match-let ([ ((s var) n value) e ])
230                         `((,%= val ,var) ,value)))
231                     enums)
232              (,%else ,default-value)))
233
234           (,%define (,to-native syms)
235             (,%let loop ((syms (,%if (,%symbol? syms) (,%list syms) syms))
236                          (sum 0))
237               (,%if (,%null? syms)
238                     sum
239                     (loop (,%cdr syms)
240                           (,%bitwise-ior
241                            sum
242                            (,%let ((val (,%car syms)))
243                              (,%case
244                               val
245                               ,@(map (lambda (e)
246                                        (match-let ([((symbol var) n d) e])
247                                          `((,symbol ,(string->keyword
248                                                       (symbol->string symbol)))
249                                            ,var)))
250                                      enums)
251                               (,%else (,%error "not a member of enum" val
252                                                ',type-name)))))))))
253
254           (,%define-foreign-type ,type-name
255             ,native-type ,to-native ,from-native)
256
257           ))))
258
259     ; handle missing default-value
260     ((_ (type-name native-type) . rest)
261      `(define-foreign-enum-type (,type-name ,native-type '()) ,@rest))
262     )))))
263
264
265;;; Testing
266
267#|
268,x
269(define-foreign-record-type (servent "struct servent")
270  (constructor: make-servent)
271  (destructor: free-servent)
272  (c-string s_name servent-name servent-name-set!)
273  (c-pointer s_aliases servent-s_aliases)
274  (port-number s_port servent-port servent-port-set!)
275  (c-string s_proto servent-proto servent-proto-set!))
276
277,x
278(define-foreign-record-type point
279  (int (xyz 3) point-coords point-coords-set!))
280
281; rename: not used
282; const specifier not used, avoid specifying setter
283
284|#
285
286#|
287;; for interactive testing
288(define (chicken.compiler.c-backend#foreign-type-declaration t n)
289  (conc t " " n))
290(define (chicken.compiler.support#register-foreign-type! . args)
291  (display "chicken.compiler.support#register-foreign-type! ")
292  (write args)
293  (newline))
294|#
Note: See TracBrowser for help on using the repository browser.