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

;;; type conversion

(use srfi-69)

;; Objective C type signature definitions.
(define objc:ID  "@")  ;; Should probably use @encode for these.
(define objc:SEL ":")
(define objc:INT "i")
(define objc:DBL "d")
(define objc:FLT "f")
(define objc:CHR "c")
(define objc:PTR "^")
(define objc:SHT "s")
(define objc:LNG "l")
(define objc:USHT "S")
(define objc:UINT "I")
(define objc:UCHR "C")
(define objc:BOOL "c")
(define objc:ULNG "L")
(define objc:VOID "v")
(define objc:CLASS "#")
(define objc:CHARPTR "*")  ;; hmm
(define objc:NSRECT  (foreign-value "@encode(NSRect)"  c-string))
(define objc:NSPOINT (foreign-value "@encode(NSPoint)" c-string))
(define objc:NSSIZE  (foreign-value "@encode(NSSize)"  c-string))
(define objc:NSRANGE (foreign-value "@encode(NSRange)" c-string))

;;; Convert Objective C references to Scheme objects.

(define-macro (define-result-conversion name to from)
  `(define ,name (foreign-lambda* ,to (((pointer ,from) obj)) "return(*obj);")))

(define-result-conversion ref->float  float   "float")
(define-result-conversion ref->double double  "double")
(define-result-conversion ref->int    integer "int")
(define-result-conversion ref->short  short   "short")
(define-result-conversion ref->long   long    "long")
(define-result-conversion ref->char   char    "char")
(define-result-conversion ref->uint   unsigned-integer "unsigned int")
(define-result-conversion ref->ushort unsigned-short   "unsigned short")
(define-result-conversion ref->ulong  unsigned-long    "unsigned long")
(define-result-conversion ref->uchar  unsigned-char    "unsigned char")
(define-result-conversion ref->ptr    c-pointer "void *")
(define-result-conversion ref->string c-string  "void *")

(define ref->void noop)

(define (objc:ref->class ref)
  (objc:pointer->class (ref->ptr ref)))

(define (objc:ref->instance ref)
  (objc:pointer->instance (ref->ptr ref)))     ;; retains object

(define (objc:ref->char-or-bool ref)
  (objc:char->char-or-bool (ref->char ref)))

(define (objc:char->char-or-bool c)
  (if (eqv? c #\nul) #f c))

;; This is not correct, we should convert to a selector object
;; which can be stringified if desired.
(define objc:ref->selector ref->string)
(define (objc:selector->ref sel buf)
  (ptr->ref (string->selector sel) buf))

;;;; Reference to structures: NSRect, NSPoint, NSSize

;;;;; Manipulation of C structures
;; It would be cheaper to have a C function fill the record in one shot.  These are
;; only used "during the making of".
(define NSRect-x (foreign-lambda* float (((pointer "NSRect") rect)) "return(rect->origin.x);"))
(define NSRect-y (foreign-lambda* float (((pointer "NSRect") rect)) "return(rect->origin.y);"))
(define NSRect-width  (foreign-lambda* float (((pointer "NSRect") rect)) "return(rect->size.width);"))
(define NSRect-height (foreign-lambda* float (((pointer "NSRect") rect)) "return(rect->size.height);"))
(define NSRect-x-set! (foreign-lambda* void (((pointer "NSRect") rect) (float val))
                                       "rect->origin.x = val;"))
(define NSRect-y-set! (foreign-lambda* float (((pointer "NSRect") rect) (float val))
                                       "rect->origin.y = val;"))
(define NSRect-width-set!
  (foreign-lambda* float (((pointer "NSRect") rect) (float val)) "rect->size.width = val;"))
(define NSRect-height-set!
  (foreign-lambda* float (((pointer "NSRect") rect) (float val)) "rect->size.height = val;"))

(define-foreign-record (NSPoint "NSPoint")
  (float x)
  (float y))
(define-foreign-record (NSSize "NSSize")
  (float width)
  (float height))
(define-foreign-record (NSRange "NSRange")
  (unsigned-int location)
  (unsigned-int length))

;;;;; Scheme record counterparts to C structs

(define-record ns:rect x y width height)
(define-record ns:point x y)
(define-record ns:size width height)
(define-record ns:range location length)
(define-record-printer (ns:rect r port)
  (fprintf port "#<ns:rect origin: (~a ~a) size: (~a ~a)>"
           (ns:rect-x r) (ns:rect-y r)
           (ns:rect-width r) (ns:rect-height r)))
(define-record-printer (ns:point p port)
  (fprintf port "#<ns:point x: ~a y: ~a>" (ns:point-x p) (ns:point-y p)))
(define-record-printer (ns:size s port)
  (fprintf port "#<ns:size w: ~a h: ~a>" (ns:size-width s)
                                         (ns:size-height s)))
(define-record-printer (ns:range r port)
  (fprintf port "#<ns:range location: ~a length: ~a>" (ns:range-location r) (ns:range-length r)))

;; Constructor aliases.
(define ns:make-rect  make-ns:rect)
(define ns:make-point make-ns:point)
(define ns:make-size  make-ns:size)
(define ns:make-range make-ns:range)


;;;;; Ref->structure converters
(define (ref->ns:rect ref)
  (ns:make-rect (NSRect-x ref)
               (NSRect-y ref)
               (NSRect-width ref)
               (NSRect-height ref)))
(define (ref->ns:point ref)
  (ns:make-point (NSPoint-x ref)
                (NSPoint-y ref)))
(define (ref->ns:size ref)
  (ns:make-size (NSSize-width ref)
               (NSSize-height ref)))
(define (ref->ns:range ref)
  (ns:make-range (NSRange-location ref)
                (NSRange-length ref)))

;; Return the proper ref->structure conversion function based on type signature.
(define ref->struct
  (let ((struct-table (alist->hash-table `((,objc:NSRECT  . ,ref->ns:rect)
                                           (,objc:NSPOINT . ,ref->ns:point)
                                           (,objc:NSRANGE . ,ref->ns:range)
                                           (,objc:NSSIZE  . ,ref->ns:size))
                                         string=?)))
    (lambda (type-signature)
      (hash-table-ref struct-table type-signature
                      (lambda ()
                        (error 'result-converter
                               "can not convert structure type" type-signature))))))

