From 6ffe476ad4c840a00f0c2e72c6020091e3ce801d Mon Sep 17 00:00:00 2001 From: Matthias Benkard Date: Thu, 6 Mar 2008 21:48:10 +0100 Subject: Refactor data conversion. darcs-hash:9ff52b1ed764ab58522070fc35eca4ab97844a1c --- Lisp/method-definition.lisp | 7 +- Lisp/method-invocation.lisp | 143 +---------------------------- Lisp/type-conversion-policy.lisp | 191 +++++++++++++++++++++++++++++++++++++++ Lisp/type-conversion.lisp | 6 ++ Objective-C/libobjcl.m | 2 +- objective-cl.asd | 7 ++ 6 files changed, 209 insertions(+), 147 deletions(-) create mode 100644 Lisp/type-conversion-policy.lisp diff --git a/Lisp/method-definition.lisp b/Lisp/method-definition.lisp index cd32600..7218f48 100644 --- a/Lisp/method-definition.lisp +++ b/Lisp/method-definition.lisp @@ -404,13 +404,12 @@ __define-objective-c-generic-function__. ,@arguments)) (format t "~&~A" (list ,@arg-symbols))) (unwind-protect - (,(case (typespec-primary-type return-type) - ((:id :class :selector) 'pointer) - (t 'progn)) + (coerce-object (,(generic-function-name gf) ;; Leave the second argument (the ;; selector) out. - ,@(list* (car arguments) (cddr arguments)))) + ,@(list* (car arguments) (cddr arguments))) + ',return-type) ;; FIXME: We may want to wrap signalled ;; SERIOUS-CONDITIONS in some kind of ;; Objective-C exception object and put diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp index ab520df..66f7368 100644 --- a/Lisp/method-invocation.lisp +++ b/Lisp/method-invocation.lisp @@ -425,7 +425,7 @@ easier to use with __apply__. ;; detailed method signature type information, ;; it's the best we can do. (setf (argref arg-c-type i) - (pointer-to (coerce-object arg 'id)))) + (pointer-to (coerce-object arg :id)))) (t (setf (argref arg-c-type i) (case arg ;; Do the right thing for booleans. @@ -481,144 +481,3 @@ easier to use with __apply__. (>= mismatch (length prefix)))))) (or (method-name-starts-with "alloc") (method-name-starts-with "new")))) - - -;;; (@* "High-level Data Conversion") -(defgeneric coerce-object (object type)) - - -(defcoercion id ((x id)) - x) - -(defcoercion id ((x objective-c-class)) - x) - -(defcoercion id ((x exception)) - x) - -(defcoercion id ((x integer)) - (primitive-invoke (find-objc-class 'ns-number) - "numberWithInt:" - 'id - x)) - -(defcoercion id ((x float)) - (primitive-invoke (find-objc-class 'ns-number) - (etypecase x - (long-float "numberWithDouble:") - (double-float "numberWithDouble:") - (short-float "numberWithFloat:") - (single-float "numberWithFloat:")) - 'id - x)) - -(defcoercion id ((x null)) - +nil+) - -;; (defcoercion id ((x {list, string, t})) ...): See lisp-value-wrapping.lisp. - - -(defcoercion class ((x id)) - (object-get-class x)) - -(defcoercion class ((x exception)) - (object-get-class x)) - -(defcoercion class ((x objective-c-class)) - x) - -(defcoercion class ((x string)) - (find-objc-class x t)) - -(defcoercion class ((x symbol)) - (find-objc-class x t)) - - -(defcoercion integer ((x integer)) - x) - -(defcoercion integer ((x id)) - (assert (objc-typep x 'ns-number)) - (invoke x 'int-value)) - -(defcoercion integer ((x number)) - (truncate x)) - -(defcoercion integer ((x null)) - (declare (ignore x)) - +no+) - -(defcoercion integer (x) - (declare (ignore x)) - +yes+) - - -(defcoercion selector ((x selector)) - x) - -(defcoercion selector ((x symbol)) - (selector x)) - -(defcoercion selector ((x string)) - (selector x)) - -(defcoercion selector ((x cons)) - (selector x)) - - -(defcoercion exception ((x exception)) - x) - - -(defcoercion character ((x character)) - x) - -(defcoercion character ((x integer)) - x) - - -(defcoercion float ((x number)) - (float x)) - - -(defcoercion double ((x number)) - (float x)) - - -;; Note that this refers to the Objective-C BOOL type, not the Lisp -;; BOOLEAN type. -(defcoercion bool ((x null)) - (declare (ignore x)) - +no+) - -(defcoercion bool (x) - (declare (ignore x)) - +yes+) - - -;; Note that this refers to the Lisp BOOLEAN type, not the Objective-C -;; BOOL type. -(defcoercion boolean ((x number)) - (not (zerop x))) - - -(defcoercion string ((x string)) - x) - -(defcoercion string ((x foreign-pointer)) - (check-type x foreign-pointer) - x) - - -(defcoercion pointer ((x foreign-pointer)) - (check-type x foreign-pointer) - x) - -(defcoercion pointer ((x exception)) - (pointer-to x)) - -(defcoercion pointer ((x c-pointer-wrapper)) - (pointer-to x)) - -(defcoercion pointer ((x number)) - (pointer-to (coerce-object x 'id))) diff --git a/Lisp/type-conversion-policy.lisp b/Lisp/type-conversion-policy.lisp new file mode 100644 index 0000000..ba1ae34 --- /dev/null +++ b/Lisp/type-conversion-policy.lisp @@ -0,0 +1,191 @@ +;;;; Objective-CL, an Objective-C bridge for Common Lisp. +;;;; Copyright (C) 2007, 2008 Matthias Andreas Benkard. +;;;; +;;;; This program is free software: you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public License +;;;; as published by the Free Software Foundation, either version 3 of +;;;; the License, or (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, but +;;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this program. If not, see +;;;; . + +(in-package #:mulk.objective-cl) + + +(defmethod coerce-object (object (type list)) + (coerce-object object (typespec-primary-type type))) + + +(defcoercion :int (x) + (coerce-object x 'integer)) + +(defcoercion :short (x) + (coerce-object x 'integer)) + +(defcoercion :long (x) + (coerce-object x 'integer)) + +(defcoercion :long-long (x) + (coerce-object x 'integer)) + +(defcoercion :char (x) + (coerce-object x 'integer)) + +(defcoercion :unsigned (x) + (coerce-object x 'integer)) + +(defcoercion :unsigned-long (x) + (coerce-object x 'integer)) + +(defcoercion :unsigned-long-long (x) + (coerce-object x 'integer)) + +(defcoercion :unsigned-char (x) + (coerce-object x 'integer)) + + + +(defcoercion :id ((x id)) + x) + +(defcoercion :id ((x objective-c-class)) + x) + +(defcoercion :id ((x exception)) + x) + +(defcoercion :id ((x integer)) + (primitive-invoke (find-objc-class 'ns-number) + "numberWithInt:" + 'id + x)) + +(defcoercion :id ((x float)) + (primitive-invoke (find-objc-class 'ns-number) + (etypecase x + (long-float "numberWithDouble:") + (double-float "numberWithDouble:") + (short-float "numberWithFloat:") + (single-float "numberWithFloat:")) + 'id + x)) + +(defcoercion :id ((x null)) + +nil+) + +;; (defcoercion id ((x {list, string, t})) ...): See lisp-value-wrapping.lisp. + + +(defcoercion :class ((x id)) + (object-get-class x)) + +(defcoercion :class ((x exception)) + (object-get-class x)) + +(defcoercion :class ((x objective-c-class)) + x) + +(defcoercion :class ((x string)) + (find-objc-class x t)) + +(defcoercion :class ((x symbol)) + (find-objc-class x t)) + + +(defcoercion integer ((x integer)) + x) + +(defcoercion integer ((x id)) + (assert (objc-typep x 'ns-number)) + (invoke x 'int-value)) + +(defcoercion integer ((x number)) + (truncate x)) + +(defcoercion integer ((x null)) + (declare (ignore x)) + +no+) + +(defcoercion integer (x) + (declare (ignore x)) + +yes+) + + +(defcoercion :selector ((x selector)) + x) + +(defcoercion :selector ((x symbol)) + (selector x)) + +(defcoercion :selector ((x string)) + (selector x)) + +(defcoercion :selector ((x cons)) + (selector x)) + + +(defcoercion :exception ((x exception)) + x) + + +(defcoercion :char ((x null)) + 0) + +(defcoercion :char ((x character)) + x) + +(defcoercion :char ((x integer)) + x) + + +(defcoercion :float ((x number)) + (float x)) + + +(defcoercion :double ((x number)) + (float x)) + + +;; Note that this refers to the Objective-C BOOL type, not the Lisp +;; BOOLEAN type. +(defcoercion :boolean ((x null)) + (declare (ignore x)) + +no+) + +(defcoercion :boolean (x) + (declare (ignore x)) + +yes+) + + +;; Note that this refers to the Lisp BOOLEAN type, not the Objective-C +;; BOOL type. +(defcoercion boolean ((x number)) + (not (zerop x))) + + +(defcoercion :string ((x string)) + x) + +(defcoercion :string ((x foreign-pointer)) + (check-type x foreign-pointer) + x) + + +(defcoercion :pointer ((x foreign-pointer)) + (check-type x foreign-pointer) + x) + +(defcoercion :pointer ((x exception)) + (pointer-to x)) + +(defcoercion :pointer ((x c-pointer-wrapper)) + (pointer-to x)) + +(defcoercion :pointer ((x number)) + (pointer-to (coerce-object x 'id))) diff --git a/Lisp/type-conversion.lisp b/Lisp/type-conversion.lisp index df9b0e0..eac3687 100644 --- a/Lisp/type-conversion.lisp +++ b/Lisp/type-conversion.lisp @@ -40,3 +40,9 @@ (make-struct-wrapper foreign-value-cell typespec t)) ((:void) (values)) (otherwise (cffi:mem-ref foreign-value-cell c-type))))) + + +;; COERCE-OBJECT is the high-level facility that other parts of +;; Objective-CL may rely on for their conversion needs. Its methods +;; are implemented in type-conversion-policy.lisp. +(defgeneric coerce-object (object type)) diff --git a/Objective-C/libobjcl.m b/Objective-C/libobjcl.m index 54684bf..06620e2 100644 --- a/Objective-C/libobjcl.m +++ b/Objective-C/libobjcl.m @@ -386,7 +386,7 @@ objcl_get_method_implementation (id object, Class target_class; /* struct objc_super super_struct; super_struct.receiver = object; - super_struct.super_class = superclass_for_send_super; + super_struct.class = superclass_for_send_super; */ if (objcl_object_is_class (object)) diff --git a/objective-cl.asd b/objective-cl.asd index e28e90a..82d1731 100644 --- a/objective-cl.asd +++ b/objective-cl.asd @@ -57,6 +57,13 @@ "type-handling" "policy" "data-types")) + (:file "type-conversion-policy" :depends-on ("defpackage" + "memory-management" + "data-types" + "type-handling" + "policy" + "data-types" + "method-invocation")) (:file "type-handling" :depends-on ("defpackage" "libobjcl" "init")) -- cgit v1.2.3