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 importing. |
30 | ||
31 | (defun read-module (pathname &key (truename (truename pathname)) location) | |
32 | "Reads a module. | |
33 | ||
bf090e02 | 34 | The module is returned if all went well; nil is returned if an error |
d9c15186 MW |
35 | occurred. |
36 | ||
37 | The PATHNAME argument is the file to read. TRUENAME should be the file's | |
38 | truename, if known: often, the file will have been searched for using | |
bf090e02 | 39 | `probe-file' or similar, which drops the truename into your lap." |
d9c15186 MW |
40 | |
41 | ;; Deal with a module which is already in the map. If its state is a | |
a07d8d00 | 42 | ;; FILE-LOCATION then it's in progress and we have a cyclic dependency. |
d9c15186 | 43 | (let ((module (gethash truename *module-map*))) |
a07d8d00 MW |
44 | (cond ((null module)) |
45 | ((typep (module-state module) 'file-location) | |
d9c15186 MW |
46 | (error "Module ~A already being imported at ~A" |
47 | pathname (module-state module))) | |
48 | (module | |
49 | (return-from read-module module)))) | |
50 | ||
51 | ;; Make a new module. Be careful to remove the module from the map if we | |
52 | ;; didn't succeed in constructing it. | |
ddee4bb1 MW |
53 | (define-module (pathname :location location :truename truename) |
54 | (let ((*readtable* (copy-readtable))) | |
55 | (with-open-file (f-stream pathname :direction :input) | |
56 | (let* ((pai-stream (make-instance 'position-aware-input-stream | |
57 | :stream f-stream | |
58 | :file pathname)) | |
59 | (lexer (make-instance 'sod-lexer :stream pai-stream))) | |
60 | (with-default-error-location (lexer) | |
61 | (next-char lexer) | |
62 | (next-token lexer) | |
a07d8d00 | 63 | (parse-module lexer))))))) |
d9c15186 MW |
64 | |
65 | ;;;-------------------------------------------------------------------------- | |
66 | ;;; Module parsing protocol. | |
67 | ||
68 | (defgeneric parse-module-declaration (tag lexer pset) | |
69 | (:method (tag lexer pset) | |
a07d8d00 MW |
70 | (error "Unexpected module declaration ~(~A~)" tag)) |
71 | (:method :before (tag lexer pset) | |
72 | (next-token lexer))) | |
d9c15186 MW |
73 | |
74 | (defun parse-module (lexer) | |
75 | "Main dispatching for module parser. | |
76 | ||
77 | Calls PARSE-MODULE-DECLARATION for the identifiable declarations." | |
78 | ||
d9c15186 | 79 | (loop |
a07d8d00 MW |
80 | (restart-case |
81 | (case (token-type lexer) | |
82 | (:eof (return)) | |
83 | (#\; (next-token lexer)) | |
84 | (t (let ((pset (parse-property-set lexer))) | |
85 | (case (token-type lexer) | |
86 | (:id (let ((tag (intern (frob-case (token-value lexer)) | |
87 | :keyword))) | |
88 | (parse-module-declaration tag lexer pset) | |
89 | (check-unused-properties pset))) | |
90 | (t (error "Unexpected token ~A: ignoring" | |
91 | (format-token lexer))))))) | |
92 | (continue () | |
93 | :report "Ignore the error and continue parsing." | |
94 | nil)))) | |
d9c15186 | 95 | |
a07d8d00 MW |
96 | (defmethod parse-module-declaration ((tag (eql :typename)) lexer pset) |
97 | "module-decl ::= `typename' id-list `;'" | |
98 | (loop (let ((name (require-token lexer :id))) | |
99 | (unless name (return)) | |
100 | (if (gethash name *type-map*) | |
101 | (cerror* "Type `~A' already defined" name) | |
102 | (add-to-module *module* (make-instance 'type-item :name name))) | |
103 | (unless (require-token lexer #\, :errorp nil) (return)))) | |
104 | (require-token lexer #\;)) | |
105 | ||
106 | ;;;-------------------------------------------------------------------------- | |
107 | ;;; Fragments. | |
108 | ||
a07d8d00 MW |
109 | (defmethod parse-module-declaration ((tag (eql :code)) lexer pset) |
110 | "module-decl ::= `code' id `:' id [constraint-list] `{' c-fragment `}' | |
111 | constraint ::= id*" | |
112 | (labels ((parse-constraint () | |
113 | (let ((list nil)) | |
114 | (loop (let ((id (require-token lexer :id | |
115 | :errorp (null list)))) | |
116 | (unless id (return)) | |
117 | (push id list))) | |
118 | (nreverse list))) | |
119 | (parse-constraints () | |
120 | (let ((list nil)) | |
121 | (when (require-token lexer #\[ :errorp nil) | |
122 | (loop (let ((constraint (parse-constraint))) | |
123 | (push constraint list) | |
124 | (unless (require-token lexer #\, :errorp nil) | |
125 | (return)))) | |
126 | (require-token lexer #\])) | |
127 | (nreverse list))) | |
128 | (keywordify (id) | |
129 | (and id (intern (substitute #\- #\_ (frob-case id)) :keyword)))) | |
130 | (let* ((reason (prog1 (keywordify (require-token lexer :id)) | |
131 | (require-token lexer #\:))) | |
132 | (name (keywordify (require-token lexer :id))) | |
133 | (constraints (parse-constraints))) | |
134 | (when (require-token lexer #\{ :consumep nil) | |
135 | (let ((frag (scan-c-fragment lexer '(#\})))) | |
136 | (next-token lexer) | |
137 | (require-token lexer #\}) | |
138 | (add-to-module *module* | |
139 | (make-instance 'code-fragment-item | |
140 | :name name | |
141 | :reason reason | |
142 | :constraints constraints | |
143 | :fragment frag))))))) | |
144 | ||
d9c15186 | 145 | ;;;-------------------------------------------------------------------------- |
abdf50aa MW |
146 | ;;; File searching. |
147 | ||
abdf50aa | 148 | |
d9c15186 | 149 | (defmethod parse-module-declaration ((tag (eql :import)) lexer pset) |
a07d8d00 | 150 | "module-decl ::= `import' string `;'" |
d9c15186 MW |
151 | (let ((name (require-token lexer :string))) |
152 | (when name | |
153 | (find-file lexer | |
154 | (merge-pathnames name | |
155 | (make-pathname :type "SOD" :case :common)) | |
156 | "module" | |
157 | (lambda (path true) | |
158 | (handler-case | |
159 | (let ((module (read-module path :truename true))) | |
160 | (when module | |
161 | (module-import module) | |
162 | (pushnew module (module-dependencies *module*)))) | |
163 | (file-error (error) | |
164 | (cerror* "Error reading module ~S: ~A" | |
165 | path error))))) | |
166 | (require-token lexer #\;)))) | |
167 | ||
168 | (defmethod parse-module-declaration ((tag (eql :load)) lexer pset) | |
a07d8d00 | 169 | "module-decl ::= `load' string `;'" |
d9c15186 MW |
170 | (let ((name (require-token lexer :string))) |
171 | (when name | |
172 | (find-file lexer | |
173 | (merge-pathnames name | |
174 | (make-pathname :type "LISP" :case :common)) | |
175 | "Lisp file" | |
176 | (lambda (path true) | |
177 | (handler-case (load true :verbose nil :print nil) | |
178 | (error (error) | |
179 | (cerror* "Error loading Lisp file ~S: ~A" | |
180 | path error))))) | |
181 | (require-token lexer #\;)))) | |
182 | ||
abdf50aa | 183 | ;;;-------------------------------------------------------------------------- |
a07d8d00 MW |
184 | ;;; Lisp escapes. |
185 | ||
186 | (defmethod parse-module-declaration :around ((tag (eql :lisp)) lexer pset) | |
187 | "module-decl ::= `lisp' s-expression `;'" | |
188 | (let ((form (with-lexer-stream (stream lexer) (read stream t)))) | |
189 | (eval form)) | |
190 | (next-token lexer) | |
191 | (require-token lexer #\;)) | |
192 | ||
193 | ;;;-------------------------------------------------------------------------- | |
194 | ;;; Class declarations. | |
195 | ||
196 | (defmethod parse-module-declaration ((tag (eql :class)) lexer pset) | |
197 | "module-decl ::= `class' id [`:' id-list] `{' class-item* `}'" | |
198 | (let* ((location (file-location lexer)) | |
199 | (name (let ((name (require-token lexer :id))) | |
200 | (make-class-type name location) | |
201 | (when (require-token lexer #\; :errorp nil) | |
202 | (return-from parse-module-declaration)) | |
203 | name)) | |
204 | (supers (when (require-token lexer #\: :errorp nil) | |
205 | (let ((list nil)) | |
206 | (loop (let ((id (require-token lexer :id))) | |
207 | (unless id (return)) | |
208 | (push id list) | |
209 | (unless (require-token lexer #\, :errorp nil) | |
210 | (return)))) | |
211 | (nreverse list)))) | |
212 | (class (make-sod-class name (mapcar #'find-sod-class supers) | |
213 | pset location)) | |
214 | (nick (sod-class-nickname class))) | |
215 | (require-token lexer #\{) | |
216 | ||
217 | (labels ((parse-item () | |
218 | "Try to work out what kind of item this is. Messy." | |
219 | (let* ((pset (parse-property-set lexer)) | |
220 | (location (file-location lexer))) | |
221 | (cond ((declaration-specifier-p lexer) | |
222 | (let ((declspec (parse-c-type lexer))) | |
223 | (multiple-value-bind (type name) | |
224 | (parse-c-declarator lexer declspec :dottedp t) | |
225 | (cond ((null type) | |
226 | nil) | |
227 | ((consp name) | |
228 | (parse-method type (car name) (cdr name) | |
229 | pset location)) | |
230 | ((typep type 'c-function-type) | |
231 | (parse-message type name pset location)) | |
232 | (t | |
233 | (parse-slots declspec type name | |
234 | pset location)))))) | |
235 | ((not (eq (token-type lexer) :id)) | |
236 | (cerror* "Expected <class-item>; found ~A (skipped)" | |
237 | (format-token lexer)) | |
238 | (next-token lexer)) | |
239 | ((string= (token-value lexer) "class") | |
240 | (next-token lexer) | |
241 | (parse-initializers #'make-sod-class-initializer | |
242 | pset location)) | |
243 | (t | |
244 | (parse-initializers #'make-sod-instance-initializer | |
245 | pset location))))) | |
246 | ||
247 | (parse-method (type nick name pset location) | |
248 | "class-item ::= declspec+ dotted-declarator -!- method-body | |
249 | ||
250 | method-body ::= `{' c-fragment `}' | `extern' `;' | |
251 | ||
252 | The dotted-declarator must describe a function type." | |
253 | (let ((body (cond ((eq (token-type lexer) #\{) | |
254 | (prog1 (scan-c-fragment lexer '(#\})) | |
255 | (next-token lexer) | |
256 | (require-token lexer #\}))) | |
257 | ((and (eq (token-type lexer) :id) | |
258 | (string= (token-value lexer) | |
259 | "extern")) | |
260 | (next-token lexer) | |
261 | (require-token lexer #\;) | |
262 | nil) | |
263 | (t | |
264 | (cerror* "Expected <method-body>; ~ | |
265 | found ~A" | |
266 | (format-token lexer)))))) | |
267 | (make-sod-method class nick name type body pset location))) | |
268 | ||
269 | (parse-message (type name pset location) | |
270 | "class-item ::= declspec+ declarator -!- (method-body | `;') | |
271 | ||
272 | The declarator must describe a function type." | |
273 | (make-sod-message class name type pset location) | |
274 | (unless (require-token lexer #\; :errorp nil) | |
275 | (parse-method type nick name nil location))) | |
276 | ||
277 | (parse-initializer-body () | |
278 | "initializer ::= `=' `{' c-fragment `}' | `=' c-fragment" | |
279 | (let ((char (lexer-char lexer))) | |
280 | (loop | |
281 | (when (or (null char) (not (whitespace-char-p char))) | |
282 | (return)) | |
283 | (setf char (next-char lexer))) | |
284 | (cond ((eql char #\{) | |
285 | (next-char lexer) | |
286 | (let ((frag (scan-c-fragment lexer '(#\})))) | |
287 | (next-token lexer) | |
288 | (require-token lexer #\}) | |
289 | (values :compound frag))) | |
290 | (t | |
291 | (let ((frag (scan-c-fragment lexer '(#\, #\;)))) | |
292 | (next-token lexer) | |
293 | (values :simple frag)))))) | |
294 | ||
295 | (parse-slots (declspec type name pset location) | |
296 | "class-item ::= | |
297 | declspec+ init-declarator [`,' init-declarator-list] `;' | |
298 | ||
299 | init-declarator ::= declarator -!- [initializer]" | |
300 | (loop | |
301 | (make-sod-slot class name type pset location) | |
302 | (when (eql (token-type lexer) #\=) | |
303 | (multiple-value-bind (kind form) (parse-initializer-body) | |
304 | (make-sod-instance-initializer class nick name | |
305 | kind form nil | |
306 | location))) | |
307 | (unless (require-token lexer #\, :errorp nil) | |
308 | (return)) | |
309 | (setf (values type name) | |
310 | (parse-c-declarator lexer declspec) | |
311 | location (file-location lexer))) | |
312 | (require-token lexer #\;)) | |
313 | ||
314 | (parse-initializers (constructor pset location) | |
315 | "class-item ::= [`class'] -!- slot-initializer-list `;' | |
316 | ||
317 | slot-initializer ::= id `.' id initializer" | |
318 | (loop | |
319 | (let ((nick (prog1 (require-token lexer :id) | |
320 | (require-token lexer #\.))) | |
321 | (name (require-token lexer :id))) | |
322 | (require-token lexer #\=) | |
323 | (multiple-value-bind (kind form) | |
324 | (parse-initializer-body) | |
325 | (funcall constructor class nick name kind form | |
326 | pset location))) | |
327 | (unless (require-token lexer #\, :errorp nil) | |
328 | (return)) | |
329 | (setf location (file-location lexer))) | |
330 | (require-token lexer #\;))) | |
331 | ||
332 | (loop | |
333 | (when (require-token lexer #\} :errorp nil) | |
334 | (return)) | |
335 | (parse-item))) | |
336 | ||
337 | (finalize-sod-class class) | |
338 | (add-to-module *module* class))) | |
339 | ||
abdf50aa | 340 | ;;;----- That's all, folks -------------------------------------------------- |