[slime-cvs] CVS slime
CVS User trittweiler
trittweiler at common-lisp.net
Tue Dec 30 18:57:54 UTC 2008
Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv13135
Modified Files:
swank.lisp swank-scl.lisp swank-sbcl.lisp swank-openmcl.lisp
swank-lispworks.lisp swank-ecl.lisp swank-corman.lisp
swank-cmucl.lisp swank-clisp.lisp swank-backend.lisp
swank-allegro.lisp swank-abcl.lisp slime.el ChangeLog
Log Message:
As of now, `C-u C-c C-c' compiled a function with maximum debug
settings (SBCL only.)
Now, `M-- C-c C-c' will compile a function with maximum _speed_
settings (still SBCL only) --- useful to elicit compiler notes.
* slime.el (slime-compilation-debug-level): Renamed to
`slime-compilation-policy'.
(slime-normalize-optimization-level): Renamed to
`slime-compute-policy'.
* swank.lisp (compile-string-for-emacs): Takes a policy now.
(compile-multiple-strings-for-emacs): Ditto.
* swank-backend.lisp (swank-compile-string): Change :DEBUG key arg
to :POLICY.
* swank-scl.lisp, swank-openmcl.lisp, swank-lispworks.lisp
* swank-ecl.lisp, swank-corman.lisp, swank-cmucl.lisp,
* swank-clisp.lisp, swank-allegro.lisp, swank-sbcl.lisp:
Changed accordingly.
--- /project/slime/cvsroot/slime/swank.lisp 2008/12/27 18:24:29 1.617
+++ /project/slime/cvsroot/slime/swank.lisp 2008/12/30 18:57:54 1.618
@@ -2541,7 +2541,7 @@
(declare (ignore output-pathname warnings?))
(not failure?)))))))
-(defslimefun compile-string-for-emacs (string buffer position directory debug)
+(defslimefun compile-string-for-emacs (string buffer position directory policy)
"Compile STRING (exerpted from BUFFER at POSITION).
Record compiler notes signalled as `compiler-condition's."
(with-buffer-syntax ()
@@ -2552,9 +2552,9 @@
:buffer buffer
:position position
:directory directory
- :debug debug))))))
+ :policy policy))))))
-(defslimefun compile-multiple-strings-for-emacs (strings debug)
+(defslimefun compile-multiple-strings-for-emacs (strings policy)
"Compile STRINGS (exerpted from BUFFER at POSITION).
Record compiler notes signalled as `compiler-condition's."
(loop for (string buffer package position directory) in strings collect
@@ -2566,7 +2566,7 @@
:buffer buffer
:position position
:directory directory
- :debug debug)))))))
+ :policy policy)))))))
(defun file-newer-p (new-file old-file)
"Returns true if NEW-FILE is newer than OLD-FILE."
--- /project/slime/cvsroot/slime/swank-scl.lisp 2008/10/17 21:26:53 1.29
+++ /project/slime/cvsroot/slime/swank-scl.lisp 2008/12/30 18:57:54 1.30
@@ -452,8 +452,8 @@
(not (load output-file)))))))))
(defimplementation swank-compile-string (string &key buffer position directory
- debug)
- (declare (ignore directory debug))
+ policy)
+ (declare (ignore directory policy))
(with-compilation-hooks ()
(let ((*buffer-name* buffer)
(*buffer-start-position* position)
--- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/10/30 09:28:51 1.227
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/12/30 18:57:54 1.228
@@ -502,19 +502,27 @@
"Return a temporary file name to compile strings into."
(concatenate 'string (tmpnam nil) ".lisp"))
+(defun get-compiler-policy (default-policy)
+ (declare (ignorable default-policy))
+ #+#.(swank-backend::sbcl-with-symbol 'restrict-compiler-policy 'sb-ext)
+ (remove-duplicates (append default-policy (sb-ext:restrict-compiler-policy))
+ :key #'car))
+
+(defun set-compiler-policy (policy)
+ (declare (ignorable policy))
+ #+#.(swank-backend::sbcl-with-symbol 'restrict-compiler-policy 'sb-ext)
+ (loop for (qual . value) in policy
+ do (sb-ext:restrict-compiler-policy qual value)))
+
(defimplementation swank-compile-string (string &key buffer position directory
- debug)
- (declare (ignorable debug))
+ policy)
(let ((*buffer-name* buffer)
(*buffer-offset* position)
(*buffer-substring* string)
(filename (temp-file-name))
- #+#.(swank-backend::sbcl-with-symbol 'restrict-compiler-policy 'sb-ext)
- (old-min-debug (assoc 'debug (sb-ext:restrict-compiler-policy)))
- )
- #+#.(swank-backend::sbcl-with-symbol 'restrict-compiler-policy 'sb-ext)
- (when debug
- (sb-ext:restrict-compiler-policy 'debug debug))
+ (saved-policy (get-compiler-policy '((debug . 0) (speed . 0)))))
+ (when policy
+ (set-compiler-policy policy))
(flet ((load-it (filename)
(when filename (load filename)))
(compile-it (cont)
@@ -532,9 +540,7 @@
(compile-it #'load-it)
(load-it (compile-it #'identity)))
(ignore-errors
- #+#.(swank-backend::sbcl-with-symbol
- 'restrict-compiler-policy 'sb-ext)
- (sb-ext:restrict-compiler-policy 'debug (or old-min-debug 0))
+ (set-compiler-policy saved-policy)
(delete-file filename)
(delete-file (compile-file-pathname filename)))))))
--- /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/12/29 19:03:20 1.148
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/12/30 18:57:54 1.149
@@ -369,8 +369,8 @@
:test 'equal))
(defimplementation swank-compile-string (string &key buffer position directory
- debug)
- (declare (ignore debug))
+ policy)
+ (declare (ignore policy))
(with-compilation-hooks ()
(let ((*buffer-name* buffer)
(*buffer-offset* position)
--- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/10/31 14:13:19 1.123
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/12/30 18:57:54 1.124
@@ -621,8 +621,8 @@
htab))
(defimplementation swank-compile-string (string &key buffer position directory
- debug)
- (declare (ignore directory debug))
+ policy)
+ (declare (ignore directory policy))
(assert buffer)
(assert position)
(let* ((location (list :emacs-buffer buffer position string))
--- /project/slime/cvsroot/slime/swank-ecl.lisp 2008/10/17 21:26:53 1.35
+++ /project/slime/cvsroot/slime/swank-ecl.lisp 2008/12/30 18:57:54 1.36
@@ -146,8 +146,8 @@
(compile-file *compile-filename* :load t))))
(defimplementation swank-compile-string (string &key buffer position directory
- debug)
- (declare (ignore directory debug))
+ policy)
+ (declare (ignore directory policy))
(with-compilation-hooks ()
(let ((*buffer-name* buffer)
(*buffer-start-position* position)
--- /project/slime/cvsroot/slime/swank-corman.lisp 2008/10/19 20:03:34 1.20
+++ /project/slime/cvsroot/slime/swank-corman.lisp 2008/12/30 18:57:54 1.21
@@ -372,8 +372,8 @@
(or failure? (and load-p (load output-file))))))))
(defimplementation swank-compile-string (string &key buffer position directory
- debug)
- (declare (ignore directory debug))
+ policy)
+ (declare (ignore directory policy))
(with-compilation-hooks ()
(let ((*buffer-name* buffer)
(*buffer-position* position)
--- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/12/24 07:56:20 1.204
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/12/30 18:57:54 1.205
@@ -395,8 +395,8 @@
(not (load output-file)))))))))
(defimplementation swank-compile-string (string &key buffer position directory
- debug)
- (declare (ignore directory debug))
+ policy)
+ (declare (ignore directory policy))
(with-compilation-hooks ()
(let ((*buffer-name* buffer)
(*buffer-start-position* position)
--- /project/slime/cvsroot/slime/swank-clisp.lisp 2008/10/19 20:03:34 1.84
+++ /project/slime/cvsroot/slime/swank-clisp.lisp 2008/12/30 18:57:54 1.85
@@ -635,8 +635,8 @@
(not (load fasl-file)))))))))
(defimplementation swank-compile-string (string &key buffer position directory
- debug)
- (declare (ignore directory debug))
+ policy)
+ (declare (ignore directory policy))
(with-compilation-hooks ()
(let ((*buffer-name* buffer)
(*buffer-offset* position))
--- /project/slime/cvsroot/slime/swank-backend.lisp 2008/12/24 07:56:20 1.164
+++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/12/30 18:57:54 1.165
@@ -370,8 +370,8 @@
(declare (ignore ignore))
`(call-with-compilation-hooks (lambda () (progn , at body))))
-(definterface swank-compile-string (string &key buffer position directory
- debug)
+(definterface swank-compile-string (string &key buffer position directory
+ policy)
"Compile source from STRING.
During compilation, compiler conditions must be trapped and
resignalled as COMPILER-CONDITIONs.
--- /project/slime/cvsroot/slime/swank-allegro.lisp 2008/10/21 20:38:05 1.119
+++ /project/slime/cvsroot/slime/swank-allegro.lisp 2008/12/30 18:57:54 1.120
@@ -316,8 +316,8 @@
(not failure?)))))
(defimplementation swank-compile-string (string &key buffer position directory
- debug)
- (declare (ignore debug))
+ policy)
+ (declare (ignore policy))
;; We store the source buffer in excl::*source-pathname* as a string
;; of the form <buffername>;<start-offset>. Quite ugly encoding, but
;; the fasl file is corrupted if we use some other datatype.
--- /project/slime/cvsroot/slime/swank-abcl.lisp 2008/10/19 20:03:34 1.60
+++ /project/slime/cvsroot/slime/swank-abcl.lisp 2008/12/30 18:57:54 1.61
@@ -341,8 +341,8 @@
(not (load fn))))))))))
(defimplementation swank-compile-string (string &key buffer position directory
- debug)
- (declare (ignore directory debug))
+ policy)
+ (declare (ignore directory policy))
(let ((jvm::*resignal-compiler-warnings* t)
(*abcl-signaled-conditions* nil))
(handler-bind ((warning #'handle-compiler-warning))
--- /project/slime/cvsroot/slime/slime.el 2008/12/27 18:24:28 1.1083
+++ /project/slime/cvsroot/slime/slime.el 2008/12/30 18:57:54 1.1084
@@ -2530,14 +2530,20 @@
slime-maybe-show-xrefs-for-notes
slime-goto-first-note))
-(defvar slime-compilation-debug-level nil
+(defvar slime-compilation-policy nil
"When non-nil compile defuns with this debug optimization level.")
-(defun slime-normalize-optimization-level (n)
- (cond ((not n) nil)
- ((> n 3) 3)
- ((< n 0) 0)
- (t n)))
+(defun slime-compute-policy (arg)
+ (flet ((between (min n max)
+ (if (< n min)
+ min
+ (if (> n max) max n))))
+ (let ((n (prefix-numeric-value arg)))
+ (cond ((not arg) slime-compilation-policy)
+ ((plusp n) `((cl:debug . ,(between 0 n 3))))
+ ((eq arg '-) `((cl:speed . 3)))
+ (t `((cl:speed . ,(between 0 (abs n) 3))))))))
+
(defstruct (slime-compilation-result
(:type list)
@@ -2592,9 +2598,7 @@
with maximum debug setting. If invoked with a numeric prefix arg,
compile with a debug setting of that number."
(interactive "P")
- (let* ((prefix-arg (and raw-prefix-arg (prefix-numeric-value raw-prefix-arg)))
- (debug-level (slime-normalize-optimization-level prefix-arg))
- (slime-compilation-debug-level debug-level))
+ (let ((slime-compilation-policy (slime-compute-policy raw-prefix-arg)))
(apply #'slime-compile-region (slime-region-for-defun-at-point))))
(defun slime-compile-region (start end)
@@ -2616,7 +2620,7 @@
,(buffer-name)
,start-offset
,(if (buffer-file-name) (file-name-directory (buffer-file-name)))
- ',slime-compilation-debug-level)
+ ',slime-compilation-policy)
#'slime-compilation-finished))
(defun slime-compilation-finished (result)
@@ -2682,12 +2686,12 @@
;;;;; Recompilation.
-(defun slime-recompile-location (location &optional debug-level)
+(defun slime-recompile-location (location)
(save-excursion
(slime-goto-source-location location)
- (slime-compile-defun debug-level)))
+ (slime-compile-defun)))
-(defun slime-recompile-locations (locations debug-level cont)
+(defun slime-recompile-locations (locations cont)
(slime-eval-async
`(swank:compile-multiple-strings-for-emacs
',(loop for loc in locations collect
@@ -2702,7 +2706,7 @@
(if (buffer-file-name)
(file-name-directory (buffer-file-name))
nil)))))
- ,debug-level)
+ ',slime-compilation-policy)
cont))
@@ -4916,28 +4920,24 @@
(defun slime-recompile-xref (&optional raw-prefix-arg)
(interactive "P")
- (let* ((prefix-arg (and raw-prefix-arg
- (prefix-numeric-value raw-prefix-arg)))
- (debug-level (slime-normalize-optimization-level prefix-arg)))
+ (let ((slime-compilation-policy (slime-compute-policy raw-prefix-arg)))
(let ((location (slime-xref-location-at-point))
(dspec (slime-xref-dspec-at-point)))
(slime-recompile-locations
- (list location) debug-level
+ (list location)
(slime-rcurry #'slime-xref-recompilation-cont
(list dspec) (current-buffer))))))
(defun slime-recompile-all-xrefs (&optional raw-prefix-arg)
(interactive "P")
- (let* ((prefix-arg (and raw-prefix-arg
- (prefix-numeric-value raw-prefix-arg)))
- (debug-level (slime-normalize-optimization-level prefix-arg)))
+ (let ((slime-compilation-policy (slime-compute-policy raw-prefix-arg)))
(let ((dspecs) (locations))
(dolist (xref (slime-all-xrefs))
(when (slime-xref-has-location-p xref)
(push (slime-xref.dspec xref) dspecs)
(push (slime-xref.location xref) locations)))
(slime-recompile-locations
- locations debug-level
+ locations
(slime-rcurry #'slime-xref-recompilation-cont
dspecs (current-buffer))))))
@@ -6034,16 +6034,14 @@
(interactive "P")
(slime-eval-async
`(swank:frame-source-location-for-emacs ,(sldb-frame-number-at-point))
- (lexical-let ((debug-level (slime-normalize-optimization-level
- (and raw-prefix-arg
- (prefix-numeric-value raw-prefix-arg)))))
+ (let ((slime-compilation-policy (slime-compute-policy raw-prefix-arg)))
(lambda (source-location)
(destructure-case source-location
((:error message)
(message "%s" message)
(ding))
(t
- (slime-recompile-location source-location debug-level)))))))
+ (slime-recompile-location source-location)))))))
;;;; Thread control panel
--- /project/slime/cvsroot/slime/ChangeLog 2008/12/29 19:03:20 1.1609
+++ /project/slime/cvsroot/slime/ChangeLog 2008/12/30 18:57:54 1.1610
@@ -1,3 +1,28 @@
+2008-12-30 Tobias C. Rittweiler <tcr at freebits.de>
+
+ As of now, `C-u C-c C-c' compiled a function with maximum debug
+ settings (SBCL only.)
+
+ Now, `M-- C-c C-c' will compile a function with maximum _speed_
+ settings (still SBCL only) --- useful to elicit compiler notes.
+
+ * slime.el (slime-compilation-debug-level): Renamed to
+ `slime-compilation-policy'.
+ (slime-normalize-optimization-level): Renamed to
+ `slime-compute-policy'.
+
+ * swank.lisp (compile-string-for-emacs): Takes a policy now.
+ (compile-multiple-strings-for-emacs): Ditto.
+
+ * swank-backend.lisp (swank-compile-string): Change :DEBUG key arg
+ to :POLICY.
+
+ * swank-scl.lisp, swank-openmcl.lisp, swank-lispworks.lisp
+ * swank-ecl.lisp, swank-corman.lisp, swank-cmucl.lisp,
+ * swank-clisp.lisp, swank-allegro.lisp, swank-sbcl.lisp:
+
+ Changed accordingly.
+
2008-12-29 Helmut Eller <heller at common-lisp.net>
* swank-openmcl.lisp (find-definitions, source-locations): Use
More information about the slime-cvs
mailing list