#!/usr/local/bin/perl

# Copyright (C) by Stein Vidar Hagfors Haugan, April 1999, January  2001,
#                                              September 2002

# Permission hereby granted to anyone (including RSI) to copy and use
# this program, even if you make money by using it, as long as this
# copyright notice is kept intact. It doesn't hurt to throw in an
# acknowledgement if you're selling or giving away stuff produced by
# this program. If you actually get money for the program itself, you
# should pay up to me, though.

###################################################
# get_types($ftype)
###################################################
sub get_idltypes
{
    local($ftype) = @_;

    local ($cvto,$idltype,$ctype,$field);

    $cvto = "XXX";

    $cvto = "Byte" if $ftype =~ /^INTEGER\s*\*1$/i;
    $cvto = "Byte" if $ftype =~ /^CHARACTER(\s*\*\d+)?$/i;
    $cvto = "Byte" if $ftype =~ /^CHARACTER\s*\*\(.*\)$/i;
    $cvto = "Fix"  if $ftype =~ /^INTEGER\s*\*2$/i;
    $cvto = "Lng"  if $ftype =~ /^INTEGER(\s*\*4)?$/i; # INTEGER=4 bytes??
    $cvto = "Lng"  if $ftype =~ /^LOGICAL$/i;          # LOGICAL=4 bytes??
    $cvto = "Flt"  if $ftype =~ /^REAL(\s*\*4)?$/i;
    $cvto = "Dbl"  if $ftype =~ /^(DOUBLE\s*PRECISION|REAL\s*\*8)$/i;
    $cvto = "DComplex" if $ftype =~ /^(DOUBLE)?\s*COMPLEX(\s*\*16)?$/i;
    $cvto = "Complex" if $ftype =~ /^COMPLEX\s*(\*8)?$/i;

    $idltype = "IDL_TYP_";

    $idltype .= "BYTE" if $cvto eq "Byte";
    $idltype .= "INT" if $cvto eq "Fix";
    $idltype .= "LONG" if $cvto eq "Lng";
    $idltype .= "FLOAT" if $cvto eq "Flt";
    $idltype .= "DOUBLE" if $cvto eq "Dbl";
    $idltype .= "COMPLEX" if $cvto eq "Complex";
    $idltype .= "DCOMPLEX" if $cvto eq "DComplex";

    $ctype = "char" if $cvto eq "Byte";
    $ctype = "short" if $cvto eq "Fix";
    $ctype = "int" if $cvto eq "Lng";
    $ctype = "float" if $cvto eq "Flt";
    $ctype = "double" if $cvto eq "Dbl";
    $ctype = "IDL_COMPLEX" if $cvto eq "Complex";
    $ctype = "IDL_DCOMPLEX" if $cvto eq "DComplex";
    
    $field = "c" if $cvto eq "Byte";
    $field = "i" if $cvto eq "Fix";
    $field = "l" if $cvto eq "Lng";
    $field = "f" if $cvto eq "Flt";
    $field = "d" if $cvto eq "Dbl";
    $field = "cmp" if $cvto eq "Complex";
    $field = "dcmp" if $cvto eq "DComplex";
    
    ($cvto,$idltype,$ctype,$field);
}

sub escape_pattern
{
    local ($p) = @_[0];
    $p =~ s/\(/\\\(/g; # Escape (
    $p =~ s/\*/\\\*/g; # Escape *
    $p =~ s/\)/\\\)/g; # Escape )
    $p;
}

#################################################################
# Parses possible declaration a la "CHARACTER*4 P(155),P2(10)"
#
# 1st arg is input line to parse
# 2nd arg is e.g. "CHARACTER"
# 3rd arg is the type (empty string if 2nd arg is DIMENSION)
# 4th arg is *var
# 5th arg is *type
# 6th arg is *dim

sub parselist 
{
    local($srch,$thistype,*var,*vartype,*dim) = @_;

    $srch = &escape_pattern($srch);

    if ( /(\b$srch\s*)(.*)/ ) {

	$r = $2;

	#             <VAR< (DIM,DIIIM)>?>,    REST
	while ($r =~ /(\w+(\([^\(\)]*\))?),?\s*(.*)/) {
	    $r = $3;
	    $decl = $1;
	    ($thisvar,$thisdim) = ($decl =~ /(\w+)((\(.*\))?)/);
	    for ($j=0; $j<=$#var; $j++) {
		if ( $var[$j] =~ /^$thisvar$/i ) {
		    $vartype[$j] = $thistype if $vartype[$j] eq "";
		    $dim[$j] = $thisdim if $dim[$j] eq "";
		    last;
		}
	    }
	}
    }
}

