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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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))