Changeset 574
- Timestamp:
- Feb 27, 2004, 8:27:30 AM (21 years ago)
- File:
-
- 1 edited
-
trunk/ccl/examples/bridge.lisp (modified) (15 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/ccl/examples/bridge.lisp
r455 r574 23 23 (require "OBJC-RUNTIME") 24 24 (require "NAME-TRANSLATION") 25 26 27 28 25 29 26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; … … 186 183 187 184 185 ;;; For some reason, these types sometimes show up as :STRUCTs even though they 186 ;;; are not structure tags, but type names 187 188 (defun fudge-objc-type (ftype) 189 (if (equal ftype '(:STRUCT :<NSD>ecimal)) 190 :<NSD>ecimal 191 ftype)) 192 193 188 194 ;;; Returns T if the result spec requires a STRET for its return, NIL otherwise 189 195 ;;; RSPEC may be either a number (in which case it is interpreted as a number … … 192 198 193 199 (defun requires-stret-p (rspec) 200 (when (member rspec '(:DOUBLE-FLOAT :UNSIGNED-DOUBLEWORD :SIGNED-DOUBLEWORD) 201 :test #'eq) 202 (return-from requires-stret-p nil)) 203 (setq rspec (fudge-objc-type rspec)) 194 204 (if (numberp rspec) 195 205 (> rspec 1) … … 249 259 `(,var :<NSS>ize :width ,(second form) :height ,(third form))) 250 260 (send 251 (let ((rtype (caar (message-type-signatures (parse-message (cddr form)))))) 261 (let ((rtype (first (msg-desc-type-signature 262 (first (message-descriptors 263 (parse-message (cddr form)))))))) 252 264 (if (requires-stret-p rtype) 253 265 (values `(,var ,rtype) `(send/stret ,var ,@(rest form))) … … 256 268 form)))) 257 269 (send-super 258 (let ((rtype (caar (message-type-signatures (parse-message (cddr form)))))) 270 (let ((rtype (first (msg-desc-type-signature 271 (first (message-descriptors 272 (parse-message (cddr form)))))))) 259 273 (if (requires-stret-p rtype) 260 274 (values `(,var ,rtype) `(send-super/stret ,var ,@(rest form))) … … 322 336 ;;; A hash table from message names to lists of foreign type signature lists 323 337 324 (defvar *type-signature-table* (make-hash-table :test #'equal :size 6750)) 338 (defstruct (msg-desc 339 (:constructor make-msg-desc 340 (classes type-signature i/o-signature))) 341 classes 342 type-signature 343 i/o-signature) ; Not yet used 344 345 (defvar *type-signature-table* (make-hash-table :test #'equal :size 8192)) 325 346 326 347 327 348 ;;; Add a new method to the table 328 349 329 (defun update-type-signatures-for-method (m )350 (defun update-type-signatures-for-method (m c) 330 351 (let* ((sel (pref m :objc_method.method_name)) 331 (msg (lisp-string-from-sel sel))) 332 (when (neq (schar msg 0) #\_) 333 (pushnew 334 (compute-method-type-signature m) 335 (gethash msg *type-signature-table*) 336 :test #'equal)))) 337 352 (msg (lisp-string-from-sel sel)) 353 (c (%setf-macptr (%int-to-ptr 0) c))) 354 (when (and (neq (schar msg 0) #\_) ) 355 (let* ((tsig (compute-method-type-signature m)) 356 (msgdesc (find tsig (gethash msg *type-signature-table*) 357 :test #'equal 358 :key #'msg-desc-type-signature))) 359 (if (null msgdesc) 360 ;; Add new msg desc for this type signature 361 (push 362 (make-msg-desc (list c) tsig nil) 363 (gethash msg *type-signature-table*)) 364 ;; Merge class with existing classes for this type signature 365 (progn 366 (setf (msg-desc-classes msgdesc) 367 (add-class-to-msg-desc c (msg-desc-classes msgdesc))) 368 msgdesc)))))) 369 370 371 ;;; Merge a new class into the current list of class in a message 372 ;;; descriptor. 373 374 (defun add-class-to-msg-desc (class classes) 375 (flet ((objc-subclass-p (c1 c2) 376 (if (eql c1 c2) 377 t 378 (loop for s = (pref c1 :objc_class.super_class) 379 then (pref s :objc_class.super_class) 380 until (eql s (%null-ptr)) 381 when (eql s c2) return t)))) 382 (cond ((null classes) (list class)) 383 ((objc-subclass-p class (first classes)) classes) 384 ((objc-subclass-p (first classes) class) 385 (add-class-to-msg-desc class (rest classes))) 386 (t (cons (first classes) (add-class-to-msg-desc class (rest classes))))))) 387 338 388 339 389 ;;; Rescan all loaded modules for methods and update the type signature … … 343 393 (note-all-library-methods 344 394 #'(lambda (m c) 345 (declare (ignore c))346 395 (#+gnu-objc progn #+apple-objc progn 347 396 ;; Some libraries seem to have methods with bogus-looking 348 397 ;; type signatures 349 (update-type-signatures-for-method m )))))350 351 352 ;;; Return the type signature(s) associated with MSG353 354 (defun message- type-signatures (msg)398 (update-type-signatures-for-method m c))))) 399 400 401 ;;; Return the message descriptor(s) associated with MSG 402 403 (defun message-descriptors (msg) 355 404 (values (gethash msg *type-signature-table*))) 356 405 … … 541 590 542 591 ;;; Convert a Lisp object X to a desired foreign type FTYPE 543 ;;; Currently only handles T/NIL => #$YES/#$NO and NIL => (%null-ptr) 544 ;;; NOTE: Many conversions are done by %FF-CALL 545 546 (defmacro coerce-to-address (x) 547 (let ((x-temp (gensym))) 548 `(let ((,x-temp ,x)) 549 (if (null ,x-temp) (%null-ptr) ,x-temp)))) 592 ;;; The following conversions are currently done: 593 ;;; - T/NIL => #$YES/#$NO 594 ;;; - NIL => (%null-ptr) 595 ;;; - Lisp string => NSString 596 ;;; - Lisp numbers => SINGLE-FLOAT when possible 550 597 551 598 (defmacro coerce-to-bool (x) … … 553 600 `(let ((,x-temp ,x)) 554 601 (if (or (eq ,x-temp 0) (null ,x-temp)) #$NO #$YES)))) 555 602 603 (defmacro coerce-to-address (x) 604 (let ((x-temp (gensym))) 605 `(let ((,x-temp ,x)) 606 (cond ((null ,x-temp) (%null-ptr)) 607 ((stringp ,x-temp) (%make-nsstring ,x-temp)) 608 (t ,x-temp))))) 609 556 610 (defmacro coerce-to-foreign-type (x ftype) 557 611 (cond ((and (constantp x) (constantp ftype)) 558 612 (case ftype 559 (:id (if (null x) `(%null-ptr) (coerce-to-address x))) 613 (:id (cond ((null x) `(%null-ptr)) 614 ((stringp x) `(%make-nsstring ,x)) 615 (t (coerce-to-address x)))) 560 616 (:char (coerce-to-bool x)) 617 (:single-float (coerce x 'single-float)) 561 618 (t x))) 562 619 ((constantp ftype) … … 564 621 (:id `(coerce-to-address ,x)) 565 622 (:char `(coerce-to-bool ,x)) 623 (:single-float `(coerce ,x 'single-float)) 566 624 (t x))) 567 625 (t `(case ,(if (atom ftype) ftype) 568 626 (:id (coerce-to-address ,x)) 569 627 (:char (coerce-to-bool ,x)) 628 (:single-float (coerce ,x 'single-float)) 570 629 (t ,x))))) 571 630 … … 584 643 585 644 (defun convert-to-argspecs (argtypes result-ftype args evalargs) 645 (setq argtypes (mapcar #'fudge-objc-type argtypes)) 646 (setq result-ftype (fudge-objc-type result-ftype)) 586 647 (flet ((foo (ftype &optional for-result) 587 (let* ((translated 588 (if for-result 589 (translate-foreign-result-type ftype) 590 (translate-foreign-arg-type ftype)))) 648 (let* ((translated 649 (if (member ftype 650 '(:unsigned-doubleword :signed-doubleword) 651 :test #'eq) 652 ftype 653 (if for-result 654 (translate-foreign-result-type ftype) 655 (translate-foreign-arg-type ftype))))) 591 656 (if (and (consp translated) (eq (first translated) :record)) 592 657 #+apple-objc … … 682 747 ;;;; Invoking ObjC Methods ;;;; 683 748 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 749 684 750 ;;; Check that the correct number of ARGs have been supplied to the given MSG 685 751 … … 766 832 ;; If only the message is known at compile-time, we can still build a 767 833 ;; direct call if the type signature is unique 768 (let* ((m tsigs (message-type-signatures msg)))834 (let* ((msgdescs (message-descriptors msg))) 769 835 (cond 770 ((null m tsigs) (error "Unknown message: ~S" msg))771 ((null (rest m tsigs))836 ((null msgdescs) (error "Unknown message: ~S" msg)) 837 ((null (rest msgdescs)) 772 838 ;; If MSG has a unique type signature at compile-time, build a 773 839 ;; call for that signature 774 (let* ((mtsig ( first mtsigs))840 (let* ((mtsig (msg-desc-type-signature (first msgdescs))) 775 841 (result-type (first mtsig)) 776 842 (argtypes (rest mtsig)) … … 797 863 ;; If the type signature is not unique, build a general call for now 798 864 (t (if (null super) 799 800 `(%send ,o ,msg ,@args)801 802 803 804 865 (if (null s) 866 `(%send ,o ,msg ,@args) 867 `(%send/stret ,o ,msg ,@args)) 868 (if (null s) 869 `(%send-super ,msg ,@args) 870 `(%send-super/stret ,s ,msg ,@args)))))))))) 805 871 806 872 … … 970 1036 971 1037 972 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;973 ;;;; Defining CLOS Subclasses of ObjC Classes ;;;;974 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;975 976 977 978 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;979 ;;;; Defining CLOS Methods on ObjC Classes ;;;;980 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;981 982 983 1038 ;;; Provide the BRIDGE module 984 1039
Note:
See TracChangeset
for help on using the changeset viewer.
