--- /dev/null
+;;; -*-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 --------------------------------------------------
~mdw / sod / blobdiff