From msimmons at common-lisp.net  Tue Nov  2 12:32:10 2010
From: msimmons at common-lisp.net (CVS User msimmons)
Date: Tue, 02 Nov 2010 08:32:10 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1PDG26-00079p-BK@common-lisp.net>

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

Modified Files:
	ChangeLog swank-lispworks.lisp 
Log Message:
* swank-lispworks.lisp (list-callers-internal): Revert to previous
low level implementation, fixed for LW6.
(list-callees-internal): Reimplement using low level instead of
the compiler's xref.


--- /project/slime/cvsroot/slime/ChangeLog	2010/10/23 12:18:28	1.2159
+++ /project/slime/cvsroot/slime/ChangeLog	2010/11/02 12:32:10	1.2160
@@ -1,3 +1,10 @@
+2010-11-02  Martin Simmons  <martin at lispworks.com>
+
+	* swank-lispworks.lisp (list-callers-internal): Revert to previous
+	low level implementation, fixed for LW6.
+	(list-callees-internal): Reimplement using low level instead of
+	the compiler's xref.
+
 2010-10-23  Stas Boukarev  <stassats at gmail.com>
 
 	* slime.el (slime-goto-location-position): In case of
--- /project/slime/cvsroot/slime/swank-lispworks.lisp	2010/07/22 13:45:46	1.137
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp	2010/11/02 12:32:10	1.138
@@ -697,10 +697,8 @@
 (defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too
 (defxref calls-who      hcl:calls-who)
 (defxref list-callers   list-callers-internal)
-#+lispworks6
 (defxref list-callees   list-callees-internal)
 
-#-lispworks6
 (defun list-callers-internal (name)
   (let ((callers (make-array 100
                              :fill-pointer 0
@@ -708,7 +706,8 @@
     (hcl:sweep-all-objects
      #'(lambda (object)
          (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object)
-                    #-Harlequin-PC-Lisp (sys::callablep object)
+                    #+Harlequin-Unix-Lisp (sys:callablep object)
+                    #-(or Harlequin-PC-Lisp Harlequin-Unix-Lisp) (sys:compiled-code-p object)
                     (system::find-constant$funcallable name object))
            (vector-push-extend object callers))))
     ;; Delay dspec:object-dspec until after sweep-all-objects
@@ -718,23 +717,18 @@
 		      (list 'function object)
                       (or (dspec:object-dspec object) object)))))
 
