Massive reorganization in progress.

[sod] / pre-reorg / pset.lisp

;;; -*-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 --------------------------------------------------