← Back to branch summary

~ubuntu-branches/ubuntu/lucid/gauche-c-wrapper/lucid

« back to all changes in this revision

Viewing changes to objc/c-wrapper/objc-ffi.scm

  • Committer: Bazaar Package Importer
  • Author(s): NIIBE Yutaka
  • Date: 2008-04-07 09:15:03 UTC
  • Revision ID: james.westby@ubuntu.com-20080407091503-wu0h414koe95kj4i
Tags: upstream-0.5.2
Import upstream version 0.5.2

Show diffs side-by-side

added added

removed removed

Lines of Context:
objc/c-wrapper/objc-ffi.scm
 
1
;; -*- coding: utf-8; mode: scheme -*-
 
2
;;
 
3
;; objc-ffi.scm 
 
4
;;
 
5
;;   Copyright (c) 2006 KOGURO, Naoki (naoki@koguro.net)
 
6
;;   All rights reserved.
 
7
;;
 
8
;;   Redistribution and use in source and binary forms, with or without 
 
9
;;   modification, are permitted provided that the following conditions 
 
10
;;   are met:
 
11
;;
 
12
;;   1. Redistributions of source code must retain the above copyright 
 
13
;;      notice, this list of conditions and the following disclaimer.
 
14
;;   2. Redistributions in binary form must reproduce the above copyright 
 
15
;;      notice, this list of conditions and the following disclaimer in the 
 
16
;;      documentation and/or other materials provided with the distribution.
 
17
;;   3. Neither the name of the authors nor the names of its contributors 
 
18
;;      may be used to endorse or promote products derived from this 
 
19
;;      software without specific prior written permission.
 
20
;;
 
21
;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 
 
22
;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 
 
23
;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 
 
24
;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 
 
25
;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
 
26
;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 
 
27
;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 
 
28
;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 
 
29
;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 
 
30
;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 
 
31
;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
32
;;
 
33
;;   $Id: $
 
34
;;
 
35
 
 
36
(define-module c-wrapper.objc-ffi
 
37
  (use c-wrapper)
 
38
  (use file.util)
 
39
  (use srfi-1)
 
40
  (extend c-wrapper.c-ffi)
 
41
  
 
42
  (c-load '("stdlib.h" "objc/objc-runtime.h" "objc/objc-class.h")
 
43
          :libs "-lobjc"
 
44
          :compiled-lib "objc-ffilib")
 
45
 
 
46
  (export @ 
 
47
          @selector
 
48
          c-load-framework
 
49
          objc-lookup-class
 
50
          objc-register-method
 
51
          objc-add-method
 
52
          make-super
 
53
          <id>
 
54
          <SEL>)
 
55
  )
 
56
 
 
57
(select-module c-wrapper.objc-ffi)
 
58
 
 
59
(with-module c-wrapper.c-ffi
 
60
  (set! %c-load-framework
 
61
        (lambda (name)
 
62
          (or (and-let* ((filename (find-file-in-paths
 
63
                                    name :paths (map (cut string-append 
 
64
                                                          <>
 
65
                                                          name
 
66
                                                          ".framework/")
 
67
                                                     (list (build-path 
 
68
                                                            (sys-getenv "HOME")
 
69
                                                            "Library/Frameworks/")
 
70
                                                           "/Library/Frameworks/"
 
71
                                                           "/System/Library/Frameworks/"))
 
72
                                    :pred file-is-readable?)))
 
73
                (c-load-library filename))
 
74
              (errorf "framework ~a is not found" name)))))
 
75
 
 
76
(define c-load-framework (with-module c-wrapper.objc-ffi %c-load-framework))
 
