[slime-cvs] CVS update: slime/present.lisp

[Matthias Koeppe]

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

Modified Files:
	present.lisp 
Log Message:
[sbcl, allegro]: Add printer hooks for unreadable objects and
pathnames.

Date: Thu Aug  4 21:39:59 2005
Author: mkoeppe

Index: slime/present.lisp
diff -u slime/present.lisp:1.5 slime/present.lisp:1.6
--- slime/present.lisp:1.5	Thu Aug  4 21:36:27 2005
+++ slime/present.lisp	Thu Aug  4 21:39:59 2005
@@ -294,3 +294,29 @@
   (fwrappers::fwrap 'lisp::%print-pathname  #'presenting-pathname-wrapper)
   (fwrappers::fwrap 'lisp::%print-unreadable-object  #'presenting-unreadable-wrapper)
   )
+
+#+sbcl
+(progn 
+  (defvar *saved-%print-unreadable-object*
+    (fdefinition 'sb-impl::%print-unreadable-object))
+  (sb-ext:without-package-locks 
+    (setf (fdefinition 'sb-impl::%print-unreadable-object)
+	  (lambda (object stream type identity body)
+	    (presenting-object object stream
+	      (funcall *saved-%print-unreadable-object* 
+		       object stream type identity body))))
+    (defmethod print-object :around ((object pathname) stream)
+      (presenting-object object stream
+	(call-next-method)))))
+
+#+allegro
+(progn
+  (excl:def-fwrapper presenting-unreadable-wrapper (object stream type identity continuation) 
+    (swank::presenting-object object stream (excl:call-next-fwrapper)))
+  (excl:def-fwrapper presenting-pathname-wrapper (pathname stream depth)
+    (presenting-object-if (can-present-readable-objects stream) pathname stream
+      (excl:call-next-fwrapper)))
+  (excl:fwrap 'excl::print-unreadable-object-1 
+	      'print-unreadable-present 'presenting-unreadable-wrapper)
+  (excl:fwrap 'excl::pathname-printer 
+	      'print-pathname-present 'presenting-pathname-wrapper))