From heller at common-lisp.net  Sun Sep 29 07:39:48 2013
From: heller at common-lisp.net (CVS User heller)
Date: Sun, 29 Sep 2013 00:39:48 -0700 (PDT)
Subject: CVS slime
Message-ID: <20130929073948.BDE84356697@mail.common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory alpha-cl-net:/tmp/cvs-serv15848

Modified Files:
	ChangeLog swank-clisp.lisp 
Log Message:
* swank-clisp.lisp (*frame-prefixes*): Update some of the patterns
for new layout.
(is-prefix-p): Use regexp matching.
(boring-frame-p): Also make compiled-tagbody compiled-block
boring.
(sldb-backtrace, %parse-stack-values): Remove code for versions
before 2.44.

--- /project/slime/cvsroot/slime/ChangeLog	2013/09/29 07:39:39	1.2404
+++ /project/slime/cvsroot/slime/ChangeLog	2013/09/29 07:39:48	1.2405
@@ -1,5 +1,15 @@
 2013-09-29  Helmut Eller  <heller at common-lisp.net>
 
+	* swank-clisp.lisp (*frame-prefixes*): Update some of the patterns
+	for new layout.
+	(is-prefix-p): Use regexp matching.
+	(boring-frame-p): Also make compiled-tagbody compiled-block
+	boring.
+	(sldb-backtrace, %parse-stack-values): Remove code for versions
+	before 2.44.
+
+2013-09-29  Helmut Eller  <heller at common-lisp.net>
+
 	For CCL, also search nx1-alphatizer definitions.
 
 	* swank-ccl.lisp (alphatizer-definitions): New
--- /project/slime/cvsroot/slime/swank-clisp.lisp	2013/02/02 10:11:16	1.103
+++ /project/slime/cvsroot/slime/swank-clisp.lisp	2013/09/29 07:39:48	1.104
@@ -36,6 +36,10 @@
 
 (in-package :swank-backend)
 
+(eval-when (:compile-toplevel)
+  (unless (string< "2.44" (lisp-implementation-version))
+    (error "Need at least CLISP version 2.44")))
+
 (eval-when (:compile-toplevel :load-toplevel :execute)
   ;;(use-package "SOCKET")
   (use-package "GRAY"))
@@ -359,54 +363,59 @@
 
 (defvar *sldb-backtrace*)
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (when (string< "2.44" (lisp-implementation-version))
-    (pushnew :clisp-2.44+ *features*)))
-
 (defun sldb-backtrace ()
   "Return a list ((ADDRESS . DESCRIPTION) ...) of frames."
-  (do ((frames '())
-       (last nil frame)
-       (frame (sys::the-frame)
-              #+clisp-2.44+ (sys::frame-up 1 frame 1)
-              #-clisp-2.44+ (sys::frame-up-1 frame 1))) ; 1 = "all frames"
-      ((eq frame last) (nreverse frames))
-    (unless (boring-frame-p frame)
-      (push frame frames))))
+  (let* ((modes '((:all-stack-elements 1)
+                  (:all-frames 2)
+                  (:only-lexical-frames 3)
+                  (:only-eval-and-apply-frames 4)
+                  (:only-apply-frames 5)))
+         (mode (cadr (assoc :all-stack-elements modes))))
+    (do ((frames '())
+         (last nil frame)
+         (frame (sys::the-frame)
+                (sys::frame-up 1 frame mode)))
+        ((eq frame last) (nreverse frames))
+      (unless (boring-frame-p frame)
+        (push frame frames)))))
 
 (defimplementation call-with-debugging-environment (debugger-loop-fn)
   (let* (;;(sys::*break-count* (1+ sys::*break-count*))
          ;;(sys::*driver* debugger-loop-fn)
          ;;(sys::*fasoutput-stream* nil)
          (*sldb-backtrace*
-          (nthcdr 3 (member (sys::the-frame) (sldb-backtrace)))))
+          (let* ((f (sys::the-frame))
+                 (bt (sldb-backtrace))
+                 (rest (member f bt)))
+            (if rest (nthcdr 8 rest) bt))))
     (funcall debugger-loop-fn)))
 
 (defun nth-frame (index)
   (nth index *sldb-backtrace*))
 
 (defun boring-frame-p (frame)
-  (member (frame-type frame) '(stack-value bind-var bind-env)))
+  (member (frame-type frame) '(stack-value bind-var bind-env
+                               compiled-tagbody compiled-block)))
 
 (defun frame-to-string (frame)
   (with-output-to-string (s)
     (sys::describe-frame s frame)))
 
