Commit | Line | Data |
---|---|---|
bf090e02 MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Top-level parser for module syntax | |
4 | ;;; | |
5 | ;;; (c) 2010 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
10 | ;;; This file is part of the Sensble Object Design, an object system for C. | |
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 | (in-package #:sod) | |
27 | ||
28 | ;;;-------------------------------------------------------------------------- | |
29 | ;;; Toplevel syntax. | |
30 | ||
31 | (export 'module) | |
32 | ||
33 | ;;; Type names. | |
34 | ||
048d0b2d MW |
35 | (define-pluggable-parser module typename (scanner pset) |
36 | ;; `typename' id ( `,' id )* `;' | |
37 | (declare (ignore pset)) | |
bf090e02 MW |
38 | (with-parser-context (token-scanner-context :scanner scanner) |
39 | (parse (and "typename" | |
40 | (skip-many (:min 1) | |
41 | (seq ((id :id)) | |
42 | (if (gethash id *module-type-map*) | |
43 | (cerror* "Type `~A' already defined" id) | |
44 | (add-to-module *module* | |
45 | (make-instance 'type-item | |
46 | :name id)))) | |
47 | #\,) | |
48 | #\;)))) | |
49 | ||
50 | ;;; Fragments. | |
51 | ||
048d0b2d MW |
52 | (define-pluggable-parser module code (scanner pset) |
53 | ;; `code' id `:' id [constraints] `{' c-fragment `}' | |
54 | ;; | |
55 | ;; constrains ::= `[' constraint-list `]' | |
56 | ;; constraint ::= id+ | |
57 | (declare (ignore pset)) | |
bf090e02 MW |
58 | (with-parser-context (token-scanner-context :scanner scanner) |
59 | (parse (seq ("code" | |
60 | (reason :id) | |
61 | #\: | |
62 | (name :id) | |
63 | (constraints (? (seq (#\[ | |
64 | (constraints (list (:min 1) | |
65 | (list (:min 1) :id) | |
66 | #\,)) | |
67 | #\]) | |
68 | constraints))) | |
69 | (fragment (parse-delimited-fragment scanner #\{ #\}))) | |
70 | (add-to-module *module* (make-instance 'code-fragment-item | |
71 | :fragment fragment | |
72 | :constraints constraints | |
73 | :reason reason | |
74 | :name name)))))) | |
75 | ||
76 | ;;; External files. | |
77 | ||
78 | (defun read-module (pathname &key (truename (truename pathname)) location) | |
79 | "Parse the file at PATHNAME as a module, returning it. | |
80 | ||
81 | This is the main entry point for parsing module files. You may well know | |
82 | the file's TRUENAME already (e.g., because `probe-file' dropped it into | |
83 | your lap) so you can avoid repeating the search by providing it. | |
84 | ||
85 | The LOCATION is the thing which wanted the module imported -- usually a | |
86 | `file-location' object, though it might be anything other than `t' which | |
87 | can be printed in the event of circular imports." | |
88 | ||
89 | (define-module (pathname :location location :truename truename) | |
90 | (with-open-file (f-stream pathname :direction :input) | |
91 | (let* ((*readtable* (copy-readtable)) | |
92 | (char-scanner (make-instance 'charbuf-scanner | |
93 | :stream f-stream)) | |
94 | (scanner (make-instance 'sod-token-scanner | |
95 | :char-scanner char-scanner))) | |
96 | (with-default-error-location (scanner) | |
97 | (with-parser-context (token-scanner-context :scanner scanner) | |
048d0b2d MW |
98 | (parse (skip-many () |
99 | (seq ((pset (parse-property-set scanner)) | |
100 | (nil (error () | |
101 | (plug module scanner pset)))) | |
102 | (check-unused-properties pset)))))))))) | |
103 | ||
104 | (define-pluggable-parser module test (scanner pset) | |
105 | ;; `demo' string `;' | |
106 | (declare (ignore pset)) | |
bf090e02 MW |
107 | (with-parser-context (token-scanner-context :scanner scanner) |
108 | (parse (seq ("demo" (string :string) #\;) | |
109 | (format t ";; DEMO ~S~%" string))))) | |
110 | ||
048d0b2d MW |
111 | (define-pluggable-parser module file (scanner pset) |
112 | ;; `import' string `;' | |
113 | ;; `load' string `;' | |
114 | (declare (ignore pset)) | |
bf090e02 MW |
115 | (flet ((common (name type what thunk) |
116 | (find-file scanner | |
117 | (merge-pathnames name | |
118 | (make-pathname :type type | |
119 | :case :common)) | |
120 | what | |
121 | thunk))) | |
122 | (with-parser-context (token-scanner-context :scanner scanner) | |
123 | (parse (or (seq ("import" (name :string) #\;) | |
124 | (common name "SOD" "module" | |
125 | (lambda (path true) | |
126 | (handler-case | |
127 | (let ((module (read-module path | |
128 | :truename true))) | |
129 | (when module | |
130 | (module-import module) | |
131 | (pushnew module | |
132 | (module-dependencies | |
133 | *module*)))) | |
134 | (file-error (error) | |
135 | (cerror* "Error reading module ~S: ~A" | |
136 | path error)))))) | |
137 | (seq ("load" (name :string) #\;) | |
138 | (common name "LISP" "Lisp file" | |
139 | (lambda (path true) | |
140 | (handler-case | |
141 | (load true :verbose nil :print nil) | |
142 | (error (error) | |
143 | (cerror* "Error loading Lisp file ~S: ~A" | |
144 | path error))))))))))) | |
145 | ||
146 | ;;; Lisp escape. | |
147 | ||
048d0b2d | 148 | (define-pluggable-parser module lisp (scanner pset) |
bf090e02 | 149 | ;; `lisp' s-expression `;' |
048d0b2d | 150 | (declare (ignore pset)) |
bf090e02 MW |
151 | (with-parser-context (token-scanner-context :scanner scanner) |
152 | (parse (seq ((sexp (if (and (eql (token-type scanner) :id) | |
153 | (string= (token-value scanner) "lisp")) | |
154 | (let* ((stream (make-scanner-stream scanner)) | |
155 | (sexp (read stream t))) | |
156 | (scanner-step scanner) | |
157 | (values sexp t t)) | |
158 | (values '((:id "lisp")) nil nil))) | |
159 | #\;) | |
160 | (eval sexp))))) | |
161 | ||
162 | ;;;-------------------------------------------------------------------------- | |
163 | ;;; Class declarations. | |
164 | ||
048d0b2d | 165 | (defun parse-class-body (scanner pset name supers) |
c91b90c3 | 166 | ;; class-body ::= `{' class-item* `}' |
048d0b2d MW |
167 | ;; |
168 | ;; class-item ::= property-set raw-class-item | |
c91b90c3 MW |
169 | (with-parser-context (token-scanner-context :scanner scanner) |
170 | (make-class-type name) | |
048d0b2d | 171 | (let* ((class (make-sod-class name (mapcar #'find-sod-class supers) |
c91b90c3 MW |
172 | pset scanner)) |
173 | (nick (sod-class-nickname class))) | |
174 | ||
175 | (labels ((parse-maybe-dotted-declarator (base-type) | |
176 | ;; Parse a declarator or dotted-declarator, i.e., one whose | |
177 | ;; centre is | |
178 | ;; | |
179 | ;; maybe-dotted-identifier ::= [id `.'] id | |
180 | ;; | |
181 | ;; A plain identifier is returned as a string, as usual; a | |
182 | ;; dotted identifier is returned as a cons cell of the two | |
183 | ;; names. | |
184 | (parse-declarator | |
185 | scanner base-type | |
ea578bb4 | 186 | :kernel (parser () |
c91b90c3 MW |
187 | (seq ((name-a :id) |
188 | (name-b (? (seq (#\. (id :id)) id)))) | |
189 | (if name-b (cons name-a name-b) | |
190 | name-a))))) | |
191 | ||
c91b90c3 MW |
192 | (parse-message-item (sub-pset type name) |
193 | ;; message-item ::= | |
194 | ;; declspec+ declarator -!- (method-body | `;') | |
195 | (make-sod-message class name type sub-pset scanner) | |
048d0b2d MW |
196 | (parse (or #\; (parse-method-item sub-pset |
197 | type nick name)))) | |
c91b90c3 MW |
198 | |
199 | (parse-method-item (sub-pset type sub-nick name) | |
200 | ;; method-item ::= | |
201 | ;; declspec+ dotted-declarator -!- method-body | |
202 | ;; | |
203 | ;; method-body ::= `{' c-fragment `}' | `extern' `;' | |
204 | (parse (seq ((body (or (seq ("extern" #\;) nil) | |
205 | (parse-delimited-fragment | |
206 | scanner #\{ #\})))) | |
207 | (make-sod-method class sub-nick name type | |
208 | body sub-pset scanner)))) | |
209 | ||
210 | (parse-initializer () | |
211 | ;; initializer ::= `=' c-fragment | `=' `{' c-fragment `}' | |
212 | ;; | |
213 | ;; Return (VALUE-KIND . VALUE-FORM), ready for passing to a | |
214 | ;; `sod-initializer' constructor. | |
215 | (parse (or (peek (seq (#\= (frag (parse-delimited-fragment | |
216 | scanner #\{ #\}))) | |
217 | (cons :compound frag))) | |
218 | (seq ((frag (parse-delimited-fragment | |
219 | scanner #\= '(#\; #\,) | |
220 | :keep-end t))) | |
221 | (cons :simple frag))))) | |
222 | ||
223 | (parse-slot-item (sub-pset base-type type name) | |
224 | ;; slot-item ::= | |
225 | ;; declspec+ declarator -!- [initializer] | |
226 | ;; [`,' init-declarator-list] `;' | |
227 | ;; | |
228 | ;; init-declarator-list ::= | |
229 | ;; declarator [initializer] [`,' init-declarator-list] | |
230 | (parse (and (seq ((init (? (parse-initializer)))) | |
231 | (make-sod-slot class name type | |
232 | sub-pset scanner) | |
233 | (when init | |
234 | (make-sod-instance-initializer | |
235 | class nick name (car init) (cdr init) | |
048d0b2d | 236 | sub-pset scanner))) |
c91b90c3 MW |
237 | (skip-many () |
238 | (seq (#\, | |
239 | (ds (parse-declarator scanner | |
240 | base-type)) | |
241 | (init (? (parse-initializer)))) | |
242 | (make-sod-slot class (cdr ds) (car ds) | |
243 | sub-pset scanner) | |
244 | (when init | |
245 | (make-sod-instance-initializer | |
246 | class nick (cdr ds) | |
247 | (car init) (cdr init) | |
048d0b2d | 248 | sub-pset scanner)))) |
c91b90c3 MW |
249 | #\;))) |
250 | ||
251 | (parse-initializer-item (sub-pset constructor) | |
252 | ;; initializer-item ::= | |
253 | ;; [`class'] -!- slot-initializer-list `;' | |
254 | ;; | |
255 | ;; slot-initializer ::= id `.' id initializer | |
256 | (parse (and (skip-many () | |
257 | (seq ((name-a :id) #\. (name-b :id) | |
258 | (init (parse-initializer))) | |
259 | (funcall constructor class | |
260 | name-a name-b | |
261 | (car init) (cdr init) | |
262 | sub-pset scanner)) | |
263 | #\,) | |
264 | #\;))) | |
265 | ||
266 | (class-item-dispatch (sub-pset base-type type name) | |
267 | ;; Logically part of `parse-raw-class-item', but the | |
268 | ;; indentation was getting crazy. We're currently at | |
269 | ;; | |
270 | ;; raw-class-item ::= | |
271 | ;; declspec+ (declarator | dotted-declarator) -!- ... | |
272 | ;; | other-items | |
273 | ;; | |
274 | ;; If the declarator is dotted then this must be a method | |
275 | ;; definition; otherwise it might be a message or slot. | |
276 | (cond ((not (typep type 'c-function-type)) | |
277 | (when (consp name) | |
278 | (cerror*-with-location | |
279 | scanner | |
280 | "Method declarations must have function type.") | |
281 | (setf name (cdr name))) | |
282 | (parse-slot-item sub-pset base-type type name)) | |
283 | ((consp name) | |
284 | (parse-method-item sub-pset type | |
285 | (car name) (cdr name))) | |
286 | (t | |
287 | (parse-message-item sub-pset type name)))) | |
288 | ||
289 | (parse-raw-class-item (sub-pset) | |
290 | ;; raw-class-item ::= | |
291 | ;; message-item | |
292 | ;; | method-item | |
293 | ;; | slot-item | |
294 | ;; | initializer-item | |
295 | ;; | |
296 | ;; Most of the above begin with declspecs and a declarator | |
297 | ;; (which might be dotted). So we parse that here and | |
298 | ;; dispatch based on what we find. | |
048d0b2d MW |
299 | (parse (or (plug class-item scanner class sub-pset) |
300 | (peek | |
c91b90c3 MW |
301 | (seq ((ds (parse-c-type scanner)) |
302 | (dc (parse-maybe-dotted-declarator ds)) | |
048d0b2d MW |
303 | (nil (class-item-dispatch sub-pset |
304 | ds | |
305 | (car dc) | |
306 | (cdr dc)))))) | |
c91b90c3 MW |
307 | (and "class" |
308 | (parse-initializer-item | |
309 | sub-pset | |
310 | #'make-sod-class-initializer)) | |
311 | (parse-initializer-item | |
312 | sub-pset | |
313 | #'make-sod-instance-initializer))))) | |
314 | ||
048d0b2d MW |
315 | (parse (seq (#\{ |
316 | (nil (skip-many () | |
317 | (seq ((sub-pset (parse-property-set scanner)) | |
318 | (nil (error () | |
319 | (parse-raw-class-item sub-pset)))) | |
320 | (check-unused-properties sub-pset)))) | |
321 | #\}) | |
322 | (finalize-sod-class class) | |
323 | (add-to-module *module* class))))))) | |
324 | ||
325 | (define-pluggable-parser module class (scanner pset) | |
c91b90c3 MW |
326 | ;; `class' id [`:' id-list] class-body |
327 | ;; `class' id `;' | |
bf090e02 | 328 | (with-parser-context (token-scanner-context :scanner scanner) |
c91b90c3 MW |
329 | (parse (seq ("class" |
330 | (name :id) | |
331 | (nil (or (seq (#\;) | |
332 | (make-class-type name)) | |
333 | (seq ((supers (? (seq (#\: (ids (list () :id #\,))) | |
334 | ids))) | |
335 | (nil (parse-class-body | |
336 | scanner | |
337 | pset name supers))))))))))) | |
338 | ||
bf090e02 | 339 | ;;;----- That's all, folks -------------------------------------------------- |