chiark - git - mdw - sod/blob - src/parse-pset.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Parsing property sets
   4 ;;;
   5 ;;; (c) 2012 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Sensble Object Design, an object system for C.
  11 ;;;
  12 ;;; SOD is free software; you can redistribute it and/or modify
  13 ;;; it under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 2 of the License, or
  15 ;;; (at your option) any later version.
  16 ;;;
  17 ;;; SOD is distributed in the hope that it will be useful,
  18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with SOD; if not, write to the Free Software Foundation,
  24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  25
  26 (defun play (args)
  27   "Parse and evaluate a simple expression.
  28
  29    The result is a pair (TYPE . VALUE).  Currently, type types are `:id',
  30    `:int', `:string', and `:char'.  If an error prevented a sane ; value from
  31    being produced, the type `:invalid' is returned.
  32
  33    The syntax of expressions is rather limited at the moment, but more may be
  34    added later.
  35
  36    expression: term | expression `+' term | expression `-' term
  37    term: factor | term `*' factor | term `/' factor
  38    factor: primary | `+' factor | `-' factor
  39    primary: int | id | string | `(' expression `)' | `?' lisp-expression
  40
  41    Only operators for dealing with integers are provided."
  42
  43   (labels ((type-dispatch (name args &rest spec)
  44              (acond ((find :invalid args :key #'car)
  45                      (cons :invalid nil))
  46                     ((find-if (lambda (item)
  47                                 (every (lambda (type arg)
  48                                          (eql type (car arg)))
  49                                        (cddr item)
  50                                        args))
  51                               spec)
  52                      (cons (car it) (apply (cadr it)
  53                                            (mapcar #'cdr args))))
  54                     (t
  55                      (cerror* "Type mismatch: operator `~A' applied to ~
  56                                types ~{~(~A~)~#[~; and ~;, ~]~}"
  57                               name
  58                               (mapcar #'car args))
  59                      (cons :invalid nil))))
  60            (add (x y) (type-dispatch "+" (list x y)
  61                                      (list :integer #'+ :integer :integer)))
  62            (sub (x y) (type-dispatch "-" (list x y)
  63                                      (list :integer #'- :integer :integer)))
  64            (mul (x y) (type-dispatch "*" (list x y)
  65                                      (list :integer #'* :integer :integer)))
  66            (div (x y) (type-dispatch "/" (list x y)
  67                                      (list :integer
  68                                            (lambda (x y)
  69                                              (cond ((zerop y)
  70                                                     (cerror*
  71                                                      "Division by zero")
  72                                                     (cons :invalid nil))
  73                                                    (t
  74                                                     (floor x y))))
  75                                            :integer :integer)))
  76            (nop (x) (type-dispatch "+" (list x)
  77                                    (list :integer #'+ :integer)))
  78            (neg (x) (type-dispatch "-" (list x)
  79                                    (list :integer #'- :integer))))
  80
  81     (with-parser-context (token-scanner-context :scanner scanner)
  82       (parse (expr (lisp (flet ((prop (type value)
  83                                   (scanner-step scanner)
  84                                   (values (cons type value) t t)))
  85                            (case (token-type scanner)
  86                              (:int
  87                               (prop :integer (token-value scanner)))
  88                              ((:id :char :string)
  89                               (prop (token-type scanner) (token-value scanner)))
  90                              (#\?
  91                               (let* ((stream (make-scanner-stream scanner))
  92                                      (sexp (read stream t)))
  93                                 (scanner-step scanner)
  94                                 (values (cons (property-type sexp) sexp)
  95                                         t t)))
  96                              (t
  97                               (values (list :int :id :char :string #\?)
  98                                       nil nil)))))
  99
 100
 101 (defun parse-property (scanner pset)
 102   "Parse a single property using the SCANNER; add it to the PSET."
 103   ;; id `=' expression
 104
 105 ;;;----- That's all, folks --------------------------------------------------