##############################################################
# parse_dcl($sub,*var,*vartype,*dim)
##############################################################
sub parse_dcl 
{
    local ($sub,*var,*vartype,*dim) = @_;
    
    while (<DCLFILE>) { last if /Begin Module\s*$sub/i;}
    while (<DCLFILE>) { last if /Argument variables/;}
    while (<DCLFILE>) { 
	last if /End Module/i;
	next if /^C/;
	($thistype)=/\s+(\S+(\s{0,1}\S+){0,1})\s+\S+/;
	&parselist($thistype,$thistype,*var,*vartype,*dim);
    }
}


###################################################
# write_dlm_file($module,@subs,@ftypes,@nargs)
###################################################
sub write_dlm_file {
    local ($module,*subs,*ftypes,*nargs) = @_;
    local ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
	gmtime(time);
    local ($i);

    $year += 1900;
    $mon = ("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep",
	    "Oct","Nov","Dec")[$mon];

    print DLMFILE <<DLM_STOP;
# Automatically generated from Fortran source file
MODULE \U$module\E
DESCRIPTION Subroutines: $subs[0..$#subs]
BUILD_DATE $mday $mon $year
SOURCE Perl script written by S. V. H. Haugan
DLM_STOP

    for ($i=0; $i<=$#subs; $i++) {
	$sub = $subs[$i];
	$narg = $nargs[$i];
	$proc_fun = $ftypes[$i] eq "" ? "PROCEDURE" : "FUNCTION";
	print DLMFILE "$proc_fun \U$prefix$sub\E $narg $narg\n";
    }
}


###################################################
# write_cfile_header;
###################################################
sub write_cfile_header {
    print CFILE <<HEADER_STOP;
#include <unistd.h>
#include <stdio.h>
#include "export.h"
    
#define NULL_VPTR ((IDL_VPTR) NULL)
    
#define GETVARADDR(v) ((v->flags&IDL_V_ARR) ? (void*)v->value.arr->data \\
    : (void*) &v->value.c)
    
#define GETVARDATA(v,n) ((v->flags&IDL_V_ARR) \\
    ? (*(n) = v->value.arr->n_elts, v->value.arr->data) \\
    : (*(n) = 1, & v->value.c ) )

#define IDL_SINCE(maj,min) \\
    ((IDL_VERSION_MAJOR>maj) || (IDL_VERSION_MAJOR==maj && IDL_VERSION_MINOR>=min))
    
HEADER_STOP
}


###################################################
# write_sysfun_defs(*subs,*ftypes,*nargs)
###################################################

