Evenson merge 20170423a

contrib/swank-fancy-inspector.lisp

@@ -9,6 +9,15 @@
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (swank-require :swank-util))
 
+(defun symbol-info (symbol)
+  (list (and (constantp symbol) (symbol-value symbol))
+	  (and (fboundp symbol) (symbol-function symbol))
+	  (and (boundp symbol) (symbol-value symbol))
+	  (and (find-class symbol nil) (find-class symbol))
+	  (find-package symbol)
+	  #+armedbear (get symbol 'sys::structure-definition)))
+
+
 (defmethod emacs-inspect ((symbol symbol))
   (let ((package (symbol-package symbol)))
     (multiple-value-bind (_symbol status)
@@ -39,9 +48,9 @@
         ;; Function
         (if (fboundp symbol)
             (append (if (macro-function symbol)
-                        `("It a macro with macro-function: "
+                        `((:label "It a macro with macro-function: ")
                           (:value ,(macro-function symbol)))
-                        `("It is a function: "
+                        `((:label "It is a function: ")
                           (:value ,(symbol-function symbol))))
                     `(" " (:action "[unbind]"
                                    ,(lambda () (fmakunbound symbol))))
@@ -61,8 +70,8 @@
         ;;
         ;; Package
         (if package
-            `("It is " ,(string-downcase (string status))
-                       " to the package: "
+            `((:label "It is ") (:label ,(string-downcase (string status)))
+	      (:label " to the package: ")
                        (:value ,package ,(package-name package))
                        ,@(if (eq :internal status)
                              `(" "
@@ -89,8 +98,44 @@
         ;; More package
         (if (find-package symbol)
             (label-value-line "It names the package" (find-package symbol)))
+
+	;; Same string
+	(lines-for-symbol-in-other-packages symbol)
+
         (inspect-type-specifier symbol)))))
 
+(defun lines-for-symbol-in-other-packages (symbol)
+  (let ((others
+         (loop for p in (list-all-packages) 
+            for candidate = (find-symbol (string symbol) p) 
+            for found = (and (not (null candidate)) 
+                             (eq (symbol-package candidate) p)
+                             (not (eq (symbol-package symbol) (symbol-package candidate)))
+                             candidate)
+            for (constant function value class package structure) = (and found (symbol-info found))
+            for specs  = (and found
+                              (append (when value
+                                        `((:value ,value
+                                                  ,(if constant "constant" "bound") ", ")))
+                                      (when function
+                                        `((:value ,function "fbound" ", ")))
+                                      (when package
+                                        `((:value ,package "package" ", ")))
+                                      (when class
+                                        `((:value ,class "class") ", "))
+                                      (when structure
+                                        `((:value ,structure "structure") ", "))))
+            when found
+            collect
+              (let ((specs (butlast specs)))
+                (list* (list :value found (let ((*package* (find-package :keyword))) (format nil "~s" found)))
+                       (if specs ": " "")
+                       (append specs '((:newline))))))))
+    (if others
+        `("In other packages: " 
+          (:newline)  
+          ,@(apply 'append others)))))
+
 #-sbcl
 (defun inspect-type-specifier (symbol)
   (declare (ignore symbol)))
@@ -139,23 +184,23 @@
     (cond ((not docstring) nil)
           ((< (+ (length label) (length docstring))
               75)
-           (list label ": " docstring '(:newline)))
+           (list `(:label ,label) ": " docstring '(:newline)))
           (t
-           (list label ":" '(:newline) "  " docstring '(:newline))))))
+           (list `(:label ,label) ":" '(:newline) "  " docstring '(:newline))))))
 
 (unless (find-method #'emacs-inspect '() (list (find-class 'function)) nil)
   (defmethod emacs-inspect ((f function))
     (inspect-function f)))
 
 (defun inspect-function (f)
   (append
-   (label-value-line "Name" (function-name f))
-   `("Its argument list is: "
+   (list '(:label "Name:") (function-name f) '(:newline))
+   `((:label "Argument list: ")
      ,(inspector-princ (arglist f)) (:newline))
    (docstring-ispec "Documentation" f t)
    (if (function-lambda-expression f)
        (label-value-line "Lambda Expression"
-                         (function-lambda-expression f)))))
+			 (function-lambda-expression f)))))
 
 (defun method-specializers-for-inspect (method)
   "Return a \"pretty\" list of the method's specializers. Normal
@@ -341,7 +386,7 @@ See `methods-by-applicability'.")
       ,@ (case (ref grouping-kind)
            (:all
             `((:newline)
-              "All Slots:"
+              (:label "All Slots:")
               (:newline)
               ,@(make-slot-listing checklist object class
                                    effective-slots direct-slots
@@ -451,15 +496,15 @@ See `methods-by-applicability'.")
 
 
 (defmethod emacs-inspect ((gf standard-generic-function))
-  (flet ((lv (label value) (label-value-line label value)))
+  (flet ((lv (label value) `((:label ,label)": " (:value  ,value ,(princ-to-string value)) (:newline))))
     (append
       (lv "Name" (swank-mop:generic-function-name gf))
       (lv "Arguments" (swank-mop:generic-function-lambda-list gf))
       (docstring-ispec "Documentation" gf t)
       (lv "Method class" (swank-mop:generic-function-method-class gf))
       (lv "Method combination"
           (swank-mop:generic-function-method-combination gf))
-      `("Methods: " (:newline))
+      `((:label "Methods: ") (:newline))
       (loop for method in (funcall *gf-method-getter* gf) append
             `((:value ,method ,(inspector-princ
                                ;; drop the name of the GF
@@ -475,23 +520,23 @@ See `methods-by-applicability'.")
 
 (defmethod emacs-inspect ((method standard-method))
   `(,@(if (swank-mop:method-generic-function method)
-          `("Method defined on the generic function "
+          `((:label "Method defined on the generic function ")
             (:value ,(swank-mop:method-generic-function method)
                     ,(inspector-princ
                       (swank-mop:generic-function-name
                        (swank-mop:method-generic-function method)))))
           '("Method without a generic function"))
       (:newline)
       ,@(docstring-ispec "Documentation" method t)
-      "Lambda List: " (:value ,(swank-mop:method-lambda-list method))
+      (:label "Lambda List: ") (:value ,(swank-mop:method-lambda-list method))
       (:newline)
-      "Specializers: " (:value ,(swank-mop:method-specializers method)
+      (:label "Specializers: ") (:value ,(swank-mop:method-specializers method)
                                ,(inspector-princ
                                  (method-specializers-for-inspect method)))
       (:newline)
-      "Qualifiers: " (:value ,(swank-mop:method-qualifiers method))
+      (:label "Qualifiers: ") (:value ,(swank-mop:method-qualifiers method))
       (:newline)
-      "Method function: " (:value ,(swank-mop:method-function method))
+      (:label "Method function: ") (:value ,(swank-mop:method-function method))
       (:newline)
       ,@(all-slots-for-inspector method)))
 
@@ -508,22 +553,22 @@ See `methods-by-applicability'.")
                  (second name)))))))
 
 (defmethod emacs-inspect ((class standard-class))
-  `("Name: "
+  `((:label "Name: ")
     (:value ,(class-name class))
     (:newline)
-    "Super classes: "
-    ,@(common-seperated-spec (swank-mop:class-direct-superclasses class))
+    (:label "Super classes: ")
+    ,@(common-separated-spec (swank-mop:class-direct-superclasses class))
     (:newline)
-    "Direct Slots: "
-    ,@(common-seperated-spec
+    (:label "Direct Slots: ")
+    ,@(common-separated-spec
        (swank-mop:class-direct-slots class)
        (lambda (slot)
          `(:value ,slot ,(inspector-princ
                           (swank-mop:slot-definition-name slot)))))
     (:newline)
-    "Effective Slots: "
+    (:label "Effective Slots: ")
     ,@(if (swank-mop:class-finalized-p class)
-          (common-seperated-spec
+          (common-separated-spec
            (swank-mop:class-slots class)
            (lambda (slot)
              `(:value ,slot ,(inspector-princ
@@ -534,16 +579,16 @@ See `methods-by-applicability'.")
     (:newline)
     ,@(let ((doc (documentation class t)))
         (when doc
-          `("Documentation:" (:newline) ,(inspector-princ doc) (:newline))))
+          `((:label "Documentation:") (:newline) ,(inspector-princ doc) (:newline))))
     "Sub classes: "
-    ,@(common-seperated-spec (swank-mop:class-direct-subclasses class)
+    ,@(common-separated-spec (swank-mop:class-direct-subclasses class)
                              (lambda (sub)
                                `(:value ,sub
                                         ,(inspector-princ (class-name sub)))))
     (:newline)
-    "Precedence List: "
+    (:label "Precedence List: ")
     ,@(if (swank-mop:class-finalized-p class)
-          (common-seperated-spec
+          (common-separated-spec
            (swank-mop:class-precedence-list class)
            (lambda (class)
              `(:value ,class ,(inspector-princ (class-name class)))))
@@ -554,16 +599,16 @@ See `methods-by-applicability'.")
           (:newline)
           ,@(loop
               for method in (specializer-direct-methods class)
+	      for method-spec = (method-for-inspect-value method)
               collect "  "
-              collect `(:value ,method
-                               ,(inspector-princ
-                                 (method-for-inspect-value method)))
+	      collect `(:value ,method ,(inspector-princ (car method-spec)))
+              collect `(:value ,method ,(format nil " (~{~a~^ ~})" (cdr method-spec)))
               collect '(:newline)
               if (documentation method t)
               collect "    Documentation: " and
               collect (abbrev-doc (documentation method t)) and
               collect '(:newline))))
-    "Prototype: " ,(if (swank-mop:class-finalized-p class)
+    (:label "Prototype: ") ,(if (swank-mop:class-finalized-p class)
                        `(:value ,(swank-mop:class-prototype class))
                        '"#<N/A (class not finalized)>")
     (:newline)
@@ -574,19 +619,19 @@ See `methods-by-applicability'.")
     (:value ,(swank-mop:slot-definition-name slot))
     (:newline)
     ,@(when (swank-mop:slot-definition-documentation slot)
-        `("Documentation:" (:newline)
+        `((:label "Documentation:") (:newline)
                            (:value ,(swank-mop:slot-definition-documentation
                                      slot))
                            (:newline)))
-    "Init args: "
+    (:label "Init args: ")
     (:value ,(swank-mop:slot-definition-initargs slot))
     (:newline)
-    "Init form: "
+    (:label "Init form: ")
     ,(if (swank-mop:slot-definition-initfunction slot)
          `(:value ,(swank-mop:slot-definition-initform slot))
          "#<unspecified>")
     (:newline)
-    "Init function: "
+    (:label "Init function: ")
     (:value ,(swank-mop:slot-definition-initfunction slot))
     (:newline)
     ,@(all-slots-for-inspector slot)))
@@ -761,21 +806,21 @@ SPECIAL-OPERATOR groups."
           external-symbols     (sort external-symbols #'string<)
           inherited-symbols    (sort inherited-symbols #'string<))
     `("" ;; dummy to preserve indentation.
-      "Name: " (:value ,package-name) (:newline)
+      (:label "Name: ") (:value ,package-name) (:newline)
 
-      "Nick names: " ,@(common-seperated-spec package-nicknames) (:newline)
+      (:label "Nick names: ") ,@(common-separated-spec package-nicknames) (:newline)
 
       ,@(when (documentation package t)
-          `("Documentation:" (:newline)
+          `((:label "Documentation:") (:newline)
                              ,(documentation package t) (:newline)))
 
-      "Use list: " ,@(common-seperated-spec
+      "Uses packages: " ,@(common-separated-spec
                       package-use-list
                       (lambda (package)
                         `(:value ,package ,(package-name package))))
       (:newline)
 
-      "Used by list: " ,@(common-seperated-spec
+      (:label "Used by packages: ") ,@(common-separated-spec
                           package-used-by-list
                           (lambda (package)
                             `(:value ,package ,(package-name package))))
@@ -986,7 +1031,7 @@ SPECIAL-OPERATOR groups."
                 (make-file-stream-ispec stream))
               content))))
 
-(defun common-seperated-spec (list &optional (callback (lambda (v)
+(defun common-separated-spec (list &optional (callback (lambda (v)
                                                          `(:value ,v))))
   (butlast
    (loop

contrib/swank-kawa.scm

@@ -809,6 +809,12 @@
          (l (values-to-list (eval form env))))
     (apply cat (map pprint-to-string l))))
 
+(defslimefun eval-and-grab-output (env string)
+  (let ((form (read (open-input-string string))))
+    (let-values ((values (eval form env)))
+      (list ""
+            (format #f "~{~S~^~%~}" values)))))
+
 (df call-with-abort (f)
   (try-catch (f) (ex <throwable> (exception-message ex))))
 

packages.lisp

@@ -60,6 +60,15 @@
            profile-reset
            profile-package
 
+	   with-struct*
+	   lcons
+	   lcons*
+	   lcons-cdr
+	   llist-range
+	   llist-skip
+	   llist-take
+	   iline
+
            with-collected-macro-forms))
 
 (defpackage swank/rpc