[slime-devel] Allegro/CMUCL patch for presentations.lisp

[Matthias Koeppe]

I am sending another patch related to presentations.  It contains
improvements specific to CMUCL and Allegro CL.

Would someone like to handle this (and the previous) patch?

Cheers,
Matthias

2005-06-28  Matthias Koeppe  <mkoeppe at mail.math.uni-magdeburg.de>

	* present.lisp (slime-stream-p) [cmu]: Handle indenting-streams
	whose base streams are SLIME streams.  These occur in logical
	blocks in pretty-printing.
	[allegro]: Handle xp-simple-streams whose base streams are SLIME
	streams.

	* present.lisp (presenting-object-1) [allegro]: Unconfuse the
	pretty printer.

	* present.lisp [allegro]: Add fwrappers for printing pathnames and
	unreadable objects as presentations.

--- present.lisp.~1.4.~	2005-05-24 04:42:01.000000000 +0200
+++ present.lisp	2005-06-28 15:04:16.680297000 +0200
@@ -82,8 +82,13 @@
 					;(slime-stream-p (ccl::xp-base-stream (slot-value stream 'ccl::xp-structure)))
 			 (slime-stream-p (ccl::%svref (slot-value stream 'ccl::xp-structure) 1)))
 		    #+cmu
-		    (and (typep stream 'pretty-print::pretty-stream)
-			 (slime-stream-p (pretty-print::pretty-stream-target  stream)))
+		    (or (and (typep stream 'lisp::indenting-stream)
+			     (slime-stream-p (lisp::indenting-stream-stream stream)))
+			(and (typep stream 'pretty-print::pretty-stream)
+			     (slime-stream-p (pretty-print::pretty-stream-target  stream))))
+		    #+allegro
+		    (and (typep stream 'excl:xp-simple-stream)
+			 (slime-stream-p (excl::stream-output-handle stream)))
 		    (loop for connection in *connections*
 			  thereis (or (eq stream (connection.dedicated-output connection))
 				      (eq stream (connection.socket-io connection))
@@ -94,20 +99,39 @@
   (declare (ignore stream))
   *enable-presenting-readable-objects*)
 
+;; If we are printing to an XP (pretty printing) stream, printing the
+;; escape sequences directly would mess up the layout because column
+;; counting is disturbed.  Use "annotations" instead.
+#+allegro
+(defmacro annotating ((base-stream stream) &body body)
+  `(if (typep ,stream 'excl:xp-simple-stream)
+       (excl::schedule-annotation ,stream (lambda (.ignore. ,base-stream .ignore2.)
+					    (declare (ignore .ignore. .ignore2.))
+					    , at body)
+				  nil)
+       (let ((,base-stream ,stream))
+	 , at body)))
+#-allegro
+(defmacro annotating ((base-stream stream) &body body)
+  `(let ((,base-stream ,stream))
+     , at body))
+
 (defun presenting-object-1 (object stream continue)
   "Uses the bridge mechanism with two messages >id and <id. The first one
 says that I am starting to print an object with this id. The second says I am finished"
   (if (and *record-repl-results* *can-print-presentation*
 	   (slime-stream-p stream))
       (let ((pid (swank::save-presented-object object)))
-	(write-string "<" stream)
-	(prin1 pid stream)
-	(write-string "" stream)
+	(annotating (base-stream stream)
+	  (write-string "<" base-stream)
+	  (prin1 pid base-stream)
+	  (write-string "" base-stream))
 	(multiple-value-prog1
 	    (funcall continue)
-	  (write-string ">" stream)
-	  (prin1 pid stream)
-	  (write-string "" stream)))
+	  (annotating (base-stream stream)
+	    (write-string ">" base-stream)
+	    (prin1 pid base-stream)
+	    (write-string "" base-stream))))
       (funcall continue)))
 
 ;; enable presentations inside listener eval, when compiling, when evaluating
@@ -371,3 +395,15 @@
   (fwrappers::fwrap 'lisp::%print-pathname  #'presenting-pathname-wrapper)
   (fwrappers::fwrap 'lisp::%print-unreadable-object  #'presenting-unreadable-wrapper)
   )
+
+#+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))


-- 
Matthias Koeppe -- http://www.math.uni-magdeburg.de/~mkoeppe