src/parser/floc-proto.lisp: Restore missing argument.

[sod] / src / utilities.lisp

diff --git a/src/utilities.lisp b/src/utilities.lisp
index 023fc60..6663441 100644 (file)
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -7,7 +7,7 @@
 
 ;;;----- Licensing notice ---------------------------------------------------
 ;;;
-;;; This file is part of the Sensble Object Design, an object system for C.
+;;; This file is part of the Sensible Object Design, an object system for C.
 ;;;
 ;;; SOD is free software; you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by
@@ -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.
 
@@ -825,6 +847,6 @@
           (,classvar (,instance ,class) (,slotvar (eql ',slot)))
         ,@docs ,@decls
         (declare (ignore ,classvar))
-        (setf (slot-value ,instance ',slot) (progn ,@body))))))
+        (setf (slot-value ,instance ',slot) (block ,slot ,@body))))))
 
 ;;;----- That's all, folks --------------------------------------------------