blob: 0a25a6bdea5f7aaaed6d1612326990bb54585a7d (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
|
(defpackage #:argot.examples.calc
(:use #:cl)
(:import-from #:argot #:deflanguage))
(in-package #:argot.examples.calc)
(deflanguage calc (:documentation "A calculator language")
(<start>
:match (:or
(:seq <subexpr> (:eof))
(:seq <value> (:eof))
(:seq <unop> (:eof))
(:seq <binop> (:eof)))
:then car)
(<expr>
:match (:or <subexpr> <value> <unop> <binop>))
(<subexpr>
:match (:{} calc)
:doc "A subexpression, like (1 + 2 / cos(1.5))")
(<value>
:match (:item)
:if numberp
:doc "A Number")
(<binop>
:match (:seq
(:@ lhs <expr>)
(:@ rhs (:+ (:seq (:or= + - / * ^ %) <expr>))))
:then (expand-binop lhs rhs))
(<unop>
:match (:seq (:or= sin cos tan -) <expr>)))
(defun lassoc? (op)
(member op '(+ -)))
(defparameter +op-table+
'((+ . +)
(- . -)
(^ . expt)
(% . mod)
(* . *)
(/ . /)))
(defun symb->op (op)
(cdr (assoc op +op-table+)))
(defun expand-binop (lhs rhs)
(let ((op (symb->op (caar rhs))))
(if (lassoc? op)
`(,(caar rhs) ,lhs ,(if (cdr rhs)
(expand-binop (cadar rhs) (cdr rhs))
(cadar rhs)))
(if (cdr rhs)
(expand-binop `(,op ,lhs ,(cadar rhs)) (cdr rhs))
`(,op ,lhs ,(cadar rhs))))))
|