sub write_sysfun_defs {
    local (*subs,*ftypes,*nargs) = @_;
    local ($l);
    print CFILE "int IDL_Load(void)\n{\n";

    local($npros,$npro,$nfuns,$nfun,$nvoid) = (0,0,0,0,0);

    foreach $ftype (@ftypes) { $npros++ if $ftype eq ""; 
			       $nvoid++ if $ftype =~ /COMPLEX/i; };
    $npro = $npros;
    $nfun = $nfuns = ($#ftypes+1 - $npro - $nvoid);

# Added code 10 September 2002 to use IDL_SysRtnAdd for IDL v 5.3+

    print CFILE "\n#if IDL_SINCE(5,3)\n\n";

    if ($npro) {
	print CFILE "  static IDL_SYSFUN_DEF2 proc_def[] = {\n    ";
	for ($i=0; $i<=$#subs; $i++) {
	    if ($ftypes[$i] eq "") {
		$sub = $subs[$i];
		$narg = $nargs[$i];
		$comma = (--$npro) ? "," : "";
		print CFILE "{(IDL_FUN_RET) \U$sub\E,\"\U$prefix$sub\E\",";
		print CFILE "$narg,$narg,0,(void*)0}$comma\n    ";
	    }
	}
	print CFILE "};\n";
    }

    # Now do the functions 

    if ($nfun) {
	print CFILE "  static IDL_SYSFUN_DEF2 func_def[] = {\n    ";
	
	for ($i=0; $i<=$#subs; $i++) {
	    if ($ftypes[$i] ne "" && ! ($ftypes[$i] =~ /COMPLEX/i)) {
		$sub = $subs[$i];
		$narg = $nargs[$i];
		$comma = (--$nfun) ? "," : "";
		print CFILE "{(IDL_FUN_RET) \U$sub\E,\"\U$prefix$sub\E\",";
		print CFILE "$narg,$narg,0,(void*)0}$comma\n    ";
	    }
	}
	print CFILE "};\n";
    }

    $l = "";
    $l = "IDL_SysRtnAdd(proc_def,IDL_FALSE,$npros)" if $npros;
    $l .= " &&\n         " if $nfuns && $npros;
    $l .= "IDL_SysRtnAdd(func_def,IDL_TRUE,$nfuns)" if $nfuns;
    print CFILE "  return $l;\n";

    # restore $npro  & $nfun before doing the pre-5.3 code 
    # (loops above counted down to zero)

    $npro = $npros; 
    $nfun = $nfuns;
    
    print CFILE "\n#else  /* Before v 5.3 */\n\n";

    if ($npro) {
	print CFILE "  static IDL_SYSFUN_DEF proc_def[] = {\n    ";
	
	for ($i=0; $i<=$#subs; $i++) {
	    if ($ftypes[$i] eq "") {
		$sub = $subs[$i];
		$narg = $nargs[$i];
		$comma = (--$npro) ? "," : "";
		print CFILE "{(IDL_FUN_RET) \U$sub\E,\"\U$prefix$sub\E\",";
		print CFILE "$narg,$narg}$comma\n    ";
	    }
	}
	print CFILE "};\n";
    }

    # Now do the functions 

    if ($nfun) {
	print CFILE "  static IDL_SYSFUN_DEF func_def[] = {\n    ";
	
	for ($i=0; $i<=$#subs; $i++) {
	    if ($ftypes[$i] ne "" && ! ($ftypes[$i] =~ /COMPLEX/i)) {
		$sub = $subs[$i];
		$narg = $nargs[$i];
		$comma = (--$nfun) ? "," : "";
		print CFILE "{(IDL_FUN_RET) \U$sub\E,\"\U$prefix$sub\E\",";
		print CFILE "$narg,$narg}$comma\n    ";
	    }
	}
	print CFILE "};\n";
    }

    $l = "";
    $l = "IDL_AddSystemRoutine(proc_def,IDL_FALSE,$npros)" if $npros;
    $l .= " &&\n         " if $nfuns && $npros;
    $l .= "IDL_AddSystemRoutine(func_def,IDL_TRUE,$nfuns)" if $nfuns;
    print CFILE "  return $l;\n";

    print CFILE "\n#endif\n\n";

    print CFILE "}\n";
}


###################################################
# print_cfunc_header($name,$nargs,$ftype)
###################################################

sub print_cfunc_header {
    local ($name,$nargs,$ftype) = @_;
    local ($cvto,$idltype,$ctype);

    $ctype = "void";

    ($cvto,$idltype,$ctype,$field) = &get_idltypes($ftype);
    
    print "extern $ctype \L$name\E_(";  
    print "void*," x ($nargs-1);
    print "void*);\n\n";
    print <<SUBHEADER_STOP;
    
IDL_VPTR \U$name\E(int argc, IDL_VPTR argv[])
{
  int in; /* Set flag appropriately before each variable block      */
  int i=0; /* Note it's use in indexing argv[i++]                   */
           /* This simplifies taking away extra arguments,          */
           /* typically those specifying the number of elements     */
           /* in input arrays (available as var->value.arr->n_elts) */

  int ndim;
  IDL_MEMINT dim[IDL_MAX_ARRAY_DIM];
  IDL_VPTR call[1]; /* For use when calling conversion routines */
  
  IDL_VPTR tmp;
SUBHEADER_STOP

}

###################################################
# print_arr_init($var,$dim,$vartype,$idltype,$arr_init,$e)
###################################################
sub print_arr_init
{
    local ($var,$dimstr,$vartype,$idltype,$arr_init,$e) = @_;
    local($i);
    
    $e = $e . "    ";
    
    if ($dim =~ /\*/) {
	print $e."/* Cannot be out, dimension=$dim? */\n";
	return;
    }
    if ($dim eq "") {
	print $e."IDL_StoreScalarZero($var,$idltype);  "
	    ."/* Not for in/out! */\n";
	return;
    }

    ($dimstr) = ($dimstr =~ /\((.*)\)/);
    
    @dims = split(/,/,$dimstr);
    
    if ($vartype =~ /CHARACTER\s*\*(.+)/i) { @dims = ($1,@dims); }
    
    print $e."ndim = ";
    print $#dims+1 . ";\n";
    
    for ($i=0; $i<=$#dims; $i++) {
	$dims[$i] =~ s/0:(.*)/$1/;
	$dims[$i] = "\U$dims[$i]\E_->value.l /*???*/"  
	    if ($dims[$i] =~ /^\D/);
	$dims[$i] .= " /* Should depend on input var? */"
	    if $dims[$i] !~ /value\.l/;
	print $e."dim[$i] = $dims[$i];\n";
    }
    
    print $e."IDL_StoreScalarZero($var,$idltype);  /* Free resources */\n";
    print $e."IDL_MakeTempArray($idltype,ndim,dim,$arr_init,&tmp);\n";
    print $e."IDL_VarCopy(tmp,$var);\n";
}

##########################################################
# print_array_suggestion($var,$input,$vartype)
##########################################################
sub print_array_suggestion
{
    local ($var,$input,$vartype) = @_;
    local ($cvto,$idltype,$ctype,$field) =
	&get_idltypes($vartype);
    
    print <<ARRAY_SUGGESTION_STOP;
      IDL_StoreScalarZero($var,$idltype);   /* Free resources */
      IDL_MakeTempArray($idltype,$input->value.arr->n_dim,
			$input->value.arr->dim,IDL_ARR_INI_ZERO,&tmp);
      IDL_VarCopy(tmp,$var);
ARRAY_SUGGESTION_STOP
}

###################################################
# print_variable_block($var,$vartype,$dim,$in,$vectorize)
###################################################
sub print_variable_block {
    local ($var,$vartype,$dim,$in,$vectorize) = @_;
    local ($int,$nocomplex,$scalar_array,$cvto,$idltype,$array_dim);

    ($cvto,$idltype) = &get_idltypes($vartype);

    if ($cvto eq "XXX") {
	print STDERR "$var '$vartype' '$dim' -> XXX ?\n";
    }

    $in = 0 if !$in;
    $in = 1 if $dim =~ /\*/;
    

    print <<VARIABLE_BLOCK_STOP1;
  in = $in;           /* $var : $vartype : $dim : $int */
  if (in) {
    IDL_EXCLUDE_UNDEF($var);
    IDL_ENSURE_SIMPLE($var);
VARIABLE_BLOCK_STOP1
    print "    IDL_EXCLUDE_STRING($var);\n" if $vartype !~ /CHARACTER\s*\*/i;
    
    print "    IDL_EXCLUDE_COMPLEX($var);\n" if $vartype !~ /COMPLEX/i;
      
    if ($vectorize eq "") {
	$scalar_array = $dim eq "" ? "SCALAR" : "ARRAY";
	print "    IDL_ENSURE_$scalar_array($var);\n";
    }

    print "    call[0] = $var;\n";

# Jan 11  2001:
# IDL version 5.4 suddenly introduced a change in IDL_CvtComplex!!
# So we have to use preprocessor directives to test 

    if ($cvto eq "Complex") {
	print ("#if IDL_SINCE(5,4)\n" .
	       "    $var = IDL_Cvt$cvto(1,call,(void*)NULL);\n" .
	       "#else \n")
    }

    print "    $var = IDL_Cvt$cvto(1,call); "
	."/* May cause $var to be tmp */\n";


    if ($cvto eq "Complex") {
	print "#endif\n";
	}

    print "  } else { /* Output */ \n";
    print "    IDL_EXCLUDE_EXPR($var); /* Output cannot be expression */\n";
    
    local ($e) = "";
    if ($vectorize ne "") {
	print "    if ($vectorize->flags&IDL_V_ARR) {\n";
	&print_array_suggestion($var,$vectorize,$vartype);
	print "    } else {\n";
        $e = "  ";
    } 

    $arr_init = "IDL_ARR_INI_ZERO";

    &print_arr_init($var,$dim,$vartype,$idltype,$arr_init,$e);
    print "    }\n" if $vectorize ne "";

    print "  }\n\n";
}

###################################################
# print_fortran_call($name,$ftype,@var,@vartype,$offset);
###################################################

sub print_fortran_call
{
    local($name,$ftype,*var,*vartype,$offset) = @_;

    local($l,$i);
    
    if ($ftype eq "") {
	$l = "     \L$name\E_(";
    } else {
	local ($cvto,$idltype,$ctype,$field) = &get_idltypes($ftype);
	$l = "    tmp->value.$field =\L$name\E_(" if !$offset;
	if ($offset) {
	    print "      *(i+($ctype*)tmp->value.arr->data) = \n";
            $l =    "             \L$name\E_(";
	}
    }

    $len = length($l);
    
    for ($i=0; $i<=$#var; $i++) {
	$comma = $i < $#var ? "," : ");"; # All but last one has comma
	if ($offset) {
	    local ($cvto,$idltype,$ctype,$field) =
		&get_idltypes($vartype[$i]);
	    $l .= "i*a[$i] + ($ctype*)";
	}
	$l .= "GETVARADDR($var[$i])$comma";  
	if (length($l) > 40 || $i==$#var) {
	    print "$l\n";
	    $l = " " x $len;
	}
    }

    # Fix fixed length strings...assume they should be converted back
    # to strings from byte arrays...

    for ($i=0; $i<=$#var; $i++) {
	if ($vartype[$i] =~ /CHARACTER\s*\*(\d+)/i) {
	    print "  call[0] = $var[$i];\n";
	    print "  tmp = IDL_CvtString(1,call,NULL);\n";
	    print "  IDL_VarCopy(tmp,$var[$i]);\n";
	}
    }

}


##################################################
# gobble_routine_body(*var,*assignto)
##################################################
sub gobble_routine_body
{
    local(*var,*assignto) = @_;

    while (!/^\s+END\b/i) {
	if (/^[\*Cc]/) {
	    s/^\S(.*)\n/$1/;  next if length == 0;
	    $commlen = length if $commlen < length;
	    $_ .= " " x ($commlen - length);
	    @comments = (@comments,"/* $_ */\n");
	    next;
	}
	
	# Check for assignments to parameters
	for ($i=0; $i<=$#var; $i++) {
	    $assignto[$i] = $assignto[$i] 
		|| /^\s+$var[$i]\b.*=/i;
	}
	last if eof(ARGV);
    } continue { 
	$_ = <>; 
	print FORTRAN;
    }
}

###################################################################
# print_cfunc($name,$ftype,*var,*vartype,*dim,*assignedto)
###################################################################
sub print_cfunc
{
    local ($name,$ftype,*var,*vartype,*dim,*assignedto) = @_;

    return if $ftype =~ /COMPLEX/i;

    foreach $vv (@var) { $vv .= "_"; }

    &print_cfunc_header($name,$#var+1,$ftype);
    print "@comments\n";
    @comments = ();
	
    # Initialization of variable ptrs from argv[] 
    for ($i=0; $i<=$#var; $i++) {
	print "  IDL_VPTR $var[$i]=argv[i++];  ";
	$int = ("in?","out?")[$assignto[$i]];
	print  "/* $var[$i] : $vartype[$i] : $dim[$i] :$int */\n";
    }
    print "\n\n";
	
    # Analyze dimensions to see if arrayification is appropriate.

    $allscalar = 1;
    $ninput = 0;
    $firstinput = -1;
    for ($i=0; $i<=$#var; $i++) {
	$allscalar &= $dim[$i] eq "";
	$ninput++ if !$assignto[$i];
	$firstinput = $i if !$assignto[$i] && $ninput==1;
    }

    local ($input) = "ar" if $allscalar;

    if ($allscalar) {
	print "  /*NOTE: All fortran arguments scalar */\n";
	print "  /*NOTE: Suggesting arrayification "
	    ."based on variable '$input' */\n\n";

	print "  IDL_VPTR ar=NULL_VPTR; /* Arrayification variable */ \n";
	print "  int a[$#var+1];        /* argv[i] is a variable or not? */\n";
	print "\n\n";
    
	# In case of arrayification, the array with the least number of 
	# elements decides the size & structure of the output variables.
    
	for ($i=0; $i<=$#var; $i++) {
	    local($e) = "      ";
	    print "  in = " . ($assignedto[$i]?"0":"1") . ";";
	    print "  /* $var[$i] : $vartype[$i] : $dim[$i] */ \n";
	    print "  if (in && $var[$i]\->flags &IDL_V_ARR ".
		"/* Delete statement for output args */\n";
	    print $e."&& (ar==NULL_VPTR \n";
	    print $e."    || $var[$i]\->value.arr\->n_elts ".
		"< ar\->value.arr\->n_elts))\n";
	    print $e."          ar=$var[$i];\n";
	    print "  \n";
	}

	print "  if (ar==NULL_VPTR) ar = $var[0]; /* Scalar call? */\n\n";
    }

    print "\n  /* TYPE CHECKING / ALLOCATION SECTION */\n\n";

    # Print the variable checking block for all variables.
    for ($i=0; $i<=$#var; $i++) {
	&print_variable_block($var[$i],$vartype[$i],$dim[$i],
			      !$assignto[$i],$input);
    }

    # If arrayification is in effect, check which parameters are
    # scalar and which are arrays.

    for ($i=0; $i<=$#var; $i++) {
	print "  a[$i] = ($var[$i]\->flags&IDL_V_ARR) ? 1 : 0;\n"
	    if $allscalar;
    }
    print "\n" if $allscalar;

    # And now for the call....

    local ($e) = "  "; # Used as shorthand & to control indentation.
    
    local ($fcvto,$fidltype,$fctype,$ffield) =
	&get_idltypes($ftype) if $ftype;

    # Arrayification suggested ?
    if ($input ne "") { 
	print $e."if ($input->flags&IDL_V_ARR) {\n";
	
	# Is it a function as well?
	if ($ftype ne "") {
	    print $e."  /* Storage for result */\n";
	    print $e."  IDL_MakeTempArray($fidltype,";
	    print "$input->value.arr->n_dim,\n";
	    print $e."                    $input->value.arr->dim,";
	    print "IDL_ARR_INI_NOP,&tmp);\n";
	}

	# Loop over result if arrayified and IDL_V_ARR is set!
	print "$e  ".
	    "for (i=0; i<$input->value.arr->n_elts;i++)\n";
	&print_fortran_call($name,$ftype,*var,*vartype,1); # 1->arrayified
       
	# ...else IDL_V_ARR is not set, but the scalar call should
	# be indented extra..
	print $e."} else { \n";
	$e .= "  ";
    }

    print $e."tmp = IDL_Gettmp(); /* Storage for result */\n" if $ftype ne "";

    &print_fortran_call($name,$ftype,*var,*vartype,0); # 0->scalar call

    # This finishes the "if (IDL_V_ARR) {...} else {" brace.

    print "  }\n" if $input ne ""; 

    # Cleanup temporary variables.
    # NOTE! It's not safe to let IDL_DELTMP decide whether or not to
    # delete the variable based on whether or not it's a temp. It could
    # be a temp that was created by the caller and sent to us. The best
    # way is to check whether the variable pointer points to something
    # which is *not* what we got from our caller.

    # Note also that the result of copying e.g. a temporary array
    # into a named variable (an argument) does *not* make the argument
    # a temporary varible, neither does it alter the variable pointer!

    print "  i=0;\n";
    for ($i=0; $i<=$#var; $i++) {
	print "  if ($var[$i]!=argv[i++]) IDL_DELTMP($var[$i]);\n";
    }
    
    # If it's a function, return the result - otherwise return NULL_VPTR
    if ($ftype ne "") {
	print "  tmp->type = $fidltype;\n";
	print "  return tmp;\n";
    } else { 
	print "  return NULL_VPTR;\n";
    }
    
    print  "}\n\n";
}

sub read_sub_func
{
    # Find SUBROUTINE declarations & parameters.

    print CFILE @comments if $cfile;
    @comments = ();

    local ($commlen) = 40;
    local (@var,@vartype,@dim,@assignedto);
    local ($r);
    
    # We'll keep on eating lines until we don't find a continuation line,
    # to make sure we get the whole routine definition as one string.
    
    ($r) = /(.*)\n/;
    
    while (<>) {
	print FORTRAN;
	last if /^\t/ || !s/^     \S//;
	s/\n//;
	$r .= $_;
    }
    
    local ($r_org) = $r;

    local ($decl,$void,$ftype,$name,$r) = 
	$r =~ /^\s+(((\S.*)\s+FUNCTION|SUBROUTINE)\s+(\w+))(.*)/i;
    
    if ($name eq "") {
	print STDERR 
	    "\nDLMFORM: Couldn't parse FUNCTION/SUBROUTINE decl properly\n";
	print STDERR 
	    "DLMFORM: Only declarations like 'REAL FUNCTION BLAHBLAH(..)'".
		"are allowed\n" if $r_org =~ /FUNCTION/i;
	print STDERR 
	    "DLMFORM: Offending line:\n";
	print STDERR
	    "DLMFORM: '$r_org'\n";
	die "Whoops???";
    }

    if ($ftype =~ /COMPLEX/i) {
	print STDERR "\nWarning: Cannot do COMPLEX FUNCTIONs: " .
	    "modify or write wrapper subroutine!\n\n";
    }	
    
    local ($var,$r) = $r =~ /\(\s*(\w+)\s*,?(.*)/i;
    
    while ($var) {
	@var = (@var,"\U$var\E");
	@vartype = (@vartype,"");
	@dim = (@dim,"");
	@assignedto = (@assignedto,0);
	($var,$r) = ($r =~ /\s*(\w+),?(.*)/);
    }
  
    @subs = (@subs,$name);
    @ftypes = (@ftypes,$ftype);
    @nargs = (@nargs,$#var+1);
    
    $r = $_; # Keep it
    &parse_dcl($name,*var,*vartype,*dim);
    $_ = $r; # Restore it
    
    print FORTRAN;
    
    # Process func/sub body, checking for assignments to arguments
    &gobble_routine_body(*var,*assignto);
 
    if (/^\s*END\b/i && $cfile) {
	$oldfh = select(CFILE);
	&print_cfunc($name,$ftype,*var,*vartype,*dim,*assignedto);

	
	select($oldfh);
    }
}

$prefix = "F77_";

 LINE:
while (<>) {
    
    # NEW FILE - bookkeeping.
    if ($ARGV ne $oldargv) {
	
	$module = $oldargv = $ARGV;
	$module =~ s/\.for//;
	
	die "Cannot find $module.dcl\n" if ! -f "$module.dcl";	
	
	$cfile = ! -f "$module.c";
	print "Not touching existing file $module.c\n" if !$cfile;
	
	open (FORTRAN,">$module.f");
	open (CFILE,">$module.c") if $cfile; # Open C file
	open (DLMFILE,">$module.dlm");   # Open DLM file
	open (DCLFILE,"<$module.dcl");
	
	# Zero lists.
	@subs = ();
	@ftypes = ();
	@nargs = ();

	&write_cfile_header if $cfile;
    }
    
    # Main program should be commented out!
    if (/^\s*PROGRAM/i) {
	do { s/^/C/; print FORTRAN; $_ = <>;} until (/^\s*END\b/);
	s/^/C/i; print FORTRAN;
	next LINE;
    }
    
    print FORTRAN;

    # Comments in front of a subroutine/function should be added to
    # it's comment list.
    if (/^[\*cC]/) {
	s/^\S(.*)\n/$1/;
	next LINE if length == 0;
	$commlen = length if $commlen < length;
	$_ .= " " x ($commlen - length);
	@comments = (@comments,"/* $_ */\n");
	next LINE;
    }

    # If we're seeing the start of a function/subroutine, deal with it
    &read_sub_func if /^\s+((.*)\s*FUNCTION|SUBROUTINE)\b/i;

} continue {
    # If we're seeing the end of a source file, write the IDL_Load
    # procedure with IDL_SYSFUN_DEF blocks, and the .dlm file.
    if (eof) {
	&write_sysfun_defs(*subs,*ftypes,*nargs);
	&write_dlm_file($module,*subs,*ftypes,*nargs);
	close CFILE;
	close DLMFILE;
    }
}