summaryrefslogtreecommitdiff
path: root/Lisp
diff options
context:
space:
mode:
Diffstat (limited to 'Lisp')
-rw-r--r--Lisp/class-definition.lisp126
-rw-r--r--Lisp/libobjcl.lisp7
-rw-r--r--Lisp/name-conversion.lisp17
3 files changed, 132 insertions, 18 deletions
diff --git a/Lisp/class-definition.lisp b/Lisp/class-definition.lisp
index cac6041..b8e23e4 100644
--- a/Lisp/class-definition.lisp
+++ b/Lisp/class-definition.lisp
@@ -18,6 +18,9 @@
(in-package #:mulk.objective-cl)
+(defvar *objcl-foreign-default-initform* (gensym))
+
+
(defclass foreign-slot-definition-mixin ()
((foreign-name :initarg :foreign-name
:initform nil
@@ -26,6 +29,9 @@
(foreign-type :initarg :foreign-type
:initform nil
:accessor slot-definition-foreign-type)
+ (foreign-slot :initarg :foreign-slot
+ :initform nil
+ :accessor slot-definition-foreign-slot)
#+#:unused
(property :initarg :property
:accessor slot-definition-property-p
@@ -56,7 +62,7 @@
&rest initargs)
(if (some #'(lambda (symbol) (let ((nada '#:nada))
(not (eq nada (getf initargs symbol nada)))))
- '(:foreign-type :foreign-name))
+ '(:foreign-type :foreign-name :foreign-slot))
(find-class 'foreign-direct-slot-definition)
(find-class 'c2mop:standard-direct-slot-definition)))
@@ -65,37 +71,100 @@
&rest initargs)
(if (some #'(lambda (symbol) (let ((nada '#:nada))
(not (eq nada (getf initargs symbol nada)))))
- '(:foreign-type :foreign-name))
+ '(:foreign-type :foreign-name :foreign-slot))
(find-class 'foreign-effective-slot-definition)
(find-class 'c2mop:standard-effective-slot-definition)))
+(defmethod c2mop:compute-effective-slot-definition ((class objective-c-class)
+ name
+ direct-slot-definitions)
+ (etypecase (first direct-slot-definitions)
+ (foreign-direct-slot-definition
+ (let ((direct-slot (first direct-slot-definitions)))
+ (with-accessors ((type c2mop:slot-definition-type)
+ (readers c2mop:slot-definition-readers)
+ (writers c2mop:slot-definition-writers)
+ (initargs c2mop:slot-definition-initargs)
+ (initform c2mop:slot-definition-initform)
+ (allocation c2mop:slot-definition-allocation)
+ (initfunction c2mop:slot-definition-initfunction)
+ (foreign-type slot-definition-foreign-type)
+ (foreign-name slot-definition-foreign-name)
+ (foreign-slot slot-definition-foreign-slot))
+ direct-slot
+ (make-instance 'foreign-effective-slot-definition
+ :type (or type t)
+ :name name
+ :readers (or readers nil)
+ :writers (or writers nil)
+ :initargs (or initargs nil)
+ :initform (or initform *objcl-foreign-default-initform*)
+ :location nil
+ :allocation (or allocation :instance)
+ :initfunction (or initfunction
+ #'(lambda ()
+ (or initform *objcl-foreign-default-initform*)))
+ :foreign-type foreign-type
+ :foreign-name foreign-name
+ :foreign-slot foreign-slot
+ :class class))))
+ (c2mop:standard-direct-slot-definition (call-next-method))))
+
+
+(defmethod initialize-instance :after
+ ((slot-definition foreign-effective-slot-definition)
+ &key foreign-name
+ foreign-slot
+ foreign-type
+ name
+ class
+ &allow-other-keys)
+ (when (and (not foreign-name) (not foreign-slot))
+ (setf foreign-name (slot-name->foreign-slot-name name)
+ (slot-value slot-definition 'foreign-name) foreign-name))
+ (cond ((and foreign-name foreign-slot))
+ (foreign-name
+ (setf foreign-slot
+ (or (find foreign-name
+ (mapcan #'objcl-class-direct-slots
+ (c2mop:compute-class-precedence-list
+ class))
+ :key #'objcl-slot-name
+ :test #'string=)
+ (error "There is no Objective-C slot named ~A in class ~A"
+ foreign-name
+ class))
+ (slot-value slot-definition 'foreign-slot) foreign-slot))
+ (foreign-slot
+ (setf foreign-name (objcl-slot-name foreign-slot)
+ (slot-value slot-definition 'foreign-name) foreign-name)))
+ (unless foreign-type
+ (setf (slot-value slot-definition 'foreign-type)
+ foreign-slot)))
+
+
(defmethod c2mop:slot-value-using-class ((class objective-c-class)
instance
- effective-slot-definition)
- (etypecase effective-slot-definition
- (c2mop:standard-effective-slot-definition (call-next-method))
- (foreign-effective-slot-definition
- (cerror "Continue" "FIXME"))))
+ (effective-slot-definition
+ foreign-effective-slot-definition))
+ (cerror "Continue" "FIXME"))
(defmethod (setf c2mop:slot-value-using-class) (value
(class objective-c-class)
instance
- effective-slot-definition)
- (etypecase effective-slot-definition
- (c2mop:standard-effective-slot-definition (call-next-method))
- (foreign-effective-slot-definition
- (cerror "Continue" "FIXME"))))
+ (effective-slot-definition
+ foreign-effective-slot-definition))
+ (unless (eq value *objcl-foreign-default-initform*)
+ (cerror "Continue" "FIXME")))
(defmethod c2mop:slot-boundp-using-class ((class objective-c-class)
instance
- effective-slot-definition)
- (declare (ignore instance))
- (etypecase effective-slot-definition
- (c2mop:standard-effective-slot-definition (call-next-method))
- (foreign-effective-slot-definition t)))
+ (effective-slot-definition
+ foreign-effective-slot-definition))
+ (declare (ignore instance)))
(defmethod c2mop:slot-makunbound-using-class ((class objective-c-class)
@@ -115,6 +184,29 @@
(call-next-method))
+(defmethod initialize-instance :around ((class objective-c-class)
+ &rest args
+ &key direct-slots
+ pointer
+ &allow-other-keys)
+ (let ((key-args (copy-list args)))
+ (dolist (objc-slot (objcl-class-direct-slots/pointer pointer))
+ (let ((slot-name
+ (intern (string-upcase (objcl-slot-name objc-slot))
+ (find-package '#:objective-c-classes))))
+ (when (notany #'(lambda (slot-definition)
+ (eql slot-name (car slot-definition)))
+ direct-slots)
+ (push (list
+ :name slot-name
+ :foreign-name (objcl-slot-name objc-slot)
+ :foreign-type (typespec->c-type
+ (parse-typespec
+ (objcl-slot-type objc-slot))))
+ (getf key-args :direct-slots)))))
+ (apply #'call-next-method class key-args)))
+
+
#+(or)
(defmethod make-instance ((class-name (eql 'objective-c-class)) &rest initargs)
(let ((class (call-next-method)))
diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp
index bf166c4..4dff7ad 100644
--- a/Lisp/libobjcl.lisp
+++ b/Lisp/libobjcl.lisp
@@ -742,9 +742,14 @@ separating parts by hyphens works nicely in all of the `:INVERT`,
(%objcl-slot-name slot))
(defun objcl-class-direct-slots (class)
+ (if (typep class 'objective-c-class)
+ (objcl-class-direct-slots/pointer (pointer-to class))
+ nil))
+
+(defun objcl-class-direct-slots/pointer (class-ptr)
(with-foreign-objects ((count-ptr :unsigned-int)
(element-size-ptr :unsigned-int))
- (let ((array-pointer (%objcl-class-direct-slots (pointer-to class)
+ (let ((array-pointer (%objcl-class-direct-slots class-ptr
count-ptr
element-size-ptr)))
(unwind-protect
diff --git a/Lisp/name-conversion.lisp b/Lisp/name-conversion.lisp
index 4ff637c..0c294fb 100644
--- a/Lisp/name-conversion.lisp
+++ b/Lisp/name-conversion.lisp
@@ -114,3 +114,20 @@
(concatenate 'string
"%"
(symbol-name (objc-class-name->symbol meta-class-name)))))))
+
+
+(defun slot-name->foreign-slot-name (slot-name)
+ (let* ((string (symbol-name slot-name))
+ (case-converted-slot-name
+ (ecase (readtable-case *readtable*)
+ (:preserve string)
+ (:invert (cond ((notany #'lower-case-p string)
+ (string-downcase string))
+ ((notany #'upper-case-p string)
+ (string-upcase string))
+ (t string)))
+ (:upcase (if (notany #'lower-case-p string)
+ (string-downcase string)
+ string))
+ (:downcase string))))
+ (substitute #\_ #\- case-converted-slot-name)))