Commit | Line | Data |
---|---|---|
bf090e02 MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Parsing property sets | |
4 | ;;; | |
5 | ;;; (c) 2012 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
e0808c47 | 10 | ;;; This file is part of the Sensible Object Design, an object system for C. |
bf090e02 MW |
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 | ||
c91b90c3 MW |
26 | (in-package #:sod) |
27 | ||
239fa5bd MW |
28 | ;;;-------------------------------------------------------------------------- |
29 | ;;; The expression parser. | |
30 | ||
0ee8826a MW |
31 | (defun parse-expression (scanner) |
32 | "Parse and evaluate a simple expression. | |
bf090e02 MW |
33 | |
34 | The result is a pair (TYPE . VALUE). Currently, type types are `:id', | |
288c7651 MW |
35 | `:int', `:string', `:char', `:fragment', `:type'. If an error prevented a |
36 | sane value from being produced, the type `:invalid' is returned. | |
bf090e02 MW |
37 | |
38 | The syntax of expressions is rather limited at the moment, but more may be | |
39 | added later. | |
40 | ||
41 | expression: term | expression `+' term | expression `-' term | |
42 | term: factor | term `*' factor | term `/' factor | |
43 | factor: primary | `+' factor | `-' factor | |
dbac800b | 44 | primary: int | id | string | `(' expression `)' | `{' fragment `}' |
6ee19709 | 45 | | `<' declspec+ declarator[empty] `>' | `?' lisp-expression |
bf090e02 MW |
46 | |
47 | Only operators for dealing with integers are provided." | |
0ee8826a | 48 | |
7469d31e MW |
49 | ;; The expression parser works in two stages. First, the parser proper |
50 | ;; builds a thunk as its `value'. If this is successful, then the thunk is | |
51 | ;; invoked to return a property type and value. Primitive expressions | |
52 | ;; produce thunks which just return their values; operators combine their | |
53 | ;; argument thunks together, evaluating them (or not) on demand. | |
54 | ||
55 | (macrolet ((oplambda (&body body) | |
56 | ;; Like `lambda', but (a) always produces a function with no | |
57 | ;; arguments, and (b) captures the current location so that | |
58 | ;; errors are attributed correctly. | |
59 | ||
60 | (with-gensyms (floc) | |
61 | `(let ((,floc (file-location scanner))) | |
62 | (lambda () | |
63 | (with-default-error-location (,floc) | |
64 | ,@body)))))) | |
65 | ||
4979de88 MW |
66 | (labels ((want (type thunk) |
67 | ;; Evaluate THUNK and convert its result to the given TYPE. | |
68 | (multiple-value-bind (ty val) (funcall thunk) | |
69 | (coerce-property-value val ty type))) | |
70 | ||
71 | (int-unop (intop x) | |
72 | ;; Evaluate X to an integer, and apply INTOP to the result, | |
73 | ;; giving another integer. | |
74 | (oplambda (values :int (funcall intop (want :int x))))) | |
75 | ||
76 | (int-binop (intop x y) | |
77 | ;; Evaluate X and Y to integers, and apply INTOP to the | |
78 | ;; results, giving another integer. | |
79 | (oplambda | |
fe471148 MW |
80 | (values :int (funcall intop (want :int x) (want :int y))))) |
81 | ||
82 | (compareop (intop strop x y) | |
83 | ;; Evaluate X and Y. If they're integers, then apply INTOP to | |
84 | ;; them; if they're strings, apply STROP. The result is a | |
85 | ;; boolean. | |
86 | (oplambda | |
87 | (multiple-value-bind (xty xval) (funcall x) | |
88 | (case xty | |
89 | (:int | |
90 | (values :boolean | |
91 | (funcall intop xval (want :int y)))) | |
92 | ((:id :string :symbol) | |
93 | (values :boolean | |
94 | (funcall strop | |
95 | (coerce-property-value xval xty :id) | |
96 | (want :id y)))) | |
97 | (t | |
98 | (error "Can't compare objects of type ~(~A~)" xty))))))) | |
7469d31e MW |
99 | |
100 | (with-parser-context (token-scanner-context :scanner scanner) | |
101 | (when-parse () | |
102 | ||
103 | ;; Parse the expression, producing a thunk. | |
104 | (expr (:nestedp nestedp) | |
5eeb83d2 | 105 | |
7469d31e | 106 | (lisp (case (token-type scanner) |
5eeb83d2 | 107 | |
7469d31e | 108 | ((:int :id :char :string) |
5eeb83d2 | 109 | ;; A simple literal. |
7469d31e MW |
110 | (let ((type (token-type scanner)) |
111 | (value (token-value scanner))) | |
112 | (scanner-step scanner) | |
113 | (values (lambda () (values type value)) t t))) | |
5eeb83d2 | 114 | |
7469d31e | 115 | (#\? |
5eeb83d2 MW |
116 | ;; A Lisp s-expression. Catch and report reader- |
117 | ;; errors (though the main parser will probably | |
118 | ;; end up /very/ confused); delay evaluation for | |
119 | ;; later. | |
7469d31e MW |
120 | (handler-case |
121 | (let* ((stream (make-scanner-stream scanner)) | |
122 | (sexp (read stream t))) | |
123 | (scanner-step scanner) | |
124 | (values (oplambda (decode-property (eval sexp))) | |
125 | t t)) | |
126 | (error (cond) | |
127 | (scanner-step scanner) | |
128 | (cerror*-with-location scanner | |
129 | "Lisp `read' error: ~A" | |
130 | cond) | |
131 | (values #'continue t t)))) | |
5eeb83d2 | 132 | |
7469d31e | 133 | (#\{ |
5eeb83d2 | 134 | ;; A code fragment. |
7469d31e MW |
135 | (let ((fragment (parse-delimited-fragment scanner |
136 | #\{ #\}))) | |
137 | (values (lambda () (values :fragment fragment)) | |
138 | t t))) | |
5eeb83d2 | 139 | |
7469d31e | 140 | (#\< |
5eeb83d2 | 141 | ;; A C type. |
7469d31e MW |
142 | (parse (seq (#\< |
143 | (ds (parse-c-type scanner)) | |
144 | (dc (parse-declarator | |
145 | scanner ds | |
146 | :kernel (lambda () | |
147 | (values nil t nil)) | |
148 | :abstractp t)) | |
149 | #\>) | |
150 | (values (lambda () (values :type (car dc))) | |
151 | t t)))) | |
5eeb83d2 | 152 | |
7469d31e | 153 | (t |
5eeb83d2 | 154 | ;; Anything else is an error. |
7469d31e MW |
155 | (values (list :int :id :char :string #\? #\{ #\<) |
156 | nil nil)))) | |
157 | ||
5eeb83d2 | 158 | ;; Binary operators. |
4979de88 MW |
159 | ((:op #\* binop "*" (x y 70) (int-binop #'* x y)) |
160 | (:op #\/ binop "/" (x y 70) | |
161 | (oplambda | |
162 | (let ((x (want :int x)) (y (want :int y))) | |
163 | (when (zerop y) (error "Division by zero")) | |
164 | (values :int (floor x y))))) | |
165 | (:op #\+ binop "+" (x y 60) (int-binop #'+ x y)) | |
fe471148 MW |
166 | (:op #\- binop "-" (x y 60) (int-binop #'- x y)) |
167 | (:op :shl binop "<<" (x y 50) (int-binop #'ash x y)) | |
168 | (:op :shr binop ">>" (x y 50) | |
169 | (int-binop (lambda (x y) (ash x (- y))) x y)) | |
170 | (:op #\< binop "<" (x y 45) | |
171 | (compareop #'< #'string< x y)) | |
172 | (:op :le binop "<=" (x y 45) | |
173 | (compareop #'<= #'string<= x y)) | |
174 | (:op :ge binop ">=" (x y 45) | |
175 | (compareop #'>= #'string>= x y)) | |
176 | (:op #\> binop ">" (x y 45) | |
177 | (compareop #'> #'string> x y)) | |
178 | (:op :eq binop "==" (x y 40) | |
179 | (compareop #'= #'string= x y)) | |
180 | (:op :ne binop "!=" (x y 40) | |
181 | (compareop #'/= #'string/= x y)) | |
182 | (:op #\& binop "&" (x y 37) (int-binop #'logand x y)) | |
183 | (:op #\^ binop "^" (x y 35) (int-binop #'logxor x y)) | |
184 | (:op #\| binop "|" (x y 32) (int-binop #'logior x y)) | |
185 | (:op :and binop "&&" (x y 27) | |
186 | (oplambda (if (want :boolean x) (funcall y) | |
187 | (values :boolean nil)))) | |
188 | (:op :or binop "||" (x y 22) | |
189 | (oplambda | |
190 | (multiple-value-bind (xty xval) (funcall x) | |
191 | (if (coerce-property-value xval xty :boolean) | |
192 | (values xty xval) | |
193 | (funcall y)))))) | |
7469d31e | 194 | |
5eeb83d2 | 195 | ;; Prefix operators. |
fe471148 MW |
196 | ((:op #\~ preop "~" (x 90) (int-unop #'lognot x)) |
197 | (:op #\! preop "!" (x 90) | |
198 | (oplambda | |
199 | (values :boolean | |
200 | (not (want :boolean (funcall x)))))) | |
201 | (:op #\+ preop "+" (x 90) (int-unop #'identity x)) | |
4979de88 | 202 | (:op #\- preop "-" (x 90) (int-unop #'- x)) |
7469d31e MW |
203 | (:op #\( lparen #\))) |
204 | ||
5eeb83d2 | 205 | ;; Postfix operators. |
7469d31e MW |
206 | ((:op (when nestedp #\)) rparen #\)))) |
207 | ||
208 | ;; Do the delayed evaluation. Establish a restart so that we can | |
209 | ;; continue if evaluation fails for some reason. (The value thunk | |
210 | ;; is expected to report the correct error locations, if it signals | |
211 | ;; conditions.) | |
212 | (restart-case (multiple-value-bind (type value) (funcall it) | |
213 | (values (cons type value) t t)) | |
214 | (continue () (values (cons :invalid nil) t t)))))))) | |
239fa5bd MW |
215 | |
216 | ;;;-------------------------------------------------------------------------- | |
217 | ;;; Parsing property sets. | |
bf090e02 | 218 | |
b944e68b | 219 | (export 'parse-property) |
bf090e02 MW |
220 | (defun parse-property (scanner pset) |
221 | "Parse a single property using the SCANNER; add it to the PSET." | |
239fa5bd MW |
222 | ;; property ::= id `=' expression |
223 | (with-parser-context (token-scanner-context :scanner scanner) | |
224 | (parse (seq ((name :id) #\= (result (parse-expression scanner))) | |
225 | (let ((type (car result)) | |
226 | (value (cdr result))) | |
227 | (unless (eq type :invalid) | |
228 | (add-property pset name value | |
229 | :type type | |
230 | :location scanner))))))) | |
231 | ||
232 | (export 'parse-property-set) | |
233 | (defun parse-property-set (scanner) | |
c91b90c3 | 234 | "Parse an optional property set from the SCANNER and return it." |
048d0b2d | 235 | ;; property-set ::= [`[' property-list `]'] |
239fa5bd | 236 | (with-parser-context (token-scanner-context :scanner scanner) |
048d0b2d MW |
237 | (parse (? (seq (#\[ |
238 | (pset (many (pset (make-property-set) pset) | |
239 | (error () | |
240 | (parse-property scanner pset) | |
241 | (skip-until () #\, #\])) | |
242 | #\,)) | |
243 | #\]) | |
244 | pset))))) | |
bf090e02 MW |
245 | |
246 | ;;;----- That's all, folks -------------------------------------------------- |