Define an external interface, properly document FIND-OBJC-CLASS.

darcs-hash:2e4424a65b72a13e3cfa26d07dce945bc35ba8e1

7 files changed, 104 insertions, 23 deletions

diff --git a/Lisp/data-types.lisp b/Lisp/data-types.lisp
index 707c494..847b599 100644
--- a/Lisp/data-types.lisp
+++ b/Lisp/data-types.lisp
@@ -54,11 +54,11 @@
                      "The Objective C runtime has issued an exception of ~
                       type `~A'.~&~
                       Reason: ~A."
-                     (objcl-invoke-class-method
-                      (objcl-invoke-class-method condition "name")
+                     (invoke-by-name
+                      (invoke-by-name condition "name")
                       "UTF8String")
-                     (objcl-invoke-class-method
-                      (objcl-invoke-class-method condition "reason")
+                     (invoke-by-name
+                      (invoke-by-name condition "reason")
                       "UTF8String")))))
 
 
@@ -79,11 +79,11 @@
   (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")
+             (invoke-by-name object "class"))
+            (invoke-by-name
+             (invoke-by-name object "description")
              "UTF8String")
-            (objcl-invoke-class-method object "hash"))))
+            (invoke-by-name object "hash"))))
 
 
 (defmethod print-object ((object objc-class) stream)
diff --git a/Lisp/defpackage.lisp b/Lisp/defpackage.lisp
index ee40d1c..3047087 100644
--- a/Lisp/defpackage.lisp
+++ b/Lisp/defpackage.lisp
@@ -1,3 +1,10 @@
 (defpackage #:mulk.objective-cl
   (:nicknames #:objcl)
-  (:use #:cl #:cffi))
+  (:use #:cl #:cffi #:split-sequence)
+  (:export #:initialise-runtime
+           #:shutdown-runtime
+           #:install-reader-syntax
+           #:invoke-by-name
+           #:invoke
+           #:find-objc-class
+           #:*trace-method-calls*))
diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp
index d735773..a7171b4 100644
--- a/Lisp/libobjcl.lisp
+++ b/Lisp/libobjcl.lisp
@@ -7,8 +7,10 @@
 (use-foreign-library libobjcl)
 
 
-(defcfun "objcl_initialise_runtime" :void)
-(defcfun "objcl_shutdown_runtime" :void)
+(defcfun ("objcl_initialise_runtime" initialise-runtime) :void)
+
+(defcfun ("objcl_shutdown_runtime" shutdown-runtime) :void)
+
 (defcfun ("objcl_invoke_instance_method"
           %objcl-invoke-instance-method) obj-data
   (receiver obj-data)
@@ -30,7 +32,67 @@
   (class obj-data))
 
 
-(defun objcl-find-class (class-name)
+(defun symbol->objc-class-name (symbol)
+  (let ((components (split-sequence #\- (symbol-name symbol)
+                                    :remove-empty-subseqs t)))
+    (reduce #'(lambda (x y) (concatenate 'string x y))
+            (mapcar #'(lambda (x)
+                        (concatenate 'string
+                                     (string (char x 0))
+                                     (string-downcase (subseq x 1))))
+                    (subseq components 1))
+            :initial-value (concatenate 'string
+                                        (string (char (first components) 0))
+                                        (string-upcase
+                                         (subseq (first components) 1))))))
+
+
+(defun find-objc-class (class-name)
+  "Retrieve an Objective C class by name.
+
+CLASS-NAME: a symbol or a string.
+
+Returns: an OBJC-CLASS object representing the class whose name is
+CLASS-NAME.
+
+
+If CLASS-NAME is a symbol which does not contain a hyphen, its symbol
+name is converted to lower case except for the first letter, which is
+left intact, and the resulting string used as if directly given as an
+argument to FIND-OBJC-CLASS.
+
+If CLASS-NAME is a symbol which containts a hyphen, its symbol name is
+split into components seperated by hyphens and each component is
+converted into a string according to the following rules:
+
+ 1. The first component is fully converted to upper case except for its
+ first letter, which is left intact.
+
+ 2. Any additional components have all of their letters converted to
+ lower case, except for their first letters, which are left intact.
+
+After this, the components are concatenated in order and the resulting
+string used as if directly given as an argument to FIND-OBJC-CLASS.
+
+Examples:
+
+ (find-objc-class \"NSObject\")   ;=> #<OBJC-CLASS NSObject>
+ (find-objc-class 'ns-object)     ;=> #<OBJC-CLASS NSObject>
+ (find-objc-class 'nsobject)      ;=> NIL
+
+Rationale:
+
+The first component of an Objective C class name is conventionally
+thought of as a namespace identifier.  It is therefore sensible to
+expect it to be converted to upper case by default, which is the
+conventional case for namespace identifiers in Objective C."
+
+  (typecase class-name
+    (string (find-objc-class-by-name class-name))
+    (symbol (find-objc-class-by-name (symbol->objc-class-name class-name)))))
+
+
+(defun find-objc-class-by-name (class-name)
   (let ((obj-data (%objcl-find-class class-name)))
     (prog1
         (if (null-pointer-p (foreign-slot-value
diff --git a/Lisp/memory-management.lisp b/Lisp/memory-management.lisp
index 1c540fb..600e079 100644
--- a/Lisp/memory-management.lisp
+++ b/Lisp/memory-management.lisp
@@ -1,9 +1,6 @@
 (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))
@@ -63,7 +60,7 @@
                            :incomplete)
                      (let ((new-obj (call-next-method)))
                        (unless *skip-retaining*
-                         (objcl-invoke-class-method new-obj "retain"))
+                         (invoke-by-name new-obj "retain"))
                        (unless *skip-finalization*
                          ;; We only put the new object into the hash
                          ;; table if it is a regular wrapper object
@@ -89,7 +86,7 @@
                                                       (*skip-retaining*    t))
                                                   (make-instance saved-type
                                                                  :pointer saved-pointer))))
-                                      (objcl-invoke-class-method temp "release"))))
+                                      (invoke-by-name temp "release"))))
                              (trivial-garbage:finalize new-obj #'finalizer))))
                        new-obj))
                (t obj))))
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index 3cc927b..63f3e24 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -2,7 +2,15 @@
 
 
 ;;; (@* "Method invocation")
-(defun objcl-invoke-class-method (receiver method-name &rest args)
+(defun invoke (receiver message-start &rest message-components)
+  "FIXME"
+  (flet ((message-component->string (component)
+           ()))
+  (do ((message-string ())))))
+
+
+(defun invoke-by-name (receiver method-name &rest args)
+  "FIXME"
   (let* ((arglist (arglist-intersperse-types
                    (mapcar #'lisp->obj-data args)))
          (return-value (apply-macro '%objcl-invoke-class-method
@@ -10,7 +18,8 @@
                                     method-name
                                     (length args)
                                     arglist)))
-    (format t "~&Invoking [~A].~%" method-name)
+    (when *trace-method-calls*
+      (format t "~&Invoking [~A].~%" method-name))
     (unwind-protect
          (let ((value
                 (let ((*skip-retaining* (or *skip-retaining*
@@ -23,7 +32,7 @@
 
 
 #+nil
-(defun objcl-invoke-class-method (receiver method-name &rest args)
+(defun invoke-instance-method-by-name (receiver method-name &rest args)
   (let* ((arglist (arglist-intersperse-types
                    (mapcar #'lisp->obj-data args)))
          (return-value (apply-macro '%objcl-invoke-instance-method
diff --git a/Lisp/parameters.lisp b/Lisp/parameters.lisp
new file mode 100644
index 0000000..2cb5a6d
--- /dev/null
+++ b/Lisp/parameters.lisp
@@ -0,0 +1,6 @@
+(in-package #:mulk.objective-cl)
+
+
+(defvar *skip-finalization*  nil)
+(defvar *skip-retaining*     nil)
+(defvar *trace-method-calls* nil)
diff --git a/Lisp/reader-syntax.lisp b/Lisp/reader-syntax.lisp
index 4a1491f..3ca143b 100644
--- a/Lisp/reader-syntax.lisp
+++ b/Lisp/reader-syntax.lisp
@@ -28,7 +28,7 @@
                            (let ((*readtable* (copy-readtable)))
                              (setf class-method-p t)
                              (setf (readtable-case *readtable*) :preserve)
-                             `(objcl-find-class
+                             `(find-objc-class
                                ,(symbol-name (read stream t nil t))))
                            ;; Something else.
                            (read stream t nil t)))
@@ -49,9 +49,9 @@
         (assert (char= #\] (read-char)))
         (setf args (nreverse args))
         `(,(if class-method-p
-               'objcl-invoke-class-method
+               'invoke-by-name
                #+nil 'objcl-invoke-instance-method
-               #-nil 'objcl-invoke-class-method)
+               #-nil 'invoke-by-name)
            ,receiver
            ,(make-array (list (length message))
                         :element-type 'character