      PROGRAM POLISH
**MAIN******************************************************************
* Program to read an infix expression, and then call subroutine GENRPN *
* to generate the corresponding expression Reverse Polish Notation.    *
* Identifiers used are:                                                *
*     RESPON : user response                                           *
*     EXPR   : infix expression                                        *
*     MARK   : end-of-expression marker                                *
*     RPN    : RPN expression                                          *
*     ERROR  : signals an error in EXPR                                *
*                                                                      *
* Input:   RESPON and EXPR                                             *
* Output:  User prompts, RPN or ERROR                                  *
************************************************************************

      CHARACTER*80, EXPR, RPN, MARK*1, RESPON*1
      LOGICAL ERROR
      DATA MARK /';'/

* Repeat the following until RESPON = 'N'

10    CONTINUE
          PRINT *, 'ENTER INFIX EXPRESSION (END WITH ', MARK, ')'
          READ '(A)', EXPR
          CALL GENRPN(EXPR, MARK, RPN, ERROR)
          IF (.NOT. ERROR) THEN
              PRINT *, 'RPN EXPRESSION IS '
              PRINT *, RPN
          END IF
          PRINT *
          PRINT *, 'MORE (Y OR N)'
          READ '(A)', RESPON
      IF (RESPON .NE. 'N') GO TO 10

      END


**GENRPN****************************************************************
* Subroutine to convert infix expression EXPR to Reverse Polish        *
* Notation.  MARK marks the end of EXPR.  ERROR is returned as true if *
* an error is detected in EXPR.  Other identifiers used are:           *
*     STKLIM : parameter = limit on stack size                         *
*     STACK  : character array used as a stack                         *
*     TOP    : pointer to top of stack                                 *
*     SYMBOL : a symbol in expression EXPR                             *
*     I, R   : indices                                                 *
* Subprograms ISOPER and OPERAT are used to process operators, IDENT   *
* for identifiers and RPAREN for right parentheses.  The basic stack   *
* operations are implemented by subprograms CREATE, EMPTY, PUSH, and   *
* POP.                                                                 *
*                                                                      *
* Accepts:  EXPR and MARK                                              *
* Returns:  RPN and ERROR                                              *
************************************************************************

      SUBROUTINE GENRPN(EXPR, MARK, RPN, ERROR)

      CHARACTER*(*) EXPR, MARK, RPN
      INTEGER STKLIM
      PARAMETER (STKLIM = 80)
      CHARACTER*2, STACK(STKLIM), SYMBOL
      INTEGER TOP, I, R
      LOGICAL ISOPER, ERROR, EMPTY

* Initialize an empty stack and blank out RPN

      CALL CREATE(STACK, TOP, STKLIM)
      RPN = ' '
      ERROR = .FALSE.

* Begin the conversion to RPN

      I = 1
      R = 1

* While not end of expression do:

10    IF (EXPR(I:I) .NE. MARK) THEN

*         Skip blanks
20        IF (EXPR(I:I) .EQ. ' ') THEN
              I = I + 1
          GO TO 20
          END IF
          SYMBOL = EXPR(I:I)

          IF ((SYMBOL .GE. 'A') .AND. (SYMBOL .LE. 'Z') .OR.
     +        (SYMBOL .GE. '0') .AND. (SYMBOL .LE. '9')) THEN
*         First letter/digit of identifier/constant

              CALL IDENT(EXPR, I, RPN, R)

          ELSE IF (SYMBOL .EQ. '(') THEN

*         Left parenthesis, push it onto stack

              CALL PUSH(STACK, TOP, STKLIM, SYMBOL)

          ELSE IF (SYMBOL .EQ. ')') THEN
*         Right parenthesis

              CALL RPAREN(STACK, TOP, STKLIM, RPN, R, ERROR) 

          ELSE IF (ISOPER(SYMBOL)) THEN
*         Operator

*             Check for exponentiation operator
              IF ((SYMBOL .EQ. '*') .AND.
     +            (EXPR(I+1 : I+1) .EQ. '*')) THEN
                  SYMBOL = '**'
                  I = I + 1
              END IF
              CALL OPERAT(STACK, TOP, STKLIM, SYMBOL, RPN, R)

          ELSE
*             Illegal character -- skip it

              PRINT *, SYMBOL , ' IS ILLEGAL CHARACTER -- IGNORED'

          END IF
          I = I + 1
          SYMBOL = EXPR(I:I)
      GO TO 10
      END IF

* End of expression reached.  If no error detected, pop
* any operands on the stack and put them in RPN

      IF (.NOT. ERROR) THEN
