lib/keyword.c (kw_parseempty): Use correct variable scanning `kwval' list.

[sod] / src / module-output.lisp

diff --git a/src/module-output.lisp b/src/module-output.lisp
index f04bdd6f7b1071114d1e1eb5a54e8e0b6d9b78cc..21fcaddbd46d257cc04e2027fd5e803604388bf7 100644 (file)
--- a/src/module-output.lisp
+++ b/src/module-output.lisp
@@ -7,7 +7,7 @@
 
 ;;;----- Licensing notice ---------------------------------------------------
 ;;;
 
 ;;;----- 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
 ;;;
 ;;; SOD is free software; you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by


@@ -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,52 +87,59 @@ (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 stream
                                   :file (stream-pathname stream)))))
        (stream (if (typep stream 'position-aware-output-stream)
                    stream
                    (make-instance 'position-aware-output-stream
                                   :stream stream
                                   :file (stream-pathname stream)))))

-    (hook-output module reason sequencer)
-    (invoke-sequencer-items sequencer stream)))
+    (with-module-environment (module)
+      (hook-output module reason sequencer)
+      (invoke-sequencer-items sequencer stream))))

 
 ;;;--------------------------------------------------------------------------
 ;;; Output implementation.
 
 
 ;;;--------------------------------------------------------------------------
 ;;; 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)))
 
 
   ;; 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))
 
   ;; 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
     (:prologue
      (:guard :start)
      (:typedefs :start) :typedefs (:typedefs :end)
   (sequence-output (stream sequencer)
 
     :constraint
     (:prologue
      (:guard :start)
      (:typedefs :start) :typedefs (:typedefs :end)

-     (:includes :start) :includes (:includes :end)
-     (:classes :start) :classes (:classes :end)
+     (: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)
 
     (:prologue
      (format stream "~
      (:guard :end)
      :epilogue)
 
     (:prologue
      (format stream "~

-/* -*-c-*-
+/* -*- mode: c; indent-tabs-mode: nil -*-

  *
  * Header file generated by SOD for ~A
  */~2%"
  *
  * Header file generated by SOD for ~A
  */~2%"


@@ -154,18 +175,23 @@ (defmethod hook-output progn ((module module) (reason (eql :h)) sequencer)
     ((:includes :end)
      (terpri stream))))
 
     ((: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)
   (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)
      (:classes :start) (:classes :end)

+     (:user :start) :user (:user :end)

      :epilogue)
 
     (:prologue
      (format stream "~
      :epilogue)
 
     (:prologue
      (format stream "~

-/* -*-c-*-
+/* -*- mode: c; indent-tabs-mode: nil -*-

  *
  * Implementation file generated by SOD for ~A
  */~2%"
  *
  * Implementation file generated by SOD for ~A
  */~2%"


@@ -179,4 +205,102 @@ (defmethod hook-output progn ((module module) (reason (eql :c)) sequencer)
     ((:includes :end)
      (terpri stream))))
 
     ((:includes :end)
      (terpri stream))))
 

+;;;--------------------------------------------------------------------------
+;;; Output types.
+
+(defvar *output-types* nil
+  "List of known output types.")
+
+(export 'declare-output-type)
+(defun declare-output-type (reason pathname)
+  "Record that REASON is a valid user-level output type.
+
+   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)
+(defun output-type-pathname (reason)
+  "Return the PATHNAME template for the output type REASON.
+
+   Report an error if there is no such output type."
+  (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))
+  (setf *output-types* nil)
+  (declare-output-type :c (make-pathname :type "C" :case :common))
+  (declare-output-type :h (make-pathname :type "H" :case :common)))
+

 ;;;----- That's all, folks --------------------------------------------------
 ;;;----- That's all, folks --------------------------------------------------