src/: Write dependency-tracking Makefile fragments.

[sod] / src / module-output.lisp

diff --git a/src/module-output.lisp b/src/module-output.lisp
index a0ca42d5423612a11b317b353c27d3dd5b003d13..f9eb3a47b952ac9e3ee01d3ed644f262ee6ed2a4 100644 (file)
--- a/src/module-output.lisp
+++ b/src/module-output.lisp
@@ -65,6 +65,20 @@ (defun guess-output-file (module type)
   (merge-pathnames (make-pathname :type type :case :common)
                   (module-name module)))
 
   (merge-pathnames (make-pathname :type type :case :common)
                   (module-name module)))
 

+(defvar *done-one-off-output* nil
+  "A list of tokens for things which should appear at most once in output.")
+
+(export 'one-off-output)
+(defun one-off-output (token sequencer item-name function)
+  "Arrange to output a thing at most once.
+
+   If there has been no previous call to `one-off-output' with the given
+   TOKEN during this output run, then arrange to call FUNCTION when the item
+   called ITEM-NAME is traversed.  Otherwise do nothing."
+  (unless (member token *done-one-off-output*)
+    (push token *done-one-off-output*)
+    (add-sequencer-item-function sequencer item-name function)))
+

 ;;;--------------------------------------------------------------------------
 ;;; Main output interface.
 
 ;;;--------------------------------------------------------------------------
 ;;; Main output interface.
 


@@ -73,7 +87,9 @@ (defun output-module (module reason stream)
   "Write the MODULE to STREAM, giving the output machinery the REASON.
 
    This is the top-level interface for producing output."
   "Write the MODULE to STREAM, giving the output machinery the REASON.
 
    This is the top-level interface for producing output."

-  (let ((sequencer (make-instance 'sequencer))
+  (let ((*print-right-margin* 77)
+       (*done-one-off-output* nil)
+       (sequencer (make-instance 'sequencer))

        (stream (if (typep stream 'position-aware-output-stream)
                    stream
                    (make-instance 'position-aware-output-stream
        (stream (if (typep stream 'position-aware-output-stream)
                    stream
                    (make-instance 'position-aware-output-stream


@@ -112,7 +128,7 @@ (defmethod hook-output progn ((module module) (reason (eql :h)) sequencer)
     (:prologue
      (:guard :start)
      (:typedefs :start) :typedefs (:typedefs :end)
     (:prologue
      (:guard :start)
      (:typedefs :start) :typedefs (:typedefs :end)

-     (:includes :start) :includes (:includes :end)
+     (:includes :start) :includes :early-decls (:includes :end)

      (:early-user :start) :early-user (:early-user :end)
      (:classes :start) (:classes :end)
      (:user :start) :user (:user :end)
      (:early-user :start) :early-user (:early-user :end)
      (:classes :start) (:classes :end)
      (:user :start) :user (:user :end)


@@ -196,6 +212,7 @@ (defun declare-output-type (reason pathname)
 
    The output file name will be constructed by merging the module's pathname
    with PATHNAME."
 
    The output file name will be constructed by merging the module's pathname
    with PATHNAME."

+  (pushnew reason *output-types*)

   (setf (get reason 'output-type) pathname))
 
 (export 'output-type-pathname)
   (setf (get reason 'output-type) pathname))
 
 (export 'output-type-pathname)


@@ -206,6 +223,75 @@ (defun output-type-pathname (reason)
   (or (get reason 'output-type)
       (error "Unknown output type `~(~A~)'" reason)))
 
   (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)))))
+
+(export 'write-dependency-file)
+(defgeneric write-dependency-file (module reason output-dir)
+  (:documentation
+   "Write a dependency-tracking make(1) fragment.
+
+   Specifically, we've processed a MODULE for a particular REASON (a
+   symbol), and the user has requested that output be written to OUTPUT-DIR
+   (a pathname): determine a suitable output pathname and write a make(1)
+   fragment explaining that the output file we've made depends on all of the
+   files we had to read to load the module."))
+
+(defmethod write-dependency-file ((module module) reason output-dir)
+  (let* ((common-case
+         ;; Bletch.  We want to derive the filetype from the one we're
+         ;; given, but we need to determine the environment's preferred
+         ;; filetype case to do that.  Make a pathname and inspect it to
+         ;; find out how to do this.
+
+         (if (upper-case-p
+                          (char (pathname-type (make-pathname
+                                                :type "TEST"
+                                                :case :common))
+                                0))
+                         #'string-upcase
+                         #'string-downcase))
+
+        (outpath (output-type-pathname reason))
+        (deppath (make-pathname :type (concatenate 'string
+                                                   (pathname-type outpath)
+                                                   (funcall common-case
+                                                            "-DEP"))
+                                :defaults outpath))
+        (outfile (module-output-file module reason output-dir))
+        (depfile (module-output-file module deppath output-dir)))
+
+    (with-open-file (dep depfile
+                    :direction :output
+                    :if-exists :supersede
+                    :if-does-not-exist :create)
+      (format dep "### -*-makefile-*-~%~
+                  ~A:~{ \\~%   ~A~}~%"
+             outfile
+             (cons (module-name module)
+                   (module-files module))))))
+

 (define-clear-the-decks reset-output-types
   "Clear out the registered output types."
   (dolist (reason *output-types*) (remprop reason 'output-type))
 (define-clear-the-decks reset-output-types
   "Clear out the registered output types."
   (dolist (reason *output-types*) (remprop reason 'output-type))