#!/usr/local/bin/perl
# Copyright (C) 1992 by Gustaf Neumann, Stefan Nusser
#
#     Wirtschaftsuniversitaet Wien, 
#     Abteilung fuer Wirtschaftsinformatik
#     Augasse 2-6, 
#     A-1090 Vienna, Austria
#     neumann@wu-wien.ac.at, nusser@wu-wien.ac.at
#
# Permission to use, copy, modify, and distribute this software and its
# documentation for any purpose and without fee is hereby granted, provided
# that the above copyright notice appears in all copies and that both that
# copyright notice and this permission notice appear in all supporting
# documentation.  This software is provided "as is" without expressed or
# implied warranty.
#
# Date: Mon, Apr 13 1992
# Author: Gustaf Neumann
# Version: 0.9

require 'getopts.pl';
die <<"EndOfUsage"
usage: $0 [-<options>]
    -f <definition file>
    -o <output file>
EndOfUsage
if ! &Getopts('f:o:'); 

$opt_f = $opt_f || $ARGV[0];

die "no definition file specified" if !$opt_f;

require 'types';

sub printComment {
    local($_) = @_;
    s/\n(.)/\n * $1/g;
    print OUT "/* $_ */\n";
}

sub tclName {
    local($_) = @_;

    if (/^(\S+)\s*vulgo\s*(.*)/) {
	($XtName,$_) = ($1,$2);
    } else {
	$XtName = $_;
	$_ = $1 if /^Xaw(.*)/ || /^Xt(.*)/ || /^X(.*)/;
    }
    ($first = substr($_,$[,1)) =~ tr/A-Z/a-z/;

    return ($first . substr($_,$[+1),$XtName);
}


sub inConversion {
    local($fromTcl, $cVar, $type,$_,$tab) = @_;
    local($string);
    local($t) = " " x (4*$tab);
    local(@pre,$pre);
   
    if ($additional[$_]) {
        @pre = &stringToCascade($fromTcl,$cVar,$additional[$_],$t);
	pop(@pre);   # remove error message 
	$pre .= join("\n",@pre)."\n$t else\n";
    }

    return "$t $cVar = $fromTcl;\n" if $stringTo{$type} eq "%s";

    if ($stringTo{$type}) {
	$convCode = 
	    $stringTo{$type} =~ /^%/  ?
		"sscanf($fromTcl, \"$stringTo{$type}\", &$cVar)" :
		    "$cVar = $stringTo{$type}($fromTcl)";

	return $pre.<<"cConversion";
$t if (!($convCode))
$t      {
$t      convError("$tclName","$_",$fromTcl,"$type");
$t      DBUG_RETURN (TCL_ERROR);
$t      }

cConversion
    } 
    return $pre.&conversionToStructure($fromTcl,$cVar,$type,$_) if $Structure{$type};
    return $pre.join("\n$t else\n", &stringToCascade($fromTcl,$cVar,$type,$t)), "\n\n";
}


sub conversionToStructure {
    local($fromTcl,$cVar,$type,$nr) = @_;
    local($cmds) = "     { char *charp;\n";

    foreach (split(/,\s*/,$Structure{$type})) {
	next if /^\*/;
	($compType,$compName) = ($1,$2) if /\((.*)\)\s*(.*)/;
        $cmds .= "         if (!(charp="
	    ."Tcl_GetVar2(interpreter,$fromTcl,\"$compName\", 0)))\n"
	    ."               {\n               "
	    ."noVarCompError(\"$tclName\",$fromTcl,\"$compName\");\n"
	    ."               DBUG_RETURN (TCL_ERROR);\n               }\n"
	    .&inConversion(charp,"$cVar.$compName",$compType,"$nr.$compName",2);
    }
    return $cmds."     }\n\n";
}

sub outConversion {
    local($cVar, $type, $nr) = @_;

#    return ("     if (!$cVar) $cVar = \"NULL\";\n",$cVar) if $toString{$type} eq "%s";
    return ("",$cVar) if $toString{$type} eq "%s";

    if ($toString{$type}) {
	return ("","$toString{$type}($cVar)") if $toString{$type} !~ /^%/;
	return ("sprintf(conversionBuffer, \"$toString{$type}\", $cVar);","conversionBuffer");
    } else {
        local($typePtr) = $1 if $type =~ /^(\S+)\s*\*/;
	return &conversionFromStructure($cVar,$typePtr,"\"$cVar\"","\"$cVar\"") 
	    if $Structure{$typePtr};
	return &conversionFromStructure($cVar,$type,"argv[$nr]","") 
	    if $Structure{$type};
	return (join("\n     else\n", &cascadeToString($cVar,$type))."\n\n", 
			"conversionBuffer");
    }
}

sub conversionFromStructure {
    local($cVar,$type,$name,$data) = @_;
    local($cmds);

    foreach (split(/,\s*/,$Structure{$type})) {
	next if /^\*/;
	($compType,$compName) = ($1,$2) if /\((.*)\)\s*(.*)/;
	($convCode,$convData) = &outConversion("$cVar".
			  ($data?"->":".")."$compName",$compType);
        $cmds .= "     $convCode\n"
	               ."     Tcl_SetVar2(interpreter,$name,\"$compName\", $convData,0);\n";
    }
    return ($cmds,$data);
}


sub stringToCascade {
    local($fromTcl, $cVar, $type,$t) = @_;
    local(@typeDef) = eval "@$type";
    local(@return);

    for ($i=$[; $i < $#typeDef; $i += 2) {
	push(@return, "$t if (!strcmp($fromTcl, \"$typeDef[$i]\")) \n"
	     . "$t     $cVar = " . ($typeDef[$i+1]) . ";");
    }
    push(@return, "$t     {\n$t     convError(\"$tclName\",\"$_\",$fromTcl,\"$type\");\n"
                             ."$t     DBUG_RETURN (TCL_ERROR);\n$t    }\n");
    @return;
}

sub cascadeToString {
    local( $cVar, $type) = @_;
    local(@typeDef) = eval "@$type";
    local(@return);

    for ($i=$[; $i < $#typeDef; $i += 2) {
	push(@return, "     if ($cVar == ".($typeDef[$i+1]).") \n"
	     . "          strcpy(conversionBuffer, \"$typeDef[$i]\");");
    }
    @return;
}

sub castedType {
    local($_) = @_;
    return ($1,$2) if /\((.*)\)\s*(.*)/;
    return ($_,$_);
}

$outputfile = $opt_o || "$opt_f.c"; 

open(DEFS,"<$opt_f") || die "cannot open $opt_f for reading";
open(OUT, ">$outputfile") || die "cannot open $outputfile for writing";
open(TCC, ">$opt_f.tcc") || die "cannot open $opt_f.tcc for writing";

$[=1;
undef($/); ($file = <DEFS>) =~ s/\\\n\s*//g; $/ = "\n";

chop($now = `/bin/date`);
&printComment(<<"Copyright");
Copyright (C) 1992 by Gustaf Neumann, Stefan Nusser

     Wirtschaftsuniversitaet Wien, 
     Abteilung fuer Wirtschaftsinformatik
     Augasse 2-6, 
     A-1090 Vienna, Austria
     neumann@wu-wien.ac.at, nusser@wu-wien.ac.at

Permission to use, copy, modify, and distribute this software and its
documentation for any purpose and without fee is hereby granted, provided
that the above copyright notice appears in all copies and that both that
copyright notice and this permission notice appear in all supporting
documentation.  This software is provided "as is" without expressed or
implied warranty.

Creation: $now on $ENV{'HOST'}
Author: genc
Version: 0.9
Copyright

foreach(split(/\s*\n\n+/,$file)) {
        if (/^(#include|#ifdef|#define|#ifndef|#endif|extern)/) {
	    print OUT "$_\n\n";
	    next;
	}
        if (/^%/ || /^@/) {
	    eval $_;
	    die "ERROR: $@" if $@;
	    next;
	}
        next if /^#/;
        next if !(@items = split(/[ \t]*\n[ \t]*/));
	$openR5 = $closeR5 = $prototype = "";
	if ($items[$[] =~ /hints?\s*:(.*)/) {
	    foreach (split(/\s*,\s*/,$items[$[])) {
		$openR5 = "#ifndef PRER5\n", $closeR5 = "#endif" if /R5/;
		$prototype = 1 if /prototype/;
	    }
	    shift(@items);
	} 

        ($returnType,$name,@args) = @items;
	&printComment( "\n$_\n");
	($tclName,$XtName) = &tclName($name);

	$localVars = $preCode = $postCode = $endCode = "";
        $repeatCall = $nrArgs = 0;
	@cVars = @inOut = @type = @inFunction = @toRemove = @prototypes = @array = ();

	for ($[..$#args) {
	    $repeatCall = $_, unshift(@toRemove,$_) if $args[$_]=~ /^callmultiple$/;
	    $preCode = "     $1\n", unshift(@toRemove,$_) if $args[$_]=~/^[Pp]re\s*:\s*(.*)$/;
	    $postCode = "     $1\n",unshift(@toRemove,$_) if $args[$_]=~/^[Pp]ost\s*:\s*(.*)$/;
	    $endCode = "     $1\n",unshift(@toRemove,$_) if $args[$_]=~/^[Ee]nd\s*:\s*(.*)$/;
	}
#	print "toremove = ",join(" und ",@toRemove),"\n";
	foreach (@toRemove) {
	    splice(@args,$_,1);
	}
#	print "args are now: <",join(",",@args),">\n";

        $tclArgs = $nrConst = 0;
	for ($[..$#args) {
	    ($inOut[$_], $type[$_]) = split(/:\s*/,$args[$_]);
            $nrConst++,next if $inOut[$_] =~ /[Cc]onst/;
	    $cVar[$_] = "localVar". ($_ - $nrConst) ;
	    ($type[$_],$array[$_]) = 
		$type[$_] =~ /\[(.*)\]/ ? ($1,1) : ($type[$_],0);
	    ($type[$_],$additional[$_]) = 
		$type[$_] =~ /(\w+)\s*\|\s*(.*)/ ? ($2,$1) : ($type[$_], "");
	    ($type[$_],$inFunction[$_]) = 
		$type[$_] =~ /^(\w+)\((.*)\)/ ? ($2,$1) : ($type[$_], "");
            ($typeDecl,$type[$_]) = &castedType($type[$_]);
            $typeDecl = "$typeDecl *" if $array[$_];
	    $localVars .= "     $typeDecl $cVar[$_];\n";
	    push(@prototypes,$typeDecl) if $prototype;
	    $tclArgs++;
	}

        print OUT "extern $returnType $XtName(\n#if NeedFunctionPrototypes\n     ",
	    join(', ',@prototypes),"\n#endif\n);\n" if $prototype;

        if ($returnType !~ /[Vv]oid/) {
            ($typeDecl,$returnType) = &castedType($returnType);
	    $localVars .= "     $typeDecl returnVar;\n";
	}

	$argList = $repeatCall || grep(/1/,@array);
	($argCountTest,$quant) = 
	     (($argList ? '< ' : '!= ').($tclArgs+1),
	      ($argList ? "at least " : ""));

        $argBreak = $#args;
        $argBreak = $repeatCall -1 if $repeatCall;

	$localVars .= "     char conversionBuffer[100];\n" 
	    if grep(/[Oo]ut/,@inOut) || 
		($returnType !~ /[Vv]oid/ && $toString{$returnType} ne "%s");
	$localVars .= "     int count;\n" if $repeatCall;

        print TCC <<"tccEntry";
$openR5
{  COM_PROTOTYPE(com_$tclName)
   Tcl_CreateCommand(interpreter, "$tclName", com_$tclName, NULL, NULL); 
}
$closeR5

tccEntry



	print OUT <<"cHeader";
$openR5
int 
com_$tclName(clientData, comInterpreter, argc, argv)
ClientData    clientData;
Tcl_Interp   *comInterpreter;
int           argc;
char        **argv;
     {
$localVars
     DBUG_ENTER("$tclName");  

     if (argc $argCountTest) 
	 {
	 argcError("$tclName","$quant",$tclArgs,argc);
	 DBUG_RETURN (TCL_ERROR);
         }

cHeader

        $argc=0;
	for ($[..$argBreak) {
            $argc++, next if $inOut[$_] =~ /^[Oo]ut/;
            next if $inOut[$_] !~ /^[Ii]n/;
	    $argc++;
	    if ($array[$_]) {
                local($arg) = $_ - $nrConst;
		print OUT "     {    $type[$_] *ptr;\n          argv += $arg;\n          "
		    ."$cVar[$_] = ptr =\n             "
			."($type[$_] *)XtMalloc((argc-$arg)*sizeof($type[$_]));\n\n          "
			."while (*argv)\n             {\n";
		print OUT &inConversion("*argv","*ptr",$type[$_],$arg,3);
		print OUT "          ptr ++; argv++;\n          }\n     }\n";
	    } else {
		print OUT &inConversion("argv[$argc]",$cVar[$_],$type[$_],$_,1);
	    }
        } #for


	 @realArgs = ();
	 for ($[..$#args) {
	     $realArgs[$_] = "&$cVar[$_]",next 
		 if $inOut[$_] =~ /^[Oo]ut/ || $Structure{$type[$_]};
	     $realArgs[$_] = "$inFunction[$_]($cVar[$_])",next if $inFunction[$_];
	     $realArgs[$_] = "$cVar[$_]",next if $inOut[$_] =~ /^[Ii]n/;
	     $realArgs[$_] = $type[$_],next if $inOut[$_] =~ /^[Cc]onst/;
	 }

         $cCall= $returnType =~ /[Vv]oid/ ?  $XtName : "returnVar = $XtName";

	 if ($repeatCall) {
	     $argBreak ++;
	     print OUT "$preCode     for (count = $argBreak; count < argc; count++)\n         {\n";
	     for ($argBreak .. $#args) {
		 print OUT &inConversion("argv[count]",$cVar[$_],$type[$_],"count",2);
	     }
	     print OUT "         $cCall(",join(",",@realArgs),");\n          }\n$postCode";
	 } else {
	     print OUT "$preCode     $cCall(",join(",",@realArgs),");\n$postCode";
	 }

	for ($[..$#args) {
            next if $inOut[$_] !~ /^[Oo]ut/;
            ($convCode,$convData) = &outConversion($cVar[$_], $type[$_],$_);

            print OUT "\n     $convCode\n";
	    print OUT "     Tcl_SetVar(interpreter, argv[$_], $convData, 0);\n" if $convData;
        }

         if ($returnType !~ /[Vv]oid/) {
	     ($convCode,$convData) = &outConversion("returnVar", $returnType);
             print OUT "\n$convCode\n     " 
		 ."Tcl_SetResult(comInterpreter, $convData, TCL_VOLATILE);\n";
	 }
         print OUT "\n$endCode" if $endCode; 


         print OUT <<"cFooter";

     DBUG_RETURN (TCL_OK);
     }     
$closeR5

cFooter

}

