src/{module-impl,utilities}.lisp: Make `#line' work when pretty-printing.

The `pprint-logical-block' macro interposes a `pretty-printing stream'
between its body and the underlying stream.  This makes using fancy
functionality of the underlying stream (e.g., having it keep track of
the current cursor position) rather tricky.

It would (just about) be possible to introduce a wrapper around
`pprint-logical-block' which keeps track of the mapping between
pretty-printing and plain streams; but that requires that the macro is
actually used everywhere, which is difficult because pretty-printing can
also be initiated using the `format' `~<...~:>' command.

So instead I introduce a system-specific hack `print-ugly-stuff' which
knows how to extract and expose the underlying stream to its caller, and
synchronize things so that nothing gets lost (on SBCL and CMUCL, at
least; on others, it just passes back the pretty-printing stream).  The
function `output-c-excursion' now uses this to do its thing.

diff --git a/doc/SYMBOLS b/doc/SYMBOLS
index 5b66e2a..3243197 100644 (file)
--- a/doc/SYMBOLS
+++ b/doc/SYMBOLS
@@ -2006,6 +2006,7 @@ utilities.lisp
   sb-mop:method-specializers                    generic
   once-only                                     macro
   parse-body                                    function
+  print-ugly-stuff                              function
   ref                                           function setf
   symbolicate                                   function
   update-position                               function

diff --git a/doc/misc.tex b/doc/misc.tex
index abc15eb..8c8b9c1 100644 (file)
--- a/doc/misc.tex
+++ b/doc/misc.tex
@@ -179,6 +179,9 @@ These symbols are defined in the @|sod-utilities| package.
       @<form>^*}
 \end{describe}
 
+\begin{describe}{fun}{print-ugly-stuff @<stream> @<func> @> @<value>^*}
+\end{describe}
+
 \begin{describe}{mac}
     {dosequence (@<var> @<sequence>
                  @[[ :start @<start> @! :end @<end> @!

diff --git a/src/module-impl.lisp b/src/module-impl.lisp
index 873e091..908a017 100644 (file)
--- a/src/module-impl.lisp
+++ b/src/module-impl.lisp
@@ -154,29 +154,35 @@
    A C fragment is aware of its original location, and will bear proper #line
    markers when written out."))
 
-(defun output-c-excursion (stream location thunk)
-  "Invoke THUNK surrounding it by writing #line markers to STREAM.
+(defun output-c-excursion (stream location func)
+  "Invoke FUNC surrounding it by writing #line markers to STREAM.
 
    The first marker describes LOCATION; the second refers to the actual
    output position in STREAM.  If LOCATION doesn't provide a line number then
    no markers are output after all.  If the output stream isn't
-   position-aware then no final marker is output."
-
-  (let* ((location (file-location location))
-        (line (file-location-line location))
-        (filename (file-location-filename location)))
-    (cond (line
-          (when (typep stream 'position-aware-stream)
-            (format stream "~&#line ~D~@[ ~S~]~%" line filename))
-          (funcall thunk)
-          (when (typep stream 'position-aware-stream)
-            (fresh-line stream)
-            (format stream "#line ~D ~S~%"
-                    (1+ (position-aware-stream-line stream))
-                    (let ((path (stream-pathname stream)))
-                      (if path (namestring path) "<sod-output>")))))
-         (t
-          (funcall thunk)))))
+   position-aware then no final marker is output.
+
+   FUNC is passed the output stream as an argument.  Complicated games may be
+   played with interposed streams.  Try not to worry about it."
+
+  (flet ((doit (stream)
+          (let* ((location (file-location location))
+                 (line (file-location-line location))
+                 (filename (file-location-filename location)))
+            (cond (line
+                   (when (typep stream 'position-aware-stream)
+                     (format stream "~&#line ~D~@[ ~S~]~%" line filename))
+                   (funcall func stream)
+                   (when (typep stream 'position-aware-stream)
+                     (fresh-line stream)
+                     (format stream "#line ~D ~S~%"
+                             (1+ (position-aware-stream-line stream))
+                             (let ((path (stream-pathname stream)))
+                               (if path (namestring path)
+                                   "<sod-output>")))))
+                  (t
+                   (funcall func stream))))))
+    (print-ugly-stuff stream #'doit)))
 
 (defmethod print-object ((fragment c-fragment) stream)
   (let ((text (c-fragment-text fragment))
@@ -191,7 +197,7 @@
                 (prin1 (subseq text 0 37) stream)
                 (write-string "..." stream))))
        (output-c-excursion stream location
-                           (lambda () (write-string text stream))))))
+                           (lambda (stream) (write-string text stream))))))
 
 (defmethod make-load-form ((fragment c-fragment) &optional environment)
   (make-load-form-saving-slots fragment :environment environment))

diff --git a/src/utilities.lisp b/src/utilities.lisp
index 17260f4..6663441 100644 (file)
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -714,6 +714,28 @@
             (,print))
           (,print)))))
 
+(export 'print-ugly-stuff)
+(defun print-ugly-stuff (stream func)
+  "Print not-pretty things to the stream underlying STREAM.
+
+   The Lisp pretty-printing machinery, notably `pprint-logical-block', may
+   interpose additional streams between its body and the original target
+   stream.  This makes it difficult to make use of the underlying stream's
+   special features, whatever they might be."
+
+  ;; This is unpleasant.  Hacky hacky.
+  #.(or #+sbcl '(if (typep stream 'sb-pretty:pretty-stream)
+                 (let ((target (sb-pretty::pretty-stream-target stream)))
+                   (pprint-newline :mandatory stream)
+                   (funcall func target))
+                 (funcall func stream))
+       #+cmu '(if (typep stream 'pp:pretty-stream)
+                 (let ((target (pp::pretty-stream-target stream)))
+                   (pprint-newline :mandatory stream)
+                   (funcall func target))
+                 (funcall func stream))
+       '(funcall func stream)))
+
 ;;;--------------------------------------------------------------------------
 ;;; Iteration macros.