;;; Foreign helpers

;; compile: csc -X objc -objc -framework Foundation -s objc-tinyclos-bin.scm scheme-object.m
;;(declare (emit-external-prototypes-first))

#>
#import "objc-runtime.h"
#import <objc/objc-class.h>
#import <objc/objc-runtime.h>
#import "scheme-object.h"
<#

;;; GC root operations
;; These operate on a pointer which contains the root pointer, such as an instance variable.

(define gc-root-ref
  (foreign-lambda* scheme-object ((c-pointer ptr))
                   "return(CHICKEN_gc_root_ref(*(void **)ptr));"))

(define gc-root-set!
  (foreign-lambda* void ((c-pointer ptr) (scheme-object obj)) #<<EOF
     void *root = *(void **)ptr;
     if (root == NULL)
       root = CHICKEN_new_gc_root();
       
     CHICKEN_gc_root_set(root, obj);
     *(void **)ptr = root;
EOF
))

(define gc-root-delete!
  (foreign-lambda* void (((pointer "void *") ptr))
                   "if (*ptr) CHICKEN_delete_gc_root(*ptr);"))

;;; Scheme object wrapper

;;;; For instance variables:
(define scheme-object-wrapper-ref
  (foreign-lambda* scheme-object (((pointer "Scheme_Object_Wrapper *") ivar_ptr))
                   "return( [(*ivar_ptr) __scheme_object__] );"))

(define scheme-object-wrapper-set!
  (foreign-lambda* void (((pointer "Scheme_Object_Wrapper *") ivar_ptr) (scheme-object obj)) #<<EOF
    if (*ivar_ptr == NULL) {
      *ivar_ptr = [Scheme_Object_Wrapper alloc];
    }
    [(*ivar_ptr) initWithObject: obj];
EOF
))

(define scheme-object-wrapper-delete!
  (foreign-lambda* void (((pointer "Scheme_Object_Wrapper *") ivar_ptr))
                         "if (*ivar_ptr) [*ivar_ptr release];"))

;;;; For argument conversion:

;; Wrap a scheme object in a Scheme_Object_Wrapper instance so it may be passed
;; as an ID.  This is not an NSProxy -- messages are not forwarded to the payload.
;; It's mainly useful for scheme->scheme communication when return or arg type is ID.
(define (objc:wrap obj)
  (define obj->id (foreign-lambda* c-pointer ((scheme-object o))
                                   "return([[Scheme_Object_Wrapper alloc] initWithObject: o]);"))
  (let* ((id      (obj->id obj))
         (wrapper (objc:pointer->instance id)))
      (objc-release id)  ;; remove extra reference count, allowing finalizer to dealloc it
      wrapper))

(define (objc:unwrap instance)
  (define wrapper->obj (foreign-lambda* scheme-object (((pointer "Scheme_Object_Wrapper") wrapper))
                                        "return([wrapper __scheme_object__]);"))
  (define wrapper? (foreign-lambda* bool (((pointer "NSObject") o))
                                    "return([o isKindOfClass: [Scheme_Object_Wrapper class]]);"))
  (let ((ptr (objc:instance->pointer instance)))
    (if (wrapper? ptr)
        (wrapper->obj ptr)
        (error 'objc:unwrap "expected Scheme_Object_Wrapper, got" instance))))
  

;;; Deallocation

;; Unfortunately, dealloc has to be an FFI closure, not a simple function.  We need
;; to pass the superclass in, as it depends on the method definition point, not self.
#>
#include <ffi.h>

static void objc_method_dealloc(ffi_cif* cif __attribute__((__unused__)), void* resp,
                                 void** args, void *userdata) {
  struct objc_super super;
  id self = *(id *)args[0];
  SEL _cmd = *(SEL *)args[1];
  dealloc_scheme(self, userdata);

  super.class = ((Class)userdata)->super_class;
  RECEIVER(super) = self;
  objc_msgSendSuper(&super, (SEL)_cmd);
}

<#

(define objc_method_dealloc (foreign-value "objc_method_dealloc" c-pointer))

;; Temporarily using make-objc:instance so we do not retain this instance, as it
;; must be released (finalized) before calling the superclass impl, and we don't want
;; to force a garbage collection. make-objc:instance may be illegal in the future.
(define-external (dealloc_scheme (c-pointer self) (c-pointer klass-ptr)) void
  (dealloc-scheme self (objc:pointer->class klass-ptr)))