Changeset 14899 in project


Ignore:
Timestamp:
06/06/09 09:56:38 (11 years ago)
Author:
Alex Shinn
Message:

initial conversion, not yet working

Location:
release/4/objc
Files:
2 deleted
9 edited
1 copied

Legend:

Unmodified
Added
Removed

  • release/4/objc/trunk/classes.scm

    r9966 r14899  
    104104<#
    105105
    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
    107113(define-record-printer (objc:raw-ivar x p)
    108114  (fprintf p "#<raw-ivar: ~a ~s at ~a>"
    … …  
    513519;;;; Method creation
    514520
    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))
    521528
    522529(define (make-method-proxy typelist proc)

  • release/4/objc/trunk/convert.scm

    r9966 r14899  
    11;;; type conversion
    2 
    3 (use srfi-69)
    42
    53;; Objective C type signature definitions.
    … …  
    2826;;; Convert Objective C references to Scheme objects.
    2927
    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);"))))))
    3237
    3338(define-result-conversion ref->float  float   "float")
    … …  
    8287  (foreign-lambda* float (((pointer "NSRect") rect) (float val)) "rect->size.height = val;"))
    8388
    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!))
    9398
    9499;;;;; Scheme record counterparts to C structs
    95100
    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
    100127(define-record-printer (ns:rect r port)
    101128  (fprintf port "#<ns:rect origin: (~a ~a) size: (~a ~a)>"
    … …  
    178205;; so use make-locative when you need to put the result in a byte-vector.
    179206
    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);"))))))
    183216
    184217(define-arg-conversion int->ref    integer "int")

  • release/4/objc/trunk/objc-base.scm

    r9966 r14899  
    11;;; objc Scheme<->ObjC bridge
    22
    3 ;(use objc-support) ;; instead, use require-at-runtime in objc.setup
    43;(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")
    5288
    6289;;; invoker macros
    … …  
    12295;; the superclass of self.)
    13296
    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 ...))))
    22309
    23310
    … …  
    28315;;   `(objc:send/safe ,@args))
    29316
    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 "" '()))))
    31352  (let ((super? (eq? target 'super)))
    32353    (if (null? args)
    33354        (if super?
    34355            `(objc:invoker ',safe? self (string-append _supersel
    35                                                       ,(objcify-selector (symbol->string arg))))
     356                                                       ,(objcify-selector (symbol->string arg))))
    36357            `(objc:invoker ',safe? ,target ,(objcify-selector (symbol->string arg))))
    37358        (receive (method passargs)
    … …  
    42363              `(objc:invoker ',safe? ,target ,(objcify-selector method) ,@passargs))))))
    43364
    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 
    81365;;; Instance variables
    82366
    … …  
    86370;; Note: these are macros, and cannot comply with SRFI-17.  However, (ivar-set! ...) is
    87371;; 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)))))
    92383
    93384;;; Class definitions
    … …  
    122413
    123414;; 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))))))
    153450 
    154451;;;; define-method
    … …  
    160457;; (objc:add-method MyClass "sel1:sel2:" (list objc:DBL objc:ID objc:SEL objc:INT objc:DBL)
    161458;;                                       (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)))))
    166467
    167468(define (macro:type->encoding x)   ;; internal
    … …  
    173474;; objc:add-method creates the super selector at runtime from the actual registered class name.
    174475
    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
    203509;; Note: type is normally a keyword; objc: will be prepended (e.g. objc:ID).  If
    204510;; not a keyword, it is pasted verbatim so you can e.g. pass an encoded typestring.
    … …  
    206512;;; Importing classes
    207513
    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))))))
    217529
    218530;;; Read syntax
    … …  
    244556                   (else (error "invalid read syntax for `@'" c)) ) ) ) ) ) ) )
    245557
     558)

  • release/4/objc/trunk/objc-class-proxies-bin.scm

    r9966 r14899  
    22
    33;; 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))
    55
    66#>

  • release/4/objc/trunk/objc-class-proxies.scm

    r9966 r14899  
    1 (use srfi-69 objc-class-proxies-bin)
    21
    32;;; Common code for class proxies
    … …  
    2019;; is only set for classes with a scheme implementation.
    2120;; 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
    2537(define-record-printer (objc:ivar x port)
    2638  (fprintf port "#<objc:ivar ~a ~a ~a>"

  • release/4/objc/trunk/objc-support.scm

    r9966 r14899  
    11;;; objc-support
    2 
    3 (use lolevel)
    42
    53(include "array.scm")
    … …  
    10199;;; #<objc:class> records
    102100
    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
    104106(define (objc:class-ivars x) '())  ;; Dummy implementations; defined in the class proxies.
    105107(define (objc:class-objc? x) #f)
    … …  
    157159;;; #<objc:instance> records
    158160
    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!))
    160165
    161166(define-foreign-type objc-instance
    … …  
    213218;;; instance variables
    214219
    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!))
    223228
    224229;; object_getInstanceVariable returns the variable value, not a pointer to the value
    … …  
    279284
    280285;; 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?
    282287
    283288;; Define all Objective C classes as symbols at toplevel.  We don't

  • release/4/objc/trunk/objc.meta

    r9966 r14899  
    55 (category ffi)
    66 (license "MIT")
    7  (needs easyffi)
     7 (needs easyffi foreigners)
    88 (author "Zbigniew")
    99 (files "objc.setup" "objc.scm" "objc.html" "objc-support.scm"

  • release/4/objc/trunk/objc.scm

    r9966 r14899  
    11;;; Chicken ObjC bridge -- basic proxies
    22
     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)
    350(require-extension objc-base)
     51(include "objc-class-proxies.scm")
     52(include "objc-class-proxies-bin.scm")
    453
    554;;; Class definition macro
    … …  
    3079
    3180;; 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.
    46101
    47      ;; set instance variables
    48      (let ((,instance-variables
    49             (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                                                 0
    58                                                 ,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! ,class
    64              (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))
    67122
    68      ;; add user methods
    69      ,@(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)
    76131
    77      ;; Add convenience methods.  The dealloc-scheme comments explain why it gets
    78      ;; added to every class, not just the first Scheme generation.
    79      (objc:add-convenience-method! ,class
    80                                    "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)))))))
    83138
     139)

  • release/4/objc/trunk/objc.setup

    r9967 r14899  
    11;;; objc setup file
    22
    3 (define exports? (string>=? (chicken-version) "2.310"))
     3(define version "0.5.0")
    44
    5 (define easyffi? (string>=? (chicken-version) "2.424"))
     5(define easyffi? #t)
    66
    77(define dbg
    88  (if (member "-debug" (command-line-arguments))
    99      "-kv -D debug"
    10       "") )
     10      ""))
    1111
    1212;; Uhh, I guess make body already in quasiquote
    1313
    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"))
    3632
    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)))
    4442
    4543(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")))
    5447
Note: See TracChangeset for help on using the changeset viewer.