#!/usr/local/bin/perl
# Geoffrey Furnish
# Institute for Fusion Studies
# University of Texas at Austin
# 27 June 1995
#
# This script is used to automatically generate most of the functions needed
# to implement the PLplot Tcl API.  It reads a file which specifies the
# PLplot API command arguments and return value (basically like a C
# prototype, but easier to parse) and generates a Tcl command procedure to
# call that function.
#
# Currently it can support arguments of type PLINT, PLFLT, char *, PLINT&
# and PLFLT& where the last two are used for the 'g' series functions which
# provide data to the caller.
#
# What is not supported at this time, but needs to be, is support for (those
# few) PLplot API functions with non-void return types, and (the many)
# PLplot API functions which accept arrays (PLFLT *, etc).  The latter can
# in many cases be correctly treated as 1-d Tcl Matricies.  The code for
# using these should be sufficiently perfunctory to be amenable to an
# approach like that used here.  Automatic support for the 2-d API is
# probably unrealistic.
###############################################################################

require "getopts.pl";

&Getopts('v');

$verbose = $opt_v;

# Find the source tree directory that must be specified on the command line.
$sourcedir = $ARGV[0];
$specfile = "$sourcedir/plapi.tpl";	# PLplot API template specification file.
$genfile  = "tclgen.c";			# Generated functions go here.
$genhead  = "tclgen.h";			# Prototypes for generated functions.
$genstruct= "tclgen_s.h";		# Initializers for CmdInfo struct.
$cmdfile  = "$sourcedir/tclcmd.tpl";	# Template file for generated functions.

open( SPECFILE, "<$specfile") || die "Can't open PLplot API spec file.";
open( GENFILE,  ">$genfile" ) || die "Can't open output file.";
open( GENHEAD,  ">$genhead" ) || die "Can't open output header file.";
open( GENSTRUCT,">$genstruct")|| die "Can't open second output header file.";

# Scan the PLplot API template specification file looking for function
# "prototypes".  These are introduced with the token "pltclcmd".  When
# we find one, go process it.  Anything other than a comment or a
# valid function "prototype" is considered an error, and is printed to
# stdout.

