Commit | Line | Data |
---|---|---|
abdf50aa MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Modules and module parser | |
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 | ;;; File searching. | |
30 | ||
31 | (defparameter *module-dirs* nil | |
32 | "A list of directories (as pathname designators) to search for files. | |
33 | ||
34 | Both SOD module files and Lisp extension files are searched for in this | |
35 | list. The search works by merging the requested pathname with each | |
36 | element of this list in turn. The list is prefixed by the pathname of the | |
37 | requesting file, so that it can refer to other files relative to wherever | |
38 | it was found. | |
39 | ||
40 | See FIND-FILE for the grubby details.") | |
41 | ||
42 | (defun find-file (lexer name what thunk) | |
43 | "Find a file called NAME on the module search path, and call THUNK on it. | |
44 | ||
45 | The file is searched for relative to the LEXER's current file, and also in | |
46 | the directories mentioned in the *MODULE-DIRS* list. If the file is | |
47 | found, then THUNK is invoked with two arguments: the name we used to find | |
48 | it (which might be relative to the starting directory) and the truename | |
49 | found by PROBE-FILE. | |
50 | ||
51 | If the file wasn't found, or there was some kind of error, then an error | |
52 | is signalled; WHAT should be a noun phrase describing the kind of thing we | |
53 | were looking for, suitable for inclusion in the error message. | |
54 | ||
55 | While FIND-FILE establishes condition handlers for its own purposes, THUNK | |
56 | is not invoked with any additional handlers defined." | |
57 | ||
58 | (handler-case | |
59 | (dolist (dir (cons (stream-pathname (lexer-stream lexer)) | |
60 | *module-dirs*) | |
61 | (values nil nil)) | |
62 | (let* ((path (merge-pathnames name dir)) | |
63 | (probe (probe-file path))) | |
64 | (when probe | |
65 | (return (values path probe))))) | |
66 | (file-error (error) | |
67 | (error "Error searching for ~A ~S: ~A" what (namestring name) error)) | |
68 | (:no-error (path probe) | |
69 | (cond ((null path) | |
70 | (error "Failed to find ~A ~S" what name)) | |
71 | (t | |
72 | (funcall thunk path probe)))))) | |
73 | ||
74 | ;;;-------------------------------------------------------------------------- | |
75 | ;;; Modules. | |
76 | ||
77 | (defclass module () | |
78 | ((name :initarg :name | |
79 | :type pathname | |
80 | :accessor module-name) | |
81 | (plist :initform nil | |
82 | :initarg :plist | |
83 | :type list | |
84 | :accessor module-plist) | |
85 | (classes :initform nil | |
86 | :initarg :classes | |
87 | :type list | |
88 | :accessor module-classes) | |
89 | (source-fragments :initform nil | |
90 | :initarg :source-fragments | |
91 | :type list | |
92 | :accessor module-source-fragments) | |
93 | (header-fragments :initform nil | |
94 | :initarg :header-fragments | |
95 | :type list | |
96 | :accessor module-header-fragments) | |
97 | (dependencies :initform nil | |
98 | :initarg :dependencies | |
99 | :type list | |
100 | :accessor module-dependencies)) | |
101 | (:documentation | |
102 | "A module is a container for the definitions made in a source file. | |
103 | ||
104 | Modules are the fundamental units of translation. The main job of a | |
105 | module is to remember which definitions it contains, so that they can be | |
106 | translated and written to output files. The module contains the following | |
107 | handy bits of information: | |
108 | ||
109 | * A (path) name, which is the filename we used to find it. The default | |
110 | output filenames are derived from this. (We use the file's truename | |
111 | as the hash key to prevent multiple inclusion, and that's a different | |
112 | thing.) | |
113 | ||
114 | * A property list containing other useful things. | |
115 | ||
116 | * A list of the classes defined in the source file. | |
117 | ||
118 | * Lists of C fragments to be included in the output header and C source | |
119 | files. | |
120 | ||
121 | * A list of other modules that this one depends on. | |
122 | ||
123 | Modules are usually constructed by the PARSE-MODULE function, which is in | |
124 | turn usually invoked by IMPORT-MODULE, though there's nothing to stop | |
125 | fancy extensions building modules programmatically.")) | |
126 | ||
127 | (defun import-module (pathname &key (truename (truename pathname))) | |
128 | "Import a module. | |
129 | ||
130 | The module is returned if all went well; NIL is returned if an error | |
131 | occurred. | |
132 | ||
133 | The PATHNAME argument is the file to read. TRUENAME should be the file's | |
134 | truename, if known: often, the file will have been searched for using | |
135 | PROBE-FILE or similar, which drops the truename into your lap." | |
136 | ||
137 | (let ((module (gethash truename *module-map*))) | |
138 | (cond | |
139 | ||
140 | ;; The module's not there. (The *MODULE-MAP* never maps things to | |
141 | ;; NIL.) | |
142 | ((null module) | |
143 | ||
144 | ;; Mark the module as being in progress. Another attempt to import it | |
145 | ;; will fail. | |
146 | (setf (gethash truename *module-map*) :in-progress) | |
147 | ||
148 | ;; Be careful to restore the state of the module map on exit. | |
149 | (unwind-protect | |
150 | ||
151 | ;; Open the module file and parse it. | |
152 | (with-open-file (f-stream pathname :direction :input) | |
153 | (let* ((pai-stream (make-instance 'position-aware-input-stream | |
154 | :stream f-stream | |
155 | :file pathname)) | |
156 | (lexer (make-instance 'sod-lexer :stream pai-stream))) | |
157 | (with-default-error-location (lexer) | |
158 | (restart-case | |
159 | (progn | |
160 | (next-char lexer) | |
161 | (next-token lexer) | |
162 | (setf module (parse-module lexer))) | |
163 | (continue () | |
164 | :report "Ignore the import and continue" | |
165 | nil)))))) | |
166 | ||
167 | ;; If we successfully parsed the module, then store it in the table; | |
168 | ;; otherwise remove it because we might want to try again. (That | |
169 | ;; might not work very well, but it could be worth a shot.) | |
170 | (if module | |
171 | (setf (gethash truename *module-map*) module) | |
172 | (remhash truename *module-map*)))) | |
173 | ||
174 | ;; A module which is being read can't be included again. | |
175 | ((eql module :in-progress) | |
176 | (error "Cyclic module dependency involving module ~A" pathname)) | |
177 | ||
178 | ;; A module which was successfully read. Just return it. | |
179 | (t | |
180 | module)))) | |
181 | ||
182 | (defun parse-module (lexer) | |
183 | "Parse a module from the given LEXER. | |
184 | ||
185 | The newly constructed module is returned. This is the top-level parsing | |
186 | function." | |
187 | ||
188 | (let ((hfrags nil) | |
189 | (cfrags nil) | |
190 | (classes nil) | |
191 | (plist nil) | |
192 | (deps nil)) | |
193 | ||
194 | (labels ((fragment (func) | |
195 | (next-token lexer) | |
196 | (when (require-token lexer #\{ :consumep nil) | |
197 | (let ((frag (scan-c-fragment lexer '(#\})))) | |
198 | (next-token lexer) | |
199 | (require-token lexer #\}) | |
200 | (funcall func frag))))) | |
201 | ||
202 | (tagbody | |
203 | ||
204 | top | |
205 | ;; module : empty | module-def module | |
206 | ;; | |
207 | ;; Just read module-defs until we reach the end of the file. | |
208 | (case (token-type lexer) | |
209 | ||
210 | (:eof | |
211 | (go done)) | |
212 | (#\; | |
213 | (next-token lexer) | |
214 | (go top)) | |
215 | ||
216 | ;; module-def : `import' string `;' | |
217 | ;; | |
218 | ;; Read another module of definitions from a file. | |
219 | (:import | |
220 | (next-token lexer) | |
221 | (let ((name (require-token lexer :string))) | |
222 | (when name | |
223 | (find-file lexer | |
224 | (merge-pathnames name (make-pathname | |
225 | :type "SOD" | |
226 | :case :common)) | |
227 | "module" | |
228 | (lambda (path true) | |
229 | (handler-case | |
230 | (let ((module (import-module path | |
231 | :truename true))) | |
232 | (when module | |
233 | (push module deps))) | |
234 | (file-error (error) | |
235 | (cerror* "Error reading module ~S: ~A" | |
236 | path error))))))) | |
237 | (go semicolon)) | |
238 | ||
239 | ;; module-def : `load' string `;' | |
240 | ;; | |
241 | ;; Load a Lisp extension from a file. | |
242 | (:load | |
243 | (next-token lexer) | |
244 | (let ((name (require-token lexer :string))) | |
245 | (when name | |
246 | (find-file lexer | |
247 | (merge-pathnames name | |
248 | (make-pathname :type "LISP" | |
249 | :case :common)) | |
250 | "Lisp file" | |
251 | (lambda (path true) | |
252 | (handler-case (load true | |
253 | :verbose nil | |
254 | :print nil) | |
255 | (error (error) | |
256 | (cerror* "Error loading Lisp file ~S: ~A" | |
257 | path error))))))) | |
258 | (go semicolon)) | |
259 | ||
260 | ;; module-def : `lisp' sexp | |
261 | ;; | |
262 | ;; Process an in-line Lisp form immediately. | |
263 | (:lisp | |
264 | (let ((form (with-lexer-stream (stream lexer) | |
265 | (read stream t)))) | |
266 | (handler-case | |
267 | (eval form) | |
268 | (error (error) | |
269 | (cerror* "Error in Lisp form: ~A" error)))) | |
270 | (next-token lexer) | |
271 | (go top)) | |
272 | ||
273 | ;; module-def : `typename' ids `;' | |
274 | ;; ids : id | ids `,' id | |
275 | ;; | |
276 | ;; Add ids as registered type names. We don't need to know what | |
277 | ;; they mean at this level. | |
278 | (:typename | |
279 | (next-token lexer) | |
280 | (loop | |
281 | (let ((id (require-token lexer :id))) | |
282 | (cond ((null id) | |
283 | (return)) | |
284 | ((gethash id *type-map*) | |
285 | (cerror* "Type ~A is already defined" id)) | |
286 | (t | |
287 | (setf (gethash id *type-map*) | |
288 | (make-instance 'simple-c-type :name id)))) | |
289 | (unless (eql (token-type lexer) #\,) | |
290 | (return)) | |
291 | (next-token lexer))) | |
292 | (go semicolon)) | |
293 | ||
294 | ;; module-def : `source' `{' c-stuff `}' | |
295 | ;; module-def : `header' `{' c-stuff `}' | |
296 | (:source | |
297 | (fragment (lambda (frag) (push frag cfrags))) | |
298 | (go top)) | |
299 | (:header | |
300 | (fragment (lambda (frag) (push frag hfrags))) | |
301 | (go top)) | |
302 | ||
303 | ;; Anything else is an error. | |
304 | (t | |
305 | (cerror* "Unexpected token ~A ignored" (format-token lexer)) | |
306 | (next-token lexer) | |
307 | (go top))) | |
308 | ||
309 | semicolon | |
310 | ;; Scan a terminating semicolon. | |
311 | (require-token lexer #\;) | |
312 | (go top) | |
313 | ||
314 | done) | |
315 | ||
316 | ;; Assemble the module and we're done. | |
317 | (make-instance 'module | |
318 | :name (stream-pathname (lexer-stream lexer)) | |
319 | :plist plist | |
320 | :classes classes | |
321 | :header-fragments hfrags | |
322 | :source-fragments cfrags | |
323 | :dependencies deps)))) | |
324 | ||
325 | ;;;----- That's all, folks -------------------------------------------------- |