Minor fixes and added the support for typedefs
Tue Oct 2 19:32:58 PDT 2007 matley@muppetslab.org
* Minor fixes and added the support for typedefs
diff -rN -u old-cl-objc/src/clos.lisp new-cl-objc/src/clos.lisp
--- old-cl-objc/src/clos.lisp 2014-04-17 00:51:32.000000000 -0700
+++ new-cl-objc/src/clos.lisp 2014-04-17 00:51:32.000000000 -0700
@@ -74,11 +74,14 @@
value (CLOS instance or primitive type)"
(typecase ret
(objc-object
- (let ((new-ret
- (make-instance (export-class-symbol (obj-class ret)))))
- (setf (objc:objc-id new-ret) ret)
- new-ret))
+ (if (objc-nil-object-p ret)
+ ret
+ (let ((new-ret
+ (make-instance (export-class-symbol (obj-class ret)))))
+ (setf (objc:objc-id new-ret) ret)
+ new-ret)))
(fixnum ret)
+ (string ret)
(otherwise (error "Not yet supported ~s" (class-name (class-of ret))))))
(defmethod closer-mop:compute-discriminating-function ((gf objc-generic-function))
@@ -192,9 +195,25 @@
(when (fboundp symbol) (fmakunbound symbol))
(unintern symbol "OBJC")))
-;; Fixme: when types of args are available, method should be
-;; specialized on the corresponding lisp types
-(defun update-clos-definitions (&key output-stream force)
+(defun framework-class (class-name)
+ "Find the framework short name handling CLASS-NAME"
+ (objc-cffi::load-framework "Foundation")
+ (let ((all-frameworks (invoke 'ns-bundle all-frameworks))
+ (class-name-string (invoke (invoke 'ns-string alloc) :init-with-utf8-string class-name)))
+ (loop
+ for i below (invoke all-frameworks count)
+ for framework = (invoke all-frameworks :object-at-index i)
+ when (and
+ (not (objc-nil-object-p framework))
+ (not (eq objc-nil-class (invoke framework :class-named class-name-string))))
+ do
+ (let ((bundle-id (invoke framework bundle-identifier)))
+ (if (objc-nil-object-p bundle-id)
+ (warn "Class ~a not binded to any framework" class-name)
+ (let ((full-name (invoke bundle-id utf8-string)))
+ (return (car (last (split-string full-name #\.))))))))))
+
+(defun update-clos-definitions (&key output-stream force for-framework)
"Generate CLOS classes/generic function for each ObjC
class/method. The default behavior is to not redefine a
class/generic function if it is already defined, except if FORCE
@@ -205,8 +224,10 @@
~%(in-package \"CL-OBJC-USER\")~%~%"))
(dolist (objc-class (get-class-ordered-list))
;; Adding Classes
- (when (or force
- (not (find-class (export-class-symbol objc-class) nil)))
+ (when (and (or (not for-framework)
+ (string-equal for-framework (framework-class (class-name objc-class))))
+ (or force
+ (not (find-class (export-class-symbol objc-class) nil))))
(add-clos-class objc-class output-stream))
;; Adding Generic Functions for ObjC methods
(dolist (method (append (get-instance-methods objc-class) (get-class-methods objc-class)))
diff -rN -u old-cl-objc/src/lisp-interface.lisp new-cl-objc/src/lisp-interface.lisp
--- old-cl-objc/src/lisp-interface.lisp 2014-04-17 00:51:32.000000000 -0700
+++ new-cl-objc/src/lisp-interface.lisp 2014-04-17 00:51:32.000000000 -0700
@@ -24,35 +24,36 @@
(setf string new-string))))
string)))
-(memoize:def-memoized-function objc-selector-to-symbols (selector)
- "The inverse of SYMBOLS-TO-OBJC-SELECTOR"
- (when (eq (find-class 'objc-selector) (class-of selector))
- (setq selector (sel-name selector)))
- (flet ((convert-selector-part (selector-part)
- (if selector-part
- (with-output-to-string (out)
- (when (upper-case-p (elt selector-part 0))
- (princ #\- out))
- (princ
- (if (= 1 (length selector-part))
- (string-upcase selector-part)
- (loop
- for char across (subseq selector-part 1)
- with old-char = (elt selector-part 0)
- finally (return (char-upcase char))
- do
- (princ (char-upcase old-char) out)
- (when (upper-case-p char)
- (princ "-" out))
- (setf old-char char))) out))
- "*")))
- (mapcar (lambda (name)
- (intern name
- (if (zerop (count #\: selector))
- *package*
- (find-package "KEYWORD"))))
- (mapcar #'replace-acronyms-1
- (mapcar #'convert-selector-part (split-string selector #\:))))))
+(unless (fboundp 'objc-selector-to-symbols)
+ (memoize:def-memoized-function objc-selector-to-symbols (selector)
+ "The inverse of SYMBOLS-TO-OBJC-SELECTOR"
+ (when (eq (find-class 'objc-selector) (class-of selector))
+ (setq selector (sel-name selector)))
+ (flet ((convert-selector-part (selector-part)
+ (if selector-part
+ (with-output-to-string (out)
+ (when (upper-case-p (elt selector-part 0))
+ (princ #\- out))
+ (princ
+ (if (= 1 (length selector-part))
+ (string-upcase selector-part)
+ (loop
+ for char across (subseq selector-part 1)
+ with old-char = (elt selector-part 0)
+ finally (return (char-upcase char))
+ do
+ (princ (char-upcase old-char) out)
+ (when (upper-case-p char)
+ (princ "-" out))
+ (setf old-char char))) out))
+ "*")))
+ (mapcar (lambda (name)
+ (intern name
+ (if (zerop (count #\: selector))
+ *package*
+ (find-package "KEYWORD"))))
+ (mapcar #'replace-acronyms-1
+ (mapcar #'convert-selector-part (split-string selector #\:)))))))
(defun symbols-to-objc-selector (lst)
"Translate a list of symbols to a string naming a translator"
@@ -224,13 +225,19 @@
Return a new ObjectiveC Method object."
(flet ((remove-symbol-with-name (symbol-name list)
- (remove symbol-name list :key (lambda (el) (symbol-name (car el))) :test #'string-equal)))
+ (remove symbol-name list :key (lambda (el) (symbol-name (car el))) :test #'string-equal))
+ (replace-nsclass (arg-def) (if (and (listp arg-def)
+ (not (eq objc-nil-class (objc-get-class (symbol-to-objc-class-name (second arg-def))))))
+ (list (first arg-def) 'objc-id)
+ arg-def)))
`(add-objc-method (,(symbols-to-objc-selector (ensure-list list-selector))
,(symbol-to-objc-class-name (or (lookup-same-symbol-name 'self argument-list)
(error "You have to specify the SELF argument and the related type")))
:return-type ,return-type
:class-method ,class-method)
- (,@(or (remove-symbol-with-name "self" (remove-symbol-with-name "sel" argument-list))
+ (,@(or (remove-symbol-with-name "self"
+ (remove-symbol-with-name "sel"
+ (mapcar #'replace-nsclass argument-list)))
()))
,@body)))
@@ -251,6 +258,8 @@
"Execute BODY with bindings to accessors of the
form (CLASS-NAME`-`IVAR-NAME)"
(let ((class (objc-get-class (symbol-to-objc-class-name symbol-class))))
+ (when (eq class objc-nil-class)
+ (error "Can't find class ~a" symbol-class))
`(ivars-macrolet-forms ,(class-ivars class) ,symbol-class
,@body)))
@@ -271,12 +280,14 @@
(objc-get-class ,(symbol-to-objc-class-name symbol-superclass))
(list ,@(mapcar (lambda (ivar-def)
(let ((var-name (car ivar-def))
- (var-type (cadr ivar-def)))
- (unless (eq objc-nil-class
- (objc-get-class (symbol-to-objc-class-name var-type)))
- (setf var-type 'objc-id))
+ (var-type
+ `(cond
+ ((not (eq objc-nil-class (objc-get-class
+ ,(symbol-to-objc-class-name (second ivar-def)))))
+ 'objc-id)
+ (t ',(cadr ivar-def)))))
`(make-ivar ,(symbols-to-objc-selector (list var-name))
- ',var-type)))
+ ,var-type)))
ivars)))))
(defun objc-let-bindings (bindings)
(mapcar (lambda (binding)
diff -rN -u old-cl-objc/src/runtime.lisp new-cl-objc/src/runtime.lisp
--- old-cl-objc/src/runtime.lisp 2014-04-17 00:51:32.000000000 -0700
+++ new-cl-objc/src/runtime.lisp 2014-04-17 00:51:32.000000000 -0700
@@ -70,6 +70,18 @@
(first argument)
argument)))))))
+(defun remove-typedef (type)
+ "TYPE is the lisp CFFI name. Returns an objc struct definition
+if TYPE names a struct, a primitive type if TYPE names a basic C
+typedef, else TYPE itself."
+ (cond
+ ((find-struct-definition type))
+ ((and (gethash type cffi::*type-parsers*)
+ (eq (class-of (funcall (gethash type cffi::*type-parsers*)))
+ (find-class 'cffi::foreign-typedef)))
+ (cffi::type-keyword (cffi::actual-type (funcall (gethash type cffi::*type-parsers*)))))
+ (t type)))
+
(defmacro add-objc-method ((name class &key (return-type 'objc-id) (class-method nil))
argument-list &body body)
"Add an ObjectiveC method to CLASS returning the CFFI
@@ -104,7 +116,7 @@
(let ((,new-method
(register-method ,class
,name
- (objc-types:encode-types (append (list ',return-type) ',type-list) t)
+ (objc-types:encode-types (append (list ',return-type) ',(mapcar #'remove-typedef type-list)) t)
(callback ,callback)
,class-method)))
(when objc-clos:*automatic-definitions-update*
@@ -203,7 +215,7 @@
((objc-class-already-exists (lambda (c)
(invoke-restart 'use-the-same-class (objc-get-class (objc-class-name c))))))
(add-objc-class class-name super-class ivar-list))
- (use-the-same-class (same-class) (prog2
+ (use-the-same-class (&optional same-class) (prog2
(format *error-output* "Class named ~a already exists. Use the existing one.~%"
(class-name same-class))
same-class))))
@@ -211,13 +223,7 @@
(defun make-ivar (name type)
"Returns a new instance variable object named NAME of TYPE"
(let ((ret (foreign-alloc 'objc-ivar-cstruct))
- (type (cond
- ((find-struct-definition type))
- ((and (gethash type cffi::*type-parsers*)
- (eq (class-of (funcall (gethash type cffi::*type-parsers*)))
- (find-class 'cffi::foreign-typedef)))
- (cffi::type-keyword (cffi::actual-type (funcall (gethash type cffi::*type-parsers*)))))
- (t type))))
+ (type (remove-typedef type)))
(convert-from-foreign
(with-foreign-slots ((ivar_name ivar_type ivar_offset) ret objc-ivar-cstruct)
(setf ivar_name name
diff -rN -u old-cl-objc/src/utils.lisp new-cl-objc/src/utils.lisp
--- old-cl-objc/src/utils.lisp 2014-04-17 00:51:32.000000000 -0700
+++ new-cl-objc/src/utils.lisp 2014-04-17 00:51:32.000000000 -0700
@@ -15,8 +15,9 @@
(defun cffi-type-p (symbol)
;; FIXME: do not use internal symbols of CFFI to check if a type is legal
- (member symbol
- (loop for key being the hash-key of cffi::*type-parsers* collecting key)))
+ (not (null
+ (member symbol
+ (loop for key being the hash-key of cffi::*type-parsers* collecting key)))))
(defun split-string (string separator &key (test-fn #'char-equal))
"Split STRING containing items separated by SEPARATOR into a