From: Mark Wooding <mdw@distorted.org.uk>
Date: Thu, 8 Aug 2019 11:44:55 +0000 (+0100)
Subject: src/module-output.lisp: Introduce `module-output-file'.
X-Git-Url: https://git.distorted.org.uk/~mdw/sod/commitdiff_plain/b0e21f8370fb60321f178572e2b90dfc4e2eb5b6

src/module-output.lisp: Introduce `module-output-file'.

This is the code from `frontend.lisp', which has been modified to use
it.
---

diff --git a/doc/SYMBOLS b/doc/SYMBOLS
index 33d4b95..e533a38 100644
--- a/doc/SYMBOLS
+++ b/doc/SYMBOLS
@@ -582,6 +582,7 @@ module-output.lisp
   banner                                        function
   declare-output-type                           function
   guard-name                                    function
+  module-output-file                            generic
   one-off-output                                function
   output-module                                 function
   output-type-pathname                          function
@@ -1363,6 +1364,9 @@ module-items
   t module
 module-name
   module
+module-output-file
+  module cl:pathname t
+  module cl:symbol t
 module-pset
   module
 module-state
diff --git a/doc/output.tex b/doc/output.tex
index 2284703..0423178 100644
--- a/doc/output.tex
+++ b/doc/output.tex
@@ -176,6 +176,23 @@ until the third.  So the final processing order is
 
 \subsection{Producing output}
 
+\begin{describe}{gf}
+    {module-output-file @<module> @<output-type> @<output-dir>
+      @> @<pathname>}
+  \begin{describe*}
+      {\dhead{meth}{module,symbol}
+          {module-output-file \=(@<module> module)              \\
+                              \>(@<output-type> symbol)         \\
+                              \>@<output-dir>
+           \nlret @<pathname>}
+       \dhead{meth}{module,pathname}
+          {module-output-file \=(@<module> module)              \\
+                              \>(@<output-type> pathname)       \\
+                              \>@<output-dir>
+           \nlret @<pathname>}}
+  \end{describe*}
+\end{describe}
+
 \begin{describe}{fun}{output-module @<module> @<reason> @<stream>}
 \end{describe}
 
diff --git a/src/frontend.lisp b/src/frontend.lisp
index 2d20fbc..1d09382 100644
--- a/src/frontend.lisp
+++ b/src/frontend.lisp
@@ -171,37 +171,26 @@
 
 		 ;; Arrange to be able to recover from errors.
 		 (restart-case
-
-		     ;; Collect information for constructing the output
-		     ;; filenames here.  In particular,
-		     ;; `output-type-pathname' will sanity-check the
-		     ;; output type for us, which is useful even if
-		     ;; we're writing to stdout.
-		     (let ((outpath (output-type-pathname reason))
-			   (modpath (module-name module)))
-
-		       (if stdoutp
-
-			   ;; If we're writing to stdout then just do
-			   ;; that.
-			   (output-module module reason
-					  *standard-output*)
-
-			   ;; Otherwise we have to construct an output
-			   ;; filename the hard way.
-			   (with-open-file
-			       (stream
-				(reduce #'merge-pathnames
-					(list output-path
-					      outpath
-					      (make-pathname
-					       :directory nil
-					       :defaults modpath))
-					:from-end t)
-				:direction :output
-				:if-exists :supersede
-				:if-does-not-exist :create)
-			     (output-module module reason stream))))
+		     (cond
+
+		       (stdoutp
+			;; If we're writing to stdout then use
+			;; `output-type-pathname' to check the output type
+			;; for us.
+
+			(output-type-pathname reason)
+			(output-module module reason *standard-output*))
+
+		       (t
+			;; Otherwise we have to construct an output
+			;; filename the hard way.
+			(with-open-file
+			    (stream
+			     (module-output-file module reason output-path)
+			     :direction :output
+			     :if-exists :supersede
+			     :if-does-not-exist :create)
+			  (output-module module reason stream))))
 
 		   ;; Error recovery.
 		   (continue ()
diff --git a/src/module-output.lisp b/src/module-output.lisp
index c3c61d6..fe04f2b 100644
--- a/src/module-output.lisp
+++ b/src/module-output.lisp
@@ -222,6 +222,30 @@
   (or (get reason 'output-type)
       (error "Unknown output type `~(~A~)'" reason)))
 
+(export 'module-output-file)
+(defgeneric module-output-file (module output-type output-dir)
+  (:documentation
+   "Return a pathname to which the output should be written.
+
+   Specifically, if we're processing a MODULE for a particular OUTPUT-TYPE,
+   and the user has requested that output be written to OUTPUT-DIR (a
+   pathname), then return the pathname to which the output should be
+   written.
+
+   The OUTPUT-TYPE can be an `reason' symbol or a raw pathname.  (Or
+   something else, of course.)"))
+
+(defmethod module-output-file
+    ((module module) (output-type symbol) output-dir)
+  (module-output-file module (output-type-pathname output-type) output-dir))
+
+(defmethod module-output-file
+    ((module module) (output-type pathname) output-dir)
+  (reduce #'merge-pathnames
+	  (list output-dir output-type
+		(make-pathname :directory nil
+			       :defaults (module-name module)))))
+
 (define-clear-the-decks reset-output-types
   "Clear out the registered output types."
   (dolist (reason *output-types*) (remprop reason 'output-type))