chiark - git - mdw - sod/blob - pre-reorg/module-output.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Output handling for modules
   4 ;;;
   5 ;;; (c) 2009 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Simple Object Definition system.
  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 (defun banner (title output &key (blank-line-p t))
  32   (format output "~&/*----- ~A ~A*/~%"
  33           title
  34           (make-string (- 77 2 5 1 (length title) 1 2)
  35                        :initial-element #\-))
  36   (when blank-line-p
  37     (terpri output)))
  38
  39 (defun guard-name (filename)
  40   "Return a sensible inclusion guard name for FILENAME."
  41   (with-output-to-string (guard)
  42     (let* ((pathname (make-pathname :name (pathname-name filename)
  43                                     :type (pathname-type filename)))
  44            (name (namestring pathname))
  45            (uscore t))
  46       (dotimes (i (length name))
  47         (let ((ch (char name i)))
  48           (cond ((alphanumericp ch)
  49                  (write-char (char-upcase ch) guard)
  50                  (setf uscore nil))
  51                 ((not uscore)
  52                  (write-char #\_ guard)
  53                  (setf uscore t))))))))
  54
  55 ;;;--------------------------------------------------------------------------
  56 ;;; Driving output.
  57
  58 (defun guess-output-file (module type)
  59   (merge-pathnames (make-pathname :type type :case :common)
  60                    (module-name module)))
  61
  62 (defun output-module (module reason stream)
  63   (let ((sequencer (make-instance 'sequencer))
  64         (stream (if (typep stream 'position-aware-output-stream)
  65                     stream
  66                     (make-instance 'position-aware-output-stream
  67                                    :stream stream
  68                                    :file (or (stream-pathname stream)
  69                                              #p"<unnamed>")))))
  70     (add-output-hooks module reason sequencer)
  71     (invoke-sequencer-items sequencer stream)))
  72
  73 ;;;--------------------------------------------------------------------------
  74 ;;; Main output protocol implementation.
  75
  76 (defmethod add-output-hooks progn ((module module) reason sequencer)
  77   (dolist (item (module-items module))
  78     (add-output-hooks item reason sequencer)))
  79
  80 (defmethod add-output-hooks progn
  81     ((frag code-fragment-item) reason sequencer)
  82   (when (eq reason (code-fragment-reason frag))
  83     (dolist (constraint (code-fragment-constraints frag))
  84       (add-sequencer-constraint sequencer constraint))
  85     (add-sequencer-item-function sequencer (code-fragment-name frag)
  86                                  (lambda (stream)
  87                                    (write (code-fragment frag)
  88                                           :stream stream
  89                                           :pretty nil
  90                                           :escape nil)))))
  91
  92 ;;;--------------------------------------------------------------------------
  93 ;;; Header output.
  94
  95 (defmethod add-output-hooks progn
  96     ((module module) (reason (eql :h)) sequencer)
  97   (sequence-output (stream sequencer)
  98     :constraint (:prologue
  99                  (:guard :start)
 100                  (:typedefs :start) :typedefs (:typedefs :end)
 101                  (:includes :start) :includes (:includes :end)
 102                  (:classes :start) :classes (:classes :end)
 103                  (:guard :end)
 104                  :epilogue)
 105
 106     (:prologue
 107      (format stream "~
 108 /* -*-c-*-
 109  *
 110  * Header file generated by SOD for ~A
 111  */~2%"
 112              (namestring (module-name module))))
 113
 114     ((:guard :start)
 115      (format stream "~
 116 #ifndef ~A
 117 #define ~:*~A
 118
 119 #ifdef __cplusplus
 120   extern \"C\" {
 121 #endif~2%"
 122              (or (get-property (module-pset module) :guard :id)
 123                  (guard-name (or (stream-pathname stream)
 124                                  (guess-output-file module "H"))))))
 125     ((:guard :end)
 126      (banner "That's all, folks" stream)
 127      (format stream "~
 128 #ifdef __cplusplus
 129   }
 130 #endif
 131
 132 #endif~%"))
 133
 134     ((:typedefs :start)
 135      (banner "Forward type declarations" stream))
 136     ((:typedefs :end)
 137      (terpri stream))
 138
 139     ((:includes :start)
 140      (banner "External header files" stream))
 141     ((:includes :end)
 142      (terpri stream))))
 143
 144 ;;;--------------------------------------------------------------------------
 145 ;;; Source output.
 146
 147 (defmethod add-output-hooks progn
 148     ((module module) (reason (eql :c)) sequencer)
 149   (sequence-output (stream sequencer)
 150     :constraint (:prologue
 151                  (:includes :start) :includes (:includes :end)
 152                  (:classes :start) (:classes :end)
 153                  :epilogue)
 154
 155     (:prologue
 156      (format stream "~
 157 /* -*-c-*-
 158  *
 159  * Implementation file generated by SOD for ~A
 160  */~2%"
 161              (namestring (module-name module))))
 162
 163     (:epilogue
 164      (banner "That's all, folks" stream :blank-line-p nil))
 165
 166     ((:includes :start)
 167      (banner "External header files" stream))
 168     ((:includes :end)
 169      (terpri stream))))
 170
 171 ;;;----- That's all, folks --------------------------------------------------