#!/usr/local/bin/perl -w
#-*-perl-*-
######################################################################
# 
# File: fd2pl
# 
# Created:       Sat Sep 23 23:47:54 1995 by Zoran Popovic
# 
# parse a c or fd file produced by fdesign and create the
# appropriate perl file.  If converting from the C file make sure
# it is dumped by fdesign in "Alt Format".
# 
######################################################################

$fdesign = "/usr/local/xforms81/DESIGN/fdesign";

$verbose_parse = 0;
$suffix = "pl";

sub usage {
   print STDERR "Usage: fd2pl fdesign_file.{fd,c} [fdesign_file.pl]\n";
   die("wrong number of args");
}

usage() if ($#ARGV < 0);

$infile = shift;
($infile_base, $infile_format) = $infile =~ /^(.*?)\.?([^.]*)$/;

usage() unless ($infile_format =~ /^(c|fd)$/);

if ($#ARGV < 0) {
   $outfile = "$infile_base.$suffix";
}
else {
   $outfile = shift;
}

$out_header= <<"EOH";
#!/usr/local/bin/perl -w
#-*-perl-*-
# Autogenerated by fd2pl from fdesign file $infile
#
EOH

$vregex = '\w+(?:\[[0-9]+\])?';

if ($infile_format eq "fd") {
   system "$fdesign -altformat -convert $infile"
     and die("invoking fdesign");
}   

$cfile = "$infile_base.c";

open(IN, "<$cfile") or die ("opening $cfile");
open(OUT, ">$outfile") or die ("opening $outfile");
print OUT $out_header;
print OUT "\n";

$chunk="";

$tab_width = 2;
$indent_level = 0;

while(<IN>) {
    # chunk ends with a semi-colon ;
    if (/^([^\;]*\;)(.*)/) {
	$chunk .= $1;
	my $rest = $2;

	# this horrible thing strips all C comments
	$chunk =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/|([^/"']*("[^"\\]*(\\[\d\D][^"\\]*)*"[^/"']*|'[^'\\]*(\\[\d\D][^'\\]*)*'[^/"']*|/+[^*/][^/"']*)*)#$2#g; 
 
        convert_chunk("$chunk");
	$chunk=$rest;
    } else {
	$chunk .= $_;
    }
}
convert_chunk("$chunk");
close(IN);

close(OUT);

sub convert_chunk {
    $_ = $_[0];

    SWITCH: {
	# match '}\n'
	# and generate the corresponding perl function ending
	/^\s*}\s+/ && 
	    do {
		$indent_level--;
		print OUT ' ' x ($tab_width * $indent_level);
		print OUT "}\n";
		$verbose_parse && print "- end of function\n";
		convert_chunk("$'");
		last SWITCH;
	    };
	# match 'void create_form_form(void)'
	# and generate the corresponding perl function
	/^\s*void\s+(\w+)\s*\(void\)\s*{\s*/s && 
	    do {
		my $sfun = $1;
		print OUT "\n";
		print OUT ' ' x ($tab_width * $indent_level);
		print OUT "sub $sfun {\n";
		$indent_level++;
		$verbose_parse && print "- function $sfun\n";
		convert_chunk("$'");
		last SWITCH;
	    };
	# match 'FL_FORM *form_name'
	# and generate the corresponding perl code
	/\s*FL_FORM\s+\*($vregex)\s*;/s && 
	    do {
		print OUT ' ' x ($tab_width * $indent_level);
		define_var($1);
		print OUT "\n";
		$verbose_parse && print "- FL_FORM $1\n";
		last SWITCH;
	    };
	# match 'FL_OBJECT *obj0, ..., *obj_arr[n], ..., *objn;'
	# and generate the corresponding perl code
	/\s*FL_OBJECT\s+([^;]+)\s*;/ && 
	    do {
		my @objects = map {s/\*//; s/\s//g; $_} split(/,/, $1);
		foreach $obj ( @objects ) {
		    print OUT ' ' x ($tab_width * $indent_level);
		    define_var($obj);
		    print OUT "\n";
		}
		$verbose_parse && print "- FL_OBJECT @objects\n";
		last SWITCH;
	    };
	# match double assignment 'var0 = var1 = expr;'
	# and generate the appropriate perl code
	/\s+($vregex)\s*=\s*($vregex)\s*=\s*([^;]+)\s*;/ && 
	    do {
		my ($var0, $var1, $expr) = ($1, $2, $3);
		print OUT ' ' x ($tab_width * $indent_level);
		set_var($var1, $expr);
		print OUT "\n";
		print OUT ' ' x ($tab_width * $indent_level);
		set_var($var0, $var1);
		print OUT "\n";
		$verbose_parse && 
		  print "- double assignment $var0=$var1=$expr\n";
		last SWITCH;
	    };
	# match single assignment 'var = expr;'
	# and generate the appropriate perl code
	/\s+($vregex)\s*=\s*([^;]+)\s*;\s*$/ && 
	    do {
		my ($var, $expr) = ($1, $2);
		print OUT ' ' x ($tab_width * $indent_level);
		set_var($var, $expr);
		print OUT "\n";
		$verbose_parse && print "- assignment $var=$expr\n";
		last SWITCH;
	    };
	# match func call 'function_name(arg0, ..., argn);'
	# and generate the appropriate perl call
	/^\s*(\w+\s*\([^\)]*\))\s*;\s*$/ && 
	    do {
		print OUT ' ' x ($tab_width * $indent_level);
		parse_expr($1);
		print OUT ";\n";
		$verbose_parse && print "- func call $1\n";
		last SWITCH;
	    };
    }
}

sub parse_expr {
    $_ = $_[0];
    if (/^\s*(\w+)\s*\(([^\)]*)\)\s*$/) {
	my ($fname, @args) = ($1, split(/,/, $2));
	@args = map(c2pl($_), @args);
	if ($fname =~ /_callback$/) {  # callback param is not a scalar var.
	   $args[1] =~ s/^\$(\w+)$/"$1"/;
	}
	print OUT "$fname(" . join(', ', @args) . ")";
    }
    elsif (/^\s*($vregex)\s*$/) {
	get_var($1);
    }
    else {
	print STDERR "Error: unparsable expression: $_\n";
	die();
    }
}

