blob: 87993e84ec7c3fd60ce601a6c570ee1c15689d57 (
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
|
(defpackage #:argot.examples.calc
(:use #:cl)
(:import-from #:argot #:deflanguage))
(in-package #:argot.examples.calc)
(deflanguage calc (:documentation "A calculator language")
(<calc> :-> (:or
(:seq <subexpr> (:eof))
(:seq <value> (:eof))
(:seq <unop> (:eof))
(:seq <binop> (:eof)))
:=> car)
(<expr> :-> (:or <subexpr> <value> <unop> <binop>))
(<subexpr> :-> (:item)
:?? listp
:=> (argot:parse calc <subexpr> ))
(<value> :-> (:item) :?? numberp)
(<binop> :-> (:seq (:@ lhs <expr>)
(:@ rhs (:+ (:seq (:or= + - / * ^ %) <expr>))))
:=> (expand-binop lhs rhs))
(<unop> :-> (: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))))))
|
