Commit | Line | Data |
---|---|---|
bf090e02 MW |
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))))) | |
bf090e02 MW |
99 | |
100 | (defun parse-property (scanner pset) | |
101 | "Parse a single property using the SCANNER; add it to the PSET." | |
102 | ;; id `=' expression | |
103 | ||
104 | ;;;----- That's all, folks -------------------------------------------------- |