sub define_var {
    my ($var, $idx) = parse_var($_[0]);
    if (defined($idx)) {	
       $var =~ s/^\$/\@/;
    }
    print OUT "$var = undef;";
}

sub set_var {
    my ($unparsed_var, $unparsed_expr) = @_;
    my ($var, $idx) = parse_var($unparsed_var);
    if (defined($idx)) {	
	print OUT "$var\[$idx\] = ";
    }
    else {
	print OUT "$var = ";
    }
    parse_expr($unparsed_expr);
    print OUT ";";
}

sub get_var {
    my ($unparsed_var) = @_;
    my ($var, $idx) = parse_var($unparsed_var);
    if (defined($idx)) {	
	print OUT "$var\[$idx\]";
    }
    else {
	print OUT "$var";
    }
}

sub parse_var {
    $_ = $_[0];
    if (/^(\w+)\[([0-9]+)\]$/) {
	(c2pl($1), $2);
    }
    elsif (/^(\w+)$/) {
	(c2pl($1), undef);
    }
    else {
	print STDERR "Error: not a var $_\n";
	die();
    }
}

sub c2pl {
    $_ = shift;

    return $_ if (/^".*"$/);            # strings remain unchanged

    s/\s+//g; 			        # remove surrounding space
    return $_ if (/^[A-Z][A-Za-z0-9_]*$/); # constants remain unchanged

    if (/^[^0-9]\w*$/) {          # variables get a '$'
       return "\$$_";
    }
    return $_;
}




#{{{ Emacs local variables
# Local Variables:
# folded-file: t
# End:
#}}}
