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 | ;;;-------------------------------------------------------------------------- | |
d9c15186 MW |
29 | ;;; Module basics. |
30 | ||
31 | (defclass module () | |
32 | ((name :initarg :name :type pathname :reader module-name) | |
33 | (pset :initarg :pset :initform (make-pset) :type pset :reader module-pset) | |
34 | (items :initarg :items :initform nil :type list :accessor module-items) | |
35 | (dependencies :initarg :dependencies :initform nil | |
36 | :type list :accessor module-dependencies) | |
37 | (state :initarg :state :initform nil :accessor module-state)) | |
38 | (:documentation | |
39 | "A module is a container for the definitions made in a source file. | |
40 | ||
41 | Modules are the fundamental units of translation. The main job of a | |
42 | module is to remember which definitions it contains, so that they can be | |
43 | translated and written to output files. The module contains the following | |
44 | handy bits of information: | |
45 | ||
46 | * A (path) name, which is the filename we used to find it. The default | |
47 | output filenames are derived from this. (We use the file's truename | |
48 | as the hash key to prevent multiple inclusion, and that's a different | |
49 | thing.) | |
50 | ||
51 | * A property list containing other useful things. | |
52 | ||
53 | * A list of the classes defined in the source file. | |
54 | ||
55 | * Lists of C fragments to be included in the output header and C source | |
56 | files. | |
57 | ||
58 | * A list of other modules that this one depends on. | |
59 | ||
60 | Modules are usually constructed by the PARSE-MODULE function, which is in | |
61 | turn usually invoked by IMPORT-MODULE, though there's nothing to stop | |
62 | fancy extensions building modules programmatically.")) | |
63 | ||
64 | (defparameter *module* nil | |
65 | "The current module under construction. | |
66 | ||
67 | This is always an instance of MODULE. Once we've finished constructing | |
68 | it, we'll call CHANGE-CLASS to turn it into an instance of whatever type | |
69 | is requested in the module's :LISP-CLASS property.") | |
70 | ||
71 | (defgeneric module-import (object) | |
72 | (:documentation | |
73 | "Import definitions into the current environment. | |
74 | ||
75 | Instructs the OBJECT to import its definitions into the current | |
76 | environment. Modules pass the request on to their constituents. There's | |
77 | a default method which does nothing at all. | |
78 | ||
79 | It's not usual to modify the current module. Inserting things into the | |
80 | *TYPE-MAP* is a good plan.") | |
81 | (:method (object) nil)) | |
82 | ||
83 | (defgeneric add-to-module (module item) | |
84 | (:documentation | |
85 | "Add ITEM to the MODULE's list of accumulated items. | |
86 | ||
87 | The module items participate in the MODULE-IMPORT and ADD-OUTPUT-HOOKS | |
88 | protocols.")) | |
89 | ||
90 | (defgeneric finalize-module (module) | |
91 | (:documentation | |
92 | "Finalizes a module, setting everything which needs setting. | |
93 | ||
94 | This isn't necessary if you made the module by hand. If you've | |
95 | constructed it incrementally, then it might be a good plan. In | |
96 | particular, it will change the class (using CHANGE-CLASS) of the module | |
97 | according to the class choice set in the module's :LISP-CLASS property. | |
98 | This has the side effects of calling SHARED-INITIALIZE, setting the | |
99 | module's state to T, and checking for unrecognized properties. (Therefore | |
100 | subclasses should add a method to SHARED-INITIALIZE should take care of | |
101 | looking at interesting properties, just to make sure they're ticked | |
102 | off.)")) | |
103 | ||
104 | (defmethod module-import ((module module)) | |
105 | (dolist (item (module-items module)) | |
106 | (module-import item))) | |
107 | ||
108 | (defmethod add-to-module ((module module) item) | |
109 | (setf (module-items module) | |
110 | (nconc (module-items module) (list item))) | |
111 | (module-import item)) | |
112 | ||
113 | (defmethod shared-initialize :after ((module module) slot-names &key pset) | |
114 | "Tick off known properties on the property set." | |
115 | (declare (ignore slot-names)) | |
116 | (when pset | |
117 | (dolist (prop '(:guard)) | |
118 | (get-property pset prop nil)))) | |
119 | ||
120 | (defmethod finalize-module ((module module)) | |
121 | (let* ((pset (module-pset module)) | |
122 | (class (get-property pset :lisp-class :symbol 'module))) | |
123 | ||
124 | ;; Always call CHANGE-CLASS, even if it's the same one; this will | |
125 | ;; exercise the property-set fiddling in SHARED-INITIALIZE and we can | |
126 | ;; catch unknown-property errors. | |
127 | (change-class module class :state t :pset pset) | |
128 | (check-unused-properties pset) | |
129 | module)) | |
130 | ||
131 | ;;;-------------------------------------------------------------------------- | |
132 | ;;; Module importing. | |
133 | ||
ddee4bb1 MW |
134 | (defun build-module |
135 | (name body-func &key (truename (probe-file name)) location) | |
136 | (let ((*module* (make-instance 'module | |
137 | :name (pathname name) | |
138 | :state (file-location location))) | |
139 | (*type-map* (make-hash-table :test #'equal))) | |
140 | (module-import *builtin-module*) | |
141 | (when truename | |
142 | (setf (gethash truename *module-map*) *module*)) | |
143 | (unwind-protect | |
144 | (progn | |
145 | (funcall body-func) | |
146 | (finalize-module *module*)) | |
147 | (when (and truename (not (eq (module-state *module*) t))) | |
148 | (remhash truename *module-map*))))) | |
149 | ||
150 | (defmacro define-module | |
151 | ((name &key (truename nil truenamep) (location nil locationp)) | |
152 | &body body) | |
153 | `(build-module ,name | |
154 | (lambda () ,@body) | |
155 | ,@(and truenamep `(:truename ,truename)) | |
156 | ,@(and locationp `(:location ,location)))) | |
157 | ||
d9c15186 MW |
158 | (defun read-module (pathname &key (truename (truename pathname)) location) |
159 | "Reads a module. | |
160 | ||
161 | The module is returned if all went well; NIL is returned if an error | |
162 | occurred. | |
163 | ||
164 | The PATHNAME argument is the file to read. TRUENAME should be the file's | |
165 | truename, if known: often, the file will have been searched for using | |
166 | PROBE-FILE or similar, which drops the truename into your lap." | |
167 | ||
168 | ;; Deal with a module which is already in the map. If its state is a | |
169 | ;; file-location then it's in progress and we have a cyclic dependency. | |
170 | (let ((module (gethash truename *module-map*))) | |
171 | (cond ((typep (module-state module) 'file-location) | |
172 | (error "Module ~A already being imported at ~A" | |
173 | pathname (module-state module))) | |
174 | (module | |
175 | (return-from read-module module)))) | |
176 | ||
177 | ;; Make a new module. Be careful to remove the module from the map if we | |
178 | ;; didn't succeed in constructing it. | |
ddee4bb1 MW |
179 | (define-module (pathname :location location :truename truename) |
180 | (let ((*readtable* (copy-readtable))) | |
181 | (with-open-file (f-stream pathname :direction :input) | |
182 | (let* ((pai-stream (make-instance 'position-aware-input-stream | |
183 | :stream f-stream | |
184 | :file pathname)) | |
185 | (lexer (make-instance 'sod-lexer :stream pai-stream))) | |
186 | (with-default-error-location (lexer) | |
187 | (next-char lexer) | |
188 | (next-token lexer) | |
189 | (parse-module lexer *module*))))))) | |
d9c15186 MW |
190 | |
191 | ;;;-------------------------------------------------------------------------- | |
192 | ;;; Module parsing protocol. | |
193 | ||
194 | (defgeneric parse-module-declaration (tag lexer pset) | |
195 | (:method (tag lexer pset) | |
196 | (error "Unexpected module declaration ~(~A~)" tag))) | |
197 | ||
198 | (defun parse-module (lexer) | |
199 | "Main dispatching for module parser. | |
200 | ||
201 | Calls PARSE-MODULE-DECLARATION for the identifiable declarations." | |
202 | ||
203 | ;; A little fancy footwork is required because `class' is a reserved word. | |
204 | (loop | |
205 | (flet ((dispatch (tag pset) | |
206 | (next-token lexer) | |
207 | (parse-module-declaration tag lexer pset) | |
208 | (check-unused-properties pset))) | |
209 | (restart-case | |
210 | (case (token-type lexer) | |
211 | (:eof (return)) | |
212 | (#\; (next-token lexer)) | |
213 | (t (let ((pset (parse-property-set lexer))) | |
214 | (case (token-type lexer) | |
215 | (:id (dispatch (string-to-symbol (token-value lexer) | |
216 | :keyword) | |
217 | pset)) | |
218 | (t (error "Unexpected token ~A: ignoring" | |
219 | (format-token lexer))))))) | |
220 | (continue () | |
221 | :report "Ignore the error and continue parsing." | |
222 | nil))))) | |
223 | ||
224 | ;;;-------------------------------------------------------------------------- | |
225 | ;;; Type definitions. | |
226 | ||
227 | (defclass type-item () | |
228 | ((name :initarg :name :type string :reader type-name))) | |
229 | ||
230 | (defmethod module-import ((item type-item)) | |
231 | (let* ((name (type-name item)) | |
232 | (def (gethash name *type-map*)) | |
233 | (type (make-simple-type name))) | |
234 | (cond ((not def) | |
235 | (setf (gethash name *type-map*) type)) | |
236 | ((not (eq def type)) | |
237 | (error "Conflicting types `~A'" name))))) | |
238 | ||
239 | (defmethod module-import ((class sod-class)) | |
240 | (record-sod-class class)) | |
241 | ||
242 | ;;;-------------------------------------------------------------------------- | |
abdf50aa MW |
243 | ;;; File searching. |
244 | ||
245 | (defparameter *module-dirs* nil | |
246 | "A list of directories (as pathname designators) to search for files. | |
247 | ||
248 | Both SOD module files and Lisp extension files are searched for in this | |
249 | list. The search works by merging the requested pathname with each | |
250 | element of this list in turn. The list is prefixed by the pathname of the | |
251 | requesting file, so that it can refer to other files relative to wherever | |
252 | it was found. | |
253 | ||
254 | See FIND-FILE for the grubby details.") | |
255 | ||
256 | (defun find-file (lexer name what thunk) | |
257 | "Find a file called NAME on the module search path, and call THUNK on it. | |
258 | ||
259 | The file is searched for relative to the LEXER's current file, and also in | |
260 | the directories mentioned in the *MODULE-DIRS* list. If the file is | |
261 | found, then THUNK is invoked with two arguments: the name we used to find | |
262 | it (which might be relative to the starting directory) and the truename | |
263 | found by PROBE-FILE. | |
264 | ||
265 | If the file wasn't found, or there was some kind of error, then an error | |
266 | is signalled; WHAT should be a noun phrase describing the kind of thing we | |
267 | were looking for, suitable for inclusion in the error message. | |
268 | ||
269 | While FIND-FILE establishes condition handlers for its own purposes, THUNK | |
270 | is not invoked with any additional handlers defined." | |
271 | ||
272 | (handler-case | |
273 | (dolist (dir (cons (stream-pathname (lexer-stream lexer)) | |
274 | *module-dirs*) | |
275 | (values nil nil)) | |
276 | (let* ((path (merge-pathnames name dir)) | |
277 | (probe (probe-file path))) | |
278 | (when probe | |
279 | (return (values path probe))))) | |
280 | (file-error (error) | |
281 | (error "Error searching for ~A ~S: ~A" what (namestring name) error)) | |
282 | (:no-error (path probe) | |
283 | (cond ((null path) | |
284 | (error "Failed to find ~A ~S" what name)) | |
285 | (t | |
286 | (funcall thunk path probe)))))) | |
287 | ||
d9c15186 MW |
288 | (defmethod parse-module-declaration ((tag (eql :import)) lexer pset) |
289 | (let ((name (require-token lexer :string))) | |
290 | (when name | |
291 | (find-file lexer | |
292 | (merge-pathnames name | |
293 | (make-pathname :type "SOD" :case :common)) | |
294 | "module" | |
295 | (lambda (path true) | |
296 | (handler-case | |
297 | (let ((module (read-module path :truename true))) | |
298 | (when module | |
299 | (module-import module) | |
300 | (pushnew module (module-dependencies *module*)))) | |
301 | (file-error (error) | |
302 | (cerror* "Error reading module ~S: ~A" | |
303 | path error))))) | |
304 | (require-token lexer #\;)))) | |
305 | ||
306 | (defmethod parse-module-declaration ((tag (eql :load)) lexer pset) | |
307 | (let ((name (require-token lexer :string))) | |
308 | (when name | |
309 | (find-file lexer | |
310 | (merge-pathnames name | |
311 | (make-pathname :type "LISP" :case :common)) | |
312 | "Lisp file" | |
313 | (lambda (path true) | |
314 | (handler-case (load true :verbose nil :print nil) | |
315 | (error (error) | |
316 | (cerror* "Error loading Lisp file ~S: ~A" | |
317 | path error))))) | |
318 | (require-token lexer #\;)))) | |
319 | ||
abdf50aa MW |
320 | ;;;-------------------------------------------------------------------------- |
321 | ;;; Modules. | |
322 | ||
d9c15186 | 323 | #+(or) |
abdf50aa MW |
324 | (defun parse-module (lexer) |
325 | "Parse a module from the given LEXER. | |
326 | ||
327 | The newly constructed module is returned. This is the top-level parsing | |
328 | function." | |
329 | ||
330 | (let ((hfrags nil) | |
331 | (cfrags nil) | |
332 | (classes nil) | |
333 | (plist nil) | |
334 | (deps nil)) | |
335 | ||
336 | (labels ((fragment (func) | |
337 | (next-token lexer) | |
338 | (when (require-token lexer #\{ :consumep nil) | |
339 | (let ((frag (scan-c-fragment lexer '(#\})))) | |
340 | (next-token lexer) | |
341 | (require-token lexer #\}) | |
342 | (funcall func frag))))) | |
343 | ||
344 | (tagbody | |
345 | ||
346 | top | |
347 | ;; module : empty | module-def module | |
348 | ;; | |
349 | ;; Just read module-defs until we reach the end of the file. | |
350 | (case (token-type lexer) | |
351 | ||
352 | (:eof | |
353 | (go done)) | |
354 | (#\; | |
355 | (next-token lexer) | |
356 | (go top)) | |
357 | ||
abdf50aa MW |
358 | ;; module-def : `lisp' sexp |
359 | ;; | |
360 | ;; Process an in-line Lisp form immediately. | |
361 | (:lisp | |
362 | (let ((form (with-lexer-stream (stream lexer) | |
363 | (read stream t)))) | |
364 | (handler-case | |
365 | (eval form) | |
366 | (error (error) | |
367 | (cerror* "Error in Lisp form: ~A" error)))) | |
368 | (next-token lexer) | |
369 | (go top)) | |
370 | ||
371 | ;; module-def : `typename' ids `;' | |
372 | ;; ids : id | ids `,' id | |
373 | ;; | |
374 | ;; Add ids as registered type names. We don't need to know what | |
375 | ;; they mean at this level. | |
376 | (:typename | |
377 | (next-token lexer) | |
378 | (loop | |
379 | (let ((id (require-token lexer :id))) | |
380 | (cond ((null id) | |
381 | (return)) | |
382 | ((gethash id *type-map*) | |
383 | (cerror* "Type ~A is already defined" id)) | |
384 | (t | |
385 | (setf (gethash id *type-map*) | |
386 | (make-instance 'simple-c-type :name id)))) | |
387 | (unless (eql (token-type lexer) #\,) | |
388 | (return)) | |
389 | (next-token lexer))) | |
390 | (go semicolon)) | |
391 | ||
392 | ;; module-def : `source' `{' c-stuff `}' | |
393 | ;; module-def : `header' `{' c-stuff `}' | |
394 | (:source | |
395 | (fragment (lambda (frag) (push frag cfrags))) | |
396 | (go top)) | |
397 | (:header | |
398 | (fragment (lambda (frag) (push frag hfrags))) | |
399 | (go top)) | |
400 | ||
401 | ;; Anything else is an error. | |
402 | (t | |
403 | (cerror* "Unexpected token ~A ignored" (format-token lexer)) | |
404 | (next-token lexer) | |
405 | (go top))) | |
406 | ||
407 | semicolon | |
408 | ;; Scan a terminating semicolon. | |
409 | (require-token lexer #\;) | |
410 | (go top) | |
411 | ||
412 | done) | |
413 | ||
414 | ;; Assemble the module and we're done. | |
415 | (make-instance 'module | |
416 | :name (stream-pathname (lexer-stream lexer)) | |
417 | :plist plist | |
418 | :classes classes | |
419 | :header-fragments hfrags | |
420 | :source-fragments cfrags | |
421 | :dependencies deps)))) | |
422 | ||
423 | ;;;----- That's all, folks -------------------------------------------------- |