[slime-cvs] CVS slime

[CVS User heller]

Update of /project/slime/cvsroot/slime
In directory tiger.common-lisp.net:/tmp/cvs-serv22109

Modified Files:
	ChangeLog swank-allegro.lisp 
Log Message:
* swank-allegro.lisp (frame-source-location, ldb-code-to-src-loc):
Use function-source-location for some cases that used to cause
errors.
(frame-package): New.
(format-sldb-condition, call-with-syntax-hooks): Deleted. Did just
the same as the default implementation.

--- /project/slime/cvsroot/slime/ChangeLog	2012/11/02 08:14:16	1.2360
+++ /project/slime/cvsroot/slime/ChangeLog	2012/11/02 08:14:28	1.2361
@@ -1,5 +1,14 @@
 2012-11-02  Helmut Eller  <heller at common-lisp.net>
 
+	* swank-allegro.lisp (frame-source-location, ldb-code-to-src-loc):
+	Use function-source-location for some cases that used to cause
+	errors.
+	(frame-package): New.
+	(format-sldb-condition, call-with-syntax-hooks): Deleted. Did just
+	the same as the default implementation.
+
+2012-11-02  Helmut Eller  <heller at common-lisp.net>
+
 	* slime.el ([test] find-definition): Test defstruct and defvar.
 	([test] find-definition.3): New.
 
--- /project/slime/cvsroot/slime/swank-allegro.lisp	2012/08/04 23:48:19	1.154
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2012/11/02 08:14:28	1.155
@@ -85,12 +85,6 @@
             (excl:find-external-format (car e) 
                                        :try-variant t)))))
 
-(defimplementation format-sldb-condition (c)
-  (princ-to-string c))
-
-(defimplementation call-with-syntax-hooks (fn)
-  (funcall fn))
-
 ;;;; Unix signals
 
 (defimplementation getpid ()
@@ -214,11 +208,11 @@
   (let* ((frame (nth-frame index)))
     (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
       (declare (ignore x xx xxx))
-      (cond (pc
-             #+(version>= 8 2)
-             (pc-source-location fun pc)
-             #-(version>= 8 2)
-             (function-source-location fun))
+      (cond ((and pc
+                  #+(version>= 8 2)
+                  (pc-source-location fun pc)
+                  #-(version>= 8 2)
+                  (function-source-location fun)))
             (t ; frames for unbound functions etc end up here
              (cadr (car (fspec-definition-locations
                          (car (debugger:frame-expression frame))))))))))
@@ -232,7 +226,7 @@
   (let* ((debug-info (excl::function-source-debug-info fun)))
     (cond ((not debug-info)
            (function-source-location fun))
-          (t 
+          (t
            (let* ((code-loc (find-if (lambda (c)
                                        (<= (- pc (sys::natural-width))
                                            (excl::ldb-code-pc c)
@@ -248,25 +242,27 @@
   (let* ((start (excl::ldb-code-start-char code))
          (func (excl::ldb-code-func code))
          (src-file (excl:source-file func)))
-    (cond (start 
+    (cond (start
            (buffer-or-file-location src-file start))
-          (t
+          (func
            (let* ((debug-info (excl::function-source-debug-info func))
                   (whole (aref debug-info 0))
                   (paths (source-paths-of (excl::ldb-code-source whole)
                                           (excl::ldb-code-source code)))
-                  (path (longest-common-prefix paths))
+                  (path (if paths (longest-common-prefix paths) '()))
                   (start (excl::ldb-code-start-char whole)))
-             (buffer-or-file 
-              src-file 
-              (lambda (file) 
-                (make-location `(:file ,file) 
+             (buffer-or-file
+              src-file
+              (lambda (file)
+                (make-location `(:file ,file)
                                `(:source-path (0 . ,path) ,start)))
               (lambda (buffer bstart)
                 (make-location `(:buffer ,buffer)
                                `(:source-path (0 . ,path)
-                                              ,(+ bstart start))))))))))
- 
+                                              ,(+ bstart start)))))))
+          (t
+           nil))))
+
 (defun longest-common-prefix (sequences)
   (assert sequences)
   (flet ((common-prefix (s1 s2)
@@ -296,6 +292,12 @@
        `(let* ,vars ,form)
        (debugger:environment-of-frame frame)))))
 
+(defimplementation frame-package (frame-number)
+  (let* ((frame (nth-frame frame-number))
+         (exp (debugger:frame-expression frame)))
+    (typecase exp
+      ((cons symbol) (symbol-package (car exp))))))
+
 (defimplementation return-from-frame (frame-number form)
   (let ((frame (nth-frame frame-number)))
     (multiple-value-call #'debugger:frame-return