source: project/release/4/foreign-records/trunk/foreign-records.scm @ 13517

Last change on this file since 13517 was 13517, checked in by Jim Ursetto, 11 years ago

foreign-records: reformat

File size: 13.1 KB
Line 
1;;; foreign-records 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 foreign-records
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          ;; void note: foreign-lambda* does not allow renaming
68          (with-renamed r
69              (void int begin define foreign-lambda foreign-lambda*
70                    if let lambda declare foreign-declare
71                    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 (r (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 (r (gensym)))
121                                    (cvar (r (gensym)))
122                                    (svar (r (gensym)))
123                                    (xvar (r (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 (r (gensym))] ; rename may be unnecessary
160                                    [xvar (r (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           (,%define-foreign-type ,type-name
216             ,native-type ,to-native ,from-native)
217           
218           ,@(map (lambda (e)
219                    (match-let ([ ((s var) name d) e ])
220                      `(,%define-foreign-variable ,var ,native-type
221                         ,(if (symbol? name) (symbol->string name) name))))
222                  enums)
223
224           (,%define (,from-native val)
225             (,%cond
226              ,@(map (lambda (e)
227                       (match-let ([ ((s var) n value) e ])
228                         `((,%= val ,var) ,value)))
229                     enums)
230              (,%else ,default-value)))
231
232           (,%define (,to-native syms)
233             (,%let loop ((syms (,%if (,%symbol? syms) (,%list syms) syms))
234                          (sum 0))
235               (,%if (,%null? syms)
236                     sum
237                     (loop (,%cdr syms)
238                           (,%bitwise-ior
239                            sum
240                            (,%let ((val (,%car syms)))
241                              (,%case
242                               val
243                               ,@(map (lambda (e)
244                                        (match-let ([((symbol var) n d) e])
245                                          `((,symbol) ,var)))
246                                      enums)
247                               (,%else (,%error "not a member of enum" val
248                                                ',type-name)))))))))
249           ))))
250
251     ; handle missing default-value
252     ((_ (type-name native-type) . rest)
253      `(define-foreign-enum-type (,type-name ,native-type '()) ,@rest))
254     ))))
255
256
257;;; Testing
258
259#|
260,x
261(define-foreign-record-type (servent "struct servent")
262  (constructor: make-servent)
263  (destructor: free-servent)
264  (c-string s_name servent-name servent-name-set!)
265  (c-pointer s_aliases servent-s_aliases)
266  (port-number s_port servent-port servent-port-set!)
267  (c-string s_proto servent-proto servent-proto-set!))
268
269,x
270(define-foreign-record-type point
271  (int (xyz 3) point-coords point-coords-set!))
272
273; rename: not used
274; const specifier not used, avoid specifying setter
275
276|#
277
278#|
279;; for interactive testing
280(define (##compiler#foreign-type-declaration t n)
281  (conc t " " n))
282(define ##compiler#foreign-type-table (make-hash-table))
283(define (##sys#hash-table-set! . args) (display "hash-table-set! ") (write args) (newline))
284|#
Note: See TracBrowser for help on using the repository browser.