[slime-cvs] CVS update: slime/swank-allegro.lisp
Helmut Eller
heller at common-lisp.net
Sun Dec 5 14:52:41 UTC 2004
Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv5014
Modified Files:
swank-allegro.lisp
Log Message:
(handle-compiler-warning): Handle undefined-functions warnings by
looking the fromat-arguments of the condition.
(compiler-undefined-functions-called-warning-p, location-for-warning)
(handle-undefined-functions-warning): New functions.
Date: Sun Dec 5 15:52:39 2004
Author: heller
Index: slime/swank-allegro.lisp
diff -u slime/swank-allegro.lisp:1.65 slime/swank-allegro.lisp:1.66
--- slime/swank-allegro.lisp:1.65 Mon Nov 29 18:35:03 2004
+++ slime/swank-allegro.lisp Sun Dec 5 15:52:39 2004
@@ -51,10 +51,10 @@
(defimplementation close-socket (socket)
(close socket))
-(defimplementation accept-connection (socket
- &key (external-format :iso-latin-1-unix))
- (let ((s (socket:accept-connection socket :wait t)))
- (set-external-format s external-format)
+(defimplementation accept-connection (socket &key external-format)
+ (let ((ef (or external-format :iso-latin-1-unix))
+ (s (socket:accept-connection socket :wait t)))
+ (set-external-format s ef)
s))
(defun set-external-format (stream external-format)
@@ -89,12 +89,13 @@
"allegro")
(defimplementation set-default-directory (directory)
- (excl:chdir directory)
- (namestring (setf *default-pathname-defaults*
- (truename (merge-pathnames directory)))))
+ (let ((dir (namestring (setf *default-pathname-defaults*
+ (truename (merge-pathnames directory))))))
+ (excl:chdir dir)
+ dir))
(defimplementation default-directory ()
- (excl:chdir))
+ (namestring (excl:current-directory)))
;;;; Misc
@@ -213,37 +214,57 @@
(defvar *buffer-string*)
(defvar *compile-filename* nil)
-(defun compiler-note-p (x)
- (member (type-of x) '(excl::compiler-note compiler::compiler-note)))
+(defun compiler-note-p (object)
+ (member (type-of object) '(excl::compiler-note compiler::compiler-note)))
+
+(defun compiler-undefined-functions-called-warning-p (object)
+ #-allegro-v5.0
+ (typep object 'excl:compiler-undefined-functions-called-warning))
(deftype compiler-note ()
`(satisfies compiler-note-p))
+(defun signal-compiler-condition (&rest args)
+ (signal (apply #'make-condition 'compiler-condition args)))
+
(defun handle-compiler-warning (condition)
+ (declare (optimize (debug 3) (speed 0) (space 0)))
+ (cond ((and (not *buffer-name*)
+ (compiler-undefined-functions-called-warning-p condition))
+ (handle-undefined-functions-warning condition))
+ (t
+ (signal-compiler-condition
+ :original-condition condition
+ :severity (etypecase condition
+ (warning :warning)
+ (compiler-note :note))
+ :message (format nil "~A" condition)
+ :location (location-for-warning condition)))))
+
+(defun location-for-warning (condition)
(let ((loc (getf (slot-value condition 'excl::plist) :loc)))
- (signal
- (make-condition
- 'compiler-condition
- :original-condition condition
- :severity (etypecase condition
- (warning :warning)
- (compiler-note :note))
- :message (format nil "~A" condition)
- :location (cond (*buffer-name*
- (make-location
- (list :buffer *buffer-name*)
- (list :position *buffer-start-position*)))
- (loc
- (destructuring-bind (file . pos) loc
- (make-location
- (list :file (namestring (truename file)))
- (list :position (1+ pos)))))
- (*compile-filename*
- (make-location
- (list :file *compile-filename*)
- (list :position 1)))
- (t
- (list :error "No error location available.")))))))
+ (cond (*buffer-name*
+ (make-location
+ (list :buffer *buffer-name*)
+ (list :position *buffer-start-position*)))
+ (loc
+ (destructuring-bind (file . pos) loc
+ (make-location
+ (list :file (namestring (truename file)))
+ (list :position (1+ pos)))))
+ (t
+ (list :error "No error location available.")))))
+
+(defun handle-undefined-functions-warning (condition)
+ (let ((fargs (slot-value condition 'excl::format-arguments)))
+ (dolist (farg (car fargs))
+ (destructuring-bind (fname (pos file)) farg
+ (signal-compiler-condition
+ :original-condition condition
+ :severity :warning
+ :message (format nil "Undefined function referenced: ~S" fname)
+ :location (make-location (list :file file)
+ (list :position (1+ pos))))))))
(defimplementation call-with-compilation-hooks (function)
(handler-bind ((warning #'handle-compiler-warning)
More information about the slime-cvs
mailing list