Commit | Line | Data |
---|---|---|
abdf50aa MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Collections of properties | |
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 | ;;;-------------------------------------------------------------------------- | |
77027cca | 29 | ;;; Expression parser. |
abdf50aa MW |
30 | |
31 | (defun parse-expression (lexer) | |
32 | "Parse an expression from the LEXER. | |
33 | ||
1f1d88f5 MW |
34 | The return values are the expression's VALUE and TYPE; currently the types |
35 | are :ID, :INTEGER, :STRING, and :CHAR. If an error prevented a sane value | |
abdf50aa MW |
36 | being produced, the TYPE :INVALID is returned. |
37 | ||
38 | Expression syntax is rather limited at the moment: | |
39 | ||
40 | expression : term | expression `+' term | expression `-' term | |
41 | term : factor | term `*' factor | term `/' factor | |
42 | factor : primary | `+' factor | `-' factor | |
43 | primary : integer | identifier | string | |
44 | | `(' expression `)' | |
45 | | `?' lisp-expression | |
46 | ||
47 | Identifiers are just standalone things. They don't name values. The | |
48 | operators only work on integer values at the moment. (Confusingly, you | |
49 | can manufacture rational numbers using the division operator, but they | |
50 | still get called integers.)" | |
51 | ||
52 | (let ((valstack nil) | |
53 | (opstack nil)) | |
54 | ||
55 | ;; The following is a simple operator-precedence parser: the | |
56 | ;; recursive-descent parser I wrote the first time was about twice the | |
57 | ;; size and harder to extend. | |
58 | ;; | |
59 | ;; The parser flips between two states, OPERAND and OPERATOR. It starts | |
60 | ;; out in OPERAND state, and tries to parse a sequence of prefix | |
61 | ;; operators followed by a primary expression. Once it's found one, it | |
62 | ;; pushes the operand onto the value stack and flips to OPERATOR state; | |
63 | ;; if it fails, it reports a syntax error and exits. The OPERAND state | |
64 | ;; tries to read a sequence of postfix operators followed by an infix | |
65 | ;; operator; if it fails, it assumes that it hit the stuff following the | |
66 | ;; expression and stops. | |
67 | ;; | |
68 | ;; Each operator is pushed onto a stack consisting of lists of the form | |
69 | ;; (FUNC PREC TY*). The PREC is a precedence -- higher numbers mean | |
70 | ;; tighter binding. The TY* are operand types; operands are popped off | |
71 | ;; the operand stack, checked against the requested types, and passed to | |
72 | ;; the FUNC, which returns a new operand to be pushed in their place. | |
73 | ;; | |
74 | ;; Usually, when a binary operator is pushed, existing stacked operators | |
75 | ;; with higher precedence are applied. Whether operators with /equal/ | |
76 | ;; precedence are also applied depends on the associativity of the | |
77 | ;; operator: apply equal precedence operators for left-associative | |
78 | ;; operators, don't apply for right-associative. When we reach the end | |
79 | ;; of the expression, all the remaining operators on the stack are | |
80 | ;; applied. | |
81 | ;; | |
82 | ;; Parenthesized subexpressions are implemented using a hack: when we | |
83 | ;; find an open paren in operand position, a fake operator is pushed with | |
84 | ;; an artificially low precedece, which protects the operators beneath | |
85 | ;; from premature application. The fake operator's function reports an | |
86 | ;; error -- this will be triggered only if we reach the end of the | |
87 | ;; expression before a matching close-paren, because the close-paren | |
88 | ;; handler will pop the fake operator before it does any harm. | |
89 | ||
90 | (restart-case | |
91 | (labels ((apply-op (op) | |
92 | ;; Apply the single operator list OP to the values on the | |
93 | ;; value stack. | |
94 | (let ((func (pop op)) | |
95 | (args nil)) | |
96 | (dolist (ty (reverse (cdr op))) | |
97 | (let ((arg (pop valstack))) | |
98 | (cond ((eq (car arg) :invalid) | |
99 | (setf func nil)) | |
100 | ((eq (car arg) ty) | |
101 | (push (cdr arg) args)) | |
102 | (t | |
103 | (cerror* "Type mismatch: wanted ~A; found ~A" | |
104 | ty (car arg)) | |
105 | (setf func nil))))) | |
106 | (if func | |
107 | (multiple-value-bind (type value) (apply func args) | |
108 | (push (cons type value) valstack)) | |
109 | (push '(:invalid . nil) valstack)))) | |
110 | ||
111 | (apply-all (prec) | |
112 | ;; Apply all operators with precedence PREC or higher. | |
113 | (loop | |
114 | (when (or (null opstack) (< (cadar opstack) prec)) | |
115 | (return)) | |
116 | (apply-op (pop opstack))))) | |
117 | ||
118 | (tagbody | |
119 | ||
120 | operand | |
121 | ;; Operand state. Push prefix operators, and try to read a | |
122 | ;; primary operand. | |
123 | (case (token-type lexer) | |
124 | ||
125 | ;; Aha. A primary. Push it onto the stack, and see if | |
126 | ;; there's an infix operator. | |
1f1d88f5 | 127 | ((:integer :id :string :char) |
abdf50aa MW |
128 | (push (cons (token-type lexer) |
129 | (token-value lexer)) | |
130 | valstack) | |
131 | (go operator)) | |
132 | ||
133 | ;; Look for a Lisp S-expression. | |
134 | (#\? | |
135 | (with-lexer-stream (stream lexer) | |
136 | (let ((value (eval (read stream t)))) | |
137 | (push (cons (property-type value) value) valstack))) | |
138 | (go operator)) | |
139 | ||
140 | ;; Arithmetic unary operators. Push an operator for `+' for | |
141 | ;; the sake of type-checking. | |
142 | (#\+ | |
143 | (push (list (lambda (x) (values :integer x)) | |
144 | 10 :integer) | |
145 | opstack)) | |
146 | (#\- | |
147 | (push (list (lambda (x) (values :integer (- x))) | |
148 | 10 :integer) | |
149 | opstack)) | |
150 | ||
151 | ;; The open-paren hack. Push a magic marker which will | |
152 | ;; trigger an error if we hit the end of the expression. | |
153 | ;; Inside the paren, we're still looking for an operand. | |
154 | (#\( | |
155 | (push (list (lambda () | |
156 | (error "Expected `)' but found ~A" | |
157 | (format-token lexer))) | |
158 | -1) | |
159 | opstack)) | |
160 | ||
161 | ;; Failed to find anything. Report an error and give up. | |
162 | (t | |
163 | (error "Expected expression but found ~A" | |
164 | (format-token lexer)))) | |
165 | ||
166 | ;; Assume prefix operators as the default, so go round for more. | |
167 | (next-token lexer) | |
168 | (go operand) | |
169 | ||
170 | operator | |
171 | ;; Operator state. Push postfix operators, and try to read an | |
172 | ;; infix operator. It turns out that we're always a token | |
173 | ;; behind here, so catch up. | |
174 | (next-token lexer) | |
175 | (case (token-type lexer) | |
176 | ||
177 | ;; Binary operators. | |
178 | (#\+ (apply-all 3) | |
179 | (push (list (lambda (x y) (values :integer (+ x y))) | |
180 | 3 :integer :integer) | |
181 | opstack)) | |
182 | (#\- (apply-all 3) | |
183 | (push (list (lambda (x y) (values :integer (- x y))) | |
184 | 3 :integer :integer) | |
185 | opstack)) | |
186 | (#\* (apply-all 5) | |
187 | (push (list (lambda (x y) (values :integer (* x y))) | |
188 | 5 :integer :integer) | |
189 | opstack)) | |
190 | (#\/ (apply-all 5) | |
191 | (push (list (lambda (x y) | |
192 | (if (zerop y) | |
193 | (progn (cerror* "Division by zero") | |
194 | (values nil :invalid)) | |
195 | (values (/ x y) :integer))) | |
196 | 5 :integer :integer) | |
197 | opstack)) | |
198 | ||
199 | ;; The close-paren hack. Finish off the operators pushed | |
200 | ;; since the open-paren. If the operator stack is now empty, | |
201 | ;; this is someone else's paren, so exit. Otherwise pop our | |
202 | ;; magic marker, and continue looking for an operator. | |
203 | (#\) (apply-all 0) | |
204 | (when (null opstack) | |
205 | (go done)) | |
206 | (pop opstack) | |
207 | (go operator)) | |
208 | ||
209 | ;; Nothing useful. Must have hit the end, so leave. | |
210 | (t (go done))) | |
211 | ||
212 | ;; Assume we found the binary operator as a default, so snarf a | |
213 | ;; token and head back. | |
214 | (next-token lexer) | |
215 | (go operand) | |
216 | ||
217 | done) | |
218 | ||
219 | ;; Apply all the pending operators. If there's an unmatched | |
220 | ;; open paren, this will trigger the error message. | |
221 | (apply-all -99) | |
222 | ||
223 | ;; If everything worked out, we should have exactly one operand | |
224 | ;; left. This is the one we want. | |
225 | (assert (and (consp valstack) | |
226 | (null (cdr valstack)))) | |
227 | (values (cdar valstack) (caar valstack))) | |
228 | (continue () | |
77027cca | 229 | :report "Return an invalid value and continue." |
abdf50aa MW |
230 | (values nil :invalid))))) |
231 | ||
77027cca MW |
232 | ;;;-------------------------------------------------------------------------- |
233 | ;;; Property set parsing. | |
234 | ||
235 | (defun parse-property (lexer pset) | |
236 | "Parse a single property from LEXER; add it to PSET." | |
237 | (let ((name (require-token lexer :id))) | |
238 | (require-token lexer #\=) | |
239 | (multiple-value-bind (value type) (parse-expression lexer) | |
240 | (unless (eq type :invalid) | |
241 | (add-property pset name value :type type :location lexer))))) | |
242 | ||
abdf50aa MW |
243 | (defun parse-property-set (lexer) |
244 | "Parse a property set from LEXER. | |
245 | ||
246 | If there wasn't one to parse, return nil; this isn't considered an error, | |
247 | and GET-PROPERTY will perfectly happily report defaults for all requested | |
248 | properties." | |
249 | ||
77027cca MW |
250 | (when (require-token lexer #\[ :errorp nil) |
251 | (let ((pset (make-pset))) | |
abdf50aa | 252 | (loop |
77027cca | 253 | (parse-property lexer pset) |
abdf50aa MW |
254 | (unless (require-token lexer #\, :errorp nil) |
255 | (return))) | |
256 | (require-token lexer #\]) | |
77027cca | 257 | pset))) |
abdf50aa MW |
258 | |
259 | ;;;-------------------------------------------------------------------------- | |
260 | ;;; Testing cruft. | |
261 | ||
262 | #+test | |
77027cca | 263 | (with-input-from-string (raw "[role = before, integer = 42 * (3 - 1)]") |
abdf50aa MW |
264 | (let* ((in (make-instance 'position-aware-input-stream :stream raw)) |
265 | (lexer (make-instance 'sod-lexer :stream in))) | |
266 | (next-char lexer) | |
267 | (next-token lexer) | |
268 | (multiple-value-call #'values | |
269 | (parse-property-set lexer) | |
270 | (token-type lexer)))) | |
271 | ||
272 | ;;;----- That's all, folks -------------------------------------------------- |