diff options
Diffstat (limited to 'Lisp')
| -rw-r--r-- | Lisp/constant-data.lisp | 123 | ||||
| -rw-r--r-- | Lisp/data-types.lisp | 97 | ||||
| -rw-r--r-- | Lisp/defpackage.lisp | 3 | ||||
| -rw-r--r-- | Lisp/libobjcl.lisp | 63 | ||||
| -rw-r--r-- | Lisp/memory-management.lisp | 93 | ||||
| -rw-r--r-- | Lisp/method-invocation.lisp | 96 | ||||
| -rw-r--r-- | Lisp/objcl.lisp | 1 | ||||
| -rw-r--r-- | Lisp/reader-syntax.lisp | 61 | ||||
| -rw-r--r-- | Lisp/utilities.lisp | 10 | ||||
| -rw-r--r-- | Lisp/weak-hash-tables.lisp | 33 |
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)))) |