X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/dea4d05507e59ab779ed4bb209e05971d87e260c..bf090e021a5c20da452a4841cdfb8eb78e29544e:/src/parse-pset.lisp

diff --git a/src/parse-pset.lisp b/src/parse-pset.lisp
new file mode 100644
index 0000000..a38f44b
--- /dev/null
+++ b/src/parse-pset.lisp
@@ -0,0 +1,105 @@
+;;; -*-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 --------------------------------------------------