From fedbfff7c5f7091e5e2b2d29d6ebf1a20349f60f Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Tue, 19 Feb 2008 13:22:41 +0100
Subject: Reimplement slot writing.

darcs-hash:54a65f96e6367f42013fef524eeddbeb4b8889ec
---
 Lisp/class-definition.lisp | 47 ++++++++++++++++------------------------------
 Lisp/libobjcl.lisp         | 11 ++++++++---
 Objective-C/libobjcl.h     |  3 +++
 Objective-C/libobjcl.m     |  8 ++++++++
 4 files changed, 35 insertions(+), 34 deletions(-)

diff --git a/Lisp/class-definition.lisp b/Lisp/class-definition.lisp
index e228c56..0d95cc4 100644
--- a/Lisp/class-definition.lisp
+++ b/Lisp/class-definition.lisp
@@ -170,38 +170,23 @@
   ;; present in the foreign slot at this time.
   (unless (eq value *objcl-foreign-default-initform*)
     (with-slots (foreign-name foreign-type) effective-slot-definition
-      ;; FIXME: What to do about memory management here?  Strings are
-      ;; possibly the most problematic case here.
-      ;;
-      ;; Note: %OBJCL-SET-SLOT-VALUE expects a pointer to the value that
-      ;; it should store as an argument, not the value itself.  For
-      ;; structs and related things that can't be reasonably passed by
-      ;; value, this is good news.  For everything else, it means just a
-      ;; bit more work.
-      (case (typespec-primary-type foreign-type)
-        ((struct union id class array)
-         (%objcl-set-slot-value (pointer-to instance)
-                                foreign-name
-                                (typecase value
+      (let* ((slot-offset
+              (%objcl-get-slot-offset
+               (%objcl-get-slot (pointer-to class) foreign-name)))
+             (slot-cell (inc-pointer (pointer-to instance) slot-offset)))
+        (case (typespec-primary-type foreign-type)
+          ((struct union array)
+           (let ((value-pointer (typecase value
                                   (c-pointer value)
-                                  (t (pointer-to value)))))
-         ((:pointer)
-          ;; FIXME: Does this make sense?  No.  Does it work?  Must
-          ;; check.
-          (with-foreign-object (slot-cell (typespec->c-type foreign-type))
-            (setf (mem-ref slot-cell (typespec->c-type foreign-type))
-                  value)
-            (%objcl-set-slot-value (pointer-to instance)
-                                   foreign-name
-                                   slot-cell)))
-         (otherwise
-          ;; BIG RED FIXME: WTF is _wrong_ with this
-          ;; object_getInstanceVariable stuff?
-          ;;
-          ;; Pure lossage!
-          (%objcl-set-slot-value (pointer-to instance)
-                                 foreign-name
-                                 (make-pointer value)))))))
+                                  (c-pointer-wrapper (pointer-to value)))))
+             (memmove slot-cell value-pointer (sizeof foreign-type))))
+          (otherwise
+           ;; FIXME: What to do about memory management here?  Strings are
+           ;; possibly the most problematic case.
+           ;;
+           ;; Also, should we do ID conversion as for method arguments
+           ;; here?
+           (setf (mem-ref slot-cell (typespec->c-type foreign-type)) value)))))))
 
 
 (defmethod c2mop:slot-boundp-using-class ((class objective-c-class)
diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp
index f28d4b8..f68838c 100644
--- a/Lisp/libobjcl.lisp
+++ b/Lisp/libobjcl.lisp
@@ -33,6 +33,11 @@
 (use-foreign-library libobjcl)
 
 
+(defcfun ("objcl_memmove" memmove) :pointer
+  (destination :pointer)
+  (source :pointer)
+  (length :unsigned-long))
+
 (defcfun ("objcl_initialise_runtime" %initialise-runtime) :void)
 
 (defcfun ("objcl_shutdown_runtime" %shutdown-runtime) :void)
@@ -873,13 +878,13 @@ separating parts by hyphens works nicely in all of the `:INVERT`,
 
 ;;;; (@* "Helper functions")
 (defun sizeof (typespec)
-  (%objcl-sizeof-type typespec))
+  (%objcl-sizeof-type (print-typespec-to-string typespec)))
 
 (defun alignof (typespec)
-  (%objcl-alignof-type typespec))
+  (%objcl-alignof-type (print-typespec-to-string typespec)))
 
 (defun return-type-sizeof (typespec)
-  (%objcl-sizeof-return-type typespec))
+  (%objcl-sizeof-return-type (print-typespec-to-string typespec)))
 
 (defun runtime-type ()
   (let ((runtime (%objcl-get-runtime-type)))
diff --git a/Objective-C/libobjcl.h b/Objective-C/libobjcl.h
index c2e2fac..b5cefce 100644
--- a/Objective-C/libobjcl.h
+++ b/Objective-C/libobjcl.h
@@ -59,6 +59,9 @@ extern id objcl_current_exception;
 extern NSRecursiveLock *objcl_current_exception_lock;
 
 
+void *
+objcl_memmove (void *dest, void *src, unsigned long length);
+
 void
 objcl_initialise_runtime (void);
 
diff --git a/Objective-C/libobjcl.m b/Objective-C/libobjcl.m
index f244e50..646dccd 100644
--- a/Objective-C/libobjcl.m
+++ b/Objective-C/libobjcl.m
@@ -25,6 +25,7 @@
 #import "Foundation/Foundation.h"
 
 #include <stdarg.h>
+#include <string.h>
 #include <sys/mman.h>
 #include <objc/objc-api.h>
 
@@ -68,6 +69,13 @@ static NSMutableSet *lisp_backed_classes = nil;
 static int init_count = 0;
 
 
+void *
+objcl_memmove (void *dest, void *src, unsigned long length)
+{
+  return memmove (dest, src, length);
+}
+
+
 void
 objcl_initialise_runtime (void)
 {
-- 
cgit v1.2.3