PROCEDURE   cjc_pretty_fortran

!  REPLACEMENT RULES:

    cjc_fix_labels ;

    cjc_global_pat_replace ( '('      ,  ' ( '    ) ;
    cjc_global_pat_replace ( ')'      ,  ' ) '    ) ;
    cjc_global_pat_replace ( ','      ,  ' , '    ) ;
    cjc_global_pat_replace ( '+'      ,  '  +  '  ) ;
    cjc_global_pat_replace ( '-'      ,  '  -  '  ) ;
    cjc_global_pat_replace ( '*'      ,  ' * '    ) ;
    cjc_global_pat_replace ( '/'      ,  ' / '    ) ;
    cjc_global_pat_replace ( '='      ,  '  =  '  ) ;
    cjc_global_pat_replace ( '<'      ,  ' < '    ) ;
    cjc_global_pat_replace ( '>'      ,  ' > '    ) ;
    cjc_global_pat_replace ( '.GT.'   ,  ' .GT. ' ) ;
    cjc_global_pat_replace ( '.GE.'   ,  ' .GE. ' ) ;
    cjc_global_pat_replace ( '.LT.'   ,  ' .LT. ' ) ;
    cjc_global_pat_replace ( '.LE.'   ,  ' .LE. ' ) ;
    cjc_global_pat_replace ( '.EQ.'   ,  ' .EQ. ' ) ;
    cjc_global_pat_replace ( '.NE.'   ,  ' .NE. ' ) ;
    cjc_global_pat_replace ( '.OR.'   ,  ' .OR. ' ) ;
    cjc_global_pat_replace ( '.AND.'  ,  ' .AND. ') ;
    cjc_global_pat_replace ( '.NOT.'  ,  ' .NOT. ') ;

!  PATCH-UP RULES (to deal with adjacent applications of the rules above, etc.)

    cjc_global_pat_replace ( '(  ('   ,  '( ('    ) ;
    cjc_global_pat_replace ( ')  )'   ,  ') )'    ) ;
    cjc_global_pat_replace ( '(   '   ,  '(  '    ) ;
    cjc_global_pat_replace ( '   )'   ,  '  )'    ) ;
    cjc_global_pat_replace ( '   ('   ,  '  ('    ) ;
    cjc_global_pat_replace ( ')   '   ,  ')  '    ) ;
    cjc_global_pat_replace ( '  *'    ,  ' *'     ) ;
    cjc_global_pat_replace ( '*  '    ,  '* '     ) ;
    cjc_global_pat_replace ( '* *'    ,  '**'     ) ;
    cjc_global_pat_replace ( '* *'    ,  '**'     ) ;
    cjc_global_pat_replace ( '+   '   ,  '+  '    ) ;
    cjc_global_pat_replace ( '-   '   ,  '-  '    ) ;
    cjc_global_pat_replace ( '   +'      ,  '  +' ) ;
    cjc_global_pat_replace ( '   -'      ,  '  -' ) ;
    cjc_global_pat_replace ( '-  -'      ,  '--'  ) ;
    cjc_global_pat_replace ( '-  -'      ,  '--'  ) ;
    cjc_global_pat_replace ( LINE_BEGIN & ' *'
                                      ,  '*'      ) ;
    cjc_global_pat_replace ( 'CHARACTER * '
                                      ,  'CHARACTER*') ;
    cjc_global_pat_replace ( 'LOGICAL * '
                                      ,  'LOGICAL*' ) ;
    cjc_global_pat_replace ( 'INTEGER * '
                                      ,  'INTEGER*') ;
    cjc_global_pat_replace ( 'REAL * '
                                      ,  'REAL*') ;
    cjc_global_pat_replace ( 'COMPLEX * '
                                      , 'COMPLEX*') ;
    cjc_global_pat_replace ( '/ /'    ,  '//'     ) ;
    cjc_global_pat_replace ( '/ /'    ,  '//'     ) ;
    cjc_global_pat_replace ( '  /'    ,  ' /'     ) ;
    cjc_global_pat_replace ( '/  '    ,  '/ '     ) ;
    cjc_global_pat_replace ( '  ,'    ,  ' ,'     ) ;
    cjc_global_pat_replace ( '  ,'    ,  ' ,'     ) ;
    cjc_global_pat_replace ( ',  '    ,  ', '     ) ;
    cjc_global_pat_replace ( ',  '    ,  ', '     ) ;
    cjc_global_pat_replace ( '>   ='  ,  '>='     ) ;
    cjc_global_pat_replace ( '<   ='  ,  '<='     ) ;
    cjc_global_pat_replace ( '   ='   ,  '  ='    ) ;
    cjc_global_pat_replace ( '   ='   ,  '  ='    ) ;
    cjc_global_pat_replace ( '=   '   ,  '=  '    ) ;
    cjc_global_pat_replace ( '=   '   ,  '=  '    ) ;
    cjc_global_pat_replace ( '.GT.  '   ,  ' .GT. ' ) ;
    cjc_global_pat_replace ( '.GE.  '   ,  ' .GE. ' ) ;
    cjc_global_pat_replace ( '.LT.  '   ,  ' .LT. ' ) ;
    cjc_global_pat_replace ( '.LE.  '   ,  ' .LE. ' ) ;
    cjc_global_pat_replace ( '.EQ.  '   ,  ' .EQ. ' ) ;
    cjc_global_pat_replace ( '.NE.  '   ,  ' .NE. ' ) ;
    cjc_global_pat_replace ( ' / LIST'   ,  '/LIST' ) ;
    cjc_global_pat_replace ( 'PF / MF'   ,  'PF/MF' ) ;

