source: project/release/4/objc/trunk/objc-base.scm @ 14899

Last change on this file since 14899 was 14899, checked in by Alex Shinn, 12 years ago

initial conversion, not yet working
  • Property svn:executable set to *
File size: 16.9 KB
Line 
1;;; objc Scheme<->ObjC bridge
2
3;(objc:import-classes-at-toplevel!)
4
5(require-library lolevel foreigners easyffi srfi-13 srfi-69)
6
7(module objc-base
8  (define-objc-class
9   define-objc-classes
10   objc:define-method
11   objc:define-class-method
12   objc:send
13   objc:send/safe
14   objc:send/maybe-safe
15   @
16   ivar-ref
17   ivar-set!
18   Class-cache
19   Class-info
20   Class-info-set!
21   Class-instance_size
22   Class-instance_size-set!
23   Class-isa
24   Class-isa-set!
25   Class-ivars
26   Class-ivars-set!
27   Class-methodLists
28   Class-name
29   Class-name-set!
30   Class-protocols
31   Class-super_class
32   Class-super_class-set!
33   Class-version
34   Class-version-set!
35   Ivar-ivar_name
36   Ivar-ivar_name-set!
37   Ivar-ivar_offset
38   Ivar-ivar_offset-set!
39   Ivar-ivar_type
40   Ivar-ivar_type-set!
41   Ivar-list-ivar_count
42   Ivar-list-ivar_count-set!
43   Ivar-list-ivar_list
44   Method-method_imp
45   Method-method_imp-set!
46   Method-method_name
47   Method-method_name-set!
48   Method-method_types
49   Method-method_types-set!
50   NSPoint-x
51   NSPoint-x-set!
52   NSPoint-y
53   NSPoint-y-set!
54   NSRange-length
55   NSRange-length-set!
56   NSRange-location
57   NSRange-location-set!
58   NSRect-height
59   NSRect-height-set!
60   NSRect-width
61   NSRect-width-set!
62   NSRect-x
63   NSRect-x-set!
64   NSRect-y
65   NSRect-y-set!
66   NSSize-height
67   NSSize-height-set!
68   NSSize-width
69   NSSize-width-set!
70   add-method-definition
71   alignof-type
72   allocate-ivar-list
73   arg-converter
74   c-c-string0
75   char->ref
76   class-of
77   create-invocation
78   double->ref
79   find-ivar
80   find-superclass-method
81   float->ref
82   get-return-value!
83   instance-selector-to-signature
84   int->ref
85   invoke
86   invoke-safe
87   is-nsstring
88   ivar-base-offset
89   long->ref
90   make-autorelease-pool
91   make-imp-closure
92   make-method-proxy
93   make-ns:point
94   make-ns:range
95   make-ns:rect
96   make-ns:size
97   make-nsstring
98   make-objc-ffi-closure
99   make-objc:class
100   make-objc:instance
101   make-objc:raw-ivar
102   method-argument-count
103   method-argument-type
104   method-return-length
105   method-return-type
106   new-autorelease-pool
107   ns:make-point
108   ns:make-range
109   ns:make-rect
110   ns:make-size
111   ns:point->ref
112   ns:point-x
113   ns:point-x-set!
114   ns:point-y
115   ns:point-y-set!
116   ns:point?
117   ns:range->ref
118   ns:range-length
119   ns:range-length-set!
120   ns:range-location
121   ns:range-location-set!
122   ns:range?
123   ns:rect->ref
124   ns:rect-height
125   ns:rect-height-set!
126   ns:rect-width
127   ns:rect-width-set!
128   ns:rect-x
129   ns:rect-x-set!
130   ns:rect-y
131   ns:rect-y-set!
132   ns:rect?
133   ns:size->ref
134   ns:size-height
135   ns:size-height-set!
136   ns:size-width
137   ns:size-width-set!
138   ns:size?
139   nsstring-to-string
140   objc-description
141   objc-release
142   objc-retain
143   objc-retain-count
144   objc:BOOL
145   objc:CHARPTR
146   objc:CHR
147   objc:CLASS
148   objc:DBL
149   objc:FLT
150   objc:ID
151   objc:INT
152   objc:LNG
153   objc:NSPOINT
154   objc:NSRANGE
155   objc:NSRECT
156   objc:NSSIZE
157   objc:PTR
158   objc:SEL
159   objc:SHT
160   objc:UCHR
161   objc:UINT
162   objc:ULNG
163   objc:USHT
164   objc:VOID
165   objc:_get_class_list!
166   objc:add-class-method
167   objc:add-method
168   objc:alignof-type
169   objc:allow-class-redefinition
170   objc:char->char-or-bool
171   objc:char-or-bool->char
172   objc:char-or-bool->ref
173   objc:class->pointer
174   objc:class->ref
175   objc:class-class-method-list
176   objc:class-ivar-list
177   objc:class-ivars
178   objc:class-meta-class
179   objc:class-method-list
180   objc:class-name
181   objc:class-objc?
182   objc:class-of
183   objc:class-or-instance-ptr
184   objc:class-ptr
185   objc:class-ptr-set!
186   objc:class-super-class
187   objc:class?
188   objc:classes
189   objc:get-class-list
190   objc:import-classes-at-toplevel!
191   objc:instance->pointer
192   objc:instance->ref
193   objc:instance-ptr
194   objc:instance-ptr-set!
195   objc:instance?
196   objc:invoker
197   objc:ivar-ref
198   objc:ivar-set!
199   objc:nsstring
200   objc:nsstring->string
201   objc:number-of-classes
202   objc:optimize-callbacks
203   objc:pointer->class
204   objc:pointer->instance
205   objc:raw-ivar-name
206   objc:raw-ivar-name-set!
207   objc:raw-ivar-offset
208   objc:raw-ivar-offset-set!
209   objc:raw-ivar-type
210   objc:raw-ivar-type-set!
211   objc:raw-ivar?
212   objc:ref->char-or-bool
213   objc:ref->class
214   objc:ref->instance
215   objc:ref->scheme-object
216   objc:ref->selector
217   objc:register-class
218   objc:scheme-object->ref
219   objc:selector->ref
220   objc:set-ivars!
221   objc:sizeof-type
222   objc:string->class
223   objc_class_method_list
224   pointer-ptr-ref
225   ptr->ref
226   ptr-array->pointer-vector!
227   ptr-array-map->list
228   ptr-array-ref
229   ref->char
230   ref->double
231   ref->float
232   ref->int
233   ref->long
234   ref->ns:point
235   ref->ns:range
236   ref->ns:rect
237   ref->ns:size
238   ref->ptr
239   ref->short
240   ref->string
241   ref->struct
242   ref->uchar
243   ref->uint
244   ref->ulong
245   ref->ushort
246   ref->void
247   ref_to_scheme_object
248   register-class
249   result-converter
250   retain-and-autorelease
251   retain-count
252   scheme_object_to_ref
253   selector-allocates?
254   selector-to-signature
255   set-class-ivar
256   set-method-argument
257   short->ref
258   signature-to-ffi-return-type
259   signature-to-ffi-type
260   sizeof-result-type
261   sizeof-type
262   string->new-selector
263   string->ref
264   string->selector
265   string-to-class
266   struct->ref
267   struct-to-ffi-type
268   uchar->ref
269   uint->ref
270   ulong->ref
271   ushort->ref
272   vector-map->list
273   void->ref
274   with-autorelease-pool
275   cocoa:run
276   ns:application-main
277   ns:beep
278   ns:log
279   ns:point->locative
280   ns:range->locative
281   ns:rect->locative
282   ns:rect-fill
283   ns:size->locative)
284
285(import scheme chicken extras lolevel data-structures foreigners easyffi)
286(import srfi-13 srfi-69)
287(include "objc-support.scm")
288
289;;; invoker macros
290
291;; (objc TypeTest printInt: 1.1 Double: 2.2 Float: 3.3)
292;; Allows target "super" -- e.g. @[super init] is transformed
293;; into @[self classname:super:init].  (The classname: is required
294;; because super calls the superclass of the class defining method, not
295;; the superclass of self.)
296
297(define-syntax objc:send
298  (er-macro-transformer
299   (lambda (e r c) (%objc r #f (cadr e) (caddr e) (cdddr e)))))
300(define-syntax objc:send/safe
301  (er-macro-transformer
302   (lambda (e r c) (%objc r #t (cadr e) (caddr e) (cdddr e)))))
303(define-syntax objc:send/maybe-safe
304  (er-macro-transformer
305   (lambda (e r c) (%objc r 'maybe (cadr e) (caddr e) (cdddr e)))))
306(define-syntax (@ . args)
307  (syntax-rules ()
308    ((_ args ...) (objc:send/maybe-safe args ...))))
309
310
311;; Old forms:
312;; (define-macro (objc . args)
313;;   `(objc:send ,@args))            ;; doesn't work (?)
314;; (define-macro (objc/safe . args)
315;;   `(objc:send/safe ,@args))
316
317(define (%objc r safe? target arg args)
318  ;; Convert a scheme-type selector string to Objective C syntax.
319  ;; This simply entails uppercasing any character after a hyphen.
320  ;; This is only done during macroexpansion.
321  (define (objcify-selector sel)
322    (let ((pieces (string-split sel "-")))
323      (for-each (lambda (s) (string-upcase! s 0 1)) (cdr pieces))
324      (apply string-append pieces)))
325  ;; For parameter names, we accept actual keywords instead of symbols
326  ;; ending in :.  Thus, depending on the current keyword-style,
327  ;; initWithValue:, #:initWithValue, or :initWithValue will be
328  ;; converted to "initWithValue:".  Note a single argument taking no
329  ;; value requires a bare symbol, not a keyword.
330  (define objc:aggregate-args
331    (lambda args
332      (letrec ((keyword (lambda (ls method-name params)
333                          (if (null? ls)
334                              (values method-name (reverse params))
335                              (param (cdr ls)
336                                     (string-append
337                                      method-name
338                                      (let ((this-method (car ls)))
339                                        (cond ((keyword? this-method)
340                                               (string-append (symbol->string this-method) ":"))
341                                              ((symbol? this-method)
342                                               (symbol->string this-method))
343                                              (error 'objc "keyword expected" this-method))))
344                                     params))))
345               (param   (lambda (ls method-name params)
346                          (if (null? ls)
347                              (error 'objc "malformed method name")
348                              (keyword (cdr ls)
349                                       method-name
350                                       (cons (car ls) params))))))
351        (keyword args "" '()))))
352  (let ((super? (eq? target 'super)))
353    (if (null? args)
354        (if super?
355            `(objc:invoker ',safe? self (string-append _supersel
356                                                       ,(objcify-selector (symbol->string arg))))
357            `(objc:invoker ',safe? ,target ,(objcify-selector (symbol->string arg))))
358        (receive (method passargs)
359            (apply objc:aggregate-args (cons arg args))
360          (if super?
361              `(objc:invoker ',safe? self (string-append _supersel ,(objcify-selector method))
362                             ,@passargs)
363              `(objc:invoker ',safe? ,target ,(objcify-selector method) ,@passargs))))))
364
365;;; Instance variables
366
367;; This macro is slightly counterintuitive, as the name is expected to be a symbol
368;; (and thus fixed at read time).  On the other hand, you can use objc:ivar-ref,
369;; which takes a real string.
370;; Note: these are macros, and cannot comply with SRFI-17.  However, (ivar-set! ...) is
371;; shorter than (set! (ivar-ref ...)) anyway, and the (set! @foo 'bar) syntax still works.
372(define-syntax ivar-ref
373  (er-macro-transformer
374   (lambda (e r c)
375     `(,(r 'objc:ivar-ref) ,(cadr e) ,(symbol->string (caddr e))))))
376(define-syntax ivar-set!
377  (er-macro-transformer
378   (lambda (e r c)
379     `(,(r 'objc:ivar-set!)
380       ,(cadr e)
381       ,(symbol->string (caddr e))
382       ,(cadddr e)))))
383
384;;; Class definitions
385
386;;;; define-class
387
388#|
389
390Example transformation:
391
392(define-objc-class MyPoint NSObject ((FLT x) (FLT y))
393  (define-method FLT getX (ivar-ref self x))
394  (define-method VOID ((moveByX: FLT a) (Y: FLT b))
395    (ivar-set! self x (+ a (ivar-ref self x)))
396    (ivar-set! self y (+ b (ivar-ref self y)))))
397
398=>
399
400(begin
401  (if (string-to-class "MyPoint")
402      (warning (conc "(define-objc-class): class already registered: " 'MyPoint))
403      (objc:register-class "MyPoint" (objc:string->class "NSObject")))
404  (define-objc-classes MyPoint)
405  (objc:set-ivars! MyPoint (list (make-objc:raw-ivar "x" objc:FLT 0)
406                                (make-objc:raw-ivar "y" objc:FLT 0)))
407  (objc:define-method MyPoint FLT getX (ivar-ref self x))
408  (objc:define-method MyPoint VOID ((moveByX: FLT a) (Y: FLT b))
409    (ivar-set! self x (+ a (ivar-ref self x)))
410    (ivar-set! self y (+ b (ivar-ref self y)))))
411
412|#
413
414;; The superclass will be looked up for you; it does not need to be imported.
415(define-syntax define-objc-class
416  (er-macro-transformer
417   (lambda (e r c)
418     (let ((class (cadr e))
419           (super (caddr e))
420           (ivars (cadddr e))
421           (methods (cddddr e)))
422       `(begin
423          ;; register class
424          (if (string-to-class ,(symbol->string class))
425              ((if (objc:allow-class-redefinition)
426                   warning error)
427               ,(string-append "(define-objc-class): class already registered: "
428                               (symbol->string class)))
429              (objc:register-class ,(symbol->string class)
430                                   (objc:string->class ,(symbol->string super))))
431          ;; import class
432          (define-objc-classes ,class)
433          ;; set instance variables
434          (objc:set-ivars! ,class
435                           (list ,@(map (lambda (ivar)
436                                          (let ((type (car ivar))
437                                                (name (cadr ivar)))
438                                            `(make-objc:raw-ivar ,(symbol->string name)
439                                                                 ,(macro:type->encoding type)
440                                                                 0)))
441                                        ivars)))
442          ;; add methods
443          ,@(map (lambda (method)
444                   (let ((definer (case (car method)
445                                    ((define-method -) 'objc:define-method)
446                                    ((define-class-method +) 'objc:define-class-method)
447                                    (else (error "invalid method definition keyword" (car method))))))
448                     `(,definer ,class ,@(cdr method))))
449                 methods))))))
450 
451;;;; define-method
452
453;; Transformation:
454;; (objc:define-method MyClass DBL ((sel1: INT i) (sel2: DBL d))
455;;                                 (print i) (+ i d))
456;; =>
457;; (objc:add-method MyClass "sel1:sel2:" (list objc:DBL objc:ID objc:SEL objc:INT objc:DBL)
458;;                                       (lambda (self sel i d) (print i) (+ i d)))
459(define-syntax objc:define-method
460  (er-macro-transformer
461   (lambda (e r c)
462     (%define-method #f (cadr e) (caddr e) (cadddr e) (cddddr e)))))
463(define-syntax objc:define-class-method
464  (er-macro-transformer
465   (lambda (e r c)
466     (%define-method #t (cadr e) (caddr e) (cadddr e) (cddddr e)))))
467
468(define (macro:type->encoding x)   ;; internal
469  (cond ((symbol? x) (string->symbol
470                      (string-append "objc:" (symbol->string x))))
471        (else x)))
472
473;; Discrepancy: we compute _classname at macroexpansion time from the class -symbol-, but
474;; objc:add-method creates the super selector at runtime from the actual registered class name.
475
476(define-for-syntax %define-method
477  (lambda (class? class rt args body)  ;; internal helper function
478    ;; XXXX duplicated from above, workaround issues with define-for-syntax
479    (define (objcify-selector sel)
480      (let ((pieces (string-split sel "-")))
481        (for-each (lambda (s) (string-upcase! s 0 1)) (cdr pieces))
482        (apply string-append pieces)))
483    (define (add-method-body method-name types names)
484      (let ((self-type  (if class? 'CLASS 'ID))
485            (add-method (if class? 'objc:add-class-method
486                            'objc:add-method)))
487        `(,add-method ,class
488                      ,(objcify-selector method-name)
489                      (list ,@(map (cut macro:type->encoding <>) (apply list rt self-type 'SEL types)))
490                      (let ((_supersel (string-append ,(symbol->string class) ":super:")))
491                        ;; _supersel is a hidden variable used by @[super..]
492                        (lambda (self sel ,@names) ,@body)))))
493
494    (if (pair? args)
495        (let* ((args  (apply map list args))  ;; '((sel: type name) ...) =>
496               ;; '((sel: ...) (type ...) (name ...))
497               (sels  (car args))
498               (types (cadr args))
499               (names (caddr args))
500               (method-name (apply string-append
501                                   (map (lambda (x) (string-append (keyword->string x) ":"))
502                                        sels))))
503          (add-method-body method-name types names))
504        (let ((method-name (if (keyword? args)
505                               (error 'objc:define-method "argument required for selector" args)
506                               (symbol->string args))))
507          (add-method-body method-name '() '())))))
508
509;; Note: type is normally a keyword; objc: will be prepended (e.g. objc:ID).  If
510;; not a keyword, it is pasted verbatim so you can e.g. pass an encoded typestring.
511
512;;; Importing classes
513
514(define-syntax define-objc-classes
515  (er-macro-transformer
516   (lambda (e r c)
517     `(begin
518        ,@(map
519           (lambda (name)
520             (cond
521              ((symbol? name)
522               `(define ,name (objc:string->class ,(->string name))))
523              ((and (list? name) (= (length name) 2) (symbol? (car name)))
524               `(define ,(car name)
525                  (objc:string->class ,(->string (cadr name)))))
526              (else
527               (syntax-error 'define-objc-classes "invalid class name" name))))
528           (cdr e))))))
529
530;;; Read syntax
531
532;; Felix's @[] read syntax implementation, with one tweak: all calls are maybe-safe
533;; unless prefixed by unsafe: or safe:.
534;; @[target sel1: x sel2: y] => (objc sel1: x sel2: y)
535;; @"..."                    => creates NSString from "..."
536;; @foo                      => (ivar-ref self foo)
537(set-read-syntax! 
538 #\@
539 (let ([terminating-characters '(#\, #\; #\) #\] #\{ #\} #\')])
540   (lambda (p)
541     (let ((c (peek-char p)))
542       (if (or (char-whitespace? c) (memq c terminating-characters))
543           '@
544           (let ((x (read p)))
545             (cond ((keyword? x) (string->keyword (string-append "@" (keyword->string x))))
546                   ((symbol? x) ;(string->symbol (string-append "@" (symbol->string x)
547                    `(objc:ivar-ref self ,(symbol->string x)))  ;; Can't use macro due to SRFI-17
548                   ((string? x) `(force (delay (objc:nsstring ,x))))
549                   ((pair? x) 
550                    (cond ((eq? #:safe (car x))
551                           `(objc:send/safe ,@(cdr x)))
552                          ((eq? #:unsafe (car x))
553                           `(objc:send ,@(cdr x)))
554                          (else
555                           `(objc:send/maybe-safe ,@x))))
556                   (else (error "invalid read syntax for `@'" c)) ) ) ) ) ) ) )
557
558)
Note: See TracBrowser for help on using the repository browser.