40        IF (.NOT. EMPTY(STACK, TOP, STKLIM)) THEN
              CALL POP(STACK, TOP, STKLIM, SYMBOL)
              R = R + 2
              IF (SYMBOL .EQ. '**') THEN
                  RPN(R-1: R+1) = '** '
                  R = R + 1
              ELSE
                  RPN(R-1:R) = SYMBOL // ' '
              END IF
          GO TO 40
          END IF
      END IF

      END


**RPAREN*****************************************************************
* Subroutine to process a symbol that is a right parenthesis by popping *
* symbols from STACK (max size STKLIM, TOP is top of stack) until the   *
* corresponding left parenthesis appears, adding these symbols to the   *
* RPN expression at position R.  ERROR is returned as true if no left   *
* parenthesis is found.  Local identifiers used are:                    *
*     SYMBOL  : a symbol popped from stack                              *
*                                                                       *
* Accepts:  STACK, TOP, STKLIM, RPN, and R                              *
* Returns:  Modified STACK, TOP, RPN, and R                             *
*************************************************************************

      SUBROUTINE RPAREN(STACK, TOP, STKLIM, RPN, R, ERROR)

      INTEGER STKLIM, TOP, R
      CHARACTER*2, STACK(1:STKLIM), SYMBOL, RPN*(*)
      LOGICAL ERROR, EMPTY
 
*     Repeatedly pop symbols until left parenthesis appears
*     or stack becomes empty

10    CONTINUE
          IF (EMPTY(STACK, TOP, STKLIM)) THEN
              ERROR = .TRUE.
          ELSE
              CALL POP(STACK, TOP, STKLIM, SYMBOL)
              IF (SYMBOL .NE. '(') THEN
                  R = R + 2
                  IF (SYMBOL .EQ. '**') THEN
                      RPN(R-1: R+1) = '** '
                      R = R + 1
                  ELSE
                      RPN(R-1:R) = SYMBOL // ' '
                  END IF
              END IF
          END IF
      IF (.NOT. ERROR .AND. SYMBOL .NE. '(') GO TO 10

      END

**IDENT*****************************************************************
* Subroutine to copy letters and digits from EXPR, beginning at        *
* position I, into RPN, beginning at position R.  Local variables used:*
*     SYMBOL : a symbol in EXPR                                        *
*     L      : an index used to locate last letter/digit               *
*                                                                      *
* Accepts:  EXPR, I, RPN, and R                                        *
* Returns:  Modified EXPR, I, RPN, and R                               *
************************************************************************

      SUBROUTINE IDENT(EXPR, I, RPN, R)

      CHARACTER*(*) EXPR, RPN, SYMBOL*2
      INTEGER I, R, L

      L = I + 1
      SYMBOL = EXPR(L:L)

* While L-th character of EXPR is a letter or digit do:
10    IF ((SYMBOL .GE. 'A') .AND. (SYMBOL .LE. 'Z') .OR.
     +    (SYMBOL .GE. '0') .AND. (SYMBOL .LE. '9')) THEN
          L = L + 1
          SYMBOL = EXPR(L:L)
      GO TO 10
      END IF

* Copy identifier/constant into RPN

      R = R + 1
      RPN(R : R + L - I) = EXPR(I:L-1) // ' '
      R = R + L - I
      I = L - 1

      END

**ISOPER****************************************************************
* Logical-valued function that determines if SYMBOL is an operator.    *
*                                                                      *
* Accepts:  SYMBOL                                                     *
* Returns:  True if SYMBOL is an operator, false otherwise             *
************************************************************************

      LOGICAL FUNCTION ISOPER(SYMBOL)

      CHARACTER*(*) SYMBOL, OPER(5)*2
      INTEGER OP
      DATA OPER / '+', '-','*','/', '**' /

      ISOPER = .FALSE.
      DO 10 OP = 1, 5
          IF (SYMBOL .EQ. OPER(OP)) ISOPER = .TRUE.
10    CONTINUE
      END

**OPERAT****************************************************************
* Subroutine to process a symbol OP that is an operator by popping     *
* operators from STACK (max size STKLIM, TOP is top of stack) until    *
* the stack becomes empty or an operator appears on the top of the     *
* stack whose priority is less than or equal to that of OP.  OP is     *
* then pushed onto the stack.  Local identifiers used are:             *
*     TOPOP  : operator on top of stack                                *
*     DONE   : signals completion of stack popping                     *
* The function PRIOR is used to find the priorities of operators.      *
*                                                                      *
* Accepts:  STACK, TOP, STKLIM, OP, RPN, and R                         *
* Returns:  Modified STACK, TOP, RPN, and R                            *
************************************************************************

      SUBROUTINE OPERAT(STACK, TOP, STKLIM, OP, RPN, R)

      INTEGER STKLIM, TOP, R, PRIOR
      CHARACTER*2, STACK(STKLIM), OP, TOPOP, RPN*(*)
      LOGICAL DONE, EMPTY

      DONE = .FALSE.

