kate@cgdisis.cgd.ucar.edu (Kate Hedstrom) (02/11/91)
OK, I've gotten several requests so here is the perl relabel program. Keep your old sources until you're sure that nothing bad has happened to the new ones! Kate Hedstrom Also, I got the following message from a Swedish astronomer: > From uucp@kth.se Sun Feb 10 17:16:58 1991 > Organization: SAAF, Svensk Amat|rAstronomisk F|rening > > About 7-8 years ago I wrote a Fortran-77 program that renumbers all > labels in a Fortran program. If the Fortran program to be renumbered > is syntactically correct, it will correctly handle all the syntax > details of the F-77 program to be renumbered. > > Each function/subroutine will get a number sequence of its own. Also, > one can select different number sequences for FORMAT labels and other > labels (if they should overlap, the program will ensure that no two > labels get the same number). > > Although it's many years since I wrote a Fortran program, I still have > this Fortran renumbering program available somewhere. If you are > interested, I can post it here. #!/usr/bin/perl eval "exec /usr/bin/perl -S $0 $*" if $running_under_some_shell; # # Relabel a fortran program # # Usage: relabel [file] # # The relabeled program is written to STDOUT. # # Restrictions: # # No computed goto # No assigned goto or assign # No arithmetic if # No new-lines inside the parenthesis immediately following a read/write # Others that I have not thought of # # $Header: /usr/local/src/RCS/relabel,v 1.2 89/11/14 10:44:25 bin Exp $ # # Written by: # Sverre Froyen # sverre@fesk.seri.gov # Bugfixes and perl 3 support by: # Kate Hedstrom # kate@ahab.rutgers.edu # $tmp = "/tmp/rel.$$"; # Temporary file name $label_no_start = 100; # First new label number $label_no_incr = 10; # New label increment $cont_char = '&'; # Continuation character $label_no = $label_no_start; $section_no = 0; $s_pref = $section_no."_"; # # get a line, combining continuation lines # sub get_line { $thisline = $lookahead; line: while ($lookahead = <tmp>) { if ($lookahead =~ s/^ \S/ $cont_char/) { $thisline .= $lookahead; } else { last line; } } $thisline; } # # Find matching parenthesis # sub find_match { $parexp = ''; while (/[()]/) { $parexp .= $`; $parexp .= $&; $_ = $'; if ($& eq "(") { $left++; } else { $left--; } if ($left == 0) { last; } } } # # first pass - collect all labels and copy to tmp file # open(tmp,">$tmp") || die "Can't open tmp file"; $no_change_needed = 1; while (<>) { # # Skip comments # if (/^[c#]/i) { print tmp; next; } # # Check for new section (function or subroutine) # if (/function|subroutine/i && $` !~ /'/) { $section_no++; $s_pref = $section_no."_"; $label_no = $label_no_start; } # # Check for numeric label field # $label_field = substr($_,0,5); if ($label_field =~ s/^[ 0]*([1-9][0-9]*) */$1/) { $label_field = $s_pref.$label_field; if ($label{$label_field}) { # Duplicate label close(tmp); system "rm $tmp"; die "Duplicate label $label_field"; } if ($label_field != $label_no) { $no_change_needed = 0; } printf tmp ("%5d", $label_no); # New label $_ = substr($_,5,999); $label{$label_field} = $label_no; $label_no += $label_no_incr; if (/^ *format/i) { # Label type $type{$label_field} = "format"; } else { $type{$label_field} = "other"; } } print tmp; } close(tmp); if ($no_change_needed) { system "cat $tmp"; system "rm $tmp"; exit 0; } # # Second pass - relabel # open(tmp,"$tmp") || die "Can't open tmp file - second pass"; $lookahead = <tmp>; # Get first line $section_no = 0; $s_pref = $section_no."_"; while ($_ = do get_line()) { # # Skip comments # if (/^[c#]/i) { print; next; } s/\t/ /g; # Replace tabs with blanks # # Check for new section (function or subroutine) # if (/function|subroutine/i && $` !~ /'/) { $section_no++; $s_pref = $section_no."_"; } # # Remove and print label field # (these were changed during first pass) # print substr($_,0,6); $_ = substr($_,6,999); # # Must first skip past `if (...)' constructs # if (/^ *if *\(/i) { print $&; $_ = $'; $left = 1; do find_match(); if ($left != 0) { die "Illegal if statement"; } print $parexp; } # # Skip to next line if end-of-line before continuation-line # if (/^ *\n \S */) { print $&; $_ = $'; } # # Do some simple tests to see if line needs further processing # (to speed things up) # if ($_ !~ /^ *read|^ *write|^ *open|^ *go *to|^ *do/i) { print; next; } study; # # Read / write # if (/^ *read *\(|^ *write *\(/i) { print $&; $_ = $'; $left = 1; do find_match(); if ($left != 0) { die "Illegal read/write statement"; } if ($parexp =~ /\n/) { # Can be removed later die "Cannot handle new-lines in r/w statements"; } if ($parexp =~ /^([ a-z0-9()*]+ *)/i) { print $1; # unit $parexp = $'; } if ($parexp =~ /^(, *\*)/i) { print $1; # free format $parexp = $'; } elsif ($parexp =~ /^(, *)([0-9]+)/i) { if ($type{$s_pref.$2} ne "format") { die "Wrong label type - # $2"; } print $1; print $label{$s_pref.$2}; # format number $parexp = $'; } while ($parexp =~ /^( *, *[ednr]+ *= *)([0-9]+)/i) { if ($type{$s_pref.$2} ne "other") { die "Wrong label type - # $2"; } print $1; # end / err print $label{$s_pref.$2}; # label $parexp = $'; } print $parexp; } # # open # elsif (/^ *open *\(/i) { print $&; $_ = $'; $left = 1; do find_match(); if ($left != 0) { die "Illegal open statement"; } while ($parexp =~ /([ednr]+ *= *)([0-9]+)/i) { print $`; if ($type{$s_pref.$2} ne "other") { die "Wrong label type - # $2"; } print $1; # end / err print $label{$s_pref.$2}; # label $parexp = $'; } print $parexp; } # # goto # elsif (/^ *go *to */i) { print $&; $_ = $'; if (/^([0-9]+) *$/i) { # only simplest type if ($type{$s_pref.$1} ne "other") { die "Wrong label type - # $1 sec $section_no"; } print $label{$s_pref.$1}; $_ = $'; } else { die "Illegal goto"; } } # # do # elsif (/^( *do *)([0-9]+)( *[a-z0-9]+ *= *[-+*\/a-z0-9() ]+ *, *[-+*\/a-z0-9() ]+)/i) { if ($type{$s_pref.$2} ne "other") { die "Wrong label type - # $2"; } print $1; print $label{$s_pref.$2}; print $3; $_ = $'; } print; } # # cleanup # close(tmp); system "rm $tmp";