X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/blobdiff_plain/5b0a2bdbdeabfd02923a9998e6e2dafa614b47f3..239fa5bd3dff0b38b0cebdd3438311f21c24ba4f:/src/pset-parse.lisp

diff --git a/src/pset-parse.lisp b/src/pset-parse.lisp
index d1e437e..be7984e 100644
--- a/src/pset-parse.lisp
+++ b/src/pset-parse.lisp
@@ -23,11 +23,55 @@
 ;;; 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 expression parser.
+
+(flet ((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)))))
+  (let ((add (binop "+" (x y 5)
+	       (dispatch "+" (list x y) (list :int #'+ :int :int))))
+	(sub (binop "-" (x y 5)
+	       (dispatch "-" (list x y) (list :int #'- :int :int))))
+	(mul (binop "*" (x y 7)
+	       (dispatch "*" (list x y) (list :int #'* :int :int))))
+	(div (binop "/" (x y 7)
+	       (dispatch "/" (list x y)
+			 (list :int
+			       (lambda (x y)
+				 (cond ((zerop y)
+					(cerror*
+					 "Division by zero")
+					(cons :invalid nil))
+				       (t
+					(floor x y))))
+			       :int :int))))
+	(nop (preop "+" (x 9)
+	       (dispatch "+" (list x) (list :int #'+ :int))))
+	(neg (preop "-" (x 9)
+	       (dispatch "-" (list x) (list :int #'- :int))))
+	(lp (lparen #\)))
+	(rp (rparen #\))))
+
+    (defun parse-expression (scanner)
+      "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
+   `: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
@@ -39,66 +83,58 @@ (defun play (args)
    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)))
+      (with-parser-context (token-scanner-context :scanner scanner)
+	(parse (expr (:nestedp nestedp)
+		 (lisp (flet ((prop (type value)
 				(scanner-step scanner)
-				(values (cons (property-type sexp) sexp)
-					t t)))
-			     (t
-			      (values (list :int :id :char :string #\?)
-				      nil nil)))))
+				(values (cons type value) t t)))
+			 (case (token-type scanner)
+			   ((:int :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)))))
+		 (or (seq (#\+) add)
+		     (seq (#\-) sub)
+		     (seq (#\*) mul)
+		     (seq (#\/) div))
+		 (or (seq (#\() lp)
+		     (seq (#\+) nop)
+		     (seq (#\-) neg))
+		 (when nestedp (seq (#\)) rp))))))))
+
+;;;--------------------------------------------------------------------------
+;;; Parsing property sets.
 
 (defun parse-property (scanner pset)
   "Parse a single property using the SCANNER; add it to the PSET."
-  ;; id `=' expression
+  ;; property ::= id `=' expression
+  (with-parser-context (token-scanner-context :scanner scanner)
+    (parse (seq ((name :id) #\= (result (parse-expression scanner)))
+	     (let ((type (car result))
+		   (value (cdr result)))
+	       (unless (eq type :invalid)
+		 (add-property pset name value
+			       :type type
+			       :location scanner)))))))
+
+(export 'parse-property-set)
+(defun parse-property-set (scanner)
+  "Parse an optional property set from the SCANNER and return it, or `nil'."
+  ;; property-set ::= [`[' property-list `]']
+  (with-parser-context (token-scanner-context :scanner scanner)
+    (parse (? (seq (#\[
+		    (pset (many (pset (make-property-set) pset)
+			    (parse-property scanner pset)
+			    #\,))
+		    #\])
+		pset)))))
 
 ;;;----- That's all, folks --------------------------------------------------