Path: utzoo!attcan!uunet!elroy.jpl.nasa.gov!ncar!cgdisis.cgd.ucar.edu!kate
From: kate@cgdisis.cgd.ucar.edu (Kate Hedstrom)
Newsgroups: comp.lang.fortran
Subject: renumbering
Message-ID: <10235@ncar.ucar.edu>
Date: 11 Feb 91 14:12:31 GMT
References: <1991Feb4.195630.6570@math.ufl.edu> <5166@awdprime.UUCP> <37298@netnews.upenn.edu>
Sender: news@ncar.ucar.edu
Organization: Institute of Marine and Coastal Sciences/Rutgers University
Lines: 290

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";