diff options
| -rw-r--r-- | Lisp/class-definition.lisp | 20 | ||||
| -rw-r--r-- | Lisp/constant-data.lisp | 2 | ||||
| -rw-r--r-- | Lisp/data-types.lisp | 6 | ||||
| -rw-r--r-- | Lisp/defpackage.lisp | 5 | ||||
| -rw-r--r-- | Lisp/libobjcl.lisp | 28 | ||||
| -rw-r--r-- | Lisp/memory-management.lisp | 6 | ||||
| -rw-r--r-- | Lisp/method-invocation.lisp | 15 | ||||
| -rw-r--r-- | Lisp/name-conversion.lisp | 37 | ||||
| -rw-r--r-- | Lisp/tests.lisp | 6 | ||||
| -rw-r--r-- | Lisp/type-handling.lisp | 2 | ||||
| -rw-r--r-- | Lisp/utilities.lisp | 16 | ||||
| -rw-r--r-- | objective-cl.asd | 3 |
12 files changed, 98 insertions, 48 deletions
diff --git a/Lisp/class-definition.lisp b/Lisp/class-definition.lisp index 3da1ec2..ea77362 100644 --- a/Lisp/class-definition.lisp +++ b/Lisp/class-definition.lisp @@ -39,11 +39,6 @@ (foreign-slot-definition-mixin c2mop:standard-effective-slot-definition) ()) -(defclass objective-c-class (standard-class) - ((class-ptr :initarg :class-ptr - :type c-pointer - :accessor pointer-to))) - (defmethod c2mop:direct-slot-definition-class ((class objective-c-class) &rest initargs) @@ -82,6 +77,15 @@ (cerror "FIXME" '())))) +(defmethod c2mop:slot-boundp-using-class ((class objective-c-class) + instance + effective-slot-definition) + (declare (ignore instance)) + (etypecase effective-slot-definition + (standard-effective-slot-definition (call-next-method)) + (foreign-effective-slot-definition t))) + + (defmethod c2mop:compute-slots ((class objective-c-class)) ;; FIXME: Maybe add lots of foreign slots here whose presence the ;; Objective-C runtime tells us. @@ -93,7 +97,6 @@ (let ((class (call-next-method))) class)) -#+(or) (defmethod initialize-instance ((class objective-c-class) &key documentation name @@ -101,11 +104,10 @@ direct-superclasses direct-slots direct-default-initargs - class-ptr + pointer wrapped-foreign-class) (call-next-method)) -#+(or) (defmethod reinitialize-instance ((class objective-c-class) &key documentation name @@ -113,7 +115,7 @@ direct-superclasses direct-slots direct-default-initargs - class-ptr + pointer wrapped-foreign-class) (call-next-method)) diff --git a/Lisp/constant-data.lisp b/Lisp/constant-data.lisp index c4e8393..85b5584 100644 --- a/Lisp/constant-data.lisp +++ b/Lisp/constant-data.lisp @@ -74,7 +74,7 @@ (defparameter *objcl-type-map* '((id . id) - (class . objc-class) + (class . objective-c-class) (sel . selector) (exc . exception) (chr . character) diff --git a/Lisp/data-types.lisp b/Lisp/data-types.lisp index bc66bf3..1f33af6 100644 --- a/Lisp/data-types.lisp +++ b/Lisp/data-types.lisp @@ -89,12 +89,12 @@ a suitable class method instead as you would in Objective-C. __invoke__, __invoke-by-name__, __exception__")) -(defclass objc-class (c-pointer-wrapper) () - (:documentation "")) +(defclass objective-c-class (standard-class c-pointer-wrapper) + ()) (defclass objc-meta-class (c-pointer-wrapper) - ((meta-class-for-class :type (or null id objc-class) + ((meta-class-for-class :type (or null id objective-c-class) :initarg :meta-class-for-class :reader meta-class-for-class)) (:documentation "")) diff --git a/Lisp/defpackage.lisp b/Lisp/defpackage.lisp index d7156d0..0543ed5 100644 --- a/Lisp/defpackage.lisp +++ b/Lisp/defpackage.lisp @@ -68,4 +68,9 @@ #:next-runtime)) +(defpackage #:objective-c-classes + (:nicknames #:objc-classes) + (:use)) + + #-(or cmu sbcl) (declaim (declaration values)) diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp index 752dcf4..dd4ec88 100644 --- a/Lisp/libobjcl.lisp +++ b/Lisp/libobjcl.lisp @@ -158,7 +158,7 @@ objects or classes, let alone send messages to them. (declaim (ftype (function ((or string symbol) &optional t) - (or null objc-class)) + (or null objective-c-class)) find-objc-class)) (defun find-objc-class (class-name &optional errorp) "Retrieve an Objective-C class by name. @@ -224,16 +224,18 @@ conventional case for namespace identifiers in Objective-C." nil)))) -(declaim (ftype (function (string) (or null objc-class)) +(declaim (ftype (function (string) (or null objective-c-class)) find-objc-class-by-name)) -(defun find-objc-class-by-name (class-name) - (let ((class-ptr (%objcl-find-class class-name))) +(defun find-objc-class-by-name (class-name-string) + (let ((class-ptr (%objcl-find-class class-name-string))) (if (objc-pointer-null class-ptr) nil - #-(or t openmcl) (make-pointer-wrapper 'objc-class :pointer class-ptr) - #+(and nil openmcl) (change-class (make-pointer-wrapper 'c-pointer-wrapper - :pointer value) - 'objc-class)))) + (let ((class-name (objc-class-name->symbol class-name-string))) + (or (find-class class-name nil) + (c2mop:ensure-class class-name + :metaclass 'objective-c-class + :pointer class-ptr + :wrapped-foreign-class class-name-string)))))) (defun find-objc-meta-class (meta-class-name &optional errorp) @@ -279,7 +281,7 @@ conventional case for namespace identifiers in Objective-C." (make-pointer-wrapper 'selector :pointer selector-ptr))) -(declaim (ftype (function ((or objc-class id exception)) string) +(declaim (ftype (function ((or objective-c-class id exception)) string) objc-class-name)) (defun objc-class-name (class) "Find the name of a class. @@ -315,7 +317,7 @@ If *name* is the name of an existing class: ## See Also: __find-objc-class__" - (declare (type (or objc-class id exception) class)) + (declare (type (or objective-c-class id exception) class)) (%objcl-class-name (pointer-to class))) @@ -359,7 +361,7 @@ If *name* is the name of an existing selector: (%objcl-selector-name (pointer-to selector))) -(declaim (ftype (function ((or id objc-class exception) selector) t) +(declaim (ftype (function ((or id objective-c-class exception) selector) t) get-method-implementation)) (defun get-method-implementation (object selector) (declare (type selector selector)) @@ -563,8 +565,8 @@ separating parts by hyphens works nicely in all of the `:INVERT`, (%objcl-object-is-meta-class (pointer-to obj))) (defun object-get-class (obj) - (make-pointer-wrapper 'objc-class - :pointer (%objcl-object-get-class (pointer-to obj)))) + (find-objc-class-by-name + (%objcl-class-name (%objcl-object-get-class (pointer-to obj))))) (defun object-get-meta-class (obj) (make-pointer-wrapper 'objc-meta-class diff --git a/Lisp/memory-management.lisp b/Lisp/memory-management.lisp index caadf60..4b6666e 100644 --- a/Lisp/memory-management.lisp +++ b/Lisp/memory-management.lisp @@ -19,16 +19,18 @@ (defvar *id-objects* (make-weak-value-hash-table)) -(defvar *class-objects* (make-weak-value-hash-table)) (defvar *exception-objects* (make-weak-value-hash-table)) (defvar *selector-objects* (make-weak-value-hash-table)) (defvar *meta-class-objects* (make-weak-value-hash-table)) (defun make-pointer-wrapper (class &rest initargs &key pointer &allow-other-keys) + (when (and (not (eq 'selector class)) + (%objcl-object-is-class pointer)) + (return-from make-pointer-wrapper + (find-objc-class-by-name (%objcl-class-name pointer)))) (let* ((hash-table (ecase class ((id) *id-objects*) - ((objc-class) *class-objects*) ((exception) *exception-objects*) ((selector) *selector-objects*) ((objc-meta-class) *meta-class-objects*))) diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp index ef5058a..92a9c92 100644 --- a/Lisp/method-invocation.lisp +++ b/Lisp/method-invocation.lisp @@ -219,7 +219,7 @@ easier to use with __apply__. (let* ((raw-argc (the argument-number (length args))) (real-argc (+ raw-argc 2)) (return-c-type (case return-type - ((id objc-class exception selector) :pointer) + ((id objective-c-class exception selector) :pointer) (otherwise return-type))) (selector (if (typep method-name 'selector) method-name @@ -305,7 +305,7 @@ easier to use with __apply__. ;; us. (error (make-condition 'exception :pointer error-cell))) (case return-type - ((id objc-class exception selector) + ((id objective-c-class exception selector) (let ((*skip-retaining* (or *skip-retaining* (constructor-name-p (selector-name selector)))) @@ -357,7 +357,8 @@ easier to use with __apply__. (defun typespec->c-type (typespec) (case (car typespec) - ((:pointer struct union id objc-class exception array selector) :pointer) + ((:pointer struct union id objective-c-class exception array selector) + :pointer) ((:string) :string) (otherwise (car typespec)))) @@ -405,7 +406,7 @@ easier to use with __apply__. do (case (car arg-type) ((:pointer) (setf (argref :pointer i) arg)) - ((objc-class exception) + ((objective-c-class exception) (setf (argref :pointer i) (pointer-to arg))) ((selector) (setf (argref :pointer i) (pointer-to (selector arg)))) @@ -457,7 +458,7 @@ easier to use with __apply__. (unless (cffi:null-pointer-p error-cell) (error (make-condition 'exception :pointer error-cell))) (case (car return-type) - ((id objc-class exception selector) + ((id objective-c-class exception selector) (let ((*skip-retaining* (or *skip-retaining* (constructor-name-p (selector-name selector))))) @@ -489,7 +490,7 @@ easier to use with __apply__. (defcoercion id ((x id)) x) -(defcoercion id ((x objc-class)) +(defcoercion id ((x objective-c-class)) x) (defcoercion id ((x exception)) @@ -537,7 +538,7 @@ easier to use with __apply__. (defcoercion class ((x exception)) (object-get-class x)) -(defcoercion class ((x objc-class)) +(defcoercion class ((x objective-c-class)) x) (defcoercion class ((x string)) diff --git a/Lisp/name-conversion.lisp b/Lisp/name-conversion.lisp index d8f9a5d..64a42c7 100644 --- a/Lisp/name-conversion.lisp +++ b/Lisp/name-conversion.lisp @@ -62,3 +62,40 @@ (string (char (first components) 0)) (string-upcase (subseq (first components) 1)))))) + + +(defun objc-class-name->symbol (class-name) + (let ((prefix-end (1- (position-if #'lower-case-p class-name)))) + (cond ((and prefix-end (> prefix-end 0)) + ;; There are n upper case chars at the head of the name. + ;; Take the first (1- n) of them and downcase them. Then, + ;; put a dash right after them and downcase the n'th char as + ;; well, such that "NSFoo" becomes "ns-foo". + (setq class-name (concatenate 'string + (string-downcase + (subseq class-name 0 prefix-end)) + "-" + (string + (char-downcase + (char class-name prefix-end))) + (subseq class-name (1+ prefix-end))))) + ((and prefix-end (zerop prefix-end)) + ;; There is exactly one upper case char at the head of the + ;; name. just downcase it and move on. + (setq class-name (copy-seq class-name)) + (setf (char class-name 0) (char-downcase (char class-name 0)))))) + (loop for delim-position = (position-if #'upper-case-p class-name) + while delim-position + do (setq class-name (concatenate 'string + (subseq class-name 0 delim-position) + "-" + (string + (char-downcase + (char class-name delim-position))) + (subseq class-name (1+ delim-position))))) + (let ((*package* (find-package '#:objective-c-classes))) + ;; Why do we use READ-FROM-STRING rather than MAKE-SYMBOL? That is + ;; because we want this procedure to work as expected for any value + ;; of (READTABLE-CASE *READTABLE*), which means that 'ns-object + ;; should always mean the same thing as "NSObject". + (read-from-string class-name))) diff --git a/Lisp/tests.lisp b/Lisp/tests.lisp index 1df4895..e362774 100644 --- a/Lisp/tests.lisp +++ b/Lisp/tests.lisp @@ -21,7 +21,7 @@ (:export #:run-all-tests) (:shadowing-import-from #:objcl #:struct #:union #:pointer #:oneway #:out #:in - #:inout #:const #:parse-typespec #:objc-class + #:inout #:const #:parse-typespec #:objective-c-class #:bit-field #:opaque #:bycopy #:byref #:primitive-invoke)) (in-package #:mulk.objective-cl.tests) @@ -89,7 +89,7 @@ ((ensure-same (primitive-invoke (find-objc-class 'ns-object) 'self 'id) (primitive-invoke (find-objc-class 'ns-object) - 'class 'objc-class))) + 'class 'objective-c-class))) ((ensure-different (primitive-invoke (find-objc-class 'ns-object) 'self 'id) (primitive-invoke (find-objc-class 'ns-number) @@ -193,7 +193,7 @@ (:unsigned-long-long ()) (:float ()) (:double ()) - (id ()) (objc-class ()) (selector ()) + (id ()) (objective-c-class ()) (selector ()) (:string ()) (:unknown ())))) ((ensure (let ((funky-spec (parse-typespec "{?=cC}"))) diff --git a/Lisp/type-handling.lisp b/Lisp/type-handling.lisp index bc46e6b..5b5292b 100644 --- a/Lisp/type-handling.lisp +++ b/Lisp/type-handling.lisp @@ -172,7 +172,7 @@ Returns: (VALUES typespec byte-position string-position)" (#\d :double) (#\v :void) (#\@ 'id) - (#\# 'objc-class) + (#\# 'objective-c-class) (#\: 'selector) (#\* :string) (#\? :unknown)) diff --git a/Lisp/utilities.lisp b/Lisp/utilities.lisp index 6619490..ef658f2 100644 --- a/Lisp/utilities.lisp +++ b/Lisp/utilities.lisp @@ -158,10 +158,10 @@ invocations will return numbers.) ;; matter (it only does so on NeXT/x86, but neither on GNUstep nor on ;; NeXT/ppc32). (or (id-eql x y) - (truep (if (typep x '(or id objc-class exception)) + (truep (if (typep x '(or id objective-c-class exception)) (invoke x :is-equal y) (progn - (assert (typep y '(or id objc-class exception))) + (assert (typep y '(or id objective-c-class exception))) (invoke y :is-equal x)))))) @@ -182,10 +182,10 @@ invocations will return numbers.) (defmethod objc-eql (x (y id)) (id-eql x y)) -(defmethod objc-eql ((x objc-class) y) +(defmethod objc-eql ((x objective-c-class) y) (id-eql x y)) -(defmethod objc-eql (x (y objc-class)) +(defmethod objc-eql (x (y objective-c-class)) (id-eql x y)) (defmethod objc-eql ((x exception) y) @@ -213,10 +213,10 @@ invocations will return numbers.) (defmethod objc-equal (x (y id)) (id-equal x y)) -(defmethod objc-equal ((x objc-class) y) +(defmethod objc-equal ((x objective-c-class) y) (id-equal x y)) -(defmethod objc-equal (x (y objc-class)) +(defmethod objc-equal (x (y objective-c-class)) (id-equal x y)) (defmethod objc-equal ((x exception) y) @@ -248,12 +248,12 @@ invocations will return numbers.) (cffi:pointer-address pointer)))))) -(defmethod print-object ((class objc-class) stream) +(defmethod print-object ((class objective-c-class) stream) (print-unreadable-object (class stream) (with-slots (pointer) class (format stream "~S ~A {~X}" (type-of class) - (objc-class-name class) + (class-name class) (cffi:pointer-address pointer))))) diff --git a/objective-cl.asd b/objective-cl.asd index e710906..82cc2aa 100644 --- a/objective-cl.asd +++ b/objective-cl.asd @@ -59,7 +59,8 @@ "memory-management")) (:file "memory-management" :depends-on ("defpackage" "weak-hash-tables" - "parameters")) + "parameters" + "conditions")) (:file "reader-syntax" :depends-on ("defpackage" "method-invocation")) (:file "utilities" :depends-on ("init" |