Changeset 5733

Timestamp:

Jan 18, 2007, 3:17:16 AM (18 years ago)

Author:

Gary Byers

Message:

Some word-size conditionalization. Will need more work to handle
struct return/asssignment correctly on all platforms.

File:

• trunk/ccl/examples/bridge.lisp (modified) (12 diffs)

trunk/ccl/examples/bridge.lisp

@@ -78 +78 @@
            ;; (STRING-with-N-colons ARG1 ... ARGN {LIST}) 
            (let* ((n (count #\: (the simple-string f)))
-                  (message-info (get-objc-message-info f))
+                  (message-info (need-objc-message-info f))
                   (args (rest args))
                   (nargs (length args)))
@@ -92 +92 @@
            (let ((nargs (length args)))
              (cond ((and (= nargs 2) (consp l)
-                         (let* ((info (get-objc-message-info
+                         (let* ((info (need-objc-message-info
                                        (lisp-to-objc-message (list f)))))
                            (getf (objc-message-info-flags info)
@@ -218 +218 @@
   (if (numberp rspec) 
     (> rspec 1)
-    (> (ensure-foreign-type-bits (parse-foreign-type rspec)) 32)))
+    (> (ensure-foreign-type-bits (parse-foreign-type rspec)) target::nbits-in-word)))
 
 
@@ -375 +375 @@
                                      (objc-method-info-arglist m)))))))
       (let* ((methods (objc-message-info-methods message-info))
+             (signatures ())
+             (protocol-methods)
              (signature-alist ()))
         (dolist (m methods)
-          (let* ((signature (ensure-method-signature m))
-                 (pair (assoc signature signature-alist :test #'equal)))
-            (if pair
-              (push m (cdr pair))
-              (push (cons signature (list m)) signature-alist))))
+          (let* ((signature (ensure-method-signature m)))
+            (pushnew signature signatures :test #'equal)
+            (if (getf (objc-method-info-flags m) :protocol)
+              (push m protocol-methods)
+              (let* ((pair (assoc signature signature-alist :test #'equal)))
+                (if pair
+                  (push m (cdr pair))
+                  (push (cons signature (list m)) signature-alist))))))
         (setf (objc-message-info-ambiguous-methods message-info)
               (mapcar #'cdr
@@ -389 +394 @@
                                    (length (cdr y)))))))
         (setf (objc-message-info-flags message-info) nil)
-        (when (cdr (objc-message-info-ambiguous-methods message-info))
+        (setf (objc-message-info-protocol-methods message-info)
+              protocol-methods)
+        (when (cdr signatures)
           (setf (getf (objc-message-info-flags message-info) :ambiguous) t))
         (let* ((first-method (car methods))
@@ -438 +445 @@
           info))))
 
+(defun need-objc-message-info (message-name)
+  (or (get-objc-message-info message-name)
+      (error "Undeclared message: ~s" message-name)))
+
 ;;; Should be called after using new interfaces that may define
 ;;; new methods on existing messages.
@@ -558 +569 @@
              (if (and (consp translated) (eq (first translated) :record))
                #+apple-objc
-               (/ (second translated) 32)
+               (ceiling (second translated) target::nbits-in-word)
                #+gnu-objc `(:* ,ftype)
                translated))))
@@ -615 +626 @@
                (methods (objc-message-info-methods message-info))
                (method (if (not ambiguous) (car methods))))
-          (if ambiguous
+          (when ambiguous
             (let* ((class (if sclassname 
                             (find-objc-class sclassname)
@@ -621 +632 @@
               (if class
                 (dolist (m methods)
-                  (let* ((mclass (or (get-objc-method-info-class m)
-                                     (error "Can't find ObjC class named ~s"
-                                            (objc-method-info-class-name m)))))
-                    (when (and class (subtypep class mclass))
-                      (return (setq method m))))))))
+                  (unless (getf (objc-method-info-flags m) :protocol)
+                    (let* ((mclass (or (get-objc-method-info-class m)
+                                       (error "Can't find ObjC class named ~s"
+                                              (objc-method-info-class-name m)))))
+                      (when (and class (subtypep class mclass))
+                        (return (setq method m)))))))))
           (if method
             (build-call-from-method-info method
@@ -746 +758 @@
                         msg
                         s
-                        super)
+                        super
+                        protocol-methods)
   (flet ((method-class-name (m)
            (let* ((mclass (get-objc-method-info-class m)))
@@ -754 +767 @@
              (class-name mclass))))
     (collect ((clauses))
+      (let* ((protocol (gensym)))
+        (dolist (method protocol-methods)
+          (let* ((protocol-name (objc-method-info-class-name method)))
+            (clauses `((let* ((,protocol (lookup-objc-protocol ,protocol-name)))
+                         (and ,protocol
+                              (not (zerop (objc-message-send ,receiver
+                                                             "conformsToProtocol:"
+                                                             :address ,protocol
+                                                             :<BOOL>)))))
+                       ,(build-internal-call-from-method-info
+                         method args vargs receiver msg s super))))))
       (do* ((methods ambiguous-methods (cdr methods)))
            ((null (cdr methods))
+            (when ambiguous-methods
             (clauses `(t
                        ,(build-internal-call-from-method-info
-                         (caar methods) args vargs receiver msg s super))))
+                         (caar methods) args vargs receiver msg s super)))))
         (clauses `(,(if (cdar methods)
                         `(or ,@(mapcar #'(lambda (m)
@@ -780 +805 @@
                     msg
                     s
-                    super)))
+                    super
+                    (objc-message-info-protocol-methods message-info))))
     `(with-ns-exceptions-as-errors
       (rlet ,svarforms