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

(use srfi-69 objc-class-proxies-bin)

;;; Common code for class proxies

(define *class-proxies* (make-hash-table))
(define (lookup-class-proxy ptr)
  (hash-table-ref/default *class-proxies* ptr #f))
(define (register-class-proxy ptr proxy)
  (hash-table-set! *class-proxies* ptr proxy)
  proxy)
(define (objc:pointer->class ptr)
  (and ptr
       (or (lookup-class-proxy ptr)
           (register-class-proxy ptr (make-class-proxy ptr)))))


;;; For basic implementation

;; IVARS is a list of the instance variables in this class (not in any superclasses), and
;; is only set for classes with a scheme implementation.
;; OBJC? is #t if this class is pure Objective C, and #f if implemented in Scheme.
(define-record objc:class ptr ivars objc?)
(define-record objc:ivar name type offset function) ;; function: #:slot, #:outlet, #:wrapper, #:ivar;
                                                    ;; used for ID only
(define-record-printer (objc:ivar x port)
  (fprintf port "#<objc:ivar ~a ~a ~a>"
           (objc:ivar-name x)
           (objc:ivar-type x)
           (objc:ivar-function x)))
(define (objc:ivar->raw x)
  (make-objc:raw-ivar (objc:ivar-name x)
                      (objc:ivar-type x)
                      (objc:ivar-offset x)))

(define (make-class-proxy ptr)
  (let* ((proxy (make-objc:class ptr '() #t))
         (super (objc:class-super-class proxy)))  ;; Implicitly instantiate superclass proxy.
    (if super
        (objc:class-objc?-set! proxy
          (objc:class-objc? super)))          ;; Scheme class in hierarchy taints this one.
    proxy))

;; If TYPES is a string, it's treated as n one-character encoded types.  Otherwise, pass a
;; list of encoded type strings.
(define (objc:add-convenience-method! klass method-name types c-func)
  (let ((typelist (if (string? types)
                      (string-chop types 1)
                      types)))
    (add-method-definition (objc:class->pointer klass)
                           (string->selector method-name)
                           (apply conc typelist)
                           (make-imp-closure typelist c-func
                                             (objc:class->pointer klass)))))

;; Find ivar NAME, traversing the class hierarchy upward from class C.
(define (objc:class-ivar-lookup c name)
  (cond ((not c) #f)
        ((assoc name (objc:class-ivars c)) => cdr)
        (else
         (objc:class-ivar-lookup (objc:class-super-class c) name))))

;; Return all ivars known by the class proxies in the class hierarchy,
;; which will typically be ivars declared in Scheme.
(define objc:class-all-ivars
  (letrec ((all-ivars (lambda (c)
                        (if (not c)
                            '()
                            (cons (objc:class-ivars c)
                                  (all-ivars (objc:class-super-class c)))))))
    (lambda (c)
      (flatten (all-ivars c)))))

(define (objc:ivar-ref obj name)
  (let* ((ptr  (objc:instance-ptr obj))
         (ivar (find-ivar ptr name)))
    (if ivar
        (let ((scheme-ivar (objc:class-ivar-lookup (objc:class-of obj) name))
              (ivar-ptr (pointer-offset ptr (Ivar-ivar_offset ivar))))
          
          (if scheme-ivar
              (case (objc:ivar-function scheme-ivar)
                ((slot:)   (gc-root-ref ivar-ptr))
                ((wrapper:) (scheme-object-wrapper-ref ivar-ptr))
                (else (objc:ref->scheme-object ivar-ptr (Ivar-ivar_type ivar))))
              (objc:ref->scheme-object ivar-ptr (Ivar-ivar_type ivar)))) ;; default (no scheme ivar)
        (error 'ivar-ref "no such instance variable" name))))

;; Same as scheme-object->ref, but maintain reference counts: if type is ID,
;; release any old value and retain the new value.  Used in ivar-set!.
(define (objc:scheme-object->ref/cnt val type ptr)
  (if (equal? type objc:ID)
      (let ((old (pointer-ptr-ref ptr 0)))
        (objc:scheme-object->ref val type ptr)   ;; write id into ptr
        (let ((new (pointer-ptr-ref ptr 0)))
          (objc-retain new)
          (if old (objc-release old))))
        
      (objc:scheme-object->ref val type ptr)))

(define (objc:ivar-set! obj name val)
  (let* ((ptr (objc:instance-ptr obj))
         (ivar (find-ivar ptr name)))
    (if ivar
        (let ((scheme-ivar (objc:class-ivar-lookup (objc:class-of obj) name))
              (ivar-ptr (pointer-offset ptr (Ivar-ivar_offset ivar)))
              (type (Ivar-ivar_type ivar)))
          (if scheme-ivar
              (case (objc:ivar-function scheme-ivar)
                ((slot:)   (gc-root-set! ivar-ptr val))
                ((wrapper:) (scheme-object-wrapper-set! ivar-ptr val))
                ((outlet:) (objc:scheme-object->ref val objc:ID ivar-ptr))
                (else (objc:scheme-object->ref/cnt val type ivar-ptr)))
              (objc:scheme-object->ref val type ivar-ptr))
          (void))
        (error 'ivar-set! "no such instance variable" name))))

(define objc:ivar-ref (getter-with-setter objc:ivar-ref objc:ivar-set!))

;;; Deallocation

;; Note: dealloc-scheme is added to every class with scheme implementation, because
;; the class proxy contains only instance variables specific to that particular class.
;; So, each call up the chain will free instance variables declared in that class.
;; An alternative would be to create a function which conses together all instance
;; variables up the hierarchy, and run this function once, in a first generation
;; scheme subclass, against this list.  (objc:class-all-ivars would work for this.)
(define (dealloc-scheme self klass)
    (for-each (lambda (x)
                (let* ((x (cdr x))   ;; objc:class-ivars is an alist -- wrap this?
                       (ivar (find-ivar self (objc:ivar-name x))))
                  (if ivar
                      (let ((ivar-ptr (pointer-offset self (Ivar-ivar_offset ivar))))
                        (if (equal? objc:ID (objc:ivar-type x))
                            (case (objc:ivar-function x)
                              ((slot:)   (gc-root-delete! ivar-ptr))
                              ((wrapper:) (scheme-object-wrapper-delete! ivar-ptr))
                              ((outlet:) 'noop)
                              (else  ;; ivar: ?
                               (let ((id (pointer-ptr-ref ivar-ptr 0)))
                                 (if id (objc-release id)))))))
                      (warning (conc "dealloc_scheme: " klass
                                     " proxy has ivar " x " but ObjC class does not")))))
              (objc:class-ivars klass)))