source: branches/f4grobner/infix-printer.lisp@ 4429

;;; -*- Mode: Lisp -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                              
;;;  Copyright (C) 1999, 2002, 2009, 2015 Marek Rychlik <rychlik@u.arizona.edu>          
;;;                                                                              
;;;  This program is free software; you can redistribute it and/or modify        
;;;  it under the terms of the GNU General Public License as published by        
;;;  the Free Software Foundation; either version 2 of the License, or           
;;;  (at your option) any later version.                                         
;;;                                                                              
;;;  This program is distributed in the hope that it will be useful,             
;;;  but WITHOUT ANY WARRANTY; without even the implied warranty of              
;;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the               
;;;  GNU General Public License for more details.                                
;;;                                                                              
;;;  You should have received a copy of the GNU General Public License           
;;;  along with this program; if not, write to the Free Software                 
;;;  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  
;;;                                                                              
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defpackage "INFIX-PRINTER"
  (:use "COMMON-LISP"
        "INFIX"                         ;for operator-lessp
        )
  (:export infix-print infix-print-to-string infix-print-to-stream))

(in-package "INFIX-PRINTER")

;;(proclaim '(optimize (speed 0) (space 0) (safety 3) (debug 3)))

(defun find-alt-op (op)
  "Find ALT-OP, used for arguments above 1. Example: 
We should have
      (+ X (- Y) Z) --> X - Y + Z
so when an argument of an expression with operator '+ has an operator '-, we
should use '- as a separator, before we render Y. Thus ALT-OP for '+ is '-"
  (ecase op 
    (+ '-)
    (- '-)
    (* '/)
    (/ '/)))

(defun inverse-op (op)
  (ecase op
    (- '+)
    (/ '*)))

(defun infix-print-separated-list (lst sep stream op print-level
                                   &optional 
                                     (alt-op nil) 
                                   &aux
                                     (beg t)
                                     (count 0)
                                     true-sep)
  "Print a list LST using SEP as separator, to stream STREAM. Every
argument is printed usin OP as main operator. PRINT-LEVEL is used to
control printing nested expressions as expected: subexpressions at
level exceeding PRINT-LEVEL are printed as ellipsis. The argument BEG
indicates whether this is the start of a sequence of arguments with
the main operator OP.  The argument ALT-OP, if not NIL, replaces
operator OP for list elements beyond the first one."

  (cond
   ((endp lst) nil)

   ;; Handle *print-level* 
   ((and (numberp *print-level*)
         (> print-level *print-level*))
    (format stream "#"))

   (t
    (dolist (arg lst)
      (setf true-sep sep)
      (incf count)
          
      ;; Treat negative number X as '(- (- X))
      (when (and (realp arg) (minusp arg))
        (setf arg (list '- (- arg))))

      ;; The following code handles unary minus
      ;; Thus:
      ;; (+ x (- y z)) --> X + Y - Z
      ;; (+ x (- y)) --> X - Y
      ;; (- x (- y)) --> X + Y
      (when (and alt-op
                 (> count 1)
                 (consp arg)
                 (endp (cddr arg))
                 (eq alt-op (car arg)))
        (psetf arg (cadr arg)
               true-sep (if (eq op alt-op) (inverse-op op) alt-op)))
        
      ;; Unless at the beginning, print the separator
      (cond
        (beg 
         (setf beg nil))
        (t 
         (format stream "~a" true-sep)))
      
      ;; If *print-length* exceeded, print ellipsis
      (when (and (numberp *print-length*) (> count *print-length*))
        (format stream "...")
        (return-from infix-print-separated-list (values)))
      
      (infix-print-to-stream arg stream op print-level)

      )))
  (values))

(defun infix-print-arg-list (lst stream print-level)
  "Print a comma-separated list."
  (infix-print-separated-list lst '\, stream '\, print-level))

(defun infix-print-to-stream (expr &optional (stream t) (op nil) (print-level 0))
  "Print an expression EXPR in infix notation to stream STREAM.
If OP is not nil, the expression is parenthesized if its operator
has lower precedence than OP. Returns (VALUES)." 
  (cond 
    ;; Handle *print-level*
    ((and (numberp *print-level*)
          (> print-level *print-level*))
     (format stream "#"))

    ;; Null expression is an error
    ((null expr)
     (error "Null expression."))

    ;; Atoms are printed using ~A format directive
    ((atom expr)
     (format stream "~a" expr))
   
    ;; Check if the operator of this expression has lower precedence
    ;; than the surrounding operator, and parenthesize if necessary
    ((and op 
          (operator-lessp (car expr) op))
     (format stream "(")
     (infix-print expr stream nil (1+ print-level))
     (format stream ")"))

    ;; Unary minus needs special handling
    ((and (eq (car expr) '-) (endp (cddr expr)))
     (format stream "-")

     ;; Print the second element in product context
     (infix-print (cadr expr) stream '* (1+ print-level)))

    ;; All other operators
    (t 
     (case (car expr)

       ;; Arithmetic operators
       ((+ - * /)
        
        (let ((op (car expr))
              (args (cdr expr)))
          (infix-print-separated-list 
           args op stream op 
           (1+ print-level) 
           (find-alt-op op))
          )
        )

       ;; Exponentials
       (expt
        (unless (= (length (cdr expr)) 2)
          (error "expt must take 2 arguments."))
        (infix-print-separated-list
         (cdr expr)
         '^
         stream
         '^
         (1+ print-level)))

       ;; Assuming function call
       (otherwise               
        (cond

          ;; Handle array references
          ((eq (car expr) 'aref)
           ;; Special syntax for subscripted variables
           ;; consistent with the infix package.
           (format stream "~a[" (cadr expr))
           (infix-print-separated-list (cddr expr) '\, stream '\, (1+ print-level))
           (format stream "]"))

          ;; Handle lists
          ((and (symbolp (car expr))
                (string= (symbol-name (car expr)) "["))
           (format stream "[")
           (infix-print-separated-list (cdr expr) '\, stream '\, (1+ print-level))
           (format stream "]"))

          ;; Handle generic function call syntax
          (t
           (format stream "~a(" (car expr))
           (infix-print-arg-list (cdr expr) stream (1+ print-level))
           (format stream ")")))))))
  (values))

(defun infix-print-to-string (expr &optional (op nil) (print-level 0)
                              &aux (fstr (make-array '(0) :element-type 'base-char
                                                     :fill-pointer 0 :adjustable t)))
  "Print an expression EXPR in infix notation to a string.  If OP is
not nil, the expression is parenthesized if its operator has lower
precedence than OP. Returns the string containing the printed
expression."
  (with-output-to-string (s fstr)
    (infix-print-to-stream expr s op print-level))
  fstr)

(defun infix-print (expr &optional (stream t) (op nil) (print-level 0))
  "Print an expression EXPR in infix notation to stream STREAM or to
string if (NULL STREAM).  If OP is not nil, the expression is
parenthesized if its operator has lower precedence than OP. Returns
the string containing the printed expression, or (VALUES) if (NULL
STREAM) is true."
  (cond 
    ((null stream)
     (infix-print-to-string expr op print-level))
    (t (infix-print-to-stream expr stream op print-level))))