The infix macro defined below allows you to turn any symbol into an infix operator and create your own DSL with infix syntax. For example: ; a DSL for infix arithmetic
(arith
(4 + 2 * (3 + 5) - 2 ^ 3))
=> 12
; a DSL for infix logic
(logic
(4 < 5 or 4 > 5 and 3 is 3))
=> t
;predicate calculus with infix logical constants
(predicate-calculus
(t -> nil -> t ^ nil <-> nil))
=> t
These were all created using the infix macro. infix takes a list of operators in the form (symbol precedence associativity) plus the expressions you want to evaluate: (infix ((+ 1 left) (* 2 right))
(4 + 2 * 7))
=> 18
You can mix infix and prefix expressions together. The macro determines whether an expression is infix by checking if it has the supplied infix operators in the right locations. So you must be careful with something like (apply + '(1 2 3)) if + is infix. (infix ((+ 1 left)) (apply + '(1 2 3)))
=> Error!
To switch infix off, use prefix: (infix ((+ 1 left)) (prefix apply + '(1 2 3)))
=> 6
Below is the code, plus the definitions of arith, logic and predicate-calculus used above.Bug reports are welcome, as are suggestions for making the code shorter without it becoming too unreadable. This is the first thing I've done in Arc so I probably missed a few tricks. ;;;;;;;;;;;;;;;;;;;;;;;;;;;; (mac infix (ops . rest)
`(do ,@(map [do-infix _ ops] rest)))
(def do-infix (expn ops)
(if (acons expn)
(if (is 'prefix (car expn)) (map [do-infix _ ops] (cdr expn))
(test-for-infix expn ops) (to-prefix (map [do-infix _ ops] expn) ops)
(map [do-infix _ ops] expn))
expn))
(def test-for-infix (expn ops)
(and (<= 3 (len expn))
(odd (len expn))
(is (len (drop-arguments (cdr expn))) (len (ops-only expn ops)))))
(def right-assoc (xs)
(if (is 3 (len xs)) (list xs.1 xs.0 xs.2)
(list xs.1 xs.0 (right-assoc (cddr xs)))))
(def left-assoc (xs)
(if (is 3 (len xs)) (list xs.1 xs.2 xs.0)
(list xs.1 (left-assoc (cddr xs)) xs.0)))
(def precedence (sym ops)
((find [is sym _.0] ops) 1))
(def associate (expn op ops)
(if (is 'left ((find [is op _.0] ops) 2))
(list (left-assoc:rev expn))
(list (right-assoc expn))))
(def to-prefix (expn ops)
(let expn-ops (ops-only expn ops)
(if expn-ops
(withs
(highest-op (best (compare > [precedence _ ops]) expn-ops)
start-end (find-start-and-end-ops highest-op expn-ops)
start (* 2 (car start-end))
end (+ 3 (* 2 (cdr start-end))))
(to-prefix
(join
(subseq expn 0 start)
(associate (subseq expn start end) highest-op ops)
(subseq expn end))
ops))
(car expn))))
(def find-start-and-end-ops (op ops)
(let start (pos op ops)
(cons start (+ start (find-end-op op (nthcdr start ops) -1)))))
(def find-end-op (op ops end)
(if (is op (car ops))
(find-end-op op (cdr ops) (+ 1 end))
end))
(def drop-arguments (expn)
(if expn
(cons (car expn) (drop-arguments (cddr expn)))))
(def ops-only (expn ops)
(keep [pos _ (map car ops)] (drop-arguments (cdr expn))))
(def subseq (seq start (o end (len seq)))
(if (isa seq 'string)
(let s2 (newstring (- end start))
(for i 0 (- end start 1)
(= (s2 i) (seq (+ start i))))
s2)
(firstn (- end start) (nthcdr start seq))))
;;;; Implementation of arith ;;;;
(mac arith body
`(let ^ (rfn ^ (base power)
(if (is 0 power) 1
(< power 0) (/ 1 (^ base (* -1 power)))
(* base (^ base (- power 1)))))
(infix ((+ 1 left) (- 1 left) (* 2 left) (/ 2 left) (^ 3 left)) ,@body)))
;;;; Implementation of logic ;;;;
(mac logic body
`(infix ((and 1 left) (or 1 left) (is 2 left) (< 2 left) (> 2 right)
(<= 2 left) (>= 2 left)) ,@body))
;;;; Implementation of predicate-calculus ;;;;
(mac predicate-calculus body
`(with
(-> (fn (ant conseq) (or (no ant) (and ant conseq)))
^ (fn (x y) (and x y))
u (fn (x y) (or x y))
<-> (fn (x y) (or (and x y) (no (or x y)))))
(infix ((-> 2 right) (^ 1 left) (u 1 left) (<-> 3 left)) ,@ body)))
| 
