infix.lisp

(require 'cl-test-more)
(defpackage infix
  (:use :cl :cl-test-more))
(in-package :infix)


(defun simple-binary (sym)
  #'(lambda (left right)
      (list sym left right)))

(defvar *operator-table*
  (list
    (list
      `(&& . ,(simple-binary 'and))
      `(and . ,(simple-binary 'and)))
    (list
      `(== . ,(simple-binary 'eql))
      `(eq . ,(simple-binary 'eq))
      `(eql . ,(simple-binary 'eql))
      `(!= . ,#'(lambda (left right)
	          `(not (eql ,left ,right))))
      `(!eq . ,#'(lambda (left right)
	           `(not (eq ,left ,right))))
      `(!eql . ,#'(lambda (left right)
	            `(not (eq ,left ,right)))))
    (list
      `(< . ,(simple-binary '<))
      `(> . ,(simple-binary '>))
      `(<= . ,(simple-binary '<=))
      `(>= . ,(simple-binary '>=)))
    (list
      `(+ . ,(simple-binary '+))
      `(- . ,(simple-binary '-)))
    (list
      `(* . ,(simple-binary '*))
      `(/ . ,(simple-binary '/))
      `(% . ,(simple-binary 'mod)))))


(defmacro infix (&body body)

  (labels ((parse-0 (tokens)
	     (let ((result (car tokens)))
	       (if (or (numberp result)
		       (symbolp result))
		 (values result t (cdr tokens))
		 (values))))

	   (parse-ops (tokens op-table)
	     (if (endp op-table)
	       (parse-0 tokens)
	       (multiple-value-bind (result ok tokens-left) (parse-ops tokens (cdr op-table))
		 (if (not ok)
		   (return-from parse-ops (values)))

		 (loop 
		   (let ((op (cdr (assoc (car tokens-left) (car op-table)))))
		     (if (not op)
		       (return))

		     (multiple-value-bind (right-term right-term-ok right-tokens) (parse-ops (cdr tokens-left) (cdr op-table))
		       (if (not right-term-ok)
			 (return))
		       (setf result (funcall op result right-term))
		       (setf tokens-left right-tokens))))

		 (values result ok tokens-left)))))

    (multiple-value-bind (value) (parse-ops body *operator-table*)
      value)))
    

(plan 13)

(is (macroexpand-1 '(infix 42)) 42
    "INFIX handles a plain numeric constant")

(is (macroexpand-1 '(infix 1 + 3)) '(+ 1 3)
    "INFIX handles binary +")

(is (macroexpand-1 '(infix 1 + 3 + 4 + 5)) '(+ (+ (+ 1 3) 4) 5)
    "INFIX handles multiple + operands")

(is (macroexpand-1 '(infix 1 + 3 - 5 + 7)) '(+ (- (+ 1 3) 5) 7)
    "INFIX handles - operations")

(is (macroexpand-1 '(infix 1 + 3 * 5 - 7)) '(- (+ 1 (* 3 5)) 7)
    "INFIX handles * operations")

(is (macroexpand-1 '(infix 1 / 3 + 4 / 7)) '(+ (/ 1 3) (/ 4 7))
    "INFIX handles / operations")

(is (macroexpand-1 '(infix 3 % 2)) '(mod 3 2)
    "INFIX turns % into MOD.")

(is (macroexpand-1 '(infix 3 && 6)) '(and 3 6)
    "INFIX turns && into AND.")

(is (macroexpand-1 '(infix 3 and 6)) '(and 3 6)
    "INFIX handles AND.")

(is (macroexpand-1 '(infix 3 * x)) '(* 3 x)
    "INFIX handles variables.")

(is (macroexpand-1 '(infix 3 !eq 6)) '(not (eq 3 6))
    "INFIX handles !EQ.")

(is (macroexpand-1 '(infix 3 == 6)) '(eql 3 6)
    "INFIX handles ==.")

(is (macroexpand-1 '(infix 3 < 6)) '(< 3 6)
    "INFIX handles <.")


(finalize)