From 9db618bedb91bccb935f025f45094fd20ec754ef Mon Sep 17 00:00:00 2001 From: Matthias Benkard Date: Fri, 14 Sep 2007 16:56:39 +0200 Subject: Code reorganisation. darcs-hash:be8c8af8504b2ce63cde33a893542d3590abd703 --- Lisp/libobjcl.lisp | 418 +++++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 325 insertions(+), 93 deletions(-) (limited to 'Lisp/libobjcl.lisp') diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp index 176423c..bf80c30 100644 --- a/Lisp/libobjcl.lisp +++ b/Lisp/libobjcl.lisp @@ -1,26 +1,58 @@ (in-package #:mulk.objective-cl) -(pushnew - (merge-pathnames (make-pathname :directory '(:relative "Objective-C" - "shared_obj") - :type "" - :name "") - (asdf:component-pathname (asdf:find-system - '#:objective-cl))) - cffi:*foreign-library-directories*) +(dolist (subdir '("shared_obj" "obj")) + (pushnew + (merge-pathnames (make-pathname :directory (list + :relative "Objective-C" subdir) + :type "" + :name "") + (asdf:component-pathname (asdf:find-system + '#:objective-cl))) + cffi:*foreign-library-directories*)) (define-foreign-library libobjcl (:unix (:or "libobjcl.so" - "libobjcl.so.0")) + "libobjcl.so.0" + "libobjcl.dylib" + "libobjcl.dylib.0")) (t (:default "libobjcl"))) (use-foreign-library libobjcl) -(defcfun ("objcl_initialise_runtime" initialise-runtime) :void) -(setf (documentation #'initialise-runtime 'function) - "Initialise the Objective C runtime. +(defcfun ("objcl_initialise_runtime" %initialise-runtime) :void) + +(defcfun ("objcl_shutdown_runtime" %shutdown-runtime) :void) + +(defcfun ("objcl_invoke_method" + %objcl-invoke-method) obj-data + (receiver obj-data) + (method-selector obj-data) + (argc :int) + &rest) + +(defcfun ("objcl_find_class" %objcl-find-class) :pointer + (class-name :string)) + +(defcfun ("objcl_class_name" %objcl-class-name) :pointer + (class obj-data)) + +(defcfun ("objcl_find_selector" %objcl-find-selector) :pointer + (selector-name :string)) + +(defcfun ("objcl_selector_name" %objcl-selector-name) :pointer + (selector obj-data)) + +(defcfun ("objcl_get_method_implementation" + %objcl-get-method-implementation) + :pointer + (object obj-data) + (selector obj-data)) + + +(defun initialise-runtime () + "Initialise the Objective C runtime. ## Description: @@ -41,12 +73,15 @@ before making any other Objective C calls. ## See also: - __shutdown-runtime__") + __shutdown-runtime__" + (when (zerop *runtime-initialisation-level*) + (%initialise-runtime)) + (atomically (incf *runtime-initialisation-level*))) -(defcfun ("objcl_shutdown_runtime" shutdown-runtime) :void) -(setf (documentation #'shutdown-runtime 'function) - "Shut the Objective C runtime down. + +(defun shutdown-runtime () + "Shut the Objective C runtime down. ## Description: @@ -64,33 +99,10 @@ objects or classes, let alone send messages to them. ## See also: - __initialise-runtime__") - - -(defcfun ("objcl_invoke_method" - %objcl-invoke-method) obj-data - (receiver obj-data) - (method-selector obj-data) - (argc :int) - &rest) - -(defcfun ("objcl_find_class" %objcl-find-class) :pointer - (class-name :string)) - -(defcfun ("objcl_class_name" %objcl-class-name) :pointer - (class obj-data)) - -(defcfun ("objcl_find_selector" %objcl-find-selector) :pointer - (selector-name :string)) - -(defcfun ("objcl_selector_name" %objcl-selector-name) :pointer - (selector obj-data)) + __initialise-runtime__" -(defcfun ("objcl_get_method_implementation" - %objcl-get-method-implementation) - :pointer - (object obj-data) - (selector obj-data)) + (when (zerop (atomically (decf *runtime-initialisation-level*))) + (%shutdown-runtime))) (declaim (ftype (function ((or string symbol) &optional t) @@ -208,57 +220,6 @@ conventional case for namespace identifiers in Objective C." (%objcl-get-method-implementation obj-obj-data sel-obj-data))) -(declaim (ftype (function ((or selector string list)) selector) - selector)) -(defun selector (designator) - "Convert an object into a selector. - -## Arguments and Values: - -*designator* --- a *selector designator*. - - -## Description: - -*selector-designator* must be a valid *selector designator*, that is: -either a __selector__ object or one of a **symbol**, a **string**, or a -**list** of **symbol**s representing a __selector__. - -If *selector-designator* is a **string** or a **list** of **symbol**s, -__find-selector__ is called and the value returned, except that if -__find-selector__ returns __nil__, an **error** is **signal**ed. - -If *selector-designator* is a single **symbol**, it is treated as if it -were a **list** whose **car** is the **symbol** and whose **cdr** is -__nil__. - -If *selector-designator* is a __selector__, it is simply returned. - - -## Examples: - - (selector \"self\") ;=> # - (selector '(self)) ;=> # - (selector 'self) ;=> # - (selector *) ;=> # - - (selector 'selph) ; error - - (selector \"stringWithCString:encoding:\") - ;=> # - - (selector '(:string-with-c-string :encoding)) - ;=> #" - - (etypecase designator - (selector designator) - (symbol (selector (list designator))) - ((or string list) - (or (find-selector designator) - (error "Could not find the selector designated by ~S." - designator))))) - - (declaim (ftype (function ((or selector string list)) (or null selector)) find-selector)) (defun find-selector (selector-name) @@ -314,3 +275,274 @@ by which __invoke__ converts its arguments into a *message name*. (string (find-selector-by-name selector-name)) (list (find-selector-by-name (symbol-list->message-name selector-name))))) + + +;;; (@* "Low-level Data Conversion") +(eval-when (:compile-toplevel :load-toplevel) + ;; In order to be able to dispatch over pointer types, we need to + ;; define an alias of the implementation's own pointer class. Note + ;; that this may be T (in GNU CLISP, for example), so it's a good idea + ;; to use CHECK-TYPE in the method body. + (unless (find-class 'foreign-pointer nil) + (setf (find-class 'foreign-pointer nil) + (class-of (make-pointer 0)))) + (deftype foreign-pointer () + '(satisfies cffi:pointerp))) + + +(declaim (ftype (function ((or selector string list)) selector) + selector)) +(defun selector (designator) + "Convert an object into a selector. + +## Arguments and Values: + +*designator* --- a *selector designator*. + + +## Description: + +*selector-designator* must be a valid *selector designator*, that is: +either a __selector__ object or one of a **symbol**, a **string**, or a +**list** of **symbol**s representing a __selector__. + +If *selector-designator* is a **string** or a **list** of **symbol**s, +__find-selector__ is called and the value returned, except that if +__find-selector__ returns __nil__, an **error** is **signal**ed. + +If *selector-designator* is a single **symbol**, it is treated as if it +were a **list** whose **car** is the **symbol** and whose **cdr** is +__nil__. + +If *selector-designator* is a __selector__, it is simply returned. + + +## Examples: + + (selector \"self\") ;=> # + (selector '(self)) ;=> # + (selector 'self) ;=> # + (selector *) ;=> # + + (selector 'selph) ; error + + (selector \"stringWithCString:encoding:\") + ;=> # + + (selector '(:string-with-c-string :encoding)) + ;=> #" + + (etypecase designator + (selector designator) + (symbol (selector (list designator))) + ((or string list) + (or (find-selector designator) + (error "Could not find the selector designated by ~S." + designator))))) + + +(declaim (ftype (function (*) + (values foreign-pointer &rest nil)) + lisp->obj-data)) +(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 + (symbol (selector value)) + ((or id objc-class selector exception) + (pointer-to value)) + (string (foreign-string-alloc value)) + (otherwise value))) + (setf type + (foreign-string-alloc (type-name->type-id type-name)))) + obj-data)) + + +(declaim (ftype (function (foreign-pointer) + (values (or number string symbol selector id + objc-class boolean foreign-pointer) + &rest nil)) + obj-data->lisp)) +(defun obj-data->lisp (obj-data) + (with-foreign-slots ((type data) obj-data obj-data) + (let* ((type-name (type-id->type-name (if (stringp type) + type + (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 + ((id objc-class selector exception) + (make-instance lisp-type :pointer value)) + ((string) (foreign-string-to-lisp value)) + (otherwise value))))) + + +(declaim (ftype (function (foreign-pointer) (values string &rest nil)) + foreign-string-to-lisp/dealloc)) +(defun foreign-string-to-lisp/dealloc (foreign-string) + "Convert a (possibly freshly allocated) C string into a Lisp string +and free the C string afterwards." + + (unwind-protect + (foreign-string-to-lisp foreign-string) + (foreign-string-free foreign-string))) + + +(defun parse-typespec (typestring &optional (start 0)) + "Parse a typestring like \"@0:4{_NSRange=II}8\" into something like (ID ()). + +\"rn{_NSRange=II}8\" is parsed into (STRUCT (CONST IN) +\"_NSRange\" :INTEGER :INTEGER). + +Returns: (VALUES typespec byte-position string-position)" + + (let ((init-char (char typestring start)) + (string-position start) + (qualifiers (list))) + (loop do (setq init-char (char typestring string-position)) + while (let ((qualifier (case init-char + (#\r 'const) + (#\n 'in) + (#\N 'inout) + (#\o 'out) + (#\O 'bycopy) + (#\V 'oneway) + (#\R 'byref)))) + (and qualifier + (incf string-position) + (push qualifier qualifiers)))) + (values (case init-char + ((#\{ #\() + (let* ((=-token (position #\= typestring :start start)) + (name-end (or =-token + ;; An opaque struct whose contents + ;; we don't know. + (position (ecase init-char + (#\{ #\}) + (#\( #\))) + typestring + :start start) + (error "Premature end of file in~ + typespec: ~A." + typestring))) + (struct-name (subseq typestring + (1+ string-position) + name-end))) + (list* (ecase init-char + (#\{ 'struct) + (#\( 'union)) + (if =-token + qualifiers + (cons 'opaque qualifiers)) + struct-name + (progn + (setq string-position + (if =-token + (1+ name-end) ; skip #\= + name-end)) + (loop until (char= (char typestring string-position) + (ecase init-char + (#\{ #\}) + (#\( #\)))) + collect (multiple-value-bind (typespec + byte-position + new-string-pos) + (parse-typespec + typestring + string-position) + (declare (ignore byte-position)) + (setq string-position new-string-pos) + typespec) + ;; Skip end marker (right brace/paren). + finally (incf string-position)))))) + (#\^ (list 'pointer + qualifiers + (multiple-value-bind (typespec byte-pos new-str-pos) + (parse-typespec typestring (1+ string-position)) + (declare (ignore byte-pos)) + (prog1 typespec + (setq string-position new-str-pos))))) + (#\[ (list 'array + qualifiers + (multiple-value-bind (count new-str-pos) + (parse-integer typestring + :start (1+ string-position) + :junk-allowed t) + (prog1 count + (setq string-position new-str-pos))) + (multiple-value-bind (typespec byte-pos new-str-pos) + (parse-typespec typestring string-position) + (declare (ignore byte-pos)) + ;; Skip end marker (right bracket). + (prog1 typespec + (setq string-position (1+ new-str-pos)))))) + (#\j + (list 'complex + qualifiers + (multiple-value-bind (typespec byte-pos new-str-pos) + (parse-typespec typestring (1+ string-position)) + (declare (ignore byte-pos)) + (prog1 typespec + (setq string-position new-str-pos))))) + (#\b + (let (bit-field-starting-pos + bit-field-typespec + bit-field-length + byte-position) + (multiple-value-setq (bit-field-starting-pos string-position) + (parse-integer typestring + :start (1+ string-position) + :junk-allowed t)) + (multiple-value-setq (bit-field-typespec + byte-position + string-position) + (parse-typespec typestring string-position)) + (multiple-value-setq (bit-field-length string-position) + (parse-integer typestring + :start string-position + :junk-allowed t)) + (list 'bit-field + qualifiers + bit-field-starting-pos + bit-field-length + bit-field-typespec))) + (otherwise + (prog1 (list (case init-char + (#\B :boolean) + (#\c :char) + (#\C :unsigned-char) + (#\s :short) + (#\S :unsigned-short) + (#\i :int) + (#\I :unsigned-int) + (#\l :long) + (#\L :unsigned-long) + (#\q :long-long) + (#\Q :unsigned-long-long) + (#\f :float) + (#\d :double) + (#\v :void) + (#\@ 'id) + (#\# 'objc-class) + (#\: 'selector) + (#\* :string) + (#\? :unknown)) + qualifiers) + (incf string-position)))) + #+(or) ; too greedy (=> bit-fields can't see their length!) + (multiple-value-bind (byte-position new-string-pos) + (parse-integer typestring + :start string-position + :junk-allowed t) + (setq string-position new-string-pos) + byte-position) + #-(or) nil + string-position))) -- cgit v1.2.3