X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/7d21069e791a4d164c1eb1fc4f1ae661fe08ffbe..8f33dc2a5d924fc6747d32d047b8c52ab753331c:/pre-reorg/pset.lisp diff --git a/pre-reorg/pset.lisp b/pre-reorg/pset.lisp deleted file mode 100644 index 20f0ff9..0000000 --- a/pre-reorg/pset.lisp +++ /dev/null @@ -1,272 +0,0 @@ -;;; -*-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 --------------------------------------------------