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