/[slime]/slime/swank.lisp
ViewVC logotype

Diff of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.253 by heller, Tue Oct 19 06:14:17 2004 UTC revision 1.254 by mbaringer, Mon Oct 25 16:19:32 2004 UTC
# Line 2635  NIL is returned if the list is circular. Line 2635  NIL is returned if the list is circular.
2635              ("Dimensions" (array-dimensions array))              ("Dimensions" (array-dimensions array))
2636              ("Its element type is" (array-element-type array))              ("Its element type is" (array-element-type array))
2637              ("Total size" (array-total-size array))              ("Total size" (array-total-size array))
             ("Fill pointer" (fill-pointer array))  
2638              ("Adjustable" (adjustable-array-p array)))              ("Adjustable" (adjustable-array-p array)))
2639               (when (array-has-fill-pointer-p array)
2640                 `(("Fill pointer" (fill-pointer array))))
2641             '("Contents:" (:newline))             '("Contents:" (:newline))
2642             (let ((darray (make-array (array-total-size array)             (let ((darray (make-array (array-total-size array)
2643                                         :element-type (array-element-type array)
2644                                       :displaced-to array                                       :displaced-to array
2645                                       :displaced-index-offset 0)))                                       :displaced-index-offset 0)))
2646               (loop for e across darray               (loop for e across darray
2647                     for i from 0                     for i from 0
2648                     collect (label-value-line i e))))))                     append (label-value-line i e))))))
2649    
2650  (defmethod inspect-for-emacs ((char character) (inspector t))  (defmethod inspect-for-emacs ((char character) (inspector t))
2651    (declare (ignore inspector))    (declare (ignore inspector))
# Line 2728  NIL is returned if the list is circular. Line 2730  NIL is returned if the list is circular.
2730            `("Name: " (:value ,(function-name f)) (:newline)            `("Name: " (:value ,(function-name f)) (:newline)
2731              "Its argument list is: " ,(inspector-princ (arglist f))              "Its argument list is: " ,(inspector-princ (arglist f))
2732              (:newline)              (:newline)
2733                ,@(when (function-lambda-expression f)
2734                    `("Lambda Expression: " (:value ,(function-lambda-expression f)) (:newline)))
2735              ,@(when (documentation f t)              ,@(when (documentation f t)
2736                  `("Documentation:" (:newline) ,(documentation f t) (:newline))))))                  `("Documentation:" (:newline) ,(documentation f t) (:newline))))))
2737    
# Line 2778  NIL is returned if the list is circular. Line 2782  NIL is returned if the list is circular.
2782                                                      (swank-mop:slot-definition-name slot)))                                                      (swank-mop:slot-definition-name slot)))
2783                                               direct-slots)                                               direct-slots)
2784                                      slot)                                      slot)
2785                   collect `(:value ,slot-def ,(inspector-princ (swank-mop:slot-definition-name slot-def)))                   collect `(:value ,slot-def ,(inspector-princ (swank-mop:slot-definition-name slot-def)))
2786                   collect " = "                   collect " = "
2787                   if (slot-boundp o (swank-mop:slot-definition-name slot-def))                   if (slot-boundp o (swank-mop:slot-definition-name slot-def))
2788                     collect `(:value ,(slot-value o (swank-mop:slot-definition-name slot-def)))                     collect `(:value ,(slot-value o (swank-mop:slot-definition-name slot-def)))
# Line 2786  NIL is returned if the list is circular. Line 2790  NIL is returned if the list is circular.
2790                     collect "#<unbound>"                     collect "#<unbound>"
2791                   collect '(:newline)))))                   collect '(:newline)))))
2792    
2793    (defvar *gf-method-getter* 'methods-by-applicability
2794      "This function is called to get the methods of a generic function.
2795    The default returns the method sorted by applicability.
2796    See `methods-by-applicability'.")
2797    
2798    ;;; Largely inspired by (+ copied from) the McCLIM listener
2799    (defun methods-by-applicability (gf)
2800      "Return methods ordered by qualifiers, then by most specific argument types.
2801    
2802    Qualifier ordering is: :before, :around, primary, and :after.
2803    We use the length of the class precedence list to determine which type is
2804    more specific."
2805      ;;FIXME: How to deal with argument-precedence-order?
2806      (let ((methods (copy-list (swank-mop:generic-function-methods gf))))
2807        ;; sorter function (most specific is defined as smaller)
2808        (flet ((method< (meth1 meth2)
2809                 ;; First ordering rule is by qualifiers, that is :before-methods
2810                 ;; come before :around methods, before primary methods, before
2811                 ;; :after methods, other qualifiers are treated like none at all
2812                 ;; (so like primary methods)
2813                 (let ((qualifier-order '(:before :around nil :after)))
2814                   (let ((q1 (or (position (first (swank-mop:method-qualifiers meth1)) qualifier-order) 2))
2815                         (q2 (or (position (first (swank-mop:method-qualifiers meth2)) qualifier-order) 2)))
2816                     (cond ((< q1 q2) (return-from method< t))
2817                           ((> q1 q2) (return-from method< nil)))))
2818                 ;; If qualifiers are equal, go by arguments
2819                 (loop for sp1 in (swank-mop:method-specializers meth1)
2820                       for sp2 in (swank-mop:method-specializers meth2)
2821                       do (cond
2822                            ((eq sp1 sp2)) ;; continue comparision
2823                            ;; an eql specializer is most specific
2824                            ((typep sp1 'swank-mop:eql-specializer)
2825                             (return-from method< t))
2826                            ((typep sp2 'swank-mop:eql-specializer)
2827                             (return-from method< nil))
2828                            ;; otherwise the longer the CPL the more specific
2829                            ;; the specializer is
2830                            ;; FIXME: Taking the CPL as indicator has the problem
2831                            ;; that unfinalized classes are most specific. Can we pick
2832                            ;; a reasonable default or do something with SUBTYPEP ?
2833                            (t (let ((l1 (if (swank-mop:class-finalized-p sp1)
2834                                             (length (swank-mop:class-precedence-list sp1))
2835                                             0))
2836                                     (l2 (if (swank-mop:class-finalized-p sp2)
2837                                             (length (swank-mop:class-precedence-list sp2))
2838                                             0)))
2839                                 (cond
2840                                   ((> l1 l2)
2841                                    (return-from method< t))
2842                                   ((< l1 l2)
2843                                    (return-from method< nil))))))
2844                       finally (return nil))))
2845          (declare (dynamic-extent #'method<))
2846          (sort methods #'method<))))
2847    
2848    (defun abbrev-doc (doc &optional (maxlen 80))
2849      "Return the first sentence of DOC, but not more than MAXLAN characters."
2850      (subseq doc 0 (min (1+ (or (position #\. doc) (1- maxlen)))
2851                             maxlen
2852                             (length doc))))
2853    
2854  (defmethod inspect-for-emacs ((gf standard-generic-function) (inspector t))  (defmethod inspect-for-emacs ((gf standard-generic-function) (inspector t))
2855    (declare (ignore inspector))    (declare (ignore inspector))
2856    (values "A generic function."    (values "A generic function."
# Line 2797  NIL is returned if the list is circular. Line 2862  NIL is returned if the list is circular.
2862              "It uses " (:value ,(swank-mop:generic-function-method-combination gf)) " method combination." (:newline)              "It uses " (:value ,(swank-mop:generic-function-method-combination gf)) " method combination." (:newline)
2863              "Methods: " (:newline)              "Methods: " (:newline)
2864              ,@(loop              ,@(loop
2865                   for method in (swank-mop:generic-function-methods gf)                   for method in (funcall *gf-method-getter* gf)
2866                   collect `(:value ,method ,(inspector-princ                   collect `(:value ,method ,(inspector-princ
2867                                              ;; drop the first element (the name of the generic function)                                              ;; drop the first element (the name of the generic function)
2868                                              (cdr (method-for-inspect-value method))))                                              (cdr (method-for-inspect-value method))))
2869                   collect " "                   collect " "
2870                   collect (let ((meth method))                   collect (let ((meth method))
2871                             `(:action "[remove method]" ,(lambda () (remove-method gf meth))))                             `(:action "[remove method]" ,(lambda () (remove-method gf meth))))
2872                     collect '(:newline)
2873                     if (documentation method t)
2874                     collect "  Documentation: " and
2875                     collect (abbrev-doc (documentation method t)) and
2876                   collect '(:newline)))))                   collect '(:newline)))))
2877    
2878  (defmethod inspect-for-emacs ((method standard-method) (inspector t))  (defmethod inspect-for-emacs ((method standard-method) (inspector t))
# Line 2827  NIL is returned if the list is circular. Line 2896  NIL is returned if the list is circular.
2896    
2897  (defmethod inspect-for-emacs ((class standard-class) (inspector t))  (defmethod inspect-for-emacs ((class standard-class) (inspector t))
2898    (declare (ignore inspector))    (declare (ignore inspector))
2899    (values "A stadard class."    (values "A class."
2900            `("Name: " (:value ,(class-name class))            `("Name: " (:value ,(class-name class))
2901              (:newline)              (:newline)
2902              "Super classes: " ,@(common-seperated-spec (swank-mop:class-direct-superclasses class))              "Super classes: "
2903                ,@(common-seperated-spec (swank-mop:class-direct-superclasses class))
2904              (:newline)              (:newline)
2905              "Direct Slots: " ,@(common-seperated-spec (swank-mop:class-direct-slots class)              "Direct Slots: "
2906                                                        (lambda (slot)              ,@(common-seperated-spec
2907                                                          `(:value ,slot ,(inspector-princ                 (swank-mop:class-direct-slots class)
2908                                                                           (swank-mop:slot-definition-name slot)))))                 (lambda (slot)
2909              (:newline)                   `(:value ,slot ,(inspector-princ (swank-mop:slot-definition-name slot)))))
2910              "Effective Slots: " ,@(if (swank-mop:class-finalized-p class)              (:newline)
2911                                        (common-seperated-spec (swank-mop:class-slots class)              "Effective Slots: "
2912                                                               (lambda (slot)              ,@(if (swank-mop:class-finalized-p class)
2913                                                                 `(:value ,slot ,(inspector-princ                    (common-seperated-spec
2914                                                                                  (swank-mop:slot-definition-name slot)))))                     (swank-mop:class-slots class)
2915                                        '("#<N/A (class not finalized)>"))                     (lambda (slot)
2916                         `(:value ,slot ,(inspector-princ
2917                                          (swank-mop:slot-definition-name slot)))))
2918                      '("#<N/A (class not finalized)>"))
2919              (:newline)              (:newline)
2920              ,@(when (documentation class t)              ,@(when (documentation class t)
2921                  `("Documentation:" (:newline)                  `("Documentation:" (:newline) ,(documentation class t) (:newline)))
2922                    ,(documentation class t) (:newline)))              "Sub classes: "
2923              "Sub classes: " ,@(common-seperated-spec (swank-mop:class-direct-subclasses class)              ,@(common-seperated-spec (swank-mop:class-direct-subclasses class)
2924                                                       (lambda (sub)                                       (lambda (sub)
2925                                                         `(:value ,sub ,(inspector-princ (class-name sub)))))                                         `(:value ,sub ,(inspector-princ (class-name sub)))))
2926              (:newline)              (:newline)
2927              "Precedence List: " ,@(if (swank-mop:class-finalized-p class)              "Precedence List: "
2928                                        (common-seperated-spec (swank-mop:class-precedence-list class)              ,@(if (swank-mop:class-finalized-p class)
2929                                                               (lambda (class)                    (common-seperated-spec (swank-mop:class-precedence-list class)
2930                                                                 `(:value ,class ,(inspector-princ (class-name class)))))                                           (lambda (class)
2931                                        '("#<N/A (class not finalized)>"))                                             `(:value ,class ,(inspector-princ (class-name class)))))
2932                      '("#<N/A (class not finalized)>"))
2933              (:newline)              (:newline)
2934              ,@(when (swank-mop:specializer-direct-methods class)              ,@(when (swank-mop:specializer-direct-methods class)
2935                 `("It is used as a direct specializer in the following methods:" (:newline)                 `("It is used as a direct specializer in the following methods:" (:newline)
2936                   ,@(loop                   ,@(loop
2937                        for method in (swank-mop:specializer-direct-methods class)                        for method in (sort (copy-list (swank-mop:specializer-direct-methods class))
2938                                              #'string< :key (lambda (x)
2939                                                               (symbol-name
2940                                                                (let ((name (swank-mop::generic-function-name
2941                                                                             (swank-mop::method-generic-function x))))
2942                                                                  (if (symbolp name) name (second name))))))
2943                          collect "  "
2944                        collect `(:value ,method ,(inspector-princ (method-for-inspect-value method)))                        collect `(:value ,method ,(inspector-princ (method-for-inspect-value method)))
2945                          collect '(:newline)
2946                          if (documentation method t)
2947                          collect "    Documentation: " and
2948                          collect (abbrev-doc (documentation method t)) and
2949                        collect '(:newline))))                        collect '(:newline))))
2950              "Prototype: " ,(if (swank-mop:class-finalized-p class)              "Prototype: " ,(if (swank-mop:class-finalized-p class)
2951                                 `(:value ,(swank-mop:class-prototype class))                                 `(:value ,(swank-mop:class-prototype class))

Legend:
Removed from v.1.253  
changed lines
  Added in v.1.254

  ViewVC Help
Powered by ViewVC 1.1.5