source: project/release/4/foreigners/trunk/foreigners.scm @ 33658

Last change on this file since 33658 was 33658, checked in by evhan, 3 years ago

foreigners: Remove duplicate "declare" entry in rename list

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