#!/usr/local/bin/perl
#
# clitcl input header body init xtra var1 var2
#
#  input   < source cli file
#  header  > output .h file
#  body    > output main program
#  init    > initialization
#  xtra    > auxilary code from cli program
#  var1    > code to get variables
#  var2    > code to set variables
#
# m1fxt00
#

open(IN,"<$ARGV[0]") || die "Input file $ARGV[0] not found";
open(HDR,">$ARGV[1]") || die "Can't open header file $ARGV[1]";
open(BODY,">$ARGV[2]") || die "Can't open $ARGV[2]";
open(INIT,">$ARGV[3]") || die "Can't open $ARGV[3]";
open(XTRA,">$ARGV[4]") || die "Can't open $ARGV[4]";
open(VGET,">$ARGV[5]") || die "Can't open $ARGV[4]";
open(VSET,">$ARGV[6]") || die "Can't open $ARGV[4]";

&init;
while(<IN>) {
  /^CALL|^CASE/ && ( &docall, next );
  /^VAR/ && ( &dovarline, next );
  print XTRA $_;
}
&term;

close(IN);
close(HDR);
close(BODY);
close(INIT);
close(XTRA);
close(VGET);
close(VSET);

sub init {
}

sub term {
exit(0);
}

sub dovarline {
  s/^VAR\s+//;
  ($type,$varn,$als,$dims)=&breakup($_);
  if ($als =~ /^\d$/) {
    $dims=$als; $alias="";
  }
  $als=$varn if $als eq "-";
  $als=$varn unless $als;

  if ($dims) {
    for ($i=0;$i<$dims;$i++) {
      $alias=$als.$i;
      $var="$varn[$i]";
      &dovar;
    }
  }
  else {
    $alias=$als; $var=$varn;
    &dovar;
  }
}

sub dovar {
    print INIT <<EOF;
	Tcl_TraceVar(interp,"$alias",TCL_TRACE_WRITES,Tcl_WVar_$alias,NULL);
	Tcl_TraceVar(interp,"$alias",TCL_TRACE_READS,Tcl_RVar_$alias,NULL);
EOF

  if ($type !~ /string/) {
    print VSET <<EOF;
	Tcl_WVar_$alias(ClientData clientData, Tcl *interp, char *name1,
	                char *name2, int flags)
	{
	char *value;
	value=Tcl_GetVar2(interp,name1,name2,flags&TCL_GLOBAL_ONLY);
	$var=($type)atof(value)
	return NULL;
	}
EOF
    print VGET <<EOF;
	Tcl_RVar_$alias(ClientData clientData, Tcl *interp, char *name1,
	                char *name2, int flags)
	{
	char x[1024];
	sprintf(x,"%f",(double)$var);
	Tcl_SetVar2(interp,name1,name2,x,flags&TCL_GLOBAL_ONLY);
	return NULL;
	}
EOF
  } 
  else {
      $slen=$type;
      $slen =~ s/string\s*//;
      $slen=1024 if $slen eq "";
      $type="char *";
      $cat=1;
    print VSET <<EOF;
	Tcl_WVar_$alias(ClientData clientData, Tcl *interp, char *name1,
	                char *name2, int flags)
	{
	char *value;
	value=Tcl_GetVar2(interp,name1,name2,flags&TCL_GLOBAL_ONLY);
	strncpy($var,value,$slen);
	return NULL;
	}
EOF
    print VGET <<EOF;
	Tcl_RVar_$alias(ClientData clientData, Tcl *interp, char *name1,
	                char *name2, int flags)
	{
	char *value;
	value=Tcl_SetVar2(interp,name1,name2,$var,flags&TCL_GLOBAL_ONLY);
	return NULL;
	}
EOF
  }
}

sub docall {
  s/^\S+\s+//;
  $init="";
  $retx="";
  $retv="";
  $retfree="";
  $callarg="";
  $arglist="";
  $count=0;
  $retvc=0;

  ($rettype,$call,$alias)=&breakup($_);

  if ($call =~ s/^&//) {
    $retfree.="\tfree(retval);\n" if $rettype ne "void";
  }

  $alias=$call unless $alias;

  print INIT "Tcl_CreateCommand(interp,\"$alias\",Tcl_$alias,0,0);\n";
  print HDR "int Tcl_$alias(ClientData clientData, Tcl_Interp *interp, int argc,
 char *argv[]);\n";
  print BODY "int Tcl_$alias(ClientData clientData, Tcl_Interp *interp, int argc
