From 4765624c39dffb085554b1459b3e80bcbf347791 Mon Sep 17 00:00:00 2001 From: Matthias Benkard Date: Sat, 4 Aug 2007 15:01:53 +0200 Subject: Refactor directory and source file layout. darcs-hash:0eb031a60f3b86a678869960867410811ca5325c --- GNUmakefile | 11 +- Lisp/constant-data.lisp | 123 +++++++++++ Lisp/data-types.lisp | 97 +++++++++ Lisp/defpackage.lisp | 3 + Lisp/libobjcl.lisp | 63 ++++++ Lisp/memory-management.lisp | 93 ++++++++ Lisp/method-invocation.lisp | 96 ++++++++ Lisp/objcl.lisp | 1 + Lisp/reader-syntax.lisp | 61 ++++++ Lisp/utilities.lisp | 10 + Lisp/weak-hash-tables.lisp | 33 +++ Objective-C/GNUmakefile | 12 + Objective-C/libobjcl.h | 62 ++++++ Objective-C/libobjcl.m | 295 +++++++++++++++++++++++++ defpackage.lisp | 3 - libobjcl.h | 62 ------ libobjcl.m | 295 ------------------------- objcl.lisp | 521 -------------------------------------------- objective-cl.asd | 8 + version.make | 2 + 20 files changed, 964 insertions(+), 887 deletions(-) create mode 100644 Lisp/constant-data.lisp create mode 100644 Lisp/data-types.lisp create mode 100644 Lisp/defpackage.lisp create mode 100644 Lisp/libobjcl.lisp create mode 100644 Lisp/memory-management.lisp create mode 100644 Lisp/method-invocation.lisp create mode 100644 Lisp/objcl.lisp create mode 100644 Lisp/reader-syntax.lisp create mode 100644 Lisp/utilities.lisp create mode 100644 Lisp/weak-hash-tables.lisp create mode 100644 Objective-C/GNUmakefile create mode 100644 Objective-C/libobjcl.h create mode 100644 Objective-C/libobjcl.m delete mode 100644 defpackage.lisp delete mode 100644 libobjcl.h delete mode 100644 libobjcl.m delete mode 100644 objcl.lisp create mode 100644 version.make 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/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)))) 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/Objective-C/libobjcl.h b/Objective-C/libobjcl.h new file mode 100644 index 0000000..4d6d092 --- /dev/null +++ b/Objective-C/libobjcl.h @@ -0,0 +1,62 @@ +/* -*- mode: objc; coding: utf-8 -*- */ + +#import "Foundation/Foundation.h" +#include + +typedef struct objcl_object +{ + char* type; + + union + { + id id_val; + Class class_val; + NSException *exc_val; + SEL sel_val; + char char_val; + short short_val; + int int_val; + long long_val; + long long long_long_val; + float float_val; + double double_val; + BOOL bool_val; + char *charptr_val; + void *ptr_val; + } data; +} *OBJCL_OBJ_DATA; + + +#define EXCEPTION_TYPESPEC "ERROR" + + +void +objcl_initialise_runtime (void); + +void +objcl_shutdown_runtime (void); + +void * +objcl_invoke_instance_method (OBJCL_OBJ_DATA receiver, + const char *method_name, + int argc, + ...); + +void * +objcl_invoke_class_method (OBJCL_OBJ_DATA class, + const char *method_name, + int argc, + ...); + +void * +objcl_find_class (const char *class_name); + +/* Return a null-terminated list of type information strings. + The first entry describes the type of the method's return value. */ +char ** +objcl_query_arglist_info (void *receiver, + const char *method_name); + + +const char * +objcl_class_name (OBJCL_OBJ_DATA class); diff --git a/Objective-C/libobjcl.m b/Objective-C/libobjcl.m new file mode 100644 index 0000000..41d165c --- /dev/null +++ b/Objective-C/libobjcl.m @@ -0,0 +1,295 @@ +/* -*- mode: objc; coding: utf-8 -*- */ + +#import "libobjcl.h" +#import "Foundation/Foundation.h" +#include +#include + + +static NSAutoreleasePool *objcl_autorelease_pool = NULL; + + +void +objcl_initialise_runtime () +{ + objcl_autorelease_pool = [[NSAutoreleasePool alloc] init]; +} + + +void +objcl_shutdown_runtime () +{ + [objcl_autorelease_pool release]; +} + + +#define _OBJCL_ARG_CASE(typespec, field_name) \ + case typespec: \ + memmove (buffer, &argdata->data.field_name##_val, \ + objc_sizeof_type (argdata->type)); \ + break; + + +static void +_objcl_get_arg_pointer (void *buffer, OBJCL_OBJ_DATA argdata) +{ + switch (argdata->type[0]) + { + _OBJCL_ARG_CASE(_C_ID, id); + _OBJCL_ARG_CASE(_C_CLASS, id); + _OBJCL_ARG_CASE(_C_SEL, sel); + _OBJCL_ARG_CASE(_C_CHR, char); + _OBJCL_ARG_CASE(_C_UCHR, char); + _OBJCL_ARG_CASE(_C_SHT, short); + _OBJCL_ARG_CASE(_C_USHT, short); + _OBJCL_ARG_CASE(_C_INT, int); + _OBJCL_ARG_CASE(_C_UINT, int); + _OBJCL_ARG_CASE(_C_LNG, long); + _OBJCL_ARG_CASE(_C_ULNG, long); + _OBJCL_ARG_CASE(_C_LNG_LNG, long_long); + _OBJCL_ARG_CASE(_C_ULNG_LNG, long_long); + _OBJCL_ARG_CASE(_C_FLT, float); + _OBJCL_ARG_CASE(_C_DBL, double); + _OBJCL_ARG_CASE(_C_BOOL, bool); + _OBJCL_ARG_CASE(_C_PTR, ptr); + _OBJCL_ARG_CASE(_C_CHARPTR, charptr); +/* + _OBJCL_ARG_CASE(_C_VOID, void); + _OBJCL_ARG_CASE(_C_BFLD, bitfield); + _OBJCL_ARG_CASE(_C_ATOM, atom); + _OBJCL_ARG_CASE(_C_ARY_B, ); + _OBJCL_ARG_CASE(_C_UNION_B, ); + _OBJCL_ARG_CASE(_C_STRUCT_B, ); + _OBJCL_ARG_CASE(_C_VECTOR, ); + _OBJCL_ARG_CASE(_C_COMPLEX, ); +*/ + case _C_UNDEF: + default: + NSLog (@"Dammit. What the heck is `%s' supposed to mean?", + argdata->type); + break; + } +} + + +static void +_objcl_invoke_method (id self_, + OBJCL_OBJ_DATA result, + NSMethodSignature *signature, + SEL selector, + int argc, + va_list arglist) +{ + int i; + NSInvocation *invocation; + void *result_ptr = NULL; + const char *type = [signature methodReturnType]; + + result->type = malloc (strlen (type) + 1); + strcpy (result->type, type); + + if (signature == NULL) + { + [[NSException exceptionWithName: @"MLKNoSignatureFoundException" + reason: @"No signature found" + userInfo: NULL] raise]; + } + + + switch (type[0]) + { + case _C_ID: result_ptr = &(result->data.id_val); break; + case _C_CLASS: result_ptr = &result->data.id_val; break; + case _C_SEL: result_ptr = &result->data.sel_val; break; + case _C_CHR: result_ptr = &result->data.char_val; break; + case _C_UCHR: result_ptr = &result->data.char_val; break; + case _C_SHT: result_ptr = &result->data.short_val; break; + case _C_USHT: result_ptr = &result->data.short_val; break; + case _C_INT: result_ptr = &result->data.int_val; break; + case _C_UINT: result_ptr = &result->data.int_val; break; + case _C_LNG: result_ptr = &result->data.long_val; break; + case _C_ULNG: result_ptr = &result->data.long_val; break; + case _C_LNG_LNG: result_ptr = &result->data.long_long_val; break; + case _C_ULNG_LNG: result_ptr = &result->data.long_long_val; break; + case _C_FLT: result_ptr = &result->data.float_val; break; + case _C_DBL: result_ptr = &result->data.double_val; break; + case _C_BOOL: result_ptr = &result->data.bool_val; break; + case _C_PTR: result_ptr = &result->data.ptr_val; break; + case _C_CHARPTR: result_ptr = &result->data.charptr_val; break; + /* + case _C_BFLD: result_ptr = &result->data._val; break; + case _C_VOID: result_ptr = &result->data._val; break; + case _C_UNDEF: result_ptr = &result->data._val; break; + case _C_ATOM: result_ptr = &result->data._val; break; + case _C_ARY_B: result_ptr = &result->data._val; break; + case _C_ARY_E: result_ptr = &result->data._val; break; + case _C_UNION_B: result_ptr = &result->data._val; break; + case _C_UNION_E: result_ptr = &result->data._val; break; + case _C_STRUCT_B: result_ptr = &result->data._val; break; + case _C_STRUCT_E: result_ptr = &result->data._val; break; + case _C_VECTOR: result_ptr = &result->data._val; break; + case _C_COMPLEX: result_ptr = &result->data._val; break; + */ + } + + invocation = [NSInvocation invocationWithMethodSignature: signature]; + [invocation setTarget: self_]; + [invocation setSelector: selector]; + + for (i = 0; i < argc; i++) + { + const char* type = [signature getArgumentTypeAtIndex: (i + 2)]; + void *buffer = malloc (objc_sizeof_type (type)); + OBJCL_OBJ_DATA arg = va_arg (arglist, OBJCL_OBJ_DATA); + _objcl_get_arg_pointer (buffer, arg); + + if (type[0] == '#') + NSLog (@"Argument %d: %@ (type %s)", i, buffer, type); + else + NSLog (@"Argument %d: type %s.", i, type); + + [invocation setArgument: buffer + atIndex: (i + 2)]; + + free (buffer); + } + + [invocation retainArguments]; + NSLog (@"Invoking %@ on %@.", invocation, self_); + [invocation invoke]; + NSLog (@"Fetching return value."); + [invocation getReturnValue: result_ptr]; + if (result->type[0] == '#') + NSLog (@"Returning: %@", result->data.id_val); +} + + +void * +objcl_invoke_instance_method (OBJCL_OBJ_DATA receiver, + const char *method_name, + int argc, + ...) +{ + va_list arglist; + id self_ = NULL; + SEL selector; + NSMethodSignature *signature; + OBJCL_OBJ_DATA result = malloc (sizeof (struct objcl_object)); + + NS_DURING + { + /* fprintf (stderr, "! ---------> %s <--------\n", receiver->type); */ + assert (receiver->type[0] == '#' + || receiver->type[0] == '@' + || receiver->type[0] == 'E'); + switch (receiver->type[0]) + { + case '#': self_ = receiver->data.class_val; + case '@': self_ = receiver->data.id_val; + case 'E': self_ = receiver->data.exc_val; + } + + selector = NSSelectorFromString ([NSString + stringWithUTF8String: method_name]); + + signature = [self_ instanceMethodSignatureForSelector: selector]; + + va_start (arglist, argc); + _objcl_invoke_method (self_, result, signature, selector, argc, arglist); + va_end (arglist); + } + NS_HANDLER + { + result->type = malloc (strlen (EXCEPTION_TYPESPEC) + 1); + strcpy (result->type, EXCEPTION_TYPESPEC); + result->data.exc_val = localException; + NS_VALUERETURN (result, void *); + } + NS_ENDHANDLER + + return result; +} + + +void * +objcl_invoke_class_method (OBJCL_OBJ_DATA class, + const char *method_name, + int argc, + ...) +{ + va_list arglist; + id self_ = NULL; + SEL selector; + NSMethodSignature *signature; + OBJCL_OBJ_DATA result = malloc (sizeof (struct objcl_object)); + + NS_DURING + { + /* fprintf (stderr, "? ---------> %s <--------\n", class->type); */ + assert (class->type[0] == '#' + || class->type[0] == '@' + || class->type[0] == 'E'); + switch (class->type[0]) + { + case '#': self_ = class->data.class_val; + case '@': self_ = class->data.id_val; + case 'E': self_ = class->data.exc_val; + } + + selector = NSSelectorFromString ([NSString + stringWithUTF8String: method_name]); + + signature = [self_ methodSignatureForSelector: selector]; + + va_start (arglist, argc); + _objcl_invoke_method (self_, result, signature, selector, argc, arglist); + va_end (arglist); + } + NS_HANDLER + { + result->type = malloc (strlen (EXCEPTION_TYPESPEC) + 1); + strcpy (result->type, EXCEPTION_TYPESPEC); + result->data.exc_val = localException; + NS_VALUERETURN (result, void *); + } + NS_ENDHANDLER + + return result; +} + + +void * +objcl_find_class (const char *class_name) +{ + Class class = + NSClassFromString ([NSString stringWithUTF8String: class_name]); + OBJCL_OBJ_DATA result = malloc (sizeof (struct objcl_object)); + const char *const typespec = "#8@0:4"; + + result->type = malloc (strlen (typespec) + 1); + strcpy (result->type, typespec); + result->data.class_val = class; + + return result; +} + + +const char * +objcl_class_name (OBJCL_OBJ_DATA class) +{ + Class cls = NULL; + + /* fprintf (stderr, "---------> %s <--------\n", class->type); */ + fflush (stderr); + assert (class->type[0] == '#' + || class->type[0] == '@' + || class->type[0] == 'E'); + switch (class->type[0]) + { + case '#': cls = class->data.class_val; + case '@': cls = class->data.id_val; + case 'E': cls = (id) class->data.exc_val; + } + + return class_get_class_name (cls); +} diff --git a/defpackage.lisp b/defpackage.lisp deleted file mode 100644 index ee40d1c..0000000 --- a/defpackage.lisp +++ /dev/null @@ -1,3 +0,0 @@ -(defpackage #:mulk.objective-cl - (:nicknames #:objcl) - (:use #:cl #:cffi)) diff --git a/libobjcl.h b/libobjcl.h deleted file mode 100644 index 4d6d092..0000000 --- a/libobjcl.h +++ /dev/null @@ -1,62 +0,0 @@ -/* -*- mode: objc; coding: utf-8 -*- */ - -#import "Foundation/Foundation.h" -#include - -typedef struct objcl_object -{ - char* type; - - union - { - id id_val; - Class class_val; - NSException *exc_val; - SEL sel_val; - char char_val; - short short_val; - int int_val; - long long_val; - long long long_long_val; - float float_val; - double double_val; - BOOL bool_val; - char *charptr_val; - void *ptr_val; - } data; -} *OBJCL_OBJ_DATA; - - -#define EXCEPTION_TYPESPEC "ERROR" - - -void -objcl_initialise_runtime (void); - -void -objcl_shutdown_runtime (void); - -void * -objcl_invoke_instance_method (OBJCL_OBJ_DATA receiver, - const char *method_name, - int argc, - ...); - -void * -objcl_invoke_class_method (OBJCL_OBJ_DATA class, - const char *method_name, - int argc, - ...); - -void * -objcl_find_class (const char *class_name); - -/* Return a null-terminated list of type information strings. - The first entry describes the type of the method's return value. */ -char ** -objcl_query_arglist_info (void *receiver, - const char *method_name); - - -const char * -objcl_class_name (OBJCL_OBJ_DATA class); diff --git a/libobjcl.m b/libobjcl.m deleted file mode 100644 index 41d165c..0000000 --- a/libobjcl.m +++ /dev/null @@ -1,295 +0,0 @@ -/* -*- mode: objc; coding: utf-8 -*- */ - -#import "libobjcl.h" -#import "Foundation/Foundation.h" -#include -#include - - -static NSAutoreleasePool *objcl_autorelease_pool = NULL; - - -void -objcl_initialise_runtime () -{ - objcl_autorelease_pool = [[NSAutoreleasePool alloc] init]; -} - - -void -objcl_shutdown_runtime () -{ - [objcl_autorelease_pool release]; -} - - -#define _OBJCL_ARG_CASE(typespec, field_name) \ - case typespec: \ - memmove (buffer, &argdata->data.field_name##_val, \ - objc_sizeof_type (argdata->type)); \ - break; - - -static void -_objcl_get_arg_pointer (void *buffer, OBJCL_OBJ_DATA argdata) -{ - switch (argdata->type[0]) - { - _OBJCL_ARG_CASE(_C_ID, id); - _OBJCL_ARG_CASE(_C_CLASS, id); - _OBJCL_ARG_CASE(_C_SEL, sel); - _OBJCL_ARG_CASE(_C_CHR, char); - _OBJCL_ARG_CASE(_C_UCHR, char); - _OBJCL_ARG_CASE(_C_SHT, short); - _OBJCL_ARG_CASE(_C_USHT, short); - _OBJCL_ARG_CASE(_C_INT, int); - _OBJCL_ARG_CASE(_C_UINT, int); - _OBJCL_ARG_CASE(_C_LNG, long); - _OBJCL_ARG_CASE(_C_ULNG, long); - _OBJCL_ARG_CASE(_C_LNG_LNG, long_long); - _OBJCL_ARG_CASE(_C_ULNG_LNG, long_long); - _OBJCL_ARG_CASE(_C_FLT, float); - _OBJCL_ARG_CASE(_C_DBL, double); - _OBJCL_ARG_CASE(_C_BOOL, bool); - _OBJCL_ARG_CASE(_C_PTR, ptr); - _OBJCL_ARG_CASE(_C_CHARPTR, charptr); -/* - _OBJCL_ARG_CASE(_C_VOID, void); - _OBJCL_ARG_CASE(_C_BFLD, bitfield); - _OBJCL_ARG_CASE(_C_ATOM, atom); - _OBJCL_ARG_CASE(_C_ARY_B, ); - _OBJCL_ARG_CASE(_C_UNION_B, ); - _OBJCL_ARG_CASE(_C_STRUCT_B, ); - _OBJCL_ARG_CASE(_C_VECTOR, ); - _OBJCL_ARG_CASE(_C_COMPLEX, ); -*/ - case _C_UNDEF: - default: - NSLog (@"Dammit. What the heck is `%s' supposed to mean?", - argdata->type); - break; - } -} - - -static void -_objcl_invoke_method (id self_, - OBJCL_OBJ_DATA result, - NSMethodSignature *signature, - SEL selector, - int argc, - va_list arglist) -{ - int i; - NSInvocation *invocation; - void *result_ptr = NULL; - const char *type = [signature methodReturnType]; - - result->type = malloc (strlen (type) + 1); - strcpy (result->type, type); - - if (signature == NULL) - { - [[NSException exceptionWithName: @"MLKNoSignatureFoundException" - reason: @"No signature found" - userInfo: NULL] raise]; - } - - - switch (type[0]) - { - case _C_ID: result_ptr = &(result->data.id_val); break; - case _C_CLASS: result_ptr = &result->data.id_val; break; - case _C_SEL: result_ptr = &result->data.sel_val; break; - case _C_CHR: result_ptr = &result->data.char_val; break; - case _C_UCHR: result_ptr = &result->data.char_val; break; - case _C_SHT: result_ptr = &result->data.short_val; break; - case _C_USHT: result_ptr = &result->data.short_val; break; - case _C_INT: result_ptr = &result->data.int_val; break; - case _C_UINT: result_ptr = &result->data.int_val; break; - case _C_LNG: result_ptr = &result->data.long_val; break; - case _C_ULNG: result_ptr = &result->data.long_val; break; - case _C_LNG_LNG: result_ptr = &result->data.long_long_val; break; - case _C_ULNG_LNG: result_ptr = &result->data.long_long_val; break; - case _C_FLT: result_ptr = &result->data.float_val; break; - case _C_DBL: result_ptr = &result->data.double_val; break; - case _C_BOOL: result_ptr = &result->data.bool_val; break; - case _C_PTR: result_ptr = &result->data.ptr_val; break; - case _C_CHARPTR: result_ptr = &result->data.charptr_val; break; - /* - case _C_BFLD: result_ptr = &result->data._val; break; - case _C_VOID: result_ptr = &result->data._val; break; - case _C_UNDEF: result_ptr = &result->data._val; break; - case _C_ATOM: result_ptr = &result->data._val; break; - case _C_ARY_B: result_ptr = &result->data._val; break; - case _C_ARY_E: result_ptr = &result->data._val; break; - case _C_UNION_B: result_ptr = &result->data._val; break; - case _C_UNION_E: result_ptr = &result->data._val; break; - case _C_STRUCT_B: result_ptr = &result->data._val; break; - case _C_STRUCT_E: result_ptr = &result->data._val; break; - case _C_VECTOR: result_ptr = &result->data._val; break; - case _C_COMPLEX: result_ptr = &result->data._val; break; - */ - } - - invocation = [NSInvocation invocationWithMethodSignature: signature]; - [invocation setTarget: self_]; - [invocation setSelector: selector]; - - for (i = 0; i < argc; i++) - { - const char* type = [signature getArgumentTypeAtIndex: (i + 2)]; - void *buffer = malloc (objc_sizeof_type (type)); - OBJCL_OBJ_DATA arg = va_arg (arglist, OBJCL_OBJ_DATA); - _objcl_get_arg_pointer (buffer, arg); - - if (type[0] == '#') - NSLog (@"Argument %d: %@ (type %s)", i, buffer, type); - else - NSLog (@"Argument %d: type %s.", i, type); - - [invocation setArgument: buffer - atIndex: (i + 2)]; - - free (buffer); - } - - [invocation retainArguments]; - NSLog (@"Invoking %@ on %@.", invocation, self_); - [invocation invoke]; - NSLog (@"Fetching return value."); - [invocation getReturnValue: result_ptr]; - if (result->type[0] == '#') - NSLog (@"Returning: %@", result->data.id_val); -} - - -void * -objcl_invoke_instance_method (OBJCL_OBJ_DATA receiver, - const char *method_name, - int argc, - ...) -{ - va_list arglist; - id self_ = NULL; - SEL selector; - NSMethodSignature *signature; - OBJCL_OBJ_DATA result = malloc (sizeof (struct objcl_object)); - - NS_DURING - { - /* fprintf (stderr, "! ---------> %s <--------\n", receiver->type); */ - assert (receiver->type[0] == '#' - || receiver->type[0] == '@' - || receiver->type[0] == 'E'); - switch (receiver->type[0]) - { - case '#': self_ = receiver->data.class_val; - case '@': self_ = receiver->data.id_val; - case 'E': self_ = receiver->data.exc_val; - } - - selector = NSSelectorFromString ([NSString - stringWithUTF8String: method_name]); - - signature = [self_ instanceMethodSignatureForSelector: selector]; - - va_start (arglist, argc); - _objcl_invoke_method (self_, result, signature, selector, argc, arglist); - va_end (arglist); - } - NS_HANDLER - { - result->type = malloc (strlen (EXCEPTION_TYPESPEC) + 1); - strcpy (result->type, EXCEPTION_TYPESPEC); - result->data.exc_val = localException; - NS_VALUERETURN (result, void *); - } - NS_ENDHANDLER - - return result; -} - - -void * -objcl_invoke_class_method (OBJCL_OBJ_DATA class, - const char *method_name, - int argc, - ...) -{ - va_list arglist; - id self_ = NULL; - SEL selector; - NSMethodSignature *signature; - OBJCL_OBJ_DATA result = malloc (sizeof (struct objcl_object)); - - NS_DURING - { - /* fprintf (stderr, "? ---------> %s <--------\n", class->type); */ - assert (class->type[0] == '#' - || class->type[0] == '@' - || class->type[0] == 'E'); - switch (class->type[0]) - { - case '#': self_ = class->data.class_val; - case '@': self_ = class->data.id_val; - case 'E': self_ = class->data.exc_val; - } - - selector = NSSelectorFromString ([NSString - stringWithUTF8String: method_name]); - - signature = [self_ methodSignatureForSelector: selector]; - - va_start (arglist, argc); - _objcl_invoke_method (self_, result, signature, selector, argc, arglist); - va_end (arglist); - } - NS_HANDLER - { - result->type = malloc (strlen (EXCEPTION_TYPESPEC) + 1); - strcpy (result->type, EXCEPTION_TYPESPEC); - result->data.exc_val = localException; - NS_VALUERETURN (result, void *); - } - NS_ENDHANDLER - - return result; -} - - -void * -objcl_find_class (const char *class_name) -{ - Class class = - NSClassFromString ([NSString stringWithUTF8String: class_name]); - OBJCL_OBJ_DATA result = malloc (sizeof (struct objcl_object)); - const char *const typespec = "#8@0:4"; - - result->type = malloc (strlen (typespec) + 1); - strcpy (result->type, typespec); - result->data.class_val = class; - - return result; -} - - -const char * -objcl_class_name (OBJCL_OBJ_DATA class) -{ - Class cls = NULL; - - /* fprintf (stderr, "---------> %s <--------\n", class->type); */ - fflush (stderr); - assert (class->type[0] == '#' - || class->type[0] == '@' - || class->type[0] == 'E'); - switch (class->type[0]) - { - case '#': cls = class->data.class_val; - case '@': cls = class->data.id_val; - case 'E': cls = (id) class->data.exc_val; - } - - return class_get_class_name (cls); -} 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 -- cgit v1.2.3