* Repeat the following until done popping

10    CONTINUE

          IF (EMPTY(STACK, TOP, STKLIM)) THEN
              DONE = .TRUE.
          ELSE
              CALL POP(STACK, TOP, STKLIM, TOPOP)
              IF (PRIOR(OP) .LE. PRIOR(TOPOP)) THEN
                  R = R + 2
                  IF (TOPOP .EQ. '**') THEN
                      RPN(R-1: R+1) = '** '
                      R = R + 1
                  ELSE
                      RPN(R-1:R) = TOPOP // ' '
                  END IF
              ELSE
                  CALL PUSH(STACK, TOP, STKLIM, TOPOP)
                  DONE = .TRUE.
              END IF
          END IF
      IF (.NOT. DONE) GO TO 10

      CALL PUSH(STACK, TOP, STKLIM, OP)
    
      END

**PRIOR*****************************************************************
* Function to find the priority of operator or left parenthesis OPER.  *
*                                                                      *
* Accepts:  OPER                                                       *
* Returns:  Integer priority of OPER                                   *
************************************************************************

      FUNCTION PRIOR(OPER)

      INTEGER PRIOR
      CHARACTER*2 OPER

      IF (OPER .EQ. '(') THEN
          PRIOR = 0
      ELSE IF ((OPER .EQ. '+') .OR. (OPER .EQ. '-')) THEN
          PRIOR = 1
      ELSE IF ((OPER .EQ. '*') .OR. (OPER .EQ. '/')) THEN
          PRIOR = 2
      ELSE IF (OPER .EQ. '**') THEN
          PRIOR = 3
      ELSE
          PRIOR = -1
      END IF
      END


************************************************************************
************************************************************************
************    PACKAGE OF STACK-PROCESSING SUBPROGRAMS     ************
************************************************************************
************************************************************************
*                                                                      *
**CREATE****************************************************************
* Subroutine to create an empty stack of character strings.            *
*                                                                      *
* Accepts:  STKLIM                                                     *
* Returns:  Empty STACK and TOP                                        *
************************************************************************

      SUBROUTINE CREATE(STACK, TOP, STKLIM)

      INTEGER TOP, STKLIM
      CHARACTER*(*) STACK(STKLIM)

      TOP = 0

      END

**EMPTY*****************************************************************
* Function to check if a stack of character strings is empty.          *
*                                                                      *
* Accepts:  STACK, TOP, and STKLIM                                     *
* Returns:  True if STACK is empty, false otherwise                    *
************************************************************************

      LOGICAL FUNCTION EMPTY(STACK, TOP, STKLIM)

      INTEGER TOP, STKLIM
      CHARACTER*(*) STACK(STKLIM)

      EMPTY = (TOP .EQ. 0)

      END

**PUSH******************************************************************
* Subroutine to push character symbol onto top of stack.               *
*                                                                      *
* Accepts:  STACK, TOP, STKLIM, and SYMBOL                             *
* Returns:  Modified STACK and TOP                                     *
************************************************************************

      SUBROUTINE PUSH(STACK, TOP, STKLIM, SYMBOL)

      INTEGER TOP, STKLIM
      CHARACTER*(*) STACK(STKLIM), SYMBOL

      IF (TOP .EQ. STKLIM) THEN
          STOP '*** STACK OVERFLOW ***'
      ELSE
          TOP = TOP + 1
          STACK(TOP) = SYMBOL
      END IF
      END

**POP*******************************************************************
* Subroutine to pop top symbol from stack.                             *
*                                                                      *
* Accepts:  STACK, TOP and STKLIM                                      *
* Returns:  SYMBOL and modified STACK and TOP                          *
************************************************************************

      SUBROUTINE POP(STACK, TOP, STKLIM, SYMBOL)

      INTEGER TOP, STKLIM
      CHARACTER*(*) STACK(STKLIM), SYMBOL

      IF (TOP .EQ. 0) THEN
          PRINT *, '*** EMPTY STACK ***'
      ELSE
          SYMBOL = STACK(TOP)
          TOP = TOP - 1
      END IF
      END
*                                                                      *
************************************************************************
************************************************************************
