Commit | Line | Data |
---|---|---|
048d0b2d MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Output for modules | |
4 | ;;; | |
5 | ;;; (c) 2013 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
e0808c47 | 10 | ;;; This file is part of the Sensible Object Design, an object system for C. |
048d0b2d MW |
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 | ||
e674612e MW |
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 | ||
048d0b2d MW |
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." | |
b7a3889e MW |
90 | (let ((*print-right-margin* 77) |
91 | (*done-one-off-output* nil) | |
e674612e | 92 | (sequencer (make-instance 'sequencer)) |
048d0b2d MW |
93 | (stream (if (typep stream 'position-aware-output-stream) |
94 | stream | |
95 | (make-instance 'position-aware-output-stream | |
96 | :stream stream | |
ea578bb4 | 97 | :file (stream-pathname stream))))) |
9ec578d9 MW |
98 | (with-module-environment (module) |
99 | (hook-output module reason sequencer) | |
100 | (invoke-sequencer-items sequencer stream)))) | |
048d0b2d MW |
101 | |
102 | ;;;-------------------------------------------------------------------------- | |
103 | ;;; Output implementation. | |
104 | ||
7d8d3a16 | 105 | (defmethod hook-output :after ((module module) reason sequencer) |
048d0b2d MW |
106 | |
107 | ;; Ask the module's items to sequence themselves. | |
108 | (dolist (item (module-items module)) | |
109 | (hook-output item reason sequencer))) | |
110 | ||
7d8d3a16 | 111 | (defmethod hook-output ((frag code-fragment-item) reason sequencer) |
048d0b2d MW |
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)) | |
54ea6ee8 MW |
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)))))) | |
048d0b2d | 124 | |
7d8d3a16 | 125 | (defmethod hook-output ((module module) (reason (eql :h)) sequencer) |
048d0b2d MW |
126 | (sequence-output (stream sequencer) |
127 | ||
128 | :constraint | |
129 | (:prologue | |
130 | (:guard :start) | |
131 | (:typedefs :start) :typedefs (:typedefs :end) | |
e674612e | 132 | (:includes :start) :includes :early-decls (:includes :end) |
d437292a | 133 | (:early-user :start) :early-user (:early-user :end) |
721c1ca4 | 134 | (:classes :start) (:classes :end) |
00d59354 | 135 | (:static-instances :start) :static-instances (:static-instances :end) |
d437292a | 136 | (:user :start) :user (:user :end) |
048d0b2d MW |
137 | (:guard :end) |
138 | :epilogue) | |
139 | ||
140 | (:prologue | |
141 | (format stream "~ | |
9ec578d9 | 142 | /* -*- mode: c; indent-tabs-mode: nil -*- |
048d0b2d MW |
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 | ||
7d8d3a16 | 178 | (defmethod hook-output ((module module) (reason (eql :c)) sequencer) |
048d0b2d MW |
179 | (sequence-output (stream sequencer) |
180 | ||
181 | :constraint | |
182 | (:prologue | |
183 | (:includes :start) :includes (:includes :end) | |
d437292a | 184 | (:early-user :start) :early-user (:early-user :end) |
00d59354 MW |
185 | (:static-instances :start) |
186 | (:static-instances :decls) (:static-instances :gap) | |
187 | (:static-instances :end) | |
048d0b2d | 188 | (:classes :start) (:classes :end) |
d437292a | 189 | (:user :start) :user (:user :end) |
048d0b2d MW |
190 | :epilogue) |
191 | ||
192 | (:prologue | |
193 | (format stream "~ | |
9ec578d9 | 194 | /* -*- mode: c; indent-tabs-mode: nil -*- |
048d0b2d MW |
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 | ||
9ec578d9 MW |
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." | |
e05aabbb | 220 | (pushnew reason *output-types*) |
9ec578d9 MW |
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 | ||
b0e21f83 MW |
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 | ||
e05aabbb MW |
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 | ||
9ec578d9 MW |
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 | ||
048d0b2d | 307 | ;;;----- That's all, folks -------------------------------------------------- |