3 ;;; Modules and module parser
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Simple Object Definition system.
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 ((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))
39 "A module is a container for the definitions made in a source file.
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:
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
51 * A property list containing other useful things.
53 * A list of the classes defined in the source file.
55 * Lists of C fragments to be included in the output header and C source
58 * A list of other modules that this one depends on.
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."))
64 (defparameter *module* nil
65 "The current module under construction.
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.")
71 (defgeneric module-import (object)
73 "Import definitions into the current environment.
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.
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))
83 (defgeneric add-to-module (module item)
85 "Add ITEM to the MODULE's list of accumulated items.
87 The module items participate in the MODULE-IMPORT and ADD-OUTPUT-HOOKS
90 (defgeneric finalize-module (module)
92 "Finalizes a module, setting everything which needs setting.
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
104 (defmethod module-import ((module module))
105 (dolist (item (module-items module))
106 (module-import item)))
108 (defmethod add-to-module ((module module) item)
109 (setf (module-items module)
110 (nconc (module-items module) (list item)))
111 (module-import item))
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))
117 (dolist (prop '(:guard))
118 (get-property pset prop nil))))
120 (defmethod finalize-module ((module module))
121 (let* ((pset (module-pset module))
122 (class (get-property pset :lisp-class :symbol 'module)))
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)
131 ;;;--------------------------------------------------------------------------
132 ;;; Module importing.
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*)
142 (setf (gethash truename *module-map*) *module*))
146 (finalize-module *module*))
147 (when (and truename (not (eq (module-state *module*) t)))
148 (remhash truename *module-map*)))))
150 (defmacro define-module
151 ((name &key (truename nil truenamep) (location nil locationp))
155 ,@(and truenamep `(:truename ,truename))
156 ,@(and locationp `(:location ,location))))
158 (defun read-module (pathname &key (truename (truename pathname)) location)
161 The module is returned if all went well; NIL is returned if an error
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."
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)))
175 (return-from read-module module))))
177 ;; Make a new module. Be careful to remove the module from the map if we
178 ;; didn't succeed in constructing it.
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
185 (lexer (make-instance 'sod-lexer :stream pai-stream)))
186 (with-default-error-location (lexer)
189 (parse-module lexer *module*)))))))
191 ;;;--------------------------------------------------------------------------
192 ;;; Module parsing protocol.
194 (defgeneric parse-module-declaration (tag lexer pset)
195 (:method (tag lexer pset)
196 (error "Unexpected module declaration ~(~A~)" tag)))
198 (defun parse-module (lexer)
199 "Main dispatching for module parser.
201 Calls PARSE-MODULE-DECLARATION for the identifiable declarations."
203 ;; A little fancy footwork is required because `class' is a reserved word.
205 (flet ((dispatch (tag pset)
207 (parse-module-declaration tag lexer pset)
208 (check-unused-properties pset)))
210 (case (token-type lexer)
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)
218 (t (error "Unexpected token ~A: ignoring"
219 (format-token lexer)))))))
221 :report "Ignore the error and continue parsing."
224 ;;;--------------------------------------------------------------------------
225 ;;; Type definitions.
227 (defclass type-item ()
228 ((name :initarg :name :type string :reader type-name)))
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)))
235 (setf (gethash name *type-map*) type))
237 (error "Conflicting types `~A'" name)))))
239 (defmethod module-import ((class sod-class))
240 (record-sod-class class))
242 ;;;--------------------------------------------------------------------------
245 (defparameter *module-dirs* nil
246 "A list of directories (as pathname designators) to search for files.
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
254 See FIND-FILE for the grubby details.")
256 (defun find-file (lexer name what thunk)
257 "Find a file called NAME on the module search path, and call THUNK on it.
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
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.
269 While FIND-FILE establishes condition handlers for its own purposes, THUNK
270 is not invoked with any additional handlers defined."
273 (dolist (dir (cons (stream-pathname (lexer-stream lexer))
276 (let* ((path (merge-pathnames name dir))
277 (probe (probe-file path)))
279 (return (values path probe)))))
281 (error "Error searching for ~A ~S: ~A" what (namestring name) error))
282 (:no-error (path probe)
284 (error "Failed to find ~A ~S" what name))
286 (funcall thunk path probe))))))
288 (defmethod parse-module-declaration ((tag (eql :import)) lexer pset)
289 (let ((name (require-token lexer :string)))
292 (merge-pathnames name
293 (make-pathname :type "SOD" :case :common))
297 (let ((module (read-module path :truename true)))
299 (module-import module)
300 (pushnew module (module-dependencies *module*))))
302 (cerror* "Error reading module ~S: ~A"
304 (require-token lexer #\;))))
306 (defmethod parse-module-declaration ((tag (eql :load)) lexer pset)
307 (let ((name (require-token lexer :string)))
310 (merge-pathnames name
311 (make-pathname :type "LISP" :case :common))
314 (handler-case (load true :verbose nil :print nil)
316 (cerror* "Error loading Lisp file ~S: ~A"
318 (require-token lexer #\;))))
320 ;;;--------------------------------------------------------------------------
324 (defun parse-module (lexer)
325 "Parse a module from the given LEXER.
327 The newly constructed module is returned. This is the top-level parsing
336 (labels ((fragment (func)
338 (when (require-token lexer #\{ :consumep nil)
339 (let ((frag (scan-c-fragment lexer '(#\}))))
341 (require-token lexer #\})
342 (funcall func frag)))))
347 ;; module : empty | module-def module
349 ;; Just read module-defs until we reach the end of the file.
350 (case (token-type lexer)
358 ;; module-def : `lisp' sexp
360 ;; Process an in-line Lisp form immediately.
362 (let ((form (with-lexer-stream (stream lexer)
367 (cerror* "Error in Lisp form: ~A" error))))
371 ;; module-def : `typename' ids `;'
372 ;; ids : id | ids `,' id
374 ;; Add ids as registered type names. We don't need to know what
375 ;; they mean at this level.
379 (let ((id (require-token lexer :id)))
382 ((gethash id *type-map*)
383 (cerror* "Type ~A is already defined" id))
385 (setf (gethash id *type-map*)
386 (make-instance 'simple-c-type :name id))))
387 (unless (eql (token-type lexer) #\,)
392 ;; module-def : `source' `{' c-stuff `}'
393 ;; module-def : `header' `{' c-stuff `}'
395 (fragment (lambda (frag) (push frag cfrags)))
398 (fragment (lambda (frag) (push frag hfrags)))
401 ;; Anything else is an error.
403 (cerror* "Unexpected token ~A ignored" (format-token lexer))
408 ;; Scan a terminating semicolon.
409 (require-token lexer #\;)
414 ;; Assemble the module and we're done.
415 (make-instance 'module
416 :name (stream-pathname (lexer-stream lexer))
419 :header-fragments hfrags
420 :source-fragments cfrags
421 :dependencies deps))))
423 ;;;----- That's all, folks --------------------------------------------------