[slime-devel] Removing some allegro warnings

[Gary King]

The patch below wraps #'excl:without-redefinition-warnings around a  
number of forms that cause allegro to complain... Any comments?

Index: swank-allegro.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-allegro.lisp,v
retrieving revision 1.89
diff -u -w -r1.89 swank-allegro.lisp
--- swank-allegro.lisp	28 Jul 2006 15:04:53 -0000	1.89
+++ swank-allegro.lisp	7 Aug 2006 14:32:44 -0000
@@ -28,8 +28,9 @@
;;;; TCP Server
+(excl:without-redefinition-warnings
(defimplementation preferred-communication-style ()
-  :spawn)
+    :spawn))
(defimplementation create-socket (host port)
    (socket:make-socket :connect :passive :local-port port
@@ -64,40 +65,48 @@
    (setf (stream-external-format stream)
          (find-external-format external-format)))
+(excl:without-redefinition-warnings
(defimplementation format-sldb-condition (c)
-  (princ-to-string c))
+    (princ-to-string c)))
+(excl:without-redefinition-warnings
(defimplementation condition-references (c)
    (declare (ignore c))
-  '())
+    '()))
+(excl:without-redefinition-warnings
(defimplementation call-with-syntax-hooks (fn)
-  (funcall fn))
+    (funcall fn)))
;;;; Unix signals
+(excl:without-redefinition-warnings
(defimplementation call-without-interrupts (fn)
-  (excl:without-interrupts (funcall fn)))
+    (excl:without-interrupts (funcall fn))))
(defimplementation getpid ()
    (excl::getpid))
+(excl:without-redefinition-warnings
(defimplementation lisp-implementation-type-name ()
-  "allegro")
+    "allegro"))
+(excl:without-redefinition-warnings
(defimplementation set-default-directory (directory)
    (let* ((dir (namestring (truename (merge-pathnames directory)))))
      (setf *default-pathname-defaults* (pathname (excl:chdir dir)))
-    dir))
+      dir)))
+(excl:without-redefinition-warnings
(defimplementation default-directory ()
-  (namestring (excl:current-directory)))
+    (namestring (excl:current-directory))))
;;;; Misc
+(excl:without-redefinition-warnings
(defimplementation arglist (symbol)
    (handler-case (excl:arglist symbol)
-    (simple-error () :not-available)))
+      (simple-error () :not-available))))
(defimplementation macroexpand-all (form)
    (excl::walk form))
@@ -129,8 +138,9 @@
      (:class
       (describe (find-class symbol)))))
+(excl:without-redefinition-warnings
(defimplementation make-stream-interactive (stream)
-  (setf (interactive-stream-p stream) t))
+    (setf (interactive-stream-p stream) t)))
;;;; Debugger
@@ -578,14 +588,15 @@
               (when doc
                 `("Documentation:" (:newline) ,doc))))))
-(defmethod inspect-for-emacs ((o t) (inspector acl-inspector))
-  inspector
-  (values "A value." (allegro-inspect o)))
-
+#+(or)
(defmethod inspect-for-emacs ((o function) (inspector acl-inspector))
    inspector
    (values "A function." (allegro-inspect o)))
+(defmethod inspect-for-emacs ((o t) (inspector acl-inspector))
+  inspector
+  (values "A value." (allegro-inspect o)))
+
(defmethod inspect-for-emacs ((o standard-object) (inspector acl- 
inspector))
    inspector
    (values (format nil "~A is a standard-object." o) (allegro- 
inspect o)))
@@ -613,8 +624,9 @@
;;;; Multithreading
+(excl:without-redefinition-warnings
(defimplementation initialize-multiprocessing ()
-  (mp:start-scheduler))
+    (mp:start-scheduler)))
(defimplementation spawn (fn &key name)
    (mp:process-run-function name fn))
@@ -632,21 +644,26 @@
    (find id mp:*all-processes*
          :key (lambda (p) (getf (mp:process-property-list p) 'id))))
+(excl:without-redefinition-warnings
(defimplementation thread-name (thread)
-  (mp:process-name thread))
+    (mp:process-name thread)))
+(excl:without-redefinition-warnings
(defimplementation thread-status (thread)
    (format nil "~A ~D" (mp:process-whostate thread)
-          (mp:process-priority thread)))
+            (mp:process-priority thread))))
+(excl:without-redefinition-warnings
(defimplementation make-lock (&key name)
-  (mp:make-process-lock :name name))
+    (mp:make-process-lock :name name)))
+(excl:without-redefinition-warnings
(defimplementation call-with-lock-held (lock function)
-  (mp:with-process-lock (lock) (funcall function)))
+    (mp:with-process-lock (lock) (funcall function))))
+(excl:without-redefinition-warnings
(defimplementation current-thread ()
-  mp:*current-process*)
+    mp:*current-process*))
(defimplementation all-threads ()
    (copy-list mp:*all-processes*))
@@ -654,8 +671,9 @@
(defimplementation interrupt-thread (thread fn)
    (mp:process-interrupt thread fn))
+(excl:without-redefinition-warnings
(defimplementation kill-thread (thread)
-  (mp:process-kill thread))
+    (mp:process-kill thread)))
(defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
@@ -751,8 +769,10 @@
;;;; Weak hashtables
+(excl:without-redefinition-warnings
(defimplementation make-weak-key-hash-table (&rest args)
-  (apply #'make-hash-table :weak-keys t args))
+    (apply #'make-hash-table :weak-keys t args)))
+(excl:without-redefinition-warnings
(defimplementation make-weak-value-hash-table (&rest args)
-  (apply #'make-hash-table :values :weak args))
+    (apply #'make-hash-table :values :weak args)))

thanks,
-- 
Gary Warren King
metabang.com [http://www.metabang.com/]
(413) 885 9127 * (206) 338-4052 [Fax]
gwking on #lisp (occasionally)