ENDPROCEDURE ;



PROCEDURE cjc_indent_block

LOCAL   start_position ,
        end_position   ,
        now_position   ;

ON_ERROR
	if ( ERROR = TPU$_STRNOTFOUND )  then
            !!!!  do nothing -- needing this is an idiocy of TPU courtesy of DEC
        else return ;
	endif ;
ENDON_ERROR;

if ( eve$x_select_position = 0 )  then
    message ( 'Mark block to be indented before using block-indent' ) ;
else
    now_position  :=  mark ( NONE ) ;
    if now_position < eve$x_select_position then
        start_position  :=  now_position ;
        end_position    :=  eve$x_select_position ;
    else
        start_position  :=  eve$x_select_position ;
        end_position    :=  now_position ;
    endif ;

    position ( start_position ) ;
    loop
	position ( search ( LINE_BEGIN , reverse ) ) ;
	exitif ( mark ( NONE )  >=  end_position ) ;
        if ( current_character <> 'C' ) and ( current_character <> '*' ) then
            if index ( '0123456789' , current_character ) <> 0  then
                position (
                         end_of (
                                search ( span ( '0123456789' ) , FORWARD )
                                ) ) ;
                move_horizontal ( 1 ) ;
            endif ;
	    copy_text ( '   ' ) ;
        endif ;
        move_vertical ( 1 ) ;
    endloop ;

!   then fix statement-continuations:

    cjc_global_pat_replace ( LINE_BEGIN & '        ' & ANY ( '&$*#123456789') ,
                                 '     &   '
                           ) ;

    message ( 'Remember to fix line lengths manually' ) ;

endif ;

ENDPROCEDURE ;





PROCEDURE cjc_global_pat_replace ( target_str , replace_str )

LOCAL 	target_str   ,
	replace_str  ,
	target_range ,
        now_position ;

ON_ERROR
	if ( ERROR = TPU$_STRNOTFOUND )  then
            !!!!  do nothing -- needing this is an idiocy of TPU courtesy of DEC
        else return ;
	endif ;
ENDON_ERROR;

now_position  :=  mark ( NONE ) ;
if ( eve$x_select_position = 0 )  then
        position (  beginning_of ( current_buffer ) ) ;
        end_position  :=  end_of ( current_buffer ) ;
else
        if now_position < eve$x_select_position then
            end_position  :=  eve$x_select_position ;
        else
            position ( eve$x_select_position ) ;
            end_position  :=  now_position ;
        endif ;
endif ;

loop
	target_range := search ( target_str, FORWARD ) ;
        exitif ( target_range = 0 ) ;
	erase ( target_range ) ;
	position ( end_of ( target_range ) ) ;
	copy_text ( replace_str ) ;
endloop;

position ( now_position ) ;

ENDPROCEDURE ;




PROCEDURE cjc_fix_labels

LOCAL   target_str   ,
        replace_str  ,
        target_range ,
        col          ,
        now_position ;

ON_ERROR
        if ( ERROR = TPU$_STRNOTFOUND )  then
            !!!!  do nothing -- needing this is an idiocy of TPU courtesy of DEC
        else return ;
        endif ;
ENDON_ERROR;

message ( "Moving all FORTRAN labels to column 1" ) ;

now_position  :=  mark ( NONE ) ;

position (  beginning_of ( current_buffer ) ) ;

loop
        col  :=  1 ;
        loop
            exitif ( get_info ( current_buffer , "character" ) <> ' ' ) ;
            exitif ( get_info ( current_buffer , "offset_column" ) > 5 ) ;
            col  :=  col + 1 ;
            move_horizontal ( 1 ) ;
        endloop ;

        if ( ( get_info ( current_buffer , "offset_column" ) < 6 )
             and ( index ( '1234567890' ,
                           get_info ( current_buffer , "character" )
                         ) <> 0 )
           )  then

            target_range  :=  search ( span ( '1234567890' ) , FORWARD ) ;
            replace_str   :=  erase_character ( length ( target_range ) ) ;
            position ( search ( LINE_BEGIN , REVERSE ) ) ;
            copy_text ( replace_str ) ;

        endif ;

        position ( search ( LINE_BEGIN , REVERSE ) ) ;
        move_vertical ( 1 ) ;

endloop;

eve$position_in_middle ( now_position ) ;

message  ( "FORTRAN labels now fixed" ) ;

ENDPROCEDURE ;