source: project/release/3/objc/trunk/objc-base.scm @ 9966

Last change on this file since 9966 was 9966, checked in by Kon Lovett, 13 years ago

Using canonical directory structure.

  • Property svn:executable set to *
File size: 10.3 KB
Line 
1;;; objc Scheme<->ObjC bridge
2
3;(use objc-support) ;; instead, use require-at-runtime in objc.setup
4;(objc:import-classes-at-toplevel!)
5
6;;; invoker macros
7
8;; (objc TypeTest printInt: 1.1 Double: 2.2 Float: 3.3)
9;; Allows target "super" -- e.g. @[super init] is transformed
10;; into @[self classname:super:init].  (The classname: is required
11;; because super calls the superclass of the class defining method, not
12;; the superclass of self.)
13
14(define-macro (objc:send target arg . args)
15  (%objc #f target arg args))
16(define-macro (objc:send/safe target arg . args)
17  (%objc #t target arg args))
18(define-macro (objc:send/maybe-safe target arg . args)
19  (%objc 'maybe target arg args))
20(define-macro (@ . args)
21  `(objc:send/maybe-safe ,@args))
22
23
24;; Old forms:
25;; (define-macro (objc . args)
26;;   `(objc:send ,@args))            ;; doesn't work (?)
27;; (define-macro (objc/safe . args)
28;;   `(objc:send/safe ,@args))
29
30(define (%objc safe? target arg args)
31  (let ((super? (eq? target 'super)))
32    (if (null? args)
33        (if super?
34            `(objc:invoker ',safe? self (string-append _supersel
35                                                      ,(objcify-selector (symbol->string arg))))
36            `(objc:invoker ',safe? ,target ,(objcify-selector (symbol->string arg))))
37        (receive (method passargs)
38            (apply objc:aggregate-args (cons arg args))
39          (if super?
40              `(objc:invoker ',safe? self (string-append _supersel ,(objcify-selector method))
41                             ,@passargs)
42              `(objc:invoker ',safe? ,target ,(objcify-selector method) ,@passargs))))))
43
44;; For parameter names, we accept actual keywords instead of symbols ending in :.
45;; Thus, depending on the current keyword-style, initWithValue:, #:initWithValue, or
46;; :initWithValue will be converted to "initWithValue:".
47;; Note a single argument taking no value requires a bare symbol, not a keyword.
48(eval-when [compile eval]
49 (set! objc:aggregate-args (lambda args
50  (letrec ((keyword (lambda (ls method-name params)
51                      (if (null? ls)
52                          (values method-name (reverse params))
53                          (param (cdr ls)
54                                 (string-append
55                                  method-name
56                                  (let ((this-method (car ls)))
57                                    (cond ((keyword? this-method)
58                                           (string-append (symbol->string this-method) ":"))
59                                          ((symbol? this-method)
60                                           (symbol->string this-method))
61                                          (error 'objc "keyword expected" this-method))))
62                                 params))))
63           (param   (lambda (ls method-name params)
64                      (if (null? ls)
65                          (error 'objc "malformed method name")
66                          (keyword (cdr ls)
67                                   method-name
68                                   (cons (car ls) params))))))
69    (keyword args "" '())))))
70
71;; Convert a scheme-type selector string to Objective C syntax.  This simply entails
72;; uppercasing any character after a hyphen.  This is only done during macroexpansion.
73(eval-when [compile eval]
74  (require 'srfi-13)           
75  (define (objcify-selector sel)
76    (let ((pieces (string-split sel "-")))
77      (for-each (lambda (s) (string-upcase! s 0 1))
78                (cdr pieces))
79      (apply string-append pieces))))
80
81;;; Instance variables
82
83;; This macro is slightly counterintuitive, as the name is expected to be a symbol
84;; (and thus fixed at read time).  On the other hand, you can use objc:ivar-ref,
85;; which takes a real string.
86;; Note: these are macros, and cannot comply with SRFI-17.  However, (ivar-set! ...) is
87;; shorter than (set! (ivar-ref ...)) anyway, and the (set! @foo 'bar) syntax still works.
88(define-macro (ivar-ref obj name)
89  `(objc:ivar-ref ,obj ,(symbol->string name)))
90(define-macro (ivar-set! obj name val)
91  `(objc:ivar-set! ,obj ,(symbol->string name) ,val))
92
93;;; Class definitions
94
95;;;; define-class
96
97#|
98
99Example transformation:
100
101(define-objc-class MyPoint NSObject ((FLT x) (FLT y))
102  (define-method FLT getX (ivar-ref self x))
103  (define-method VOID ((moveByX: FLT a) (Y: FLT b))
104    (ivar-set! self x (+ a (ivar-ref self x)))
105    (ivar-set! self y (+ b (ivar-ref self y)))))
106
107=>
108
109(begin
110  (if (string-to-class "MyPoint")
111      (warning (conc "(define-objc-class): class already registered: " 'MyPoint))
112      (objc:register-class "MyPoint" (objc:string->class "NSObject")))
113  (define-objc-classes MyPoint)
114  (objc:set-ivars! MyPoint (list (make-objc:raw-ivar "x" objc:FLT 0)
115                                (make-objc:raw-ivar "y" objc:FLT 0)))
116  (objc:define-method MyPoint FLT getX (ivar-ref self x))
117  (objc:define-method MyPoint VOID ((moveByX: FLT a) (Y: FLT b))
118    (ivar-set! self x (+ a (ivar-ref self x)))
119    (ivar-set! self y (+ b (ivar-ref self y)))))
120
121|#
122
123;; The superclass will be looked up for you; it does not need to be imported.
124(define-macro (define-objc-class class super ivars . methods)
125  `(begin
126     ;; register class
127     (if (string-to-class ,(symbol->string class))
128         ((if (objc:allow-class-redefinition)
129              warning error)
130          ,(string-append "(define-objc-class): class already registered: "
131                          (symbol->string class)))
132         (objc:register-class ,(symbol->string class)
133                              (objc:string->class ,(symbol->string super))))
134     ;; import class
135     (define-objc-classes ,class)
136     ;; set instance variables
137     (objc:set-ivars! ,class
138                     (list ,@(map (lambda (ivar)
139                                    (let ((type (car ivar))
140                                          (name (cadr ivar)))
141                                      `(make-objc:raw-ivar ,(symbol->string name)
142                                                           ,(macro:type->encoding type)
143                                                           0)))
144                                  ivars)))
145     ;; add methods
146     ,@(map (lambda (method)
147              (let ((definer (case (car method)
148                               ((define-method -) 'objc:define-method)
149                               ((define-class-method +) 'objc:define-class-method)
150                               (else (error "invalid method definition keyword" (car method))))))
151                `(,definer ,class ,@(cdr method))))
152            methods)))
153 
154;;;; define-method
155
156;; Transformation:
157;; (objc:define-method MyClass DBL ((sel1: INT i) (sel2: DBL d))
158;;                                 (print i) (+ i d))
159;; =>
160;; (objc:add-method MyClass "sel1:sel2:" (list objc:DBL objc:ID objc:SEL objc:INT objc:DBL)
161;;                                       (lambda (self sel i d) (print i) (+ i d)))
162(define-macro (objc:define-method class rt args . body)
163  (%define-method #f class rt args body))
164(define-macro (objc:define-class-method class rt args . body)
165  (%define-method #t class rt args body))
166
167(define (macro:type->encoding x)   ;; internal
168  (cond ((symbol? x) (string->symbol
169                      (string-append "objc:" (symbol->string x))))
170        (else x)))
171
172;; Discrepancy: we compute _classname at macroexpansion time from the class -symbol-, but
173;; objc:add-method creates the super selector at runtime from the actual registered class name.
174
175(eval-when [compile eval]
176 (set! %define-method (lambda (class? class rt args body)  ;; internal helper function
177  (define (add-method-body method-name types names)
178    (let ((self-type  (if class? 'CLASS 'ID))
179          (add-method (if class? 'objc:add-class-method
180                          'objc:add-method)))
181      `(,add-method ,class
182                    ,(objcify-selector method-name)
183                    (list ,@(map (cut macro:type->encoding <>) (apply list rt self-type 'SEL types)))
184                    (let ((_supersel (string-append ,(symbol->string class) ":super:")))
185                      ;; _supersel is a hidden variable used by @[super..]
186                      (lambda (self sel ,@names) ,@body)))))
187
188  (if (pair? args)
189      (let* ((args  (apply map list args))  ;; '((sel: type name) ...) =>
190             ;; '((sel: ...) (type ...) (name ...))
191             (sels  (car args))
192             (types (cadr args))
193             (names (caddr args))
194             (method-name (apply string-append
195                                 (map (lambda (x) (string-append (keyword->string x) ":"))
196                                      sels))))
197        (add-method-body method-name types names))
198      (let ((method-name (if (keyword? args)
199                             (error 'objc:define-method "argument required for selector" args)
200                             (symbol->string args))))
201        (add-method-body method-name '() '()))))))
202   
203;; Note: type is normally a keyword; objc: will be prepended (e.g. objc:ID).  If
204;; not a keyword, it is pasted verbatim so you can e.g. pass an encoded typestring.
205
206;;; Importing classes
207
208(define-macro (define-objc-classes . names)
209  `(begin
210     ,@(map (lambda (name)
211              (cond ((symbol? name)
212                     `(define ,name (objc:string->class ,(->string name)) ))
213                    ((and (list? name) (= (length name) 2) (symbol? (car name)))
214                     `(define ,(car name) (objc:string->class ,(->string (cadr name)))) )
215                    (else (syntax-error 'define-objc-classes "invalid class name" name))))
216            names) ) )
217
218;;; Read syntax
219
220;; Felix's @[] read syntax implementation, with one tweak: all calls are maybe-safe
221;; unless prefixed by unsafe: or safe:.
222;; @[target sel1: x sel2: y] => (objc sel1: x sel2: y)
223;; @"..."                    => creates NSString from "..."
224;; @foo                      => (ivar-ref self foo)
225(set-read-syntax! 
226 #\@
227 (let ([terminating-characters '(#\, #\; #\) #\] #\{ #\} #\')])
228   (lambda (p)
229     (let ((c (peek-char p)))
230       (if (or (char-whitespace? c) (memq c terminating-characters))
231           '@
232           (let ((x (read p)))
233             (cond ((keyword? x) (string->keyword (string-append "@" (keyword->string x))))
234                   ((symbol? x) ;(string->symbol (string-append "@" (symbol->string x)
235                    `(objc:ivar-ref self ,(symbol->string x)))  ;; Can't use macro due to SRFI-17
236                   ((string? x) `(force (delay (objc:nsstring ,x))))
237                   ((pair? x) 
238                    (cond ((eq? #:safe (car x))
239                           `(objc:send/safe ,@(cdr x)))
240                          ((eq? #:unsafe (car x))
241                           `(objc:send ,@(cdr x)))
242                          (else
243                           `(objc:send/maybe-safe ,@x))))
244                   (else (error "invalid read syntax for `@'" c)) ) ) ) ) ) ) )
245
Note: See TracBrowser for help on using the repository browser.