Refactor directory and source file layout.

darcs-hash:0eb031a60f3b86a678869960867410811ca5325c

17 files changed, 604 insertions, 527 deletions

diff --git a/GNUmakefile b/GNUmakefile
index 5aafe7f..c00c927 100644
--- a/GNUmakefile
+++ b/GNUmakefile
@@ -1,11 +1,10 @@
 include $(GNUSTEP_MAKEFILES)/common.make
 
-LIBRARY_NAME = libobjcl
-VERSION = 0.0.1
+include version.make
 
+PACKAGE_NAME = Objective-CL
 RPM_DISABLE_RELOCATABLE = YES
-ADDITIONAL_OBJCFLAGS = -Wall -g -DVERSION=\"$(VERSION)\"
-libobjcl_OBJC_FILES = libobjcl.m
-LIBRARIES_DEPEND_UPON  =  $(FND_LIBS) $(GUI_LIBS) $(OBJC_LIBS) $(SYSTEM_LIBS) $(CONFIG_SYSTEM_LIBS)
 
-include $(GNUSTEP_MAKEFILES)/library.make
+SUBPROJECTS = Objective-C
+
+include $(GNUSTEP_MAKEFILES)/aggregate.make
diff --git a/Lisp/constant-data.lisp b/Lisp/constant-data.lisp
new file mode 100644
index 0000000..3d424f5
--- /dev/null
+++ b/Lisp/constant-data.lisp
@@ -0,0 +1,123 @@
+(in-package #:mulk.objective-cl)
+
+
+;;;; (@* "Constant accessors")
+(defun lisp-value->type-name (value)
+  (car (rassoc-if #'(lambda (type)
+                      (typep value type))
+                  *objcl-type-map*)))
+
+(defun type-name->lisp-type (type-name)
+  (cdr (assoc type-name *objcl-type-map*)))
+
+(defun type-name->slot-name (type-name)
+  (cdr (assoc type-name *objcl-data-map*)))
+
+(defun type-name->type-id (type-name)
+  (string (cdr (assoc type-name *objcl-api-type-names*))))
+
+(defun type-id->type-name (type-id)
+  (car (rassoc (char type-id 0) *objcl-api-type-names*)))
+
+(defun type-name->c-type (type-name)
+  (cdr (assoc type-name *objcl-c-type-map*)))
+
+
+;;;; (@* "The constant data")
+;;; Copied from objc-api.h
+;;; Probably ought to be generated by C code at initialisation time.
+(defparameter *objcl-api-type-names*
+  '((id       . #\@)
+    (class    . #\#)
+    (exc      . #\E)
+    (sel      . #\:)
+    (chr      . #\c)
+    (uchr     . #\C)
+    (sht      . #\s)
+    (usht     . #\S)
+    (int      . #\i)
+    (uint     . #\I)
+    (lng      . #\l)
+    (ulng     . #\L)
+    (lng-lng  . #\q)
+    (ulng-lng . #\Q)
+    (flt      . #\f)
+    (dbl      . #\d)
+    (bfld     . #\b)
+    (bool     . #\B)
+    (void     . #\v)
+    (undef    . #\?)
+    (ptr      . #\^)
+    (charptr  . #\*)
+    (atom     . #\%)
+    (ary-b    . #\[)
+    (ary-e    . #\])
+    (union-b  . #\()
+    (union-e  . #\))
+    (struct-b . #\{)
+    (struct-e . #\})
+    (vector   . #\!)
+    (complex  . #\j)))
+
+
+(defparameter *objcl-data-map*
+  '((id       . id-val)
+    (class    . class-val)
+    (exc      . exc-val)
+    (sel      . sel-val)
+    (chr      . char-val)
+    (uchr     . char-val)
+    (sht      . short-val)
+    (usht     . short-val)
+    (int      . int-val)
+    (uint     . int-val)
+    (lng      . long-val)
+    (ulng     . long-val)
+    (lng-lng  . long-long-val)
+    (ulng-lng . long-long-val)
+    (flt      . float-val)
+    (dbl      . double-val)
+    (bool     . bool-val)
+    (ptr      . ptr-val)
+    (charptr  . charptr-val)))
+
+
+(defparameter *objcl-type-map*
+  '((id       . objc-id)
+    (class    . objc-class)
+    (sel      . objc-selector)
+    (exc      . objc-exception)
+    (chr      . character)
+    (int      . integer)
+    (uint     . integer)
+    (lng      . integer)
+    (ulng     . integer)
+    (sht      . integer)
+    (usht     . integer)
+    (lng-lng  . integer)
+    (ulng-lng . integer)
+    (flt      . single-float)
+    (dbl      . double-float)
+    (bool     . boolean)
+    (ptr      . c-pointer)
+    (charptr  . string)))
+
+(defparameter *objcl-c-type-map*
+  '((id       . :pointer)
+    (class    . :pointer)
+    (sel      . :pointer)
+    (exc      . :pointer)
+    (chr      . :char)
+    (int      . :int)
+    (uint     . :unsigned-int)
+    (lng      . :long)
+    (ulng     . :unsigned-long)
+    (sht      . :short)
+    (usht     . :unsigned-short)
+    (lng-lng  . :long-long)
+    (ulng-lng . :unsigned-long-long)
+    (flt      . :float)
+    (dbl      . :double)
+    (bool     . :boolean)
+    (ptr      . :pointer)
+    (charptr  . :pointer)))
diff --git a/Lisp/data-types.lisp b/Lisp/data-types.lisp
new file mode 100644
index 0000000..707c494
--- /dev/null
+++ b/Lisp/data-types.lisp
@@ -0,0 +1,97 @@
+(in-package #:mulk.objective-cl)
+
+
+;;;; (@* "Foreign data types")
+(defctype char-pointer :pointer)
+
+(defcunion obj-data-union
+  (id-val :pointer)
+  (class-val :pointer)
+  (exc-val :pointer)
+  (sel-val :pointer)
+  (char-val :char)
+  (short-val :short)
+  (int-val :int)
+  (long-val :long)
+  (long-long-val :long-long)
+  (float-val :float)
+  (double-val :double)
+  (bool-val :boolean)
+  (charptr-val :pointer)
+  (ptr-val :pointer))
+
+(defcstruct obj-data
+  (type char-pointer)
+  (data obj-data-union))
+
+(defmethod translate-to-foreign ((value string) (type (eql 'char-pointer)))
+  (foreign-string-alloc value))
+
+(defmethod translate-from-foreign (c-value (type (eql 'char-pointer)))
+  (foreign-string-to-lisp c-value))
+
+
+;;;; (@* "Objective C object wrapper classes")
+(defclass c-pointer-wrapper ()
+  ((pointer :type     c-pointer
+            :reader   pointer-to
+            :initarg  :pointer
+            :initform nil)))
+
+
+(defclass objc-selector (c-pointer-wrapper) ())
+(defclass objc-id       (c-pointer-wrapper) ())
+(defclass objc-class    (c-pointer-wrapper) ())
+
+
+(define-condition objc-exception (error)
+  ((pointer :type     c-pointer
+            :accessor pointer-to
+            :initarg  :pointer))
+  (:documentation "The condition type for Objective C exceptions.")
+  (:report (lambda (condition stream)
+             (format stream
+                     "The Objective C runtime has issued an exception of ~
+                      type `~A'.~&~
+                      Reason: ~A."
+                     (objcl-invoke-class-method
+                      (objcl-invoke-class-method condition "name")
+                      "UTF8String")
+                     (objcl-invoke-class-method
+                      (objcl-invoke-class-method condition "reason")
+                      "UTF8String")))))
+
+
+(defgeneric objcl-eql (obj1 obj2))
+(defmethod objcl-eql ((obj1 c-pointer-wrapper) (obj2 c-pointer-wrapper))
+  (pointer-eq (pointer-to obj1) (pointer-to obj2)))
+(defmethod objcl-eql (obj1 obj2)
+  (eql obj1 obj2))
+
+
+(defun dealloc-obj-data (obj-data)
+  (with-foreign-slots ((type data) obj-data obj-data)
+    (foreign-string-free type))
+  (foreign-free obj-data))
+
+
+(defmethod print-object ((object objc-id) stream)
+  (print-unreadable-object (object stream)
+    (format stream "~A `~A' {~X}"
+            (objcl-class-name
+             (objcl-invoke-class-method object "class"))
+            (objcl-invoke-class-method
+             (objcl-invoke-class-method object "description")
+             "UTF8String")
+            (objcl-invoke-class-method object "hash"))))
+
+
+(defmethod print-object ((object objc-class) stream)
+  (print-unreadable-object (object stream)
+    (format stream "OBJC-CLASS ~A"
+            (objcl-class-name object))))
+
+
+;;;; (@* "Convenience types")
+(deftype c-pointer ()
+  '(satisfies pointerp))
diff --git a/defpackage.lisp b/Lisp/defpackage.lisp
index ee40d1c..ee40d1c 100644
--- a/defpackage.lisp
+++ b/Lisp/defpackage.lisp
diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp
new file mode 100644
index 0000000..d735773
--- /dev/null
+++ b/Lisp/libobjcl.lisp
@@ -0,0 +1,63 @@
+(in-package #:mulk.objective-cl)
+
+
+(define-foreign-library libobjcl
+  (unix "/home/mulk/Dokumente/Projekte/Objective-CL/Objective-C/shared_obj/libobjcl.so"))
+
+(use-foreign-library libobjcl)
+
+
+(defcfun "objcl_initialise_runtime" :void)
+(defcfun "objcl_shutdown_runtime" :void)
+(defcfun ("objcl_invoke_instance_method"
+          %objcl-invoke-instance-method) obj-data
+  (receiver obj-data)
+  (method-name :string)
+  (argc :int)
+  &rest)
+
+(defcfun ("objcl_invoke_class_method"
+          %objcl-invoke-class-method) obj-data
+  (receiver obj-data)
+  (method-name :string)
+  (argc :int)
+  &rest)
+
+(defcfun ("objcl_find_class" %objcl-find-class) :pointer
+  (class-name :string))
+
+(defcfun ("objcl_class_name" %objcl-class-name) :string
+  (class obj-data))
+
+
+(defun objcl-find-class (class-name)
+  (let ((obj-data (%objcl-find-class class-name)))
+    (prog1
+        (if (null-pointer-p (foreign-slot-value
+                             (foreign-slot-value obj-data 'obj-data 'data)
+                             'obj-data-union
+                             'class-val))
+            nil
+            (obj-data->lisp obj-data))
+      (dealloc-obj-data obj-data))))
+
+
+(defun objcl-class-name (class)
+  (declare (type (or objc-class objc-id objc-exception) class))
+  (let ((obj-data (foreign-alloc 'obj-data)))
+    (with-foreign-slots ((type data) obj-data obj-data)
+      (setf (foreign-slot-value obj-data
+                                'obj-data-union
+                                (etypecase class
+                                  (objc-class     'class-val)
+                                  (objc-id        'id-val)
+                                  (objc-exception 'exc-val)))
+            (pointer-to class))
+      (setf type (foreign-string-alloc (etypecase class
+                                         (objc-class     "#")
+                                         (objc-id        "@")
+                                         (objc-exception "E")))))
+    (prog1
+        (%objcl-class-name obj-data)
+      (dealloc-obj-data obj-data))))
+
diff --git a/Lisp/memory-management.lisp b/Lisp/memory-management.lisp
new file mode 100644
index 0000000..4476957
--- /dev/null
+++ b/Lisp/memory-management.lisp
@@ -0,0 +1,93 @@
+(in-package #:mulk.objective-cl)
+
+
+(defvar *skip-finalization* nil)
+(defvar *skip-retaining*    nil)
+
+(defvar *id-objects* (make-weak-value-hash-table))
+(defvar *class-objects* (make-weak-value-hash-table))
+(defvar *exception-objects* (make-weak-value-hash-table))
+
+
+#+cmu
+(progn
+  (declaim (inline make-weak-value-hash-table))
+
+  (defun make-weak-value-hash-table ()
+    (make-hash-table :test 'eql))
+
+  (defun weak-gethash (key hash-table &optional (default nil))
+    (let ((pointer (gethash key hash-table default)))
+      (or (and (trivial-garbage:weak-pointer-p pointer)
+               (trivial-garbage:weak-pointer-value pointer))
+          (prog1 default
+            ;; Clean up.
+            (remhash key hash-table)))))
+
+  (defun (setf weak-gethash) (value key hash-table)
+    (setf (gethash key hash-table)
+          (trivial-garbage:make-weak-pointer value))))
+
+#-cmu
+(progn
+  (declaim (inline make-weak-value-hash-table))
+
+  (defun make-weak-value-hash-table ()
+    (trivial-garbage:make-weak-hash-table :weakness :value
+                                          :test 'eql))
+
+  (setf (fdefinition 'weak-gethash)        (fdefinition 'gethash)
+        (fdefinition '(setf weak-gethash)) (fdefinition '(setf gethash))))
+
+;; We call the `retain' method on every object that we receive from a
+;; method call or otherwise except non-convenience constructor methods
+;; (i.e. those whose name starts with `alloc' or `new').  Upon
+;; Lisp-side finalization of an object, wie `release' it.
+(eval-when (:load-toplevel)
+  (dolist (type '(objc-id objc-class objc-exception))
+    (funcall
+     (compile
+      nil
+      `(lambda ()
+         (defmethod make-instance ((class (eql ',type)) &rest initargs &key)
+           (let* ((hash-table ,(ecase type
+                                 ((objc-id)        '*id-objects*)
+                                 ((objc-class)     '*class-objects*)
+                                 ((objc-exception) '*exception-objects*)))
+                  (hash-key (pointer-address (getf initargs :pointer)))
+                  (obj (weak-gethash hash-key hash-table nil)))
+             (typecase obj
+               (keyword (assert (eq :incomplete obj))
+                        (call-next-method))
+               (null (setf (weak-gethash hash-key hash-table)
+                           :incomplete)
+                     (let ((new-obj (call-next-method)))
+                       (setf (weak-gethash hash-key hash-table) new-obj)
+                       (unless *skip-retaining*
+                         (objcl-invoke-class-method new-obj "retain"))
+                       (unless *skip-finalization*
+                         (assert (not (null (pointer-to new-obj))))
+                         (let ((saved-pointer (pointer-to new-obj))
+                               (saved-type    (type-of new-obj)))
+                           (flet ((finalizer ()
+                                    ;; In order to send the `release'
+                                    ;; message to the newly GC'd object,
+                                    ;; we have to create a temporary
+                                    ;; container object for the final
+                                    ;; message delivery.  Note that this
+                                    ;; can cause an infinite recursion
+                                    ;; or even memory corruption if we
+                                    ;; don't take measure to skip both
+                                    ;; finalization and retaining of the
+                                    ;; temporary object.
+                                    (let ((temp (let ((*skip-finalization* t)
+                                                      (*skip-retaining*    t))
+                                                  (make-instance saved-type
+                                                                 :pointer saved-pointer))))
+                                      (objcl-invoke-class-method temp "release"))))
+                             (trivial-garbage:finalize new-obj #'finalizer))))
+                       new-obj))
+               (t obj))))
+
+         (defmethod initialize-instance ((obj ,type) &key)
+           (call-next-method)))))))
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
new file mode 100644
index 0000000..ebd6fca
--- /dev/null
+++ b/Lisp/method-invocation.lisp
@@ -0,0 +1,96 @@
+(in-package #:mulk.objective-cl)
+
+
+;;; (@* "Method invocation")
+(defun objcl-invoke-class-method (receiver method-name &rest args)
+  (let* ((arglist (arglist-intersperse-types
+                   (mapcar #'lisp->obj-data args)))
+         (return-value (apply-macro '%objcl-invoke-class-method
+                                    (lisp->obj-data receiver)
+                                    method-name
+                                    (length args)
+                                    arglist)))
+    (format t "~&Invoking [~A].~%" method-name)
+    (unwind-protect
+         (let ((value
+                (let ((*skip-retaining* (or *skip-retaining*
+                                            (constructor-name-p method-name))))
+                  (obj-data->lisp return-value))))
+           (if (typep value 'condition)
+               (cerror "Return NIL from OBJCL-INVOKE-CLASS-METHOD" value)
+               value))
+      (dealloc-obj-data return-value))))
+
+
+#+nil
+(defun objcl-invoke-class-method (receiver method-name &rest args)
+  (let* ((arglist (arglist-intersperse-types
+                   (mapcar #'lisp->obj-data args)))
+         (return-value (apply-macro '%objcl-invoke-instance-method
+                                    (lisp->obj-data receiver)
+                                    method-name
+                                    (length args)
+                                    arglist)))
+    (format t "~&Invoking <~A>.~%" method-name)
+    (unwind-protect
+         (let ((value
+                (let ((*skip-retaining* (or *skip-retaining*
+                                            (constructor-name-p method-name))))
+                  (obj-data->lisp return-value))))
+           (if (typep value 'condition)
+               (cerror "Return NIL from OBJCL-INVOKE-INSTANCE-METHOD" value)
+               value))
+      (dealloc-obj-data return-value))))
+
+
+;;; (@* "Data conversion")
+(defun lisp->obj-data (value)
+  (let ((obj-data (foreign-alloc 'obj-data))
+        (type-name (lisp-value->type-name value)))
+    (with-foreign-slots ((type data) obj-data obj-data)
+      (setf (foreign-slot-value data
+                                'obj-data-union
+                                (type-name->slot-name type-name))
+            (typecase value
+              ((or objc-id objc-class objc-selector objc-exception)
+               (pointer-to value))
+              (string    (foreign-string-alloc value))
+              (otherwise value)))
+      (setf type
+            (foreign-string-alloc (type-name->type-id type-name))))
+    obj-data))
+
+
+(defun obj-data->lisp (obj-data)
+  (with-foreign-slots ((type data) obj-data obj-data)
+    (let* ((type-name (type-id->type-name (foreign-string-to-lisp type)))
+           (lisp-type (type-name->lisp-type type-name))
+           (value     (if (eq 'void type-name)
+                          (values)
+                          (foreign-slot-value data
+                                              'obj-data-union
+                                              (type-name->slot-name type-name)))))
+      (case lisp-type
+        ((objc-id objc-class objc-selector objc-exception)
+         (make-instance lisp-type :pointer value))
+        ((string)  (foreign-string-to-lisp value))
+        (otherwise value)))))
+
+
+;;; (@* "Helper functions")
+(defun arglist-intersperse-types (arglist)
+  (mapcan #'(lambda (arg)
+              (list :pointer arg))
+          arglist))
+
+
+(defun constructor-name-p (method-name)
+  (flet ((method-name-starts-with (prefix)
+           (and (>= (length method-name) (length prefix))
+                (or (and (string= prefix
+                                  (subseq method-name 0 (length prefix)))
+                         (or (= (length method-name)
+                                (length prefix))
+                             (not (lower-case-p (char method-name (length prefix))))))))))
+    (or (method-name-starts-with "alloc")
+        (method-name-starts-with "new"))))
diff --git a/Lisp/objcl.lisp b/Lisp/objcl.lisp
new file mode 100644
index 0000000..ec9b2e0
--- /dev/null
+++ b/Lisp/objcl.lisp
@@ -0,0 +1 @@
+(in-package #:mulk.objective-cl)
diff --git a/Lisp/reader-syntax.lisp b/Lisp/reader-syntax.lisp
new file mode 100644
index 0000000..4a1491f
--- /dev/null
+++ b/Lisp/reader-syntax.lisp
@@ -0,0 +1,61 @@
+(in-package #:mulk.objective-cl)
+
+
+(defun install-reader-syntax ()
+  (set-macro-character #\] (get-macro-character #\)))
+
+  (set-macro-character #\[ #'(lambda (stream char)
+                               (declare (ignore char))
+                               (parse-objc-call stream))))
+
+
+(defun parse-objc-call (stream)
+  (let ((*standard-input* stream))
+    (flet ((read-message-part (buffer)
+             (do ((char (read-char stream t nil t)
+                        (read-char stream t nil t)))
+                 ((not (or (alphanumericp char)
+                           (member char (coerce ":_-" 'list))))
+                  (unread-char char))
+               (vector-push-extend char buffer)))
+           (slurp-whitespace ()
+             (do ((char nil
+                        (read-char stream t nil t)))
+                 ((not (member (peek-char) '(#\Space #\Newline #\Tab)))))))
+      (let* ((class-method-p nil)
+             (receiver (if (upper-case-p (peek-char))
+                           ;; A class name.
+                           (let ((*readtable* (copy-readtable)))
+                             (setf class-method-p t)
+                             (setf (readtable-case *readtable*) :preserve)
+                             `(objcl-find-class
+                               ,(symbol-name (read stream t nil t))))
+                           ;; Something else.
+                           (read stream t nil t)))
+             (args (list))
+             (message (make-array '(0) :element-type 'character
+                                       :adjustable t :fill-pointer t)))
+
+        (slurp-whitespace)
+        (do ()
+            ((char= #\] (peek-char)))
+          (read-message-part message)
+          (slurp-whitespace)
+          (unless (char= #\] (peek-char))
+            (push (read stream t nil t) args)
+            (slurp-whitespace)))
+
+        ;; Slurp the trailing #\].
+        (assert (char= #\] (read-char)))
+        (setf args (nreverse args))
+        `(,(if class-method-p
+               'objcl-invoke-class-method
+               #+nil 'objcl-invoke-instance-method
+               #-nil 'objcl-invoke-class-method)
+           ,receiver
+           ,(make-array (list (length message))
+                        :element-type 'character
+                        :initial-contents message
+                        :adjustable nil
+                        :fill-pointer nil)
+           ,@args)))))
diff --git a/Lisp/utilities.lisp b/Lisp/utilities.lisp
new file mode 100644
index 0000000..f35a4d8
--- /dev/null
+++ b/Lisp/utilities.lisp
@@ -0,0 +1,10 @@
+(in-package #:mulk.objective-cl)
+
+
+(defun apply-macro (macro-name arg &rest args)
+  "Because FOREIGN-FUNCALL is a macro.  Why, oh why is this?"
+  (funcall
+   (compile nil
+            `(lambda ()
+               (,macro-name ,@(butlast (cons arg args))
+                            ,@(car (last (cons arg args))))))))
\ No newline at end of file
diff --git a/Lisp/weak-hash-tables.lisp b/Lisp/weak-hash-tables.lisp
new file mode 100644
index 0000000..6221d8a
--- /dev/null
+++ b/Lisp/weak-hash-tables.lisp
@@ -0,0 +1,33 @@
+(in-package #:mulk.objective-cl)
+
+
+#+cmu
+(progn
+  (declaim (inline make-weak-value-hash-table))
+
+  (defun make-weak-value-hash-table ()
+    (make-hash-table :test 'eql))
+
+  (defun weak-gethash (key hash-table &optional (default nil))
+    (let ((pointer (gethash key hash-table default)))
+      (or (and (trivial-garbage:weak-pointer-p pointer)
+               (trivial-garbage:weak-pointer-value pointer))
+          (prog1 default
+            ;; Clean up.
+            (remhash key hash-table)))))
+
+  (defun (setf weak-gethash) (value key hash-table)
+    (setf (gethash key hash-table)
+          (trivial-garbage:make-weak-pointer value))))
+
+
+#-cmu
+(progn
+  (declaim (inline make-weak-value-hash-table))
+
+  (defun make-weak-value-hash-table ()
+    (trivial-garbage:make-weak-hash-table :weakness :value
+                                          :test 'eql))
+
+  (setf (fdefinition 'weak-gethash)        (fdefinition 'gethash)
+        (fdefinition '(setf weak-gethash)) (fdefinition '(setf gethash))))
diff --git a/Objective-C/GNUmakefile b/Objective-C/GNUmakefile
new file mode 100644
index 0000000..231a78b
--- /dev/null
+++ b/Objective-C/GNUmakefile
@@ -0,0 +1,12 @@
+include $(GNUSTEP_MAKEFILES)/common.make
+
+include ../version.make
+
+LIBRARY_NAME = libobjcl
+
+RPM_DISABLE_RELOCATABLE = YES
+ADDITIONAL_OBJCFLAGS = -Wall -g -DVERSION=\"$(VERSION)\"
+libobjcl_OBJC_FILES = libobjcl.m
+LIBRARIES_DEPEND_UPON  =  $(FND_LIBS) $(GUI_LIBS) $(OBJC_LIBS) $(SYSTEM_LIBS) $(CONFIG_SYSTEM_LIBS)
+
+include $(GNUSTEP_MAKEFILES)/library.make
diff --git a/libobjcl.h b/Objective-C/libobjcl.h
index 4d6d092..4d6d092 100644
--- a/libobjcl.h
+++ b/Objective-C/libobjcl.h
diff --git a/libobjcl.m b/Objective-C/libobjcl.m
index 41d165c..41d165c 100644
--- a/libobjcl.m
+++ b/Objective-C/libobjcl.m
diff --git a/objcl.lisp b/objcl.lisp
deleted file mode 100644
index 44467e8..0000000
--- a/objcl.lisp
+++ /dev/null
@@ -1,521 +0,0 @@
-(in-package #:mulk.objective-cl)
-
-(define-foreign-library libobjcl
-  (unix "/home/mulk/Dokumente/Projekte/Objective-CL/shared_obj/libobjcl.so"))
-
-(use-foreign-library libobjcl)
-
-
-(deftype c-pointer ()
-  '(satisfies pointerp))
-
-
-(defctype char-pointer :pointer)
-
-(defmethod translate-to-foreign ((value string) (type (eql 'char-pointer)))
-  #+nil
-  (let ((buffer (foreign-alloc :char :count (length value))))
-    (cffi:lisp-string-to-foreign value buffer (length value))
-    buffer)
-  (foreign-string-alloc value))
-
-(defmethod translate-from-foreign (c-value (type (eql 'char-pointer)))
-  (foreign-string-to-lisp c-value))
-
-
-(defclass c-pointer-wrapper ()
-  ((pointer :type     c-pointer
-            :reader   pointer-to
-            :initarg  :pointer
-            :initform nil)))
-
-
-(defclass objc-selector (c-pointer-wrapper) ())
-(defclass objc-id       (c-pointer-wrapper) ())
-(defclass objc-class    (c-pointer-wrapper) ())
-
-(define-condition objc-exception (error)
-  ((pointer :type     c-pointer
-            :accessor pointer-to
-            :initarg  :pointer))
-  (:documentation "The condition type for Objective C exceptions.")
-  (:report (lambda (condition stream)
-             (format stream
-                     "The Objective C runtime has issued an exception of ~
-                      type `~A'.~&~
-                      Reason: ~A."
-                     (objcl-invoke-class-method
-                      (objcl-invoke-class-method condition "name")
-                      "UTF8String")
-                     (objcl-invoke-class-method
-                      (objcl-invoke-class-method condition "reason")
-                      "UTF8String")))))
-
-
-#+cmu
-(progn
-  (declaim (inline make-weak-value-hash-table))
-
-  (defun make-weak-value-hash-table ()
-    (make-hash-table :test 'eql))
-
-  (defun weak-gethash (key hash-table &optional (default nil))
-    (let ((pointer (gethash key hash-table default)))
-      (or (and (trivial-garbage:weak-pointer-p pointer)
-               (trivial-garbage:weak-pointer-value pointer))
-          (prog1 default
-            ;; Clean up.
-            (remhash key hash-table)))))
-
-  (defun (setf weak-gethash) (value key hash-table)
-    (setf (gethash key hash-table)
-          (trivial-garbage:make-weak-pointer value))))
-
-#-cmu
-(progn
-  (declaim (inline make-weak-value-hash-table))
-
-  (defun make-weak-value-hash-table ()
-    (trivial-garbage:make-weak-hash-table :weakness :value
-                                          :test 'eql))
-
-  (setf (fdefinition 'weak-gethash)        (fdefinition 'gethash)
-        (fdefinition '(setf weak-gethash)) (fdefinition '(setf gethash))))
-
-
-(defvar *skip-finalization* nil)
-(defvar *skip-retaining*    nil)
-
-(defvar *id-objects* (make-weak-value-hash-table))
-(defvar *class-objects* (make-weak-value-hash-table))
-(defvar *exception-objects* (make-weak-value-hash-table))
-
-;; We call the `retain' method on every object that we receive from a
-;; method call or otherwise except non-convenience constructor methods
-;; (i.e. those whose name starts with `alloc' or `new').  Upon
-;; Lisp-side finalization of an object, wie `release' it.
-(eval-when (:load-toplevel)
-  (dolist (type '(objc-id objc-class objc-exception))
-    (funcall
-     (compile
-      nil
-      `(lambda ()
-         (defmethod make-instance ((class (eql ',type)) &rest initargs &key)
-           (let* ((hash-table ,(ecase type
-                                 ((objc-id)        '*id-objects*)
-                                 ((objc-class)     '*class-objects*)
-                                 ((objc-exception) '*exception-objects*)))
-                  (hash-key (pointer-address (getf initargs :pointer)))
-                  (obj (weak-gethash hash-key hash-table nil)))
-             (typecase obj
-               (keyword (assert (eq :incomplete obj))
-                        (call-next-method))
-               (null (setf (weak-gethash hash-key hash-table)
-                           :incomplete)
-                     (let ((new-obj (call-next-method)))
-                       (setf (weak-gethash hash-key hash-table) new-obj)
-                       (unless *skip-retaining*
-                         (objcl-invoke-class-method new-obj "retain"))
-                       (unless *skip-finalization*
-                         (assert (not (null (pointer-to new-obj))))
-                         (let ((saved-pointer (pointer-to new-obj))
-                               (saved-type    (type-of new-obj)))
-                           (flet ((finalizer ()
-                                    ;; In order to send the `release'
-                                    ;; message to the newly GC'd object,
-                                    ;; we have to create a temporary
-                                    ;; container object for the final
-                                    ;; message delivery.  Note that this
-                                    ;; can cause an infinite recursion
-                                    ;; or even memory corruption if we
-                                    ;; don't take measure to skip both
-                                    ;; finalization and retaining of the
-                                    ;; temporary object.
-                                    (let ((temp (let ((*skip-finalization* t)
-                                                      (*skip-retaining*    t))
-                                                  (make-instance saved-type
-                                                                 :pointer saved-pointer))))
-                                      (objcl-invoke-class-method temp "release"))))
-                             (trivial-garbage:finalize new-obj #'finalizer))))
-                       new-obj))
-               (t obj))))
-
-         (defmethod initialize-instance ((obj ,type) &key)
-           (call-next-method)))))))
-
-
-(defgeneric objcl-eql (obj1 obj2))
-(defmethod objcl-eql ((obj1 c-pointer-wrapper) (obj2 c-pointer-wrapper))
-  (pointer-eq (pointer-to obj1) (pointer-to obj2)))
-(defmethod objcl-eql (obj1 obj2)
-  (eql obj1 obj2))
-
-
-(defcunion obj-data-union
-  (id-val :pointer)
-  (class-val :pointer)
-  (exc-val :pointer)
-  (sel-val :pointer)
-  (char-val :char)
-  (short-val :short)
-  (int-val :int)
-  (long-val :long)
-  (long-long-val :long-long)
-  (float-val :float)
-  (double-val :double)
-  (bool-val :boolean)
-  (charptr-val :pointer)
-  (ptr-val :pointer))
-
-
-(defcstruct obj-data
-  (type char-pointer)
-  (data obj-data-union))
-
-
-(defun dealloc-obj-data (obj-data)
-  (with-foreign-slots ((type data) obj-data obj-data)
-    (foreign-string-free type))
-  (foreign-free obj-data))
-
-
-(defcfun "objcl_initialise_runtime" :void)
-(defcfun "objcl_shutdown_runtime" :void)
-(defcfun ("objcl_invoke_instance_method"
-          %objcl-invoke-instance-method) obj-data
-  (receiver obj-data)
-  (method-name :string)
-  (argc :int)
-  &rest)
-
-(defcfun ("objcl_invoke_class_method"
-          %objcl-invoke-class-method) obj-data
-  (receiver obj-data)
-  (method-name :string)
-  (argc :int)
-  &rest)
-
-(defcfun ("objcl_find_class" %objcl-find-class) :pointer
-  (class-name :string))
-
-(defcfun ("objcl_class_name" %objcl-class-name) :string
-  (class obj-data))
-
-
-;;; Copied from objc-api.h
-;;; Probably ought to be generated by C code at initialisation time.
-(defparameter *objcl-api-type-names*
-  '((id       . #\@)
-    (class    . #\#)
-    (exc      . #\E)
-    (sel      . #\:)
-    (chr      . #\c)
-    (uchr     . #\C)
-    (sht      . #\s)
-    (usht     . #\S)
-    (int      . #\i)
-    (uint     . #\I)
-    (lng      . #\l)
-    (ulng     . #\L)
-    (lng-lng  . #\q)
-    (ulng-lng . #\Q)
-    (flt      . #\f)
-    (dbl      . #\d)
-    (bfld     . #\b)
-    (bool     . #\B)
-    (void     . #\v)
-    (undef    . #\?)
-    (ptr      . #\^)
-    (charptr  . #\*)
-    (atom     . #\%)
-    (ary-b    . #\[)
-    (ary-e    . #\])
-    (union-b  . #\()
-    (union-e  . #\))
-    (struct-b . #\{)
-    (struct-e . #\})
-    (vector   . #\!)
-    (complex  . #\j)))
-
-
-(defparameter *objcl-data-map*
-  '((id       . id-val)
-    (class    . class-val)
-    (exc      . exc-val)
-    (sel      . sel-val)
-    (chr      . char-val)
-    (uchr     . char-val)
-    (sht      . short-val)
-    (usht     . short-val)
-    (int      . int-val)
-    (uint     . int-val)
-    (lng      . long-val)
-    (ulng     . long-val)
-    (lng-lng  . long-long-val)
-    (ulng-lng . long-long-val)
-    (flt      . float-val)
-    (dbl      . double-val)
-    (bool     . bool-val)
-    (ptr      . ptr-val)
-    (charptr  . charptr-val)))
-
-
-(defparameter *objcl-type-map*
-  '((id       . objc-id)
-    (class    . objc-class)
-    (sel      . objc-selector)
-    (exc      . objc-exception)
-    (chr      . character)
-    (int      . integer)
-    (uint     . integer)
-    (lng      . integer)
-    (ulng     . integer)
-    (sht      . integer)
-    (usht     . integer)
-    (lng-lng  . integer)
-    (ulng-lng . integer)
-    (flt      . single-float)
-    (dbl      . double-float)
-    (bool     . boolean)
-    (ptr      . c-pointer)
-    (charptr  . string)))
-
-(defparameter *objcl-c-type-map*
-  '((id       . :pointer)
-    (class    . :pointer)
-    (sel      . :pointer)
-    (exc      . :pointer)
-    (chr      . :char)
-    (int      . :int)
-    (uint     . :unsigned-int)
-    (lng      . :long)
-    (ulng     . :unsigned-long)
-    (sht      . :short)
-    (usht     . :unsigned-short)
-    (lng-lng  . :long-long)
-    (ulng-lng . :unsigned-long-long)
-    (flt      . :float)
-    (dbl      . :double)
-    (bool     . :boolean)
-    (ptr      . :pointer)
-    (charptr  . :pointer)))
-
-
-(defun apply-macro (macro-name arg &rest args)
-  "Because FOREIGN-FUNCALL is a macro.  Why, oh why is this?"
-  (funcall
-   (compile nil
-            `(lambda ()
-               (,macro-name ,@(butlast (cons arg args))
-                            ,@(car (last (cons arg args))))))))
-
-
-(defun lisp-value->type-name (value)
-  (car (rassoc-if #'(lambda (type)
-                      (typep value type))
-                  *objcl-type-map*)))
-
-(defun type-name->lisp-type (type-name)
-  (cdr (assoc type-name *objcl-type-map*)))
-
-(defun type-name->slot-name (type-name)
-  (cdr (assoc type-name *objcl-data-map*)))
-
-(defun type-name->type-id (type-name)
-  (string (cdr (assoc type-name *objcl-api-type-names*))))
-
-(defun type-id->type-name (type-id)
-  (car (rassoc (char type-id 0) *objcl-api-type-names*)))
-
-(defun type-name->c-type (type-name)
-  (cdr (assoc type-name *objcl-c-type-map*)))
-
-(defun arglist-intersperse-types (arglist)
-  (mapcan #'(lambda (arg)
-              (list :pointer arg))
-          arglist))
-
-
-#+nil
-(defun objcl-invoke-instance-method (receiver method-name &rest args)
-  (let* ((arglist (arglist-intersperse-types
-                   (mapcar #'lisp->obj-data args)))
-         (return-value (apply-macro '%objcl-invoke-instance-method
-                                    (lisp->obj-data receiver)
-                                    method-name
-                                    (length args)
-                                    arglist)))
-    (prog1
-        (obj-data->lisp return-value)
-      (dealloc-obj-data return-value))))
-
-
-(defun constructor-name-p (method-name)
-  (flet ((method-name-starts-with (prefix)
-           (and (>= (length method-name) (length prefix))
-                (or (and (string= prefix
-                                  (subseq method-name 0 (length prefix)))
-                         (or (= (length method-name)
-                                (length prefix))
-                             (not (lower-case-p (char method-name (length prefix))))))))))
-    (or (method-name-starts-with "alloc")
-        (method-name-starts-with "new"))))
-
-
-(defun objcl-invoke-class-method (class method-name &rest args)
-  (let* ((arglist (arglist-intersperse-types
-                   (mapcar #'lisp->obj-data args)))
-         (return-value (apply-macro '%objcl-invoke-class-method
-                                    (lisp->obj-data class)
-                                    method-name
-                                    (length args)
-                                    arglist)))
-    (unwind-protect
-         (let ((value
-                (let ((*skip-retaining* (or *skip-retaining*
-                                            (constructor-name-p method-name))))
-                  (obj-data->lisp return-value))))
-           (if (typep value 'condition)
-               (cerror "Return NIL from OBJCL-INVOKE-CLASS-METHOD" value)
-               value))
-      (dealloc-obj-data return-value))))
-
-
-(defun lisp->obj-data (value)
-  (let ((obj-data (foreign-alloc 'obj-data))
-        (type-name (lisp-value->type-name value)))
-    (with-foreign-slots ((type data) obj-data obj-data)
-      (setf (foreign-slot-value data
-                                'obj-data-union
-                                (type-name->slot-name type-name))
-            (typecase value
-              ((or objc-id objc-class objc-selector objc-exception)
-               (pointer-to value))
-              (string    (foreign-string-alloc value))
-              (otherwise value)))
-      (setf type
-            (foreign-string-alloc (type-name->type-id type-name))))
-    obj-data))
-
-
-(defun obj-data->lisp (obj-data)
-  (with-foreign-slots ((type data) obj-data obj-data)
-    (let* ((type-name (type-id->type-name (foreign-string-to-lisp type)))
-           (lisp-type (type-name->lisp-type type-name))
-           (value     (if (eq 'void type-name)
-                          (values)
-                          (foreign-slot-value data
-                                              'obj-data-union
-                                              (type-name->slot-name type-name)))))
-      (case lisp-type
-        ((objc-id objc-class objc-selector objc-exception)
-         (make-instance lisp-type :pointer value))
-        ((string)  (foreign-string-to-lisp value))
-        (otherwise value)))))
-
-
-(defun objcl-find-class (class-name)
-  (let ((obj-data (%objcl-find-class class-name)))
-    (prog1
-        (if (null-pointer-p (foreign-slot-value
-                             (foreign-slot-value obj-data 'obj-data 'data)
-                             'obj-data-union
-                             'class-val))
-            nil
-            (obj-data->lisp obj-data))
-      (dealloc-obj-data obj-data))))
-
-
-(defun objcl-class-name (class)
-  (declare (type (or objc-class objc-id objc-exception) class))
-  (let ((obj-data (foreign-alloc 'obj-data)))
-    (with-foreign-slots ((type data) obj-data obj-data)
-      (setf (foreign-slot-value obj-data
-                                'obj-data-union
-                                (etypecase class
-                                  (objc-class     'class-val)
-                                  (objc-id        'id-val)
-                                  (objc-exception 'exc-val)))
-            (pointer-to class))
-      (setf type (foreign-string-alloc (etypecase class
-                                         (objc-class     "#")
-                                         (objc-id        "@")
-                                         (objc-exception "E")))))
-    (prog1
-        (%objcl-class-name obj-data)
-      (dealloc-obj-data obj-data))))
-
-
-(defmethod print-object ((object objc-id) stream)
-  (print-unreadable-object (object stream)
-    (format stream "~A `~A' {~X}"
-            (objcl-class-name
-             (objcl-invoke-class-method object "class"))
-            (objcl-invoke-class-method
-             (objcl-invoke-class-method object "description")
-             "UTF8String")
-            (objcl-invoke-class-method object "hash"))))
-
-
-(defmethod print-object ((object objc-class) stream)
-  (print-unreadable-object (object stream)
-    (format stream "OBJC-CLASS ~A"
-            (objcl-class-name object))))
-
-
-(set-macro-character #\] (get-macro-character #\)))
-
-(set-macro-character #\[ #'(lambda (stream char)
-                             (declare (ignore char))
-                             (parse-objc-call stream)))
-
-(defun parse-objc-call (stream)
-  (let ((*standard-input* stream))
-    (flet ((read-message-part (buffer)
-             (do ((char (read-char stream t nil t)
-                        (read-char stream t nil t)))
-                 ((not (or (alphanumericp char)
-                           (member char (coerce ":_-" 'list))))
-                  (unread-char char))
-               (vector-push-extend char buffer)))
-           (slurp-whitespace ()
-             (do ((char nil
-                        (read-char stream t nil t)))
-                 ((not (member (peek-char) '(#\Space #\Newline #\Tab)))))))
-      (let* ((class-method-p nil)
-             (receiver (if (upper-case-p (peek-char))
-                           ;; A class name.
-                           (let ((*readtable* (copy-readtable)))
-                             (setf class-method-p t)
-                             (setf (readtable-case *readtable*) :preserve)
-                             `(objcl-find-class
-                               ,(symbol-name (read stream t nil t))))
-                           ;; Something else.
-                           (read stream t nil t)))
-             (args (list))
-             (message (make-array '(0) :element-type 'character
-                                       :adjustable t :fill-pointer t)))
-
-        (slurp-whitespace)
-        (do ()
-            ((char= #\] (peek-char)))
-          (read-message-part message)
-          (slurp-whitespace)
-          (unless (char= #\] (peek-char))
-            (push (read stream t nil t) args)
-            (slurp-whitespace)))
-
-        ;; Slurp the trailing #\].
-        (assert (char= #\] (read-char)))
-        (setf args (nreverse args))
-        `(,(if class-method-p
-               'objcl-invoke-class-method
-               #+nil 'objcl-invoke-instance-method
-               #-nil 'objcl-invoke-class-method)
-           ,receiver
-           ,(make-array (list (length message))
-                        :element-type 'character
-                        :initial-contents message
-                        :adjustable nil
-                        :fill-pointer nil)
-           ,@args)))))
diff --git a/objective-cl.asd b/objective-cl.asd
index 4abaff2..b3f7f8a 100644
--- a/objective-cl.asd
+++ b/objective-cl.asd
@@ -5,5 +5,13 @@
   :licence "GNU General Public License, version 3 or higher"
   :depends-on (#:cffi #:trivial-garbage)
   :components ((:file "defpackage")
+               (:file "constant-data")
+               (:file "data-types")
+               (:file "libobjcl")
+               (:file "utilities")
+               (:file "weak-hash-tables")
+               (:file "memory-management")
+               (:file "method-invocation")
+               (:file "reader-syntax")
                (:file "objcl"))
   :serial t)
diff --git a/version.make b/version.make
new file mode 100644
index 0000000..a12428f
--- /dev/null
+++ b/version.make
@@ -0,0 +1,2 @@
+# -*- coding: utf-8; mode: makefile -*-
+VERSION = 0.0.1