infix.lisp

(defmacro binary (infix-op &key is)
  (let ((pattern (cond
		   ((not is)
		    `(,infix-op :left :right))
		   ((symbolp is)
		    `(,is :left :right))
		   (t
		    is))))
    `(cons ,infix-op #'(lambda (left right)
			 `( ; BRAIN FAIL HERE.


  (cons sym #'(lambda (left right) (list sym left right))))

(defvar *operator-table*
  (list
    (list
      (binary '&& :is 'and)
      (binary 'and))
    (list
      (binary '== :is 'eql)
      (binary 'eq :is 'eq)
      (binary 'eql :is 'eql)
      (binary '!= :is '(not (eql :left :right)))
      (binary '!eq :is '(not (eq :left :right)))
      (binary '!eql :is '(not (eql :left :right))))
    (list
      (binary '<)
      (binary '>)
      (binary '<=)
      (binary '>=))
    (list
      (binary '+)
      (binary '-))
    (list
      (binary '*)
      (binary '/)
      (binary '% :is 'mod))))

prior-infix.lisp

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


(defmacro infix (&body body)

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

	   (parse-binary-operators (ts binary-operators next-level)
	     (multiple-value-bind (result ok ts-left) (funcall next-level ts)
	       (if (not ok)
		 (return-from parse-binary-operators (values)))

	       (loop 
		 (let ((op (cdr (assoc (car ts-left) binary-operators))))
		   (if (not op)
		     (return))

		   (multiple-value-bind (right-term right-term-ok right-ts) (funcall next-level (cdr ts-left))
		     (if (not right-term-ok)
		       (return))
		     (setf result (funcall op result right-term))
		     (setf ts-left right-ts))))

	       (values result ok ts-left)))

	   ; Numbers and variables
	   (parse-0 (tokens)
	     (let ((result (car tokens)))
	       (if (or (numberp result)
		       (symbolp result))
		 (values result t (cdr tokens))
		 (values))))

	   ; * / %
	   (parse-5 (ts)
	     (parse-binary-operators ts `((* . ,(simple-binary '*))
					  (/ . ,(simple-binary '/))
					  (% . ,(simple-binary 'mod))) #'parse-0))

	   ; + -
	   (parse-6 (ts)
	     (parse-binary-operators ts `((+ . ,(simple-binary '+))
					  (- . ,(simple-binary '-))) #'parse-5))

	   (parse-8 (ts)
	     (parse-binary-operators ts `((< . ,(simple-binary '<))
					  (> . ,(simple-binary '>))
					  (<= . ,(simple-binary '<=))
					  (>= . ,(simple-binary '>=))) #'parse-6))

	   (parse-9 (ts)
	     (parse-binary-operators ts `((== . ,(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))))
					  ) #'parse-8))

	   ; && and
	   (parse-13 (ts)
	     (parse-binary-operators ts `((&& . ,(simple-binary 'and))
					  (and . ,(simple-binary 'and))) #'parse-9))
	   )


    (multiple-value-bind (value) (parse-13 body)
      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)