home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / xl21hos2.zip / INFIX.LSP < prev    next >
Lisp/Scheme  |  1995-12-27  |  2KB  |  100 lines
  1. ;;;
  2. ;;; An infix to prefix converter for algebraic expressions.
  3. ;;; From Winston and Horn, Second Edition, pp 185-189.
  4. ;;;
  5. ;
  6. ;    Adapted as a lisp macro by:
  7. ;        Jonathan Roger Greenblatt (jonnyg@rover.umd.edu)
  8. ;        University of Maryland at College Park
  9. ;
  10. ;
  11. ;    (usage:
  12. ;
  13. ;        [ <expr> <oper> <expr> ( <oper> <expr> ) ... ]
  14. ;
  15. ;    <expr>: a lisp expresion.
  16. ;    <oper>: =,+,-,*,/,mod.**,^
  17. ;
  18. ;    Note: [ and ] are part of the syntax, ( and ) mean this part is
  19. ;                optional.
  20. ;
  21. ;    Examples:
  22. ;
  23. ;        [a = 7 * 5 + 4]
  24. ;        [b = 7 + (sin (float a)) + (float [a / 7]) * [3 + a]]
  25. ;
  26. ;    These are expanded to:
  27. ;
  28. ;        (SETQ A (+ (* 7 5) 4))
  29. ;        (SETQ B (+ (+ 7 (SIN (FLOAT A))) (* (FLOAT (/ A 7)) (+ 3 A))))
  30. ;
  31. ;
  32.  
  33. (defun inf-to-pre (ae)
  34.   (labels
  35.     ((weight (operator)
  36.       (case operator
  37.         (= 0)
  38.         (+ 1)
  39.         (- 1)
  40.         (* 2)
  41.         (/ 2)
  42.         (mod 2)
  43.         (** 3)
  44.         (^ 3)
  45.         (t 4)))
  46.  
  47.     (opcode (operator)
  48.       (case operator
  49.         (= 'setq)
  50.         (+ '+)
  51.         (- '-)
  52.         (* '*)
  53.         (/ '/)
  54.         (mod 'mod)
  55.         (** 'expt)
  56.         (^ 'expt)
  57.         (t (error "~s is an invalid operator" operator))))
  58.  
  59.     (inf-aux (ae operators operands)
  60.       (inf-iter (cdr ae)
  61.         operators
  62.         (cons (car ae) operands)))
  63.  
  64.     (inf-iter (ae operators operands)
  65.       (cond ((and (null ae) (null operators))
  66.          (car operands))
  67.         ((and (not (null ae))
  68.               (or (null operators)
  69.               (> (weight (car ae))
  70.                  (weight (car operators)))))
  71.          (inf-aux (cdr ae)
  72.               (cons (car ae) operators)
  73.               operands))
  74.         (t (inf-iter ae
  75.                  (cdr operators)
  76.                  (cons (list (opcode (car operators))
  77.                      (cadr operands)
  78.                      (car operands))
  79.                    (cddr operands)))))))
  80.  
  81.   (if (atom ae)
  82.       ae
  83.       (inf-aux ae nil nil))))
  84.  
  85. (setf (aref *readtable* (char-int #\[))
  86.   (cons :tmacro
  87.     (lambda (f c &aux ex)
  88.         (setf ex nil)
  89.         (do () ((eq (peek-char t f) #\]))
  90.             (setf ex (append ex (cons (read f) nil))))
  91.         (read-char f)
  92.         (cons (inf-to-pre ex) nil))))
  93.  
  94. (setf (aref *readtable* (char-int #\]))
  95.   (cons :tmacro
  96.     (lambda (f c)
  97.         (error "misplaced right bracket"))))
  98.  
  99.  
  100.