, char *argv[])\n{\n";

  if ($rettype =~ /string/) {
    $rettype="char *";
    $decl="\t$rettype retval;\n";
    $retv.="\tTcl_AppendResult(interp,retval,NULL);\n";
  }
  elsif ($rettype ne "void") { 
    $decl="\t$rettype retval;\n"; 
    $retv.= <<EOF;
	{
    	char x[128];
    	sprintf(x,"%f",(float)retval);
    	Tcl_AppendResult(interp,x,NULL);
	}
EOF
  }
  else { $decl=""; $retv=""; }
  
  while(<IN>) {
    last if /^END/;
    ($io,$type,$argx,$dims)=&breakup($_);

    if ($dims) { $dimsv="[".$dims."]" }
    else { $dimsv=""; }

    if ($argx =~ s/^&//) { $alloc=0; }
    else { $alloc=1; }

    if ($argx =~ /^=/) {
      $_=$argx;
      ($argx,$initv)=/([^=]*)(.*)/;
    } else { $initv=""; }

    # $cat=0 for numeric; 1 for string
    if ($type =~ /string/) { 
      $slen=$type;
      $slen =~ s/string\s*//;
      $slen=1024 if $slen eq "";
      $type="char *";
      $cat=1;
    }
    else { $cat=0; }

    $decl.="\t$type $argx$dimsv$initv;\n";

    if ($cat) {
      if ( ($slen) && ($alloc || $io =~ /I/) ) {
        $callarg.="$argx,";
      }
      else {
        $callarg.="&$argx,";
      }
    }
    else {
      if ($dims) {
        $callarg.="$argx,";
      }
      elsif ($io =~ /O/) {
        $callarg.="&$argx,";
      }
      else {
        $callarg.="$argx,";
      }
    }

    if ($dims) {
      for ($i=0; $i<$dims; $i++) {
        $arg="$argx[$i]";
        &doarg;
      }
    }
    else {
      $arg=$argx;
      &doarg;
    }
  }

  chop($arglist);
  print BODY <<EOF;

        if (argc != $count+1) {
          interp->result="Usage: $alias $arglist";
          return TCL_ERROR;
        }
        else {

EOF
  print BODY $decl,"\n";
  print BODY $init,"\n";

  chop($callarg);  # take out final ","
  if ($rettype ne "void") {
    print BODY "\tretval=($rettype)$call($callarg);\n";
  }
  else {
    print BODY "\t(void)$call($callarg);\n";
  }

  print BODY $retx;
  print BODY $retv;
  print BODY $retfree;
  print BODY "\t}\n";;
  print BODY "\treturn TCL_OK;\n";
  print BODY "}\n\n";
}

sub doarg {
    $count++ if $io =~ /[IO]/;

    if ($cat) {
      if ( ($slen) && ($alloc || $io =~ /I/) ) {
        $init.="\t$arg=($type)malloc($slen);\n";
        $init.="\tif ($arg==NULL) ";
        $init.="{ interp->result=\"Out of memory in $alias($arg)\"; return TCL_ERROR; }\n"
      }
      if ($io =~ /O/) { $arglist.="$arg "; }
      elsif ($io =~ /I/) { $arglist.="\$$arg "; }
      #$arglist.="\$$arg " if $io =~ /[IO]/;
      $retfree.="\tfree($arg);\n";
      if ( $io =~ /I/ ) {
        if ($io =~ /O/) {
          $init.="\tstrncpy($arg,Tcl_GetVar(interp,argv[$count],0),$slen);\n"
        } else {
          $init.="\tstrncpy($arg,argv[$count],$slen);\n";
        }
      }
      if ($io =~ /O/) {
        $retx.="\tTcl_SetVar(interp,argv[$count],$arg,0);\n";
      }
      if ($io =~ /R/) {
        $retv.="Tcl_AppendResult(interp,$arg,NULL);\n";
        $retvc++;
      }
    }
    else {
      if ( $io =~ /O/ ) {
        $init.="\t$arg=($type)atoi(Tcl_GetVar(interp,argv[$count],0));\n"
          if $io =~ /I/;
        $retx.=<<EOF;
	{
        char x[128];
        sprintf(x,"%f",(float)$arg);
        Tcl_SetVar(interp,argv[$count],x,0);
	}
EOF
        if ($io =~ /O/) { $arglist.="$arg "; }
        elsif ($io =~ /I/) { $arglist.="\$$arg "; }
        #$arglist.="\$$arg,";
        if ( $io =~ /R/ ) {
          $retv.=<<EOF;
	{
	char x[128];
        sprintf(x,"%f",(float)$arg);
	Tcl_AppendResult(interp,x,NULL);
	}
EOF
          #$retv.="\tstr_numset(st[$retvc],(double) $arg);\n"; $retvc++;
        }
      } else { 
        if ($io =~ /O/) { $arglist.="$arg "; }
        elsif ($io =~ /I/) { $arglist.="\$$arg "; }
        #$arglist.="\$$arg," if /[IO]/; 
        $init.="\t$arg=($type)atoi(argv[$count]);\n"
          if $io =~ /I/;
        if ( $io =~ /R/ ) {
          $retv.=<<EOF;
	{
	char x[128];
        sprintf(x,"%f",(float)$arg),NULL);
	Tcl_AppendResult(interp,x,NULL);
	}
EOF
          #$retv.="\tstr_numset(st[$retvc],(double) $arg);\n"; $retvc++;
        }
      }
    }
}

sub breakup {
  local ($_)=@_;
  local(@r,$x,$xx,$count);

  s/\s+$//;

  while ($_ ne "") {
    s/^\s+//; 
    if (/^\(/) {
      $count=0; $xx="";
      do {
        if (/^\(/) { $count++; }
        ($x,$_)=/^(.[^\)\(]*)(.*)/;
        $xx.=$x;
        if (/^\)/) { $count--; }
      } while ($count>0);
      s/^.//;
      push(@r,substr($xx,1));
    }
    else { 
      ($xx,$_)=/^(\S+)(.*)/;
      push(@r,$xx);
    }
  }
  @r;
}
