From 6895fb365446fb98b76e2f94d27afa0a7fa18133 Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Mon, 13 Aug 2007 15:24:48 +0200
Subject: Add generic functions that convert Lisp values into CFFI-friendly
 objects.

darcs-hash:8a1564deb9558bfd7d884ce16841d3c766a7f094
---
 Lisp/type-conversion.lisp | 163 +++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 162 insertions(+), 1 deletion(-)

(limited to 'Lisp')

diff --git a/Lisp/type-conversion.lisp b/Lisp/type-conversion.lisp
index 42f3a98..9e8e94f 100644
--- a/Lisp/type-conversion.lisp
+++ b/Lisp/type-conversion.lisp
@@ -1,7 +1,7 @@
 (in-package #:mulk.objective-cl)
 
 
-;;; (@* "Data conversion")
+;;; (@* "Low-level Data Conversion")
 (defun lisp->obj-data (value)
   (let ((obj-data (foreign-alloc 'obj-data))
         (type-name (lisp-value->type-name value)))
@@ -66,3 +66,164 @@ and free the C string afterwards."
   (unwind-protect
        (foreign-string-to-lisp foreign-string)
     (foreign-string-free foreign-string)))
+
+
+;;; (@* "High-level Data Conversion")
+(eval-when (:compile-toplevel :load-toplevel)
+  ;; In order to be able to dispatch over pointer types, we need to
+  ;; define an alias of the implementation's own pointer class.  Note
+  ;; that this may be T (in GNU CLISP, for example), so it's a good idea
+  ;; to use CHECK-TYPE in the method body.
+  (unless (find-class 'foreign-pointer nil)
+    (setf (find-class 'foreign-pointer nil)
+          (class-of (make-pointer 0))))
+  (deftype foreign-pointer ()
+    '(satisfies cffi:pointerp)))
+
+
+(defun objc-typep (x class-designator)
+  (objc-eql (invoke x 'class)
+            (etypecase x
+              (class x)
+              (id (invoke x 'class))
+              ((or string symbol) (find-objc-class class-designator t)))))
+
+
+(defgeneric ->id (x))
+(defgeneric ->class (x))
+(defgeneric ->integer (x))
+(defgeneric ->selector (x))
+(defgeneric ->exception (x))
+(defgeneric ->character (x))
+(defgeneric ->float (x))
+(defgeneric ->double (x))
+(defgeneric ->bool (x))
+(defgeneric ->string (x))
+(defgeneric ->pointer (x))
+
+
+(defmethod ->id ((x id))
+  x)
+
+(defmethod ->id ((x class))
+  (invoke x 'self))
+
+(defmethod ->id ((x exception))
+  (invoke x 'self))
+
+(defmethod ->id ((x integer))
+  (let ((id (invoke (find-class 'ns-number)
+                    :number-with-long x)))
+    (invoke id 'retain)
+    (invoke id 'autorelease)
+    id))
+
+(defmethod ->id ((x float))
+  (let ((id (invoke (find-class 'ns-number)
+                    :number-with-double x)))
+    (invoke id 'retain)
+    (invoke id 'autorelease)
+    id))
+
+(defmethod ->id ((x string))
+  (let ((id (invoke (find-class 'ns-string)
+                    :string-with-c-string x)))
+    (invoke id 'retain)
+    (invoke id 'autorelease)
+    id))
+
+
+(defmethod ->class ((x id))
+  (invoke x 'class))
+
+(defmethod ->class ((x exception))
+  (invoke x 'class))
+
+(defmethod ->class ((x class))
+  x)
+
+(defmethod ->class ((x string))
+  (find-objc-class x t))
+
+(defmethod ->class ((x symbol))
+  (find-objc-class x t))
+
+
+(defmethod ->integer ((x id))
+  (assert (objc-typep x 'ns-number))
+  (invoke x 'long-value))
+
+(defmethod ->integer ((x number))
+  (truncate x))
+
+(defmethod ->integer ((x null))
+  0)
+
+(defmethod ->integer ((x symbol))
+  (assert (eq 't x))
+  1)
+
+
+(defmethod ->selector ((x selector))
+  x)
+
+(defmethod ->selector ((x symbol))
+  (selector x))
+
+(defmethod ->selector ((x string))
+  (selector x))
+
+(defmethod ->selector ((x cons))
+  (selector x))
+
+
+(defmethod ->exception ((x exception))
+  x)
+
+
+(defmethod ->character ((x character))
+  x)
+
+(defmethod ->character ((x integer))
+  x)
+
+
+(defmethod ->float ((x number))
+  (float x))
+
+
+(defmethod ->double ((x number))
+  (float x))
+
+
+(defmethod ->bool ((x null))
+  x)
+
+(defmethod ->bool ((x symbol))
+  (assert (eq 't x))
+  x)
+
+(defmethod ->bool ((x integer))
+  x)
+
+
+(defmethod ->string ((x string))
+  x)
+
+(defmethod ->string ((x foreign-pointer))
+  (check-type x foreign-pointer)
+  x)
+
+
+(defmethod ->pointer ((x foreign-pointer))
+  (check-type x foreign-pointer)
+  x)
+
+(defmethod ->pointer ((x exception))
+  (pointer-to x))
+
+(defmethod ->pointer ((x c-pointer-wrapper))
+  (pointer-to x))
+
+(defmethod ->pointer ((x number))
+  (pointer-to (->id x)))
-- 
cgit v1.2.3