From 061a969f39f50c365369e28b5182d547f81ee11d Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Sun, 17 Feb 2008 12:46:23 +0100
Subject: Implement OBJCL-CREATE-CLASS.

darcs-hash:410094108d1b68697e4bf6c40a92e0d4dfceedba
---
 Lisp/class-definition.lisp | 24 ++++++++++--------------
 Lisp/libobjcl.lisp         | 27 +++++++++++++++++++++++++++
 2 files changed, 37 insertions(+), 14 deletions(-)

diff --git a/Lisp/class-definition.lisp b/Lisp/class-definition.lisp
index a4fb022..11d3767 100644
--- a/Lisp/class-definition.lisp
+++ b/Lisp/class-definition.lisp
@@ -225,20 +225,16 @@
                                    (typep c 'foreign-direct-slot-definition))
                                direct-slots))
          (new-class-pointer
-          (%objcl-create-class (symbol->objc-class-name name)
-                               (pointer-to (find-if
-                                            #'(lambda (c)
-                                                (typep c 'objective-c-class))
-                                            direct-superclasses))
-                               0
-                               (null-pointer)
-                               (length ivars)
-                               (mapcar #'slot-definition-foreign-name
-                                       ivars)
-                               (mapcar #'(lambda (x)
-                                           (print-typespec-to-string
-                                            (slot-definition-foreign-type x)))
-                                       ivars)))
+          (objcl-create-class (symbol->objc-class-name name)
+                              (find-if #'(lambda (c)
+                                           (typep c 'objective-c-class))
+                                       direct-superclasses)
+                              nil
+                              (mapcar #'slot-definition-foreign-name
+                                      ivars)
+                              (mapcar #'(lambda (x)
+                                          (slot-definition-foreign-type x))
+                                      ivars)))
          (metaclass
           (ensure-class name
                         :metaclass (class-of (class-of superclass))
diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp
index c4b9d18..1364c58 100644
--- a/Lisp/libobjcl.lisp
+++ b/Lisp/libobjcl.lisp
@@ -747,6 +747,33 @@ separating parts by hyphens works nicely in all of the `:INVERT`,
 (defun objcl-class-superclass (class)
   (objcl-class-superclass/pointer (pointer-to class)))
 
+(defun objcl-create-class (class-name superclass
+                           protocol-names
+                           ivar-names ivar-typespecs)
+  (let* ((ivar-typestrings (mapcar #'print-typespec-to-string ivar-typespecs)))
+    (with-foreign-string-pool (register-temporary-string
+                               allocate-temporary-string)
+      (with-foreign-objects ((%protocol-names :pointer (length protocol-names))
+                             (%ivar-names :pointer (length ivar-names))
+                             (%ivar-typestrings :pointer (length ivar-typestrings)))
+        (flet ((fill-foreign-array-from-list (array list type)
+                 (loop for element in list
+                       for i from 0
+                       do (setf (mem-aref array type i) element))))
+          (loop for (array . list) in (list (cons %protocol-names protocol-names)
+                                            (cons %ivar-names ivar-names)
+                                            (cons %ivar-typestrings ivar-typestrings))
+                do (fill-foreign-array-from-list array
+                                                 (mapcar #'allocate-temporary-string
+                                                         list)
+                                                 :pointer)))
+        (%objcl-create-class class-name
+                         (pointer-to superclass)
+                         (length protocol-names)
+                         %protocol-names
+                         (length ivar-names)
+                         %ivar-names
+                         %ivar-typestrings)))))
 
 ;;; (@* "Low-level Data Conversion")
 (eval-when (:compile-toplevel :load-toplevel)
-- 
cgit v1.2.3