+++ /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