[nongnu] externals/sly 7bad394 09/47: Improve compiler messages for Clasp

[ELPA Syncer]

branch: externals/sly
commit 7bad394c743902b5162c0810c8d865b2644b63ea
Author: Chris Schafmeister <meister@temple.edu>
Commit: João Távora <joaotavora@gmail.com>

    Improve compiler messages for Clasp
    
    * slynk/backend/clasp.lisp: Rework.
    
    Cherry-picked-from: SLIME commit 01531b09debe1199d9726ed91c4672cd9587fb58
    Co-authored-by: Manfred Bergmann <manfred@nnamgreb.de>
    Co-authored-by: João Távora <joaotavora@gmail.com>
---
 slynk/backend/clasp.lisp | 82 +++++++++++++++++++++---------------------------
 1 file changed, 35 insertions(+), 47 deletions(-)

diff --git a/slynk/backend/clasp.lisp b/slynk/backend/clasp.lisp
index b893ab3..27f72f9 100644
--- a/slynk/backend/clasp.lisp
+++ b/slynk/backend/clasp.lisp
@@ -39,15 +39,7 @@
 ;;; Slynk-mop
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (import-slynk-mop-symbols
-   :clos
-   nil
-   #+(or)`(:eql-specializer
-           :eql-specializer-object
-           :generic-function-declarations
-           :specializer-direct-methods
-           ,@(unless (fboundp 'clos:compute-applicable-methods-using-classes)
-               '(:compute-applicable-methods-using-classes)))))
+  (import-slynk-mop-symbols :clos nil))
 
 (defimplementation gray-package-name ()
   "GRAY")
@@ -56,12 +48,6 @@
 ;;;; TCP Server
 
 (defimplementation preferred-communication-style ()
-  ;; As of March 2017 CLASP provides threads.
-  ;; But it's experimental.
-  ;; ECLs slynk implementation says that CLOS is not thread safe and
-  ;; I use ECLs CLOS implementation - this is a worry for the future.
-  ;; nil or  :spawn
-  ;; nil
   :spawn
 #|  #+threads :spawn
   #-threads nil
@@ -230,44 +216,46 @@
 (defvar *buffer-name* nil)
 (defvar *buffer-start-position*)
 
-(defun signal-compiler-condition (&rest args)
-  (apply #'signal 'compiler-condition args))
-
-#-clasp-bytecmp
-(defun handle-compiler-message (condition)
-  ;; CLASP emits lots of noise in compiler-notes, like "Invoking
-  ;; external command".
-  (unless (typep condition 'c::compiler-note)
-    (signal-compiler-condition
-     :original-condition condition
-     :message (princ-to-string condition)
-     :severity (etypecase condition
-                 (cmp:compiler-fatal-error :error)
-                 (cmp:compiler-error       :error)
-                 (error                  :error)
-                 (style-warning          :style-warning)
-                 (warning                :warning))
-     :location (condition-location condition))))
-
-#-clasp-bytecmp
-(defun condition-location (condition)
-  (let ((file     (cmp:compiler-message-file condition))
-        (position (cmp:compiler-message-file-position condition)))
-    (if (and position (not (minusp position)))
+(defun condition-severity (condition)
+  (etypecase condition
+    (cmp:redefined-function-warning :redefinition)
+    (style-warning                  :style-warning)
+    (warning                        :warning)
+    (reader-error                   :read-error)
+    (error                          :error)))
+
+(defun condition-location (origin)
+  (if (null origin)
+      (make-error-location "No error location available")
+      (let ((location (core:source-pos-info-filepos origin)))
         (if *buffer-name*
             (make-buffer-location *buffer-name*
                                   *buffer-start-position*
-                                  position)
-            (make-file-location file position))
-        (make-error-location "No location found."))))
+                                  location)
+            (make-file-location
+             (core:source-file-info-pathname
+              (core:source-file-info origin))
+             location)))))
+
+(defun signal-compiler-condition (condition origin)
+  (signal 'compiler-condition
+          :original-condition condition
+          :severity (condition-severity condition)
+          :message (princ-to-string condition)
+          :location (condition-location origin)))
+
+(defun handle-compiler-condition (condition)
+  ;; First resignal warnings, so that outer handlers - which may choose to
+  ;; muffle this - get a chance to run.
+  (when (typep condition 'warning)
+    (signal condition))
+  (signal-compiler-condition (cmp:deencapsulate-compiler-condition condition)
+                             (cmp:compiler-condition-origin condition)))
 
 (defimplementation call-with-compilation-hooks (function)
-  (funcall function))
-#||  #-clasp-bytecmp
-  (handler-bind ((c:compiler-message #'handle-compiler-message))
+  (handler-bind
+      (((or error warning) #'handle-compiler-condition))
     (funcall function)))
-||#
-
 
 (defimplementation slynk-compile-file (input-file output-file
                                        load-p external-format