;;; -*-lisp-*-
;;;
;;; Parsing property sets
;;;
;;; (c) 2012 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensble Object Design, an object system for C.
;;;
;;; 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.

(defun play (args)
  "Parse and evaluate a simple expression.

   The result is a pair (TYPE . VALUE).  Currently, type types are `:id',
   `:int', `:string', and `:char'.  If an error prevented a sane ; value from
   being produced, the type `:invalid' is returned.

   The syntax of expressions is rather limited at the moment, but more may be
   added later.

   expression: term | expression `+' term | expression `-' term
   term: factor | term `*' factor | term `/' factor
   factor: primary | `+' factor | `-' factor
   primary: int | id | string | `(' expression `)' | `?' lisp-expression

   Only operators for dealing with integers are provided."

  (labels ((type-dispatch (name args &rest spec)
	     (acond ((find :invalid args :key #'car)
		     (cons :invalid nil))
		    ((find-if (lambda (item)
				(every (lambda (type arg)
					 (eql type (car arg)))
				       (cddr item)
				       args))
			      spec)
		     (cons (car it) (apply (cadr it)
					   (mapcar #'cdr args))))
		    (t
		     (cerror* "Type mismatch: operator `~A' applied to ~
			       types ~{~(~A~)~#[~; and ~;, ~]~}"
			      name
			      (mapcar #'car args))
		     (cons :invalid nil))))
	   (add (x y) (type-dispatch "+" (list x y)
				     (list :integer #'+ :integer :integer)))
	   (sub (x y) (type-dispatch "-" (list x y)
				     (list :integer #'- :integer :integer)))
	   (mul (x y) (type-dispatch "*" (list x y)
				     (list :integer #'* :integer :integer)))
	   (div (x y) (type-dispatch "/" (list x y)
				     (list :integer
					   (lambda (x y)
					     (cond ((zerop y)
						    (cerror*
						     "Division by zero")
						    (cons :invalid nil))
						   (t
						    (floor x y))))
					   :integer :integer)))
	   (nop (x) (type-dispatch "+" (list x)
				   (list :integer #'+ :integer)))
	   (neg (x) (type-dispatch "-" (list x)
				   (list :integer #'- :integer))))

    (with-parser-context (token-scanner-context :scanner scanner)
      (parse (expr (lisp (flet ((prop (type value)
				  (scanner-step scanner)
				  (values (cons type value) t t)))
			   (case (token-type scanner)
			     (:int
			      (prop :integer (token-value scanner)))
			     ((:id :char :string)
			      (prop (token-type scanner) (token-value scanner)))
			     (#\?
			      (let* ((stream (make-scanner-stream scanner))
				     (sexp (read stream t)))
				(scanner-step scanner)
				(values (cons (property-type sexp) sexp)
					t t)))
			     (t
			      (values (list :int :id :char :string #\?)
				      nil nil)))))
		   

(defun parse-property (scanner pset)
  "Parse a single property using the SCANNER; add it to the PSET."
  ;; id `=' expression

;;;----- That's all, folks --------------------------------------------------