From 77c113ab1639d41b72fed2d86108d042f1f6892f Mon Sep 17 00:00:00 2001
From: colin <colin@cicadas.surf>
Date: Sun, 23 Jul 2023 08:56:36 -0700
Subject: Add calc example

---
 examples/calc.lisp | 44 ++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 44 insertions(+)
 create mode 100644 examples/calc.lisp

diff --git a/examples/calc.lisp b/examples/calc.lisp
new file mode 100644
index 0000000..14b03e5
--- /dev/null
+++ b/examples/calc.lisp
@@ -0,0 +1,44 @@
+
+(defpackage #:argot.examples.calc
+  (:use #:cl)
+  (:import-from #:argot #:deflanguage))
+
+(in-package #:argot.examples.calc)
+
+(deflanguage calc (:documentation "A calculator language")
+  (<calc> :-> (:or
+               (:seq <value> (:eof))
+               (:seq <unop> (:eof))
+               (:seq <binop> (:eof)))
+          :=> car)
+  (<expr>  :-> (:or <value> <unop> <binop>))
+  (<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))))))
-- 
cgit v1.2.3