[slime-cvs] CVS update: slime/swank-lispworks.lisp

[Helmut Eller]

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

Modified Files:
	swank-lispworks.lisp 
Log Message:
(toggle-trace-fdefinition, tracedp): New support functions for
toggle-trace command.  Written by Alain Picard.
(compile-from-temp-file): Don't delete the binary file if there is
none.
(lispworks-severity): Map all ERRORs to :error.
Date: Thu Dec  4 02:42:23 2003
Author: heller

Index: slime/swank-lispworks.lisp
diff -u slime/swank-lispworks.lisp:1.5 slime/swank-lispworks.lisp:1.6
--- slime/swank-lispworks.lisp:1.5	Mon Dec  1 17:30:16 2003
+++ slime/swank-lispworks.lisp	Thu Dec  4 02:42:22 2003
@@ -7,7 +7,7 @@
 ;;; This code has been placed in the Public Domain.  All warranties
 ;;; are disclaimed.
 ;;;
-;;;   $Id: swank-lispworks.lisp,v 1.5 2003/12/01 22:30:16 heller Exp $
+;;;   $Id: swank-lispworks.lisp,v 1.6 2003/12/04 07:42:22 heller Exp $
 ;;;
 
 (in-package :swank)
@@ -262,6 +262,21 @@
 (defslimefun find-function-locations (fname)
   (dspec-source-locations (from-string fname)))
 
+;;; Tracing
+
+(defun tracedp (symbol)
+  (member symbol (trace) :test #'eq))
+
+(defslimefun toggle-trace-fdefinition (fname-string)
+  (let ((fname (from-string fname-string)))
+    ;;(print `(got ,fname-string and ,fname))
+    (cond ((tracedp fname)
+           (compiler::ensure-untrace-1 (list fname))
+	   (format nil "~S is now untraced." fname))
+	  (t
+           (compiler::ensure-trace-1 (list fname))
+	   (format nil "~S is now traced." fname)))))
+
 ;;; callers
 
 (defun stringify-function-name-list (list)
@@ -288,7 +303,7 @@
 (defun lispworks-severity (condition)
   (cond ((not condition) :warning)
 	(t (etypecase condition
-	     (simple-error  :error)
+	     (error :error)
 	     (style-warning :warning)
 	     (warning :warning)))))
 
@@ -307,7 +322,8 @@
 	   (write-string string s)
 	   (finish-output s))
 	 (let ((binary-filename (compile-file filename :load t)))
-	   (delete-file binary-filename)))
+           (when binary-filename
+             (delete-file binary-filename))))
     (delete-file filename)))
 
 (defun make-dspec-location (dspec location &optional tmpfile buffer position)