;;;; Master result converter
(define (result-converter method-signature)
  (let loop ((i 0))
    (case (string-ref method-signature i)
      ((#\v) ref->void)
      ((#\s) ref->short)
      ((#\i) ref->int)
      ((#\l) ref->long)
      ((#\C) ref->uchar)
      ((#\I) ref->uint)
      ((#\S) ref->ushort)
      ((#\L) ref->ulong)
      ((#\f) ref->float)
      ((#\d) ref->double)
      ((#\*) ref->string)
      ((#\^) ref->ptr)
      ((#\c) objc:ref->char-or-bool)
      ((#\@) objc:ref->instance)
      ((#\#) objc:ref->class)
      ((#\:) objc:ref->selector)
      ((#\{) (ref->struct method-signature))
      ((#\r #\n #\N #\R #\V #\o #\O) (loop (fx+ i 1)))  ;; const etc. prefix modifiers
      (else (error 'result-converter "can not convert result type" method-signature)))))

(define (objc:ref->scheme-object ptr type)
  ((result-converter type) ptr))
      
;;; Convert Scheme objects to Objective C references.

;; These take c-pointers as their second (destination buffer) argument,
;; so use make-locative when you need to put the result in a byte-vector.

(define-macro (define-arg-conversion name from to)
  `(define ,name (foreign-lambda* c-pointer ((,from val) ((pointer ,to) buf))
                                  "*buf = val; return(buf);")))

(define-arg-conversion int->ref    integer "int")
(define-arg-conversion float->ref  float   "float")
(define-arg-conversion double->ref double  "double")
(define-arg-conversion short->ref  short   "short")
(define-arg-conversion long->ref   long    "long")
(define-arg-conversion char->ref   char    "char")
(define-arg-conversion uint->ref   unsigned-integer "unsigned int")
(define-arg-conversion ushort->ref unsigned-short   "unsigned short")
(define-arg-conversion ulong->ref  unsigned-long    "unsigned long")
(define-arg-conversion uchar->ref  unsigned-char    "unsigned char")
(define-arg-conversion ptr->ref    c-pointer "void *")
; (define-arg-conversion string->ref c-string  "void *")  ;; Disabled--need permanent storage space
;                                                         ;; for lifetime of ref.
(define (string->ref str buf) (error 'string->ref "conversion to char * unimplemented"))

(define (void->ref obj buf) buf)
  
(define (objc:class->ref c buf)
  (ptr->ref (objc:class->pointer c) buf))


;; (Auto-convert strings to NSStrings when ID is expected.)
;; (Convert #f to nil, implicitly done in ptr->ref.)
(define (objc:instance->ref o buf)
  (let ((ptr (objc:instance->pointer
              (if (string? o) (objc:nsstring o) o))))
    (if ptr
        (retain-and-autorelease ptr))   ;; The GC might destroy the corresponding Scheme object.
    (ptr->ref ptr buf)))

(define (objc:char-or-bool->ref c buf)
  (char->ref (objc:char-or-bool->char c) buf))

(define (objc:char-or-bool->char c)
  (case c
    ((#f) #\nul)
    ((#t) #\x1)
    (else c)))

;;;; Structure to reference converters.

(define (ns:rect->ref r buf)
  (NSRect-x-set! buf (ns:rect-x r))
  (NSRect-y-set! buf (ns:rect-y r))
  (NSRect-width-set! buf (ns:rect-width r))
  (NSRect-height-set! buf  (ns:rect-height r))
  buf)
(define (ns:point->ref p buf)
  (NSPoint-x-set! buf (ns:point-x p))
  (NSPoint-y-set! buf (ns:point-y p))
  buf)
(define (ns:size->ref s buf)
  (NSSize-width-set! buf (ns:size-width s))
  (NSSize-height-set! buf (ns:size-height s))
  buf)
(define (ns:range->ref r buf)
  (NSRange-location-set! buf (ns:range-location r))
  (NSRange-length-set! buf (ns:range-length r))
  buf)

;; Return the proper ref->structure conversion function based on type signature.
(define struct->ref
  (let ((struct-table (alist->hash-table `((,objc:NSRECT  . ,ns:rect->ref)
                                           (,objc:NSPOINT . ,ns:point->ref)
                                           (,objc:NSRANGE . ,ns:range->ref)
                                           (,objc:NSSIZE  . ,ns:size->ref))
                                         string=?)))
    (lambda (type-signature)
      (hash-table-ref struct-table type-signature
                      (lambda ()
                        (error 'arg-converter
                               "can not convert structure type" type-signature))))))


;;;; Master argument converter

(define (arg-converter method-signature)
  (let loop ((i 0))
    (case (string-ref method-signature i)
      ((#\v) void->ref)
      ((#\s) short->ref)
      ((#\i) int->ref)
      ((#\l) long->ref)
      ((#\C) uchar->ref)
      ((#\I) uint->ref)
      ((#\S) ushort->ref)
      ((#\L) ulong->ref)
      ((#\f) float->ref)
      ((#\d) double->ref)
      ((#\*) string->ref)   ; disabled above
;     ((#\^) ptr->ref)     ; suspicious: could be return by reference (void**)
                           ; or pass by reference (void *)
      ((#\c) objc:char-or-bool->ref)
      ((#\@) objc:instance->ref)
      ((#\#) objc:class->ref)
      ((#\:) objc:selector->ref)
      ((#\{) (struct->ref method-signature)) 
      ((#\r #\n #\N #\R #\V #\o #\O) (loop (fx+ i 1)))  ;; const etc. prefix modifiers
      (else (error 'arg-converter "can not convert argument type" method-signature)))))

;; buf-ptr should be a c-pointer (locative), not a container
(define (objc:scheme-object->ref obj type buf-ptr)
  ((arg-converter type) obj buf-ptr))