-;; FIXME: they changed the layout in 2.44 so the frame-to-string &
-;; string-matching silliness no longer works.
 (defun frame-type (frame)
   ;; FIXME: should bind *print-length* etc. to small values.
   (frame-string-type (frame-to-string frame)))
 
+;; FIXME: they changed the layout in 2.44 and not all patterns have
+;; been updated.
 (defvar *frame-prefixes*
-  '(("frame binding variables" bind-var)
+  '(("\\[[0-9]\\+\\] frame binding variables" bind-var)
     ("<1> #<compiled-function" compiled-fun)
     ("<1> #<system-function" sys-fun)
     ("<1> #<special-operator" special-op)
     ("EVAL frame" eval)
     ("APPLY frame" apply)
-    ("compiled tagbody frame" compiled-tagbody)
-    ("compiled block frame" compiled-block)
+    ("\\[[0-9]\\+\\] compiled tagbody frame" compiled-tagbody)
+    ("\\[[0-9]\\+\\] compiled block frame" compiled-block)
     ("block frame" block)
     ("nested block frame" block)
     ("tagbody frame" tagbody)
@@ -415,11 +424,12 @@
     ("handler frame" handler)
     ("unwind-protect frame" unwind-protect)
     ("driver frame" driver)
-    ("frame binding environments" bind-env)
+    ("\\[[0-9]\\+\\] frame binding environments" bind-env)
     ("CALLBACK frame" callback)
     ("- " stack-value)
     ("<1> " fun)
-    ("<2> " 2nd-frame)))
+    ("<2> " 2nd-frame)
+    ))
 
 (defun frame-string-type (string)
   (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string))
