! optionally step trailing comments to tab stops ! statement number reordering !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! Indenter, version 1.1 ! ! date 2/12/95 ! ! Indenter, version 1.4 ! ! date 5/3/96 ! ! Indenter, version 1.5 ! ! date 1/4/96 ! ! bug fixed---tabs outside quoted strings now replaced by spaces. ! ! Indenter, version 1.6 ! ! date 2/4/96 ! ! old-style do loops allowed. ! ! Indenter, version 1.7 ! ! date 21/6/96 ! ! forall construct, pure, elemental preceding subroutine added. ! ! ! ! This program is copyright to : ! ! Dr. Rose Baker, email r.d.baker@mcs.salford.ac.uk. ! ! ! ! It may be copied, used freely, and passed on to other users, BUT ! ! if so the code must be passed on in its entirety, and must NOT be ! ! changed from this version. ! ! ! ! Neither I nor the University of Salford accept any responsibility ! ! for errors caused by this program---use it at your own risk. ! ! ! ! Please report any bugs or comments to me at my email address, ! ! and in case of a bug, do mail me the Fortran source of the ! ! program that caused the error. ! ! ! ! This program does not support obselescent features of Fortran90--- ! ! it will indent old-style do loops, but it will not regard the ! ! contents of a Hollerith string as a quoted string. ! ! It does not support fixed format source layout. ! ! ! ! "I made this, I have forgotten ! ! And remember. ! ! The rigging weak and the canvas rotten ! ! Between one June and another September. ! ! Made this unknowing, half conscious, unknown, my own ! ! The garboard strake leaks, the seams need caulking." ! ! ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! module environment ! used for storing all necessary arrays etc !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! ********* user parameters: ******************************************! ! indent_step :: indentation step in characters. ! ! max_length_line :: max. length of line desired (can be <= 132 chars) ! ! tab :: smallest indentation ! ! indent_format :: indent formats if true, else don't indent ! ! *********************************************************************! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! implicit integer (a-z) integer, parameter :: max_line_length=132,indent_step=3,max_tokens=20,buff_len=40*132 ! longest statement possible. integer, parameter :: tab=6 ! positions of start of statement (excluding number and structure name) relative to indent_level integer :: lg(40),leng_stat,indent_level,indent_from,token_index integer, dimension(max_tokens) :: token_start(max_tokens),token_end(max_tokens),token_type(max_tokens) integer, parameter, dimension(35) :: prec_tok_type=(/1,1,2,2,1,2,1,2,2,2,2,3,4,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,5,1,1,2/& &),succ_tok_type=(/1,2,3,1,4,5,6,11,5,7,12,8,9,10,2,7,15,2,2,5,2,13,2,7,5,7,7,2,7,2,14,5,16,4,5/),split_after_keyword=(/0,0& &,0,4,0,0,0,0,0,0,0,0,0,0,0,0,0,3,3,3,5,5,3,3,3,3,3,3,3,3,6,0,0,0,3/) logical, parameter, dimension(35) :: increment_later=(/.true.,.true.,.true.,.true.,.true.,.true.,.true.,.true.,.true.,.true& &.,.true.,.true.,.true.,.true.,.true.,.true.,.false.,.false.,.false.,.false.,.true.,.true.,.false.,.false.,.false.,.false.,& &.false.,.false.,.false.,.false.,.true.,.false.,.true.,.true.,.false./),decrement_now=(/.false.,.false.,.true.,.true.,.fals& &e.,.true.,.false.,.true.,.true.,.true.,.false.,.false.,.false.,.false.,.false.,.false.,.true.,.true.,.true.,.true.,.false.& &,.false.,.true.,.true.,.true.,.true.,.true.,.true.,.true.,.true.,.false.,.true.,.false.,.false.,.true./),line_up_on_keywor& &d=(/.true.,.true.,.true.,.true.,.true.,.true.,.true.,.true.,.true.,.true.,.false.,.false.,.false.,.false.,.false.,.false.,& &.true.,.true.,.true.,.true.,.true.,.true.,.true.,.true.,.true.,.true.,.true.,.true.,.true.,.true.,.true.,.true.,.true.,.tr& &ue.,.true./) character(133) :: lines(40),blank ! sic..to detect overlong trailing comments character(1) :: tabchar character(buff_len) :: buffer character(buff_len) :: upline,orig_line character(32) :: file_in,file_out character(6) :: do_number(20) ! should never exceed this level of do nesting. integer :: buff_leng,line_num=0, stack_size=0 logical, parameter :: debug=.false.,indent_format=.false. end module environment program indenter use environment implicit integer (a-z) logical :: eof,semicolon,inc_later,dec_now !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! This program indents or beautifies Fortran90 code. ! ! (a) Code is indented according to the control structure or ! ! block name by indent_steps (parameter). ! ! (b) endif, enddo, endwhere, elseif etc are converted to end if, ! ! end do etc. ! ! (c) Line length is reset to parameter max_line_length <= 132. ! ! (d) Format statements can be optionally indented or not. ! ! ! ! forthcoming feature(s): ! ! (e) Statement numbers to be optionally renumbered starting from 1. ! ! ! ! date 30/11/95---21/6/96 ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! tabchar=char(9) ! tab call openup ! sets up input from 5, output to 7 eof=.false. indent_level=0 blank=' ' do call read_lines(eof) ! reads lines of data if (eof) exit ! end of file if(debug)write(*,'(a)')upline(:leng_stat) semicolon=.false. do call indent_update(inc_later,dec_now,semicolon,num,beg_tok_num,key_tok_num,pen_tok_num,ito) ! finds correct indentation level call write_lines(inc_later,dec_now,semicolon,num,beg_tok_num,key_tok_num,pen_tok_num,ito) ! writes lines with correct indentation if (.not.semicolon) exit ! otherwise back for next statement end do end do if(indent_level /= 0)then write(*,100) 100 format('error---indentation level not back to zero at end of program'/'may be missing program statement') end if close(5) close(7) stop 'done' end program indenter subroutine openup use environment implicit integer (a-z) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! This routine reads input and output filenames and opens the files. ! ! 4/12/95 ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! write(*,100,advance='no') !prompt 100 format('Type input file name: ') read(*,'(a)')file_in write(*,101,advance='no') 101 format('Type output file name: ') read(*,'(a)')file_out open(5,file=file_in,status='old',err=98) ! compiler bug means * gets redefined as 5 after 1st open, hence ! perverse order of tests. open(7,file=file_out,status='replace',err=99) return 98 write(*,102)file_in 102 format('Unable to open input file ',a) stop 'failed' 99 write(*,103)file_out 103 format('Unable to open output file ',a) stop 'failed' end subroutine openup subroutine read_lines(eof) !reads a statement or statements separated by semicolons use environment implicit integer (a-z) logical :: eof,in_quote,is_cont,last_space character(1) :: quote_type !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! This routine reads a complete line or lines of a statement ! ! and copies it, uppercased and with & symbols removed, to array ! ! uplines. original case in orig_line. ! ! Comment lines are output at once and ignored. ! ! eof flag set on eof. ! ! date 26/11/95 ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! read in all lines of a statement. loop: do in_quote=.false. do i=1,41 ! will jump out...should really check dont exceed array bound if (i == 41) then ! should never have this many continuation lines write(*,333)line_num 333 format(' *** error after reading line',i7/'too many continuation lines. Aborting. ') stop 'failed' end if read(5,'(a)',end=99)lines(i) line_num=line_num+1 lg(i)=len_trim(lines(i)) if(lg(i) > 132) then write(*,999)line_num lg(i)=132 end if 999 format('line ',i7,' was > 132 characters...truncated') if(i == 1) then if(lg(i) == 0) then ! output this blank line and start again write(7,'(1x)') cycle loop else ! find start of line and see if it is a comment do j=1, lg(i) if(lines(i)(j:j) == ' ')then cycle else if(lines(i)(j:j) == '!') then ! 1st line is a comment...output it as it stands write(7,'(a)')lines(i)(:lg(i)) ! no trailing spaces ! ...and restart search for statement cycle loop else exit end if end do end if end if call contin(lines(i),lg(i),in_quote,quote_type,is_cont) ! returns is_cont true if is continuation line ! and splits off trailing comment which it writes out if(.not. is_cont) exit loop end do end do loop n_lines=i ! uppercase lines and make into one long statement. ! remove multiple spaces at same time leng_stat=0 in_quote=.false. last_space=.false. ldec=1 do i=1,n_lines if(lg(i) == 0)cycle ! ignore blank lines within statements if(i == n_lines)ldec=0 ! dont take off trailing ampersand for last line do j=1,lg(i) if (lines(i)(j:j) /= ' ')exit end do if (lines(i)(j:j) == '&')j=j+1 ! skip leading ampersand if any do k=j,lg(i)-ldec if(in_quote)then if(lines(i)(k:k) == quote_type)then in_quote=.false. end if else if(lines(i)(k:k) == '"' .or. lines(i)(k:k) =='''')then in_quote=.true. quote_type=lines(i)(k:k) else if(lines(i)(k:k) == tabchar)then ! replace tab by space ! bug fix put in 1/4/96 lines(i)(k:k)=' ' end if if(last_space)then if(lines(i)(k:k) == ' ')cycle end if last_space=lines(i)(k:k)==' ' end if leng_stat=leng_stat+1 orig_line(leng_stat:leng_stat)=lines(i)(k:k) ia=ichar(orig_line(leng_stat:leng_stat))-ichar('a') if (ia >=0 .and. ia < 26) then upline(leng_stat:leng_stat)=char(ia+ichar('A')) else upline(leng_stat:leng_stat)=orig_line(leng_stat:leng_stat) end if end do end do return 99 eof=.true. end subroutine read_lines subroutine get_next_token(token_num) use environment implicit integer (a-z) character(1) :: quote_sample,temp !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! This routine returns the sequence number of the next token ! ! as token_num. ! ! pointers to tokens are stored in array token_start,token_end, ! ! token type in array token_type. ! ! ! ! Token types: ! ! ! ! 1 end of line ! ! 2 number (all digits) ! ! 3 word (starts with letter or underscore, contains letters, digits,! ! underscore ! ! 4 colon ! ! 5 expression in parentheses ! ! 6 comment ! ! 7 semicolon ! ! 8 other symbol not in name + rest of line ! ! ! ! date 27/11/95 ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! set pointer to character in array upline. if (token_num > 0) then if(debug)write(*,222)token_num,token_type(token_num),upline(token_start(token_num):token_end(token_num)) 222 format('entering gettoken-num, type, token',2i5,a) if (token_type(token_num) == 1)return ! do nothing if eol already end if if(token_num == 0) then i=1 else i=token_end(token_num)+1 end if ! find start of next token as first nonblank character. do if (i > leng_stat) exit if (upline(i:i) /= ' ')exit i=i+1 end do token_num=token_num+1 if (i > leng_stat) then token_type(token_num)=1 ! eol token_start(token_num)=leng_stat+1 ! so as not to cause problems if accessed. token_end(token_num)=leng_stat+1 return end if token_start(token_num)=i ! find token type select case (upline(i:i)) case (':') token_type(token_num)=4 token_end(token_num)=i case (';') token_type(token_num)=7 token_end(token_num)=i case('!') token_type(token_num)=6 token_end(token_num)=leng_stat case ('0' : '9') ! number token_type(token_num)=2 do j=i,leng_stat if (index('0123456789',upline(j:j)) == 0)exit token_end(token_num)=j end do case('A':'Z') ! word token_type(token_num)=3 do j=i,leng_stat if (index('0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_',upline(j:j)) == 0)exit token_end(token_num)=j end do case('_') ! word token_type(token_num)=3 do j=i,leng_stat if (index('0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_',upline(j:j)) == 0)exit token_end(token_num)=j end do case('(') ! expression in parentheses token_type(token_num)=5 brack_level=0 quote_level=0 do j=i,leng_stat ! scan through until brack_level back to zero token_end(token_num)=j temp=upline(j:j) if (quote_level == 0.and. (temp == '''' .or. temp == '"'))then ! start of quote quote_sample=temp quote_level=1 else if(quote_level == 1 .and. temp == quote_sample) then ! end of quote quote_level=0 else if (temp == '(' .and. quote_level == 0) then brack_level=brack_level+1 else if (temp == ')' .and. quote_level == 0) then brack_level=brack_level-1 if (brack_level == 0)exit end if end do case default quote_level=0 token_type(token_num)=8 do j=i,leng_stat token_end(token_num)=j ! search for end of line or semicolon at level 0 wrt quotes and shriek. temp=upline(j:j) if (quote_level == 0.and. (temp == '''' .or. temp == '"'))then ! start of quote quote_sample=temp quote_level=1 else if(quote_level == 1 .and. temp == quote_sample) then ! end of quote quote_level=0 else if (temp == ';' .and. quote_level == 0) then ! is semicolon token_end(token_num)=j-1 exit else if (temp == '!' .and. quote_level == 0) then token_end(token_num)=j-1 exit end if end do end select end subroutine get_next_token subroutine indent_update(inc_later,dec_now,semicolon,num,beg_tok_num,key_tok_num,pen_tok_num,ito) use environment implicit integer (a-z) logical :: inc_later,dec_now,semicolon ! line ends with semicolon logical :: prev_tok_ok,subs_tok_ok !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! This routine calls for a lexical scan of the statement, which may ! ! be several statements separated by semicolons, and scans far enough ! ! to establish whether there is an indentation-changing keyword in the ! ! statement. If so, flags inc_later and dec_now are set. ! ! num is sequence number of statement in semicolon-separated line ! ! indent from position indent_from , if semicolon have processed ! ! substring orig_line(ifrom: ito). ! ! remove trailing semicolon if any before processing. ! ! date 26/11/95 ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! inc_later=.false. ! set up defaults needed if no keyword on this line dec_now=.false. ito=leng_stat ! write_line to write all of line by default zeroth_tok_num=0 if(semicolon)then ! processing next statement in line with semicolons num=num+1 token_num=pen_tok_num+1 ! token_num is set to point to semicolon if(debug)write(*,333)token_num 333 format('setting token num to',i3) beg_tok_num=token_num+1 semicolon=.false. zeroth_tok_num=token_num else token_num=0 beg_tok_num=1 num=1 end if ! look at this line...may have semicolons or not. do call get_next_token(token_num) pen_tok_num=token_num-1 ! last token on line if(token_type(token_num) == 1) exit ! end of line and no keyword found if(token_type(token_num) == 7) then ! semicolon semicolon=.true. ito=token_end(token_num) return end if ! see if token matches one in list ! first check if is a word at all... if (token_type(token_num) /= 3 ) cycle ! not a word---cannot match---get next token select case (upline(token_start(token_num):token_end(token_num))) case ('IF') token_index=1 case ('DO') token_index=33 ! assume old-style do loop first case ('ELSE') token_index=3 case ('ELSEIF') token_index=4 case ('WHERE') token_index=5 case ('ELSEWHERE') token_index=6 case ('SELECT') token_index=7 case ('CASE') token_index=8 case ('CONTAINS') token_index=9 case ('ENTRY') token_index=10 case ('TYPE') token_index=11 case ('FUNCTION') token_index=12 case ('SUBROUTINE') token_index=13 case ('MODULE') token_index=14 case ('INTERFACE') token_index=15 case ('PROGRAM') token_index=16 case ('END') token_index=17 case ('ENDDO') token_index=18 case ('ENDIF') token_index=19 case ('ENDWHERE') token_index=20 case ('BLOCKDATA') token_index=21 case ('BLOCK') token_index=22 case ('ENDBLOCKDATA') token_index=23 case ('ENDFUNCTION') token_index=24 case ('ENDINTERFACE') token_index=25 case ('ENDMODULE') token_index=26 case ('ENDPROGRAM') token_index=27 case ('ENDSELECT') token_index=28 case ('ENDSUBROUTINE') token_index=29 case ('ENDTYPE') token_index=30 case ('SELECTCASE') token_index=31 case ('CONTINUE') token_index=32 case ('FORALL') token_index=34 case('ENDFORALL') token_index=35 case default ! no match cycle ! get next token end select key_tok_num=token_num ! token number of candidate keyword ! test previous tokens in this line are compatible with this keyword if (.not.prev_tok_ok(zeroth_tok_num,token_num))then ! search for semicolon and exit call get_semicolon(token_num,semicolon) ! return with semicolon flag set and token_num pointing at semicolon if(semicolon)ito=token_end(token_num) pen_tok_num=token_num-1 return end if if(token_index == 33 ) then ! do-loop save_token_num=token_num if (.not. subs_tok_ok(token_num))then token_index=2 ! try new-style do loop ! (change token_index from 33 to 2 if not old style do but is new-style do) else stack_size=stack_size-1 ! pop number stack as we shall do again end if token_num=save_token_num end if if (subs_tok_ok(token_num)) then dec_now=decrement_now(token_index) inc_later=increment_later(token_index) call get_semicolon(token_num,semicolon) ! return with semicolon flag set and token_num pointing at semicolon if(semicolon)ito=token_end(token_num) pen_tok_num=token_num-1 return ! match else ! subsequent tokens not OK...try for match in later tokens if(key_tok_num-zeroth_tok_num > 2 ) then ! no hope of a match now ! must correct for semicolon lines ! search for semicolon and exit call get_semicolon(token_num,semicolon) ! return with semicolon flag set and token_num pointing at semicolon if(semicolon)ito=token_end(token_num) pen_tok_num=token_num-1 return ! no match else token_num=key_tok_num ! reset current token to failed keyword candidate ! note that this code is inefficient; we repeat lexical scan. ! however, this will seldom happen ( > 1 candidate per line) cycle ! get next token end if end if end do end subroutine indent_update subroutine write_lines(inc_later,dec_now,semicolon,num,beg_tok_num,key_tok_num,pen_tok_num,ito) use environment implicit integer (a-z) logical :: is_format,lined_up,inc_later,dec_now,semicolon ! line ends with semicolon !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! This routine ouputs a statement or part of one up to trailing ! ! semicolon. ! ! semicolon means statement ends with a semicolon, num is ! ! statement number in line, beg_tok_num is the token number of the ! ! first token in the line, key_tok_num is the token number of the ! ! keyword, the line is output as far as character ito. ! ! 27/11/95 ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! implement change to indentation level if(debug)then write(*,222)orig_line(:leng_stat) 222 format('line is: ',a) write(*,223)num,beg_tok_num,key_tok_num,ito 223 format('num,beg_tok_num,key_tok_num,ito',4i5) write(*,225)token_type(beg_tok_num),token_type(key_tok_num),token_index 225 format('token types',2i5, 'key',i5) end if if(dec_now)indent_level=indent_level-indent_step realtab=indent_level+tab lined_up=.false. if (num == 1)then buffer=' ' ! clear output buffer buff_leng=0 if(.not.indent_format)then ! check if this is a format...if so, don't indent it. if(is_format())realtab=tab+indent_step ! indent 1 step because formats are not `in' if, do structures, but ARE `in' functions etc. end if end if tok_num=beg_tok_num ! see if number to be copied to output buffer if (token_type(tok_num) == 2 .and. num == 1) then ! copy number buff_leng=token_end(tok_num)-token_start(tok_num)+1 buffer(:buff_leng)=orig_line(token_start(tok_num):token_end(tok_num)) tok_num=tok_num+1 end if if (num == 1)then ! here at start of statement excluding statement number (if 1st statement in line) if (dec_now.or.inc_later)then ! keyword if (line_up_on_keyword(token_index)) then ! line up on keyword ! write (structure name) tokens before keyword backwards from position realtab ! and text after it forwards from character realtab. end_pos=realtab-2 ! to leave 1 space before keyword ! accomodate label and structure name even if it spoils indentation if(key_tok_num > 1)then string_start=realtab-2-token_end(key_tok_num-1)+token_start(tok_num) if(string_start <= buff_leng+1 )end_pos=end_pos+buff_leng+2-string_start end if buff_leng=end_pos+1 ! accomodate number and structure name even if it spoils indentation if(end_pos > realtab-2)then write(*,444)line_num 444 format(' indentation spoiled at line ',i7,' of input file to accomodate label') write(*,'(a)')orig_line(:leng_stat) end if do i=key_tok_num-1,tok_num,-1 start_pos=end_pos+token_start(i)-token_end(i) buffer(start_pos:end_pos)=orig_line(token_start(i):token_end(i)) end_pos=start_pos-1 ! to leave no space between tokens end do ! copy rest of text forwards from keyword lined_up=.true. ifrom=token_start(key_tok_num) if(split_after_keyword(token_index) > 0)then ! put space in keyword buffer(buff_leng+1:buff_leng+split_after_keyword(token_index))=orig_line(ifrom:ifrom+split_after_keyword(token_& &index)-1) buff_leng=buff_leng+split_after_keyword(token_index)+1 buffer(buff_leng:buff_leng)=' ' ifrom=ifrom+split_after_keyword(token_index) end if buff_up=buff_leng+ito+1-ifrom buffer(buff_leng+1:buff_up)=orig_line(ifrom:ito) buff_leng=buff_up end if end if buff_leng=max(buff_leng,realtab-1) end if if(debug)write(*,224)lined_up,semicolon 224 format(2l6) if(.not.lined_up)then ! copy rest of line ifrom=token_start(tok_num) ! have ito already buff_up=buff_leng+ito-ifrom+1 buffer(buff_leng+1:buff_up)=orig_line(ifrom:ito) buff_leng=buff_up end if ! write out line if does not end with semicolon if (.not.semicolon)then if (buff_leng <= max_line_length) then write(7,'(a)')buffer(:buff_leng) else call multi_line_output(realtab,pen_tok_num) end if end if if(inc_later)indent_level=indent_level+indent_step end subroutine write_lines logical function prev_tok_ok(zeroth_tok_num,token_num) use environment implicit integer (a-z) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! this routine checks if previous tokens are consistent with this ! ! candidate token type. ! ! 28/11/95 ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! prev_tok_ok=.false. ! so can skip out if not OK n_prev=token_num-1-zeroth_tok_num select case (prec_tok_type(token_index)) case (1) ! tokens 1...token_num-1 must be [number][word:] select case (n_prev) case (0) ! is OK case (1) ! must be number if(token_type(zeroth_tok_num+1) /= 2) return case (2) ! must be construct name and its trailing colon if(token_type(zeroth_tok_num+1) /=3 .or. token_type(zeroth_tok_num+2) /= 4) return case (3) ! must be number and construct name if(token_type(zeroth_tok_num+1) /= 2) return if(token_type(zeroth_tok_num+2) /=3 .or. token_type(zeroth_tok_num+3) /= 4) return case (4:)! can not match return end select case (2) select case(n_prev) ! tokens 1...token_num-1 must be [number] case (0) ! is OK case (1) ! must be number if(token_type(zeroth_tok_num+1) /= 2) return case (2:)! must be not OK return end select case (3) ! function select case (n_prev) ! tokens must be [number][words][bracketed expression] ! tokens 1...token_num-1 must be [number] case (0)! is OK case (1:) do j=1,n_prev if(token_type(zeroth_tok_num+j) == 2 .and. j /= 1) return if(token_type(zeroth_tok_num+j) /= 2 .and. token_type(zeroth_tok_num+j) /= 3 .and.token_type(zeroth_tok_num+j) /= & &5 )return end do end select case (4) ! subroutine---tokens must be [number] [recursive] or [pure] or [elemental] select case (n_prev) case (0)! is OK case(1:4) do j=1,n_prev if(token_type(zeroth_tok_num+j) == 2 .and. j /= 1) return if(token_type(zeroth_tok_num+j) /= 2 .and. token_type(zeroth_tok_num+j) /= 3) return if(token_type(zeroth_tok_num+j) == 3 .and. upline(token_start(zeroth_tok_num+j):token_end(zeroth_tok_num+j)) /= 'R& &ECURSIVE'.and. upline(token_start(zeroth_tok_num+j):token_end(zeroth_tok_num+j)) /= 'PURE'.and. upline(token_star& &t(zeroth_tok_num+j):token_end(zeroth_tok_num+j)) /= 'ELEMENTAL') return end do case (5:)! is not OK return end select case(5) ! is continue statement---token must be if(debug)write(*,33) 33 format('processing continue') if(n_prev /= 1) return ! no previous token if(token_type(zeroth_tok_num+1) /= 2) return ! previous token not a number ! *** check that is last number in stack if(stack_size == 0) return ! stack is empty if(upline(token_start(zeroth_tok_num+1):token_end(zeroth_tok_num+1)) /= do_number(stack_size) )return ! matches...pop stack stack_size=stack_size-1 if(debug)write(*,34)stack_size 34 format('popped stack to',i3) end select prev_tok_ok=.true. ! has survived sieve and is OK end function prev_tok_ok subroutine get_semicolon(token_num,semicolon) use environment implicit integer (a-z) logical :: semicolon !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! this routine reads rest of line searching for a semicolon, and ! ! returns the updated token number and the semicolon flag. ! ! 28/11/95 ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! semicolon=.false. do if (token_type(token_num) == 1)then !eol return else if(token_type(token_num) == 7)then semicolon=.true. return end if call get_next_token(token_num) end do end subroutine get_semicolon logical function subs_tok_ok(token_num) use environment implicit integer (a-z) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! this routine checks if subsequent tokens are consistent with this ! ! candidate token type. ! ! 28/11/95 ! ! modified to include ! and ; as end of line (bug fix) ! ! 2/3/96 ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subs_tok_ok=.false. select case (succ_tok_type(token_index)) case (1) ! should be then (if, elseif) call get_next_token(token_num) if (token_type(token_num) /= 5) return call get_next_token(token_num) if (token_type(token_num) /= 3) return if(upline(token_start(token_num):token_end(token_num)) /= 'THEN')return case (2) ! should be [word| number] | call get_next_token(token_num) if(token_type(token_num) /= 1 .and. token_type(token_num) /= 6 .and. token_type(token_num) /= 7 .and. token_type(token_n& &um) /= 2 .and. token_type(token_num) /= 3)return case (3) ! should be if or call get_next_token(token_num) if(token_type(token_num) /= 1 .and. token_type(token_num) /= 6 .and. token_type(token_num) /= 7 .and. token_type(token_n& &um) /= 3)return if(token_type(token_num) == 3)then if(upline(token_start(token_num):token_end(token_num)) /= 'IF')return end if case (4) ! should be call get_next_token(token_num) if (token_type(token_num) /= 5) return call get_next_token(token_num) if (token_type(token_num) /= 1 .and. token_type(token_num) /= 6 .and. token_type(token_num) /= 7) return case (5) ! should be call get_next_token(token_num) if (token_type(token_num) /= 1 .and. token_type(token_num) /= 6 .and. token_type(token_num) /= 7) return case (6) ! should be the word `case' call get_next_token(token_num) if (token_type(token_num) /= 3) return if(upline(token_start(token_num):token_end(token_num)) /= 'CASE')return case (7) ! should be a word call get_next_token(token_num) if (token_type(token_num) /= 3) return case (8) ! should be word and expression in parentheses call get_next_token(token_num) if (token_type(token_num) /= 3) return call get_next_token(token_num) if (token_type(token_num) /= 5) return case (9) ! should be word followed by parentheses or call get_next_token(token_num) if (token_type(token_num) /= 3) return call get_next_token(token_num) if (token_type(token_num) /= 5 .and. token_type(token_num) /= 1 .and. token_type(token_num) /= 6 .and. token_type(token_& &num) /= 7) return case (10) ! should be word followed by call get_next_token(token_num) if (token_type(token_num) /= 3) return call get_next_token(token_num) if (token_type(token_num) /= 1 .and. token_type(token_num) /= 6 .and. token_type(token_num) /= 7) return case (11) ! should be word `default' or bracketed expression, then word or end-of-line call get_next_token(token_num) if (token_type(token_num) /= 3 .and. token_type(token_num) /= 5) return if (token_type(token_num) == 3) then if(upline(token_start(token_num):token_end(token_num)) /= 'DEFAULT')return call get_next_token(token_num) if (token_type(token_num) /= 1 .and. token_type(token_num) /= 3) return end if case (12) ! should be a word or comma call get_next_token(token_num) if (token_type(token_num) /= 3 .and. token_type(token_num) /= 8) return if(token_type(token_num) == 8 ) then ! must start with comma (type ,private...) if(upline(token_start(token_num):token_start(token_num)) /= ',')return end if case(13) ! should be word---data call get_next_token(token_num) if (token_type(token_num) /= 3) return if(upline(token_start(token_num):token_end(token_num)) /= 'DATA')return case(14) ! should be expression in parentheses call get_next_token(token_num) if (token_type(token_num) /= 5) return case(15) ! end---should be word or eol. Word must not be `FILE' ! should be [word] | call get_next_token(token_num) if(token_type(token_num) /= 1 .and. token_type(token_num) /= 6 .and. token_type(token_num) /= 7 .and. token_type(token_n& &um) /= 3)return if(token_type(token_num) == 3) then if(upline(token_start(token_num):token_end(token_num)) == 'FILE')return end if case (16) ! old-style 'do'---must be number. if(debug)write(*,44) 44 format('processing old-style do') call get_next_token(token_num) if(token_type(token_num) /= 2) return ! push number stack stack_size=stack_size+1 do_number(stack_size)=upline(token_start(token_num):token_end(token_num)) if(debug)write(*,333)do_number(stack_size) 333 format('put',a,' on stack') end select subs_tok_ok=.true. ! has survived sieve end function subs_tok_ok subroutine multi_line_output(rtab,pen_tok_num) use environment implicit integer (a-z) character(1) :: quote_sample,temp !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! outputs a line of length to_char with continuation lines, ! ! each line tabbed to ! ! start at position rtab, and not exceeding max_line_length. ! ! trailing comments that would need to be continued are put on ! ! the next line, as comment continuation is not allowed. ! ! date 29/11/95 ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! shriek_pos=0 true_buff_leng=buff_leng ! needed for later if(token_type(pen_tok_num) == 6)then ! have trailing comment which spills over one line ! find start of comment. quote_level=0 do j=rtab,buff_leng ! inefficient code, but will hardly ever happen. temp=buffer(j:j) if (quote_level == 0.and. (temp == '''' .or. temp == '"'))then ! start of quote quote_sample=temp quote_level=1 else if(quote_level == 1 .and. temp == quote_sample) then ! end of quote quote_level=0 else if (temp == '!' .and. quote_level == 0) then ! is shriek shriek_pos=j end if end do end if done_to=rtab-1 ! chars output so far if(shriek_pos > 0)then ! trailing comment---can we do rest of code on one line? if (shriek_pos <= max_line_length)then ! do code then comment on next line write(7,'(a)')buffer(:shriek_pos-1) write(7,'(a)')buffer(shriek_pos:buff_leng) return else true_buff_leng=buff_leng buff_leng=shriek_pos-1 ! set to output up to comment as several lines end if end if chars_poss=max_line_length-rtab ! no. of chars that can be output per line chars_poss1=chars_poss-1 ! no of chars in line that is not final line ! -1 because of starting continuation ampersand do if (done_to + chars_poss >= buff_leng)then ! output rest of line as last line if (shriek_pos > 0 .and. done_to+chars_poss >= true_buff_leng)then ! can output trailing comment on last continuation line... ! set flags to do so buff_leng=true_buff_leng shriek_pos=0 end if if(rtab > 1)then write(7,'(a,''&'',a)')blank(:rtab-1),buffer(done_to+1:buff_leng) else write(7,'(''&'',a)')buffer(done_to+1:buff_leng) end if ! is there a trailing comment to be output? if(shriek_pos > 0) then write(7,'(a)')buffer(shriek_pos:true_buff_leng) ! if the last line is too long, that's what the user intended---long comment. end if return else if(done_to == rtab-1) then ! first line---output ending with ampersand do_to=done_to+chars_poss write(7,'(a,''&'')')buffer(:do_to) done_to=do_to else ! output line starting and ending with ampersand do_to=done_to+chars_poss1 if(rtab > 1 )then write(7,'(a,''&'',a,''&'')')blank(:rtab-1),buffer(done_to+1:do_to) else write(7,'(''&'',a,''&'')')buffer(done_to+1:do_to) end if done_to=do_to end if end do end subroutine multi_line_output logical function is_format() use environment implicit integer(a-z) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! returns true if statement is a format. ! ! tokens are already found to eol or semicolon. ! ! date 4/12/95 ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! is_format=.false. ! so can skip out if conditions are not met i=1 if(token_type(i) /= 2)return i=i+1 if(token_type(i) /= 3)return if(upline(token_start(i):token_end(i)) /= 'FORMAT') return i=i+1 if(token_type(i) /= 5)return i=i+1 if(token_type(i) /= 1)return ! is kosher...set function true is_format=.true. end function is_format subroutine contin(line,lg,in_quote,quote_type,iscont) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! returns iscont true if is continuing line ! ! and splits off trailing comment which it writes out. ! ! lg is adjusted to new end of line. ! ! date 5/3/96 ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! implicit integer (a-z) character (*) :: line,quote_type logical :: in_quote,iscont ! search for shriek at level 0 w.r.t. quotes. ! then if previous nonspace char is &, is continuation line. ! if no shriek at level 0 w.r.t. quotes, is continuing line if ! last nonspace char is &. ! write(*,222)line !222 format('iscont entered--line ',a) if(lg ==0)return ! and keep is_cont as it was on entry last_char_no=0 do i=1,lg if (in_quote) then if(line(i:i) /= ' ')last_char_no=i if(line(i:i) == quote_type)then in_quote=.false. cycle end if else if(line(i:i) == '"' .or. line(i:i) == '''')then quote_type=line(i:i) in_quote=.true. cycle end if ! here if not in quote if(line(i:i) == '!')then if (last_char_no > 0) then if(line(last_char_no:last_char_no) == '&') then ! write out comment etc write(7,'(a)')line(i:lg) lg=last_char_no iscont=.true. return end if end if else ! char not shriek if(line(i:i) /= ' ')last_char_no=i end if end if end do ! did not find shriek at level 0 w.r.t. quotes if(last_char_no == 0) then iscont=.false. return end if iscont=line(last_char_no:last_char_no) == '&' end subroutine contin