-#+lispworks6
-(defun list-callers-internal (name)
-    ;; Delay dspec:object-dspec until after sweep-all-objects
-    ;; to reduce allocation problems.
-    (loop for object in (hcl::who-calls name)
-          collect (if (symbolp object)
-		      (list 'function object)
-                      (or (dspec:object-dspec object) object))))
-
-#+lispworks6
 (defun list-callees-internal (name)
-    ;; Delay dspec:object-dspec until after sweep-all-objects
-    ;; to reduce allocation problems.
-    (loop for object in (hcl::calls-who name)
-          collect (if (symbolp object)
-		      (list 'function object)
-                      (or (dspec:object-dspec object) object))))
+  (let ((callees '()))
+    (system::find-constant$funcallable
+     'junk name
+     :test #'(lambda (junk constant)
+               (declare (ignore junk))
+               (when (and (symbolp constant)
+                          (fboundp constant))
+                 (pushnew (list 'function constant) callees :test 'equal))
+               ;; Return nil so we iterate over all constants.
+               nil))
+    callees))
 
 ;; only for lispworks 4.2 and above
 #-lispworks4.1




From sboukarev at common-lisp.net  Wed Nov  3 11:00:40 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Wed, 03 Nov 2010 07:00:40 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1PDb56-0001zi-PL@common-lisp.net>

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

Modified Files:
	ChangeLog swank-loader.lisp 
Log Message:
* swank-loader.lisp (*architecture-features*): Add :arm for CCL
ARM port.


--- /project/slime/cvsroot/slime/ChangeLog	2010/11/02 12:32:10	1.2160
+++ /project/slime/cvsroot/slime/ChangeLog	2010/11/03 11:00:40	1.2161
@@ -1,3 +1,8 @@
+2010-11-03  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-loader.lisp (*architecture-features*): Add :arm for CCL
+	ARM port.
+
 2010-11-02  Martin Simmons  <martin at lispworks.com>
 
 	* swank-lispworks.lisp (list-callers-internal): Revert to previous
--- /project/slime/cvsroot/slime/swank-loader.lisp	2010/10/16 10:10:38	1.108
+++ /project/slime/cvsroot/slime/swank-loader.lisp	2010/11/03 11:00:40	1.109
@@ -56,7 +56,7 @@
 
 (defparameter *architecture-features*
   '(:powerpc :ppc :x86 :x86-64 :x86_64 :amd64 :i686 :i586 :i486 :pc386 :iapx386
-    :sparc64 :sparc :hppa64 :hppa
+    :sparc64 :sparc :hppa64 :hppa :arm
     :pentium3 :pentium4
     :java-1.4 :java-1.5 :java-1.6 :java-1.7))
 




From heller at common-lisp.net  Sun Nov  7 19:48:14 2010
From: heller at common-lisp.net (CVS User heller)
Date: Sun, 07 Nov 2010 14:48:14 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1PFBDq-0002nz-Cw@common-lisp.net>

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

Modified Files:
	ChangeLog swank-loader.lisp 
Log Message:
* swank-loader.lisp: ASDF free again.  And proud of it!
(default-fasl-dir, load-swank): Remove asdf stuff.

--- /project/slime/cvsroot/slime/ChangeLog	2010/11/03 11:00:40	1.2161
+++ /project/slime/cvsroot/slime/ChangeLog	2010/11/07 19:48:14	1.2162
@@ -1,3 +1,8 @@
+2010-11-07  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-loader.lisp: ASDF free again.  And proud of it!
+	(default-fasl-dir, load-swank): Remove asdf stuff.
+
 2010-11-03  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-loader.lisp (*architecture-features*): Add :arm for CCL
--- /project/slime/cvsroot/slime/swank-loader.lisp	2010/11/03 11:00:40	1.109
+++ /project/slime/cvsroot/slime/swank-loader.lisp	2010/11/07 19:48:14	1.110
@@ -124,22 +124,12 @@
     (and s (symbol-name (read s)))))
 
 (defun default-fasl-dir ()
-  (or
-   ;; If ASDF is available then store Slime's fasl's where ASDF stores them.
-   (let ((translate-fn (and (find-package :asdf)
-                            (find-symbol "COMPILE-FILE-PATHNAME*" :asdf))))
-     (when translate-fn
-       (make-pathname
-        :name nil :type nil
-        :defaults (funcall translate-fn
-                           (make-pathname :name "foo"
-                                          :defaults *source-directory*)))))
-   (merge-pathnames
-    (make-pathname
-     :directory `(:relative ".slime" "fasl"
-                            ,@(if (slime-version-string) (list (slime-version-string)))
-                            ,(unique-dir-name)))
-    (user-homedir-pathname))))
+  (merge-pathnames
+   (make-pathname
+    :directory `(:relative ".slime" "fasl"
+                 ,@(if (slime-version-string) (list (slime-version-string)))
+                 ,(unique-dir-name)))
+   (user-homedir-pathname)))
 
 (defvar *fasl-directory* (default-fasl-dir)
   "The directory where fasl files should be placed.")
@@ -244,16 +234,6 @@
 
 (defun load-swank (&key (src-dir *source-directory*)
                         (fasl-dir *fasl-directory*))
-  (when (find-package :asdf)
-    ;; Make sure our swank.asd is visible to ASDF.
-    (eval
-     (let ((*package* (find-package :swank-loader)))
-       (read-from-string
-        "(let ((swank-system (asdf:find-system :swank nil)))
-          (unless (and swank-system
-                       (equal (asdf:component-pathname swank-system)
-                              (merge-pathnames \"swank.asd\" *source-directory*)))
-            (push *source-directory* asdf:*central-registry*)))"))))
   (compile-files (src-files *swank-files* src-dir) fasl-dir t)
   (funcall (q "swank::before-init")
            (slime-version-string)




From heller at common-lisp.net  Sun Nov  7 19:48:21 2010
From: heller at common-lisp.net (CVS User heller)
Date: Sun, 07 Nov 2010 14:48:21 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1PFBDx-0002oa-IW@common-lisp.net>

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

Modified Files:
	ChangeLog swank-backend.lisp 
Log Message:
* swank-backend.lisp (label-value-line): Remove display-nil-value.
And the other stuff too.
(label-value-line*): Idem.

--- /project/slime/cvsroot/slime/ChangeLog	2010/11/07 19:48:14	1.2162
+++ /project/slime/cvsroot/slime/ChangeLog	2010/11/07 19:48:21	1.2163
@@ -1,5 +1,11 @@
 2010-11-07  Helmut Eller  <heller at common-lisp.net>
 
+	* swank-backend.lisp (label-value-line): Remove display-nil-value.
+	And the other stuff too.
+	(label-value-line*): Idem.
+
+2010-11-07  Helmut Eller  <heller at common-lisp.net>
+
 	* swank-loader.lisp: ASDF free again.  And proud of it!
 	(default-fasl-dir, load-swank): Remove asdf stuff.
 
--- /project/slime/cvsroot/slime/swank-backend.lisp	2010/10/15 22:42:14	1.204
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2010/11/07 19:48:21	1.205
@@ -1053,45 +1053,16 @@
 
 ;;; Utilities for inspector methods.
 ;;; 
-(defun label-value-line (label value &key padding-length display-nil-value hide-when-nil
-                               splice-as-ispec value-text (newline t))
-  "Create a control list which prints \"LABEL: VALUE\" in the inspector."
-  (if (or value (not hide-when-nil))
-      `((:label ,(princ-to-string label) ":")
-        ,@(when (or value display-nil-value)
-                (list " "))
-        ,@(when (and (or value display-nil-value)
-                     padding-length)
-                (list (make-array padding-length
-                                  :element-type 'character
-                                  :initial-element #\Space)))
-        ,@(when (or value display-nil-value)
-                (if splice-as-ispec
-                    (if (listp value) value (list value))
-                    `((:value ,value ,@(when value-text (list value-text))))))
-        ,@(if newline '((:newline)) nil))
-      (values)))
+
+(defun label-value-line (label value &key (newline t))
+  "Create a control list which prints \"LABEL: VALUE\" in the inspector.
+If NEWLINE is non-NIL a `(:newline)' is added to the result."
+  (list* (princ-to-string label) ": " `(:value ,value)
+         (if newline '((:newline)) nil)))
 
 (defmacro label-value-line* (&rest label-values)
-  (let ((longest-label-length (loop
-                                 :for (label value) :in label-values
-                                 :maximize (if (stringp label)
-                                               (length label)
-                                               0))))
-  `(append ,@(loop
-                :for entry :in label-values
-                :if (and (consp entry)
-                         (not (consp (first entry)))
-                         (string= (first entry) '@))
-                  :appending (rest entry)
-                :else
-                  :collect (destructuring-bind
-                                 (label value &rest args &key &allow-other-keys) entry
-                             `(label-value-line ,label ,value
-                                                :padding-length ,(when (stringp label)
-                                                                       (- longest-label-length
-                                                                          (length label)))
-                                                , at args))))))
+  ` (append ,@(loop for (label value) in label-values
+                    collect `(label-value-line ,label ,value))))
 
 (definterface describe-primitive-type (object)
   "Return a string describing the primitive type of object."




From heller at common-lisp.net  Fri Nov 12 19:42:51 2010
From: heller at common-lisp.net (CVS User heller)
Date: Fri, 12 Nov 2010 14:42:51 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1PGzWN-00082Z-Rg@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el swank-lispworks.lisp 
Log Message:
Improve frame-source-location for Lispworks.

* swank-lispworks.lisp (frame-source-location): Exctract the
edit-path from the frame and pass it to Emacs.
(edit-path-to-cmucl-source-path): New function.
(frame-location): Use it.

* slime.el (slime-location-offset): Add a :edit-path property.
(slime-search-edit-path): New function.
(slime-search-call-site): Fix regexp to match
zero arg functions.

--- /project/slime/cvsroot/slime/ChangeLog	2010/11/07 19:48:21	1.2163
+++ /project/slime/cvsroot/slime/ChangeLog	2010/11/12 19:42:51	1.2164
@@ -1,3 +1,17 @@
+2010-11-12  Helmut Eller  <heller at common-lisp.net>
+
+	Improve frame-source-location for Lispworks.
+
+	* swank-lispworks.lisp (frame-source-location): Exctract the
+	edit-path from the frame and pass it to Emacs.
+	(edit-path-to-cmucl-source-path): New function.
+	(frame-location): Use it.
+
+	* slime.el (slime-location-offset): Add a :edit-path property.
+	(slime-search-edit-path): New function.
+	(slime-search-call-site): Fix regexp to match
+	zero arg functions.
+
 2010-11-07  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-backend.lisp (label-value-line): Remove display-nil-value.
--- /project/slime/cvsroot/slime/slime.el	2010/10/23 12:18:28	1.1349
+++ /project/slime/cvsroot/slime/slime.el	2010/11/12 19:42:51	1.1350
@@ -3338,12 +3338,21 @@
   (save-restriction 
     (narrow-to-defun)
     (let ((start (point))
-          (regexp (concat "(" fname "[\n \t]")))
+          (regexp (concat "(" fname "[)\n \t]"))
+          (case-fold-search t))
       (cond ((and (re-search-forward regexp nil t)
                   (not (re-search-forward regexp nil t)))
              (goto-char (match-beginning 0)))
             (t (goto-char start))))))
 
+(defun slime-search-edit-path (edit-path)
+  "Move to EDIT-PATH starting at the current toplevel form."
+  (when edit-path
+    (unless (and (= (current-column) 0)
+                 (looking-at "("))
+      (beginning-of-defun))
+    (slime-forward-source-path edit-path)))
+
 (defun slime-goto-source-location (location &optional noerror)
   "Move to the source location LOCATION.  Several kinds of locations
 are supported:
@@ -3383,6 +3392,8 @@
     (let ((hints (slime-location.hints location)))
       (when-let (snippet (getf hints :snippet))
         (slime-isearch snippet))
+      (when-let (snippet (getf hints :edit-path))
+        (slime-search-edit-path snippet))
       (when-let (fname (getf hints :call-site))
         (slime-search-call-site fname))
       (when (getf hints :align)
--- /project/slime/cvsroot/slime/swank-lispworks.lisp	2010/11/02 12:32:10	1.138
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp	2010/11/12 19:42:51	1.139
@@ -336,7 +336,7 @@
 
 (defun nth-frame (index)
   (nth-next-frame *sldb-top-frame* index))
-           
+
 (defun find-top-frame ()
   "Return the most suitable top-frame for the debugger."
   (or (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)
@@ -406,9 +406,11 @@
     (if (dbg::call-frame-p frame)
 	(let ((dspec (dbg::call-frame-function-name frame))
               (cname (and (dbg::call-frame-p callee)
-                          (dbg::call-frame-function-name callee))))
+                          (dbg::call-frame-function-name callee)))
+              (path (and (dbg::call-frame-p frame)
+                         (dbg::call-frame-edit-path frame))))
 	  (if dspec
-              (frame-location dspec cname))))))
+              (frame-location dspec cname path))))))
 
 (defimplementation eval-in-frame (form frame-number)
   (let ((frame (nth-frame frame-number)))
@@ -432,19 +434,34 @@
 
 ;;; Definition finding
 
-(defun frame-location (dspec callee-name)
+(defun frame-location (dspec callee-name edit-path)
   (let ((infos (dspec:find-dspec-locations dspec)))
     (cond (infos 
            (destructuring-bind ((rdspec location) &rest _) infos
              (declare (ignore _))
              (let ((name (and callee-name (symbolp callee-name)
-                              (string callee-name))))
-               (make-dspec-location rdspec location 
-                                    `(:call-site ,name)))))
+                              (string callee-name)))
+                   (path (edit-path-to-cmucl-source-path edit-path)))
+               (make-dspec-location rdspec location
+                                    `(:call-site ,name :edit-path ,path)))))
           (t 
            (list :error (format nil "Source location not available for: ~S" 
                                 dspec))))))
 
+;; dbg::call-frame-edit-path is not documented but lets assume the
+;; binary representation of the integer EDIT-PATH should be
+;; interpreted as a sequence of CAR or CDR.  #b1111010 is roughly the
+;; same as cadadddr.  Something is odd with the highest bit.
+(defun edit-path-to-cmucl-source-path (edit-path)
+  (and edit-path
+       (cons 0
+             (let ((n -1))
+               (loop for i from (1- (integer-length edit-path)) downto 0
+                     if (logbitp i edit-path) do (incf n)
+                     else collect (prog1 n (setq n 0)))))))
+
+;; (edit-path-to-cmucl-source-path #b1111010) => (0 3 1)
+
 (defimplementation find-definitions (name)
   (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
     (loop for (dspec location) in locations




From heller at common-lisp.net  Sat Nov 13 11:18:03 2010
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 13 Nov 2010 06:18:03 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1PHE7P-0002HU-Tw@common-lisp.net>

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

Modified Files:
	ChangeLog swank-lispworks.lisp 
Log Message:
Improve source locations for compiler messages in Lispworks.

* swank-lispworks.lisp (map-error-database)
(signal-error-data-base, make-dspec-progenitor-location): Pass the
edit-path along.
(signal-undefined-functions): No edit-path available so just use
nil.

--- /project/slime/cvsroot/slime/ChangeLog	2010/11/12 19:42:51	1.2164
+++ /project/slime/cvsroot/slime/ChangeLog	2010/11/13 11:18:03	1.2165
@@ -1,3 +1,13 @@
+2010-11-13  Helmut Eller  <heller at common-lisp.net>
+
+	Improve source locations for compiler messages in Lispworks.
+
+	* swank-lispworks.lisp (map-error-database)
+	(signal-error-data-base, make-dspec-progenitor-location): Pass the
+	edit-path along.
+	(signal-undefined-functions): No edit-path available so just use
+	nil.
+
 2010-11-12  Helmut Eller  <heller at common-lisp.net>
 
 	Improve frame-source-location for Lispworks.
--- /project/slime/cvsroot/slime/swank-lispworks.lisp	2010/11/12 19:42:51	1.139
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp	2010/11/13 11:18:03	1.140
@@ -520,8 +520,10 @@
 (defun map-error-database (database fn)
   (loop for (filename . defs) in database do
 	(loop for (dspec . conditions) in defs do
-	      (dolist (c conditions) 
-		(funcall fn filename dspec (if (consp c) (car c) c))))))
+	      (dolist (c conditions)
+                (multiple-value-bind (condition path)
+                    (if (consp c) (values (car c) (cdr c)) (values c nil))
+                  (funcall fn filename dspec condition path))))))
 
 (defun lispworks-severity (condition)
   (cond ((not condition) :warning)
@@ -649,23 +651,25 @@
                       (dspec-function-name-position dspec `(:offset ,offset 0))
                       hints)))))
 
-(defun make-dspec-progenitor-location (dspec location)
+(defun make-dspec-progenitor-location (dspec location edit-path)
   (let ((canon-dspec (dspec:canonicalize-dspec dspec)))
     (make-dspec-location
      (if canon-dspec
          (if (dspec:local-dspec-p canon-dspec)
              (dspec:dspec-progenitor canon-dspec)
-           canon-dspec)
-       nil)
-     location)))
+             canon-dspec)
+         nil)
+     location
+     (if edit-path
+         (list :edit-path (edit-path-to-cmucl-source-path edit-path))))))
 
 (defun signal-error-data-base (database &optional location)
   (map-error-database 
    database
-   (lambda (filename dspec condition)
+   (lambda (filename dspec condition edit-path)
      (signal-compiler-condition
       (format nil "~A" condition)
-      (make-dspec-progenitor-location dspec (or location filename))
+      (make-dspec-progenitor-location dspec (or location filename) edit-path)
       condition))))
 
 (defun unmangle-unfun (symbol)
@@ -680,10 +684,11 @@
 	     (dolist (dspec dspecs)
 	       (signal-compiler-condition 
 		(format nil "Undefined function ~A" (unmangle-unfun unfun))
-		(make-dspec-progenitor-location dspec
-                                                (or filename
-                                                    (gethash (list unfun dspec)
-                                                             *undefined-functions-hash*)))
+		(make-dspec-progenitor-location 
+                 dspec
+                 (or filename
+                     (gethash (list unfun dspec) *undefined-functions-hash*))
+                 nil)
 		nil)))
 	   htab))