sverre@fesk.UUCP (Sverre Froyen) (10/07/89)
Here is a perl script I whipped up to relabel fortran code.
As noted in the script it will not treat all types of
legal fortran statements containing lables, and the user is advised
to check the code for errors after use. The script can be used
as a filter or with file name as argument. Relabeled code on
standard output.
Bug fixes and/or improvements are welcome.
Enjoy -- Sverre
#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of shell archive."
# Contents: relabel
# Wrapped by bin@fesk on Fri Oct 6 11:36:33 1989
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'relabel' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'relabel'\"
else
echo shar: Extracting \"'relabel'\" \(4996 characters\)
sed "s/^X//" >'relabel' <<'END_OF_FILE'
Xeval "exec /usr/bin/perl -S $0 $*"
X if $running_under_some_shell;
X#
X# Relabel a fortran program
X#
X# Usage: relabel [file]
X#
X# Restrictions:
X#
X# No computed goto
X# No assigned goto or assign
X# No arithmetic if
X# No new-lines inside the parenthesis immediately following a read/write
X# Others that I have not thought of
X#
X# $Header: /usr/local/src/RCS/relabel,v 1.1 89/10/06 11:23:32 bin Exp $
X#
X$tmp = "/tmp/rel.$$"; # Temporary file name
X$label_no_start = 100; # First new label number
X$label_no_incr = 10; # New label increment
X$cont_char = '+'; # Continuation character
X$label_no = $label_no_start;
X$section_no = 0;
X$s_pref = $section_no."_";
X#
X# get a line, combining continuation lines
X#
Xsub get_line {
X $thisline = $lookahead;
X line: while ($lookahead = <tmp>) {
X if ($lookahead =~ s/^ \S/ $cont_char/) {
X $thisline .= $lookahead;
X }
X else {
X last line;
X }
X }
X $thisline;
X}
X#
X# Find matching parenthesis
X#
Xsub find_match {
X $parexp = '';
X while (/[()]/) {
X $parexp .= $`;
X $parexp .= $&;
X $_ = $';
X if ($& eq "(") { $left++; }
X else { $left--; }
X if ($left == 0) { last; }
X }
X}
X#
X# first pass - collect all labels and copy to tmp file
X#
Xopen(tmp,">$tmp") || die "Can't open tmp file";
X$no_change_needed = 1;
Xwhile (<>) {
X#
X# Skip comments
X#
X if (/^[c#]/i) {
X print tmp;
X next;
X }
X#
X# Check for new section (function or subroutine)
X#
X if (/function|subroutine/i) {
X $section_no++;
X $s_pref = $section_no."_";
X $label_no = $label_no_start;
X }
X#
X# Check for numeric label field
X#
X $label_field = substr($_,0,5);
X if ($label_field =~ s/^[ 0]*([1-9][0-9]*) */$1/) {
X $label_field = $s_pref.$label_field;
X if ($label{$label_field}) { # Duplicate label
X close(tmp);
X system "rm $tmp";
X die "Duplicate label $label_field";
X }
X if ($label_field != $label_no) {
X $no_change_needed = 0;
X }
X printf tmp ("%5d", $label_no); # New label
X $_ = substr($_,5,-1);
X $label{$label_field} = $label_no;
X $label_no += $label_no_incr;
X if (/^ *format/i) { # Label type
X $type{$label_field} = "format";
X }
X else {
X $type{$label_field} = "other";
X }
X }
X print tmp;
X}
Xclose(tmp);
Xif ($no_change_needed) {
X system "cat $tmp";
X system "rm $tmp";
X exit 0;
X}
X#
X# Second pass - relabel
X#
Xopen(tmp,"$tmp") || die "Can't open tmp file - second pass";
X$lookahead = <tmp>; # Get first line
X$section_no = 0;
X$s_pref = $section_no."_";
Xwhile ($_ = do get_line()) {
X#
X# Skip comments
X#
X if (/^[c#]/i) {
X print;
X next;
X }
X s/\t/ /g; # Replace tabs with blanks
X#
X# Check for new section (function or subroutine)
X#
X if (/function|subroutine/i) {
X $section_no++;
X $s_pref = $section_no."_";
X }
X#
X# Remove and print label field
X# (these were changed during first pass)
X#
X print substr($_,0,6);
X $_ = substr($_,6,-1);
X#
X# Must first skip past `if (...)' constructs
X#
X if (/^ *if *\(/i) {
X print $&;
X $_ = $';
X $left = 1;
X do find_match();
X if ($left != 0) { die "Illegal if statement"; }
X print $parexp;
X }
X#
X# Skip to next line if end-of-line before continuation-line
X#
X if (/^ *\n \S */) {
X print $&;
X $_ = $';
X }
X#
X# Do some simple tests to see if line needs further processing
X# (to speed things up)
X#
X if ($_ !~ /^ *read|^ *write|^ *open|^ *go *to|^ *do/i) {
X print;
X next;
X }
X study;
X#
X# Read / write
X#
X if (/^ *read *\(|^ *write *\(/i) {
X print $&;
X $_ = $';
X $left = 1;
X do find_match();
X if ($left != 0) { die "Illegal read/write statement"; }
X if ($parexp =~ /\n/) { # Can be removed later
X die "Cannot handle new-lines in r/w statements";
X }
X if ($parexp =~ /^([ a-z0-9()*]+ *)/i) {
X print $1; # unit
X $parexp = $';
X }
X if ($parexp =~ /^(, *)([0-9]+)/i) {
X if ($type{$s_pref.$2} ne "format") {
X die "Wrong label type - # $2";
X }
X print $1;
X print $label{$s_pref.$2}; # format number
X $parexp = $';
X }
X while ($parexp =~ /^( *, *[ednr]+ *= *)([0-9]+)/i) {
X if ($type{$s_pref.$2} ne "other") {
X die "Wrong label type - # $2";
X }
X print $1; # end / err
X print $label{$s_pref.$2}; # label
X $parexp = $';
X }
X print $parexp;
X }
X#
X# open
X#
X elsif (/^ *open *\(/i) {
X print $&;
X $_ = $';
X $left = 1;
X do find_match();
X if ($left != 0) { die "Illegal open statement"; }
X while ($parexp =~ /([ednr]+ *= *)([0-9]+)/i) {
X print $`;
X if ($type{$s_pref.$2} ne "other") {
X die "Wrong label type - # $2";
X }
X print $1; # end / err
X print $label{$s_pref.$2}; # label
X $parexp = $';
X }
X print $parexp;
X }
X#
X# goto
X#
X elsif (/^ *go *to */i) {
X print $&;
X $_ = $';
X if (/^([0-9]+) *$/i) { # only simplest type
X if ($type{$s_pref.$1} ne "other") {
X die "Wrong label type - # $1 sec $section_no";
X }
X print $label{$s_pref.$1};
X $_ = $';
X }
X else { die "Illegal goto"; }
X }
X#
X# do
X#
X elsif (/^( *do *)([0-9]+)( *[a-z0-9]+ *= *[a-z0-9]+ *, *[a-z0-9]+)/i) {
X if ($type{$s_pref.$2} ne "other") {
X die "Wrong label type - # $2";
X }
X print $1;
X print $label{$s_pref.$2};
X print $3;
X $_ = $';
X }
X print;
X}
X#
X# cleanup
X#
Xclose(tmp);
Xsystem "rm $tmp";
END_OF_FILE
if test 4996 -ne `wc -c <'relabel'`; then
echo shar: \"'relabel'\" unpacked with wrong size!
fi
chmod +x 'relabel'
# end of 'relabel'
fi
echo shar: End of shell archive.
exit 0
--
Sverre Froyen
UUCP: boulder!fesk!sverre, sunpeaks!seri!fesk!sverre
ARPA: sverre@fesk.seri.gov
BITNET: froyen@csugold.bitnet