From trittweiler at common-lisp.net  Sun Mar  2 15:10:18 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Sun,  2 Mar 2008 10:10:18 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080302151018.EDED15622F@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv19061

Modified Files:
	slime.el 
Log Message:

* slime.el (slime-edit-definition-hooks): This variable can be
  used to hook into the M-. machinery.
  (slime-edit-definition): Run above hooks until one succeeds. By
  default, try to find a definition for the symbol at point.


--- /project/slime/cvsroot/slime/slime.el	2008/02/28 19:45:32	1.914
+++ /project/slime/cvsroot/slime/slime.el	2008/03/02 15:10:18	1.915
@@ -5139,14 +5139,17 @@
 (defun slime-xref-has-location-p (xref)
   (slime-location-p (slime-xref.location xref)))
 
+(defvar slime-edit-definition-hooks)
+
 (defun slime-edit-definition (name &optional where)
   "Lookup the definition of the name at point.  
 If there's no name at point, or a prefix argument is given, then the
 function name is prompted."
   (interactive (list (slime-read-symbol-name "Name: ")))
-  (slime-find-definitions name
-                          (slime-rcurry
-                           #'slime-edit-definition-cont name where)))
+  (or (run-hook-with-args-until-success 'slime-edit-definition-hooks (point))
+      (slime-find-definitions name
+                              (slime-rcurry
+                               #'slime-edit-definition-cont name where))))
 
 (defun slime-edit-definition-cont (xrefs name where)
   (destructuring-bind (1loc file-alist) (slime-analyze-xrefs xrefs)



From trittweiler at common-lisp.net  Sun Mar  2 15:10:34 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Sun,  2 Mar 2008 10:10:34 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080302151034.D19245C180@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv19120

Modified Files:
	ChangeLog 
Log Message:

* slime.el (slime-edit-definition-hooks): This variable can be
  used to hook into the M-. machinery.
  (slime-edit-definition): Run above hooks until one succeeds. By
  default, try to find a definition for the symbol at point.


--- /project/slime/cvsroot/slime/ChangeLog	2008/02/28 19:46:13	1.1308
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/02 15:10:34	1.1309
@@ -1,3 +1,10 @@
+2008-03-02  Tobias C. Rittweiler <tcr at freebits.de>
+
+	* slime.el (slime-edit-definition-hooks): This variable can be
+	used to hook into the M-. machinery.
+	(slime-edit-definition): Run above hooks until one succeeds. By
+	default, try to find a definition for the symbol at point.
+
 2008-02-28  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* swank.lisp (find-definition-for-thing): New DEFSLIMEFUN.



From trittweiler at common-lisp.net  Sun Mar  2 15:21:42 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Sun,  2 Mar 2008 10:21:42 -0500 (EST)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080302152142.5083D240F5@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv22329

Modified Files:
	slime-presentations.el 
Log Message:

M-. now works on presentations. 

Additionally, a Find Definition entry is presented in the menu
appearing on right clicking on a presentation.
	
* slime-presentations.lisp (slime-M-.-presentation): New function.
  (slime-M-.-presentation-at-mouse): New function.
  (slime-M-.-presentation-at-point): New function.
  (slime-maybe-M-.-presentation-at-point): New function.
  (slime-menu-choices-for-presentation): New entry "Find Definition".
  (slime-presentation-easy-menu): New entry "Find Definition".
  (slime-presentations-init): Hook into `slime-edit-definition-hooks'.


--- /project/slime/cvsroot/slime/contrib/slime-presentations.el	2008/02/15 17:35:29	1.13
+++ /project/slime/cvsroot/slime/contrib/slime-presentations.el	2008/03/02 15:21:42	1.14
@@ -374,6 +374,39 @@
       (slime-presentation-around-or-before-point-or-error point)
     (slime-inspect-presentation presentation start end (current-buffer))))
 
+
+(defun slime-M-.-presentation (presentation start end buffer)
+  (let* ((id (slime-presentation-id presentation))
+	 (presentation-string (format "Presentation %s" id))
+	 (location (slime-eval `(swank:find-definition-for-thing
+				 (swank::lookup-presented-object
+				  ',(slime-presentation-id presentation))))))
+    (slime-edit-definition-cont
+     (and location (list (make-slime-xref :dspec `(,presentation-string)
+					  :location location)))
+     presentation-string
+     nil)))
+
+(defun slime-M-.-presentation-at-mouse (event)
+  (interactive "e")
+  (multiple-value-bind (presentation start end buffer) 
+      (slime-presentation-around-click event)
+    (slime-M-.-presentation presentation start end buffer)))
+
+(defun slime-M-.-presentation-at-point (point)
+  (interactive "d")
+  (multiple-value-bind (presentation start end) 
+      (slime-presentation-around-or-before-point-or-error point)
+    (slime-M-.-presentation presentation start end (current-buffer))))
+
+(defun slime-maybe-M-.-presentation-at-point (point)
+  (interactive "d")
+  (multiple-value-bind (presentation start end whole-p)
+      (slime-presentation-around-or-before-point point)
+    (when presentation
+      (slime-M-.-presentation presentation start end (current-buffer)))))
+
+
 (defun slime-copy-presentation-to-repl (presentation start end buffer)
   (let ((presentation-text 
 	 (with-current-buffer buffer
@@ -550,6 +583,7 @@
       (list
        `(,(format "Presentation %s" what)
          ("" 
+	  ("Find Definition" . ,(savel 'slime-M-.-presentation-at-mouse))
           ("Inspect" . ,(savel 'slime-inspect-presentation-at-mouse))
           ("Describe" . ,(savel 'slime-describe-presentation-at-mouse))
           ("Pretty-print" . ,(savel 'slime-pretty-print-presentation-at-mouse))
@@ -680,6 +714,7 @@
 (defvar slime-presentation-easy-menu
   (let ((P '(slime-presentation-around-or-before-point-p)))
     `("Presentations"
+      [ "Find Definition" slime-M-.-presentation-at-point ,P ]
       [ "Inspect" slime-inspect-presentation-at-point ,P ]
       [ "Describe" slime-describe-presentation-at-point ,P ]
       [ "Pretty-print" slime-pretty-print-presentation-at-point ,P ]
@@ -831,6 +866,7 @@
   (add-hook 'slime-open-stream-hooks 'slime-presentation-on-stream-open)
   (add-hook 'slime-repl-clear-buffer-hook 'slime-clear-presentations)
   (add-hook 'slime-connected-hook 'slime-install-presentations)
+  (add-hook 'slime-edit-definition-hooks 'slime-maybe-M-.-presentation-at-point)
   (setq slime-inspector-insert-ispec-function 'slime-presentation-inspector-insert-ispec)
   (setq sldb-insert-frame-variable-value-function 
 	'slime-presentation-sldb-insert-frame-variable-value)



From trittweiler at common-lisp.net  Sun Mar  2 15:21:52 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Sun,  2 Mar 2008 10:21:52 -0500 (EST)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080302152152.471A024104@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv22543

Modified Files:
	ChangeLog 
Log Message:

M-. now works on presentations. 

Additionally, a Find Definition entry is presented in the menu
appearing on right clicking on a presentation.
	
* slime-presentations.lisp (slime-M-.-presentation): New function.
  (slime-M-.-presentation-at-mouse): New function.
  (slime-M-.-presentation-at-point): New function.
  (slime-maybe-M-.-presentation-at-point): New function.
  (slime-menu-choices-for-presentation): New entry "Find Definition".
  (slime-presentation-easy-menu): New entry "Find Definition".
  (slime-presentations-init): Hook into `slime-edit-definition-hooks'.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2008/02/21 20:49:31	1.94
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2008/03/02 15:21:52	1.95
@@ -1,3 +1,18 @@
+2008-03-02  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	M-. now works on presentations. 
+
+	Additionally, a Find Definition entry is presented in the menu
+	appearing on right clicking on a presentation.
+	
+	* slime-presentations.lisp (slime-M-.-presentation): New function.
+	(slime-M-.-presentation-at-mouse): New function.
+	(slime-M-.-presentation-at-point): New function.
+	(slime-maybe-M-.-presentation-at-point): New function.
+	(slime-menu-choices-for-presentation): New entry "Find Definition".
+	(slime-presentation-easy-menu): New entry "Find Definition".
+	(slime-presentations-init): Hook into `slime-edit-definition-hooks'.
+
 2008-02-21  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	Having the `slime-presentations' contrib enabled, (princ 10)



From heller at common-lisp.net  Sun Mar  2 22:41:45 2008
From: heller at common-lisp.net (heller)
Date: Sun,  2 Mar 2008 17:41:45 -0500 (EST)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080302224145.F0CC85D17A@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv759

Modified Files:
	ChangeLog 
Added Files:
	swank-mit-scheme.scm 
Log Message:
* swank-mit-scheme.scm: New file.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2008/03/02 15:21:52	1.95
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2008/03/02 22:41:45	1.96
@@ -13,6 +13,10 @@
 	(slime-presentation-easy-menu): New entry "Find Definition".
 	(slime-presentations-init): Hook into `slime-edit-definition-hooks'.
 
+2008-03-02  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-mit-scheme.scm: New file.
+
 2008-02-21  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	Having the `slime-presentations' contrib enabled, (princ 10)

--- /project/slime/cvsroot/slime/contrib/swank-mit-scheme.scm	2008/03/02 22:41:45	NONE
+++ /project/slime/cvsroot/slime/contrib/swank-mit-scheme.scm	2008/03/02 22:41:45	1.1
;;; swank-mit-scheme.scm --- SLIME server for MIT Scheme
;;
;; Copyright (C) 2008  Helmut Eller
;;
;; This file is licensed under the terms of the GNU General Public
;; License as distributed with Emacs (press C-h C-c for details).

;;;; Installation:
#|

1. You need MIT Scheme (version 7.7.0 and 7.7.90 seem to work).

2. You also need the `netcat' program to create sockets.  MIT Scheme
   has some socket functions built-in, but I couldn't figure out how
   to access the locat port number of a server socket.  We shell out
   to netcat to get us started.

3. The Emacs side needs a bit configuration.  I have the following in
   my .emacs:

(setq slime-lisp-implementations
      '((mit-scheme ("mit-scheme") :init mit-scheme-init)))

(defun mit-scheme-init (file encoding)
  (format "%S\n\n"
	  `(begin
	    (load-option 'format)
	    (load-option 'sos)
	    (eval 
	     '(construct-normal-package-from-description
	       (make-package-description '(swank) '(()) 
					 (vector) (vector) (vector) false))
	     (->environment '(package)))
	    (load ,(expand-file-name 
		    ".../contrib/swank-mit-scheme.scm" ; <-- insert your path
		    slime-path)
		  (->environment '(swank)))
	    (eval '(start-swank ,file) (->environment '(swank))))))

(defun mit-scheme ()
  (interactive)
  (slime 'mit-scheme))

(defun find-mit-scheme-package ()
  (save-excursion
    (let ((case-fold-search t))
      (and (re-search-backward "^[;]+ package: \\((.+)\\).*$" nil t)
	   (match-string-no-properties 1)))))

(setq slime-find-buffer-package-function 'find-mit-scheme-package)

   The `mit-scheme-init' function first loads the SOS and FORMAT
   libraries, then creates a package "(swank)", and loads this file
   into that package.  Finally it starts the server.  

   `find-mit-scheme-package' tries to figure out which package the
   buffer belongs to, assuming that ";;; package: (FOO)" appears
   somewhere in the file.  Luckily, this assumption is true for many of
   MIT Scheme's own files.  Alternatively, you could add Emacs style
   -*- slime-buffer-package: "(FOO)" -*- file variables.

4. Start everything with `M-x mit-scheme'.

|#

;;; package: (swank)

(define (swank port)
  (accept-connections (or port 4005) #f))

(define (start-swank port-file)
  (accept-connections #f port-file))

;;;; Networking

(define (accept-connections port port-file)
  (let ((nc (netcat port)))
    (format #t "Listening on port: ~s~%" (cadr nc))
    (if port-file (write-port-file (cadr nc) port-file))
    (dynamic-wind 
	(lambda () #f)
	(lambda () (serve (netcat-accept (car nc))))
	(lambda () (close-port (subprocess-input-port (car nc)))))))

(define (netcat port)
  (let* ((sh (os/shell-file-name))
	 (cmd (format #f "exec netcat -s localhost -q 0 -l -v ~a 2>&1"
		      (if port (format #f "-p ~a" port) "")))
	 (netcat (start-pipe-subprocess sh 
					(vector sh "-c" cmd)
					scheme-subprocess-environment))
	 (line (read-line (subprocess-input-port netcat)))
	 (match (re-string-match "^listening on \\[[^]]+\\] \\([0-9]+\\) ...$"
				 line)))
    (cond ((not match)
	   (close-port (subprocess-input-port netcat))
	   (error "netcat:" line))
	  (else (list netcat 
		      (string->number (re-match-extract line match 1)))))))

(define (netcat-accept nc)
  (let* ((rx "^connect to \\[[^]]+\\] from [^ ]+ \\[[^]]+\\] \\([0-9]+\\)$")
	 (line (read-line (subprocess-input-port nc)))
	 (match (re-string-match rx line)))
    (cond ((not match) (error "netcat:" line))
	  (else (subprocess-input-port nc)))))

(define (write-port-file portnumber filename)
  (call-with-output-file filename (lambda (p) (write portnumber p))))

(define *top-level-restart* #f)
(define (serve socket)
  (with-simple-restart 
      'disconnect "Close connection."
      (lambda ()
	(with-keyboard-interrupt-handler 
	    (lambda () (main-loop socket))))))

(define (disconnect) 
  (format #t "Disconnecting ...~%")
  (invoke-restart (find-restart 'disconnect)))

(define (main-loop socket)
  (do () (#f)
    (with-simple-restart 
	'abort "Return to SLIME top-level."
	(lambda () 
	  (fluid-let ((*top-level-restart* (find-restart 'abort)))
	    (dispatch (read-packet socket) socket 0))))))

(define (with-keyboard-interrupt-handler fun)
  (define (set-^G-handler exp)
    (eval `(vector-set! keyboard-interrupt-vector (char->ascii #\G) ,exp)
	  (->environment '(runtime interrupt-handler))))
  (dynamic-wind
      (lambda () #f)
      (lambda ()
	(set-^G-handler
	 `(lambda (char) (with-simple-restart
			  'continue "Continue from interrupt."
			  (lambda () (error "Keyboard Interrupt.")))))
	(fun))
      (lambda ()
	(set-^G-handler '^G-interrupt-handler))))


;;;; Reading/Writing of SLIME packets

(define (read-packet in)
  "Read an S-expression from STREAM using the SLIME protocol."
  (let* ((len (read-length in))
	 (buffer (make-string len)))
    (fill-buffer! in buffer)
    (read-from-string buffer)))

(define (write-packet message out)
  (let* ((string (write-to-string message)))
    (log-event "WRITE: [~a]~s~%" (string-length string) string)
    (write-length (string-length string) out)
    (write-string string out)
    (flush-output out)))

(define (fill-buffer! in buffer)
  (read-string! buffer in))

(define (read-length in)
  (if (eof-object? (peek-char in)) (disconnect))
  (do ((len 6 (1- len))
       (sum 0 (+ (* sum 16) (char->hex-digit (read-char in)))))
      ((zero? len) sum)))

(define (ldb size position integer)
  "LoaD a Byte of SIZE bits at bit position POSITION from INTEGER."
  (fix:and (fix:lsh integer (- position))
	   (1- (fix:lsh 1 size))))

(define (write-length len out)
  (do ((pos 20 (- pos 4)))
      ((< pos 0))
    (write-hex-digit (ldb 4 pos len) out)))

(define (write-hex-digit n out)
  (write-char (hex-digit->char n) out))

(define (hex-digit->char n)
  (digit->char n 16))

(define (char->hex-digit c)
  (char->digit c 16))


;;;; Event dispatching

(define (dispatch request socket level)
  (log-event "READ: ~s~%" request)
  (case (car request)
    ((:emacs-rex) (apply emacs-rex socket level (cdr request)))))

(define (swank-package)
  (or (name->package '(swank))
      (name->package '(user))))

(define *buffer-package* #f)
(define (find-buffer-package name)
  (if (elisp-false? name)
      #f
      (let ((v (ignore-errors 
		(lambda () (name->package (read-from-string name))))))
	(and (package? v) v))))

(define swank-env (->environment (swank-package)))
(define (user-env buffer-package)
  (cond ((string? buffer-package)
	 (let ((p (find-buffer-package buffer-package)))
	   (if (not p) (error "Invalid package name: " buffer-package))
	   (package/environment p)))
	(else (nearest-repl/environment))))

(define (emacs-rex socket level sexp package thread id)
  (let ((ok? #f) (result #f))
    (dynamic-wind
	(lambda () #f)
	(lambda ()
	  (bind-condition-handler 
	   (list condition-type:serious-condition)
	   (lambda (c) (invoke-sldb socket (1+ level) c))
	   (lambda ()
	     (fluid-let ((*buffer-package* package))
	       (set! result 
		     (eval (cons* (car sexp) socket (cdr sexp))
			   swank-env))
	       (set! ok? #t)))))
	(lambda ()
	  (write-packet `(:return ,(if ok? `(:ok ,result) '(:abort))
				   ,id)
			 socket)))))

(define (swank:connection-info _)
  (let ((p (environment->package (user-env #f))))
    `(:pid ,(unix/current-pid)
      :package (:name ,(write-to-string (package/name p))
		      :prompt ,(write-to-string (package/name p)))
      :lisp-implementation 
      (:type "MIT Scheme" :version ,(get-subsystem-version-string "release"))
      )))

(define (swank:quit-lisp _)
  (%exit))


;;;; Evaluation

(define (swank:listener-eval socket string)
  ;;(call-with-values (lambda () (eval-region string socket))
  ;;  (lambda values `(:values . ,(map write-to-string values))))
  `(:values ,(write-to-string (eval-region string socket))))

(define (eval-region string socket)
  (let ((sexp (read-from-string string)))
    (if (eof-object? exp)
	(values)
	(with-output-to-repl socket
	  (lambda () (eval sexp (user-env *buffer-package*)))))))

(define (with-output-to-repl socket fun)
  (let ((p (make-port repl-port-type socket)))
    (dynamic-wind
	(lambda () #f)
	(lambda () (with-output-to-port p fun))
	(lambda () (flush-output p)))))

(define (swank:interactive-eval socket string)
  ;;(call-with-values (lambda () (eval-region string)) format-for-echo-area)
  (format-values (eval-region string socket))
  )

(define (format-values . values)
  (if (null? values) 
      "; No value"
      (with-string-output-port
	  (lambda (out)
	    (write-string "=> " out)
	    (do ((vs values (cdr vs))) ((null? vs))
	      (write (car vs) out)
	      (if (not (null? (cdr vs)))
		  (write-string ", " out)))))))

(define (swank:pprint-eval _ string)
  (pprint-to-string (eval (read-from-string string) 
			  (user-env *buffer-package*))))

(define (swank:interactive-eval-region socket string)
  (format-values (eval-region string socket)))

(define (swank:set-package _ package)
  (set-repl/environment! (nearest-repl) 
			 (->environment (read-from-string package)))
  (let* ((p (environment->package (user-env #f)))
	 (n (write-to-string (package/name p))))
    (list n n)))

 
(define (repl-write-substring port string start end)
  (cond ((< start end)
	 (write-packet `(:write-string ,(substring string start end))
		       (port/state port))))
  (- end start))

(define (repl-write-char port char)
  (write-packet `(:write-string ,(string char))
                (port/state port)))

(define repl-port-type
  (make-port-type `((write-substring ,repl-write-substring)
		    (write-char ,repl-write-char)) #f))


;;;; Compilation

(define (swank:compile-string-for-emacs _ string . x)
  (call-compiler
   (lambda ()
     (let* ((sexps (snarf-string string))
	    (env (user-env *buffer-package*))
	    (scode (syntax `(begin , at sexps) env))
	    (compiled-expression (compile-scode scode #t)))
       (scode-eval compiled-expression env)))))

(define (snarf-string string)
  (with-input-from-string string
    (lambda () 
      (let loop ()
	(let ((e (read)))
	  (if (eof-object? e) '() (cons e (loop))))))))

(define (call-compiler fun)
  (let ((time #f))
    (with-timings fun
      (lambda (run-time gc-time real-time)
	(set! time real-time)))
    (list 'nil (format #f "~a" (internal-time/ticks->seconds time)))))

(define (swank:compiler-notes-for-emacs _) nil)

(define (swank:compile-file-for-emacs socket file load?)
  (call-compiler
   (lambda ()
     (with-output-to-repl socket
       (lambda () (compile-file file)))
     (cond ((elisp-true? load?)
	    (load (pathname-new-type file "com")
		  (user-env *buffer-package*)))))))

(define (swank:load-file socket file)
  (with-output-to-repl socket
    (lambda () (load file (user-env *buffer-package*)))))

(define (swank:disassemble-symbol _ string)
  (with-output-to-string
      (lambda () 
	(compiler:disassemble
	 (eval (read-from-string string) 
	       (user-env *buffer-package*))))))


;;; Arglist

(define (swank:operator-arglist socket name pack)
  (let ((v (ignore-errors
	    (lambda ()
	      (with-output-to-string 
		(lambda ()
		  (carefully-pa 
		   (eval (read-from-string name) (user-env pack)))))))))
    (if (condition? v) 'nil v)))

(define (carefully-pa o)
  (cond ((arity-dispatched-procedure? o) 
	 ;; MIT Scheme crashes for (pa /)
	 (display "arity-dispatched-procedure"))
	((procedure? o) (pa o))
	(else (error "Not a procedure"))))


;;; Some unimplemented stuff.
(define (swank:buffer-first-change . _) nil)
(define (swank:frame-catch-tags-for-emacs . _) nil)

[457 lines skipped]


From mbaringer at common-lisp.net  Tue Mar  4 13:40:51 2008
From: mbaringer at common-lisp.net (mbaringer)
Date: Tue,  4 Mar 2008 08:40:51 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080304134051.62A3655357@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv30634

Modified Files:
	swank.asd ChangeLog 
Log Message:
(asdf:output-files, asdf:perform): Make compile-op on
swank-loader-file a noop.


--- /project/slime/cvsroot/slime/swank.asd	2008/02/25 17:17:56	1.7
+++ /project/slime/cvsroot/slime/swank.asd	2008/03/04 13:40:50	1.8
@@ -28,6 +28,12 @@
 
 ;;;; make compile-op a nop
 
+(defmethod asdf:output-files ((o asdf:compile-op) (f swank-loader-file))
+  (list (asdf:component-pathname f)))
+
+(defmethod asdf:perform ((o asdf:compile-op) (f swank-loader-file))
+  t)
+
 (defmethod asdf:operation-done-p ((o asdf:compile-op) (f swank-loader-file))
   t)
 
--- /project/slime/cvsroot/slime/ChangeLog	2008/03/02 15:10:34	1.1309
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/04 13:40:50	1.1310
@@ -1,3 +1,8 @@
+2008-03-04  Andreas Fuchs <asf at boinkor.net>
+
+	* swank.asd (asdf:output-files, asdf:perform): Make compile-op on
+	swank-loader-file a noop.
+
 2008-03-02  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* slime.el (slime-edit-definition-hooks): This variable can be



From heller at common-lisp.net  Tue Mar  4 15:47:06 2008
From: heller at common-lisp.net (heller)
Date: Tue,  4 Mar 2008 10:47:06 -0500 (EST)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080304154706.933D756245@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv2106

Modified Files:
	swank-mit-scheme.scm 
Log Message:
Macro expansion commands for MIT Scheme.


--- /project/slime/cvsroot/slime/contrib/swank-mit-scheme.scm	2008/03/02 22:41:45	1.1
+++ /project/slime/cvsroot/slime/contrib/swank-mit-scheme.scm	2008/03/04 15:47:06	1.2
@@ -15,7 +15,7 @@
    to access the locat port number of a server socket.  We shell out
    to netcat to get us started.
 
-3. The Emacs side needs a bit configuration.  I have the following in
+3. The Emacs side needs some fiddling.  I have the following in
    my .emacs:
 
 (setq slime-lisp-implementations
@@ -363,6 +363,17 @@
 	       (user-env *buffer-package*))))))
 
 
+;;;; Macroexpansion
+
+(define (swank:swank-macroexpand-all _ string) 
+  (with-output-to-string
+      (lambda ()
+	(pp (syntax (read-from-string string)
+		    (user-env *buffer-package*))))))
+(define swank:swank-macroexpand-1 swank:swank-macroexpand-all)
+(define swank:swank-macroexpand swank:swank-macroexpand-all)
+
+
 ;;; Arglist
 
 (define (swank:operator-arglist socket name pack)



From heller at common-lisp.net  Tue Mar  4 15:48:41 2008
From: heller at common-lisp.net (heller)
Date: Tue,  4 Mar 2008 10:48:41 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080304154841.079E95832F@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv2220

Modified Files:
	test.sh ChangeLog 
Log Message:
Update test script for Emacs 23.


--- /project/slime/cvsroot/slime/test.sh	2007/08/27 13:16:49	1.9
+++ /project/slime/cvsroot/slime/test.sh	2008/03/04 15:48:40	1.10
@@ -49,27 +49,24 @@
 cp -r $slimedir/*.{el,lisp} ChangeLog $slimedir/contrib  $testdir
 mkfifo $dribble
 
-session=slime-screen.$$
-
-screen -S $session -m -D bash -c "$emacs -nw -q -no-site-file --no-site-file \
-       --eval '(setq debug-on-quit t)' \
-       --eval '(setq max-lisp-eval-depth 1000)' \
-       --eval '(setq load-path (cons \"$testdir\" load-path))' \
-       --eval '(require (quote slime))' \
-       --eval '(setq inferior-lisp-program \"$lisp\")' \
-       --eval '(slime-batch-test \"$results\")' > $dribble;\
-       echo \$? > $statusfile" &
-
-screenpid=$!
+cmd=($emacs -nw -q -no-site-file --no-site-file
+       --eval "(setq debug-on-quit t)"
+       --eval "(add-to-list 'load-path \"$testdir\")"
+       --eval "(require 'slime)"
+       --eval "(setq inferior-lisp-program \"$lisp\")"
+       --eval "(slime-batch-test \"$results\")")
 
 if [ "$verbose" = true ]; then
-    cat $dribble &
-else
-    cat $dribble > /dev/null &
-fi;
-
-trap "screen -S $session -X quit" SIGINT
-wait $screenpid
+    "${cmd[@]}"
+    echo $? > $statusfile
+else 
+    session=slime-screen.$$
+    screen -S $session -m -D \
+	bash -c "\"\$@\"; echo \$? > $statusfile" "" "${cmd[@]}" &
+    screenpid=$!
+    trap "screen -S $session -X quit" SIGINT
+    wait $screenpid
+fi
 
 if [ -f "$statusfile" ]; then
     [ "$dump_results" = true ] && cat $results;
--- /project/slime/cvsroot/slime/ChangeLog	2008/03/04 13:40:50	1.1310
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/04 15:48:40	1.1311
@@ -1,3 +1,7 @@
+2008-03-04  Helmut Eller  <heller at common-lisp.net>
+
+	* test.sh: Updated for Emacs 23.
+
 2008-03-04  Andreas Fuchs <asf at boinkor.net>
 
 	* swank.asd (asdf:output-files, asdf:perform): Make compile-op on



From heller at common-lisp.net  Sat Mar  8 08:42:21 2008
From: heller at common-lisp.net (heller)
Date: Sat,  8 Mar 2008 03:42:21 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080308084221.DDDC81F012@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv17641

Modified Files:
	ChangeLog slime.el 
Log Message:
Be GC friendlier when parsing net packets.

* slime.el (slime-net-read): Instead of consing a fresh string,
use narrow-to-region and read the packet out of the buffer.

--- /project/slime/cvsroot/slime/ChangeLog	2008/03/04 15:48:40	1.1311
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/08 08:42:21	1.1312
@@ -1,3 +1,10 @@
+2008-03-07  Helmut Eller  <heller at common-lisp.net>
+
+	Be GC friendlier when parsing net packets.
+
+	* slime.el (slime-net-read): Instead of consing a fresh string,
+	use narrow-to-region and read the packet out of the buffer.
+
 2008-03-04  Helmut Eller  <heller at common-lisp.net>
 
 	* test.sh: Updated for Emacs 23.
--- /project/slime/cvsroot/slime/slime.el	2008/03/02 15:10:18	1.915
+++ /project/slime/cvsroot/slime/slime.el	2008/03/08 08:42:21	1.916
@@ -1743,9 +1743,10 @@
          (start (+ 6 (point)))
          (end (+ start length)))
     (assert (plusp length))
-    (let ((string (buffer-substring-no-properties start end)))
-      (prog1 (read string)
-        (delete-region (point-min) end)))))
+    (prog1 (save-restriction
+             (narrow-to-region start end)
+             (read (current-buffer)))
+      (delete-region (point-min) end))))
 
 (defun slime-net-decode-length ()
   "Read a 24-bit hex-encoded integer from buffer."



From heller at common-lisp.net  Sat Mar  8 08:42:23 2008
From: heller at common-lisp.net (heller)
Date: Sat,  8 Mar 2008 03:42:23 -0500 (EST)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080308084223.AE0301F012@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv17669/contrib

Modified Files:
	ChangeLog swank-fancy-inspector.lisp 
Log Message:
Don't blindly override the inspect method for functions.

* swank-fancy-inspector.lisp (emacs-inspect function): Define this
method only if the backend hasn't defined one.
(inspect-function): New function.

--- /project/slime/cvsroot/slime/contrib/ChangeLog	2008/03/02 22:41:45	1.96
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2008/03/08 08:42:23	1.97
@@ -1,3 +1,11 @@
+2008-03-08  Helmut Eller  <heller at common-lisp.net>
+
+	Don't blindly override the inspect method for functions.
+
+	* swank-fancy-inspector.lisp (emacs-inspect function): Define this
+	method only if the backend hasn't defined one.
+	(inspect-function): New function.
+
 2008-03-02  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	M-. now works on presentations. 
--- /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp	2008/02/10 08:31:21	1.11
+++ /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp	2008/03/08 08:42:23	1.12
@@ -87,15 +87,19 @@
 	  (t 
 	   (list label ": " '(:newline) "  " docstring '(:newline))))))
 
-(defmethod emacs-inspect ((f function))
-  (append 
-	   (label-value-line "Name" (function-name f))
-	   `("Its argument list is: " 
-	     ,(inspector-princ (arglist f)) (:newline))
-	   (docstring-ispec "Documentation" f t)
-	   (if (function-lambda-expression f)
-	       (label-value-line "Lambda Expression"
-				 (function-lambda-expression f)))))
+(unless (find-method #'emacs-inspect '() (list (find-class 'function)) nil)
+  (defmethod emacs-inspect ((f function))
+    (inspect-function f)))
+
+(defun inspect-function (f)
+  (append
+   (label-value-line "Name" (function-name f))
+   `("Its argument list is: " 
+     ,(inspector-princ (arglist f)) (:newline))
+   (docstring-ispec "Documentation" f t)
+   (if (function-lambda-expression f)
+       (label-value-line "Lambda Expression"
+			 (function-lambda-expression f)))))
 
 (defun method-specializers-for-inspect (method)
   "Return a \"pretty\" list of the method's specializers. Normal



From heller at common-lisp.net  Thu Mar 13 10:42:49 2008
From: heller at common-lisp.net (heller)
Date: Thu, 13 Mar 2008 05:42:49 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080313104249.00A6762135@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv12311

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (sldb-toggle-details): Inhibit point-motion-hooks.
This is a workaround for problems with the --more-- field.

--- /project/slime/cvsroot/slime/ChangeLog	2008/03/08 08:42:21	1.1312
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/13 10:42:49	1.1313
@@ -1,3 +1,8 @@
+2008-03-08  Helmut Eller  <heller at common-lisp.net>
+
+	* slime.el (sldb-toggle-details): Inhibit point-motion-hooks.
+	This is a workaround for problems with the --more-- field.
+
 2008-03-07  Helmut Eller  <heller at common-lisp.net>
 
 	Be GC friendlier when parsing net packets.
--- /project/slime/cvsroot/slime/slime.el	2008/03/08 08:42:21	1.916
+++ /project/slime/cvsroot/slime/slime.el	2008/03/13 10:42:49	1.917
@@ -6744,7 +6744,7 @@
   (let ((inhibit-point-motion-hooks t)
         (inhibit-read-only t)
         (prev (get-text-property (point) 'sldb-previous-frame-number)))
-    ;; for unkown reasons, PREV is sometimes nil
+    ;; we may be called twice, PREV is nil the second time
     (when prev
       (let* ((count 40)
              (from (1+ prev))
@@ -6986,7 +6986,8 @@
 The details include local variable bindings and CATCH-tags."
   (interactive)
   (assert (sldb-frame-number-at-point))
-  (let ((inhibit-read-only t))
+  (let ((inhibit-read-only t)
+        (inhibit-point-motion-hooks t))
     (if (or on (not (sldb-frame-details-visible-p)))
 	(sldb-show-frame-details)
       (sldb-hide-frame-details))))



From heller at common-lisp.net  Thu Mar 13 10:42:58 2008
From: heller at common-lisp.net (heller)
Date: Thu, 13 Mar 2008 05:42:58 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080313104258.E8A3A62134@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv12352

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-inspector-operate-on-point): Signal an error if
there is no object to operate on.

--- /project/slime/cvsroot/slime/ChangeLog	2008/03/13 10:42:49	1.1313
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/13 10:42:58	1.1314
@@ -1,3 +1,8 @@
+2008-03-12  Helmut Eller  <heller at common-lisp.net>
+
+	* slime.el (slime-inspector-operate-on-point): Signal an error if
+	there is no object to operate on.
+
 2008-03-08  Helmut Eller  <heller at common-lisp.net>
 
 	* slime.el (sldb-toggle-details): Inhibit point-motion-hooks.
--- /project/slime/cvsroot/slime/slime.el	2008/03/13 10:42:49	1.917
+++ /project/slime/cvsroot/slime/slime.el	2008/03/13 10:42:58	1.918
@@ -7576,7 +7576,8 @@
            (slime-inspector-fetch-range range-button))
           (action-number 
            (slime-eval-async `(swank::inspector-call-nth-action ,action-number)
-                             opener)))))
+                             opener))
+          (t (error "No object at point")))))
 
 (defun slime-inspector-operate-on-click (event)
   "Inspect the value at the clicked-at position or invoke an action."



From heller at common-lisp.net  Thu Mar 13 10:43:08 2008
From: heller at common-lisp.net (heller)
Date: Thu, 13 Mar 2008 05:43:08 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080313104308.8C6C67E011@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv12415

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-find-definitions-function): Renamed from
slime-edit-definition-fallback-function.
(slime-find-definitions): Use it.
(slime-find-tag-if-tags-table-visited): Deleted.

--- /project/slime/cvsroot/slime/ChangeLog	2008/03/13 10:42:58	1.1314
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/13 10:43:07	1.1315
@@ -1,5 +1,12 @@
 2008-03-12  Helmut Eller  <heller at common-lisp.net>
 
+	* slime.el (slime-find-definitions-function): Renamed from
+	slime-edit-definition-fallback-function.
+	(slime-find-definitions): Use it.
+	(slime-find-tag-if-tags-table-visited): Deleted.
+
+2008-03-12  Helmut Eller  <heller at common-lisp.net>
+
 	* slime.el (slime-inspector-operate-on-point): Signal an error if
 	there is no object to operate on.
 
--- /project/slime/cvsroot/slime/slime.el	2008/03/13 10:42:58	1.918
+++ /project/slime/cvsroot/slime/slime.el	2008/03/13 10:43:07	1.919
@@ -226,19 +226,20 @@
   :prefix "slime-"
   :group 'slime)
 
-(defcustom slime-edit-definition-fallback-function nil
-  "Function to call when edit-definition fails to find the source itself.
-The function is called with the definition name, a string, as its argument.
-
-If you want to fallback on TAGS you can set this to `find-tag',
-`slime-find-tag-if-tags-table-visited', or
-`slime-edit-definition-with-etags'."
-  :type 'symbol
-  :group 'slime-mode-mode
-  :options '(nil 
-             slime-edit-definition-with-etags
-             slime-find-tag-if-tags-table-visited
-             find-tag))
+(defcustom slime-find-definitions-function 'slime-find-definitions-rpc
+  "Function to find definitions for a name.
+The function is called with the definition name, a string, as its argument."
+  :type 'function
+  :group 'slime-mode
+  :options '(slime-find-definitions-rpc
+             slime-etags-definitions
+             (lambda (name)
+               (append (slime-find-definitions-rpc name)
+                       (slime-etags-definitions name)))
+             (lambda (name)
+               (or (slime-find-definitions-rpc name)
+                   (and tags-table-list
+                        (slime-etags-definitions name))))))
 
 (defcustom slime-complete-symbol-function 'slime-simple-complete-symbol
   "*Function to perform symbol completion."
@@ -5148,9 +5149,8 @@
 function name is prompted."
   (interactive (list (slime-read-symbol-name "Name: ")))
   (or (run-hook-with-args-until-success 'slime-edit-definition-hooks (point))
-      (slime-find-definitions name
-                              (slime-rcurry
-                               #'slime-edit-definition-cont name where))))
+      (slime-edit-definition-cont (slime-find-definitions name)
+                                  name where)))
 
 (defun slime-edit-definition-cont (xrefs name where)
   (destructuring-bind (1loc file-alist) (slime-analyze-xrefs xrefs)
@@ -5199,21 +5199,12 @@
     (window (pop-to-buffer (current-buffer) t))
     (frame (let ((pop-up-frames t)) (pop-to-buffer (current-buffer) t)))))
 
-(defun slime-find-definitions (name cont)
+(defun slime-find-definitions (name)
   "Find definitions for NAME and pass them to CONT."
-  ;; FIXME: append SWANK xrefs and etags xrefs
-  (funcall cont
-           (or (slime-eval `(swank:find-definitions-for-emacs ,name))
-               (and slime-edit-definition-fallback-function
-                    (funcall slime-edit-definition-fallback-function name)))))
-
-(defun slime-find-tag-if-tags-table-visited (name)
-  "Find tag (in current tags table) whose name contains NAME.
-If no tags table is visited, don't offer to visit one;
-just signal that no definition is known."
-  (if tags-table-list
-      (find-tag name)
-    (error "No known definition for: %s; use M-x visit-tags-table RET" name)))
+  (funcall slime-find-definitions-function name))
+
+(defun slime-find-definitions-rpc (name)
+  (slime-eval `(swank:find-definitions-for-emacs ,name)))
  
 (defun slime-edit-definition-other-window (name)
   "Like `slime-edit-definition' but switch to the other window."



From heller at common-lisp.net  Thu Mar 13 10:43:17 2008
From: heller at common-lisp.net (heller)
Date: Thu, 13 Mar 2008 05:43:17 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080313104317.651CC7E01E@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv12605

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-xref-group): Renamed from slime-location-to-string.
Handle source-form locations.

--- /project/slime/cvsroot/slime/ChangeLog	2008/03/13 10:43:07	1.1315
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/13 10:43:17	1.1316
@@ -1,3 +1,8 @@
+2008-03-13  Helmut Eller  <heller at common-lisp.net>
+
+	* slime.el (slime-xref-group): Renamed from slime-location-to-string.
+	Handle source-form locations.
+
 2008-03-12  Helmut Eller  <heller at common-lisp.net>
 
 	* slime.el (slime-find-definitions-function): Renamed from
--- /project/slime/cvsroot/slime/slime.el	2008/03/13 10:43:07	1.919
+++ /project/slime/cvsroot/slime/slime.el	2008/03/13 10:43:17	1.920
@@ -100,7 +100,7 @@
     (let ((changelog (concat slime-path "ChangeLog")))
       (if (file-exists-p changelog)
           (with-temp-buffer 
-            (insert-file-contents changelog nil 0 100)
+            (insert-file-contents-literally changelog nil 0 100)
             (goto-char (point-min))
             (symbol-name (read (current-buffer))))
         nil))))
@@ -2509,7 +2509,6 @@
 (defvar slime-repl-input-start-mark)
 (defvar slime-repl-prompt-start-mark)
 
-
 (defun slime-output-buffer (&optional noprompt)
   "Return the output buffer, create it if necessary."
   (let ((buffer (slime-connection-output-buffer)))
@@ -3810,8 +3809,8 @@
 ;;;;; Cleanup after a quit
 
 (defun slime-kill-all-buffers ()
-  "Kill all the slime related buffers. This is only used by the
-  repl command sayoonara."
+  "Kill all the slime related buffers.
+This is only used by the repl command sayoonara."
   (dolist (buf (buffer-list))
     (when (or (string= (buffer-name buf) slime-event-buffer-name)
               (string-match "^\\*inferior-lisp*" (buffer-name buf))
@@ -5176,21 +5175,21 @@
                (and (slime-location-p loc)
                     (every (lambda (x) (equal (slime-xref.location x) loc))
                            (cdr xrefs)))))
-        (slime-alistify xrefs
-                        (lambda (x)
-                          (if (slime-xref-has-location-p x)
-                              (slime-location-to-string (slime-xref.location x))
-                            "Error"))
-                        #'equal)))
-
-(defun slime-location-to-string (location)
-  (destructure-case (slime-location.buffer location)
-    ((:file filename) filename)
-    ((:buffer bufname)
-     (let ((buffer (get-buffer bufname)))
-       (if buffer 
-           (format "%S" buffer) ; "#<buffer foo.lisp>"
-           (format "%s (previously existing buffer)" bufname))))))
+        (slime-alistify xrefs #'slime-xref-group #'equal)))
+
+(defun slime-xref-group (xref)
+  (cond ((slime-xref-has-location-p xref)
+         (destructure-case (slime-location.buffer (slime-xref.location xref))
+           ((:file filename) filename)
+           ((:buffer bufname)
+            (let ((buffer (get-buffer bufname)))
+              (if buffer 
+                  (format "%S" buffer) ; "#<buffer foo.lisp>"
+                (format "%s (previously existing buffer)" bufname))))
+           ((:source-form _)
+            "(S-Exp)")))
+        (t
+         "(No location)")))
 
 (defun slime-pop-to-location (location &optional where)
   (slime-goto-source-location location)



From heller at common-lisp.net  Thu Mar 13 10:43:26 2008
From: heller at common-lisp.net (heller)
Date: Thu, 13 Mar 2008 05:43:26 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080313104326.AE7FE62134@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv12736

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-region-for-defun-function): Deleted.
(slime-region-for-defun-at-point): Use beginning-of-defun
and not beginning-of-sexp.
(slime-flash-region): New function.
(slime-compile-region): Use it.

--- /project/slime/cvsroot/slime/ChangeLog	2008/03/13 10:43:17	1.1316
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/13 10:43:26	1.1317
@@ -1,5 +1,13 @@
 2008-03-13  Helmut Eller  <heller at common-lisp.net>
 
+	* slime.el (slime-region-for-defun-function): Deleted.
+	(slime-region-for-defun-at-point): Use beginning-of-defun
+	and not beginning-of-sexp.
+	(slime-flash-region): New function.
+	(slime-compile-region): Use it.
+
+2008-03-13  Helmut Eller  <heller at common-lisp.net>
+
 	* slime.el (slime-xref-group): Renamed from slime-location-to-string.
 	Handle source-form locations.
 
--- /project/slime/cvsroot/slime/slime.el	2008/03/13 10:43:17	1.920
+++ /project/slime/cvsroot/slime/slime.el	2008/03/13 10:43:26	1.921
@@ -3890,9 +3890,15 @@
 (defun slime-compile-region (start end)
   "Compile the region."
   (interactive "r")
+  (slime-flash-region start end)
   (run-hook-with-args 'slime-before-compile-functions start end)
   (slime-compile-string (buffer-substring-no-properties start end) start))
 
+(defun slime-flash-region (start end &optional timeout)
+  (let ((overlay (make-overlay start end))) 
+    (overlay-put overlay 'face 'secondary-selection)
+    (run-with-timer (or timeout 0.2) nil 'delete-overlay overlay)))
+
 (defun slime-compile-string (string start-offset)
   (slime-eval-async 
    `(swank:compile-string-for-emacs
@@ -9116,18 +9122,14 @@
   (apply #'buffer-substring-no-properties
          (slime-region-for-defun-at-point)))
 
-(defvar slime-region-for-defun-function nil)
-
 (defun slime-region-for-defun-at-point ()
   "Return the start and end position of the toplevel form at point."
-  (or (and slime-region-for-defun-function
-           (funcall slime-region-for-defun-function))
-      (save-excursion
-        (save-match-data
-          (end-of-defun)
-          (let ((end (point)))
-            (beginning-of-sexp)
-            (list (point) end))))))
+  (save-excursion
+    (save-match-data
+      (end-of-defun)
+      (let ((end (point)))
+        (beginning-of-defun)
+        (list (point) end)))))
 
 (defun slime-beginning-of-symbol ()
   "Move point to the beginning of the current symbol."



From trittweiler at common-lisp.net  Thu Mar 13 15:20:26 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Thu, 13 Mar 2008 10:20:26 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080313152026.A8A98340CD@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv28037

Modified Files:
	slime.el 
Log Message:

* slime.el (slime-edit-definition-cont): If no definition could
  be found, print also the package name in the error message where
  the definition was tried to be found in.


--- /project/slime/cvsroot/slime/slime.el	2008/03/13 10:43:26	1.921
+++ /project/slime/cvsroot/slime/slime.el	2008/03/13 15:20:25	1.922
@@ -2216,7 +2216,7 @@
 If `slime-buffer-package' has a value then return that, otherwise
 search for and read an `in-package' form.
 
-The REPL buffer is a special case: it's package is `slime-lisp-package'."
+The REPL buffer is a special case: its package is `slime-lisp-package'."
   (cond ((eq major-mode 'slime-repl-mode)
          (slime-lisp-package))
         (slime-buffer-package)
@@ -5160,7 +5160,8 @@
 (defun slime-edit-definition-cont (xrefs name where)
   (destructuring-bind (1loc file-alist) (slime-analyze-xrefs xrefs)
     (cond ((null xrefs) 
-           (error "No known definition for: %s" name))
+           (error "No known definition for: %s (in %s)" 
+                  name (or (slime-current-package) (slime-lisp-package))))
           (1loc
            (slime-push-definition-stack)
            (slime-pop-to-location (slime-xref.location (car xrefs)) where))



From trittweiler at common-lisp.net  Thu Mar 13 15:21:03 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Thu, 13 Mar 2008 10:21:03 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080313152103.8172A3F026@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv29123

Modified Files:
	ChangeLog 
Log Message:

* slime.el (slime-edit-definition-cont): If no definition could
  be found, print also the package name in the error message where
  the definition was tried to be found in.


--- /project/slime/cvsroot/slime/ChangeLog	2008/03/13 10:43:26	1.1317
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/13 15:21:03	1.1318
@@ -1,3 +1,9 @@
+2008-03-13  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime.el (slime-edit-definition-cont): If no definition could
+	be found, print also the package name in the error message where
+	the definition was tried to be found in.
+	
 2008-03-13  Helmut Eller  <heller at common-lisp.net>
 
 	* slime.el (slime-region-for-defun-function): Deleted.



From trittweiler at common-lisp.net  Thu Mar 13 23:45:00 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Thu, 13 Mar 2008 18:45:00 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080313234500.AE85D3F026@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv6082

Modified Files:
	slime.el 
Log Message:

* slime.el (slime-eval-macroexpand): Indent expansion.


--- /project/slime/cvsroot/slime/slime.el	2008/03/13 15:20:25	1.922
+++ /project/slime/cvsroot/slime/slime.el	2008/03/13 23:45:00	1.923
@@ -6267,6 +6267,8 @@
          (slime-macroexpansion-minor-mode)
          (erase-buffer)
          (insert expansion)
+         (goto-char (point-min))
+         (indent-sexp)
          (font-lock-fontify-buffer))))))
 
 (defun slime-eval-macroexpand-inplace (expander)



From trittweiler at common-lisp.net  Thu Mar 13 23:45:36 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Thu, 13 Mar 2008 18:45:36 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080313234536.4E3677914F@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv6343

Modified Files:
	ChangeLog 
Log Message:

* slime.el (slime-eval-macroexpand): Indent expansion.


--- /project/slime/cvsroot/slime/ChangeLog	2008/03/13 15:21:03	1.1318
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/13 23:45:35	1.1319
@@ -1,5 +1,9 @@
 2008-03-13  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* slime.el (slime-eval-macroexpand): Indent expansion.
+	
+2008-03-13  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	* slime.el (slime-edit-definition-cont): If no definition could
 	be found, print also the package name in the error message where
 	the definition was tried to be found in.



From trittweiler at common-lisp.net  Fri Mar 14 14:04:31 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Fri, 14 Mar 2008 09:04:31 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080314140431.8A19A2E2CC@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv13384

Modified Files:
	swank.lisp 
Log Message:

* swank.lisp (classify-symbol, symbol-classification->string): Add
  classification of symbols denoting type specifier, and denoting
  constants.


--- /project/slime/cvsroot/slime/swank.lisp	2008/02/28 19:43:58	1.538
+++ /project/slime/cvsroot/slime/swank.lisp	2008/03/14 14:04:31	1.539
@@ -493,30 +493,38 @@
 
 
 (defun classify-symbol (symbol)
-  "Returns a list of classifiers that classify SYMBOL according
-to its underneath objects (e.g. :BOUNDP if SYMBOL constitutes a
-special variable.) The list may contain the following classification
-keywords: :BOUNDP, :FBOUNDP, :GENERIC-FUNCTION, :CLASS, :MACRO, 
-:SPECIAL-OPERATOR, and/or :PACKAGE"
+  "Returns a list of classifiers that classify SYMBOL according to its
+underneath objects (e.g. :BOUNDP if SYMBOL constitutes a special
+variable.) The list may contain the following classification
+keywords: :BOUNDP, :FBOUNDP, :CONSTANT, :GENERIC-FUNCTION,
+:TYPESPEC, :CLASS, :MACRO, :SPECIAL-OPERATOR, and/or :PACKAGE"
   (check-type symbol symbol)
-  (let (result)
-    (when (boundp symbol)             (push :boundp result))
-    (when (fboundp symbol)            (push :fboundp result))
-    (when (find-class symbol nil)     (push :class result))
-    (when (macro-function symbol)     (push :macro result))
-    (when (special-operator-p symbol) (push :special-operator result))
-    (when (find-package symbol)       (push :package result))
-    (when (typep (ignore-errors (fdefinition symbol))
-                 'generic-function)
-      (push :generic-function result))
-    result))
+  (flet ((type-specifier-p (s)
+           (or (documentation s 'type)
+               (not (eq (type-specifier-arglist s) :not-available)))))
+    (let (result)
+      (when (boundp symbol)             (push (if (constantp symbol)
+                                                  :constant :boundp) result))
+      (when (fboundp symbol)            (push :fboundp result))
+      (when (type-specifier-p symbol)   (push :typespec result))
+      (when (find-class symbol nil)     (push :class result))
+      (when (macro-function symbol)     (push :macro result))
+      (when (special-operator-p symbol) (push :special-operator result))
+      (when (find-package symbol)       (push :package result))
+      (when (typep (ignore-errors (fdefinition symbol))
+                   'generic-function)
+        (push :generic-function result))
+
+      result)))
 
 (defun symbol-classification->string (flags)
-  (format nil "~A~A~A~A~A~A~A"
-          (if (member :boundp flags) "b" "-")
+  (format nil "~A~A~A~A~A~A~A~A"
+          (if (or (member :boundp flags)
+                  (member :constant flags)) "b" "-")
           (if (member :fboundp flags) "f" "-")
           (if (member :generic-function flags) "g" "-")
           (if (member :class flags) "c" "-")
+          (if (member :typespec flags) "t" "-")
           (if (member :macro flags) "m" "-")
           (if (member :special-operator flags) "s" "-")
           (if (member :package flags) "p" "-")))



From trittweiler at common-lisp.net  Fri Mar 14 14:05:04 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Fri, 14 Mar 2008 09:05:04 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080314140504.66CDA49024@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv13441

Modified Files:
	ChangeLog 
Log Message:

* swank.lisp (classify-symbol, symbol-classification->string): Add
  classification of symbols denoting type specifier, and denoting
  constants.


--- /project/slime/cvsroot/slime/ChangeLog	2008/03/13 23:45:35	1.1319
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/14 14:05:04	1.1320
@@ -1,3 +1,9 @@
+2008-03-14  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* swank.lisp (classify-symbol, symbol-classification->string): Add
+	classification of symbols denoting type specifier, and denoting
+	constants.
+	
 2008-03-13  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime.el (slime-eval-macroexpand): Indent expansion.



From trittweiler at common-lisp.net  Fri Mar 14 14:14:51 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Fri, 14 Mar 2008 09:14:51 -0500 (EST)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080314141451.AEAA8450C8@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv16256/contrib

Modified Files:
	swank-fancy-inspector.lisp 
Log Message:

* swank-fancy-inspector.lisp (make-symbols-listing :classification):
  Add support for typespec and constant classification; don't
  silently ignore symbols that can't be usefully classified, but
  group them under "MISC".


--- /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp	2008/03/08 08:42:23	1.12
+++ /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp	2008/03/14 14:14:51	1.13
@@ -342,7 +342,7 @@
 
 ;; Wrapper structure over the list of symbols of a package that should
 ;; be displayed with their respective classification flags. This is
-;; because we need a unique type to dispatch on in INSPECT-FOR-EMACS.
+;; because we need a unique type to dispatch on in EMACS-INSPECT.
 ;; Used by the Inspector for packages.
 (defstruct (%package-symbols-container (:conc-name   %container.)
                                        (:constructor %%make-package-symbols-container))
@@ -381,7 +381,7 @@
         ,(concatenate 'string        ; underlining dashes
                       (make-string (+ max-length distance -1) :initial-element #\-)
                       " "
-                      (let* ((dummy (classify-symbol (gensym)))
+                      (let* ((dummy (classify-symbol :foo))
                              (dummy (symbol-classification->string dummy))
                              (classification-length (length dummy)))
                         (make-string classification-length :initial-element #\-)))
@@ -402,21 +402,29 @@
 specified to be FBOUNDP, there is no general FBOUNDP group,
 instead there are the three explicit FUNCTION, MACRO and
 SPECIAL-OPERATOR groups."
-  (let ((table (make-hash-table :test #'eq)))
-    (flet ((maybe-convert-fboundps (classifications)
-             ;; Convert an :FBOUNDP in CLASSIFICATIONS to :FUNCTION if possible.
-             (if (and (member :fboundp classifications)
-                      (not (member :macro classifications))
-                      (not (member :special-operator classifications)))
-                 (substitute :function :fboundp classifications)
-                 (remove :fboundp classifications))))
+  (let ((table (make-hash-table :test #'eq))
+	(+default-classification+ :misc))
+    (flet ((normalize-classifications (classifications)
+             (cond ((null classifications) `(,+default-classification+))
+		   ;; Convert an :FBOUNDP in CLASSIFICATIONS to :FUNCTION if possible.
+		   ((and (member :fboundp classifications)
+			 (not (member :macro classifications))
+			 (not (member :special-operator classifications)))
+		      (substitute :function :fboundp classifications))
+		   (t (remove :fboundp classifications)))))
       (loop for symbol in symbols do
-            (loop for classification in (maybe-convert-fboundps (classify-symbol symbol))
+            (loop for classification in (normalize-classifications (classify-symbol symbol))
                   ;; SYMBOLS are supposed to be sorted alphabetically;
                   ;; this property is preserved here except for reversing.
                   do (push symbol (gethash classification table)))))
     (let* ((classifications (loop for k being each hash-key in table collect k))
-           (classifications (sort classifications #'string<)))
+           (classifications (sort classifications
+				  ;; Sort alphabetically, except +DEFAULT-CLASSIFICATION+
+				  ;; which sort to the end.
+				  #'(lambda (a b)
+				      (cond ((eql a +default-classification+) nil)
+					    ((eql b +default-classification+) t)
+					    (t (string< a b)))))))
       (loop for classification in classifications
             for symbols = (gethash classification table)
             appending`(,(symbol-name classification)



From trittweiler at common-lisp.net  Fri Mar 14 14:15:06 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Fri, 14 Mar 2008 09:15:06 -0500 (EST)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080314141506.18D161703F@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv16428/contrib

Modified Files:
	ChangeLog 
Log Message:

* swank-fancy-inspector.lisp (make-symbols-listing :classification):
  Add support for typespec and constant classification; don't
  silently ignore symbols that can't be usefully classified, but
  group them under "MISC".


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2008/03/08 08:42:23	1.97
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2008/03/14 14:15:06	1.98
@@ -1,3 +1,10 @@
+2008-03-08  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* swank-fancy-inspector.lisp (make-symbols-listing :classification):
+	Add support for typespec and constant classification; don't
+	silently ignore symbols that can't be usefully classified, but
+	group them under "MISC".
+
 2008-03-08  Helmut Eller  <heller at common-lisp.net>
 
 	Don't blindly override the inspect method for functions.



From trittweiler at common-lisp.net  Fri Mar 14 14:31:52 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Fri, 14 Mar 2008 09:31:52 -0500 (EST)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080314143152.2E8F01F009@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv21260/contrib

Modified Files:
	swank-fuzzy.lisp 
Log Message:

* swank-fuzzy.lisp (fuzzy-convert-matching-for-emacs): Return a
  string representation of the classifications rather than the
  classifications themselves. (Notice this propagates up to (and
  consequently changes the return value of) the RPC function
  FUZZY-COMPLETIONS. (incompatible api change.)  

  Rationale: The number of supported classification can be changed
  without having to adapt its display at the client.

* slime-fuzzy.lisp (slime-fuzzy-insert-completion-choice):
  (slime-fuzzy-fill-completions-buffer): Adapted to API change.


--- /project/slime/cvsroot/slime/contrib/swank-fuzzy.lisp	2008/01/10 00:39:37	1.7
+++ /project/slime/cvsroot/slime/contrib/swank-fuzzy.lisp	2008/03/14 14:31:52	1.8
@@ -30,14 +30,14 @@
 The main result is a list of completion objects, where a completion
 object is:
 
-    (COMPLETED-STRING SCORE (&rest CHUNKS) FLAGS)
+    (COMPLETED-STRING SCORE (&rest CHUNKS) CLASSIFICATION-STRING)
 
 where a CHUNK is a description of a matched substring:
 
     (OFFSET SUBSTRING)
 
-and FLAGS is a list of keywords describing properties of the 
-symbol (see CLASSIFY-SYMBOL).
+and FLAGS is short string describing properties of the symbol (see
+CLASSIFY-SYMBOL and STRING-CLASSIFICATION->STRING).
 
 E.g., completing \"mvb\" in a package that uses COMMON-LISP would
 return something like:
@@ -131,11 +131,11 @@
       (values result (search symbol-name result)))))
 
 (defun fuzzy-convert-matching-for-emacs (fuzzy-matching user-input-string)
-  "Converts a result from the fuzzy completion core into
-something that emacs is expecting.  Converts symbols to strings,
-fixes case issues, and adds information describing if the symbol
-is :bound, :fbound, a :class, a :macro, a :generic-function,
-a :special-operator, or a :package."
+  "Converts a result from the fuzzy completion core into something
+that emacs is expecting.  Converts symbols to strings, fixes case
+issues, and adds information (as a string) describing if the symbol is
+bound, fbound, a class, a macro, a generic-function, a
+special-operator, or a package."
   (with-struct (fuzzy-matching. symbol score package-chunks symbol-chunks) fuzzy-matching
     (multiple-value-bind (name added-length)
 	(fuzzy-format-matching fuzzy-matching user-input-string)
@@ -148,7 +148,7 @@
 				(let ((offset (first chunk)) (string (second chunk)))
 				  (list (+ added-length offset) string))) 
 			    symbol-chunks))
-	    (classify-symbol symbol)))))
+	    (symbol-classification->string (classify-symbol symbol))))))
 
 (defun fuzzy-completion-set (string default-package-name &key limit time-limit-in-msec)
   "Returns two values: an array of completion objects, sorted by



From trittweiler at common-lisp.net  Fri Mar 14 14:33:07 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Fri, 14 Mar 2008 09:33:07 -0500 (EST)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080314143307.6D5344908B@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv22176

Modified Files:
	slime-fuzzy.el 
Log Message:

* swank-fuzzy.lisp (fuzzy-convert-matching-for-emacs): Return a
  string representation of the classifications rather than the
  classifications themselves. (Notice this propagates up to (and
  consequently changes the return value of) the RPC function
  FUZZY-COMPLETIONS. (incompatible api change.)  

  Rationale: The number of supported classification can be changed
  without having to adapt its display at the client.

* slime-fuzzy.lisp (slime-fuzzy-insert-completion-choice):
  (slime-fuzzy-fill-completions-buffer): Adapted to API change.


--- /project/slime/cvsroot/slime/contrib/slime-fuzzy.el	2008/01/10 00:39:19	1.6
+++ /project/slime/cvsroot/slime/contrib/slime-fuzzy.el	2008/03/14 14:33:07	1.7
@@ -294,30 +294,22 @@
   "Inserts the completion object `completion' as a formatted
 completion choice into the current buffer, and mark it with the
 proper text properties."
-  (let ((start (point))
-        (symbol-name (first completion))
-        (score (second completion))
-        (chunks (third completion))
-        (flags (fourth completion)))
-    (insert symbol-name)
-    (let ((end (point)))
+  (destructuring-bind (symbol-name score chunks classification-string) completion
+    (let ((start (point))
+	  (end))
+      (insert symbol-name)
+      (setq end (point))
       (dolist (chunk chunks)
-        (put-text-property (+ start (first chunk)) 
-                           (+ start (first chunk) 
-                              (length (second chunk)))
-                           'face 'bold))
+	(put-text-property (+ start (first chunk)) 
+			   (+ start (first chunk) 
+			      (length (second chunk)))
+			   'face 'bold))
       (put-text-property start (point) 'mouse-face 'highlight)
       (dotimes (i (- max-length (- end start)))
-        (insert " "))
-      (insert (format " %s%s%s%s%s%s%s %8.2f"
-                      (if (member :boundp flags) "b" "-")
-                      (if (member :fboundp flags) "f" "-")
-                      (if (member :generic-function flags) "g" "-")
-                      (if (member :class flags) "c" "-")
-                      (if (member :macro flags) "m" "-")
-                      (if (member :special-operator flags) "s" "-")
-                      (if (member :package flags) "p" "-")
-                      score))
+	(insert " "))
+      (insert (format " %s %-8.2f"
+		      classification-string
+		      score))
       (insert "\n")
       (put-text-property start (point) 'completion completion))))
 
@@ -386,13 +378,20 @@
 
       (insert "Completion:")
       (dotimes (i (- max-length 10)) (insert " "))
-      ;;     Flags:  Score:
-      ;; ... ------- --------
-      ;;     bfgcmsp 
-      (insert "Flags:  Score:\n")
-      (dotimes (i max-length) (insert "-"))
-      (insert " ------- --------\n")
-      (setq slime-fuzzy-first (point))
+      ;;     Flags:   Score:
+      ;; ... -------  --------
+      ;;     bfgctmsp
+      (let* ((example-classification-string (fourth (first completions)))
+	     (classification-length (length example-classification-string))
+	     (spaces (- classification-length (length "Flags:"))))
+	(insert "Flags:")
+	(dotimes (i spaces) (insert " "))
+	(insert " Score:\n")
+	(dotimes (i max-length) (insert "-"))
+	(insert " ")
+	(dotimes (i classification-length) (insert "-"))
+	(insert " --------\n")
+	(setq slime-fuzzy-first (point)))
 
       (dolist (completion completions)
         (setq slime-fuzzy-last (point)) ; will eventually become the last entry



From trittweiler at common-lisp.net  Fri Mar 14 14:33:14 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Fri, 14 Mar 2008 09:33:14 -0500 (EST)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080314143314.949274908B@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv22334

Modified Files:
	ChangeLog 
Log Message:

* swank-fuzzy.lisp (fuzzy-convert-matching-for-emacs): Return a
  string representation of the classifications rather than the
  classifications themselves. (Notice this propagates up to (and
  consequently changes the return value of) the RPC function
  FUZZY-COMPLETIONS. (incompatible api change.)  

  Rationale: The number of supported classification can be changed
  without having to adapt its display at the client.

* slime-fuzzy.lisp (slime-fuzzy-insert-completion-choice):
  (slime-fuzzy-fill-completions-buffer): Adapted to API change.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2008/03/14 14:15:06	1.98
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2008/03/14 14:33:14	1.99
@@ -1,4 +1,18 @@
-2008-03-08  Tobias C. Rittweiler  <tcr at freebits.de>
+2008-03-14  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* swank-fuzzy.lisp (fuzzy-convert-matching-for-emacs): Return a
+	string representation of the classifications rather than the
+	classifications themselves. (Notice this propagates up to (and
+	consequently changes the return value of) the RPC function
+	FUZZY-COMPLETIONS. (incompatible api change.)  
+
+	Rationale: The number of supported classification can be changed
+	without having to adapt its display at the client.
+
+	* slime-fuzzy.lisp (slime-fuzzy-insert-completion-choice):
+	(slime-fuzzy-fill-completions-buffer): Adapted to API change.
+	
+2008-03-14  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank-fancy-inspector.lisp (make-symbols-listing :classification):
 	Add support for typespec and constant classification; don't



From trittweiler at common-lisp.net  Fri Mar 14 14:39:20 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Fri, 14 Mar 2008 09:39:20 -0500 (EST)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080314143920.5A42D1705A@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv24760/contrib

Modified Files:
	swank-fancy-inspector.lisp 
Log Message:

* swank-fancy-inspector.lisp (add-slots-for-inspector): Remove
  IGNORE declaration of non-existing argument.


--- /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp	2008/03/14 14:14:51	1.13
+++ /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp	2008/03/14 14:39:20	1.14
@@ -188,7 +188,6 @@
 
 (defgeneric all-slots-for-inspector (object)
   (:method ((object standard-object))
-    (declare (ignore inspector))
     (append '("--------------------" (:newline)
               "All Slots:" (:newline))
             (let* ((class (class-of object))



From trittweiler at common-lisp.net  Fri Mar 14 14:39:36 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Fri, 14 Mar 2008 09:39:36 -0500 (EST)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080314143936.02699450C8@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv24840/contrib

Modified Files:
	ChangeLog 
Log Message:

* swank-fancy-inspector.lisp (add-slots-for-inspector): Remove
  IGNORE declaration of non-existing argument.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2008/03/14 14:33:14	1.99
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2008/03/14 14:39:36	1.100
@@ -1,5 +1,10 @@
 2008-03-14  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* swank-fancy-inspector.lisp (add-slots-for-inspector): Remove
+	IGNORE declaration of non-existing argument.
+
+2008-03-14  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	* swank-fuzzy.lisp (fuzzy-convert-matching-for-emacs): Return a
 	string representation of the classifications rather than the
 	classifications themselves. (Notice this propagates up to (and



From trittweiler at common-lisp.net  Sun Mar 16 10:44:05 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Sun, 16 Mar 2008 05:44:05 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080316104405.D27534087@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv16267

Modified Files:
	swank.lisp 
Log Message:

* swank.lisp (load-file-set-package): Removed; the function was
  only used in `slime-load-file-set-package' which invokes
  `slime-repl-set-package' which set the package for a second time.

* slime.lisp (slime-load-file-set-package): Don't call
  SWANK:LOAD-FILE-SET-PACKAGE, but merely call SWANK:LOAD-FILE,
  then invoke `slime-repl-set-package' which will set the package.

  (slime-pretty-find-buffer-package): Removed. (Nowhere used.)
  (slime-set-package): Ditto.


--- /project/slime/cvsroot/slime/swank.lisp	2008/03/14 14:04:31	1.539
+++ /project/slime/cvsroot/slime/swank.lisp	2008/03/16 10:44:05	1.540
@@ -2262,11 +2262,6 @@
 (defslimefun load-file (filename)
   (to-string (load filename)))
 
-(defslimefun load-file-set-package (filename &optional package)
-  (load-file filename)
-  (if package
-      (set-package package)))
-
 
 ;;;;; swank-require
 



From trittweiler at common-lisp.net  Sun Mar 16 10:44:37 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Sun, 16 Mar 2008 05:44:37 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080316104437.C8DA84087@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv16337

Modified Files:
	slime.el 
Log Message:

* swank.lisp (load-file-set-package): Removed; the function was
  only used in `slime-load-file-set-package' which invokes
  `slime-repl-set-package' which set the package for a second time.

* slime.lisp (slime-load-file-set-package): Don't call
  SWANK:LOAD-FILE-SET-PACKAGE, but merely call SWANK:LOAD-FILE,
  then invoke `slime-repl-set-package' which will set the package.

  (slime-pretty-find-buffer-package): Removed. (Nowhere used.)
  (slime-set-package): Ditto.


--- /project/slime/cvsroot/slime/slime.el	2008/03/13 23:45:00	1.923
+++ /project/slime/cvsroot/slime/slime.el	2008/03/16 10:44:37	1.924
@@ -508,11 +508,6 @@
                     (t name))))
     (format "%s" (read name))))
 
-(defun slime-pretty-find-buffer-package ()
-  "Return a prettied version of `slime-find-buffer-package'."
-  (let ((p (slime-find-buffer-package)))
-    (and p (slime-pretty-package-name p))))
-
 (when slime-update-modeline-package
   (run-with-idle-timer 0.2 0.2 'slime-update-modeline-package))
 
@@ -1272,10 +1267,10 @@
 
 (defun slime-load-file-set-package (filename package)
   (let ((filename (slime-to-lisp-filename filename)))
-    (slime-eval-async `(swank:load-file-set-package ,filename ,package)
-                      (lambda (package)
-                        (when package
-                          (slime-repl-set-package (second package)))))))
+    (slime-eval-async `(swank:load-file ,filename)
+                      (lexical-let ((package package))
+                        (lambda (ignored)
+                          (slime-repl-set-package package))))))
 
 ;;;;; Start inferior lisp
 ;;;
@@ -3280,6 +3275,7 @@
             ((memq (char-before) '(?\t ?\ ))
              (slime-echo-arglist))))))
 
+
 (defun slime-repl-set-package (package)
   "Set the package of the REPL buffer to PACKAGE."
   (interactive (list (let* ((p (slime-current-package))
@@ -6366,11 +6362,6 @@
     (slime-net-close process)
     (message "Connection closed.")))
 
-(defun slime-set-package (package)
-  (interactive (list (slime-read-package-name
-                      "Package: " (slime-pretty-find-buffer-package))))
-  (message "*package*: %s" (slime-eval `(swank:set-package ,package))))
-
 (defun slime-set-default-directory (directory)
   "Make DIRECTORY become Lisp's current directory."
   (interactive (list (read-directory-name "Directory: " nil nil t)))



From trittweiler at common-lisp.net  Sun Mar 16 10:46:33 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Sun, 16 Mar 2008 05:46:33 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080316104633.E22CA4092@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv16705

Modified Files:
	ChangeLog 
Log Message:

* swank.lisp (load-file-set-package): Removed; the function was
  only used in `slime-load-file-set-package' which invokes
  `slime-repl-set-package' which set the package for a second time.

* slime.lisp (slime-load-file-set-package): Don't call
  SWANK:LOAD-FILE-SET-PACKAGE, but merely call SWANK:LOAD-FILE,
  then invoke `slime-repl-set-package' which will set the package.

  (slime-pretty-find-buffer-package): Removed. (Nowhere used.)
  (slime-set-package): Ditto.


--- /project/slime/cvsroot/slime/ChangeLog	2008/03/14 14:05:04	1.1320
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/16 10:46:33	1.1321
@@ -1,3 +1,16 @@
+2008-03-16  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* swank.lisp (load-file-set-package): Removed; the function was
+	only used in `slime-load-file-set-package' which invokes
+	`slime-repl-set-package' which set the package for a second time.
+
+	* slime.lisp (slime-load-file-set-package): Don't call
+	SWANK:LOAD-FILE-SET-PACKAGE, but merely call SWANK:LOAD-FILE,
+	then invoke `slime-repl-set-package' which will set the package.
+
+	(slime-pretty-find-buffer-package): Removed. (Nowhere used.)
+	(slime-set-package): Ditto.
+	
 2008-03-14  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank.lisp (classify-symbol, symbol-classification->string): Add



From trittweiler at common-lisp.net  Mon Mar 17 11:35:28 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Mon, 17 Mar 2008 06:35:28 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080317113528.392D25D17E@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv16848

Modified Files:
	swank-source-path-parser.lisp 
Log Message:

* swank-source-path-parser.lisp:

  Multibyte characters in files could screw up compiler-notes
  highlighting on SBCL. Fix that.

  (skip-toplevel-forms): Abstracted out from READ-SOURCE-FORM.
  (source-path-file-position): Don't operate on the file stream
  directly, since CL:FILE-POSITION may not return character but
  binary offsets on such streams; instead slurp file content into a
  buffer string, and operate on that.


--- /project/slime/cvsroot/slime/swank-source-path-parser.lisp	2008/01/27 10:15:52	1.18
+++ /project/slime/cvsroot/slime/swank-source-path-parser.lisp	2008/03/17 11:35:26	1.19
@@ -40,7 +40,7 @@
     (let ((start (file-position stream))
 	  (values (multiple-value-list (funcall fn stream char)))
 	  (end (file-position stream)))
-      ;;(format t "[~D ~{~A~^, ~} ~D ~D]~%" start values end (char-code char))
+      ;(format t "[~D ~{~A~^, ~} ~D ~D ~S]~%" start values end (char-code char) char)
       (unless (null values)
 	(push (cons start end) (gethash (car values) source-map)))
       (values-list values))))
@@ -72,12 +72,15 @@
       (push (cons start end) (gethash form source-map)))
     (values form source-map)))
 
+(defun skip-toplevel-forms (n stream)
+  (let ((*read-suppress* t))
+    (dotimes (i n)
+      (read stream))))
+
 (defun read-source-form (n stream)
   "Read the Nth toplevel form number with source location recording.
 Return the form and the source-map."
-  (let ((*read-suppress* t))
-    (dotimes (i n)
-      (read stream)))
+  (skip-toplevel-forms n stream)
   (let ((*read-suppress* nil))
     (read-and-record-source-map stream)))
   
@@ -98,8 +101,20 @@
     (source-path-stream-position path s)))
 
 (defun source-path-file-position (path filename)
-  (with-open-file (file filename)
-    (source-path-stream-position path file)))
+  ;; We go this long way round, and don't directly operate on the file
+  ;; stream because FILE-POSITION is not totally savy even on file
+  ;; character streams; on SBCL, FILE-POSITION returns the binary
+  ;; offset, and not the character offset---screwing up on Unicode.
+  (let ((toplevel-number (first path))
+	(buffer))
+    (with-open-file (file filename)
+      (skip-toplevel-forms (1+ toplevel-number) file)
+      (let ((endpos (file-position file)))
+	(setq buffer (make-array (list endpos) :element-type 'character
+				 :initial-element #\Space))
+	(assert (file-position file 0))
+	(read-sequence buffer file :end endpos)))
+    (source-path-string-position path buffer)))
 
 (defun source-path-source-position (path form source-map)
   "Return the start position of PATH from FORM and SOURCE-MAP.  All



From trittweiler at common-lisp.net  Mon Mar 17 11:36:01 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Mon, 17 Mar 2008 06:36:01 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080317113601.A95146A004@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv16926

Modified Files:
	ChangeLog 
Log Message:

* swank-source-path-parser.lisp:

  Multibyte characters in files could screw up compiler-notes
  highlighting on SBCL. Fix that.

  (skip-toplevel-forms): Abstracted out from READ-SOURCE-FORM.
  (source-path-file-position): Don't operate on the file stream
  directly, since CL:FILE-POSITION may not return character but
  binary offsets on such streams; instead slurp file content into a
  buffer string, and operate on that.


--- /project/slime/cvsroot/slime/ChangeLog	2008/03/16 10:46:33	1.1321
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/17 11:36:00	1.1322
@@ -1,3 +1,16 @@
+2008-03-17  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* swank-source-path-parser.lisp:
+
+	Multibyte characters in files could screw up compiler-notes
+	highlighting on SBCL. Fix that.
+
+	(skip-toplevel-forms): Abstracted out from READ-SOURCE-FORM.
+	(source-path-file-position): Don't operate on the file stream
+	directly, since CL:FILE-POSITION may not return character but
+	binary offsets on such streams; instead slurp file content into a
+	buffer string, and operate on that.
+	
 2008-03-16  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank.lisp (load-file-set-package): Removed; the function was



From heller at common-lisp.net  Tue Mar 18 13:21:19 2008
From: heller at common-lisp.net (heller)
Date: Tue, 18 Mar 2008 08:21:19 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080318132119.67AE85D174@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv11726

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-repl-return-behaviour): Deleted.  Rebind
the key if you don't like what the command does.

--- /project/slime/cvsroot/slime/ChangeLog	2008/03/17 11:36:00	1.1322
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/18 13:21:18	1.1323
@@ -34,6 +34,11 @@
 
 	* slime.el (slime-eval-macroexpand): Indent expansion.
 	
+2008-03-14  Helmut Eller  <heller at common-lisp.net>
+
+	* slime.el (slime-repl-return-behaviour): Deleted.  Rebind
+	the key if you don't like what the command does.
+
 2008-03-13  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime.el (slime-edit-definition-cont): If no definition could
--- /project/slime/cvsroot/slime/slime.el	2008/03/16 10:44:37	1.924
+++ /project/slime/cvsroot/slime/slime.el	2008/03/18 13:21:18	1.925
@@ -385,26 +385,6 @@
   :type '(boolean)
   :group 'slime-repl)
 
-(defcustom slime-repl-return-behaviour :send-if-complete
-  "Keyword specifying how slime-repl-return behaves when the
-  point is on a lisp expression (as opposed to being on a
-  previous output).
-
-Currently only two values are supported:
-
-:send-if-complete - If the current expression is complete, as per
-slime-input-complete-p, it is sent to the underlying lisp,
-otherwise a newline is inserted. The current value of (point) has
-no effect.
-
-:send-only-if-after-complete - If the current expression is complete
-and point is after the expression it is sent, otherwise a newline
-is inserted."
-  :type '(choice (const :tag "Send if complete" :value :send-if-complete)
-                 (const :tag "Send only if after complete" :value :send-only-if-after-complete))
-  :group 'slime-repl)
-  
-
 (defface slime-repl-prompt-face
   (if (slime-face-inheritance-possible-p)
       '((t (:inherit font-lock-keyword-face)))
@@ -519,23 +499,6 @@
 		((slime-modeline-package (":" slime-modeline-package) "")
 		 slime-state-name))))
 
-(defun slime-input-complete-p (start end)
-  "Return t if the region from START to END contains a complete sexp."
-  (save-excursion
-    (goto-char start)
-    (cond ((looking-at "\\s *['`#]?[(\"]")
-           (ignore-errors
-             (save-restriction
-               (narrow-to-region start end)
-               ;; Keep stepping over blanks and sexps until the end of
-               ;; buffer is reached or an error occurs. Tolerate extra
-               ;; close parens.
-               (loop do (skip-chars-forward " \t\r\n)")
-                     until (eobp)
-                     do (forward-sexp))
-               t)))
-          (t t))))
-
 
 ;;;;; Key bindings
 
@@ -3122,9 +3085,7 @@
          (slime-repl-recenter-if-needed))
         ((run-hook-with-args-until-success 'slime-repl-return-hooks))
         ((slime-input-complete-p slime-repl-input-start-mark
-                                 (ecase slime-repl-return-behaviour
-                                   (:send-only-if-after-complete (min (point) slime-repl-input-end-mark))
-                                   (:send-if-complete slime-repl-input-end-mark)))
+                                 slime-repl-input-end-mark)
          (slime-repl-send-input t))
         (t 
          (slime-repl-newline-and-indent)
@@ -3213,6 +3174,23 @@
     (insert "\n")
     (lisp-indent-line)))
 
+(defun slime-input-complete-p (start end)
+  "Return t if the region from START to END contains a complete sexp."
+  (save-excursion
+    (goto-char start)
+    (cond ((looking-at "\\s *['`#]?[(\"]")
+           (ignore-errors
+             (save-restriction
+               (narrow-to-region start end)
+               ;; Keep stepping over blanks and sexps until the end of
+               ;; buffer is reached or an error occurs. Tolerate extra
+               ;; close parens.
+               (loop do (skip-chars-forward " \t\r\n)")
+                     until (eobp)
+                     do (forward-sexp))
+               t)))
+          (t t))))
+
 (defun slime-repl-delete-current-input ()
   (delete-region slime-repl-input-start-mark slime-repl-input-end-mark))
 



From heller at common-lisp.net  Tue Mar 18 13:21:28 2008
From: heller at common-lisp.net (heller)
Date: Tue, 18 Mar 2008 08:21:28 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080318132128.CED2C7C075@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv11792

Modified Files:
	ChangeLog slime.el 
Log Message:
Move filename translation code to contrib.

* slime.el (slime-find-filename-translators)
(slime-filename-translations): Move to contrib/slime-tramp.el.
(slime-to-lisp-filename-function)
(slime-from-lisp-filename-function): New variables.

* slime-tramp.el (slime-find-filename-translators)
(slime-filename-translations): Move from slime.el.
(slime-tramp-from-lisp-filename, slime-tramp-to-lisp-filename):
New functions.

--- /project/slime/cvsroot/slime/ChangeLog	2008/03/18 13:21:18	1.1323
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/18 13:21:27	1.1324
@@ -36,6 +36,15 @@
 	
 2008-03-14  Helmut Eller  <heller at common-lisp.net>
 
+	Move filename translation code to contrib.
+
+	* slime.el (slime-find-filename-translators)
+	(slime-filename-translations): Move to contrib/slime-tramp.el.
+	(slime-to-lisp-filename-function)
+	(slime-from-lisp-filename-function): New variables.
+
+2008-03-14  Helmut Eller  <heller at common-lisp.net>
+
 	* slime.el (slime-repl-return-behaviour): Deleted.  Rebind
 	the key if you don't like what the command does.
 
--- /project/slime/cvsroot/slime/slime.el	2008/03/18 13:21:18	1.925
+++ /project/slime/cvsroot/slime/slime.el	2008/03/18 13:21:27	1.926
@@ -164,45 +164,6 @@
   :type 'hook
   :group 'slime-lisp)
 
-(defcustom slime-filename-translations nil
-  "Assoc list of hostnames and filename translation functions.  
-Each element is of the form (HOSTNAME-REGEXP TO-LISP FROM-LISP).
-
-HOSTNAME-REGEXP is a regexp which is applied to the connection's
-slime-machine-instance. If HOSTNAME-REGEXP maches then the
-corresponding TO-LISP and FROM-LISP functions will be used to
-translate emacs filenames and lisp filenames.
-
-TO-LISP will be passed the filename of an emacs buffer and must
-return a string which the underlying lisp understandas as a
-pathname. FROM-LISP will be passed a pathname as returned by the
-underlying lisp and must return something that emacs will
-understand as a filename (this string will be passed to
-find-file).
-
-This list will be traversed in order, so multiple matching
-regexps are possible.
-
-Example:
-
-Assuming you run emacs locally and connect to slime running on
-the machine 'soren' and you can connect with the username
-'animaliter':
-
-  (push (list \"^soren$\"
-              (lambda (emacs-filename)
-                (subseq emacs-filename (length \"/ssh:animaliter at soren:\")))
-              (lambda (lisp-filename)
-                (concat \"/ssh:animaliter at soren:\" lisp-filename)))
-        slime-filename-translations)
-
-See also `slime-create-filename-translator'."
-  :type '(repeat (list :tag "Host description"
-                       (regexp :tag "Hostname regexp")
-                       (function :tag "To   lisp function")
-                       (function :tag "From lisp function")))
-  :group 'slime-lisp)
-
 (defcustom slime-enable-evaluate-in-emacs nil
   "*If non-nil, the inferior Lisp can evaluate arbitrary forms in Emacs.
 The default is nil, as this feature can be a security risk."
@@ -1050,24 +1011,16 @@
 ;;; these functions. This way users who run Emacs and Lisp on separate
 ;;; machines have a chance to integrate file operations somehow.
 
+(defvar slime-to-lisp-filename-function #'identity)
+(defvar slime-from-lisp-filename-function #'identity)
+
 (defun slime-to-lisp-filename (filename)
-  "Translate the string FILENAME to a Lisp filename.
-See `slime-filename-translations'."
-  (funcall (first (slime-find-filename-translators (slime-machine-instance)))
-           (expand-file-name filename)))
+  "Translate the string FILENAME to a Lisp filename."
+  (funcall slime-to-lisp-filename-function filename))
 
 (defun slime-from-lisp-filename (filename)
-  "Translate the Lisp filename FILENAME to an Emacs filename.
-See `slime-filename-translations'."
-  (funcall (second (slime-find-filename-translators (slime-machine-instance)))
-           filename))
-
-(defun slime-find-filename-translators (hostname)
-  (cond ((and hostname slime-filename-translations)
-         (or (cdr (assoc-if (lambda (regexp) (string-match regexp hostname))
-                            slime-filename-translations))
-             (error "No filename-translations for hostname: %s" hostname)))
-        (t (list #'identity #'identity))))
+  "Translate the Lisp filename FILENAME to an Emacs filename."
+  (funcall slime-from-lisp-filename-function filename))
 
 
 ;;;; Starting SLIME
@@ -1661,12 +1614,6 @@
     (insert string))
   (slime-process-available-input process))
 
-(defun slime-run-when-idle (function &rest args)
-  "Call FUNCTION as soon as Emacs is idle."
-  (apply #'run-at-time 
-         (if (featurep 'xemacs) itimer-short-interval 0) 
-         nil function args))
-
 (defun slime-process-available-input (process)
   "Process all complete messages that have arrived from Lisp."
   (with-current-buffer (process-buffer process)
@@ -1687,6 +1634,12 @@
   (and (>= (buffer-size) 6)
        (>= (- (buffer-size) 6) (slime-net-decode-length))))
 
+(defun slime-run-when-idle (function &rest args)
+  "Call FUNCTION as soon as Emacs is idle."
+  (apply #'run-at-time 
+         (if (featurep 'xemacs) itimer-short-interval 0) 
+         nil function args))
+
 (defun slime-net-read-or-lose (process)
   (condition-case error
       (slime-net-read)
@@ -1947,9 +1900,7 @@
   ;; from a timer then it mysteriously uses the wrong keymap for the
   ;; first command.
   (slime-eval-async '(swank:connection-info)
-                    (with-lexical-bindings (proc)
-                      (lambda (info)
-                        (slime-set-connection-info proc info)))))
+                    (slime-curry #'slime-set-connection-info proc)))
 
 (defun slime-set-connection-info (connection info)
   "Initialize CONNECTION with INFO received from Lisp."



From heller at common-lisp.net  Tue Mar 18 13:21:29 2008
From: heller at common-lisp.net (heller)
Date: Tue, 18 Mar 2008 08:21:29 -0500 (EST)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080318132129.184374E01A@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv11792/contrib

Modified Files:
	ChangeLog slime-tramp.el 
Log Message:
Move filename translation code to contrib.

* slime.el (slime-find-filename-translators)
(slime-filename-translations): Move to contrib/slime-tramp.el.
(slime-to-lisp-filename-function)
(slime-from-lisp-filename-function): New variables.

* slime-tramp.el (slime-find-filename-translators)
(slime-filename-translations): Move from slime.el.
(slime-tramp-from-lisp-filename, slime-tramp-to-lisp-filename):
New functions.

--- /project/slime/cvsroot/slime/contrib/ChangeLog	2008/03/14 14:39:36	1.100
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2008/03/18 13:21:28	1.101
@@ -24,6 +24,15 @@
 	silently ignore symbols that can't be usefully classified, but
 	group them under "MISC".
 
+2008-03-14  Helmut Eller  <heller at common-lisp.net>
+
+	Move filename translation code to contrib.
+
+	* slime-tramp.el (slime-find-filename-translators)
+	(slime-filename-translations): Move from slime.el.
+	(slime-tramp-from-lisp-filename, slime-tramp-to-lisp-filename):
+	New functions.
+
 2008-03-08  Helmut Eller  <heller at common-lisp.net>
 
 	Don't blindly override the inspect method for functions.
--- /project/slime/cvsroot/slime/contrib/slime-tramp.el	2007/09/04 10:18:44	1.2
+++ /project/slime/cvsroot/slime/contrib/slime-tramp.el	2008/03/18 13:21:28	1.3
@@ -11,9 +11,56 @@
 ;;   (add-hook 'slime-load-hook (lambda () (require 'slime-tramp)))
 ;;
 
+(require 'tramp)
+
+(defcustom slime-filename-translations nil
+  "Assoc list of hostnames and filename translation functions.  
+Each element is of the form (HOSTNAME-REGEXP TO-LISP FROM-LISP).
+
+HOSTNAME-REGEXP is a regexp which is applied to the connection's
+slime-machine-instance. If HOSTNAME-REGEXP maches then the
+corresponding TO-LISP and FROM-LISP functions will be used to
+translate emacs filenames and lisp filenames.
+
+TO-LISP will be passed the filename of an emacs buffer and must
+return a string which the underlying lisp understandas as a
+pathname. FROM-LISP will be passed a pathname as returned by the
+underlying lisp and must return something that emacs will
+understand as a filename (this string will be passed to
+find-file).
+
+This list will be traversed in order, so multiple matching
+regexps are possible.
+
+Example:
+
+Assuming you run emacs locally and connect to slime running on
+the machine 'soren' and you can connect with the username
+'animaliter':
+
+  (push (list \"^soren$\"
+              (lambda (emacs-filename)
+                (subseq emacs-filename (length \"/ssh:animaliter at soren:\")))
+              (lambda (lisp-filename)
+                (concat \"/ssh:animaliter at soren:\" lisp-filename)))
+        slime-filename-translations)
+
+See also `slime-create-filename-translator'."
+  :type '(repeat (list :tag "Host description"
+                       (regexp :tag "Hostname regexp")
+                       (function :tag "To   lisp function")
+                       (function :tag "From lisp function")))
+  :group 'slime-lisp)
+
+(defun slime-find-filename-translators (hostname)
+  (cond ((and hostname slime-filename-translations)
+         (or (cdr (assoc-if (lambda (regexp) (string-match regexp hostname))
+                            slime-filename-translations))
+             (error "No filename-translations for hostname: %s" hostname)))
+        (t (list #'identity #'identity))))
+
 (defun slime-make-tramp-file-name (username remote-host lisp-filename)
   "Old (with multi-hops) tramp compatability function"
-  (require 'tramp)
   (if (boundp 'tramp-multi-methods)
       (tramp-make-tramp-file-name nil nil
                                   username
@@ -52,4 +99,15 @@
              ,remote-host
              lisp-filename)))))
 
+(defun slime-tramp-to-lisp-filename (filename)
+  (funcall (first (slime-find-filename-translators (slime-machine-instance)))
+           (expand-file-name filename)))
+
+(defun slime-tramp-from-lisp-filename (filename)
+  (funcall (second (slime-find-filename-translators (slime-machine-instance)))
+           filename))
+
+(setq slime-to-lisp-filename-function #'slime-tramp-to-lisp-filename)
+(setq slime-from-lisp-filename-function #'slime-tramp-from-lisp-filename)
+
 (provide 'slime-tramp)
\ No newline at end of file



From heller at common-lisp.net  Tue Mar 18 13:21:42 2008
From: heller at common-lisp.net (heller)
Date: Tue, 18 Mar 2008 08:21:42 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080318132142.CA0597113E@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv11991

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (with-lexical-bindings): Removed.  Update callers
accordingly.

--- /project/slime/cvsroot/slime/ChangeLog	2008/03/18 13:21:27	1.1324
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/18 13:21:38	1.1325
@@ -36,6 +36,11 @@
 	
 2008-03-14  Helmut Eller  <heller at common-lisp.net>
 
+	* slime.el (with-lexical-bindings): Removed.  Updated callers
+	accordingly.
+
+2008-03-14  Helmut Eller  <heller at common-lisp.net>
+
 	Move filename translation code to contrib.
 
 	* slime.el (slime-find-filename-translators)
--- /project/slime/cvsroot/slime/slime.el	2008/03/18 13:21:27	1.926
+++ /project/slime/cvsroot/slime/slime.el	2008/03/18 13:21:38	1.927
@@ -634,14 +634,6 @@
 
 (put 'when-let 'lisp-indent-function 1)
 
-(defmacro with-lexical-bindings (variables &rest body)
-  "Execute BODY with VARIABLES in lexical scope."
-  `(lexical-let ,(mapcar (lambda (variable) (list variable variable))
-                         variables)
-     , at body))
-
-(put 'with-lexical-bindings 'lisp-indent-function 1)
-
 (defmacro destructure-case (value &rest patterns)
   "Dispatch VALUE to one of PATTERNS.
 A cross between `case' and `destructuring-bind'.
@@ -2979,40 +2971,34 @@
     (end-of-defun))
   t)
 
-;; FIXME: Shouldn't this be (= (point) slime-repl-input-end-mark)?
-(defun slime-repl-at-prompt-end-p ()
-  (and (get-char-property (max 1 (1- (point))) 'slime-repl-prompt)
-       (not (get-char-property (point) 'slime-repl-prompt))))
- 
-(defun slime-repl-find-prompt (move)
-  (let ((origin (point)))
-    (loop (funcall move)
-          (when (or (slime-repl-at-prompt-end-p) (bobp) (eobp))
-            (return)))
-    (unless (slime-repl-at-prompt-end-p)
-      (goto-char origin))))
-
-(defun slime-search-property-change-fn (prop &optional backward)
-  (with-lexical-bindings (prop)
-    (if backward 
-        (lambda () 
-          (goto-char
-           (previous-single-char-property-change (point) prop)))
-        (lambda () 
-          (goto-char
-           (next-single-char-property-change (point) prop))))))
-
 (defun slime-repl-previous-prompt ()
   "Move backward to the previous prompt."
   (interactive)
-  (slime-repl-find-prompt 
-   (slime-search-property-change-fn 'slime-repl-prompt t)))
+  (slime-repl-find-prompt t))
 
 (defun slime-repl-next-prompt ()
   "Move forward to the next prompt."
   (interactive)
-  (slime-repl-find-prompt
-   (slime-search-property-change-fn 'slime-repl-prompt)))
+  (slime-repl-find-prompt))
+ 
+(defun slime-repl-find-prompt (&optional backward)
+  (let ((origin (point))
+        (prop 'slime-repl-prompt))
+    (while (progn 
+             (slime-search-property-change prop backward)
+             (not (or (slime-end-of-proprange-p prop) (bobp) (eobp)))))
+    (unless (slime-end-of-proprange-p prop)
+      (goto-char origin))))
+
+(defun slime-search-property-change (prop &optional backward)
+  (cond (backward 
+         (goto-char (previous-single-char-property-change (point) prop)))
+        (t 
+         (goto-char (next-single-char-property-change (point) prop)))))
+
+(defun slime-end-of-proprange-p (property)
+  (and (get-char-property (max 1 (1- (point))) property)
+       (not (get-char-property (point) property))))
 
 (defvar slime-repl-return-hooks)
 
@@ -5303,13 +5289,14 @@
   (with-current-buffer (slime-output-buffer)
     (slime-with-output-end-mark 
      (slime-mark-output-start)))
-  (with-lexical-bindings (fn)
-    (slime-eval-async form
-                      (lambda (value)
-                        (with-current-buffer (slime-output-buffer)
-                          (slime-show-last-output)
-                          (cond (fn (funcall fn value))
-                                (t (message "%s" value))))))))
+  (slime-eval-async form
+                    (slime-rcurry 
+                     (lambda (value fn)
+                       (with-current-buffer (slime-output-buffer)
+                         (slime-show-last-output)
+                         (cond (fn (funcall fn value))
+                               (t (message "%s" value)))))
+                     fn)))
 
 (defun slime-eval-describe (form)
   "Evaluate FORM in Lisp and display the result in a new buffer."



From heller at common-lisp.net  Tue Mar 18 13:21:43 2008
From: heller at common-lisp.net (heller)
Date: Tue, 18 Mar 2008 08:21:43 -0500 (EST)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080318132143.3C5782E183@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv11991/contrib

Modified Files:
	slime-autodoc.el 
Log Message:
* slime.el (with-lexical-bindings): Removed.  Update callers
accordingly.

--- /project/slime/cvsroot/slime/contrib/slime-autodoc.el	2008/01/27 10:17:34	1.7
+++ /project/slime/cvsroot/slime/contrib/slime-autodoc.el	2008/03/18 13:21:42	1.8
@@ -93,11 +93,12 @@
         ;; Asynchronously fetch, cache, and display documentation
         (slime-eval-async 
          retrieve-form
-         (with-lexical-bindings (cache-key)
-           (lambda (doc)
-             (let ((doc (if doc (slime-fontify-string doc) "")))
-               (slime-update-autodoc-cache cache-key doc)
-               (slime-autodoc-message doc)))))))))
+         (slime-rcurry 
+	  (lambda (doc cache-key)
+	    (let ((doc (if doc (slime-fontify-string doc) "")))
+	      (slime-update-autodoc-cache cache-key doc)
+	      (slime-autodoc-message doc)))
+	  cache-key))))))
 
 (defcustom slime-autodoc-use-multiline-p nil
   "If non-nil, allow long autodoc messages to resize echo area display."



From heller at common-lisp.net  Tue Mar 18 13:21:55 2008
From: heller at common-lisp.net (heller)
Date: Tue, 18 Mar 2008 08:21:55 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080318132155.7D07231035@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv12148

Modified Files:
	ChangeLog slime.el 
Log Message:
Remove some rarely used code.

* slime.el(slime-make-default-connection, slime-choose-connection)
(slime-find-connection-by-name, slime-symbol-at-point): Remove. Unused
code.

--- /project/slime/cvsroot/slime/ChangeLog	2008/03/18 13:21:38	1.1325
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/18 13:21:51	1.1326
@@ -36,8 +36,13 @@
 	
 2008-03-14  Helmut Eller  <heller at common-lisp.net>
 
+	Remove some rarely used code.
+
 	* slime.el (with-lexical-bindings): Removed.  Updated callers
 	accordingly.
+	(slime-make-default-connection, slime-choose-connection)
+	(slime-find-connection-by-name, slime-symbol-at-point):
+	Remove. Unused code.
 
 2008-03-14  Helmut Eller  <heller at common-lisp.net>
 
--- /project/slime/cvsroot/slime/slime.el	2008/03/18 13:21:38	1.927
+++ /project/slime/cvsroot/slime/slime.el	2008/03/18 13:21:54	1.928
@@ -1957,31 +1957,6 @@
   (interactive)
   (mapc #'slime-net-close slime-net-processes))
 
-(defun slime-make-default-connection ()
-  "Make the current connection the default connection."
-  (interactive)
-  (slime-select-connection (slime-connection))
-  (message "Connection #%S (%s) now default SLIME connection."
-           (slime-connection-number)
-           (slime-connection-name)))
-
-(defun slime-choose-connection ()
-  "Return an established connection chosen by the user."
-  (let ((default (slime-connection-name)))
-    (slime-find-connection-by-name
-     (completing-read (format "Connection name (default %s): " default)
-                      (slime-bogus-completion-alist
-                       (mapcar #'slime-connection-name slime-net-processes))
-                      nil
-                      t
-                      nil
-                      nil
-                      default))))
-
-(defun slime-find-connection-by-name (name)
-  (find name slime-net-processes 
-        :test #'string= :key #'slime-connection-name))
-
 (defun slime-connection-port (connection)
   "Return the remote port number of CONNECTION."
   (if (featurep 'xemacs)
@@ -2628,7 +2603,7 @@
 
 (defun slime-switch-to-output-buffer (&optional connection)
   "Select the output buffer, preferably in a different window."
-  (interactive (list (if prefix-arg (slime-choose-connection))))
+  (interactive)
   (let ((slime-dispatching-connection (or connection 
                                           slime-dispatching-connection)))
     (set-buffer (slime-output-buffer))
@@ -9071,6 +9046,7 @@
 (defun slime-symbol-end-pos ()
   (save-excursion (slime-end-of-symbol) (point)))
 
+;; FIXME: rename this as slime-symbol-at-point.
 (defun slime-symbol-name-at-point ()
   "Return the name of the symbol at point, otherwise nil."
   (save-restriction
@@ -9087,11 +9063,6 @@
              (not (equal string ""))
              (substring-no-properties string))))))
 
-(defun slime-symbol-at-point ()
-  "Return the symbol at point, otherwise nil."
-  (let ((name (slime-symbol-name-at-point)))
-    (and name (intern name))))
-
 (defun slime-sexp-at-point ()
   "Return the sexp at point as a string, otherwise nil."
   (let ((string (thing-at-point 'sexp)))



From heller at common-lisp.net  Tue Mar 18 13:22:04 2008
From: heller at common-lisp.net (heller)
Date: Tue, 18 Mar 2008 08:22:04 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080318132204.57CDB31035@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv12381

Modified Files:
	ChangeLog slime.el 
Log Message:
Delete the code which warned about removed key bindings.

* slime.el (slime-obsolete-commands, slime-bind-obsolete-commands)
(slime-bind-obsolete-command, slime-upgrade-notice)
(slime-timebomb, slime-timebomb-progress, slime-timebomb-message):
Remove.

--- /project/slime/cvsroot/slime/ChangeLog	2008/03/18 13:21:51	1.1326
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/18 13:22:03	1.1327
@@ -41,8 +41,12 @@
 	* slime.el (with-lexical-bindings): Removed.  Updated callers
 	accordingly.
 	(slime-make-default-connection, slime-choose-connection)
-	(slime-find-connection-by-name, slime-symbol-at-point):
-	Remove. Unused code.
+	(slime-find-connection-by-name, slime-symbol-at-point): Remove.
+	Unused code.
+	(slime-obsolete-commands, slime-bind-obsolete-commands)
+	(slime-bind-obsolete-command, slime-upgrade-notice)
+	(slime-timebomb, slime-timebomb-progress, slime-timebomb-message):
+	Remove.  Obsolete.
 
 2008-03-14  Helmut Eller  <heller at common-lisp.net>
 
--- /project/slime/cvsroot/slime/slime.el	2008/03/18 13:21:54	1.928
+++ /project/slime/cvsroot/slime/slime.el	2008/03/18 13:22:03	1.929
@@ -9408,67 +9408,6 @@
   (if (local-variable-p hook (current-buffer))
       (remove-hook hook function t)))
 
-;;;; Some "nice" backward compatiblity bindings for lusers.
-
-(defvar slime-obsolete-commands 
-  '(("\C-c\M-i" (slime repl) slime-fuzzy-complete-symbol)
-    ;; Don't shadow bindings in lisp-mode-map
-    ;;("\M-\C-a" (slime) slime-beginning-of-defun)
-    ;;("\M-\C-e" (slime) slime-end-of-defun)
-    ("\C-c\M-q" (slime) slime-reindent-defun)
-    ("\C-c\C-s" (slime) slime-complete-form)
-    ;; (nil nil slime-close-all-parens-in-sexp)
-    ))
-
-(defun slime-bind-obsolete-commands ()
-  (loop for (key maps command) in slime-obsolete-commands do
-        (dolist (m maps) (slime-bind-obsolete-command m key command))))
-
-(defun slime-bind-obsolete-command (map key command)
-  (let ((map (ecase map
-               (slime slime-mode-map)
-               (repl slime-repl-mode-map))))
-    (unless (lookup-key map key)
-      (define-key map key `(lambda (&rest _)
-                             (interactive)
-                             (slime-upgrade-notice ',command))))))
-
-(slime-bind-obsolete-commands)
-
-(defun slime-upgrade-notice (command)
-  (slime-timebomb (format "The command `%s' has been moved to contrib.
-Please consult the README file in the contrib directory for details.
-
-To fetch the contrib directoy use:  cvs update -d"
-                          command)
-                  15))
-
-;;;;; ... with gratuitous bloat
-
-(defun slime-timebomb (message timeout)
-  (with-current-buffer (generate-new-buffer "*warning*")
-    (insert message "\n\n")
-    (slime-timebomb-progress (point-marker) timeout)
-    (goto-char (point-min))
-    (pop-to-buffer (current-buffer))))
-
-(defun slime-timebomb-progress (mark timeout)
-  (let ((buffer (marker-buffer mark)))
-    (cond ((not (buffer-live-p buffer)))
-	  ((zerop timeout) (kill-buffer buffer))
-	  (t (with-current-buffer buffer
-               (save-excursion
-                 (delete-region mark (point-max))
-                 (goto-char mark)
-                 (slime-timebomb-message timeout))
-	       (run-with-timer 1 nil 
-                               'slime-timebomb-progress mark (1- timeout)))))))
-
-(defun slime-timebomb-message (timeout)
-  (slime-insert-propertized
-   (list 'face (if (zerop (mod timeout 2)) 'highlight 'default))
-   (format "This message will destroy itself in %d seconds." timeout)))
-
 
 ;;;; Finishing up
 



From heller at common-lisp.net  Tue Mar 18 13:22:07 2008
From: heller at common-lisp.net (heller)
Date: Tue, 18 Mar 2008 08:22:07 -0500 (EST)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080318132207.28B7731033@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv12665/contrib

Modified Files:
	swank-mit-scheme.scm 
Log Message:
Use symbol-name instead of symbol->string.
Because symbol->string is very slow in MIT Scheme 7.7.90 which
makes TAB-completion unbearably slow.

--- /project/slime/cvsroot/slime/contrib/swank-mit-scheme.scm	2008/03/04 15:47:06	1.2
+++ /project/slime/cvsroot/slime/contrib/swank-mit-scheme.scm	2008/03/18 13:22:05	1.3
@@ -573,21 +573,21 @@
 	  (longest-common-prefix strings))))
 
 (define (all-completions pattern env match?)
-  (let ((ss (map symbol->string (environment-names env))))
+  (let ((ss (map %symbol->string (environment-names env))))
     (keep-matching-items ss (lambda (s) (match? pattern s)))))
 
+;; symbol->string is too slow
+(define %symbol->string symbol-name)
+
 (define (environment-names env)
-  (append (map car (environment-bindings env))
+  (append (environment-bound-names env)
 	  (if (environment-has-parent? env)
 	      (environment-names (environment-parent env))
 	      '())))
 
 (define (longest-common-prefix strings)
-  (define(common-prefix s1 s2)
-    (let ((len (min (string-length s1) (string-length s2))))
-      (do ((i 0 (1+ i)))
-	  ((or (= i len) (not (char=? (string-ref s1 i) (string-ref s2 i))))
-	   (substring s1 0 i)))))
+  (define (common-prefix s1 s2)
+    (substring s1 0 (string-match-forward s1 s2)))
   (reduce common-prefix "" strings))
 
 



From heller at common-lisp.net  Tue Mar 18 13:22:15 2008
From: heller at common-lisp.net (heller)
Date: Tue, 18 Mar 2008 08:22:15 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080318132215.8EF1331035@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv12712

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-xref-group): Hanlde :zip files.

--- /project/slime/cvsroot/slime/ChangeLog	2008/03/18 13:22:03	1.1327
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/18 13:22:15	1.1328
@@ -34,6 +34,10 @@
 
 	* slime.el (slime-eval-macroexpand): Indent expansion.
 	
+2008-03-18  Helmut Eller  <heller at common-lisp.net>
+
+	* slime.el (slime-xref-group): Hanlde :zip files.
+
 2008-03-14  Helmut Eller  <heller at common-lisp.net>
 
 	Remove some rarely used code.
--- /project/slime/cvsroot/slime/slime.el	2008/03/18 13:22:03	1.929
+++ /project/slime/cvsroot/slime/slime.el	2008/03/18 13:22:15	1.930
@@ -5079,8 +5079,8 @@
               (if buffer 
                   (format "%S" buffer) ; "#<buffer foo.lisp>"
                 (format "%s (previously existing buffer)" bufname))))
-           ((:source-form _)
-            "(S-Exp)")))
+           ((:source-form _) "(S-Exp)")
+           ((:zip zip entry) entry)))
         (t
          "(No location)")))
 



From heller at common-lisp.net  Tue Mar 18 13:22:18 2008
From: heller at common-lisp.net (heller)
Date: Tue, 18 Mar 2008 08:22:18 -0500 (EST)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080318132218.0FAE931043@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv13046/contrib

Modified Files:
	swank-kawa.scm 
Log Message:
disassemble-frame hacking.

--- /project/slime/cvsroot/slime/contrib/swank-kawa.scm	2008/02/20 22:05:24	1.2
+++ /project/slime/cvsroot/slime/contrib/swank-kawa.scm	2008/03/18 13:22:17	1.3
@@ -380,7 +380,10 @@
            (send dbg `(frame-locals ,thread ,frame ,id)))
           ((_ (':emacs-rex ('|swank:frame-catch-tags-for-emacs| frame)
                            pkg thread id))
-           (send out `(:return (:ok ()) ,id)))
+           (send dbg `(frame-catchers ,thread ,frame ,id)))
+          ((_ (':emacs-rex ('|swank:sldb-disassemble| frame)
+                           pkg thread id))
+           (send dbg `(disassemble-frame ,thread ,frame ,id)))
           ((_ (':emacs-rex ('|swank:backtrace| from to) pkg thread id))
            (send dbg `(thread-frames ,thread ,from ,to ,id)))
           ((_ (':emacs-rex ('|swank:list-threads|) pkg thread id))
@@ -847,51 +850,63 @@
 (defslimefun disassemble-symbol (env name)
   (let ((f (eval (read-from-string name) env)))
     (typecase f
-      (<gnu.expr.ModuleMethod>
-       (let ((mr (module-method>meth-ref f)))
-         (call-with-output-string
-          (fun (s)
-            (parameterize ((current-output-port s))
-                          (disassemble-meth-ref mr)))))))))
+      (<gnu.expr.ModuleMethod> 
+       (disassemble (module-method>meth-ref f))))))
+
+(df disassemble ((mr <meth-ref>) => <str>)
+  (with-sink #f (fun (out) (disassemble-meth-ref mr out))))
 
-(df disassemble-meth-ref ((mr <meth-ref>))
+(df disassemble-meth-ref ((mr <meth-ref>) (out <java.io.PrintWriter>))
   (let* ((t (! declaring-type mr)))
-    (format #t "~:[~;static ~]~:[~; final~]~
-~:[~;private ~]~:[~;protected ~]~:[~;public ~]~a ~a\n"
-            (! is-static mr) (! is-final mr)
-            (! is-private mr) (! is-protected mr) (! is-public mr)
-            (! name mr) (! signature mr))
-    (disassemble (! constant-pool t)
-                 (! constant-pool-count t)
-                 (! bytecodes mr))))
-
-(df disassemble ((cpool <byte[]>) (cpoolcount <int>) (bytecode <byte[]>))
-  (let* ((buffer (<java.io.StringWriter>))
-         (out (<java.io.PrintWriter> buffer))
-	 (ct (<gnu.bytecode.ClassType> "foo"))
+;;    (format out "~:[~;static ~]~:[~; final~]~
+;;~:[~;private ~]~:[~;protected ~]~:[~;public ~]~a ~a\n"
+;;            (! is-static mr) (! is-final mr)
+;;            (! is-private mr) (! is-protected mr) (! is-public mr)
+;;            (! name mr) (! signature mr))
+    (disas-code (! constant-pool t)
+                (! constant-pool-count t)
+                (! bytecodes mr)
+                out)))
+
+(df disas-code ((cpool <byte[]>) (cpoolcount <int>) (bytecode <byte[]>) 
+                (out <java.io.PrintWriter>))
+  (let* ((ct (<gnu.bytecode.ClassType> "foo"))
 	 (met (! addMethod ct "bar" 0))
 	 (ca (<gnu.bytecode.CodeAttr> met))
-	 (w (<gnu.bytecode.ClassTypeWriter> ct out 0))
-         (constants (let ((s (<java.io.ByteArrayOutputStream>)))
-                      (! write s (ash cpoolcount -8))
-                      (! write s (logand cpoolcount 255))
+         (constants (let* ((bs (<java.io.ByteArrayOutputStream>))
+                           (s (<java.io.DataOutputStream> bs)))
+                      (! write-short s cpoolcount)
                       (! write s cpool)
-                      (! toByteArray s))))
+                      (! flush s)
+                      (! toByteArray bs))))
     (vm-set-slot the-vm ct 'constants 
                  (<gnu.bytecode.ConstantPool>
                   (<java.io.DataInputStream>
                    (<java.io.ByteArrayInputStream>
                     constants))))
     (! setCode ca bytecode)
-    (! disAssemble ca w 0 bytecode:length)
-    (! flush out)
-    (display (! toString buffer))))
+    (let ((w (<gnu.bytecode.ClassTypeWriter> ct out 0)))
+      (! print ca w)
+      (! flush w))))
+
+(df with-sink (sink (f <function>))
+  (cond ((instance? sink <java.io.PrintWriter>) (f sink))
+        ((== sink #t) (f (as <java.io.PrintWriter> (current-output-port))))
+        ((== sink #f)
+         (let* ((buffer (<java.io.StringWriter>))
+                (out (<java.io.PrintWriter> buffer)))
+           (f out)
+           (! flush out)
+           (! toString buffer)))
+        (#t (ferror "Invalid sink designator: ~s" sink))))
 
 (df test-disas ((c <str>) (m <str>))
   (let* ((vm (as <vm> the-vm))
          (c (as <ref-type> (1st (! classes-by-name vm c))))
          (m (as <meth-ref> (1st (! methods-by-name c m)))))
-    (disassemble-meth-ref m)))
+    (with-sink #f (fun (out) (disassemble-meth-ref m out)))))
+
+;; (test-disas "java.lang.Class" "toString")
 
 
 ;;;; Macroexpansion
@@ -1085,6 +1100,10 @@
            (reply c (frame-src-loc thread frame state) id))
           ((,c . ('frame-locals thread frame id))
            (reply c (frame-locals thread frame state) id))
+          ((,c . ('frame-catchers thread frame id))
+           (reply c (frame-catchers thread frame state) id))
+          ((,c . ('disassemble-frame thread frame id))
+           (reply c (disassemble-frame thread frame state) id))
           ((,c . ('thread-frames thread from to id))
            (reply c (thread-frames thread from to state) id))
           ((,c . ('list-threads id))
@@ -1289,6 +1308,15 @@
                          (val (as <value> (! getValue e))))
                      (pack (list (! name var) (p val))))))))))))
 
+(df frame-catchers ((tid <int>) (frame <int>) state)
+  '())
+
+(df disassemble-frame ((tid <int>) (frame <int>) state)
+  (mlet ((frame _) (nth-frame tid frame state))
+    (typecase frame
+      (<java.lang.StackTraceElement> "<??>")
+      (<frame> (disassemble (!! method location frame))))))
+
 ;;;;; Restarts
 
 (df throw-to-toplevel ((tid <int>) (id <int>) (c <chan>) state)
@@ -1769,7 +1797,7 @@
     (cond (method
            (dolist ((m <sun.tools.javap.MethodData>)
                     (array-to-list (! getMethods cdata)))
-             (when (equal method (! getName m))
+             (when (equal (to-str method) (! getName m))
                (! printMethodSignature p m (! getAccess m))
                (! printExceptions p m)
                (newline)
@@ -1851,7 +1879,11 @@
   (typecase s
     (<list> (apply list (! sub-list s from to)))
     (<vector> (apply vector (! sub-list s from to)))
-    (<str> (! substring s from to))))
+    (<str> (! substring s from to))
+    (<byte[]> (let* ((len (as <int> (- to from)))
+                     (t (<byte[]> :length len)))
+                (java.lang.System:arraycopy s from t 0 len)
+                t))))
 
 (df to-string (obj => <string>)
   (cond ((instance? obj <str>) (<gnu.lists.FString> (as <str> obj)))



From heller at common-lisp.net  Tue Mar 18 13:22:24 2008
From: heller at common-lisp.net (heller)
Date: Tue, 18 Mar 2008 08:22:24 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080318132224.426F731043@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv13069

Modified Files:
	ChangeLog 
Log Message:
Fix log entries

--- /project/slime/cvsroot/slime/ChangeLog	2008/03/18 13:22:15	1.1328
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/18 13:22:24	1.1329
@@ -1,3 +1,7 @@
+2008-03-18  Helmut Eller  <heller at common-lisp.net>
+
+	* slime.el (slime-xref-group): Hanlde :zip files.
+
 2008-03-17  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank-source-path-parser.lisp:
@@ -23,20 +27,6 @@
 
 	(slime-pretty-find-buffer-package): Removed. (Nowhere used.)
 	(slime-set-package): Ditto.
-	
-2008-03-14  Tobias C. Rittweiler  <tcr at freebits.de>
-
-	* swank.lisp (classify-symbol, symbol-classification->string): Add
-	classification of symbols denoting type specifier, and denoting
-	constants.
-	
-2008-03-13  Tobias C. Rittweiler  <tcr at freebits.de>
-
-	* slime.el (slime-eval-macroexpand): Indent expansion.
-	
-2008-03-18  Helmut Eller  <heller at common-lisp.net>
-
-	* slime.el (slime-xref-group): Hanlde :zip files.
 
 2008-03-14  Helmut Eller  <heller at common-lisp.net>
 
@@ -65,6 +55,16 @@
 
 	* slime.el (slime-repl-return-behaviour): Deleted.  Rebind
 	the key if you don't like what the command does.
+	
+2008-03-14  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* swank.lisp (classify-symbol, symbol-classification->string): Add
+	classification of symbols denoting type specifier, and denoting
+	constants.
+	
+2008-03-13  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime.el (slime-eval-macroexpand): Indent expansion.
 
 2008-03-13  Tobias C. Rittweiler  <tcr at freebits.de>
 



From gcarncross at common-lisp.net  Wed Mar 19 02:34:30 2008
From: gcarncross at common-lisp.net (gcarncross)
Date: Tue, 18 Mar 2008 21:34:30 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080319023430.739733F03A@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv10157

Modified Files:
	ChangeLog swank-ecl.lisp 
Log Message:
ECL moved gray streams into GRAY package

--- /project/slime/cvsroot/slime/ChangeLog	2008/03/18 13:22:24	1.1329
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/19 02:34:30	1.1330
@@ -1,3 +1,7 @@
+2008-03-18  Geo Carncross <geocar at gmail.com>
+
+	* swank-ecl.lisp: ECL moved gray streams into GRAY package.
+
 2008-03-18  Helmut Eller  <heller at common-lisp.net>
 
 	* slime.el (slime-xref-group): Hanlde :zip files.
--- /project/slime/cvsroot/slime/swank-ecl.lisp	2008/02/09 18:47:05	1.14
+++ /project/slime/cvsroot/slime/swank-ecl.lisp	2008/03/19 02:34:30	1.15
@@ -10,7 +10,9 @@
 
 (in-package :swank-backend)
 
-(import-from :ext *gray-stream-symbols* :swank-backend)
+(if (find-package :gray)
+  (import-from :gray *gray-stream-symbols* :swank-backend)
+  (import-from :ext *gray-stream-symbols* :swank-backend))
 
 (swank-backend::import-swank-mop-symbols :clos
  '(:eql-specializer



From gcarncross at common-lisp.net  Wed Mar 19 11:46:44 2008
From: gcarncross at common-lisp.net (gcarncross)
Date: Wed, 19 Mar 2008 06:46:44 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080319114644.447885D178@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv9642

Modified Files:
	ChangeLog 
Log Message:
merge old changelog entries

--- /project/slime/cvsroot/slime/ChangeLog	2008/03/19 02:34:30	1.1330
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/19 11:46:43	1.1331
@@ -574,6 +574,11 @@
 	* swank-scl.lisp (set-stream-timeout, make-socket-io-stream): update
 	for Scieneer CL 1.3.7.
 
+2007-12-21  Geo Carncross  <geocar at gmail.com>
+
+	* swank-ecl.lisp: try to parse the Args: line in most ecl functions to
+	make modeline/autodoc more interesting
+
 2007-12-20  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank.lisp (read-softly-from-string): Now actually returns all
@@ -587,6 +592,10 @@
 	`C-c C-c'd from. Idea from Knut Olav B?hmer.
 	(slime-insert-xrefs): Use it.
 
+2007-12-14  Geo Carncross  <geocar at gmail.com>
+
+	* Add ECL threads implementation to swank
+
 2007-12-04  Helmut Eller  <heller at common-lisp.net>
 
 	Simplify the inspector.



From trittweiler at common-lisp.net  Sun Mar 23 23:34:41 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Sun, 23 Mar 2008 18:34:41 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080323233441.E533B2400A@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv26636

Modified Files:
	swank-source-path-parser.lisp 
Log Message:

	* swank-source-path-parser.lisp 

	The source parser READs in files, and if such a file contains some
	nasty #. hackery that results in an error being signalled, M-. would
	fail on anything that's defined in those files. Fix that by using
	a special #. reader function that invokes the original #. reader 
	with an IGNORE-ERRORS wrapped around.

	(make-sharpdot-reader): New function.
	(make-source-recording-readtable): Use it and install it on #.

	* slime.el (find-definition.2): New test case to guard against it.


--- /project/slime/cvsroot/slime/swank-source-path-parser.lisp	2008/03/17 11:35:26	1.19
+++ /project/slime/cvsroot/slime/swank-source-path-parser.lisp	2008/03/23 23:34:41	1.20
@@ -31,6 +31,14 @@
 	      (nth-value 1 (get-macro-character #\space rt))))
   (assert (not (get-macro-character #\\ rt))))
 
+(defun make-sharpdot-reader (orig-sharpdot-reader)
+  #'(lambda (s c n)
+      ;; We want things like M-. to work regardless of any #.-fu in
+      ;; the source file that is to be visited. (For instance, when a
+      ;; file contains #. forms referencing constants that do not
+      ;; currently exist in the image.)
+      (ignore-errors (funcall orig-sharpdot-reader s c n))))
+
 (defun make-source-recorder (fn source-map)
   "Return a macro character function that does the same as FN, but
 additionally stores the result together with the stream positions
@@ -40,7 +48,7 @@
     (let ((start (file-position stream))
 	  (values (multiple-value-list (funcall fn stream char)))
 	  (end (file-position stream)))
-      ;(format t "[~D ~{~A~^, ~} ~D ~D ~S]~%" start values end (char-code char) char)
+      ;(format t "[~D \"~{~A~^, ~}\" ~D ~D ~S]~%" start values end (char-code char) char)
       (unless (null values)
 	(push (cons start end) (gethash (car values) source-map)))
       (values-list values))))
@@ -48,15 +56,22 @@
 (defun make-source-recording-readtable (readtable source-map) 
   "Return a source position recording copy of READTABLE.
 The source locations are stored in SOURCE-MAP."
-  (let* ((tab (copy-readtable readtable))
-	 (*readtable* tab))
-    (dotimes (code 128)
-      (let ((char (code-char code)))
-	(multiple-value-bind (fn term) (get-macro-character char tab)
-	  (when fn
-	    (set-macro-character char (make-source-recorder fn source-map) 
-				 term tab)))))
-    tab))
+  (flet ((install-special-sharpdot-reader (*readtable*)
+	   (let ((old-reader (ignore-errors
+			       (get-dispatch-macro-character #\# #\.))))
+	     (when old-reader
+	       (set-dispatch-macro-character #\# #\.
+		 (make-sharpdot-reader old-reader))))))
+    (let* ((tab (copy-readtable readtable))
+	   (*readtable* tab))
+      (dotimes (code 128)
+	(let ((char (code-char code)))
+	  (multiple-value-bind (fn term) (get-macro-character char tab)
+	    (when fn
+	      (set-macro-character char (make-source-recorder fn source-map) 
+				   term tab)))))
+      (install-special-sharpdot-reader tab)
+      tab)))
 
 (defun read-and-record-source-map (stream)
   "Read the next object from STREAM.
@@ -102,8 +117,8 @@
 
 (defun source-path-file-position (path filename)
   ;; We go this long way round, and don't directly operate on the file
-  ;; stream because FILE-POSITION is not totally savy even on file
-  ;; character streams; on SBCL, FILE-POSITION returns the binary
+  ;; stream because FILE-POSITION (used above) is not totally savy even
+  ;; on file character streams; on SBCL, FILE-POSITION returns the binary
   ;; offset, and not the character offset---screwing up on Unicode.
   (let ((toplevel-number (first path))
 	(buffer))



From trittweiler at common-lisp.net  Sun Mar 23 23:35:06 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Sun, 23 Mar 2008 18:35:06 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080323233506.399E632054@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv26682

Modified Files:
	slime.el 
Log Message:

	* swank-source-path-parser.lisp 

	The source parser READs in files, and if such a file contains some
	nasty #. hackery that results in an error being signalled, M-. would
	fail on anything that's defined in those files. Fix that by using
	a special #. reader function that invokes the original #. reader 
	with an IGNORE-ERRORS wrapped around.

	(make-sharpdot-reader): New function.
	(make-source-recording-readtable): Use it and install it on #.

	* slime.el (find-definition.2): New test case to guard against it.


--- /project/slime/cvsroot/slime/slime.el	2008/03/18 13:22:15	1.930
+++ /project/slime/cvsroot/slime/slime.el	2008/03/23 23:35:06	1.931
@@ -8440,6 +8440,36 @@
            (= orig-pos (point)))))
     (slime-check-top-level))
 
+(def-slime-test find-definition.2
+    (buffer-content buffer-package snippet)
+    "Check that we're able to find definitions even when
+confronted with nasty #.-fu."
+    '(("#.(prog1 nil (defvar *foobar* 42))
+
+       (defun .foo. (x)
+         (+ x #.*foobar*))
+
+       #.(prog1 nil (makunbound '*foobar*))
+       "
+       "SWANK"
+       "(defun .foo. "
+       ))
+  (let ((slime-buffer-package buffer-package))
+    (with-temp-buffer
+      (insert buffer-content)
+      (slime-eval 
+       `(swank:compile-string-for-emacs
+         ,buffer-content
+         ,(buffer-name)
+         ,0
+         ,nil))
+      (let ((bufname (buffer-name)))
+        (slime-edit-definition ".foo.")
+        (slime-check ("Definition of `.foo.' is in buffer `%s'." bufname)
+          (string= (buffer-name) bufname))
+        (slime-check "Definition now at point." (looking-at snippet)))
+      )))
+
 (def-slime-test complete-symbol
     (prefix expected-completions)
     "Find the completions of a symbol-name prefix."



From trittweiler at common-lisp.net  Sun Mar 23 23:35:54 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Sun, 23 Mar 2008 18:35:54 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080323233554.0D6C6370C1@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv26805

Modified Files:
	ChangeLog 
Log Message:

	* swank-source-path-parser.lisp 

	The source parser READs in files, and if such a file contains some
	nasty #. hackery that results in an error being signalled, M-. would
	fail on anything that's defined in those files. Fix that by using
	a special #. reader function that invokes the original #. reader 
	with an IGNORE-ERRORS wrapped around.

	(make-sharpdot-reader): New function.
	(make-source-recording-readtable): Use it and install it on #.

	* slime.el (find-definition.2): New test case to guard against it.


--- /project/slime/cvsroot/slime/ChangeLog	2008/03/19 11:46:43	1.1331
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/23 23:35:53	1.1332
@@ -1,3 +1,18 @@
+2008-03-24  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* swank-source-path-parser.lisp 
+
+	The source parser READs in files, and if such a file contains some
+	nasty #. hackery that results in an error being signalled, M-. would
+	fail on anything that's defined in those files. Fix that by using
+	a special #. reader function that invokes the original #. reader 
+	with an IGNORE-ERRORS wrapped around.
+
+	(make-sharpdot-reader): New function.
+	(make-source-recording-readtable): Use it and install it on #.
+
+	* slime.el (find-definition.2): New test case to guard against it.
+
 2008-03-18  Geo Carncross <geocar at gmail.com>
 
 	* swank-ecl.lisp: ECL moved gray streams into GRAY package.



From trittweiler at common-lisp.net  Sun Mar 23 23:55:39 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Sun, 23 Mar 2008 18:55:39 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080323235539.EA6155D175@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv30130

Modified Files:
	slime.el 
Log Message:

* slime.el (slime-set-connection-info): Display SLIME and SWANK
  versions explicitly in Protocol Mismatch message.  Adapted from
  idea and patch by Jeronimo Pellegrini.


--- /project/slime/cvsroot/slime/slime.el	2008/03/23 23:35:06	1.931
+++ /project/slime/cvsroot/slime/slime.el	2008/03/23 23:55:39	1.932
@@ -1901,7 +1901,10 @@
                               features package version modules
                               &allow-other-keys) info
       (or (equal version slime-protocol-version)
-          (yes-or-no-p "Protocol version mismatch. Continue anyway? ")
+          (yes-or-no-p
+	    (format "Protocol version mismatch: SLIME `%s' vs. SWANK `%s'. Continue anyway? "
+		    slime-protocol-version
+		    version))
           (slime-net-close connection)
           (top-level))
       (setf (slime-pid) pid



From trittweiler at common-lisp.net  Sun Mar 23 23:56:17 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Sun, 23 Mar 2008 18:56:17 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080323235617.B08CE5D176@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv30172

Modified Files:
	ChangeLog 
Log Message:

* slime.el (slime-set-connection-info): Display SLIME and SWANK
  versions explicitly in Protocol Mismatch message.  Adapted from
  idea and patch by Jeronimo Pellegrini.


--- /project/slime/cvsroot/slime/ChangeLog	2008/03/23 23:35:53	1.1332
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/23 23:56:17	1.1333
@@ -1,5 +1,11 @@
 2008-03-24  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* slime.el (slime-set-connection-info): Display SLIME and SWANK
+	versions explicitly in Protocol Mismatch message.  Adapted from
+	idea and patch by Jeronimo Pellegrini.
+	
+2008-03-24  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	* swank-source-path-parser.lisp 
 
 	The source parser READs in files, and if such a file contains some



From trittweiler at common-lisp.net  Sun Mar 23 23:58:38 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Sun, 23 Mar 2008 18:58:38 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080323235838.343D92E1D5@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv31363

Modified Files:
	ChangeLog 
Log Message:

Fix typo in ChangeLog entry.


--- /project/slime/cvsroot/slime/ChangeLog	2008/03/23 23:56:17	1.1333
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/23 23:58:38	1.1334
@@ -25,7 +25,7 @@
 
 2008-03-18  Helmut Eller  <heller at common-lisp.net>
 
-	* slime.el (slime-xref-group): Hanlde :zip files.
+	* slime.el (slime-xref-group): Handle :zip files.
 
 2008-03-17  Tobias C. Rittweiler  <tcr at freebits.de>
 



From trittweiler at common-lisp.net  Mon Mar 24 00:20:13 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Sun, 23 Mar 2008 19:20:13 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080324002013.11C617A012@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv3121

Modified Files:
	HACKING 
Log Message:

* HACKING: Updated due to broken links. 
  Reported by Mirko Vukovic.


--- /project/slime/cvsroot/slime/HACKING	2007/09/19 11:08:27	1.8
+++ /project/slime/cvsroot/slime/HACKING	2008/03/24 00:20:12	1.9
@@ -16,6 +16,17 @@
     The top-level server program, built from the other components.
     Uses swank-backend.lisp as an interface to the actual backends.
 
+  slime.el: 
+    The Superior Lisp Inferior Mode for Emacs, i.e. the Emacs frontend
+    that the user actually interacts with and that connects to the
+    SWANK server to send expressions to, and retrieve information from
+    the running Common Lisp system.
+    
+  contrib/*.lisp:
+    Lisp related code for add-ons to SLIME that are maintained by
+    their respective authors. Consult contrib/README for more
+    information.
+
 * ChangeLog
 
 For each change we make an entry in the ChangeLog file. This is
@@ -28,12 +39,13 @@
 each day as a sort of digest summary of the slime-cvs list.
 
 There are good tips on writing ChangeLog entries in the GNU Coding Standards:
-  http://www.gnu.org/prep/standards_40.html#SEC40
+  http://www.gnu.org/prep/standards/html_node/Style-of-Change-Logs.html#Style-of-Change-Logs
 
 For information about Emacs's ChangeLog support see the `Change Log'
 and `Change Logs and VC' nodes of the Emacs manual:
-  http://www.gnu.org/software/emacs/manual/html_node/emacs_333.html#SEC333
-  http://www.gnu.org/software/emacs/manual/html_node/emacs_156.html#SEC156
+  http://www.gnu.org/software/emacs/manual/html_node/emacs/Change-Log.html#Change-Log
+  http://www.gnu.org/software/emacs/manual/html_node/emacs/Change-Logs-and-VC.html#Change-Logs-and-VC
+
 
 * Sending Patches
 



From trittweiler at common-lisp.net  Mon Mar 24 00:20:43 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Sun, 23 Mar 2008 19:20:43 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080324002043.6C00F2400D@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv3500

Modified Files:
	ChangeLog 
Log Message:

* HACKING: Updated due to broken links. 
  Reported by Mirko Vukovic.


--- /project/slime/cvsroot/slime/ChangeLog	2008/03/23 23:58:38	1.1334
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/24 00:20:43	1.1335
@@ -1,5 +1,10 @@
 2008-03-24  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* HACKING: Updated due to broken links. 
+	Reported by Mirko Vukovic.
+
+2008-03-24  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	* slime.el (slime-set-connection-info): Display SLIME and SWANK
 	versions explicitly in Protocol Mismatch message.  Adapted from
 	idea and patch by Jeronimo Pellegrini.



From heller at common-lisp.net  Mon Mar 24 07:22:20 2008
From: heller at common-lisp.net (heller)
Date: Mon, 24 Mar 2008 02:22:20 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080324072220.DBCE7330D7@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv31829

Modified Files:
	ChangeLog 
Log Message:
* swank-kawa.scm: Save stacktraces with locals on throw events.
This is quite costly but makes debugging easier.

--- /project/slime/cvsroot/slime/ChangeLog	2008/03/24 00:20:43	1.1335
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/24 07:22:19	1.1336
@@ -85,13 +85,13 @@
 
 	* slime.el (slime-repl-return-behaviour): Deleted.  Rebind
 	the key if you don't like what the command does.
-	
+
 2008-03-14  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank.lisp (classify-symbol, symbol-classification->string): Add
 	classification of symbols denoting type specifier, and denoting
 	constants.
-	
+
 2008-03-13  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime.el (slime-eval-macroexpand): Indent expansion.
@@ -101,7 +101,7 @@
 	* slime.el (slime-edit-definition-cont): If no definition could
 	be found, print also the package name in the error message where
 	the definition was tried to be found in.
-	
+
 2008-03-13  Helmut Eller  <heller at common-lisp.net>
 
 	* slime.el (slime-region-for-defun-function): Deleted.



From heller at common-lisp.net  Mon Mar 24 07:22:21 2008
From: heller at common-lisp.net (heller)
Date: Mon, 24 Mar 2008 02:22:21 -0500 (EST)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080324072221.437123F01A@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv31829/contrib

Modified Files:
	ChangeLog swank-kawa.scm 
Log Message:
* swank-kawa.scm: Save stacktraces with locals on throw events.
This is quite costly but makes debugging easier.

--- /project/slime/cvsroot/slime/contrib/ChangeLog	2008/03/18 13:21:28	1.101
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2008/03/24 07:22:20	1.102
@@ -1,3 +1,8 @@
+2008-03-24  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-kawa.scm: Save stacktraces with locals on throw events.
+	This is quite costly but makes debugging easier.
+
 2008-03-14  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank-fancy-inspector.lisp (add-slots-for-inspector): Remove
@@ -16,7 +21,7 @@
 
 	* slime-fuzzy.lisp (slime-fuzzy-insert-completion-choice):
 	(slime-fuzzy-fill-completions-buffer): Adapted to API change.
-	
+
 2008-03-14  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank-fancy-inspector.lisp (make-symbols-listing :classification):
--- /project/slime/cvsroot/slime/contrib/swank-kawa.scm	2008/03/18 13:22:17	1.3
+++ /project/slime/cvsroot/slime/contrib/swank-kawa.scm	2008/03/24 07:22:20	1.4
@@ -3,7 +3,7 @@
 ;;; Copyright (C) 2007  Helmut Eller
 ;;;
 ;;; This file is licensed under the terms of the GNU General Public
-;;; License as distributed with Emacs (press C-h C-c to view it).
+;;; License as distributed with Emacs (press C-h C-c for details).
 
 ;;;; Installation 
 ;;
@@ -40,7 +40,8 @@
 
 (module-compile-options
  :warn-invoke-unknown-method #t
- :warn-undefined-variable #t)
+ :warn-undefined-variable #t
+ )
 
 (require 'hash-table)
 
@@ -102,7 +103,7 @@
   (syntax-rules ()
     ((dotimes (i n result) body ...)
      (let ((max :: <int> n))
-       (do ((i :: <int> 0 (1+ i)))
+       (do ((i :: <int> 0 (as <int> (+ i 1))))
            ((= i max) result)
            body ...)))
     ((dotimes (i n) body ...)
@@ -110,38 +111,25 @@
 
 (define-syntax dolist 
   (syntax-rules ()
-    ((dolist (e list) body ...)
-     (for-each (lambda (e) body ...) list))
-    ((dolist ((e type) list) body ...)
-     (for-each (lambda ((e type)) body ...) list)
-     )))
+    ((dolist (e list) body ... )
+     (for ((e list)) body ...))))
 
 (define-syntax for
   (syntax-rules ()
     ((for ((var iterable)) body ...)
      (let ((iter (! iterator iterable)))
        (while (! has-next iter)
-         (let ((var (! next iter)))
-           body ...))))))
+         ((lambda (var) body ...)
+          (! next iter)))))))
 
 (define-syntax packing
   (syntax-rules ()
     ((packing (var) body ...)
-     (let ((var '()))
+     (let ((var :: <list> '()))
        (let ((var (lambda (v) (set! var (cons v var)))))
          body ...)
        (reverse! var)))))
 
-;;(define-syntax packing
-;;  (syntax-rules ()
-;;    ((packing (var) body ...)
-;;     (let* ((var '()))
-;;       (let-syntax ((var (syntax-rules ()
-;;                           ((var v)
-;;                            (set! var (cons v var))))))
-;;                   body ...)
-;;       (reverse var)))))
-
 ;;(define-syntax loop
 ;;  (syntax-rules (for = then collect until)
 ;;    ((loop for var = init then step until test collect exp)
@@ -196,15 +184,20 @@
     ((mif (,x value) then else)
      (if (eq? x value) then else))
     ((mif (() value) then else)
-     (if (null? value) then else))
-    ((mif ((pattern . rest) value) then else)
+     (if (eq? value '()) then else))
+    ((mif ((p . ps) value) then else)
      (let ((tmp value)
-           (fail (lambda () else)))
-       (if (pair? tmp)
-           (mif (pattern (car tmp))
-                (mif (rest (cdr tmp)) then (fail))
-                (fail))
-           (fail))))
+           (fail? :: <int> 0)
+           (result #!null))
+       (if (instance? tmp <pair>)
+           (let ((tmp :: <pair> tmp))
+             (mif (p tmp:car)
+                (mif (ps tmp:cdr)
+                     (set! result then)
+                     (set! fail? -1))
+                (set! fail? -1)))
+           (set! fail? -1))
+       (if (= fail? 0) result else)))
     ((mif (_ value) then else)
      then)
     ((mif (var value) then else)
@@ -219,7 +212,7 @@
        (mif (pattern tmp)
             (begin body ...)
             (mcase tmp more ...))))
-    ((mcase exp) (error "mcase failed" exp))))
+    ((mcase exp) (ferror "mcase failed ~s\n~a" 'exp (pprint-to-string exp)))))
 
 (define-syntax mlet
   (syntax-rules ()
@@ -281,6 +274,8 @@
 (define-alias <iterable> <java.lang.Iterable>)
 (define-alias <thread> <java.lang.Thread>)
 (define-alias <queue> <java.util.concurrent.LinkedBlockingQueue>)
+(define-alias <exchanger> <java.util.concurrent.Exchanger>)
+(define-alias <timeunit> <java.util.concurrent.TimeUnit>)
 (define-alias <vm> <com.sun.jdi.VirtualMachine>)
 (define-alias <mirror> <com.sun.jdi.Mirror>)
 (define-alias <value> <com.sun.jdi.Value>)
@@ -294,6 +289,7 @@
 (define-alias <field> <com.sun.jdi.Field>)
 (define-alias <local-var> <com.sun.jdi.LocalVariable>)
 (define-alias <location> <com.sun.jdi.Location>)
+(define-alias <absent-exc> <com.sun.jdi.AbsentInformationException>)
 (define-alias <ref-type> <com.sun.jdi.ReferenceType>)
 (define-alias <event> <com.sun.jdi.event.Event>)
 (define-alias <exception-event> <com.sun.jdi.event.ExceptionEvent>)
@@ -336,8 +332,9 @@
 
 ;;;; Event dispatcher
 
-;; for debugging
-(define the-vm #f)
+(define-variable *the-vm* #f)
+(define-variable *last-exception* #f)
+(define-variable *last-stacktrace* #f)
 
 (df dispatch-events ((s <socket>))
   (mlet* ((charset "iso-8859-1")
@@ -351,6 +348,9 @@
             "user" (interaction-environment))
            ;;(interaction-environment)
            )
+          (x (seq 
+               (! set-flag user-env #t #|<env>:THREAD_SAFE|# 8)
+               (! set-flag user-env #f #|<env>:DIRECT_INHERITED_ON_SET|# 16)))
           ((listener . _)
            (spawn/chan (fun (c) (listener c user-env))))
           (inspector #f)
@@ -427,14 +427,16 @@
           ((_ ('set-listener x))
            (set repl-thread x))
           ((_ ('publish-vm vm))
-           (set the-vm vm))
+           (set *the-vm* vm))
           )))))
 
 (df find-thread (id threads listener (vm <vm>))
   (cond ((== id :repl-thread) listener)
-        ((== id 't) (if (null? threads) 
-                        listener 
-                        (vm-mirror vm (car threads))))
+        ((== id 't) listener
+         ;;(if (null? threads) 
+         ;;    listener 
+         ;;    (vm-mirror vm (car threads)))
+         )
         (#t 
          (let ((f (find-if threads 
                       (fun (t :: <thread>)
@@ -449,15 +451,16 @@
 
 (df reader ((in <in>) (c <chan>))
   (! set-name (current-thread) "swank-reader")
-  (define-namespace ReadTable "class:gnu.kawa.lispexpr.ReadTable")
-  (ReadTable:setCurrent (ReadTable:createInitial)) ; ':' not special
-  (while #t
-    (send c (decode-message in))))
+  (let ((rt (gnu.kawa.lispexpr.ReadTable:createInitial))) ; ':' not special
+    (while #t
+      (send c (decode-message in rt)))))
 
-(df decode-message ((in <in>) => <list>)
+(df decode-message ((in <in>) (rt  <gnu.kawa.lispexpr.ReadTable>) => <list>)
   (let* ((header (read-chunk in 6))
          (len (java.lang.Integer:parseInt header 16)))
-    (call-with-input-string (read-chunk in len) read)))
+    (call-with-input-string (read-chunk in len) 
+                            (fun ((port <input-port>))
+                              (%read port rt)))))
 
 (df read-chunk ((in <in>) (len <int>) => <str>)
   (let* ((chars (<char[]> :length len))
@@ -465,6 +468,16 @@
     (assert (= count len) "count: ~d len: ~d" count len)
     (<str> chars)))
 
+;;; FIXME: not thread safe
+(df %read ((port <gnu.mapping.InPort>) (table <gnu.kawa.lispexpr.ReadTable>))
+  ;;  (parameterize ((current-readtable table))
+  ;;                (read)))
+  (let ((old (gnu.kawa.lispexpr.ReadTable:getCurrent)))
+    (try-finally
+     (seq (gnu.kawa.lispexpr.ReadTable:setCurrent table)
+          (read port))
+     (gnu.kawa.lispexpr.ReadTable:setCurrent old))))
+
 
 ;;;; Writer thread
 
@@ -505,16 +518,17 @@
   ;;   (<ucex-handler> (fun (t e) (reply-abort c id))))
   (reply c (%eval form env) id))
 
-(define-constant slime-funs (tab))
+(define-variable *slime-funs*)
+(set *slime-funs* (tab))
 
 (df %eval (form env)
-  (apply (lookup-slimefun (car form)) env (cdr form)))
+  (apply (lookup-slimefun (car form) *slime-funs*) env (cdr form)))
 
-(df lookup-slimefun ((name <symbol>))
+(df lookup-slimefun ((name <symbol>) tab)
   ;; name looks like '|swank:connection-info|
   (let* ((str (symbol->string name))
          (sub (substring str 6 (string-length str))))
-    (or (get slime-funs (string->symbol sub) #f)
+    (or (get tab (string->symbol sub) #f)
         (ferror "~a not implemented" sub))))
                          
 (define-syntax defslimefun 
@@ -522,7 +536,7 @@
     ((defslimefun name (args ...) body ...)
      (seq
        (df name (args ...) body ...)
-       (put slime-funs 'name name)))))
+       (put *slime-funs* 'name name)))))
 
 (defslimefun connection-info ((env <env>))
   (let ((prop java.lang.System:getProperty))
@@ -546,8 +560,9 @@
   (let ((out (rpc c `(get-channel))))
     (set (current-output-port) (make-swank-outport out)))
   (let ((vm (as <vm> (rpc c `(get-vm)))))
-    (enable-uncaught-exception-events vm)
-    (send c `(set-listener ,(vm-mirror vm (current-thread)))))
+    (send c `(set-listener ,(vm-mirror vm (current-thread))))
+    (enable-uncaught-exception-events vm))
+  (rpc c `(get-vm))
   (listener-loop c env))
 
 (df listener-loop ((c <chan>) (env <env>))
@@ -587,7 +602,12 @@
   (let* ((form (read-from-string string))
          (list (values-to-list (eval form env))))
   `(:values ,@(map pprint-to-string list))))
-  
+
+(defslimefun pprint-eval (env string)
+  (let* ((form (read-from-string string))
+         (l (values-to-list (eval form env))))
+    (apply cat (map pprint-to-string l))))
+
 (df call-with-abort (f)
   (try-catch (f) (ex <throwable> (exception-message ex))))
 
@@ -606,7 +626,7 @@
 
 (define-constant compilation-messages (<gnu.text.SourceMessages>))
 
-(defslimefun compile-file-for-emacs (env (filename <string>) load?)
+(defslimefun compile-file-for-emacs (env (filename <str>) load?)
   (let ((zip (cat (path-sans-extension (filepath filename)) ".zip")))
     (wrap-compilation 
      (fun () (kawa.lang.CompileFile:read filename compilation-messages))
@@ -625,12 +645,13 @@
     (log "compilation done.\n")
     (when (and env
                (zero? (! get-error-count compilation-messages)))
-      (eval `(load ,zip) env))
+      (log "loading ...\n")
+      (eval `(load ,zip) env)
+      (log "loading ... done.\n"))
     (when delete?
       (ignore-errors (delete-file zip)))
     (let ((end-time (current-time)))
-      (list 'nil (format "~3f" (/ (as <double> (- end-time start-time))
-                                  1000))))))
+      (list 'nil (format "~3f" (/ (- end-time start-time) 1000))))))
 
 (defslimefun compile-string-for-emacs (env string buffer offset dir)
   (wrap-compilation
@@ -666,7 +687,8 @@
         :location (error-loc>elisp e)))
 
 (df error-loc>elisp ((e <source-error>))
-  (cond ((! starts-with (@ filename e) "(buffer ")
+  (cond ((nul? (@ filename e)) `(:error "No source location"))
+        ((! starts-with (@ filename e) "(buffer ")
          (mlet (('buffer b 'offset o 'str s) (read-from-string (@ filename e)))
            `(:location (:buffer ,b)
                        (:position ,(+ o (line>offset (1- (@ line e)) s)
@@ -678,17 +700,16 @@
                      nil))))
 
 (df line>offset ((line <int>) (s <str>) => <int>)
-  (let ((offset :: <int> -1))
+  (let ((offset :: <int> 0))
     (dotimes (i line)
-      (set offset (! index-of s (as <char> #\newline) (as <int> (1+ offset))))
-      (assert (>= offset 0)))
+      (set offset (! index-of s (as <char> #\newline) offset))
+      (assert (>= offset 0))
+      (set offset (as <int> (+ offset 1))))
     (log "line=~a offset=~a\n" line offset)
     offset))
 
-;; (let ((offset -1)) (! index-of "\n" (as <char> #\newline) (as <int> (1+ offset))))
-
 (defslimefun load-file (env filename)
-  (format "~s\n" (eval `(load ,filename) env)))
+  (format "Loaded: ~a => ~s" filename (eval `(load ,filename) env)))
 
 ;;;; Completion
 
@@ -741,6 +762,28 @@
                        `(,(format "~a" d) ,(src-loc>elisp (src-loc d))))))
     (('error msg) `((,name (:error ,msg))))))
 
+(define-simple-class <swank-location> (<location>)
+  (file :init #f)
+  (line :init #f)
+  ((*init* file name) 
+   (set (@ file (this)) file)
+   (set (@ line (this)) line))
+  ((lineNumber) :: <int> (or line (absent)))
+  ((lineNumber (s <str>)) :: int (! lineNumber (this)))
+  ((method) :: <meth-ref> (absent))
+  ((sourcePath) :: <str> (or file (absent)))
+  ((sourcePath (s <str>)) :: <str> (! sourcePath (this)))
+  ((sourceName) :: <str> (absent))
+  ((sourceName (s <str>)) :: <str> (! sourceName (this)))
+  ((declaringType) :: <ref-type> (absent))
+  ((codeIndex) :: <long> -1)
+  ((virtualMachine) :: <vm> *the-vm*)
+  ((compareTo o) :: <int>
+   (typecase o
+     (<location> (- (! codeIndex (this)) (! codeIndex o))))))
+
+(df absent () (primitive-throw (<absent-exc>)))
+
 (df all-definitions (o)
   (typecase o
     (<gnu.expr.ModuleMethod> (list o))
@@ -749,28 +792,27 @@
                                       (if s (all-definitions s) '()))))
     (<java.lang.Class> (list o))
     (<gnu.mapping.Procedure> (all-definitions (! get-class o)))
-    ))
+    (<kawa.lang.Macro> (list o))))
 
 (df gf-methods ((f <gnu.expr.GenericProc>))
-  (let* ((o :: <obj-ref> (vm-mirror the-vm f))
+  (let* ((o :: <obj-ref> (vm-mirror *the-vm* f))
          (f (! field-by-name (! reference-type o) "methods"))
-         (ms (vm-demirror the-vm (! get-value o f))))
+         (ms (vm-demirror *the-vm* (! get-value o f))))
     (filter (array-to-list ms) (fun (x) (not (nul? x))))))
 
-(df src-loc (o)
+(df src-loc (o => <location>)
   (typecase o
     (<gnu.expr.ModuleMethod> (module-method>src-loc o))
-    (<gnu.expr.GenericProc> `(:error "no src-loc available"))
+    (<gnu.expr.GenericProc> (<swank-location> #f #f))
     (<java.lang.Class> (class>src-loc o))
-    ;; XXX handle macros, variables etc.
-    ))
+    (<kawa.lang.Macro> (<swank-location> #f #f))))
 
 (df module-method>src-loc ((f <gnu.expr.ModuleMethod>))
   (! location (module-method>meth-ref f)))
 
 (df module-method>meth-ref ((f <gnu.expr.ModuleMethod>) => <meth-ref>)
   (let ((module (! reference-type
-                   (as <obj-ref> (vm-mirror the-vm (@ module f)))))
+                   (as <obj-ref> (vm-mirror *the-vm* (@ module f)))))
 	(name (mangled-name f)))
     (as <meth-ref> (1st (! methods-by-name module name)))))
 
@@ -780,22 +822,42 @@
         (cat name "$V")
         name)))
 
-(df class>src-loc ((c <java.lang.Class>))
-  (1st (! all-line-locations (! reflectedType 
-                                (as <com.sun.jdi.ClassObjectReference>

[812 lines skipped]



From trittweiler at common-lisp.net  Wed Mar 26 15:57:38 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Wed, 26 Mar 2008 10:57:38 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080326155738.E09091615E@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv4453

Modified Files:
	swank-sbcl.lisp 
Log Message:

	On SBCL, 

	  (block outta
	    (let ((*debugger-hook* #'(lambda (c hook)
				       (declare (ignore hook))
				       (return-from outta 42))))
	      (error "FOO")))

	would kist silently skip over the *DEBUGGER-HOOK*, and pop right
	into SLDB to handle the error. Fix that.
	
	* swank-sbcl (make-invoke-debugger-hook): New function; returns a
	hook for SB-EXT:*INVOKE-DEBUGGER-HOOK* that checks for the
	presence of *DEBUGGER-HOOK*, and calls that if available.
	(install-debugger-globally): Use it.
	(call-with-debugger-hook): Ditto.

	(getpid): Declaim return type explicitly, to make SBCL shut up about
	being unable to optimize %SAP-ALIEN in ENABLE-SIGIO-ON-FD.

	* slime.el (def-slime-test break): Test additionally that BREAK
	turns into SLDB even when *DEBUGGER-HOOK* is locally bound.
	(def-slime-test locally-bound-debugger-hook): New test case; tests
	that a locally-bound *DEBUGGER-HOOK* is adhered, and not skipped.


--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2008/02/28 19:44:14	1.193
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2008/03/26 15:57:37	1.194
@@ -56,6 +56,17 @@
 (defun swank-mop:slot-definition-documentation (slot)
   (sb-pcl::documentation slot t))
 
+;;; Connection info
+
+(defimplementation lisp-implementation-type-name ()
+  "sbcl")
+
+;; Declare return type explicitly to shut up STYLE-WARNINGS about
+;; %SAP-ALIEN in ENABLE-SIGIO-ON-FD below.
+(declaim (ftype (function () (values (signed-byte 32) &optional)) getpid))
+(defimplementation getpid ()
+  (sb-posix:getpid))
+
 ;;; TCP Server
 
 (defimplementation preferred-communication-style ()
@@ -109,7 +120,8 @@
 
 (defun enable-sigio-on-fd (fd)
   (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
-  (sb-posix::fcntl fd sb-posix::f-setown (getpid)))
+  (sb-posix::fcntl fd sb-posix::f-setown (getpid))
+  (values))
 
 (defimplementation add-sigio-handler (socket fn)
   (set-sigio-handler)
@@ -173,11 +185,6 @@
   (declare (type function fn))
   (sb-sys:without-interrupts (funcall fn)))
 
-(defimplementation getpid ()
-  (sb-posix:getpid))
-
-(defimplementation lisp-implementation-type-name ()
-  "sbcl")
 
 
 ;;;; Support for SBCL syntax
@@ -723,8 +730,18 @@
 
 (defvar *sldb-stack-top*)
 
+(defun make-invoke-debugger-hook (hook)
+  #'(lambda (condition old-hook)
+      ;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before
+      ;; *DEBUGGER-HOOK*, so we have to make sure that the latter gets
+      ;; run when it was established locally by a user.
+      (if *debugger-hook*
+          (funcall *debugger-hook* condition old-hook)
+          (funcall hook condition old-hook))))
+
 (defimplementation install-debugger-globally (function)
-  (setq sb-ext:*invoke-debugger-hook* function))
+  (setq *debugger-hook* function)
+  (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
 
 (defimplementation condition-extras (condition)
   (cond #+#.(swank-backend::sbcl-with-new-stepper-p)
@@ -772,7 +789,8 @@
     (invoke-restart 'sb-ext:step-out)))
 
 (defimplementation call-with-debugger-hook (hook fun)
-  (let ((sb-ext:*invoke-debugger-hook* hook)
+  (let ((*debugger-hook* hook)
+        (sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))
         #+#.(swank-backend::sbcl-with-new-stepper-p)
         (sb-ext:*stepper-hook*
          (lambda (condition)



From trittweiler at common-lisp.net  Wed Mar 26 15:58:24 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Wed, 26 Mar 2008 10:58:24 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080326155824.3579332043@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv4552

Modified Files:
	slime.el 
Log Message:

	On SBCL, 

	  (block outta
	    (let ((*debugger-hook* #'(lambda (c hook)
				       (declare (ignore hook))
				       (return-from outta 42))))
	      (error "FOO")))

	would kist silently skip over the *DEBUGGER-HOOK*, and pop right
	into SLDB to handle the error. Fix that.
	
	* swank-sbcl (make-invoke-debugger-hook): New function; returns a
	hook for SB-EXT:*INVOKE-DEBUGGER-HOOK* that checks for the
	presence of *DEBUGGER-HOOK*, and calls that if available.
	(install-debugger-globally): Use it.
	(call-with-debugger-hook): Ditto.

	(getpid): Declaim return type explicitly, to make SBCL shut up about
	being unable to optimize %SAP-ALIEN in ENABLE-SIGIO-ON-FD.

	* slime.el (def-slime-test break): Test additionally that BREAK
	turns into SLDB even when *DEBUGGER-HOOK* is locally bound.
	(def-slime-test locally-bound-debugger-hook): New test case; tests
	that a locally-bound *DEBUGGER-HOOK* is adhered, and not skipped.


--- /project/slime/cvsroot/slime/slime.el	2008/03/23 23:55:39	1.932
+++ /project/slime/cvsroot/slime/slime.el	2008/03/26 15:58:24	1.933
@@ -8445,8 +8445,7 @@
 
 (def-slime-test find-definition.2
     (buffer-content buffer-package snippet)
-    "Check that we're able to find definitions even when
-confronted with nasty #.-fu."
+    "Check that we're able to find definitions even when confronted with nasty #.-fu."
     '(("#.(prog1 nil (defvar *foobar* 42))
 
        (defun .foo. (x)
@@ -8460,6 +8459,7 @@
   (let ((slime-buffer-package buffer-package))
     (with-temp-buffer
       (insert buffer-content)
+      (slime-check-top-level)
       (slime-eval 
        `(swank:compile-string-for-emacs
          ,buffer-content
@@ -8904,28 +8904,66 @@
     '((1) (2) (3))
   (slime-accept-process-output nil 1)
   (slime-check-top-level)
-  (slime-compile-string 
-   (prin1-to-string `(defun cl-user::foo () 
-                       (dotimes (i ,times) 
-                         (break)
-                         (sleep 0.2))))
+  (let ((tests
+         `((cl-user::foo . (defun cl-user::foo () 
+                             (dotimes (i ,times) 
+                               (break)
+                               (sleep 0.2))))
+           ;; Backends should arguably make sure that BREAK does not
+           ;; depend on *DEBUGGER-HOOK*.
+           (cl-user::bar . (defun cl-user::bar ()
+                             (block outta
+                               (let ((*debugger-hook*
+                                      #'(lambda (c hook)
+                                          (declare (ignore c hook))
+                                          (return-from outta 42))))
+                                 (dotimes (i ,times) 
+                                   (break)
+                                   (sleep 0.2)))))))))
+    (dolist (test tests)
+      (let ((name       (car test))
+            (definition (cdr test)))
+        (slime-compile-string (prin1-to-string definition)  0)
+        (slime-sync-to-top-level 2)
+        (slime-eval-async `(,name))
+        (dotimes (i times)
+          (slime-wait-condition "Debugger visible" 
+                                (lambda () 
+                                  (and (slime-sldb-level= 1)
+                                       (get-buffer-window 
+                                        (sldb-get-default-buffer))))
+                                5)
+          (with-current-buffer (sldb-get-default-buffer)
+            (sldb-continue))
+          (slime-wait-condition "sldb closed" 
+                                (lambda () (not (sldb-get-default-buffer)))
+                                0.2)))
+      (slime-sync-to-top-level 5))))
+
+(def-slime-test locally-bound-debugger-hook
+    ()
+    "Test that binding *DEBUGGER-HOOK* locally works properly."
+    '(())
+  (slime-accept-process-output nil 1)
+  (slime-check-top-level)
+  (slime-compile-string
+   (prin1-to-string `(defun cl-user::quux ()
+                       (block outta
+                         (let ((*debugger-hook*
+                                #'(lambda (c hook)
+                                    (declare (ignore c hook))
+                                    (return-from outta 42))))
+                           (error "FOO")))))
    0)
   (slime-sync-to-top-level 2)
-  (slime-eval-async '(cl-user::foo))
-  (dotimes (i times)
-    (slime-wait-condition "Debugger visible" 
-                          (lambda () 
-                            (and (slime-sldb-level= 1)
-                                 (get-buffer-window 
-                                  (sldb-get-default-buffer))))
-                          5)
-    (with-current-buffer (sldb-get-default-buffer)
-      (sldb-continue))
-    (slime-wait-condition "sldb closed" 
-                          (lambda () (not (sldb-get-default-buffer)))
-                          0.2))
+  (slime-eval-async '(cl-user::quux))
+  (slime-wait-condition "Checking that Debugger does not popup" 
+                        (lambda () 
+                          (not (sldb-get-default-buffer)))
+                        3)
   (slime-sync-to-top-level 5))
 
+
 (def-slime-test interrupt-at-toplevel
     ()
     "Let's see what happens if we send a user interrupt at toplevel."



From trittweiler at common-lisp.net  Wed Mar 26 15:59:30 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Wed, 26 Mar 2008 10:59:30 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080326155930.75AE87C071@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv4689

Modified Files:
	ChangeLog 
Log Message:

	On SBCL, 

	  (block outta
	    (let ((*debugger-hook* #'(lambda (c hook)
				       (declare (ignore hook))
				       (return-from outta 42))))
	      (error "FOO")))

	would kist silently skip over the *DEBUGGER-HOOK*, and pop right
	into SLDB to handle the error. Fix that.
	
	* swank-sbcl (make-invoke-debugger-hook): New function; returns a
	hook for SB-EXT:*INVOKE-DEBUGGER-HOOK* that checks for the
	presence of *DEBUGGER-HOOK*, and calls that if available.
	(install-debugger-globally): Use it.
	(call-with-debugger-hook): Ditto.

	(getpid): Declaim return type explicitly, to make SBCL shut up about
	being unable to optimize %SAP-ALIEN in ENABLE-SIGIO-ON-FD.

	* slime.el (def-slime-test break): Test additionally that BREAK
	turns into SLDB even when *DEBUGGER-HOOK* is locally bound.
	(def-slime-test locally-bound-debugger-hook): New test case; tests
	that a locally-bound *DEBUGGER-HOOK* is adhered, and not skipped.


--- /project/slime/cvsroot/slime/ChangeLog	2008/03/24 07:22:19	1.1336
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/26 15:59:30	1.1337
@@ -1,3 +1,30 @@
+2008-03-26 Tobias C. Rittweiler  <tcr at freebits.de>
+
+	On SBCL, 
+
+	  (block outta
+	    (let ((*debugger-hook* #'(lambda (c hook)
+				       (declare (ignore hook))
+				       (return-from outta 42))))
+	      (error "FOO")))
+
+	would just silently skip over the *DEBUGGER-HOOK*, and pop right
+	into SLDB to handle the error. Fix that.
+	
+	* swank-sbcl (make-invoke-debugger-hook): New function; returns a
+	hook for SB-EXT:*INVOKE-DEBUGGER-HOOK* that checks for the
+	presence of *DEBUGGER-HOOK*, and calls that if available.
+	(install-debugger-globally): Use it.
+	(call-with-debugger-hook): Ditto.
+
+	(getpid): Declaim return type explicitly, to make SBCL shut up about
+	being unable to optimize %SAP-ALIEN in ENABLE-SIGIO-ON-FD.
+
+	* slime.el (def-slime-test break): Test additionally that BREAK
+	turns into SLDB even when *DEBUGGER-HOOK* is locally bound.
+	(def-slime-test locally-bound-debugger-hook): New test case; tests
+	that a locally-bound *DEBUGGER-HOOK* is adhered, and not skipped.
+	
 2008-03-24  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* HACKING: Updated due to broken links. 



From heller at common-lisp.net  Thu Mar 27 11:46:34 2008
From: heller at common-lisp.net (heller)
Date: Thu, 27 Mar 2008 06:46:34 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080327114634.ABBA681000@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv19980

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-check-version): New function.  Make the
prompt fit in a single line.

--- /project/slime/cvsroot/slime/ChangeLog	2008/03/26 15:59:30	1.1337
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/27 11:46:33	1.1338
@@ -25,6 +25,11 @@
 	(def-slime-test locally-bound-debugger-hook): New test case; tests
 	that a locally-bound *DEBUGGER-HOOK* is adhered, and not skipped.
 	
+2008-03-24  Helmut Eller  <heller at common-lisp.net>
+
+	* slime.el (slime-check-version): New function.  Make the
+	prompt fit in a single line.
+
 2008-03-24  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* HACKING: Updated due to broken links. 
--- /project/slime/cvsroot/slime/slime.el	2008/03/26 15:58:24	1.933
+++ /project/slime/cvsroot/slime/slime.el	2008/03/27 11:46:34	1.934
@@ -1900,13 +1900,7 @@
     (destructuring-bind (&key pid style lisp-implementation machine
                               features package version modules
                               &allow-other-keys) info
-      (or (equal version slime-protocol-version)
-          (yes-or-no-p
-	    (format "Protocol version mismatch: SLIME `%s' vs. SWANK `%s'. Continue anyway? "
-		    slime-protocol-version
-		    version))
-          (slime-net-close connection)
-          (top-level))
+      (slime-check-version version connection)
       (setf (slime-pid) pid
             (slime-communication-style) style
             (slime-lisp-features) features
@@ -1936,6 +1930,14 @@
         (funcall fun)))
     (message "Connected. %s" (slime-random-words-of-encouragement))))
 
+(defun slime-check-version (version conn)
+  (or (equal version slime-protocol-version)
+      (equal slime-protocol-version 'ignore)
+      (yes-or-no-p (format "Version mismatch: %S vs. %S.  Continue? "
+                           slime-protocol-version version))
+      (slime-net-close conn)
+      (top-level)))
+
 (defun slime-generate-connection-name (lisp-name)
   (loop for i from 1
         for name = lisp-name then (format "%s<%d>" lisp-name i)



From heller at common-lisp.net  Thu Mar 27 11:46:41 2008
From: heller at common-lisp.net (heller)
Date: Thu, 27 Mar 2008 06:46:41 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080327114641.72069B108@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv20006

Modified Files:
	ChangeLog swank-loader.lisp swank.lisp 
Log Message:
* swank-loader.lisp (load-swank): Call swank::before-init.

* swank.lisp (before-init): New function.
(init): Renamed from setup.

--- /project/slime/cvsroot/slime/ChangeLog	2008/03/27 11:46:33	1.1338
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/27 11:46:41	1.1339
@@ -30,6 +30,11 @@
 	* slime.el (slime-check-version): New function.  Make the
 	prompt fit in a single line.
 
+	* swank-loader.lisp (load-swank): Call swank::before-init.
+
+	* swank.lisp (before-init): New function.
+	(init): Renamed from setup.
+
 2008-03-24  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* HACKING: Updated due to broken links. 
--- /project/slime/cvsroot/slime/swank-loader.lisp	2008/02/25 17:23:00	1.83
+++ /project/slime/cvsroot/slime/swank-loader.lisp	2008/03/27 11:46:41	1.84
@@ -199,28 +199,30 @@
 (defun contrib-dir (base-dir)
   (append-dir base-dir "contrib"))
 
+(defun q (s) (read-from-string s))
+
 (defun load-swank (&key (src-dir *source-directory*)
                    (fasl-dir *fasl-directory*))
-  (compile-files (src-files *swank-files* src-dir) fasl-dir t))
+  (compile-files (src-files *swank-files* src-dir) fasl-dir t)
+  (funcall (q "swank::before-init")
+           (slime-version-string)
+           (list (contrib-dir fasl-dir)
+                 (contrib-dir src-dir))))
 
 (defun compile-contribs (&key (src-dir (contrib-dir *source-directory*))
                          (fasl-dir (contrib-dir *fasl-directory*))
                          load)
   (compile-files (src-files *contribs* src-dir) fasl-dir load))
-
+  
 (defun loadup ()
   (load-swank)
   (compile-contribs :load t))
 
 (defun setup ()
-  (flet ((q (s) (read-from-string s)))
-    (load-site-init-file *source-directory*)
-    (load-user-init-file)
-    (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*")))
-    (funcall (q "swank::setup") 
-             (slime-version-string)
-             (list (contrib-dir *fasl-directory*)    
-                   (contrib-dir *source-directory*)))))
+  (load-site-init-file *source-directory*)
+  (load-user-init-file)
+  (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*")))
+  (funcall (q "swank::init")))
 
 (defun init (&key delete reload load-contribs (setup t))
   (when (and delete (find-package :swank))
--- /project/slime/cvsroot/slime/swank.lisp	2008/03/16 10:44:05	1.540
+++ /project/slime/cvsroot/slime/swank.lisp	2008/03/27 11:46:41	1.541
@@ -3076,10 +3076,12 @@
 
 (add-hook *pre-reply-hook* 'sync-indentation-to-emacs)
 
-(defun setup (version load-path)
+(defun before-init (version init)
   (setq *swank-wire-protocol-version* version)
   (setq *load-path* load-path)
-  (swank-backend::warn-unimplemented-interfaces)
+  (swank-backend::warn-unimplemented-interfaces))
+
+(defun init ()
   (run-hook *after-init-hook*))
 
 ;;; swank.lisp ends here



From heller at common-lisp.net  Thu Mar 27 11:46:50 2008
From: heller at common-lisp.net (heller)
Date: Thu, 27 Mar 2008 06:46:50 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080327114650.D11CF3001B@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv20050

Modified Files:
	ChangeLog slime.el swank.lisp 
Log Message:
By default, don't ask if SLIME should be started.

* slime.el (slime-auto-connect): New variable.
(slime-auto-connect): New function.
(slime-connection): Use it.

--- /project/slime/cvsroot/slime/ChangeLog	2008/03/27 11:46:41	1.1339
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/27 11:46:50	1.1340
@@ -25,6 +25,14 @@
 	(def-slime-test locally-bound-debugger-hook): New test case; tests
 	that a locally-bound *DEBUGGER-HOOK* is adhered, and not skipped.
 	
+2008-03-26  Helmut Eller  <heller at common-lisp.net>
+
+	By default, don't ask if SLIME should be started.
+
+	* slime.el (slime-auto-connect): New variable.
+	(slime-auto-connect): New function.
+	(slime-connection): Use it.
+
 2008-03-24  Helmut Eller  <heller at common-lisp.net>
 
 	* slime.el (slime-check-version): New function.  Make the
--- /project/slime/cvsroot/slime/slime.el	2008/03/27 11:46:34	1.934
+++ /project/slime/cvsroot/slime/slime.el	2008/03/27 11:46:50	1.935
@@ -1736,7 +1736,7 @@
   (or slime-dispatching-connection
       slime-buffer-connection
       slime-default-connection))
-  
+
 (defun slime-connection ()
   "Return the connection to use for Lisp interaction.
 Signal an error if there's no connection."
@@ -1744,17 +1744,25 @@
     (cond ((and (not conn) slime-net-processes)
            (error "No default connection selected."))
           ((not conn)
-           (cond ((y-or-n-p "No connection.  Start Slime? ")
-                  (save-window-excursion
-                    (slime)
-                    (while (not (slime-current-connection))
-                      (sleep-for 1))
-                    (slime-connection)))
-                 (t (error "Not connected."))))
+           (or (slime-auto-connect)
+               (error "Not connected.")))
           ((not (eq (process-status conn) 'open))
            (error "Connection closed."))
           (t conn))))
 
+(defvar slime-auto-connect 'never)
+
+(defun slime-auto-connect ()
+  (cond ((or (eq slime-auto-connect 'always)
+             (and (eq slime-auto-connect 'ask)
+                  (y-or-n-p "No connection.  Start Slime? ")))
+         (save-window-excursion
+           (slime)
+           (while (not (slime-current-connection))
+             (sleep-for 1))
+           (slime-connection)))
+        (t nil)))
+
 (defun slime-select-connection (process)
   "Make PROCESS the default connection."
   (setq slime-default-connection process))
--- /project/slime/cvsroot/slime/swank.lisp	2008/03/27 11:46:41	1.541
+++ /project/slime/cvsroot/slime/swank.lisp	2008/03/27 11:46:50	1.542
@@ -3076,7 +3076,7 @@
 
 (add-hook *pre-reply-hook* 'sync-indentation-to-emacs)
 
-(defun before-init (version init)
+(defun before-init (version load-path)
   (setq *swank-wire-protocol-version* version)
   (setq *load-path* load-path)
   (swank-backend::warn-unimplemented-interfaces))



From heller at common-lisp.net  Thu Mar 27 11:46:53 2008
From: heller at common-lisp.net (heller)
Date: Thu, 27 Mar 2008 06:46:53 -0500 (EST)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080327114653.C8EA76923B@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv20097/contrib

Modified Files:
	swank-kawa.scm 
Log Message:
Various cleanups.

--- /project/slime/cvsroot/slime/contrib/swank-kawa.scm	2008/03/24 07:22:20	1.4
+++ /project/slime/cvsroot/slime/contrib/swank-kawa.scm	2008/03/27 11:46:52	1.5
@@ -736,11 +736,11 @@
              (! substring s1 0 i))
             (#t (loop (1+ i)))))))
 
-(df fold+ (fn list)
+(df fold+ (f list)
   (let loop ((s (car list))
              (l (cdr list)))
     (cond ((null? l) s)
-          (#t (loop (fn s (car l)) (cdr l))))))
+          (#t (loop (f s (car l)) (cdr l))))))
 
 ;;; Quit
 
@@ -855,7 +855,9 @@
 (df src-loc>str ((l <location>))
   (cond ((nul? l) "<null-location>")
         (#t (format "~a ~a ~a" 
-                    (ignore-errors (! source-path l))
+                    (or (ignore-errors (! source-path l))
+                        (ignore-errors (! source-name l))
+                        (ignore-errors (!! name declaring-type l)))
                     (ignore-errors (!! name method l))
                     (ignore-errors (! lineNumber l))))))
 
@@ -1254,9 +1256,10 @@
    (set (@ names (this)) names)
    (set (@ values (this)) values))
   ((toString) :: <str>
-   (to-str (format "#<ff ~a>" 
-                   (or (ignore-errors (src-loc>str loc))
-                       (ignore-errors (!! name method loc)))))))
+   (format "#<ff ~a (~{~a~^ ~})>" 
+           (src-loc>str loc)
+           (mapi args (fun (a) 
+                        (ignore-errors (vm-demirror *the-vm* a)))))))
 
 (df copy-stack ((t <thread-ref>))
   (packing (pack)
@@ -1453,22 +1456,29 @@
 (df throw-to-toplevel ((tid <int>) (id <int>) (c <chan>) state)
   (mlet ((tref level exc) (get state tid #f))
     (let* ((t (as <thread-ref> tref))
-           (ex (<listener-abort>))
-           (vm (! virtualMachine t))
-           (ex (vm-mirror vm ex))
-           (ev (car exc)))
+           (ev (car exc))) 
       (typecase ev
-        (<exception-event> 
-         (log "exc.src-loc: ~s ~s\n" (! location ev) (! catchLocation ev)))
-        (<object> (! stop t ex)) ; XXX race condition?
-        )
-      (! resume t)
-      (reply-abort c id)
-      (do ((level level (1- level))
-           (exc exc (cdr exc)))
-          ((null? exc))
-        (send c `(forward (:debug-return ,tid ,level nil))))
-      (del state tid))))
+        (<exception-event>
+         (! resume t)
+         (reply-abort c id)
+         (do ((level level (1- level))
+              (exc exc (cdr exc)))
+             ((null? exc))
+           (send c `(forward (:debug-return ,tid ,level nil))))
+         (del state tid))
+        (<break-event>
+         ;; XXX race condition? 
+         (let ((vm (! virtualMachine t)))
+           (reply-abort c id)
+           (! stop t (vm-mirror vm (<listener-abort>)))
+           (! interrupt t)
+           (! resume t)
+           (! interrupt t)
+           (do ((level level (1- level))
+                (exc exc (cdr exc)))
+               ((null? exc))
+             (send c `(forward (:debug-return ,tid ,level nil))))
+           (del state tid)))))))
 
 (df thread-continue ((tid <int>) (id <int>) (c <chan>) state)
   (mlet ((tref level exc) (get state tid #f))
@@ -1491,6 +1501,17 @@
     (! put-property req 'continuation k)
     (! enable req)))
 
+(df eval-in-thread ((t <thread-ref>) sexp 
+		    #!optional (env :: <env> (<env>:current)))
+  (let* ((vm (! virtualMachine t))
+	 (sc :: <class-ref>
+	     (1st (! classes-by-name vm "kawa.standard.Scheme")))
+	 (ev :: <meth-ref>
+	     (1st (! methods-by-name sc "eval" 
+		     (cat "(Ljava/lang/Object;Lgnu/mapping/Environment;)"
+			  "Ljava/lang/Object;")))))
+    (! invokeMethod sc t ev (list sexp env) sc:INVOKE_SINGLE_THREADED)))
+
 ;;;;; Threads 
 
 (df list-threads (vm :: <vm> state)
@@ -1628,12 +1649,12 @@
 
 (define-simple-class <ucex-handler>
     (<java.lang.Thread$UncaughtExceptionHandler>)
-  (fn :: <gnu.mapping.Procedure>)
-  ((*init* (fn :: <gnu.mapping.Procedure>)) (set (@ fn (this)) fn))
+  (f :: <gnu.mapping.Procedure>)
+  ((*init* (f :: <gnu.mapping.Procedure>)) (set (@ f (this)) f))
   ((uncaughtException (t <thread>) (e <throwable>))
    :: <void>
    ;;(! println (java.lang.System:.err) (to-str "uhexc:::"))
-   (! apply2 fn t e)
+   (! apply2 f t e)
     #!void))
 
 ;;;; Channels
@@ -1880,7 +1901,7 @@
               (! getColumnNumber decl)
               ))))
 
-(df %time (fn)
+(df %time (f)
   (define-alias <mf> <java.lang.management.ManagementFactory>)
   (define-alias <gc> <java.lang.management.GarbageCollectorMXBean>)
   (let* ((gcs (<mf>:getGarbageCollectorMXBeans))
@@ -1895,7 +1916,7 @@
          (heap (!! getUsed getHeapMemoryUsage mem))
          (nonheap (!! getUsed getNonHeapMemoryUsage mem))
          (start (java.lang.System:nanoTime))
-         (values (fn))
+         (values (f))
          (end (java.lang.System:nanoTime))
          (newheap (!! getUsed getHeapMemoryUsage mem))
          (newnonheap (!! getUsed getNonHeapMemoryUsage mem)))



From msimmons at common-lisp.net  Thu Mar 27 21:59:49 2008
From: msimmons at common-lisp.net (msimmons)
Date: Thu, 27 Mar 2008 16:59:49 -0500 (EST)
Subject: [slime-cvs] CVS slime
Message-ID: <20080327215949.30D63702FE@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv13991

Modified Files:
	swank-lispworks.lisp ChangeLog 
Log Message:

(map-error-database): Make mapping work for LispWorks 5.1 too.


--- /project/slime/cvsroot/slime/swank-lispworks.lisp	2008/02/10 08:32:04	1.97
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp	2008/03/27 21:59:45	1.98
@@ -408,7 +408,7 @@
   (loop for (filename . defs) in database do
 	(loop for (dspec . conditions) in defs do
 	      (dolist (c conditions) 
-		(funcall fn filename dspec c)))))
+		(funcall fn filename dspec (if (consp c) (car c) c))))))
 
 (defun lispworks-severity (condition)
   (cond ((not condition) :warning)
--- /project/slime/cvsroot/slime/ChangeLog	2008/03/27 11:46:50	1.1340
+++ /project/slime/cvsroot/slime/ChangeLog	2008/03/27 21:59:45	1.1341
@@ -1,3 +1,8 @@
+2008-03-27  Martin Simmons <martin at lispworks.com>
+
+	* swank-lispworks.lisp (map-error-database): Make mapping work for
+	LispWorks 5.1 too.
+
 2008-03-26 Tobias C. Rittweiler  <tcr at freebits.de>
 
 	On SBCL,