@@ -529,9 +539,7 @@
         (venv-ref (next-venv env) (- i (/ (1- (length env)) 2))))))
 
 (defun %parse-stack-values (frame)
-  (labels ((next (fp)
-             #+clisp-2.44+ (sys::frame-down 1 fp 1)
-             #-clisp-2.44+ (sys::frame-down-1 fp 1))
+  (labels ((next (fp) (sys::frame-down 1 fp 1))
            (parse (fp accu)
              (let ((str (frame-to-string fp)))
                (cond ((is-prefix-p "- " str)
@@ -546,11 +554,8 @@
                      (t (parse (next fp) accu))))))
     (parse (next frame) '())))
 
-(setq *features* (remove :clisp-2.44+ *features*))
-
-(defun is-prefix-p (pattern string)
-  (not (mismatch pattern string :end2 (min (length pattern)
-                                           (length string)))))
+(defun is-prefix-p (regexp string)
+  (if (regexp:match (concatenate 'string "^" regexp) string) t))
 
 (defimplementation return-from-frame (index form)
   (sys::return-from-eval-frame (nth-frame index) form))



From heller at common-lisp.net  Sun Sep 29 13:45:43 2013
From: heller at common-lisp.net (CVS User heller)
Date: Sun, 29 Sep 2013 06:45:43 -0700 (PDT)
Subject: CVS slime
Message-ID: <20130929134543.467693565F1@mail.common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory alpha-cl-net:/tmp/cvs-serv4615

Modified Files:
	ChangeLog swank-ccl.lisp 
Log Message:
For CCL, also search definitions of p2 translators.

* swank-ccl.lisp (p2-definitions): New.
(find-definitions): Use it.

--- /project/slime/cvsroot/slime/ChangeLog	2013/09/29 07:39:48	1.2405
+++ /project/slime/cvsroot/slime/ChangeLog	2013/09/29 13:45:42	1.2406
@@ -1,5 +1,12 @@
 2013-09-29  Helmut Eller  <heller at common-lisp.net>
 
+	For CCL, also search definitions of p2 translators.
+
+	* swank-ccl.lisp (p2-definitions): New.
+	(find-definitions): Use it.
+
+2013-09-29  Helmut Eller  <heller at common-lisp.net>
+
 	* swank-clisp.lisp (*frame-prefixes*): Update some of the patterns
 	for new layout.
 	(is-prefix-p): Use regexp matching.
--- /project/slime/cvsroot/slime/swank-ccl.lisp	2013/09/29 07:39:39	1.33
+++ /project/slime/cvsroot/slime/swank-ccl.lisp	2013/09/29 13:45:42	1.34
@@ -549,13 +549,22 @@
   (let ((alpha (gethash name ccl::*nx1-alphatizers*)))
     (and alpha (ccl:find-definition-sources alpha))))
 
+(defun p2-definitions (name)
+  (let ((nx1-op (gethash name ccl::*nx1-operators*)))
+    (and nx1-op
+         (let ((p2 (aref (ccl::backend-p2-dispatch ccl::*target-backend*)
+                         nx1-op)))
+           (and p2
+                (ccl:find-definition-sources p2))))))
+
 (defimplementation find-definitions (name)
   (let ((defs (append (or (ccl:find-definition-sources name)
                           (and (symbolp name)
                                (fboundp name)
                                (ccl:find-definition-sources
                                 (symbol-function name))))
-                      (alphatizer-definitions name))))
+                      (alphatizer-definitions name)
+                      (p2-definitions name))))
     (loop for ((type . name) . sources) in defs
           collect (list (definition-name type name)
                         (source-note-to-source-location



From heller at common-lisp.net  Sun Sep 29 07:39:40 2013
From: heller at common-lisp.net (CVS User heller)
Date: Sun, 29 Sep 2013 00:39:40 -0700 (PDT)
Subject: CVS slime
Message-ID: <20130929073940.2B09D3565D3@mail.common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory alpha-cl-net:/tmp/cvs-serv15795

Modified Files:
	ChangeLog swank-ccl.lisp 
Log Message:
For CCL, also search nx1-alphatizer definitions.

* swank-ccl.lisp (alphatizer-definitions): New
(find-definitions): Use it.

--- /project/slime/cvsroot/slime/ChangeLog	2013/06/26 11:51:50	1.2403
+++ /project/slime/cvsroot/slime/ChangeLog	2013/09/29 07:39:39	1.2404
@@ -1,3 +1,10 @@
+2013-09-29  Helmut Eller  <heller at common-lisp.net>
+
+	For CCL, also search nx1-alphatizer definitions.
+
+	* swank-ccl.lisp (alphatizer-definitions): New
+	(find-definitions): Use it.
+
 2013-06-26  evenson  <evenson at saturn>
 
 	* swank-abcl.lisp (specializer-direct-methods): Correct symbol
--- /project/slime/cvsroot/slime/swank-ccl.lisp	2013/02/02 10:11:16	1.32
+++ /project/slime/cvsroot/slime/swank-ccl.lisp	2013/09/29 07:39:39	1.33
@@ -545,11 +545,17 @@
               (t `(:error ,(funcall if-nil-thunk))))
       (error (c) `(:error ,(princ-to-string c))))))
 
+(defun alphatizer-definitions (name)
+  (let ((alpha (gethash name ccl::*nx1-alphatizers*)))
+    (and alpha (ccl:find-definition-sources alpha))))
+
 (defimplementation find-definitions (name)
-  (let ((defs (or (ccl:find-definition-sources name)
-                  (and (symbolp name)
-                       (fboundp name)
-                       (ccl:find-definition-sources (symbol-function name))))))
+  (let ((defs (append (or (ccl:find-definition-sources name)
+                          (and (symbolp name)
+                               (fboundp name)
+                               (ccl:find-definition-sources
+                                (symbol-function name))))
+                      (alphatizer-definitions name))))
     (loop for ((type . name) . sources) in defs
           collect (list (definition-name type name)
                         (source-note-to-source-location