From 08b6e064ab3b18bbc5a9af47418c02f0e7ebc52d Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Tue, 5 Jan 2016 16:31:09 +0000 Subject: [PATCH] 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. --- doc/SYMBOLS | 1 + doc/misc.tex | 3 +++ src/module-impl.lisp | 46 ++++++++++++++++++++++++++-------------------- src/utilities.lisp | 22 ++++++++++++++++++++++ 4 files changed, 52 insertions(+), 20 deletions(-) diff --git a/doc/SYMBOLS b/doc/SYMBOLS index 5b66e2a..3243197 100644 --- 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 --- a/doc/misc.tex +++ b/doc/misc.tex @@ -179,6 +179,9 @@ These symbols are defined in the @|sod-utilities| package. @
^*} \end{describe} +\begin{describe}{fun}{print-ugly-stuff @ @ @> @^*} +\end{describe} + \begin{describe}{mac} {dosequence (@ @ @[[ :start @ @! :end @ @! diff --git a/src/module-impl.lisp b/src/module-impl.lisp index 873e091..908a017 100644 --- 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) ""))))) - (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) + ""))))) + (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 --- 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. -- 2.11.0