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
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
|
;; @module infix.lsp
;; @description Infix expression parser
;; @version 2.1 - comments redone for automatic documentation
;; @version 2.2 - fixed bug for trailing lower priority ops
;; @version 2.3 - doc changes
;; @version 2.3 - doc changes
;; @author Lutz Mueller 2006-2015
;; <h2>Infix expression parser</h2>
;; Parses infix, prefix or postfix expressions given in strings and returns a
;; newLISP expressions, which can be evaluated; captures syntax errors.
;;
;; At the beginning od the program using this module include the following
;; statement:
;; <pre>
;; (load "/usr/local/share/newlisp/modules/infix.lsp")
;; ; or shorter
;; (module "infix.lsp")
;; </pre>
;; @syntax (INFIX:xlate <str-expression> [<context-target>])
;; @param <str-expression> The infix expression in a string
;; @param <context-target> An optional context as compile taret.
;; @return A newLISP expression or 'nil' on failure.
;; When 'nil' is returned then the error message is in 'result'.
;; As an optional second parameter a target context can be passed,
;; if not used, MAIN is assumed.
;;
;; Note that the parser requires operators, variables and constants surrounded
;; by spaces except where parenthesis are used.
;;
;; @example
;; (INFIX:xlate "3 + 4") => (add 3 4) ;; parses infix
;; (INFIX:xlate "+ 3 4") => (add 3 4) ;; parses prefix s-expressions
;; (INFIX:xlate "3 4 +") => (add 2 4) ;; parses postfix
;;
;; (INFIX:xlate "3 + * 4") => "ERR: missing argument for +"
;;
;; (eval (INFIX:xlate "3 + 4")) => 7
;;
;; (INFIX:xlate "(3 + 4) * (5 - 2)") => (mul (add 3 4) (sub 5 2))
;;
;; (INFIX:xlate "(a + b) ^ 2 + (a - b) ^ 2") => (add (pow (add a b) 2) (pow (sub a b) 2))
;;
;; (INFIX:xlate "x = (3 + sin(20)) * (5 - 2)") => (setq x (mul (add 3 (sin 20)) (sub 5 2)))
;;
;; (INFIX:xlate "x = (3 + sin(10 - 2)) * (5 - 2)")
;; => (setq x (mul (add 3 (sin (sub 10 2))) (sub 5 2)))
; operator priority table
; (token operator arg-count priority)
;
(context 'INFIX)
(set 'operators '(
("=" setq 2 2)
("+" add 2 3)
("-" sub 2 3)
("*" mul 2 4)
("/" div 2 4)
("^" pow 2 5)
("abs" abs 1 9)
("acos" acos 1 9)
("asin" asin 1 9)
("atan" atan 1 9)
("sin" sin 1 9)
("sqrt" sqrt 1 9)
("tan" tan 1 9)
("cos" cos 1 9)
; add what else is needed
))
(set 'targetContext MAIN)
(define (xlate str ctx)
(if ctx (set 'targetContext ctx))
(if (catch (infix-xlate str) 'result)
result ; if starts with ERR: is error else result
(append "ERR: " result))) ; newLISP error has ocurred
(define (infix-xlate str)
(set 'tokens (parse str))
(set 'varstack '())
(set 'opstack '())
(dolist (tkn tokens)
(case tkn
("(" (push tkn opstack))
(")" (close-parenthesis))
(true (if (assoc tkn operators)
(process-op tkn)
(push tkn varstack)))))
(while (not (empty? opstack))
(make-expression))
(set 'result (first varstack))
(if (or (> (length varstack) 1) (not (list? result)))
(throw "ERR: wrong syntax")
result))
; pop all operators and make expressions
; until an open parenthesis is found
;
(define (close-parenthesis)
(while (not (= (first opstack) "("))
(make-expression))
(pop opstack))
; pop all operator, which have higher/equal priority
; and make expressions
;
(define (process-op tkn)
(while (and opstack
(<= (lookup tkn operators 3) (lookup (first opstack) operators 3)))
(make-expression))
(push tkn opstack))
; pops an operator from the opstack and makes/returns an
; newLISP expression
;
(define (make-expression)
(set 'expression '())
(if (empty? opstack)
(throw "ERR: missing parenthesis"))
(set 'ops (pop opstack))
(set 'op (lookup ops operators 1))
(set 'nops (lookup ops operators 2))
(dotimes (n nops)
(if (empty? varstack) (throw (append "ERR: missing argument for " ops)))
(set 'vars (pop varstack))
(if (atom? vars)
(if (not (or (set 'var (float vars))
(and (legal? vars) (set 'var (sym vars targetContext))) ))
(throw (append vars "ERR: is not a variable"))
(push var expression))
(push vars expression)))
(push op expression)
(push expression varstack))
(context 'MAIN)
; eof ;
|
