Add support for "super"
Wed Sep 19 08:04:09 PDT 2007 matley@muppetslab.org
* Add support for "super"
diff -rN -u old-cl-objc/TODO new-cl-objc/TODO
--- old-cl-objc/TODO 2014-07-31 20:44:05.000000000 -0700
+++ new-cl-objc/TODO 2014-07-31 20:44:05.000000000 -0700
@@ -1,7 +1,7 @@
;; -*- outline -*-
* Docs & Examples
-** Update the docs: add a tutorial on the clos interface, extract a README file
+** Update the docs: Improve the clos section, call to super, add a tutorial on the clos interface, extract a README file
** Add more examples (one using the clos interface)
@@ -21,8 +21,6 @@
** Complete the ObjC CLOS interface (objc ivars in slots, mixed slots, defmethod mixed)
-** Support for the call to super
-
** Let user add effective protocols to classes
** Integration with XCode
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-07-31 20:44:05.000000000 -0700
+++ new-cl-objc/src/lisp-interface.lisp 2014-07-31 20:44:05.000000000 -0700
@@ -206,7 +206,8 @@
&body body)
"Add an ObjectiveC method binded to a selector defined by
LIST-SELECTOR (translated by SYMBOLS-TO-OBJC-SELECTOR), returning
-the CFFI RETURN-TYPE.
+the CFFI RETURN-TYPE. If the method get zero or one argument then
+LIST-SELECTOR can be specified with an atom.
If CLASS-METHOD is true then a class method will be added.
diff -rN -u old-cl-objc/src/msg-send.lisp new-cl-objc/src/msg-send.lisp
--- old-cl-objc/src/msg-send.lisp 2014-07-31 20:44:05.000000000 -0700
+++ new-cl-objc/src/msg-send.lisp 2014-07-31 20:44:05.000000000 -0700
@@ -23,6 +23,9 @@
(sel objc-sel)
&rest)
+(defcstruct objc-super
+ (id objc-id)
+ (class objc-class-pointer))
;; Building foreign function declarations for each objc primitive type
;; e.g. char-objc-msg-send, unsigned-int-objc-msg-send, etc.
@@ -35,9 +38,9 @@
(ensure-fun allowed-simple-return-types ()
(remove 'objc-types:objc-unknown-type (mapcar #'cadr objc-types:typemap)))
- (ensure-fun make-objc-msg-send-symbol (type)
+ (ensure-fun make-objc-msg-send-symbol (type superp)
(intern
- (format nil "~a-OBJC-MSG-SEND" (string-upcase (symbol-name type)))
+ (format nil "~a-OBJC-MSG-SEND~:[~;-SUPER~]" (string-upcase (symbol-name type)) superp)
(find-package "OBJC-CFFI")))
(ensure-fun odd-positioned-elements (list)
@@ -48,28 +51,34 @@
(when (> (length list) 1)
(cons (car list) (even-positioned-elements (cddr list))))))
-(defmacro %objc-msg-send (return-type id sel args)
- (let ((gensyms (loop repeat (+ 2 (/ (length args) 2)) collect (gensym))))
+(defmacro %objc-msg-send (return-type id sel args &optional superp)
+ (let ((gensyms (gensym-list (+ 2 (/ (length args) 2)))))
(cffi::translate-objects gensyms
(append (list id sel) (odd-positioned-elements args))
- (append (list 'objc-id 'objc-sel) (even-positioned-elements args))
+ (append (list (if superp 'objc-super 'objc-id) 'objc-sel) (even-positioned-elements args))
return-type
- `(cffi-sys:%foreign-funcall ,(if (member return-type '(:float :double))
- "objc_msgSend_fpret"
- "objc_msgSend")
- ,(append (list :pointer (first gensyms)
- :pointer (second gensyms))
- (interpose (mapcar #'cffi::canonicalize-foreign-type
- (even-positioned-elements args))
- (cddr gensyms))
- (list (cffi::canonicalize-foreign-type return-type)))
- :library :default :calling-convention :cdecl))))
+ `(cffi-sys:%foreign-funcall
+ ,(cond
+ ((member return-type '(:float :double)) "objc_msgSend_fpret")
+ (superp "objc_msgSendSuper")
+ (t "objc_msgSend"))
+ ,(append (list :pointer (first gensyms)
+ :pointer (second gensyms))
+ (interpose (mapcar #'cffi::canonicalize-foreign-type
+ (even-positioned-elements args))
+ (cddr gensyms))
+ (list (cffi::canonicalize-foreign-type return-type)))
+ :library :default :calling-convention :cdecl))))
(defmacro build-objc-msg-send ()
`(progn
,@(mapcar (lambda (type)
- `(defmacro ,(make-objc-msg-send-symbol type) (id sel args)
+ `(defmacro ,(make-objc-msg-send-symbol type nil) (id sel args)
`(%objc-msg-send ,',type ,id ,sel ,args)))
+ (allowed-simple-return-types))
+ ,@(mapcar (lambda (type)
+ `(defmacro ,(make-objc-msg-send-symbol type t) (id sel args)
+ `(%objc-msg-send ,',type ,id ,sel ,args t)))
(allowed-simple-return-types))))
(build-objc-msg-send)
@@ -115,22 +124,29 @@
(defparameter *methods-cache* (make-hash-table :test #'equal))
-(defun cache-compile (sel return-type types)
+(defun cache-compile (sel return-type super-call-p types)
(let* ((sel-name (etypecase sel
(objc-selector (sel-name sel))
(string sel))))
- (macrolet ((cache (sel-name types)
- `(gethash (append (list ,sel-name) ,types) *methods-cache*)))
- (or (cache sel-name types)
- (setf (cache sel-name types)
+ (macrolet ((cache (sel-name super-call-p types)
+ `(gethash (append (list ,sel-name ,super-call-p) ,types) *methods-cache*)))
+ (or (cache sel-name super-call-p types)
+ (setf (cache sel-name super-call-p types)
(compile nil
- (let ((varargs (loop for i upto (length types) collecting (gensym))))
+ (let ((varargs (gensym-list (length types))))
`(lambda ,varargs
- (,(make-objc-msg-send-symbol return-type)
+ (,(make-objc-msg-send-symbol return-type super-call-p)
,(first varargs)
,sel
,(interpose types (cdr varargs)))))))))))
+(defparameter *super-call* nil
+ "If this variable is set to t, the objc_msgSend will be translated to ")
+
+(defmacro with-super (&body body)
+ `(let ((objc-cffi::*super-call* t))
+ ,@body))
+
(defmacro typed-objc-msg-send ((id sel &optional stret) &rest args-and-types)
"Send the message binded to selector SEL to the object ID
returning the value of the ObjectiveC call.
@@ -146,36 +162,45 @@
If ID is an ObjectiveC class object it will call the class method
binded to SEL.
"
- (with-gensyms (gsel gid gmethod greturn-type)
+ (with-gensyms (gsel gid gmethod greturn-type super)
`(let* ((,gsel ,sel)
(,gid ,id)
(,gmethod (etypecase ,gid
(objc-class (class-get-class-method ,gid ,gsel))
- (objc-object (class-get-instance-method (obj-class ,gid) ,gsel)))))
+ (objc-object (class-get-instance-method (obj-class ,gid) ,gsel))))
+ (,gid (if *super-call*
+ (let ((,super (foreign-alloc 'objc-super)))
+ (setf (foreign-slot-value ,super 'objc-super 'id) ,gid
+ (foreign-slot-value ,super 'objc-super 'class) (second (super-classes ,gid)))
+ ,super)
+ ,gid)))
(if ,gmethod
- (let ((,greturn-type (method-return-type ,gmethod)))
- (cond
- ;; big struct passed by value as argument
- ((and (some #'big-struct-type-p (method-argument-types ,gmethod))
- (equal (mapcar #'extract-struct-name (method-argument-types ,gmethod))
- ',(even-positioned-elements args-and-types)))
- (untyped-objc-msg-send ,gid ,gsel ,@(odd-positioned-elements args-and-types)))
-
- ;; big struct as return value passed by value
- ((big-struct-type-p ,greturn-type)
- (objc-msg-send-stret (or ,stret
- (foreign-alloc (extract-struct-name ,greturn-type)))
- ,gid ,gsel ,@args-and-types))
- ;; small struct as return value passed by value
- ((small-struct-type-p ,greturn-type)
- (objc-msg-send ,gid ,gsel ,@args-and-types))
-
- ;; general case
- ((member ,greturn-type ',(allowed-simple-return-types))
- (funcall
- (cache-compile ,gsel ,greturn-type ',(even-positioned-elements args-and-types))
- ,gid ,@(odd-positioned-elements args-and-types)))
- (t (error "Unknown return type ~s" ,greturn-type))))
+ (prog1
+ (let ((,greturn-type (method-return-type ,gmethod)))
+ (cond
+ ;; big struct passed by value as argument
+ ((and (some #'big-struct-type-p (method-argument-types ,gmethod))
+ (equal (mapcar #'extract-struct-name (method-argument-types ,gmethod))
+ ',(even-positioned-elements args-and-types)))
+ (untyped-objc-msg-send ,gid ,gsel ,@(odd-positioned-elements args-and-types)))
+
+ ;; big struct as return value passed by value
+ ((big-struct-type-p ,greturn-type)
+ (objc-msg-send-stret (or ,stret
+ (foreign-alloc (extract-struct-name ,greturn-type)))
+ ,gid ,gsel ,@args-and-types))
+ ;; small struct as return value passed by value
+ ((small-struct-type-p ,greturn-type)
+ (objc-msg-send ,gid ,gsel ,@args-and-types))
+
+ ;; general case
+ ((member ,greturn-type ',(allowed-simple-return-types))
+ (funcall
+ (cache-compile ,gsel ,greturn-type *super-call* ',(even-positioned-elements args-and-types))
+ ,gid ,@(odd-positioned-elements args-and-types)))
+ (t (error "Unknown return type ~s" ,greturn-type))))
+ (when *super-call*
+ (foreign-free ,gid)))
(error "ObjC method ~a not found" ,gsel)))))
(defparameter *untyped-methods-cache* (make-hash-table :test #'equal))
@@ -187,7 +212,7 @@
(or (gethash sel-name *untyped-methods-cache*)
(setf (gethash sel-name *untyped-methods-cache*)
(compile nil
- (let ((varargs (loop for i upto (- (method-get-number-of-arguments method) 2) collecting (gensym))))
+ (let ((varargs (gensym-list (- (method-get-number-of-arguments method) 2))))
`(lambda ,varargs
(typed-objc-msg-send (,(first varargs) ,sel)
,@(interpose
diff -rN -u old-cl-objc/src/objc-types.lisp new-cl-objc/src/objc-types.lisp
--- old-cl-objc/src/objc-types.lisp 2014-07-31 20:44:05.000000000 -0700
+++ new-cl-objc/src/objc-types.lisp 2014-07-31 20:44:05.000000000 -0700
@@ -151,11 +151,14 @@
(cond
((and (listp type) (eq :align (car type))) (format nil "~a~d" (encode-type (third type)) (second type)))
((lookup-type-char type) (if align (format nil "~a~d" (lookup-type-char type) 8) (lookup-type-char type)))
- ((eq :bitfield (car type)) (format nil "b~d" (second type)))
- ((eq :union (car type)) (format nil "(~a=~{~a~})" (second type) (mapcar #'encode-type (caddr type))))
- ((eq :struct (car type)) (format nil "{~a=~{~a~}}" (second type) (mapcar #'encode-type (caddr type))))
- ((eq :pointer (car type)) (format nil "^~a" (encode-type (cadr type))))
- ((eq :method (car type)) (format nil "~a~{~a~}" (lookup-method-char (second type)) (mapcar #'encode-type (cddr type))))
- ((eq :array (car type)) (format nil "[~d~a]" (second type) (encode-type (third type))))
+ ((listp type)
+ (cond
+ ((eq :bitfield (car type)) (format nil "b~d" (second type)))
+ ((eq :union (car type)) (format nil "(~a=~{~a~})" (second type) (mapcar #'encode-type (caddr type))))
+ ((eq :struct (car type)) (format nil "{~a=~{~a~}}" (second type) (mapcar #'encode-type (caddr type))))
+ ((eq :pointer (car type)) (format nil "^~a" (encode-type (cadr type))))
+ ((eq :method (car type)) (format nil "~a~{~a~}" (lookup-method-char (second type)) (mapcar #'encode-type (cddr type))))
+ ((eq :array (car type)) (format nil "[~d~a]" (second type) (encode-type (third type))))
+ (t (error "can't encode type: ~s" type))))
(t (error "can't encode type: ~s" type))))
diff -rN -u old-cl-objc/src/packages.lisp new-cl-objc/src/packages.lisp
--- old-cl-objc/src/packages.lisp 2014-07-31 20:44:05.000000000 -0700
+++ new-cl-objc/src/packages.lisp 2014-07-31 20:44:05.000000000 -0700
@@ -9,7 +9,8 @@
"ENSURE-LIST"
"INTERPOSE"
"LOOKUP-SAME-SYMBOL-NAME"
- "COMPOSITE-MAPCAR"))
+ "COMPOSITE-MAPCAR"
+ "GENSYM-LIST"))
(defpackage "OBJC-CFFI"
(:use "COMMON-LISP" "CFFI" "CL-OBJC-UTILS")
@@ -72,6 +73,7 @@
"METHOD-GET-SIZE-OF-ARGUMENTS"
"METHOD-GET-ARGUMENT-INFO"
+ "WITH-SUPER"
"TYPED-OBJC-MSG-SEND"
"UNTYPED-OBJC-MSG-SEND"
"CLEAR-METHOD-CACHES"
diff -rN -u old-cl-objc/src/runtime.lisp new-cl-objc/src/runtime.lisp
--- old-cl-objc/src/runtime.lisp 2014-07-31 20:44:05.000000000 -0700
+++ new-cl-objc/src/runtime.lisp 2014-07-31 20:44:05.000000000 -0700
@@ -211,7 +211,13 @@
(defun make-ivar (name type)
"Returns a new instance variable object named NAME of TYPE"
(let ((ret (foreign-alloc 'objc-ivar-cstruct))
- (type (or (find-struct-definition type) type)))
+ (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))))
(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/structs.lisp new-cl-objc/src/structs.lisp
--- old-cl-objc/src/structs.lisp 2014-07-31 20:44:05.000000000 -0700
+++ new-cl-objc/src/structs.lisp 2014-07-31 20:44:05.000000000 -0700
@@ -27,24 +27,23 @@
(defvar *registered-structs* nil)
(defun update-cstruct-database (&key output-stream)
- (let ((updated-structs
- (remove-duplicates
- (remove-if-not (lambda (type)
- (and (struct-type-p type)
- (not (string-equal (struct-objc-name type) "?"))))
- (mapcar #'caddr
- (mapcan #'objc-types:parse-objc-typestr
- (mapcar #'method-type-signature (mapcan #'get-instance-methods (get-class-list))))))
- :test #'string-equal
- :key #'second)))
- (when output-stream
- (let ((*package* (find-package "CL-OBJC-USER")))
- (format output-stream ";;; Structure names cache~%~%(in-package \"CL-OBJC-USER\")
+ (setf *objc-struct-db*
+ (remove-duplicates
+ (remove-if-not (lambda (type)
+ (and (struct-type-p type)
+ (not (string-equal (struct-objc-name type) "?"))))
+ (mapcar #'caddr
+ (mapcan #'objc-types:parse-objc-typestr
+ (mapcar #'method-type-signature (mapcan #'get-instance-methods (get-class-list))))))
+ :test #'string-equal
+ :key #'second))
+ (when output-stream
+ (let ((*package* (find-package "CL-OBJC-USER")))
+ (format output-stream ";;; Structure names cache~%~%(in-package \"CL-OBJC-USER\")
~%(dolist (struct-name (list ~{(quote ~s)~}))
~2t(pushnew struct-name ~s :test #'string-equal :key #'second))~%~%"
- (set-difference updated-structs *objc-struct-db* :key #'second :test #'string-equal)
- '*objc-struct-db*)))
- (setf *objc-struct-db* updated-structs)))
+ *objc-struct-db*
+ '*objc-struct-db*))))
(defun canonicalize-objc-struct-name (name)
(or (cdr (assoc name *registered-structs* :test #'equal))
diff -rN -u old-cl-objc/src/utils.lisp new-cl-objc/src/utils.lisp
--- old-cl-objc/src/utils.lisp 2014-07-31 20:44:05.000000000 -0700
+++ new-cl-objc/src/utils.lisp 2014-07-31 20:44:05.000000000 -0700
@@ -72,4 +72,7 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *doc-dir* (append
(butlast (pathname-directory (or *load-pathname* *compile-file-pathname*)))
- (list "doc" "include"))))
\ No newline at end of file
+ (list "doc" "include"))))
+
+(defun gensym-list (n)
+ (loop for i upto n collecting (gensym)))
\ No newline at end of file
diff -rN -u old-cl-objc/t/runtime.lisp new-cl-objc/t/runtime.lisp
--- old-cl-objc/t/runtime.lisp 2014-07-31 20:44:05.000000000 -0700
+++ new-cl-objc/t/runtime.lisp 2014-07-31 20:44:05.000000000 -0700
@@ -86,8 +86,7 @@
(random-y (random 10.0))
(class-name (temp-class-name))
(ivar (make-ivar "struct" 'nspoint))
- (new-class (add-objc-class class-name (objc-get-class "NSObject") (list ivar)))
- (obj (untyped-objc-msg-send (objc-get-class class-name) "alloc")))
+ (obj (untyped-objc-msg-send (add-objc-class class-name (objc-get-class "NSObject") (list ivar)) "alloc")))
(cffi:with-foreign-object (p 'nspoint)
(cffi:with-foreign-slots ((x y) p nspoint)
(setf x random-x