77
 
 
78
(define method-pool (make-hash-table 'string=?))
 
79
(define ivar-pool (make-hash-table 'equal?))
 
80
 
 
81
(define (@ str)
 
82
  (objc-string <id> str)  )
 
83
 
 
84
(define (@selector name)
 
85
  (sel_registerName (x->string name)))
 
86
 
 
87
(define (encode-objc-type c-type)
 
88
  (format "~a~a"
 
89
          (cond
 
90
           ((equal? c-type <c-char>)
 
91
            "c")
 
92
           ((equal? c-type <c-int>)
 
93
            "i")
 
94
           ((equal? c-type <c-short>)
 
95
            "s")
 
96
           ((equal? c-type <c-long>)
 
97
            "l")
 
98
           ((equal? c-type <c-longlong>)
 
99
            "q")
 
100
           ((equal? c-type <c-uchar>)
 
101
            "C")
 
102
           ((equal? c-type <c-uint>)
 
103
            "I")
 
104
           ((equal? c-type <c-ushort>)
 
105
            "S")
 
106
           ((equal? c-type <c-ulong>)
 
107
            "L")
 
108
           ((equal? c-type <c-ulonglong>)
 
109
            "Q")
 
110
           ((equal? c-type <c-float>)
 
111
            "f")
 
112
           ((equal? c-type <c-double>)
 
113
            "d")
 
114
           ((equal? c-type <c-void>)
 
115
            "v")
 
116
           ((equal? c-type <id>)
 
117
            "@")
 
118
           ((equal? c-type <Class>)
 
119
            "#")
 
120
           ((equal? c-type <SEL>)
 
121
            ":")
 
122
           ((is-a? c-type <c-array-meta>)
 
123
            (format "[~a]" (encode-objc-type (element-type-of c-type))))
 
124
           ((is-a? c-type <c-struct-meta>)
 
125
            (format "{~a}"
 
126
                    (string-append (map (lambda (alist)
 
127
                                          (format "~a=~a"
 
128
                                                  (car alist)
 
129
                                                  (encode-objc-type (cdr alist))))
 
130
                                        (decl-alist-of c-type)))))
 
131
           ((is-a? c-type <c-union-meta>)
 
132
            (format "(~a)"
 
133
                    (string-append (map (lambda (alist)
 
134
                                          (format "~a"
 
135
                                                  (encode-objc-type (cdr alist))))
 
136
                                        (decl-alist-of c-type)))))
 
137
           ((bit-field? c-type)
 
138
                   "b")
 
139
                  ((is-a? c-type <c-ptr-meta>)
 
140
                   (format "^~a" (encode-objc-type (orig-c-type-of c-type))))
 
141
                  (else
 
142
                   "?"))
 
143
          (cond
 
144
           ((bit-field? c-type)
 
145
            (bits-of c-type))
 
146
           (else
 
147
            (c-sizeof c-type)))))
 
148
            
 
149
                           
 
150
(define (objc-lookup-class name)
 
151
  (objc_lookUpClass (symbol->string name)))
 
152
 
 
153
(define (objc-register-method name type-list)
 
154
  (hash-table-put! method-pool name type-list))
 
155
 
 
156
(define (nil? x)
 
157
  (eq? (ref x) nil))
 
158
 
 
159
(define (objc-make-class name super-class-ptr)
 
160
  (unless (nil? (objc-lookup-class name))
 
161
    (errorf "Objective-C class '~a' is already exists." name))
 
162
  (let ((root-class-ptr (do ((class-ptr super-class-ptr
 
163
                                        (ref (deref class-ptr) 'super_class)))
 
164
                            ((nil? (ref (deref class-ptr) 'super_class))
 
165
                             class-ptr)))
 
166
        (new-class (deref (cast <Class>
 
167
                                (malloc (c-sizeof (c-struct 'objc_class))))))
 
168
        (meta-class (deref (cast <Class>
 
169
                                 (malloc (c-sizeof (c-struct 'objc_class)))))))
 
170
    (set! (ref new-class 'isa) (ptr meta-class))
 
171
    (set! (ref new-class 'info) CLS_CLASS)
 
172
    (set! (ref meta-class 'info) CLS_META)
 
173
    
 
174
    (set! (ref new-class 'name) (symbol->string name))
 
175
    (set! (ref meta-class 'name) (symbol->string name))
 
176
    
 
177
    (set! (ref new-class 'methodLists) (make-null-ptr))
 
178
    (set! (ref meta-class 'methodLists) (make-null-ptr))
 
179
    
 
180
    (set! (ref new-class 'super_class) super-class-ptr)
 
181
    (set! (ref meta-class 'super_class) (ref (deref super-class-ptr) 'isa))
 
182
    (set! (ref meta-class 'isa) (ref (deref root-class-ptr) 'isa))
 
183
    
 
184
    (set! (ref new-class 'instance_size) (ref (deref super-class-ptr)
 
185
                                              'instance_size))
 
186
    (set! (ref meta-class 'instance_size)
 
187
          (ref (deref (ref meta-class 'super_class)) 'instance_size))
 
188
    
 
189
    (objc_addClass (ptr new-class))
 
190
    new-class))
 
191
 
 
192
(define (objc-add-method class method-name ret-type arg-types proc)
 
193
  (let ((selector (@selector method-name))
 
194
        (method (make (c-struct 'objc_method)))
 
195
        (method-list (make (c-struct 'objc_method_list))))
 
196
    (set! (ref method 'method_name) selector)
 
197
    (set! (ref method 'method_types)
 
198
          (apply string-append (map encode-objc-type
 
199
                                    (list* ret-type <id> <SEL> arg-types))))
 
200
    (set! (ref method 'method_imp)
 
201
          (cast (c-func-ptr ret-type (list* <id> <SEL> arg-types)) proc))
 
202
    
 
203
    (set! (ref method-list 'method_count) 1)
 
204
    (set! (ref (ref method-list 'method_list) 0) method)
 
205
    
 
206
    (class_addMethods class (ptr method-list))))
 
207
 
 
208
(define (needs-objc_msgSend_stret? ret-type)
 
209
  (define (composite-type? ret-type)
 
210
    (or (is-a? ret-type <c-struct-meta>)
 
211
        (is-a? ret-type <c-union-meta>)))
 
212
  (if (big-endian?)
 
213
      ;; Mac on PPC
 
214
      (composite-type? ret-type)
 
215
      ;; Mac on Intel
 
216
      (cond
 
217
       ((not (composite-type? ret-type))
 
218
        #f)
 
219
       ((< 8 (c-sizeof ret-type))
 
220
        #t)
 
221
       (else
 
222
        (let loop ((composite-type ret-type))
 
223
          (find (lambda (type)
 
224
                  (cond
 
225
                   ((composite-type? type)
 
226
                    (loop type))
 
227
                   ((and (is-a? type <c-array-meta>)
 
228
                         (< 1 (size-of type)))
 
229
                    #t)
 
230
                   (else
 
231
                    #f)))
 
232
                (map cdr (decl-alist-of composite-type))))))))
 
233
        
 
234
(define (%objc-msg-send obj super? selector-name . args)
 
235
  (or (and-let* ((lst (hash-table-get method-pool selector-name)))
 
236
        (let* ((ret-type (car lst))
 
237
               (arg-types (cdr lst))
 
238
               (send (if (needs-objc_msgSend_stret? ret-type)
 
239
                         (lambda (obj selector . args)
 
240
                           (let ((retval (make ret-type)))
 
241
                             (apply (make-c-func-vaargs
 
242
                                     (if super?
 
243
                                         'objc_msgSendSuper_stret
 
244
                                         'objc_msgSend_stret)
 
245
                                     <c-void>
 
246
                                     (append (list (ptr <c-void>)
 
247
                                                   (if super?
 
248
                                                       (ptr (c-struct 'objc_super))
 
249
                                                       <id>)
 
250
                                                   <SEL>)
 
251
                                             arg-types))
 
252
                                    (ptr retval) obj selector args)
 
253
                             retval))
 
254
                         (make-c-func-vaargs (if super?
 
255
                                                 'objc_msgSendSuper
 
256
                                                 'objc_msgSend)
 
257
                                             ret-type
 
258
                                             (append (list (if super?
 
259
                                                               (ptr (c-struct 'objc_super))
 
260
                                                               <id>)
 
261
                                                           <SEL>)
 
262
                                                     arg-types))))
 
263
               (sel (@selector selector-name)))
 
264
          (if (null-ptr? sel)
 
265
              (errorf "selector ~a is not found." selector-name)
 
266
              (apply send obj sel args))))
 
267
      (errorf "selector ~a is not found." selector-name)))
 
268
                                       
 
269
(define (args->selector-name args)
 
270
  (string-append
 
271
   (string-join (map x->string
 
272
                     (filter (lambda (elem)
 
273
                               (or (symbol? elem) (keyword? elem)))
 
274
                             args))
 
275
                ":")
 
276
   (if (= (length args) 1)
 
277
       ""
 
278
       ":")))
 
279
 
 
280
(define (filter-args args)
 
281
  (remove (lambda (elem) (or (symbol? elem) (keyword? elem))) args))
 
282
 
 
283
(define-method object-apply ((obj <id>) . rest)
 
284
  (apply %objc-msg-send obj #f (args->selector-name rest) (filter-args rest)))
 
285
 
 
286
(define-method object-apply ((obj (ptr (c-struct 'objc_super))) . rest)
 
287
  (apply %objc-msg-send obj #t (args->selector-name rest) (filter-args rest)))
 
288
 
 
289
(define (make-super class obj)
 
290
  (let ((data (make (c-struct 'objc_super))))
 
291
    (set! (ref data 'receiver) obj)
 
292
    (set! (ref data 'class)
 
293
          (ref (deref (cast (ptr (c-struct 'objc_class)) class)) 'super_class))
 
294
    (ptr data)))
 
295
 
 
296
(provide "c-wrapper/objc-ffi")
 
297
 
 
298
;; end of file