summaryrefslogtreecommitdiff
path: root/Lisp
diff options
context:
space:
mode:
Diffstat (limited to 'Lisp')
-rw-r--r--Lisp/constant-data.lisp123
-rw-r--r--Lisp/data-types.lisp97
-rw-r--r--Lisp/defpackage.lisp3
-rw-r--r--Lisp/libobjcl.lisp63
-rw-r--r--Lisp/memory-management.lisp93
-rw-r--r--Lisp/method-invocation.lisp96
-rw-r--r--Lisp/objcl.lisp1
-rw-r--r--Lisp/reader-syntax.lisp61
-rw-r--r--Lisp/utilities.lisp10
-rw-r--r--Lisp/weak-hash-tables.lisp33
10 files changed, 580 insertions, 0 deletions
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/Lisp/defpackage.lisp b/Lisp/defpackage.lisp
new file mode 100644
index 0000000..ee40d1c
--- /dev/null
+++ b/Lisp/defpackage.lisp
@@ -0,0 +1,3 @@
+(defpackage #:mulk.objective-cl
+ (:nicknames #:objcl)
+ (:use #:cl #:cffi))
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))))