X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/e674612eb9e1a1dde2522260163a93a13ed44a0f..00d59354c311fb28730b7c9b117b0d91aac092cc:/src/module-output.lisp

diff --git a/src/module-output.lisp b/src/module-output.lisp
index 1bfb34f..d09dfd8 100644
--- a/src/module-output.lisp
+++ b/src/module-output.lisp
@@ -87,7 +87,8 @@
   "Write the MODULE to STREAM, giving the output machinery the REASON.
 
    This is the top-level interface for producing output."
-  (let ((*done-one-off-output* nil)
+  (let ((*print-right-margin* 77)
+	(*done-one-off-output* nil)
 	(sequencer (make-instance 'sequencer))
 	(stream (if (typep stream 'position-aware-output-stream)
 		    stream
@@ -101,26 +102,27 @@
 ;;;--------------------------------------------------------------------------
 ;;; Output implementation.
 
-(defmethod hook-output progn ((module module) reason sequencer)
+(defmethod hook-output :after ((module module) reason sequencer)
 
   ;; Ask the module's items to sequence themselves.
   (dolist (item (module-items module))
     (hook-output item reason sequencer)))
 
-(defmethod hook-output progn ((frag code-fragment-item) reason sequencer)
+(defmethod hook-output ((frag code-fragment-item) reason sequencer)
 
   ;; Output fragments when their reasons are called up.
   (when (eq reason (code-fragment-reason frag))
     (dolist (constraint (code-fragment-constraints frag))
       (add-sequencer-constraint sequencer constraint))
-    (add-sequencer-item-function sequencer (code-fragment-name frag)
-				 (lambda (stream)
-				   (write (code-fragment frag)
-					  :stream stream
-					  :pretty nil
-					  :escape nil)))))
-
-(defmethod hook-output progn ((module module) (reason (eql :h)) sequencer)
+    (awhen (code-fragment-name frag)
+      (add-sequencer-item-function sequencer it
+				   (lambda (stream)
+				     (write (code-fragment frag)
+					    :stream stream
+					    :pretty nil
+					    :escape nil))))))
+
+(defmethod hook-output ((module module) (reason (eql :h)) sequencer)
   (sequence-output (stream sequencer)
 
     :constraint
@@ -130,6 +132,7 @@
      (:includes :start) :includes :early-decls (:includes :end)
      (:early-user :start) :early-user (:early-user :end)
      (:classes :start) (:classes :end)
+     (:static-instances :start) :static-instances (:static-instances :end)
      (:user :start) :user (:user :end)
      (:guard :end)
      :epilogue)
@@ -172,13 +175,16 @@
     ((:includes :end)
      (terpri stream))))
 
-(defmethod hook-output progn ((module module) (reason (eql :c)) sequencer)
+(defmethod hook-output ((module module) (reason (eql :c)) sequencer)
   (sequence-output (stream sequencer)
 
     :constraint
     (:prologue
      (:includes :start) :includes (:includes :end)
      (:early-user :start) :early-user (:early-user :end)
+     (:static-instances :start)
+     (:static-instances :decls) (:static-instances :gap)
+     (:static-instances :end)
      (:classes :start) (:classes :end)
      (:user :start) :user (:user :end)
      :epilogue)
@@ -211,6 +217,7 @@
 
    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)
@@ -221,6 +228,75 @@
   (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))