/usr/share/zenlisp/infix.l is in zenlisp 2013.11.22-2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 | ; zenlisp example program
; By Nils M Holm, 1998-2007
; See the file LICENSE for conditions of use.
; Convert arithmetic expressions from prefix to
; infix notation:
; (prefix->infix '(+ '#+2 (* '#+3 (expt '#+4 (+ '#+5 '#+6)))))
; => '#2+3*4^[5+6]
; Prefix expressions may contain variables
; (single-char symbols like X), numbers (like '#57),
; and these functions: +, - (unary or binary), *, /,
; EXPT. PREFIX->INFIX will insert parentheses
; ([ and ]) where necessary.
(define (prefix->infix x)
(letrec
((ops '((+ . +) (- . -) (* . *) (/ . /) (expt . ^)))
(left '#+-*/)
(precedence '(high ([]) (expt) (* /) (+ -) low))
(function-p
(lambda (x)
(and (memq x '(+ - * / expt)) :t)))
(left-assoc-p
(lambda (x)
(and (memq x left))))
(symbol-p
(lambda (x)
(and (memq x '#abcdefghijklmnopqrstuvwxyz) :t)))
(numeric-p
(lambda (x)
(and (not (atom x))
(eq (car x) 'quote))))
(atomic-p
(lambda (x)
(or (function-p x)
(symbol-p x)
(numeric-p x))))
(unary-p
(lambda (x)
(and (not (null (cdr x)))
(null (cddr x)))))
(higher-prec-p
(lambda (x y)
(letrec
((hpp (lambda (x y prec)
(cond ((atom prec) :f)
((memq x (car prec))
(not (memq y (car prec))))
((memq y (car prec)) :f)
(t (hpp x y (cdr prec)))))))
(cond ((atomic-p x) (not (atomic-p y)))
((atomic-p y) :f)
((unary-p x) (not (unary-p y)))
((unary-p y) :f)
(t (hpp (car x) (car y) (cdr precedence)))))))
(paren
(lambda (x)
(cond ((atomic-p x) x)
(t (list '[] x)))))
(add-parens
(lambda (x)
(cond
((atomic-p x) x)
(t (let ((x (map add-parens x)))
(cond ((unary-p x)
(cond ((atomic-p (cadr x)) x)
((unary-p (cadr x)) x)
(t (list (car x)
(paren (cadr x))))))
((left-assoc-p (car x))
(list (car x)
(cond ((higher-prec-p x (cadr x))
(paren (cadr x)))
(t (cadr x)))
(cond ((higher-prec-p (caddr x) x)
(caddr x))
(t (paren (caddr x))))))
(t (list (car x)
(cond ((higher-prec-p (cadr x) x)
(cadr x))
(t (paren (cadr x))))
(cond ((higher-prec-p x (caddr x))
(paren (caddr x)))
(t (caddr x)))))))))))
(infix
(lambda (x)
(cond
((numeric-p x)
(cadr x))
((symbol-p x)
(list x))
((and (eq (car x) '-)
(not (atom (cdr x)))
(null (cddr x)))
(append '#- (infix (cadr x))))
((and (eq (car x) '[])
(not (atom (cdr x)))
(null (cddr x)))
(append '#[ (infix (cadr x)) '#]))
((and (not (atom x))
(not (atom (cdr x)))
(not (atom (cddr x)))
(null (cdddr x))
(function-p (car x)))
(append (infix (cadr x))
(list (cdr (assq (car x) ops)))
(infix (caddr x))))
(t (bottom (list 'syntax 'error: x)))))))
(infix (add-parens x))))
|