while( <SPECFILE> ) {
    chomp;			# skip the \n.

    if (/([^\#]*)\#.*/) {	# Discard # to end of line.
        $_ = $1;
    }
    next if /^\s*$/;            # Discard empty lines.

    if (/^pltclcmd (\w+) (.*)/) {
	$cmd = $1;
	$rtype = $2;

	&process_pltclcmd( $cmd, $rtype );
	next;
    }

# Just print the unrecognized output to stdout.

    print "$_\n";
}

# Process a function "prototype".  Suck up the args, then perform the
# needed substitutions to the Tcl command procedure template.
# Generate the three outputs needed for use in tclAPI.c:  the C
# function prototype, the CmdInfo structure initializer, and the
# actual function definition.

sub process_pltclcmd {
    local( $cmd, $rtype ) = @_;
    local( $i, $refargs );
    local( $vname, $vtype );
    local( $args );

    print "autogenerating Tcl command proc for $rtype $cmd ()\n" if $verbose;

    print GENHEAD "static int ${cmd}Cmd( ClientData, Tcl_Interp *, int, char **);\n";
    print GENSTRUCT "    {\"$cmd\",          ${cmd}Cmd},\n";

    $args = "";
    $nargs = 0;
    $ndefs = 0;
    $refargs = 0;
    while( <SPECFILE> ) {
	chomp;

	last if /^$/;
	if (/^(\w+)\s+(.*)$/) {
	    $vname = $1;
	    $vtype = $2;
	    $defval = "";
	    print "vname=$vname vtype=$vtype\n" if $verbose;
	    if ($vtype =~ /\s*(.*)\s+Def:\s+(.*)/) {
		$vtype = $1;
		$defval= $2;
		print "default arg: vtype=$vtype defval=$defval\n" if $verbose;
	    }
	    $argname[ $nargs ] = $vname;
	    $argtype[ $nargs ] = $vtype;
	    $argdef[  $nargs ] = $defval;
	    $argref[  $nargs ] = 0; # default.

	# Check to see if this arg is for fetching something from PLplot.

	    if ($vtype =~ /&/ || $vtype eq "char *") {
		$refargs = 1;
		$argref[ $nargs ] = 1;
	    }

	    if ($nargs == 0) {
		$args .= "$vname";
	    } else {
		$args .= " $vname";
	    }
	    $ndefs++ if $defval ne "";
	    $nargs++;
	    next;
	}

    # Unrecognized output.

	print "bogus: $_\n";
    }

    if ($verbose) {
	print "There are $nargs arguments, $ndefs are defaultable.\n";
	for( $i=0; $i < $nargs; $i++ ) {
	    print "$argtype[$i] $argname[$i]\n";
	}
	print "return string required.\n" if $refargs;
    }

    open( TEMPLATE, "<$cmdfile" ) || die "Can't open tcl cmd template file.";

    while( <TEMPLATE> ) {

    # Emit the argument declarations.  Reference args require special
    # handling, the others should be perfunctory.

	if (/^<argdecls>$/) {
	    for( $i=0; $i < $nargs; $i++ ) {
		$_ = $argtype[$i];
	      argdecl: {
		  /PLINT&/ && do {
		      print GENFILE "    PLINT $argname[$i];\n";
		      last argdecl;
		  };
		  /PLUNICODE&/ && do {
		      print GENFILE "    PLUNICODE $argname[$i];\n";
		      last argdecl;
		  };
		  /PLFLT&/ && do {
		      print GENFILE "    PLFLT $argname[$i];\n";
		      last argdecl;
		  };
		  /char&/ && do {
		      print GENFILE "    char $argname[$i];\n";
		      last argdecl;
		  };
		  /PLINT \*/ && do {
		      print GENFILE "    PLINT *$argname[$i];\n";
		      print GENFILE "    tclMatrix *mat$argname[$i];\n";
		      last argdecl;
		  };
		  /PLUNICODE \*/ && do {
		      print GENFILE "    PLUNICODE *$argname[$i];\n";
		      print GENFILE "    tclMatrix *mat$argname[$i];\n";
		      last argdecl;
		  };
		  /PLFLT \*/ && do {
		      print GENFILE "    PLFLT *$argname[$i];\n";
		      print GENFILE "    tclMatrix *mat$argname[$i];\n";
		      last argdecl;
		  };
		  /const char \*/ && do {
		      print GENFILE "    char *$argname[$i];\n";
		      last argdecl;
		  };
		  /char \*/ && do {
		      print GENFILE "    char $argname[$i]\[200\];\n";
		      last argdecl;
		  };
		  if ($argdef[$i] ne "") {
		      print GENFILE "    $argtype[$i] $argname[$i] = $argdef[$i];\n";
		  } else {
		      print GENFILE "    $argtype[$i] $argname[$i];\n";
		  }
	      }
	    }
	    next;
	}

    # Obtain the arguments which we need to pass to the PLplot API call,
    # from the argc/argv list passed to the Tcl command proc.  Each
    # supported argument type will need special handling here.

	if (/^<getargs>$/) {
	    for( $i=0; $i < $nargs; $i++ ) {
		$_ = $argtype[$i];
		if ($ndefs) {
		    print GENFILE "    if (argc > $i+1) {\n    ";
		}
	      getarg: {
		  $argref[$i] && do {
		      print GENFILE "/* $argname[$i] is for output. */\n";
		      last getarg;
		  };
		  /PLINT \*/ && do {
		      print GENFILE "    mat$argname[$i] = Tcl_GetMatrixPtr( interp, argv[1+$i] );\n";
		      print GENFILE "    if (mat$argname[$i] == NULL) return TCL_ERROR;\n";
		      print GENFILE "    $argname[$i] = mat$argname[$i]-\>idata;\n";
		      last getarg;
		  };
		  /PLUNICODE \*/ && do {
		      print GENFILE "    mat$argname[$i] = Tcl_GetMatrixPtr( interp, argv[1+$i] );\n";
		      print GENFILE "    if (mat$argname[$i] == NULL) return TCL_ERROR;\n";
		      print GENFILE "    $argname[$i] = mat$argname[$i]-\>idata;\n";
		      last getarg;
		  };
		  /PLFLT \*/ && do {
		      print GENFILE "    mat$argname[$i] = Tcl_GetMatrixPtr( interp, argv[1+$i] );\n";
		      print GENFILE "    if (mat$argname[$i] == NULL) return TCL_ERROR;\n";
		      print GENFILE "    $argname[$i] = mat$argname[$i]-\>fdata;\n";
		      last getarg;
		  };
		  /PLINT/ && do {
		      print GENFILE "    $argname[$i] = atoi(argv[1+$i]);\n";
		      last getarg;
		  };
		  /PLUNICODE/ && do {
		      print GENFILE "    $argname[$i] = strtoul(argv[1+$i],NULL,10);\n";
		      last getarg;
		  };
		  /PLFLT/ && do {
		      print GENFILE "    $argname[$i] = atof(argv[1+$i]);\n";
		      last getarg;
		  };
		  /const char \*/ && do {
		      print GENFILE "    $argname[$i] = argv[1+$i];\n";
		      last getarg;
		  };
		  /char/ && do {
		      print GENFILE "    $argname[$i] = argv[1+$i][0];\n";
		      last getarg;
		  };
		  die "Unrecognized argtype :$_:\n";
	      }
		if ($ndefs) {
		    print GENFILE "    }\n";
		}
	    }
	    next;
	}

    # Call the PLplot API function.

	if (/^<plcmd>$/) {
	    print GENFILE "    $cmd ( ";
	    for( $i=0; $i < $nargs; $i++ ) {
		$_ = $argtype[$i];
	      passarg: {
		  /&/ && do {
		      print GENFILE "&$argname[$i]";
		      last passarg;
		  };
		  print GENFILE "$argname[$i]";
	      }
		if ($i < $nargs-1) {
		    print GENFILE ", ";
		}
	    }
	    print GENFILE " );\n";
	    next;
	}

    # If there were reference arguments, fetch their contents and stuff them
    # into their corresponding Tcl variables.

    # NOTE: This should be improved so take into account the current value
    # of tcl_precision.

	if (/^<fetch_result>$/) {
	    if ($refargs) {
		for( $i=0; $i < $nargs; $i++ ) {
		    next if !$argref[$i];
		    if ($i > 0) {
			print GENFILE "    if (argc == 1)\n";
			print GENFILE "        Tcl_AppendResult( interp, \" \", (char *) NULL );\n";
		    }
		    $_ = $argtype[$i];
		  fetch: {
		      /PLINT&/ && do {
			  print GENFILE "    sprintf( buf, \"%d\", $argname[$i] );\n";
			  print GENFILE "    if (argc > 1)\n";
			  print GENFILE "        Tcl_SetVar( interp, argv[1+$i], buf, 0 );\n";
			  print GENFILE "    else\n";
			  print GENFILE "        Tcl_AppendResult( interp, buf, (char *) NULL );\n";
			  last fetch;
		      };

		      /PLUNICODE&/ && do {
			  print GENFILE "    sprintf( buf, \"%u\", $argname[$i] );\n";
			  print GENFILE "    if (argc > 1)\n";
			  print GENFILE "        Tcl_SetVar( interp, argv[1+$i], buf, 0 );\n";
			  print GENFILE "    else\n";
			  print GENFILE "        Tcl_AppendResult( interp, buf, (char *) NULL );\n";
			  last fetch;
		      };

		      /char \*/ && do {
			  print GENFILE "    if (argc > 1)\n";
			  print GENFILE "       Tcl_SetVar( interp, argv[1+$i], $argname[$i], 0 );\n";
			  print GENFILE "    else\n";
			  print GENFILE "        Tcl_AppendResult( interp, $argname[$i], (char *) NULL );\n";
			  last fetch;
		      };

		      /char&/ && do {
			  print GENFILE "    sprintf( buf, \"%c\", $argname[$i] );\n";
			  print GENFILE "    if (argc > 1)\n";
			  print GENFILE "        Tcl_SetVar( interp, argv[1+$i], buf, 0 );\n";
			  print GENFILE "    else\n";
			  print GENFILE "        Tcl_AppendResult( interp, buf, (char *) NULL );\n";
			  last fetch;
		      };

		  # The following needs to be corrected to work with the Tcl
		  # precision standard (global var tcl_precision).

		      /PLFLT&/ && do {
			  print GENFILE "    sprintf( buf, \"%f\", $argname[$i] );\n";
			  print GENFILE "    if (argc > 1)\n";
			  print GENFILE "        Tcl_SetVar( interp, argv[1+$i], buf, 0 );\n";
			  print GENFILE "    else\n";
			  print GENFILE "        Tcl_AppendResult( interp, buf, (char *) NULL );\n";
			  last fetch;
		      };
		      print GENFILE "Unsupported arg type.\n";
		  }
		}
	    }
	    next;
	}

    # substitutions here...

	$_ =~ s/%cmd%/$cmd/g;
	$_ =~ s/%nargs%/$nargs/g;
	if ($refargs) {
	    $_ =~ s/%args%/\?$args\?/g;
	} else {
	    $_ =~ s/%args%/$args/g;
	}
	$_ =~ s/%ndefs%/$ndefs/g;
	$_ =~ s/%isref%/$refargs/g;

	print GENFILE $_;
    }

    close( TEMPLATE );
}