lisp-infix.lisp

(defpackage :com.cxmcmbutterfly.lisp-infix
  (:use :common-lisp)
  (:export :$
	   :*operator-precedence-alist*))
(in-package :com.cxmcmbutterfly.lisp-infix)

;; default list of binary operations in the order of precedence, taken in the order that C++ takes it in sans lognor, logeqv and other binary operators unavailable in C++
;; , see http://clhs.lisp.se/Body/f_logand.htm
;; reference used: http://en.cppreference.com/w/cpp/language/operator_precedence
;; this is exported, and may be changed
(defparameter *operator-precedence-alist*
  '((* . 5)
    (/ . 5)
    (mod . 5)
    (+ . 6)
    (- . 6)
    (ash . 7)
    (< . 8)
    (<= . 8)
    (> . 8)
    (>= . 8)
    (= . 9)
    (/= . 9)
    (eq . 9) ; for checking boolean equality
    (logand . 10)
    (logxor . 11)
    (logior . 12) ; what's the i for? I hope this is same as cpp bitwise or
    (and . 13)
    (or . 14)))

(define-condition malformed-expression-error (error)
  ((text :initarg :text :reader text)))

;; returns values of  stack, list of popped elements
(defun recursively-pop-stack (stack element operator-precedence-alist &optional (popped '()) )
  (if (and (not (null stack))
	   (>=  (cdr (assoc element operator-precedence-alist)) (cdr (assoc (first stack) operator-precedence-alist))))
      ;; recursively pop stack
      (progn
	(push (pop stack) popped)
	(recursively-pop-stack stack element operator-precedence-alist popped))
      ;; else
      (values (push element stack) popped)))

;; apply popped operators to first two operands in queue
(defun apply-popped (popped-stack queue)
  (loop for operator in popped-stack ;; popped last is the index 0 element of the list/stack
     do
       (let ((b (pop queue))
	     (a (pop queue)))
	 (push (list operator a b) queue)))
  queue)

;; an implementation of shunting-yard algorithm for operators w/o brackets
(defun shunting-yard (list-of-expressions operator-precedence-alist)
  (let ((queue '())
	(stack '()))
    (loop for element in list-of-expressions
	 do
	 (if (assoc element operator-precedence-alist)
	     (multiple-value-bind (new-stack popped)
		 (recursively-pop-stack stack element operator-precedence-alist)
	       (setf stack new-stack)
	       (setf queue (apply-popped popped queue)))
	     ;; if number / something that's expected to evaluated to a number
	     (push element queue)))
    (first (apply-popped stack queue)))) ; append remaining stack to the queue, get the single expression left in the queue of expressions

(defmacro $ (&rest list-of-expressions)
  "Infix binary operations for lisp!"
  (shunting-yard list-of-expressions *operator-precedence-alist*))