5 ;;; (c) 2013 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Sensible Object Design, an object system for C.
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.
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.
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.
28 ;;;--------------------------------------------------------------------------
32 (defun banner (title output &key (blank-line-p t))
33 "Write a banner to the OUTPUT stream, starting a new section called TITLE.
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*/~%"
39 (make-string (- 77 2 5 1 (length title) 1 2)
40 :initial-element #\-))
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))
52 (dotimes (i (length name))
53 (let ((ch (char name i)))
54 (cond ((alphanumericp ch)
55 (write-char (char-upcase ch) guard)
58 (write-char #\_ guard)
59 (setf uscore t))))))))
61 (defun guess-output-file (module type)
62 "Guess the filename to use for a file TYPE, generated from MODULE.
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)))
68 (defvar *done-one-off-output* nil
69 "A list of tokens for things which should appear at most once in output.")
71 (export 'one-off-output)
72 (defun one-off-output (token sequencer item-name function)
73 "Arrange to output a thing at most once.
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)))
82 ;;;--------------------------------------------------------------------------
83 ;;; Main output interface.
85 (export 'output-module)
86 (defun output-module (module reason stream)
87 "Write the MODULE to STREAM, giving the output machinery the REASON.
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)
95 (make-instance 'position-aware-output-stream
97 :file (stream-pathname stream)))))
98 (with-module-environment (module)
99 (hook-output module reason sequencer)
100 (invoke-sequencer-items sequencer stream))))
102 ;;;--------------------------------------------------------------------------
103 ;;; Output implementation.
105 (defmethod hook-output progn ((module module) reason sequencer)
107 ;; Ask the module's items to sequence themselves.
108 (dolist (item (module-items module))
109 (hook-output item reason sequencer)))
111 (defmethod hook-output progn ((frag code-fragment-item) reason sequencer)
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 (add-sequencer-item-function sequencer (code-fragment-name frag)
119 (write (code-fragment frag)
124 (defmethod hook-output progn ((module module) (reason (eql :h)) sequencer)
125 (sequence-output (stream sequencer)
130 (:typedefs :start) :typedefs (:typedefs :end)
131 (:includes :start) :includes :early-decls (:includes :end)
132 (:early-user :start) :early-user (:early-user :end)
133 (:classes :start) (:classes :end)
134 (:user :start) :user (:user :end)
140 /* -*- mode: c; indent-tabs-mode: nil -*-
142 * Header file generated by SOD for ~A
144 (namestring (module-name module))))
154 (or (get-property (module-pset module) :guard :id)
155 (guard-name (or (stream-pathname stream)
156 (guess-output-file module "H"))))))
158 (banner "That's all, folks" stream)
167 (banner "Forward type declarations" stream))
172 (banner "External header files" stream))
176 (defmethod hook-output progn ((module module) (reason (eql :c)) sequencer)
177 (sequence-output (stream sequencer)
181 (:includes :start) :includes (:includes :end)
182 (:early-user :start) :early-user (:early-user :end)
183 (:classes :start) (:classes :end)
184 (:user :start) :user (:user :end)
189 /* -*- mode: c; indent-tabs-mode: nil -*-
191 * Implementation file generated by SOD for ~A
193 (namestring (module-name module))))
196 (banner "That's all, folks" stream :blank-line-p nil))
199 (banner "External header files" stream))
203 ;;;--------------------------------------------------------------------------
206 (defvar *output-types* nil
207 "List of known output types.")
209 (export 'declare-output-type)
210 (defun declare-output-type (reason pathname)
211 "Record that REASON is a valid user-level output type.
213 The output file name will be constructed by merging the module's pathname
215 (setf (get reason 'output-type) pathname))
217 (export 'output-type-pathname)
218 (defun output-type-pathname (reason)
219 "Return the PATHNAME template for the output type REASON.
221 Report an error if there is no such output type."
222 (or (get reason 'output-type)
223 (error "Unknown output type `~(~A~)'" reason)))
225 (define-clear-the-decks reset-output-types
226 "Clear out the registered output types."
227 (dolist (reason *output-types*) (remprop reason 'output-type))
228 (setf *output-types* nil)
229 (declare-output-type :c (make-pathname :type "C" :case :common))
230 (declare-output-type :h (make-pathname :type "H" :case :common)))
232 ;;;----- That's all, folks --------------------------------------------------