--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Collections of properties
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Simple Object Definition system.
+;;;
+;;; SOD is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; SOD is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Expression parser.
+
+(defun parse-expression (lexer)
+ "Parse an expression from the LEXER.
+
+ The return values are the expression's VALUE and TYPE; currently the types
+ are :ID, :INTEGER, :STRING, and :CHAR. If an error prevented a sane value
+ being produced, the TYPE :INVALID is returned.
+
+ Expression syntax is rather limited at the moment:
+
+ expression : term | expression `+' term | expression `-' term
+ term : factor | term `*' factor | term `/' factor
+ factor : primary | `+' factor | `-' factor
+ primary : integer | identifier | string
+ | `(' expression `)'
+ | `?' lisp-expression
+
+ Identifiers are just standalone things. They don't name values. The
+ operators only work on integer values at the moment. (Confusingly, you
+ can manufacture rational numbers using the division operator, but they
+ still get called integers.)"
+
+ (let ((valstack nil)
+ (opstack nil))
+
+ ;; The following is a simple operator-precedence parser: the
+ ;; recursive-descent parser I wrote the first time was about twice the
+ ;; size and harder to extend.
+ ;;
+ ;; The parser flips between two states, OPERAND and OPERATOR. It starts
+ ;; out in OPERAND state, and tries to parse a sequence of prefix
+ ;; operators followed by a primary expression. Once it's found one, it
+ ;; pushes the operand onto the value stack and flips to OPERATOR state;
+ ;; if it fails, it reports a syntax error and exits. The OPERAND state
+ ;; tries to read a sequence of postfix operators followed by an infix
+ ;; operator; if it fails, it assumes that it hit the stuff following the
+ ;; expression and stops.
+ ;;
+ ;; Each operator is pushed onto a stack consisting of lists of the form
+ ;; (FUNC PREC TY*). The PREC is a precedence -- higher numbers mean
+ ;; tighter binding. The TY* are operand types; operands are popped off
+ ;; the operand stack, checked against the requested types, and passed to
+ ;; the FUNC, which returns a new operand to be pushed in their place.
+ ;;
+ ;; Usually, when a binary operator is pushed, existing stacked operators
+ ;; with higher precedence are applied. Whether operators with /equal/
+ ;; precedence are also applied depends on the associativity of the
+ ;; operator: apply equal precedence operators for left-associative
+ ;; operators, don't apply for right-associative. When we reach the end
+ ;; of the expression, all the remaining operators on the stack are
+ ;; applied.
+ ;;
+ ;; Parenthesized subexpressions are implemented using a hack: when we
+ ;; find an open paren in operand position, a fake operator is pushed with
+ ;; an artificially low precedece, which protects the operators beneath
+ ;; from premature application. The fake operator's function reports an
+ ;; error -- this will be triggered only if we reach the end of the
+ ;; expression before a matching close-paren, because the close-paren
+ ;; handler will pop the fake operator before it does any harm.
+
+ (restart-case
+ (labels ((apply-op (op)
+ ;; Apply the single operator list OP to the values on the
+ ;; value stack.
+ (let ((func (pop op))
+ (args nil))
+ (dolist (ty (reverse (cdr op)))
+ (let ((arg (pop valstack)))
+ (cond ((eq (car arg) :invalid)
+ (setf func nil))
+ ((eq (car arg) ty)
+ (push (cdr arg) args))
+ (t
+ (cerror* "Type mismatch: wanted ~A; found ~A"
+ ty (car arg))
+ (setf func nil)))))
+ (if func
+ (multiple-value-bind (type value) (apply func args)
+ (push (cons type value) valstack))
+ (push '(:invalid . nil) valstack))))
+
+ (apply-all (prec)
+ ;; Apply all operators with precedence PREC or higher.
+ (loop
+ (when (or (null opstack) (< (cadar opstack) prec))
+ (return))
+ (apply-op (pop opstack)))))
+
+ (tagbody
+
+ operand
+ ;; Operand state. Push prefix operators, and try to read a
+ ;; primary operand.
+ (case (token-type lexer)
+
+ ;; Aha. A primary. Push it onto the stack, and see if
+ ;; there's an infix operator.
+ ((:integer :id :string :char)
+ (push (cons (token-type lexer)
+ (token-value lexer))
+ valstack)
+ (go operator))
+
+ ;; Look for a Lisp S-expression.
+ (#\?
+ (with-lexer-stream (stream lexer)
+ (let ((value (eval (read stream t))))
+ (push (cons (property-type value) value) valstack)))
+ (go operator))
+
+ ;; Arithmetic unary operators. Push an operator for `+' for
+ ;; the sake of type-checking.
+ (#\+
+ (push (list (lambda (x) (values :integer x))
+ 10 :integer)
+ opstack))
+ (#\-
+ (push (list (lambda (x) (values :integer (- x)))
+ 10 :integer)
+ opstack))
+
+ ;; The open-paren hack. Push a magic marker which will
+ ;; trigger an error if we hit the end of the expression.
+ ;; Inside the paren, we're still looking for an operand.
+ (#\(
+ (push (list (lambda ()
+ (error "Expected `)' but found ~A"
+ (format-token lexer)))
+ -1)
+ opstack))
+
+ ;; Failed to find anything. Report an error and give up.
+ (t
+ (error "Expected expression but found ~A"
+ (format-token lexer))))
+
+ ;; Assume prefix operators as the default, so go round for more.
+ (next-token lexer)
+ (go operand)
+
+ operator
+ ;; Operator state. Push postfix operators, and try to read an
+ ;; infix operator. It turns out that we're always a token
+ ;; behind here, so catch up.
+ (next-token lexer)
+ (case (token-type lexer)
+
+ ;; Binary operators.
+ (#\+ (apply-all 3)
+ (push (list (lambda (x y) (values :integer (+ x y)))
+ 3 :integer :integer)
+ opstack))
+ (#\- (apply-all 3)
+ (push (list (lambda (x y) (values :integer (- x y)))
+ 3 :integer :integer)
+ opstack))
+ (#\* (apply-all 5)
+ (push (list (lambda (x y) (values :integer (* x y)))
+ 5 :integer :integer)
+ opstack))
+ (#\/ (apply-all 5)
+ (push (list (lambda (x y)
+ (if (zerop y)
+ (progn (cerror* "Division by zero")
+ (values nil :invalid))
+ (values (/ x y) :integer)))
+ 5 :integer :integer)
+ opstack))
+
+ ;; The close-paren hack. Finish off the operators pushed
+ ;; since the open-paren. If the operator stack is now empty,
+ ;; this is someone else's paren, so exit. Otherwise pop our
+ ;; magic marker, and continue looking for an operator.
+ (#\) (apply-all 0)
+ (when (null opstack)
+ (go done))
+ (pop opstack)
+ (go operator))
+
+ ;; Nothing useful. Must have hit the end, so leave.
+ (t (go done)))
+
+ ;; Assume we found the binary operator as a default, so snarf a
+ ;; token and head back.
+ (next-token lexer)
+ (go operand)
+
+ done)
+
+ ;; Apply all the pending operators. If there's an unmatched
+ ;; open paren, this will trigger the error message.
+ (apply-all -99)
+
+ ;; If everything worked out, we should have exactly one operand
+ ;; left. This is the one we want.
+ (assert (and (consp valstack)
+ (null (cdr valstack))))
+ (values (cdar valstack) (caar valstack)))
+ (continue ()
+ :report "Return an invalid value and continue."
+ (values nil :invalid)))))
+
+;;;--------------------------------------------------------------------------
+;;; Property set parsing.
+
+(defun parse-property (lexer pset)
+ "Parse a single property from LEXER; add it to PSET."
+ (let ((name (require-token lexer :id)))
+ (require-token lexer #\=)
+ (multiple-value-bind (value type) (parse-expression lexer)
+ (unless (eq type :invalid)
+ (add-property pset name value :type type :location lexer)))))
+
+(defun parse-property-set (lexer)
+ "Parse a property set from LEXER.
+
+ If there wasn't one to parse, return nil; this isn't considered an error,
+ and GET-PROPERTY will perfectly happily report defaults for all requested
+ properties."
+
+ (when (require-token lexer #\[ :errorp nil)
+ (let ((pset (make-pset)))
+ (loop
+ (parse-property lexer pset)
+ (unless (require-token lexer #\, :errorp nil)
+ (return)))
+ (require-token lexer #\])
+ pset)))
+
+;;;--------------------------------------------------------------------------
+;;; Testing cruft.
+
+#+test
+(with-input-from-string (raw "[role = before, integer = 42 * (3 - 1)]")
+ (let* ((in (make-instance 'position-aware-input-stream :stream raw))
+ (lexer (make-instance 'sod-lexer :stream in)))
+ (next-char lexer)
+ (next-token lexer)
+ (multiple-value-call #'values
+ (parse-property-set lexer)
+ (token-type lexer))))
+
+;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff