From:	CSBVAX::MRGATE!RELAY-INFO-VAX@CRVAX.SRI.COM@SMTP  8-AUG-1988 23:19
To:	ARISIA::EVERHART
Subj:	Fpretty.3_of_3


Received: From KL.SRI.COM by CRVAX.SRI.COM with TCP; Mon,  8 AUG 88 15:34:42 PDT
Received: from CUNYVM.CUNY.EDU by KL.SRI.COM with TCP; Mon, 8 Aug 88 15:26:54 PDT
Received: from NIHKLMB.BITNET by CUNYVM.CUNY.EDU (IBM VM SMTP R1.1) with BSMTP id 1593; Mon, 08 Aug 88 18:09:48 EDT
Date: Mon, 8 Aug 88 17:58 EDT
From: Gerson H Cohen <GHC%NIHKLMB.BITNET@CUNYVM.CUNY.EDU>
Subject: Fpretty.3_of_3
To: info-vax@kl.sri.com
X-VMS-To: in%"info-vax@kl.sri.com"

$Part3:
$ File_is="FPRETTY1.FOR"
$ Check_Sum_is=271587105
$ Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
Xc
Xc     Program to read a FORTRAN program and produce
Xc     an indented listing showing levels of nesting.
Xc
Xc     This program was originally written by Dr. Ann Copeland
Xc     of the Georgia Tech Research Institute.  Mark Paulk at
Xc     SDC Huntsville made certain modifications (DCL tables,
Xc     /NOLIST format, etc.).  For info on the command line
Xc     interface, see SET COMMAND and Utilities Manual section
Xc     on the DCL editor.
Xc
Xc     MODS:
Xc     linein extended to 132 characters to allow for long comments
Xc     problem was fortran variable mismatch on read with long comment
Xc     MCP 25 Oct 82
Xc     for lines longer than 72 check for comment before splitting and
Xc     making continuation
Xc     MCP 26 Oct 82
Xc     add check for ! type of comments - dont continue them
Xc     MCP 1 Nov 82
Xc     add treatment of continue following a tab character
Xc     GHC 8 Nov 83
Xc     fix up finding file type when directory string is present
Xc     force result file to be in sys$disk:[]
Xc     GHC 9 Nov 83
Xc     recode where possible to use character functions
Xc     treat D in col 1 as a comment
Xc     GHC 10 Nov 83
Xc
Xc     Assumption:
Xc     The .FOR file submitted as input has
Xc     compiled successfully.
Xc
X      logical this_is_a_comment
X      logical success
X      logical end_flag
X      character source_file*256,default_type*6
X      integer cli$get_value,cli$present
Xc
Xc     Functions.
Xc
X      integer dedent_word
X      logical compare
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/split/line_continue,continue_length,start
X      character line_continue*132
X      integer continue_length,start
Xc
X      common/listing/comment_flag,list_flag,indenter
X      logical comment_flag,list_flag
X      character indenter*3
Xc
X      common/error/err_num,num_parens,quote_out
X      integer err_num,num_parens
X      logical quote_out
Xc
X      common/chars/blank,zero
X      integer blank,zero
Xc
Xc     Datas.
Xc
X      character letter_c,letter_d
X      data letter_c/'C'/,letter_d/'D'/
Xc
Xc     Start of executable code.
Xc
Xc     Initialization.
Xc
X      end_flag = .false.
X      indent = 0
X      next_line = 0
X      stack_pointer = 0
X      err_num = 0
X      blank = ichar(' ')
X      zero = ichar('0')
Xc
Xc     Examine command line for source file name.
Xc
X      call cli$get_value('P1',source_file)
X      i = index(source_file,' ') - 1
X      default_type = '.FOR  '
X      open (unit=5,file=source_file(1:i),defaultfile=default_type,
X     1      status='old',readonly,err=30)
Xc
Xc     so what did we open?
Xc
X      inquire (unit=5,name=source_file)
Xc
X      list_flag = cli$present('LIST')
Xc
Xc     Determine if /LIST option present.
Xc
X      if (list_flag) then
X         default_type = '.LIS;0'
X      else
X         default_type = '.FOR;0'
X         indenter(1:1) = ' '
X      end if
X      i = index(source_file,' ') - 1
X      open (unit=4,file=default_type,defaultfile=source_file(1:i),
X     1      status='new',carriagecontrol='list',err=32)
Xc
Xc     Determine if /COMMENT_INDENT option present.
Xc
X      comment_flag = .not. cli$present('COMMENT_INDENT')
Xc
Xc     Start reading input file on unit FOR005.
Xc
X      read(5,10000,end=20) in_length,linein
X10000 format(q,a)
X      do while (.true.)
Xc
Xc        get rid of trailing blanks
Xc
X         do while (in_length.gt.0 .and.
X     &      space(linein(in_length:in_length)))
X            in_length = in_length - 1
X         end do
Xd        write(6,10010) in_length
X10010    format(' in main in_length = ',i3)
Xc
Xc        Check for blank line.
Xc
X         if (in_length.gt.0) then
Xc
Xc           note if we have a comment
Xc
X            this_is_a_comment =
X     &      compare(linein(1:1),letter_c) .or.
X     &      compare(linein(1:1),letter_d)
Xc
Xc           Strip leading spaces.
Xc           Process comment lines only if /COMMENT_INDENT
Xc
X            if (.not.comment_flag .or.
X     &      (comment_flag .and. .not.this_is_a_comment)) then
X               call place(this_is_a_comment)
Xc
Xc              Check to see if an unprinted error was encountered
Xc              on the last statement.
Xc              If so, then check to see if this is a continued line
Xc              which might resolve error.
Xc
X               if (err_num.ne.0) then
X                  if (space(linein(6:6))) then
X                     call error(err_num)
X                     err_num = 0
X                  end if
Xc
Xc                 Check to see if this line should be dedented.
Xc                 Dedentation is defined to be the inverse of indentation.
Xc
X               else
X                  if ((in_length.ge.7) .and.
X     &            .not.this_is_a_comment) then
X                     indent = indent + dedent_word(end_flag)
X                  end if
X               end if
X            end if
Xc
Xc           Check to see if next line should be indented one more level.
Xc
X            if ((in_length.ge.7) .and. .not.this_is_a_comment)
X     &      call indent_word(next_line)
Xc
Xc           Write out line with proper levels of indentation on FOR004.
Xc
X            if ((in_length.le.6) .or.
X     &      (indent.le.0 .and. in_length.lt.72) .or.
X     &      (comment_flag .and. this_is_a_comment)) then
X               write(4,10030) linein(1:in_length)
X            else
Xc
Xc              Move line over for indentation before writing.
Xc              Don't try to continue comments.
Xc
X   10          if (indent.gt.0) then
X                  call nest(indent)
X               else
X                  out_length = in_length
X                  lineout(1:out_length) = linein(1:in_length)
X               end if
X               if ((out_length.gt.72) .and. .not.list_flag .and.
X     &         .not.this_is_a_comment) then
X                  write(6,10020) lineout(1:out_length)
X10020             format(' %length>72 ->'/x,a)
X                  call split(success)
X                  if (success) then
X                     write(4,10030) lineout(1:out_length)
X10030                format(a)
X                     linein(1:continue_length) =
X     &               line_continue(1:continue_length)
X                     in_length = continue_length
X                     go to 10
X                  else
X                     write(4,10030) linein(1:in_length)
X                  end if
X               else
X                  write(4,10030) lineout(1:out_length)
X               end if
X            end if
Xc
Xc           Update count of indentation level based on last line read.
Xc
X            indent = indent + next_line
X            next_line = 0
X            if (indent.lt.0) then
X               call error(1)
X               indent = 0
X            end if
X            if (indent.gt.17) call error(6)
X         else
X            write(4,10030)
X         end if
Xc
Xc        Read next line and see if it begins a new program unit.
Xc
X         read(5,10000,end=20) in_length,linein
X         if (end_flag) then
X            if (list_flag) then
X               write (4,'(////)')
X            end if
X            end_flag = .false.
X            indent = 0
X            next_line = 0
X            stack_pointer = 0
X            err_num = 0
X         end if
X      end do
X   20 call exit
X   30 inquire (file=source_file(1:i),defaultfile=default_type,
X     1         name=source_file)
X      go to 34
X   32 inquire (file=default_type,defaultfile=source_file(1:i),
X     1         name=source_file)
X   34 write (6,'(a)') ' Error opening file: '//
X     1                  source_file(1:index(source_file,' ')-1)
X      call exit
X      end
Xc
Xc     Convert statement label in columns 1-5 into integer value.
Xc     Return 0 (zero) if all spaces.
Xc
X      integer function label()
Xc
X      character save*5
Xc
Xc     Function.
Xc
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
Xc     Executable code.
Xc
Xd     write(6,10000)
X10000 format(' in label')
Xc
X      i = 1
X      do while (i.le.5 .and. space(linein(i:i)))
X         i = i + 1
X      end do
X      j = 0
X      do while (i.le.5 .and. number(linein(i:i)))
X         j = j + 1
X         save(j:j) = linein(i:i)
X         i = i + 1
X      end do
X      if (j.gt.0) then
Xd        write (6,10010) save(1:j)
X10010    format(' save = ',a)
X         read (save(1:j),10020) label
X10020    format (i<j>)
X      else
X         label = 0
X      end if
X      return
X      end
Xc
Xc     Subroutine to determine if the next line should be
Xc     indented one more level.
Xc
X      subroutine indent_word(next_line)
Xc
X      integer last
Xc
Xc     Functions.
Xc
X      logical match
X      integer do_label
X      logical space,next_non_blank
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
X      common/error/err_num,num_parens,quote_out
X      integer err_num,num_parens
X      logical quote_out
Xc
Xc     Datas.
Xc
Xc     List of possible words after which indentation occurs.
Xc     IF (THEN)
Xc     ELSE
Xc     DO (includes DO WHILE)
Xc     STRUCTURE
Xc     UNION
Xc     MAP
Xc
X      character if*2,then*4,else*4,do*2,structure*9,union*5,map*3
X      data if/'IF'/
X      data then/'THEN'/
X      data else/'ELSE'/
X      data do/'DO'/
X      data structure/'STRUCTURE'/
X      data union/'UNION'/
X      data map/'MAP'/
Xc
Xc     Executable code.
Xc
Xd     write(6,10000)
X10000 format(' in indent')
Xd     type *,in_length,' ',linein(1:in_length)
X      next_line = 0
Xc
Xc     Check for IF or continued IF.
Xc
X      if ((err_num.ne.0) .or. match(7,if,2)) then
Xc
Xc        Last word on executable part of statement must be THEN.
Xc
X         call log_expr(last)
X         if (((last+3).le.in_length) .and. (err_num.eq.0)) then
X            if (match(last,then,4)) then
X               next_line = 1
X            end if
X         end if
Xc
Xc        Check for ELSE.
Xc
X      else if (match(7,else,4)) then
X         next_line = 1
Xc
Xc        Check for DO.
Xc
X      else if (match(7,do,2).and.space(linein(9:9))
X     1             .and..not.next_non_blank(9,'=')) then
X         next_line = 1
Xc
Xc        One entry on stack for each DO.
Xc        Entry is statement label for DO-loops with labels.
Xc        Entry is 0 (zero) for DO-loops without labels and
Xc        DO-WHILEs.
Xc
Xc        Stack statement label.
Xc
X         stack_pointer = stack_pointer + 1
X         do_stack(stack_pointer) = do_label()
Xc
Xc        Check for STRUCTURE
Xc
X      else if (match(7,structure,9).and.next_non_blank(16,'/')) then
X         next_line = 1
Xc
Xc        Check for UNION
Xc
X      else if (match(7,union,5).and.
X     1        (in_length.eq.11.or.next_non_blank(12,'!'))) then
X         next_line = 1
Xc
Xc        Check for MAP
Xc
X      else if (match(7,map,3).and.
X     1        (in_length.eq.9.or.next_non_blank(10,'!'))) then
X         next_line = 1
X      end if
X      return
X      end
Xc
Xc     Function to compare next non-blank.
Xc     Absence of a non-blank is also true.
Xc
X      logical function next_non_blank(start,character)
X      integer start
X      character*1 character
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      logical space
Xc
Xc     Executable code.
Xc
Xd     write(6,10000)
X10000 format(' in next_non_blank')
X      i = start
X      do while (i.le.in_length.and.space(linein(i:i)))
X`009 i = i + 1
X      end do
X      next_non_blank = i.gt.in_length.or.linein(i:i).eq.character
X      return
X      end
Xc
Xc     Function to compare two strings for match.
Xc     The string called WORD is required upper case.
Xc
X      logical function match(start,word,word_length)
X      integer start
X      character word*(*)
X      integer word_length
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
X      character line_work*132
Xc
Xc     Executable code.
Xc
Xd     write(6,10000)
X10000 format(' in match')
X      call str$upcase(line_work,linein(start:start+word_length-1))
X      match = line_work(1:word_length).eq.word(1:word_length)
X      return
X      end
Xc
Xc     Function to compare two characters for match.
Xc
X      logical function compare(letter,upper_case_value)
X      character letter,upper_case_value
Xc
X      character lower_case_value
Xc
Xc     Common.
Xc
X      common/chars/blank,zero
X      integer blank,zero
Xc
Xc     Executable code.
Xc
Xd     write(6,10000)
X10000 format(' in compare')
X      lower_case_value = char(ichar(upper_case_value)+blank)
X      compare = ((letter.eq.upper_case_value) .or.
X     &(letter.eq.lower_case_value))
X      return
X      end
$ GoSub Convert_File
$ Exit

