GHC@NIHKLMB.BITNET (Gerson H Cohen) (08/09/88)
$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