mdw@git.distorted.org.uk Git - sod/blob - src/module-output.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Output for modules
   4 ;;;
   5 ;;; (c) 2013 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Sensible Object Design, an object system for C.
  11 ;;;
  12 ;;; SOD is free software; you can redistribute it and/or modify
  13 ;;; it under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 2 of the License, or
  15 ;;; (at your option) any later version.
  16 ;;;
  17 ;;; SOD is distributed in the hope that it will be useful,
  18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with SOD; if not, write to the Free Software Foundation,
  24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  25
  26 (cl:in-package #:sod)
  27
  28 ;;;--------------------------------------------------------------------------
  29 ;;; Utilities.
  30
  31 (export 'banner)
  32 (defun banner (title output &key (blank-line-p t))
  33   "Write a banner to the OUTPUT stream, starting a new section called TITLE.
  34
  35    If BLANK-LINE-P is false, then leave a blank line after the banner.  (This
  36    is useful for a final banner at the end of a file.)"
  37   (format output "~&/*----- ~A ~A*/~%"
  38           title
  39           (make-string (- 77 2 5 1 (length title) 1 2)
  40                        :initial-element #\-))
  41   (when blank-line-p
  42     (terpri output)))
  43
  44 (export 'guard-name)
  45 (defun guard-name (filename)
  46   "Return a sensible inclusion guard name for FILENAME."
  47   (with-output-to-string (guard)
  48     (let* ((pathname (make-pathname :name (pathname-name filename)
  49                                     :type (pathname-type filename)))
  50            (name (namestring pathname))
  51            (uscore t))
  52       (dotimes (i (length name))
  53         (let ((ch (char name i)))
  54           (cond ((alphanumericp ch)
  55                  (write-char (char-upcase ch) guard)
  56                  (setf uscore nil))
  57                 ((not uscore)
  58                  (write-char #\_ guard)
  59                  (setf uscore t))))))))
  60
  61 (defun guess-output-file (module type)
  62   "Guess the filename to use for a file TYPE, generated from MODULE.
  63
  64    Here, TYPE is a filetype string.  The result is returned as a pathname."
  65   (merge-pathnames (make-pathname :type type :case :common)
  66                    (module-name module)))
  67
  68 (defvar *done-one-off-output* nil
  69   "A list of tokens for things which should appear at most once in output.")
  70
  71 (export 'one-off-output)
  72 (defun one-off-output (token sequencer item-name function)
  73   "Arrange to output a thing at most once.
  74
  75    If there has been no previous call to `one-off-output' with the given
  76    TOKEN during this output run, then arrange to call FUNCTION when the item
  77    called ITEM-NAME is traversed.  Otherwise do nothing."
  78   (unless (member token *done-one-off-output*)
  79     (push token *done-one-off-output*)
  80     (add-sequencer-item-function sequencer item-name function)))
  81
  82 ;;;--------------------------------------------------------------------------
  83 ;;; Main output interface.
  84
  85 (export 'output-module)
  86 (defun output-module (module reason stream)
  87   "Write the MODULE to STREAM, giving the output machinery the REASON.
  88
  89    This is the top-level interface for producing output."
  90   (let ((*print-right-margin* 77)
  91         (*done-one-off-output* nil)
  92         (sequencer (make-instance 'sequencer))
  93         (stream (if (typep stream 'position-aware-output-stream)
  94                     stream
  95                     (make-instance 'position-aware-output-stream
  96                                    :stream stream
  97                                    :file (stream-pathname stream)))))
  98     (with-module-environment (module)
  99       (hook-output module reason sequencer)
 100       (invoke-sequencer-items sequencer stream))))
 101
 102 ;;;--------------------------------------------------------------------------
 103 ;;; Output implementation.
 104
 105 (defmethod hook-output :after ((module module) reason sequencer)
 106
 107   ;; Ask the module's items to sequence themselves.
 108   (dolist (item (module-items module))
 109     (hook-output item reason sequencer)))
 110
 111 (defmethod hook-output ((frag code-fragment-item) reason sequencer)
 112
 113   ;; Output fragments when their reasons are called up.
 114   (when (eq reason (code-fragment-reason frag))
 115     (dolist (constraint (code-fragment-constraints frag))
 116       (add-sequencer-constraint sequencer constraint))
 117     (awhen (code-fragment-name frag)
 118       (add-sequencer-item-function sequencer it
 119                                    (lambda (stream)
 120                                      (write (code-fragment frag)
 121                                             :stream stream
 122                                             :pretty nil
 123                                             :escape nil))))))
 124
 125 (defmethod hook-output ((module module) (reason (eql :h)) sequencer)
 126   (sequence-output (stream sequencer)
 127
 128     :constraint
 129     (:prologue
 130      (:guard :start)
 131      (:typedefs :start) :typedefs (:typedefs :end)
 132      (:includes :start) :includes :early-decls (:includes :end)
 133      (:early-user :start) :early-user (:early-user :end)
 134      (:classes :start) (:classes :end)
 135      (:static-instances :start) :static-instances (:static-instances :end)
 136      (:user :start) :user (:user :end)
 137      (:guard :end)
 138      :epilogue)
 139
 140     (:prologue
 141      (format stream "~
 142 /* -*- mode: c; indent-tabs-mode: nil -*-
 143  *
 144  * Header file generated by SOD for ~A
 145  */~2%"
 146              (namestring (module-name module))))
 147
 148     ((:guard :start)
 149      (format stream "~
 150 #ifndef ~A
 151 #define ~:*~A
 152
 153 #ifdef __cplusplus
 154   extern \"C\" {
 155 #endif~2%"
 156              (or (get-property (module-pset module) :guard :id)
 157                  (guard-name (or (stream-pathname stream)
 158                                  (guess-output-file module "H"))))))
 159     ((:guard :end)
 160      (banner "That's all, folks" stream)
 161      (format stream "~
 162 #ifdef __cplusplus
 163   }
 164 #endif
 165
 166 #endif~%"))
 167
 168     ((:typedefs :start)
 169      (banner "Forward type declarations" stream))
 170     ((:typedefs :end)
 171      (terpri stream))
 172
 173     ((:includes :start)
 174      (banner "External header files" stream))
 175     ((:includes :end)
 176      (terpri stream))))
 177
 178 (defmethod hook-output ((module module) (reason (eql :c)) sequencer)
 179   (sequence-output (stream sequencer)
 180
 181     :constraint
 182     (:prologue
 183      (:includes :start) :includes (:includes :end)
 184      (:early-user :start) :early-user (:early-user :end)
 185      (:static-instances :start)
 186      (:static-instances :decls) (:static-instances :gap)
 187      (:static-instances :end)
 188      (:classes :start) (:classes :end)
 189      (:user :start) :user (:user :end)
 190      :epilogue)
 191
 192     (:prologue
 193      (format stream "~
 194 /* -*- mode: c; indent-tabs-mode: nil -*-
 195  *
 196  * Implementation file generated by SOD for ~A
 197  */~2%"
 198              (namestring (module-name module))))
 199
 200     (:epilogue
 201      (banner "That's all, folks" stream :blank-line-p nil))
 202
 203     ((:includes :start)
 204      (banner "External header files" stream))
 205     ((:includes :end)
 206      (terpri stream))))
 207
 208 ;;;--------------------------------------------------------------------------
 209 ;;; Output types.
 210
 211 (defvar *output-types* nil
 212   "List of known output types.")
 213
 214 (export 'declare-output-type)
 215 (defun declare-output-type (reason pathname)
 216   "Record that REASON is a valid user-level output type.
 217
 218    The output file name will be constructed by merging the module's pathname
 219    with PATHNAME."
 220   (pushnew reason *output-types*)
 221   (setf (get reason 'output-type) pathname))
 222
 223 (export 'output-type-pathname)
 224 (defun output-type-pathname (reason)
 225   "Return the PATHNAME template for the output type REASON.
 226
 227    Report an error if there is no such output type."
 228   (or (get reason 'output-type)
 229       (error "Unknown output type `~(~A~)'" reason)))
 230
 231 (export 'module-output-file)
 232 (defgeneric module-output-file (module output-type output-dir)
 233   (:documentation
 234    "Return a pathname to which the output should be written.
 235
 236    Specifically, if we're processing a MODULE for a particular OUTPUT-TYPE,
 237    and the user has requested that output be written to OUTPUT-DIR (a
 238    pathname), then return the pathname to which the output should be
 239    written.
 240
 241    The OUTPUT-TYPE can be an `reason' symbol or a raw pathname.  (Or
 242    something else, of course.)"))
 243
 244 (defmethod module-output-file
 245     ((module module) (output-type symbol) output-dir)
 246   (module-output-file module (output-type-pathname output-type) output-dir))
 247
 248 (defmethod module-output-file
 249     ((module module) (output-type pathname) output-dir)
 250   (reduce #'merge-pathnames
 251           (list output-dir output-type
 252                 (make-pathname :directory nil
 253                                :defaults (module-name module)))))
 254
 255 (export 'write-dependency-file)
 256 (defgeneric write-dependency-file (module reason output-dir)
 257   (:documentation
 258    "Write a dependency-tracking make(1) fragment.
 259
 260    Specifically, we've processed a MODULE for a particular REASON (a
 261    symbol), and the user has requested that output be written to OUTPUT-DIR
 262    (a pathname): determine a suitable output pathname and write a make(1)
 263    fragment explaining that the output file we've made depends on all of the
 264    files we had to read to load the module."))
 265
 266 (defmethod write-dependency-file ((module module) reason output-dir)
 267   (let* ((common-case
 268           ;; Bletch.  We want to derive the filetype from the one we're
 269           ;; given, but we need to determine the environment's preferred
 270           ;; filetype case to do that.  Make a pathname and inspect it to
 271           ;; find out how to do this.
 272
 273           (if (upper-case-p
 274                            (char (pathname-type (make-pathname
 275                                                  :type "TEST"
 276                                                  :case :common))
 277                                  0))
 278                           #'string-upcase
 279                           #'string-downcase))
 280
 281          (outpath (output-type-pathname reason))
 282          (deppath (make-pathname :type (concatenate 'string
 283                                                     (pathname-type outpath)
 284                                                     (funcall common-case
 285                                                              "-DEP"))
 286                                  :defaults outpath))
 287          (outfile (module-output-file module reason output-dir))
 288          (depfile (module-output-file module deppath output-dir)))
 289
 290     (with-open-file (dep depfile
 291                      :direction :output
 292                      :if-exists :supersede
 293                      :if-does-not-exist :create)
 294       (format dep "### -*-makefile-*-~%~
 295                    ~A:~{ \\~%   ~A~}~%"
 296               outfile
 297               (cons (module-name module)
 298                     (module-files module))))))
 299
 300 (define-clear-the-decks reset-output-types
 301   "Clear out the registered output types."
 302   (dolist (reason *output-types*) (remprop reason 'output-type))
 303   (setf *output-types* nil)
 304   (declare-output-type :c (make-pathname :type "C" :case :common))
 305   (declare-output-type :h (make-pathname :type "H" :case :common)))
 306
 307 ;;;----- That's all, folks --------------------------------------------------