Changeset 12741
- Timestamp:
- Sep 2, 2009, 4:58:16 PM (12 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/source/objc-bridge/bridge.lisp
r12549 r12741 759 759 760 760 (defun objc-method-signature-info (sig) 761 (or (gethash sig *objc-method-signatures*) 762 (setf (gethash sig *objc-method-signatures*) 763 (make-objc-method-signature-info 764 :type-signature sig 765 :function (compile-send-function-for-signature sig) 766 :super-function (%compile-send-function-for-signature sig t))))) 761 (values 762 (or (gethash sig *objc-method-signatures*) 763 (setf (gethash sig *objc-method-signatures*) 764 (make-objc-method-signature-info 765 :type-signature sig 766 :function (compile-send-function-for-signature sig) 767 :super-function (%compile-send-function-for-signature sig t)))))) 768 769 (defmethod make-load-form ((siginfo objc-method-signature-info) &optional env) 770 (declare (ignore env)) 771 `(objc-method-signature-info ',(objc-method-signature-info-type-signature siginfo))) 767 772 768 773 (defun concise-foreign-type (ftype) … … 817 822 (defmethod shared-initialize :after ((gf objc-dispatch-function) slot-names &key message-info &allow-other-keys) 818 823 (declare (ignore slot-names)) 819 (if message-info 820 (let* ((ambiguous-methods (getf (objc-message-info-flags message-info) :ambiguous)) 821 (selector (objc-message-info-selector message-info)) 822 (first-method (car (objc-message-info-methods message-info)))) 823 (lfun-bits gf (dpb (1+ (objc-message-info-req-args message-info)) 824 $lfbits-numreq 825 (logior (ash 826 (if (getf (objc-message-info-flags message-info) 827 :accepts-varargs) 828 1 829 0) 830 $lfbits-rest-bit) 831 (logandc2 (lfun-bits gf) (ash 1 $lfbits-aok-bit))))) 832 (flet ((signature-function-for-method (m) 833 (let* ((signature-info (objc-method-info-signature-info m))) 834 (or (objc-method-signature-info-function signature-info) 835 (setf (objc-method-signature-info-function signature-info) 836 (compile-send-function-for-signature 837 (objc-method-signature-info-type-signature signature-info))))))) 838 839 (if (null ambiguous-methods) 840 ;; Pick an arbitrary method, since all methods have the same 841 ;; signature. 842 (let* ((function (signature-function-for-method first-method))) 843 (set-funcallable-instance-function 844 gf 845 (nfunction 846 send-unambiguous-message 847 (lambda (receiver &rest args) 848 (declare (dynamic-extent args)) 849 (or (check-receiver receiver) 850 (with-ns-exceptions-as-errors 851 (apply function receiver selector args))))))) 852 (let* ((protocol-pairs (mapcar #'(lambda (pm) 853 (cons (lookup-objc-protocol 854 (objc-method-info-class-name pm)) 855 (signature-function-for-method 856 pm))) 857 (objc-message-info-protocol-methods message-info))) 858 (method-pairs (mapcar #'(lambda (group) 859 (cons (mapcar #'(lambda (m) 860 (get-objc-method-info-class m)) 861 group) 862 (signature-function-for-method (car group)))) 863 (objc-message-info-ambiguous-methods message-info))) 864 (default-function (if method-pairs 865 (prog1 (cdar (last method-pairs)) 866 (setq method-pairs (nbutlast method-pairs))) 867 (prog1 (cdr (last protocol-pairs)) 868 (setq protocol-pairs (nbutlast protocol-pairs)))))) 869 (set-funcallable-instance-function 870 gf 871 (nfunction 872 send-unambiguous-message 873 (lambda (receiver &rest args) 874 (declare (dynamic-extent args)) 875 (or (check-receiver receiver) 824 (with-slots (name) gf 825 (if message-info 826 (let* ((ambiguous-methods (getf (objc-message-info-flags message-info) :ambiguous)) 827 (selector (objc-message-info-selector message-info)) 828 (first-method (car (objc-message-info-methods message-info)))) 829 (lfun-bits gf (dpb (1+ (objc-message-info-req-args message-info)) 830 $lfbits-numreq 831 (logior (ash 832 (if (getf (objc-message-info-flags message-info) 833 :accepts-varargs) 834 1 835 0) 836 $lfbits-rest-bit) 837 (logandc2 (lfun-bits gf) (ash 1 $lfbits-aok-bit))))) 838 (flet ((signature-function-for-method (m) 839 (let* ((signature-info (objc-method-info-signature-info m))) 840 (or (objc-method-signature-info-function signature-info) 841 (setf (objc-method-signature-info-function signature-info) 842 (compile-send-function-for-signature 843 (objc-method-signature-info-type-signature signature-info))))))) 844 (if (null ambiguous-methods) 845 ;; Pick an arbitrary method, since all methods have the same 846 ;; signature. 847 (set-funcallable-instance-function 848 gf 849 (compile-named-function 850 `(lambda (receiver &rest args) 851 (declare (dynamic-extent args)) 852 (or (check-receiver receiver) 853 (with-ns-exceptions-as-errors 854 (apply (objc-method-signature-info-function 855 (load-time-value 856 (objc-method-info-signature-info ,first-method))) 857 receiver ,selector args)))) 858 :name `(:objc-dispatch ,name))) 859 (let* ((protocol-pairs (mapcar #'(lambda (pm) 860 (cons (lookup-objc-protocol 861 (objc-method-info-class-name pm)) 862 (objc-method-info-signature-info 863 pm))) 864 (objc-message-info-protocol-methods message-info))) 865 (method-pairs (mapcar #'(lambda (group) 866 (cons (mapcar #'(lambda (m) 867 (get-objc-method-info-class m)) 868 group) 869 (objc-method-info-signature-info (car group)))) 870 (objc-message-info-ambiguous-methods message-info))) 871 (default-function-info (if method-pairs 872 (prog1 (cdar (last method-pairs)) 873 (setq method-pairs (nbutlast method-pairs))) 874 (prog1 (cdr (last protocol-pairs)) 875 (setq protocol-pairs (nbutlast protocol-pairs)))))) 876 (set-funcallable-instance-function 877 gf 878 (compile-named-function 879 `(lambda (receiver &rest args) 880 (declare (dynamic-extent args)) 881 (or (check-receiver receiver) 876 882 (let* ((function 877 (or (dolist (pair protocol-pairs) 878 (when (conforms-to-protocol receiver (car pair)) 879 (return (cdr pair)))) 880 (block m 881 (dolist (pair method-pairs default-function) 882 (dolist (class (car pair)) 883 (when (typep receiver class) 884 (return-from m (cdr pair))))))))) 883 (objc-method-signature-info-function 884 (or (dolist (pair ',protocol-pairs) 885 (when (conforms-to-protocol receiver (car pair)) 886 (return (cdr pair)))) 887 (block m 888 (dolist (pair ',method-pairs ,default-function-info) 889 (dolist (class (car pair)) 890 (when (typep receiver class) 891 (return-from m (cdr pair)))))))))) 885 892 (with-ns-exceptions-as-errors 886 (apply function receiver selector args)))))))))))887 (with-slots (name) gf893 (apply function receiver ,selector args))))) 894 :name `(:objc-dispatch ,name))))))) 888 895 (set-funcallable-instance-function 889 896 gf
Note: See TracChangeset
for help on using the changeset viewer.