[nongnu] elpa/sly ea83bbf0b3 5/5: Per #485: Don't use SLYNK package's symbols in ABCL backend

[ELPA Syncer]

branch: elpa/sly
commit ea83bbf0b3e1a20ab172fde42a196b7b8cf0812c
Author: Gordon Brown <gbrown@spu.edu>
Commit: João Távora <joaotavora@gmail.com>

    Per #485: Don't use SLYNK package's symbols in ABCL backend
    
    Using symbols from the SLYNK package in the ABCL backend fails because
    the SLYNK package hasn't been created yet at the time the backend file
    is CL:READ.
    
    Though Backends may use the SLYNK-BACKEND and some other utility
    packages, they should not rely on the presence of the SLYNK package,
    certainly not at read-time.
    
    Nevertheless, some -- like abcl.lisp -- qend up doing so anyway.  This
    is probably because they were developed interactively in an
    environment where some version of SLYNK is already loaded beforehand
    somehow (perhaps it's burned in the image).
    
    This commit doesn't solve the underlying problem of replacing those
    uses with something else, but it uses a common trick to allow the
    abcl.lisp file to be CL:READ even before the SLYNK package is created.
    
    It is presumed that, by the time the calls to SLYNK symbols are
    useful, the SLYNK package is effectively already loaded.  The hack is
    localized and aptly named EVIL-HACK so to identifies the culprits.
    
    It makes using a different solution in the future easier, and
    hopefully makes it clearer what's going on.
    
    * slynk/backend/abcl.lisp: Rework.
---
 slynk/backend/abcl.lisp | 204 +++++++++++++++++++++++++-----------------------
 1 file changed, 108 insertions(+), 96 deletions(-)

diff --git a/slynk/backend/abcl.lisp b/slynk/backend/abcl.lisp
index 709a51c65b..2c99fa6804 100644
--- a/slynk/backend/abcl.lisp
+++ b/slynk/backend/abcl.lisp
@@ -61,6 +61,27 @@
     (ext:make-slime-input-stream read-string
                                  (make-synonym-stream '*standard-output*))))
 
+;; A hack to call functions from packages that don't exist when this code is 
loaded.
+;; An FLET is used to make sure all the uses of it are contained in wrapper 
functions
+;; so this hack can be easily swapped out later.
+(flet ((evil-hack (function &rest args) (apply (read-from-string function) 
args)))
+  (defun %%lcons (car cdr)
+    (evil-hack "slynk::%lcons" car (lambda () cdr)))
+  
+  (defun %%lookup-class-name (&rest args)
+    (evil-hack "jss::lookup-class-name" args))
+  
+  (defun %%ed-in-emacs (what)
+    (evil-hack "slynk:ed-in-emacs" what))
+
+  (defun %%method-for-inspect-value (method)
+    ;; Note that this one is in slynk-fancy-inspector
+    (evil-hack "slynk::method-for-inspect-value" method))
+
+  (defun %%abbrev-doc (doc)
+    (evil-hack "slynk::abbrev-doc" doc)))
+
+
 ;;; Have CL:INSPECT use SLY
 ;;;
 ;;; Since Slynk may also be run in a server not running under Emacs
@@ -1068,42 +1089,33 @@
                     '(:newline)
                     (with-output-to-string (desc) (describe o desc))))))))
 
