Changeset 14899 in project
- Timestamp:
- 06/06/09 09:56:38 (12 years ago)
- Location:
- release/4/objc
- Files:
-
- 2 deleted
- 9 edited
- 1 copied
Legend:
- Unmodified
- Added
- Removed
-
release/4/objc/trunk/classes.scm
r9966 r14899 104 104 <# 105 105 106 (define-record objc:raw-ivar name type offset) 106 (define-record-type objc:raw-ivar 107 (make-objc:raw-ivar name type offset) 108 objc:raw-ivar? 109 (name objc:raw-ivar-name objc:raw-ivar-name-set!) 110 (type objc:raw-ivar-type objc:raw-ivar-type-set!) 111 (offset objc:raw-ivar-offset objc:raw-ivar-offset-set!)) 112 107 113 (define-record-printer (objc:raw-ivar x p) 108 114 (fprintf p "#<raw-ivar: ~a ~s at ~a>" … … 513 519 ;;;; Method creation 514 520 515 (define-foreign-record (Method "struct objc_method") 516 (c-pointer method_name) ;; actually a SEL 517 (c-string method_types) ;; The way we use this, it could be a c-pointer. 518 (c-pointer method_imp)) 519 520 (define string->new-selector (foreign-lambda c-pointer "sel_registerName" c-string)) 521 (define-foreign-record-type (Method "struct objc_method") 522 (c-pointer method_name Method-method_name Method-method_name-set!) ;; actually a SEL 523 (c-string method_types Method-method_types Method-method_types-set!) ;; The way we use this, it could be a c-pointer. 524 (c-pointer method_imp Method-method_imp Method-method_imp-set!)) 525 526 (define string->new-selector 527 (foreign-lambda c-pointer "sel_registerName" c-string)) 521 528 522 529 (define (make-method-proxy typelist proc) -
release/4/objc/trunk/convert.scm
r9966 r14899 1 1 ;;; type conversion 2 3 (use srfi-69)4 2 5 3 ;; Objective C type signature definitions. … … 28 26 ;;; Convert Objective C references to Scheme objects. 29 27 30 (define-macro (define-result-conversion name to from) 31 `(define ,name (foreign-lambda* ,to (((pointer ,from) obj)) "return(*obj);"))) 28 (define-syntax define-result-conversion 29 (er-macro-transformer 30 (lambda (expr rename compare) 31 (let ((name (cadr expr)) 32 (from (caddr expr)) 33 (to (cadddr expr))) 34 `(,(rename 'define) ,name 35 (,(rename 'foreign-lambda*) ,to 36 (((pointer ,from) obj)) "return(*obj);")))))) 32 37 33 38 (define-result-conversion ref->float float "float") … … 82 87 (foreign-lambda* float (((pointer "NSRect") rect) (float val)) "rect->size.height = val;")) 83 88 84 (define-foreign-record (NSPoint "NSPoint")85 (float x )86 (float y ))87 (define-foreign-record (NSSize "NSSize")88 (float width )89 (float height ))90 (define-foreign-record (NSRange "NSRange")91 (unsigned-int location )92 (unsigned-int length ))89 (define-foreign-record-type (NSPoint "NSPoint") 90 (float x NSPoint-x NSPoint-x-set!) 91 (float y NSPoint-y NSPoint-y-set!)) 92 (define-foreign-record-type (NSSize "NSSize") 93 (float width NSSize-width NSSize-width-set!) 94 (float height NSSize-height NSSize-height-set!)) 95 (define-foreign-record-type (NSRange "NSRange") 96 (unsigned-int location NSRange-location NSRange-location-set!) 97 (unsigned-int length NSRange-length NSRange-length-set!)) 93 98 94 99 ;;;;; Scheme record counterparts to C structs 95 100 96 (define-record ns:rect x y width height) 97 (define-record ns:point x y) 98 (define-record ns:size width height) 99 (define-record ns:range location length) 101 (define-record-type ns:rect 102 (make-ns:rect x y width height) 103 ns:rect? 104 (x ns:rect-x ns:rect-x-set!) 105 (y ns:rect-y ns:rect-y-set!) 106 (width ns:rect-width ns:rect-width-set!) 107 (height ns:rect-height ns:rect-height-set!)) 108 109 (define-record-type ns:point 110 (make-ns:point x y) 111 ns:point? 112 (x ns:point-x ns:point-x-set!) 113 (y ns:point-y ns:point-y-set!)) 114 115 (define-record-type ns:size 116 (make-ns:size width height) 117 ns:size? 118 (width ns:size-width ns:size-width-set!) 119 (height ns:size-height ns:size-height-set!)) 120 121 (define-record-type ns:range 122 (make-ns:range location length) 123 ns:range? 124 (location ns:range-location ns:range-location-set!) 125 (length ns:range-length ns:range-length-set!)) 126 100 127 (define-record-printer (ns:rect r port) 101 128 (fprintf port "#<ns:rect origin: (~a ~a) size: (~a ~a)>" … … 178 205 ;; so use make-locative when you need to put the result in a byte-vector. 179 206 180 (define-macro (define-arg-conversion name from to) 181 `(define ,name (foreign-lambda* c-pointer ((,from val) ((pointer ,to) buf)) 182 "*buf = val; return(buf);"))) 207 (define-syntax define-arg-conversion 208 (er-macro-transformer 209 (lambda (expr rename compare) 210 (let ((name (cadr expr)) 211 (from (caddr expr)) 212 (to (cadddr expr))) 213 `(define ,name 214 (foreign-lambda* c-pointer ((,from val) ((pointer ,to) buf)) 215 "*buf = val; return(buf);")))))) 183 216 184 217 (define-arg-conversion int->ref integer "int") -
release/4/objc/trunk/objc-base.scm
r9966 r14899 1 1 ;;; objc Scheme<->ObjC bridge 2 2 3 ;(use objc-support) ;; instead, use require-at-runtime in objc.setup4 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") 5 288 6 289 ;;; invoker macros … … 12 295 ;; the superclass of self.) 13 296 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)) 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 ...)))) 22 309 23 310 … … 28 315 ;; `(objc:send/safe ,@args)) 29 316 30 (define (%objc safe? target arg args) 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 "" '())))) 31 352 (let ((super? (eq? target 'super))) 32 353 (if (null? args) 33 354 (if super? 34 355 `(objc:invoker ',safe? self (string-append _supersel 35 ,(objcify-selector (symbol->string arg))))356 ,(objcify-selector (symbol->string arg)))) 36 357 `(objc:invoker ',safe? ,target ,(objcify-selector (symbol->string arg)))) 37 358 (receive (method passargs) … … 42 363 `(objc:invoker ',safe? ,target ,(objcify-selector method) ,@passargs)))))) 43 364 44 ;; For parameter names, we accept actual keywords instead of symbols ending in :.45 ;; Thus, depending on the current keyword-style, initWithValue:, #:initWithValue, or46 ;; :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 args50 (letrec ((keyword (lambda (ls method-name params)51 (if (null? ls)52 (values method-name (reverse params))53 (param (cdr ls)54 (string-append55 method-name56 (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-name68 (cons (car ls) params))))))69 (keyword args "" '())))))70 71 ;; Convert a scheme-type selector string to Objective C syntax. This simply entails72 ;; 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 365 ;;; Instance variables 82 366 … … 86 370 ;; Note: these are macros, and cannot comply with SRFI-17. However, (ivar-set! ...) is 87 371 ;; 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)) 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))))) 92 383 93 384 ;;; Class definitions … … 122 413 123 414 ;; 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))) 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)))))) 153 450 154 451 ;;;; define-method … … 160 457 ;; (objc:add-method MyClass "sel1:sel2:" (list objc:DBL objc:ID objc:SEL objc:INT objc:DBL) 161 458 ;; (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)) 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))))) 166 467 167 468 (define (macro:type->encoding x) ;; internal … … 173 474 ;; objc:add-method creates the super selector at runtime from the actual registered class name. 174 475 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 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 203 509 ;; Note: type is normally a keyword; objc: will be prepended (e.g. objc:ID). If 204 510 ;; not a keyword, it is pasted verbatim so you can e.g. pass an encoded typestring. … … 206 512 ;;; Importing classes 207 513 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) ) ) 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)))))) 217 529 218 530 ;;; Read syntax … … 244 556 (else (error "invalid read syntax for `@'" c)) ) ) ) ) ) ) ) 245 557 558 ) -
release/4/objc/trunk/objc-class-proxies-bin.scm
r9966 r14899 2 2 3 3 ;; compile: csc -X objc -objc -framework Foundation -s objc-tinyclos-bin.scm scheme-object.m 4 (declare (emit-external-prototypes-first))4 ;;(declare (emit-external-prototypes-first)) 5 5 6 6 #> -
release/4/objc/trunk/objc-class-proxies.scm
r9966 r14899 1 (use srfi-69 objc-class-proxies-bin)2 1 3 2 ;;; Common code for class proxies … … 20 19 ;; is only set for classes with a scheme implementation. 21 20 ;; OBJC? is #t if this class is pure Objective C, and #f if implemented in Scheme. 22 (define-record objc:class ptr ivars objc?) 23 (define-record objc:ivar name type offset function) ;; function: #:slot, #:outlet, #:wrapper, #:ivar; 24 ;; used for ID only 21 22 (define-record-type objc:class 23 (make-objc:class ptr ivars objc?) 24 objc:class? 25 (ptr objc:class-ptr objc:class-ptr-set!) 26 (ivars objc:class-ivars objc:class-ivars-set!) 27 (objc? objc:class-objc? objc:class-objc?-set!)) 28 29 (define-record-type objc:ivar 30 (make-objc:ivar name type offset function) 31 objc:ivar? 32 (name objc:ivar-name objc:ivar-name-set!) 33 (type objc:ivar-type objc:ivar-type-set!) 34 (offset objc:ivar-offset objc:ivar-offset-set!) 35 (function objc:ivar-function objc:ivar-function-set!)) 36 25 37 (define-record-printer (objc:ivar x port) 26 38 (fprintf port "#<objc:ivar ~a ~a ~a>" -
release/4/objc/trunk/objc-support.scm
r9966 r14899 1 1 ;;; objc-support 2 3 (use lolevel)4 2 5 3 (include "array.scm") … … 101 99 ;;; #<objc:class> records 102 100 103 (define-record objc:class ptr) 101 (define-record-type objc:class 102 (make-objc:class ptr) 103 objc:class? 104 (ptr objc:class-ptr objc:class-ptr-set!)) 105 104 106 (define (objc:class-ivars x) '()) ;; Dummy implementations; defined in the class proxies. 105 107 (define (objc:class-objc? x) #f) … … 157 159 ;;; #<objc:instance> records 158 160 159 (define-record objc:instance ptr) 161 (define-record-type objc:instance 162 (make-objc:instance ptr) 163 objc:instance? 164 (ptr objc:instance-ptr objc:instance-ptr-set!)) 160 165 161 166 (define-foreign-type objc-instance … … 213 218 ;;; instance variables 214 219 215 (define-foreign-record (Ivar-list "struct objc_ivar_list")216 (int ivar_count )217 ((const c-pointer) ivar_list ))218 219 (define-foreign-record (Ivar "struct objc_ivar")220 (c-string ivar_name )221 (c-string ivar_type )222 (int ivar_offset ))220 (define-foreign-record-type (Ivar-list "struct objc_ivar_list") 221 (int ivar_count Ivar-list-ivar_count Ivar-list-ivar_count-set!) 222 ((const c-pointer) ivar_list Ivar-list-ivar_list Ivar-list-ivar_list-set!)) 223 224 (define-foreign-record-type (Ivar "struct objc_ivar") 225 (c-string ivar_name Ivar-ivar_name Ivar-ivar_name-set!) 226 (c-string ivar_type Ivar-ivar_type Ivar-ivar_type-set!) 227 (int ivar_offset Ivar-ivar_offset Ivar-ivar_offset-set!)) 223 228 224 229 ;; object_getInstanceVariable returns the variable value, not a pointer to the value … … 279 284 280 285 ;; Disabled, because when using class proxies this will instantiate every one. 281 ;(define objc:classes (objc:get-class-list)) ;; or objc-classes, hyphen?286 (define objc:classes (objc:get-class-list)) ;; or objc-classes, hyphen? 282 287 283 288 ;; Define all Objective C classes as symbols at toplevel. We don't -
release/4/objc/trunk/objc.meta
r9966 r14899 5 5 (category ffi) 6 6 (license "MIT") 7 (needs easyffi )7 (needs easyffi foreigners) 8 8 (author "Zbigniew") 9 9 (files "objc.setup" "objc.scm" "objc.html" "objc-support.scm" -
release/4/objc/trunk/objc.scm
r9966 r14899 1 1 ;;; Chicken ObjC bridge -- basic proxies 2 2 3 (require-library srfi-69 foreigners) 4 5 (module objc 6 7 (*class-proxies* 8 dealloc-scheme 9 lookup-class-proxy 10 make-class-proxy 11 make-objc:class 12 make-objc:ivar 13 objc:add-convenience-method! 14 objc:class-all-ivars 15 objc:class-ivar-lookup 16 objc:class-ivars 17 objc:class-ivars-set! 18 objc:class-objc? 19 objc:class-objc?-set! 20 objc:class-ptr 21 objc:class-ptr-set! 22 objc:class? 23 objc:ivar->raw 24 objc:ivar-function 25 objc:ivar-function-set! 26 objc:ivar-name 27 objc:ivar-name-set! 28 objc:ivar-offset 29 objc:ivar-offset-set! 30 objc:ivar-ref 31 objc:ivar-set! 32 objc:ivar-type 33 objc:ivar-type-set! 34 objc:ivar? 35 objc:pointer->class 36 objc:scheme-object->ref/cnt 37 register-class-proxy 38 dealloc_scheme 39 gc-root-delete! 40 gc-root-ref 41 gc-root-set! 42 objc:unwrap 43 objc:wrap 44 objc_method_dealloc 45 scheme-object-wrapper-delete! 46 scheme-object-wrapper-ref 47 scheme-object-wrapper-set!) 48 49 (import scheme chicken srfi-69 foreigners) 3 50 (require-extension objc-base) 51 (include "objc-class-proxies.scm") 52 (include "objc-class-proxies-bin.scm") 4 53 5 54 ;;; Class definition macro … … 30 79 31 80 ;; The superclass will be looked up for you; it does not need to be imported. 32 (define-macro (define-objc-class class super ivars . methods) 33 (let ((instance-variables (gensym))) 34 `(begin 35 ;; register class 36 (if (string-to-class ,(symbol->string class)) 37 ((if (objc:allow-class-redefinition) 38 warning error) 39 ,(string-append "(define-objc-class): class already registered: " 40 (symbol->string class))) 41 (objc:register-class ,(symbol->string class) 42 (objc:string->class ,(symbol->string super)))) 43 ;; import class 44 (define-objc-classes ,class) 45 (objc:class-objc?-set! ,class #f) ;; This class is not pure ObjC. 81 (define-syntax define-objc-class 82 (er-macro-transformer 83 (lambda (e r c) 84 (let ((class (cadr e)) 85 (super (caddr e)) 86 (ivars (cadddr e)) 87 (methods (cddddr e)) 88 (instance-variables (gensym))) 89 `(begin 90 ;; register class 91 (if (string-to-class ,(symbol->string class)) 92 ((if (objc:allow-class-redefinition) 93 warning error) 94 ,(string-append "(define-objc-class): class already registered: " 95 (symbol->string class))) 96 (objc:register-class ,(symbol->string class) 97 (objc:string->class ,(symbol->string super)))) 98 ;; import class 99 (define-objc-classes ,class) 100 (objc:class-objc?-set! ,class #f) ;; This class is not pure ObjC. 46 101 47 ;; set instance variables48 (let ((,instance-variables49 (list ,@(map (lambda (ivar)50 (let ((qualified-ID? (memq (car ivar)51 '(slot: wrapper: outlet:))))52 (let ((name (cadr ivar))53 (type (if qualified-ID? 'ID (car ivar)))54 (function (if qualified-ID? (car ivar) ivar:)))55 `(make-objc:ivar ,(symbol->string name)56 ,(macro:type->encoding type)57 058 ,function))))59 ivars))))60 ;; Set instance vars on the Objective C side...61 (objc:set-ivars! ,class (map objc:ivar->raw ,instance-variables))62 ;; ... and in the Scheme class proxy.63 (objc:class-ivars-set! ,class64 (map (lambda (x)65 (cons (objc:ivar-name x) x))66 ,instance-variables))102 ;; set instance variables 103 (let ((,instance-variables 104 (list ,@(map (lambda (ivar) 105 (let ((qualified-ID? (memq (car ivar) 106 '(slot: wrapper: outlet:)))) 107 (let ((name (cadr ivar)) 108 (type (if qualified-ID? 'ID (car ivar))) 109 (function (if qualified-ID? (car ivar) ivar:))) 110 `(make-objc:ivar ,(symbol->string name) 111 ,(macro:type->encoding type) 112 0 113 ,function)))) 114 ivars)))) 115 ;; Set instance vars on the Objective C side... 116 (objc:set-ivars! ,class (map objc:ivar->raw ,instance-variables)) 117 ;; ... and in the Scheme class proxy. 118 (objc:class-ivars-set! ,class 119 (map (lambda (x) 120 (cons (objc:ivar-name x) x)) 121 ,instance-variables)) 67 122 68 ;; add user methods69 ,@(map (lambda (method)70 (let ((definer (case (car method)71 ((define-method -) 'objc:define-method)72 ((define-class-method +) 'objc:define-class-method)73 (else (error "invalid method definition keyword" (car method))))))74 `(,definer ,class ,@(cdr method))))75 methods)123 ;; add user methods 124 ,@(map (lambda (method) 125 (let ((definer (case (car method) 126 ((define-method -) 'objc:define-method) 127 ((define-class-method +) 'objc:define-class-method) 128 (else (error "invalid method definition keyword" (car method)))))) 129 `(,definer ,class ,@(cdr method)))) 130 methods) 76 131 77 ;; Add convenience methods. The dealloc-scheme comments explain why it gets78 ;; added to every class, not just the first Scheme generation.79 (objc:add-convenience-method! ,class80 "dealloc"81 "v@:"82 objc_method_dealloc)))))132 ;; Add convenience methods. The dealloc-scheme comments explain why it gets 133 ;; added to every class, not just the first Scheme generation. 134 (objc:add-convenience-method! ,class 135 "dealloc" 136 "v@:" 137 objc_method_dealloc))))))) 83 138 139 ) -
release/4/objc/trunk/objc.setup
r9967 r14899 1 1 ;;; objc setup file 2 2 3 (define exports? (string>=? (chicken-version) "2.310"))3 (define version "0.5.0") 4 4 5 (define easyffi? (string>=? (chicken-version) "2.424"))5 (define easyffi? #t) 6 6 7 7 (define dbg 8 8 (if (member "-debug" (command-line-arguments)) 9 9 "-kv -D debug" 10 "") 10 "")) 11 11 12 12 ;; Uhh, I guess make body already in quasiquote 13 13 14 (make ( 15 ("objc-support.so" ("objc-support.scm" "classes.scm" "alignment.scm" 16 "array.scm" "convert.scm" #;"objc.scm") 17 (compile objc-support.scm -s -objc -O2 -d1 18 ,@(if easyffi? '(-extend easyffi) '()) 19 ,@(if exports? '(-check-imports -emit-exports objc-support.exports) '()) 20 -lffi -framework Foundation ,dbg)) 21 ("objc-class-proxies-bin.so" ("objc-class-proxies-bin.scm" "scheme-object.m" "scheme-object.h") 22 (compile -objc -framework Foundation -s -O2 -d1 23 ,@(if easyffi? '(-extend easyffi) '()) 24 ,@(if exports? '(-check-imports -emit-exports objc-class-proxies-bin.exports) '()) 25 objc-class-proxies-bin.scm scheme-object.m)) 26 ("objc-class-proxies.so" ("objc-class-proxies.scm") 27 (compile -s -O2 -d1 28 ,@(if exports? '(-check-imports -emit-exports objc-class-proxies.exports) '()) 29 objc-class-proxies.scm)) 30 ("cocoa.so" ("cocoa.scm") 31 (compile -s cocoa.scm -objc -O2 -d1 32 ,@(if easyffi? '(-extend easyffi) '()) 33 ,@(if exports? '(-check-imports -emit-exports cocoa.exports) '()) 34 -framework Cocoa -X ./objc.scm ,dbg)) ) 35 '#("objc-support.so" "objc-class-proxies-bin.so" "objc-class-proxies.so" "cocoa.so") ) 14 (make (("objc.so" 15 ("objc.scm" "scheme-object.m" "scheme-object.h" "objc-base.so") 16 (compile -objc -framework Foundation -s -O2 -d1 17 ,@(if easyffi? '(-extend easyffi) '()) 18 objc.scm scheme-object.m)) 19 ("objc-base.so" 20 ("objc-support.scm" "classes.scm" "alignment.scm" 21 "array.scm" "convert.scm" "objc-base.scm" "objc-runtime.h") 22 (compile objc-base.scm -s -objc -O2 -d1 -j objc-base 23 ,@(if easyffi? '(-extend easyffi) '()) 24 -lffi -framework Foundation ,dbg) 25 (compile objc-base.import.scm -s -O2 -d0)) 26 ("objc-cocoa.so" ("objc-cocoa.scm" "objc-base.so") 27 (compile -s objc-cocoa.scm -objc -O2 -d1 -j objc-cocoa 28 ,@(if easyffi? '(-extend easyffi) '()) 29 -framework Cocoa -X ./objc.scm ,dbg) 30 (compile -s objc-cocoa.import.scm -O2 -d0))) 31 '#("objc.so" "objc-base.so" "objc-cocoa.so")) 36 32 37 (install-extension 'objc-base 38 `( "objc-base.scm" "objc-support.so" "cocoa.so" 39 ,@(if exports? '("objc-support.exports" "cocoa.exports") '()) ) 40 `( (syntax) 41 (require-at-runtime objc-support) 42 ,@(if exports? `((exports "objc-support.exports" "cocoa.exports")) '()) 43 (version "0.4.5") ) ) 33 (install-extension 34 'objc-cocoa 35 `("objc-cocoa.so" "objc-cocoa.import.so") 36 `((version ,version))) 37 38 (install-extension 39 'objc-base 40 `("objc-base.so" "objc-base.import.so") 41 `((version ,version))) 44 42 45 43 (install-extension 'objc 46 `( "objc.scm" "objc-class-proxies.so" "objc-class-proxies-bin.so" 47 "objc.html" 48 ,@(if exports? '("objc-class-proxies.exports" "objc-class-proxies-bin.exports") '()) ) 49 `( (syntax) 50 (require-at-runtime objc-support objc-class-proxies) 51 (version "0.4.5") 52 ,@(if exports? `((exports "objc-class-proxies.exports" "objc-class-proxies-bin.exports")) '()) 53 (documentation "objc.html") ) ) 44 `("objc.so" "objc.import.so" "objc.html") 45 `((version ,version) 46 (documentation "objc.html"))) 54 47
Note: See TracChangeset
for help on using the changeset viewer.