3 ;;; Collections of properties
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 ;;;--------------------------------------------------------------------------
29 ;;; Expression parser.
31 (defun parse-expression (lexer)
32 "Parse an expression from the LEXER.
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
36 being produced, the TYPE :INVALID is returned.
38 Expression syntax is rather limited at the moment:
40 expression : term | expression `+' term | expression `-' term
41 term : factor | term `*' factor | term `/' factor
42 factor : primary | `+' factor | `-' factor
43 primary : integer | identifier | string
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.)"
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.
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.
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.
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
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.
91 (labels ((apply-op (op)
92 ;; Apply the single operator list OP to the values on the
96 (dolist (ty (reverse (cdr op)))
97 (let ((arg (pop valstack)))
98 (cond ((eq (car arg) :invalid)
101 (push (cdr arg) args))
103 (cerror* "Type mismatch: wanted ~A; found ~A"
107 (multiple-value-bind (type value) (apply func args)
108 (push (cons type value) valstack))
109 (push '(:invalid . nil) valstack))))
112 ;; Apply all operators with precedence PREC or higher.
114 (when (or (null opstack) (< (cadar opstack) prec))
116 (apply-op (pop opstack)))))
121 ;; Operand state. Push prefix operators, and try to read a
123 (case (token-type lexer)
125 ;; Aha. A primary. Push it onto the stack, and see if
126 ;; there's an infix operator.
127 ((:integer :id :string :char)
128 (push (cons (token-type lexer)
133 ;; Look for a Lisp S-expression.
135 (with-lexer-stream (stream lexer)
136 (let ((value (eval (read stream t))))
137 (push (cons (property-type value) value) valstack)))
140 ;; Arithmetic unary operators. Push an operator for `+' for
141 ;; the sake of type-checking.
143 (push (list (lambda (x) (values :integer x))
147 (push (list (lambda (x) (values :integer (- x)))
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.
155 (push (list (lambda ()
156 (error "Expected `)' but found ~A"
157 (format-token lexer)))
161 ;; Failed to find anything. Report an error and give up.
163 (error "Expected expression but found ~A"
164 (format-token lexer))))
166 ;; Assume prefix operators as the default, so go round for more.
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.
175 (case (token-type lexer)
179 (push (list (lambda (x y) (values :integer (+ x y)))
183 (push (list (lambda (x y) (values :integer (- x y)))
187 (push (list (lambda (x y) (values :integer (* x y)))
191 (push (list (lambda (x y)
193 (progn (cerror* "Division by zero")
194 (values nil :invalid))
195 (values (/ x y) :integer)))
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.
209 ;; Nothing useful. Must have hit the end, so leave.
212 ;; Assume we found the binary operator as a default, so snarf a
213 ;; token and head back.
219 ;; Apply all the pending operators. If there's an unmatched
220 ;; open paren, this will trigger the error message.
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)))
229 :report "Return an invalid value and continue."
230 (values nil :invalid)))))
232 ;;;--------------------------------------------------------------------------
233 ;;; Property set parsing.
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)))))
243 (defun parse-property-set (lexer)
244 "Parse a property set from LEXER.
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
250 (when (require-token lexer #\[ :errorp nil)
251 (let ((pset (make-pset)))
253 (parse-property lexer pset)
254 (unless (require-token lexer #\, :errorp nil)
256 (require-token lexer #\])
259 ;;;--------------------------------------------------------------------------
263 (with-input-from-string (raw "[role = before, integer = 42 * (3 - 1)]")
264 (let* ((in (make-instance 'position-aware-input-stream :stream raw))
265 (lexer (make-instance 'sod-lexer :stream in)))
268 (multiple-value-call #'values
269 (parse-property-set lexer)
270 (token-type lexer))))
272 ;;;----- That's all, folks --------------------------------------------------