+
+(defun %%prepend-list-to-llist (list llist)
+  "Takes a list (LIST) and a lazy list (LLIST) and transforms the list items 
into lazy list items,
+which are prepended onto the existing lazy list and returned.
+
+LIST is destructively modified."
+  (flet ((lcons (car cdr) (%%lcons car (lambda () cdr))))
+    (reduce #'lcons list :initial-value llist :from-end t)))
+
 (defmethod emacs-inspect ((string string))
-  (slynk::lcons* 
-   '(:label "Value: ")  `(:value ,string ,(concatenate 'string "\"" string 
"\""))  '(:newline)
-   #+abcl-introspect ;; ??? This doesn't appear depend on ABCL-INTROSPECT.  
Why disable?
-   `(:action "[Edit in emacs buffer]" ,(lambda() (slynk::ed-in-emacs `(:string 
,string))))
-   '(:newline)
-   (if (ignore-errors (jclass string))
-       `(:line "Names java class" ,(jclass string))
-       "")
-   #+abcl-introspect
-   (if (and (jss-p) 
-            (stringp (funcall (intern "LOOKUP-CLASS-NAME" :jss) string 
:return-ambiguous t :muffle-warning t)))
-       `(:multiple
-         (:label "Abbreviates java class: ")
-         ,(let ((it (funcall (intern "LOOKUP-CLASS-NAME" :jss) string 
:return-ambiguous t :muffle-warning t)))
-           `(:value ,(jclass it)))
-         (:newline))
-       "")
-   (if (ignore-errors (find-package (string-upcase string)))
-       `(:line "Names package" ,(find-package (string-upcase string)))
-       "")
-   (let ((symbols (loop for p in (list-all-packages)
-                        for found = (find-symbol (string-upcase string))
-                        when (and found (eq (symbol-package found) p)
-                                  (or (fboundp found)
-                                      (boundp found)
-                                      (symbol-plist found)
-                                      (ignore-errors (find-class found))))
-                          collect found)))
-     (if symbols
-         `(:multiple (:label "Names symbols: ") 
-                     ,@(loop for s in symbols
-                             collect
-                             (Let ((*package* (find-package :keyword))) 
-                               `(:value ,s ,(prin1-to-string s))) collect " ") 
(:newline))
-         ""))
+  (%%prepend-list-to-llist
+   (list 
+    '(:label "Value: ")  `(:value ,string ,(concatenate 'string "\"" string 
"\""))  '(:newline)
+    (if (ignore-errors (jclass string))
+        `(:line "Names java class" ,(jclass string))
+        "")
+    #+abcl-introspect
+    (if (and (jss-p) 
+             (stringp (%%lookup-class-name string :return-ambiguous t 
:muffle-warning t)))
+        `(:line
+           "Abbreviates java class"
+           ,(let ((it (%%lookup-class-name string :return-ambiguous t 
:muffle-warning t)))
+              (jclass it)))
+        "")
+    (if (ignore-errors (find-package (string-upcase string)))
+        `(:line "Names package" ,(find-package (string-upcase string)))
+        ""))
    (call-next-method)))
 
 #+#.(slynk-backend:with-symbol 'java-exception 'java)
@@ -1135,45 +1147,45 @@
   `(,@(when (function-name f)
         `((:label "Name: ")
           ,(princ-to-string (sys::any-function-name f)) (:newline)))
-      ,@(multiple-value-bind (args present) (sys::arglist f)
-          (when present
-            `((:label "Argument list: ")
-              ,(princ-to-string args)
-              (:newline))))
-      #+abcl-introspect
-      ,@(when (documentation f t)
-          `("Documentation:" (:newline)
-                             ,(documentation f t) (:newline)))
-      ,@(when (function-lambda-expression f)
-          `((:label "Lambda expression:")
-            (:newline) ,(princ-to-string
-                         (function-lambda-expression f)) (:newline)))
-      (:label "Function java class: ") (:value ,(jcall "getClass" f)) 
(:newline)
-      #+abcl-introspect
-      ,@(when (jcall "isInstance"  (java::jclass 
"org.armedbear.lisp.CompiledClosure") f)
-          `((:label "Closed over: ")
-            ,@(loop
-                 for el in (sys::compiled-closure-context f)
-                 collect `(:value ,el)
-                 collect " ")
-            (:newline)))
-      #+abcl-introspect
-      ,@(when (sys::get-loaded-from f)
-          (list `(:label "Defined in: ")
-                `(:value ,(sys::get-loaded-from f) ,(namestring 
(sys::get-loaded-from f)))
-                '(:newline)))
-      ;; I think this should work in older lisps too -- alanr
-      ,@(let ((fields (jcall "getDeclaredFields" (jcall "getClass" f))))
-          (when (plusp (length fields))
-            (list* '(:label "Internal fields: ") '(:newline)
-                   (loop for field across fields
-                      do (jcall "setAccessible" field t) ;;; not a great idea 
esp. wrt. Java9
-                      append
-                        (let ((value (jcall "get" field f)))
-                          (list "  "
-                                `(:label ,(jcall "getName" field))
-                                ": "
-                                `(:value ,value ,(princ-to-string value))
+    ,@(multiple-value-bind (args present) (sys::arglist f)
+        (when present
+          `((:label "Argument list: ")
+            ,(princ-to-string args)
+            (:newline))))
+    #+abcl-introspect
+    ,@(when (documentation f t)
+        `("Documentation:" (:newline)
+                           ,(documentation f t) (:newline)))
+    ,@(when (function-lambda-expression f)
+        `((:label "Lambda expression:")
+          (:newline) ,(princ-to-string
+                       (function-lambda-expression f)) (:newline)))
+    (:label "Function java class: ") (:value ,(jcall "getClass" f)) (:newline)
+    #+abcl-introspect
+    ,@(when (jcall "isInstance"  (java::jclass 
"org.armedbear.lisp.CompiledClosure") f)
+        `((:label "Closed over: ")
+          ,@(loop
+              for el in (sys::compiled-closure-context f)
+              collect `(:value ,el)
+              collect " ")
+          (:newline)))
+    #+abcl-introspect
+    ,@(when (sys::get-loaded-from f)
+        (list `(:label "Defined in: ")
+              `(:value ,(sys::get-loaded-from f) ,(namestring 
(sys::get-loaded-from f)))
+              '(:newline)))
+    ;; I think this should work in older lisps too -- alanr
+    ,@(let ((fields (jcall "getDeclaredFields" (jcall "getClass" f))))
+        (when (plusp (length fields))
+          (list* '(:label "Internal fields: ") '(:newline)
+                 (loop for field across fields
+                       do (jcall "setAccessible" field t) ;;; not a great idea 
esp. wrt. Java9
+                       append
+                       (let ((value (jcall "get" field f)))
+                         (list "  "
+                               `(:label ,(jcall "getName" field))
+                               ": "
+                               `(:value ,value ,(princ-to-string value))
                                '(:newline)))))))))
 
 (defmethod emacs-inspect ((o java:java-object))
@@ -1315,7 +1327,7 @@
       ,@(when path (list `(:label ,"Loaded from: ")
                          `(:value ,path)
                          " "
-                         `(:action "[open in emacs buffer]" ,(lambda() 
(slynk::ed-in-emacs `( ,path)))) '(:newline)))
+                         `(:action "[open in emacs buffer]" ,(lambda() 
(%%ed-in-emacs `( ,path)))) '(:newline)))
       ,@(if has-superclasses 
             (list* '(:label "Superclasses: ") (butlast (loop for super = 
(jclass-superclass class) then (jclass-superclass super)
                             while super collect (list :value super (jcall 
"getName" super)) collect ", "))))
@@ -1349,27 +1361,27 @@
 (defmethod emacs-inspect ((object sys::structure-class))
   (let* ((name (jss::get-java-field object "name" t))
          (def (get name  'system::structure-definition)))
-  `((:label "Class: ") (:value ,object) (:newline)
-    (:label "Raw defstruct definition: ") (:value ,def  ,(let ((*print-array* 
nil)) (prin1-to-string def))) (:newline)
-   ,@(parts-for-structure-def  name)
-    ;; copy-paste from slynk fancy inspector
-    ,@(when (slynk-mop:specializer-direct-methods object)
-        `((:label "It is used as a direct specializer in the following 
methods:")
-          (:newline)
-          ,@(loop
-              for method in (specializer-direct-methods object)
-              for method-spec = (slynk::method-for-inspect-value method)
-              collect "  "
-              collect `(:value ,method ,(string-downcase (string (car 
method-spec))))
-              collect `(:value ,method ,(format nil " (~{~a~^ ~})" (cdr 
method-spec)))
-              append (let ((method method))
-                       `(" " (:action "[remove]"
-                                      ,(lambda () (remove-method 
(slynk-mop::method-generic-function method) method)))))
-              collect '(:newline)
-              if (documentation method t)
-                collect "    Documentation: " and
-              collect (slynk::abbrev-doc  (documentation method t)) and
-              collect '(:newline)))))))
+    `((:label "Class: ") (:value ,object) (:newline)
+      (:label "Raw defstruct definition: ") (:value ,def  ,(let 
((*print-array* nil)) (prin1-to-string def))) (:newline)
+      ,@(parts-for-structure-def  name)
+      ;; copy-paste from slynk fancy inspector
+      ,@(when (slynk-mop:specializer-direct-methods object)
+          `((:label "It is used as a direct specializer in the following 
methods:")
+            (:newline)
+            ,@(loop
+                for method in (specializer-direct-methods object)
+                for method-spec = (%%method-for-inspect-value method)
+                collect "  "
+                collect `(:value ,method ,(string-downcase (string (car 
method-spec))))
+                collect `(:value ,method ,(format nil " (~{~a~^ ~})" (cdr 
method-spec)))
+                append (let ((method method))
+                         `(" " (:action "[remove]"
+                                        ,(lambda () (remove-method 
(slynk-mop::method-generic-function method) method)))))
+                collect '(:newline)
+                if (documentation method t)
+                  collect "    Documentation: " and
+                  collect (%%abbrev-doc  (documentation method t)) and
+                  collect '(:newline)))))))
 
 (defun parts-for-structure-def-slot (def)
   `((:label ,(string-downcase (sys::dsd-name def))) " reader: " (:value 
,(sys::dsd-reader def) ,(string-downcase (string (sys::dsdreader def))))