modules/infix.lsp

   1 ;; @module infix.lsp
   2 ;; @description Infix expression parser
   3 ;; @version 2.1 - comments redone for automatic documentation
   4 ;; @author Lutz Mueller
   5 ;;
   6 ;; <h2>Infix expression parser</h2>
   7 ;; Parses infix, prefix or postfix expressions given in strings and returns a
   8 ;; newLISP expressions, which can be evaluated; captures syntax errors.
   9 ;;
  10 ;; At the beginning od the program using this module include the following
  11 ;; statement:
  12 ;; <pre>
  13 ;; (load "/usr/share/newlisp/modules/infix.lsp")
  14 ;; </pre>
  15
  16 ;; @syntax (INFIX:xlate <str-expression> [<context-target>])
  17 ;; @param <str-expression> The infix expression in a string
  18 ;; @param <context-target> An optional context as compile taret.
  19 ;; @return A newLISP expression or 'nil' on failure.
  20 ;; When 'nil' is returned then the error message is in 'result'.
  21 ;; As an optional second parameter a target context can be passed,
  22 ;; if not used, MAIN is assumed.
  23 ;;
  24 ;; Note that the parser requires operators, variables and constants surrounded
  25 ;; by spaces except where parenthesis are used.
  26 ;;
  27 ;; @example
  28 ;; (INFIX:xlate "3 + 4") => (add 3 4) ;; parses infix
  29 ;; (INFIX:xlate "+ 3 4") => (add 3 4) ;; parses prefix s-expressions
  30 ;; (INFIX:xlate "3 4 +") => (add 2 4) ;; parses postfix
  31 ;;
  32 ;; (INFIX:xlate "3 + * 4") => "ERR: missing argument for +"
  33 ;;
  34 ;; (eval (INFIX:xlate "3 + 4")) => 7
  35 ;;
  36 ;; (INFIX:xlate "(3 + 4) * (5 - 2)")  => (mul (add 3 4) (sub 5 2))
  37 ;;
  38 ;; (INFIX:xlate "(a + b) ^ 2 + (a - b) ^ 2") => (add (pow (add a b) 2) (pow (sub a b) 2))
  39 ;;
  40 ;; (INFIX:xlate "x = (3 + sin(20)) * (5 - 2)")  => (setq x (mul (add 3 (sin 20)) (sub 5 2)))
  41 ;;
  42 ;; (INFIX:xlate "x = (3 + sin(10 - 2)) * (5 - 2)")
  43 ;;         => (setq x (mul (add 3 (sin (sub 10 2))) (sub 5 2)))
  44
  45 ; operator priority table
  46 ; (token operator arg-count priority)
  47 ;
  48 (context 'INFIX)
  49
  50 (set 'operators '(
  51   ("=" setq 2 2)
  52   ("+" add 2 3)
  53   ("-" sub 2 3)
  54   ("*" mul 2 4)
  55   ("/" div 2 4)
  56   ("^" pow 2 5)
  57   ("sin" sin 1 9)
  58   ("cos" cos 1 9)
  59   ))
  60
  61 (set 'targetContext MAIN)
  62
  63 (define (xlate str ctx)
  64   (if ctx (set 'targetContext ctx))
  65   (if (catch (infix-xlate str) 'result)
  66     result                     ;; if starts with ERR: is error else result
  67     (append "ERR: " result)))  ;; newLISP error has ocurred
  68
  69
  70 (define (infix-xlate str)
  71   (set 'tokens (parse str))
  72   (set 'varstack '())
  73   (set 'opstack '())
  74   (dolist (tkn tokens)
  75         (case tkn
  76         ("(" (push tkn opstack))
  77         (")" (close-parenthesis))
  78         (true (if (assoc tkn operators)
  79                   (process-op tkn)
  80                   (push tkn varstack)))))
  81   (while (not (empty? opstack))
  82         (make-expression))
  83
  84   (set 'result (first varstack))
  85   (if (or (> (length varstack) 1) (not (list? result)))
  86     (throw "ERR: wrong syntax")
  87     result))
  88
  89
  90 ; pop all operators and make expressions
  91 ; until an open parenthesis is found
  92 ;
  93 (define (close-parenthesis)
  94  (while (not (= (first opstack) "("))
  95     (make-expression))
  96  (pop opstack))
  97
  98
  99 ; pop all operator, which have higher/equal priority
 100 ; and make expressions
 101 ;
 102 (define (process-op tkn)
 103   (if (not (empty? opstack))
 104       (while (<= (lookup tkn operators 3) (lookup (first opstack) operators 3))
 105         (make-expression)))
 106   (push tkn opstack))
 107
 108 ; pops an operator from the opstack and makes/returns an
 109 ; newLISP expression
 110 ;
 111 (define (make-expression)
 112   (set 'expression '())
 113   (if (empty? opstack)
 114         (throw "ERR: missing parenthesis"))
 115   (set 'ops (pop opstack))
 116   (set 'op (lookup ops operators 1))
 117   (set 'nops (lookup ops operators 2))
 118   (dotimes (n nops)
 119     (if (empty? varstack) (throw (append "ERR: missing argument for " ops)))
 120     (set 'vars (pop varstack))
 121     (if (atom? vars)
 122             (if (not (or (set 'var (float vars))
 123                          (and (legal? vars) (set 'var (sym vars targetContext))) ))
 124                 (throw (append vars "ERR: is not a variable"))
 125                 (push var expression))
 126             (push vars expression)))
 127   (push op expression)
 128   (push expression varstack))
 129
 130 (context 'MAIN)
 131
 132 ; eof ;
 133
 134
 135