[slime-cvs] CVS update: slime/swank.lisp slime/swank-sbcl.lisp slime/swank-backend.lisp slime/swank-source-path-parser.lisp
Helmut Eller
heller at common-lisp.net
Sat Jan 31 09:02:22 UTC 2004
Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv14560
Modified Files:
swank.lisp swank-sbcl.lisp swank-backend.lisp
swank-source-path-parser.lisp
Log Message:
Patch by Robert E. Brown. Add type declarations to keep SBCL quiet.
Date: Sat Jan 31 04:02:22 2004
Author: heller
Index: slime/swank.lisp
diff -u slime/swank.lisp:1.110 slime/swank.lisp:1.111
--- slime/swank.lisp:1.110 Thu Jan 29 03:37:57 2004
+++ slime/swank.lisp Sat Jan 31 04:02:21 2004
@@ -188,6 +188,7 @@
(setup-server port announce-fn background))
(defun setup-server (port announce-fn background)
+ (declare (type function announce-fn))
(setq *write-lock* (make-lock :name "Swank write lock"))
(let* ((socket (create-socket port))
(port (local-port socket)))
@@ -305,6 +306,7 @@
(defun call-with-redirected-io (connection function)
"Call FUNCTION with I/O streams redirected via CONNECTION."
+ (declare (type function function))
(let* ((io (connection.user-io connection))
(in (connection.user-input connection))
(out (connection.user-output connection))
@@ -346,6 +348,7 @@
(call-with-aux-connection (lambda () , at body))))
(defun call-with-aux-connection (fn)
+ (declare (type function fn))
(let* ((c (open-aux-connection))
(*dispatching-connection* c))
(unwind-protect (funcall fn)
@@ -524,13 +527,14 @@
(defun format-arglist (function-name lambda-list-fn)
"Use LAMBDA-LIST-FN to format the arglist for FUNCTION-NAME.
Call LAMBDA-LIST-FN with the symbol corresponding to FUNCTION-NAME."
- (multiple-value-bind (arglist condition)
- (ignore-errors
- (let ((symbol (find-symbol-or-lose function-name)))
- (values (funcall lambda-list-fn symbol))))
- (cond (condition (format nil "(-- ~A)" condition))
- (t (let ((*print-case* :downcase))
- (format nil "(~{~A~^ ~})" arglist))))))
+ (declare (type function lambda-list-fn))
+ (multiple-value-bind (arglist condition)
+ (ignore-errors
+ (let ((symbol (find-symbol-or-lose function-name)))
+ (values (funcall lambda-list-fn symbol))))
+ (cond (condition (format nil "(-- ~A)" condition))
+ (t (let ((*print-case* :downcase))
+ (format nil "(~{~A~^ ~})" arglist))))))
;;;; Debugger
@@ -627,6 +631,7 @@
"Bind some printer variables to properly indent the frame and call
FN with a string-stream for printing a frame of a bracktrace. Return
the string."
+ (declare (type function fn))
(let* ((label (format nil " ~D: " n))
(string (with-output-to-string (stream)
(let ((*print-pretty* *sldb-pprint-frames*))
@@ -800,6 +805,7 @@
(defun measure-time-interval (fn)
"Call FN and return the first return value and the elapsed time.
The time is measured in microseconds."
+ (declare (type function fn))
(let ((before (get-internal-real-time)))
(values
(funcall fn)
@@ -846,6 +852,7 @@
;;;; Macroexpansion
(defun apply-macro-expander (expander string)
+ (declare (type function expander))
(let ((*print-pretty* t)
(*print-length* 20)
(*print-level* 20))
@@ -904,6 +911,7 @@
FOO - Symbols with matching prefix and accessible in the buffer package.
PKG:FOO - Symbols with matching prefix and external in package PKG.
PKG::FOO - Symbols with matching prefix and accessible in package PKG."
+ (declare (type simple-base-string string))
(multiple-value-bind (name package-name internal-p)
(tokenize-symbol-designator string)
(let ((package (carefully-find-package package-name default-package-name))
@@ -939,6 +947,7 @@
SYMBOL-NAME
PACKAGE-NAME, or nil if the designator does not include an explicit package.
INTERNAL-P, if the symbol is qualified with `::'."
+ (declare (type simple-base-string string))
(values (let ((pos (position #\: string :from-end t)))
(if pos (subseq string (1+ pos)) string))
(let ((pos (position #\: string)))
@@ -967,6 +976,7 @@
\(compound-prefix-match \"foo\" \"foobar\") => t
\(compound-prefix-match \"m--b\" \"multiple-value-bind\") => t
\(compound-prefix-match \"m-v-c\" \"multiple-value-bind\") => NIL"
+ (declare (type simple-base-string prefix target))
(loop for ch across prefix
with tpos = 0
always (and (< tpos (length target))
@@ -986,6 +996,7 @@
(defun tokenize-completion (string)
"Return all substrings of STRING delimited by #\-."
+ (declare (type simple-base-string string))
(loop with end
for start = 0 then (1+ end)
until (> start (length string))
@@ -1033,6 +1044,7 @@
"Return a property list describing SYMBOL.
Like `describe-symbol-for-emacs' but with at most one line per item."
(flet ((first-line (string)
+ (declare (type simple-base-string string))
(let ((pos (position #\newline string)))
(if (null pos) string (subseq string 0 pos)))))
(let ((desc (map-if #'stringp #'first-line
@@ -1044,6 +1056,7 @@
"Like (mapcar FN . LISTS) but only call FN on objects satisfying TEST.
Example:
\(map-if #'oddp #'- '(1 2 3 4 5)) => (-1 2 -3 4 -5)"
+ (declare (type function test fn))
(apply #'mapcar
(lambda (x) (if (funcall test x) (funcall fn x) x))
lists))
@@ -1051,6 +1064,7 @@
(defun listify (f)
"Return a function like F, but which returns any non-null value
wrapped in a list."
+ (declare (type function f))
(lambda (x)
(let ((y (funcall f x)))
(and y (list y)))))
@@ -1078,6 +1092,7 @@
(apropos-list string package)))
(defun print-output-to-string (fn)
+ (declare (type function fn))
(with-output-to-string (*standard-output*)
(let ((*debug-io* *standard-output*))
(funcall fn))))
@@ -1165,6 +1180,7 @@
(defun alistify (list key test)
"Partition the elements of LIST into an alist. KEY extracts the key
from an element and TEST is used to compare keys."
+ (declare (type function key))
(let ((alist '()))
(dolist (e list)
(let* ((k (funcall key e))
@@ -1181,6 +1197,7 @@
(t nil)))
(defun partition (list predicate)
+ (declare (type function predicate))
(loop for e in list
if (funcall predicate e) collect e into yes
else collect e into no
@@ -1207,6 +1224,7 @@
(defvar *inspectee-parts*)
(defvar *inspector-stack* '())
(defvar *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))
+(declaim (type vector *inspector-history*))
(defvar *inspect-length* 30)
(defun reset-inspector ()
Index: slime/swank-sbcl.lisp
diff -u slime/swank-sbcl.lisp:1.57 slime/swank-sbcl.lisp:1.58
--- slime/swank-sbcl.lisp:1.57 Thu Jan 29 03:37:57 2004
+++ slime/swank-sbcl.lisp Sat Jan 31 04:02:22 2004
@@ -79,6 +79,7 @@
(make-socket-io-stream (accept socket)))
(defimplementation add-input-handler (socket fn)
+ (declare (type function fn))
(sb-sys:add-fd-handler (socket-fd socket)
:input (lambda (fd)
(declare (ignore fd))
@@ -107,6 +108,7 @@
(sb-bsd-sockets:interrupted-error ()))))
(defmethod call-without-interrupts (fn)
+ (declare (type function fn))
(sb-sys:without-interrupts (funcall fn)))
(defmethod getpid ()
@@ -226,6 +228,7 @@
(sb-c::compiler-error-context-original-source-path context)))))
(defimplementation call-with-compilation-hooks (function)
+ (declare (type function function))
(handler-bind ((sb-c:compiler-error #'handle-notification-condition)
(sb-ext:compiler-note #'handle-notification-condition)
(style-warning #'handle-notification-condition)
@@ -235,6 +238,7 @@
(defimplementation compile-file-for-emacs (filename load-p)
(with-compilation-hooks ()
(multiple-value-bind (fasl-file w-p f-p) (compile-file filename)
+ (declare (ignore w-p))
(cond ((and fasl-file (not f-p) load-p)
(load fasl-file))
(t fasl-file)))))
@@ -371,9 +375,11 @@
;;; Debugging
(defvar *sldb-stack-top*)
-(defvar *sldb-restarts*)
+(defvar *sldb-restarts* nil)
+(declaim (type list *sldb-restarts*))
(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (declare (type function debugger-loop-fn))
(let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
(*sldb-restarts* (compute-restarts *swank-debugger-condition*))
(sb-debug:*stack-top-hint* nil)
@@ -497,6 +503,7 @@
(location (sb-di:frame-code-location frame))
(debug-function (sb-di:frame-debug-fun frame))
(debug-variables (sb-di::debug-fun-debug-vars debug-function)))
+ (declare (type (or null simple-vector) debug-variables))
(loop for v across debug-variables
collect (list
:name (to-string (sb-di:debug-var-symbol v))
@@ -519,8 +526,9 @@
(defimplementation eval-in-frame (form index)
(let ((frame (nth-frame index)))
- (funcall (sb-di:preprocess-for-eval form
- (sb-di:frame-code-location frame))
+ (funcall (the function
+ (sb-di:preprocess-for-eval form
+ (sb-di:frame-code-location frame)))
frame)))
(defun sb-debug-catch-tag-p (tag)
@@ -581,6 +589,7 @@
(sb-thread:make-mutex :name name))
(defimplementation call-with-lock-held (lock function)
+ (declare (type function function))
(sb-thread:with-mutex (lock) (funcall function)))
)
Index: slime/swank-backend.lisp
diff -u slime/swank-backend.lisp:1.23 slime/swank-backend.lisp:1.24
--- slime/swank-backend.lisp:1.23 Thu Jan 29 03:37:57 2004
+++ slime/swank-backend.lisp Sat Jan 31 04:02:22 2004
@@ -538,7 +538,8 @@
(definterface call-with-lock-held (lock function)
"Call FUNCTION with LOCK held, queueing if necessary."
- (declare (ignore lock))
+ (declare (ignore lock)
+ (type function function))
(funcall function))
Index: slime/swank-source-path-parser.lisp
diff -u slime/swank-source-path-parser.lisp:1.1 slime/swank-source-path-parser.lisp:1.2
--- slime/swank-source-path-parser.lisp:1.1 Thu Dec 11 23:54:41 2003
+++ slime/swank-source-path-parser.lisp Sat Jan 31 04:02:22 2004
@@ -26,11 +26,12 @@
"Return a macro character function that does the same as FN, but
additionally stores the result together with the stream positions
before and after of calling FN in the hashtable SOURCE-MAP."
+ (declare (type function fn))
(lambda (stream char)
(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]~%" start values end (char-code char))
(unless (null values)
(push (cons start end) (gethash (car values) source-map)))
(values-list values))))
More information about the slime-cvs
mailing list