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

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

objc: compiles now

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