chiark - git - mdw - 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 ;;;--------------------------------------------------------------------------
  69 ;;; Main output interface.
  70
  71 (export 'output-module)
  72 (defun output-module (module reason stream)
  73   "Write the MODULE to STREAM, giving the output machinery the REASON.
  74
  75    This is the top-level interface for producing output."
  76   (let ((sequencer (make-instance 'sequencer))
  77         (stream (if (typep stream 'position-aware-output-stream)
  78                     stream
  79                     (make-instance 'position-aware-output-stream
  80                                    :stream stream
  81                                    :file (stream-pathname stream)))))
  82     (with-module-environment (module)
  83       (hook-output module reason sequencer)
  84       (invoke-sequencer-items sequencer stream))))
  85
  86 ;;;--------------------------------------------------------------------------
  87 ;;; Output implementation.
  88
  89 (defmethod hook-output progn ((module module) reason sequencer)
  90
  91   ;; Ask the module's items to sequence themselves.
  92   (dolist (item (module-items module))
  93     (hook-output item reason sequencer)))
  94
  95 (defmethod hook-output progn ((frag code-fragment-item) reason sequencer)
  96
  97   ;; Output fragments when their reasons are called up.
  98   (when (eq reason (code-fragment-reason frag))
  99     (dolist (constraint (code-fragment-constraints frag))
 100       (add-sequencer-constraint sequencer constraint))
 101     (add-sequencer-item-function sequencer (code-fragment-name frag)
 102                                  (lambda (stream)
 103                                    (write (code-fragment frag)
 104                                           :stream stream
 105                                           :pretty nil
 106                                           :escape nil)))))
 107
 108 (defmethod hook-output progn ((module module) (reason (eql :h)) sequencer)
 109   (sequence-output (stream sequencer)
 110
 111     :constraint
 112     (:prologue
 113      (:guard :start)
 114      (:typedefs :start) :typedefs (:typedefs :end)
 115      (:includes :start) :includes (:includes :end)
 116      (:early-user :start) :early-user (:early-user :end)
 117      (:classes :start) (:classes :end)
 118      (:user :start) :user (:user :end)
 119      (:guard :end)
 120      :epilogue)
 121
 122     (:prologue
 123      (format stream "~
 124 /* -*- mode: c; indent-tabs-mode: nil -*-
 125  *
 126  * Header file generated by SOD for ~A
 127  */~2%"
 128              (namestring (module-name module))))
 129
 130     ((:guard :start)
 131      (format stream "~
 132 #ifndef ~A
 133 #define ~:*~A
 134
 135 #ifdef __cplusplus
 136   extern \"C\" {
 137 #endif~2%"
 138              (or (get-property (module-pset module) :guard :id)
 139                  (guard-name (or (stream-pathname stream)
 140                                  (guess-output-file module "H"))))))
 141     ((:guard :end)
 142      (banner "That's all, folks" stream)
 143      (format stream "~
 144 #ifdef __cplusplus
 145   }
 146 #endif
 147
 148 #endif~%"))
 149
 150     ((:typedefs :start)
 151      (banner "Forward type declarations" stream))
 152     ((:typedefs :end)
 153      (terpri stream))
 154
 155     ((:includes :start)
 156      (banner "External header files" stream))
 157     ((:includes :end)
 158      (terpri stream))))
 159
 160 (defmethod hook-output progn ((module module) (reason (eql :c)) sequencer)
 161   (sequence-output (stream sequencer)
 162
 163     :constraint
 164     (:prologue
 165      (:includes :start) :includes (:includes :end)
 166      (:early-user :start) :early-user (:early-user :end)
 167      (:classes :start) (:classes :end)
 168      (:user :start) :user (:user :end)
 169      :epilogue)
 170
 171     (:prologue
 172      (format stream "~
 173 /* -*- mode: c; indent-tabs-mode: nil -*-
 174  *
 175  * Implementation file generated by SOD for ~A
 176  */~2%"
 177              (namestring (module-name module))))
 178
 179     (:epilogue
 180      (banner "That's all, folks" stream :blank-line-p nil))
 181
 182     ((:includes :start)
 183      (banner "External header files" stream))
 184     ((:includes :end)
 185      (terpri stream))))
 186
 187 ;;;--------------------------------------------------------------------------
 188 ;;; Output types.
 189
 190 (defvar *output-types* nil
 191   "List of known output types.")
 192
 193 (export 'declare-output-type)
 194 (defun declare-output-type (reason pathname)
 195   "Record that REASON is a valid user-level output type.
 196
 197    The output file name will be constructed by merging the module's pathname
 198    with PATHNAME."
 199   (setf (get reason 'output-type) pathname))
 200
 201 (export 'output-type-pathname)
 202 (defun output-type-pathname (reason)
 203   "Return the PATHNAME template for the output type REASON.
 204
 205    Report an error if there is no such output type."
 206   (or (get reason 'output-type)
 207       (error "Unknown output type `~(~A~)'" reason)))
 208
 209 (define-clear-the-decks reset-output-types
 210   "Clear out the registered output types."
 211   (dolist (reason *output-types*) (remprop reason 'output-type))
 212   (setf *output-types* nil)
 213   (declare-output-type :c (make-pathname :type "C" :case :common))
 214   (declare-output-type :h (make-pathname :type "H" :case :common)))
 215
 216 ;;;----- That's all, folks --------------------------------------------------