[comp.os.vms] Fpretty.2_of_3

GHC@NIHKLMB.BITNET (Gerson H Cohen) (08/09/88)

$Part2:
$ File_is="FPRETTY2.FOR"
$ Check_Sum_is=1396916419
$ Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
Xc
Xc     Function to determine if the current line should be
Xc     dedented a level (i.e., indented one less level).
Xc
X      integer function dedent_word(end_flag)
X      logical end_flag
Xc
Xc     Functions.
Xc
X      logical match
X      integer label
X      logical space
Xc
Xc     Commons.
Xc
X      common/line/linein,lineout,in_length,out_length
X      character linein*132,lineout*132
X      integer in_length,out_length
Xc
X      common/stack/do_stack,stack_pointer
X      integer do_stack(20),stack_pointer
Xc
Xc     Datas.
Xc
Xc     List of possible words after which dedentation occurs.
Xc     label for end of DO-loop
Xc     END (IF, DO, STRUCTURE, UNION, MAP)
Xc     ELSE (includes ELSE IF THEN)
Xc
X      character end*3,if*2,do*2,else*4,structure*9,union*5,map*3
X      data end/'END'/
X      data if/'IF'/
X      data do/'DO'/
X      data else/'ELSE'/
X      data structure/'STRUCTURE'/
X      data union/'UNION'/
X      data map/'MAP'/
Xc
Xc     Executable code.
Xc
Xd     write(6,10000)
X10000 format(' in dedent')
X      dedent_word = 0
Xc
Xc     Check for end of DO-loop.
Xc
X      line_number = label()
X      if (line_number.ne.0) then
Xc
Xc        Check for matching stack statement label.
Xc
X         if (stack_pointer.gt.0) then
X   10       if (line_number.eq.do_stack(stack_pointer)) then
X               dedent_word = dedent_word - 1
X               stack_pointer = stack_pointer - 1
X               if (stack_pointer.gt.0) goto 10
X               return
X            end if
X         end if
X      end if
Xc
Xc     Check for END.
Xc
X      if (match(7,end,3)) then
Xc
Xc        Check for IF or DO as next word.
Xc
X         if (in_length.ge.10) then
X            do i = 10,in_length
X               if (.not.space(linein(i:i))) then
X                  if (match(i,if,2)) then
X                     dedent_word = -1
X                  else if (match(i,structure,9)) then
X                     dedent_word = -1
X                  else if (match(i,union,5)) then
X                     dedent_word = -1
X                  else if (match(i,map,3)) then
X                     dedent_word = -1
X                  else
X                     if (match(i,do,2)) then
X                        if (do_stack(stack_pointer) .eq. 0) then
X                           stack_pointer = stack_pointer - 1
X                           dedent_word = -1
X                        else
X                           if (do_stack(stack_pointer) .ne.
X     &                     label()) then
X                              call error(2)
X                           else
X                              stack_pointer = stack_pointer - 1
X                              dedent_word = -1
X                           end if
X                        end if
X                     end if
X                  end if
X                  return
X               end if
X            end do
X         else
X            if (in_length.eq.9) then
X               if (stack_pointer.ne.0) then
X                  call error(3)
X                  stack_pointer = 0
X               end if
X               end_flag = .true.
X            end if
X         end if
X         return
X      end if
Xc
Xc     Check for ELSE.
Xc
X      if (match(7,else,4)) then
X         dedent_word = -1
X         return
X      end if
X      return
X      end
Xc
Xc     Subroutine to change first tab in columns 1-6 to blanks and
Xc     to left-justify columns of line past column 6 in column 7.
Xc     Also treats continue lines with initial tab character.
Xc
X      subroutine place(this_is_a_comment)
X      logical this_is_a_comment
Xc
X      integer loop_end,add_columns
Xc
Xc     Functions.
Xc
X      logical number,space
Xc
Xc     Common.
Xc
X      common/line/linein,lineout,in_length,out_length
X      character linein*132,lineout*132
X      integer in_length,out_length
Xc
Xc     Data
Xc
X      parameter tab = char(9)
Xc
Xc     Executable code.
Xc
Xd     write(6,10000)
X10000 format(' in place')
Xc
Xc     Check to see if a comment line.
Xc
X      if (this_is_a_comment) then
X         if (in_length.le.1) return
X         do i = 2,in_length
X            if (.not.space(linein(i:i))) goto 10
X         end do
X         return
X   10    if (i.gt.7) then
X            linein(7:) = linein(i:in_length)
X            in_length = in_length - i + 7
X         else
X            if (i.lt.7) then
X               in_length = in_length - i + 7
X               do j = in_length,7,-1
X                  k = j + i - 7
X                  linein(j:j) = linein(k:k)
X               end do
X            end if
X         end if
X         linein(2:6) = ' '
X         return
X      end if
X      loop_end = min(in_length,6)
X      do i = 1,loop_end
X         if (linein(i:i).eq.tab) then
X            if ((i.eq.1) .and. number(linein(2:2))) then
X               add_columns = 5 - i
X            else
X               add_columns = 6 - i
X            end if
X            do j = in_length,i+1,-1
X               k = j + add_columns
X               linein(k:k) = linein(j:j)
X            end do
X            in_length = in_length + add_columns
X            linein(i:i+add_columns) = ' '
X            goto 20
X         end if
X      end do
X   20 if (in_length.lt.7) return
Xc
Xc     If column 7 nonblank, do nothing.
Xc
X      if (.not.space(linein(7:7))) return
Xc
Xc     Find first nonspace character past column 7.
Xc
X      do i = 8,in_length
X         if (.not.space(linein(i:i))) goto 30
X      end do
Xc
Xc     Blank line.
Xc
X      return
Xc
Xc     Left-justify line unless the first non-blank character is "!"
Xc
X   30 if (linein(i:i).ne.'!') then
X         new_length = in_length - i + 7
X         linein(7:new_length) = linein(i:in_length)
X         in_length = new_length
X      end if
X      return
X      end
Xc
Xc     Subroutine to indent output line.
Xc
X      subroutine nest(indent)
X      integer indent
Xc
Xc     Commons.
Xc
X      common/line/linein,lineout,in_length,out_length
X      character linein*132,lineout*132
X      integer in_length,out_length
Xc
X      common/listing/comment_flag,list_flag,indenter
X      logical comment_flag,list_flag
X      character indenter*3
X      data indenter/'.  '/
Xc
Xc     Executable code.
Xc
Xd     write(6,10000) indent
X10000 format(' in nest, indent = ',i3)
Xc
Xc     First 6 columns are unaffected.
Xc
X      out_length = min(6,in_length)
X      lineout(1:out_length) = linein(1:out_length)
X      if (in_length.le.6) return
Xc
Xc     Insert proper levels of indentation.
Xc
X      if (indent.gt.0) then
X         out_length = 6
X         do i = 1,indent
X            out_length = out_length + 3
X            if (out_length.gt.132) return
X            lineout(out_length-2:out_length) = indenter(1:3)
X         end do
X      end if
Xc
Xc     Copy rest of line.
Xc
X      if (in_length.gt.6) then
X         length_to_copy = min ( 132-out_length, in_length-6 )
X         if (length_to_copy.gt.0) then
X            new_length = out_length + length_to_copy
X            lineout(out_length+1:new_length) =
X     &      linein(7:6+length_to_copy)
X            out_length = new_length
X         end if
X      end if
X      return
X      end
Xc
Xc     Subroutine to print error messages and
Xc     to stop execution when fatal error encountered.
Xc
X      subroutine error(number)
X      integer number
Xd     write(6,10000)
X10000 format(' in error')
Xc
Xc     Error 1 - indent<0 following dedent
Xc     END or ELSE encountered.
Xc
X      if (number.eq.1) then
X         write(4,10010)
X10010    format('%error(1) - END or ELSE encountered with no prior ',
X     &   'DO or IF.')
X         return
X      end if
Xc
Xc     Error 2 - label stored at top of stack .ne. current line label
Xc
X      if (number.eq.2) then
X         write(4,10020)
X10020    format('%error(2) - DO and end-of-loop statement labels '
X     &   'don''t match.')
X         return
X      end if
Xc
Xc     Error 3 - unresolved labels on stack at END of program module.
Xc
X      if (number.eq.3) then
X         write(4,10030)
X10030    format('%error(3) - extra labels unresolved at END')
X         return
X      end if
Xc
Xc     Error 4 - no room on if-line for then or executable statement
Xc
X      if (number.eq.4) then
X         write(4,10040)
X10040    format('%error(4) - nothing following IF')
X         return
X      end if
Xc
Xc     Error 5 - missing or mismatched parentheses following IF.
Xc
X      if (number.eq.5) then
X         write(4,10050)
X10050    format('%error(5)- missing or mismatched parentheses',
X     &   ' in logical expression following IF')
X         return
X      end if
Xc
Xc     Error 6 - indent more than 17 levels
Xc     Record will "spill" off end of line.
Xc
X      if (number.eq.6) then
X         write(4,10060)
X10060    format('%error(6)- levels of indentation limited to 17'
X     &   /1x,'Extra characters at end of line will be ignored.')
X         return
X      end if
Xc
Xc     Invalid number sent to this subroutine from calling program module
Xc
X      write(4,10070)
X10070 format('%error(10) - Invalid error number sent from call to '
X     &' to error_writer.'
X     &/1x,'User should not see this error.')
X      stop
X      end
Xc
Xc     Convert DO-loop label into integer value.
Xc     Return 0 (zero) if no label.
Xc
X      integer function do_label()
Xc
X      character save*5
Xc
Xc     Functions.
Xc
X      logical space
X      logical number
Xc
Xc     Commons.
Xc
X      common/line/linein,lineout,in_length,out_length
X      character linein*132,lineout*132
X      integer in_length,out_length
Xc
X      common/chars/blank,zero
X      integer blank,zero
Xc
Xc     Executable code.
Xc
Xd     write(6,10000)
X10000 format(' in do_label')
Xc
X      do_label = 0
Xc
Xc     Start looking for label in column 10.
Xc     (Assume 'D' in 7; 'O' in 8; and space in 9.)
Xc
X      do i = 10,in_length
X         if (.not.space(linein(i:i))) goto 10
X      end do
X      return
Xc
Xc     Check to see if it's a number.
Xc
X   10 if (.not.number(linein(i:i))) return
Xc
Xc     Assume number continues until next space up to
Xc     a maximum of five digits.
Xc
X      j = 0
X      do while (j.lt.5 .and. number(linein(i:i)))
X         j = j + 1
X         save(j:j) = linein(i:i)
X         i = i + 1
X      end do
Xd     write (6,10010) save(1:j)
X10010 format(' save = ',a)
X      read (save(1:j),10020) do_label
X10020 format (i<j>)
X      return
X      end
Xc
Xc     Function to determine if a character is a number.
Xc
X      logical function number(char)
X      character char
Xc
Xc     Executable code.
Xc
Xd     write(6,10000)
X10000 format(' in number')
X      number = (('0' .le. char) .and. (char .le. '9'))
X      return
X      end
$ GoSub Convert_File
$ Goto Part3