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 ;