#!/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: 1.0

$version = "1.0.8";

chop($now = `/bin/date`);

$creationNote = <<"Creation";
Creation: $now on $ENV{'HOST'}
Author: genc
Version: $version
Creation

require 'getopts.pl';
die <<"EndOfUsage"
usage: $0 [-<options>]
    -f <definition file>   % .spec file
    -o <output file>       % guess
    -s                     % list infor about shared strings
EndOfUsage
unless &Getopts('sf:o:'); 



$opt_f = $opt_f || $ARGV[0];
($stem = $opt_f) =~ s/^([^\.]+)\.[^\.]+$/$1/;
#print "stem = <$stem> <$opt_f>\n";
$opt_f = "$stem.spec" if $opt_f eq $stem;

die "no definition file specified" unless $opt_f;

require 'types';
$[ = 1;

sub initWafeStrings {
    local($i) = 0;
    open(WS,">wafe_strings.h");
    print WS "#ifdef MAIN\n"
	."_Xconst String wafeStrings[] = {\n";
    foreach (@wafeStrings) {
	print WS "    \"$_\",\n";
	$sharedString{$_} = "wafeStrings[$i]";
	$i++;
    }
    local($savei) = $i;
    print WS "# ifdef MOTIF\n";
    foreach (@motifStrings) {
	print WS "    \"$_\",\n";
	$sharedString{$_} = "wafeStrings[$i]";
	$i++;
    }
    $i = $savei;
    print WS 
	"# endif /* MOTIF */\n"
	."   NULL};\n"
	."#else\n"
	."extern _Xconst String wafeStrings[];\n"
	."#endif\n";
    close W;
}
&initWafeStrings;

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

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

    local($orig) = $_;
    if (/^(\S+)\s*vulgo\s*(\S+)\b/) {
	($XtName,$_) = ($1,$2);
	$orig = $_;
    } else {
	$XtName = $_;
	$_ = $1 if /^Xaw(\S+)\b/ || /^XtApp(\S+)\b/ || /^Xt(\S+)\b/ ||
	    /^X(\S+)\b/ || /^At(\S+)\b/ ;
    }
    if ($PACKAGE eq "XT" && $returnType ne "~widgetClass") {
	return ("\l$_",$XtName);
    }
    if ($PREFIX ne "" && $XtName !~ /^$PREFIX/) {
	&alias($_,"\l$XtName");
    } else {
	local($newXtName) = "\l$XtName";
	s/^XY/xy/;
	&alias($XtName,"\l$_") if $XtName ne $newXtName;
    }
    return ($orig,$XtName);
}

sub alias {
    local($old,$new) = @_;
    $new="asciiText" if $new =~ /^text$/;
    $new="html" if $new =~ /^hTML$/;
    $new =~ s/^xY/xy/;    
    if ($old eq $new) {
	print STDERR "no need to alias <$old>\n";
	return;
    }
    open(ALIAS,">>tcllib/bc/$PACKAGE.tcl");
    print ALIAS "alias $new $old\n";
    close(ALIAS);
}

sub inConversion {
    local($fromTcl, $cVar, $cast, $type,$_,$tab, $nsc) = @_;
    local($string);
    local($t) = " " x (4*$tab);
    local(@pre,$pre);
    local($origType) = $type;

    #print STDERR "ininConverion: cVar[$_] = <$cVar[$_]> min=$[, #=$#cVar\n";
  
    if ($additional[$_]) {
        @pre = &stringToCascade($fromTcl,$cVar,$additional[$_],$t);
	pop(@pre);   # remove error message 
	$pre .= join("\n",@pre)."\n$t else\n    ";
    }

    local($conv) = $stringTo{$type};
    if (!$conv && ($type =~ /^(.+)(Widget|Gadget|Object)$/)) {
	local($class) = $1;
	$conv = "name2WidgetOfClass(INPUT,\l${class}${2}Class)";
	$type = "Widget";
	$cast = "";
     }
    if ($conv eq "%s") {
	return "$pre$t $cVar = XtNewString($fromTcl);\n" if $cVar =~ /^\*/;
	return "$pre$t $cVar = $fromTcl;\n" if $pre || $nsc;  # no shortcut possible
	#print STDERR "NO NEED: cvar=<$cVar[$_] [$_]> ($cVar), fromTcl=<$fromTcl>\n";
	local($tmp) = $cVar[$_];
	$cVar[$_] = $fromTcl;
	return "    /* no need to assign  << $tmp = $fromTcl >>  */ \n\n";
    }

    local($convCode) = $stringToStore{$type};
    if ($conv || $convCode) {
        if ($conv =~ /^%/) {
	    local($string) = &sharedString($conv);
	    $convCode = "sscanf($fromTcl, $string, &$cVar)";
	} elsif ($conv =~ s/INPUT/$fromTcl/) {
	    $convCode = "$cVar = $cast $conv";
	} elsif ($conv) {
            $convCode =  "$cVar = $cast $conv($fromTcl)";
	} else {
	    $convCode =~ s/INPUT/$fromTcl/;
	    $convCode =~ s/OUTPUT/$cVar/;
	}
	$postCode .= "     $stringToGarbage{$type}($cVar);\n" 
	    if $stringToGarbage{$type};

	if (/\./) {
	    $origType = &sharedString($origType);
	    return $pre.<<"cConversion";
$t if (!($convCode))
$t     DBUG_RETURN(wafeConvError(argc, argv, $`,"$'" ,$origType));

cConversion

	} else {
	    $origType = &sharedString($origType);
	    return $pre.<<"cConversion";
$t if (!($convCode))
$t     DBUG_RETURN (wafeConvError(argc, argv, $_ ,NULL, $origType));

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(wafeInterpreter,$fromTcl,\"$compName\", 0)))\n"
	    ."               {\n               "
	    ."wafeNoVarCompError(argc,argv,$nr,\"$compName\");\n"
	    ."               DBUG_RETURN (TCL_ERROR);\n               }\n"
	    .&inConversion('charp',"$cVar.$compName","",$compType,"$nr.$compName",2,1);
    }
    return $cmds."     }\n\n";
}

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

    return ("","") if $type eq "TCL_RETURN_CODE";
    return ("",$cVar) if $toString{$type} eq "%s";

    local($cParens,$expression);

    if ($toString{$type}) {
	return ("","$xsubst") if ($xsubst = $toString{$type})=~s/OUTPUT/$cVar/g;
	$cParens = ($toString{$type} =~ tr/\(/\(/) - 
	    ($toString{$type} =~ tr/\)/\)/);
	return ("","$toString{$type}$cVar".')'x$cParens) if $cParens;
	return ("","$toString{$type}($cVar)") if $toString{$type} !~ /^%/;
	local($string) = &sharedString($toString{$type});
	return ("sprintf(conversionBuffer, $string, $cVar);\n","conversionBuffer");
    } else {
        local($typePtr) = $1 if $type =~ /^(\S+)\s*\*/;
	local($scVar) = &sharedString($cVar);
	return &conversionFromStructure($cVar,$typePtr,$cVar,$scVar, $target) 
	    if $Structure{$typePtr};
	return &conversionFromStructure($cVar,$type,"argv[$nr]","", $target) 
	    if $Structure{$type};
	return ("", $expression) 
	    if ($expression = $toStringStaticExpression{$type}) =~ 
		s/EXPRESSION/$cVar/;
	return (join("\n     else ", &cascadeToString($cVar,$type))."\n\n", 
			"staticResultString");
    }
}


sub setVar {
    local($tab,$setVarCmd,$type,$convData) = @_;
    local($pre,$data,$post);
    if ($toStringGarbage{$type}) {
	$localVarNeeded{'ptr'} = 1;
	$pre  = $tab."ptr = $convData;\n".$tab;
	$data = "ptr";
	$post = $tab.$toStringGarbage{$type}."(ptr);\n";
    } else {
	$pre  = "     ";
	$data = $convData;
	$post = "";
    }
    return "\n".$pre.$setVarCmd.$data.",0);\n".$post;
}

sub conversionFromStructure {
    local($cVar,$type,$name,$data, $target) = @_;
    local($cmds);
    local($varName) = $target || &sharedString($name);
    
    $cmds = "if ($cVar == NULL) { DBUG_RETURN (TCL_ERROR); }\n" 
	if ($data =~ /returnVar/);

    foreach (split(/,\s*/,$Structure{$type})) {
	next if /^\*/;
	($compType,$compName) = ($1,$2) if /\((.*)\)\s*(.*)/;
	($convCode,$convData) = &outConversion("$cVar".
				   ($data?"->":".")."$compName",$compType,"");
	$localVarNeeded{$convData} = 1;
	$convData =  "$convData ? $convData :wafe_EMPTY" 
	    unless $convCode || $convData =~ m.\(.;
	$cmds .= "\n     $convCode" if $convCode;
	$cmds .= &setVar("     ",
			 "Tcl_SetVar2(wafeInterpreter,"
                         .$varName.",\"$compName\",",
			 $compType, $convData);
    }
    return ($cmds,$target ? "" : $data);
}


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

#    $[=1;  #### perl5

    for ($i=$[; $i < $#typeDef; $i += 2) {
	$string = &sharedString($typeDef[$i]);
	push(@return, "$t if (!strcmp($fromTcl, $string)) \n"
	     . "$t     $cVar = " . ($typeDef[$i+1]) . ";");
    }
    $type = &sharedString($type);
    push(@return, "$t     DBUG_RETURN(wafeConvError(argc,argv, $_,NULL, $type));\n");
    @return;
}

sub cascadeToString {
    local( $cVar, $type) = @_;
    local(@typeDef) = eval "\@$type";
    local(@returnValue,%done,$fromValue);

    # print STDERR "cascadetostring: min=$[, #=$#typeDef\n";
    for ($i=$[; $i < $#typeDef; $i += 2) {
	$fromValue = $typeDef[$i+1];
	next if $done{$fromValue};
	push(@returnValue, "if ($cVar == ".$fromValue.") \n"
	     . "         staticResultString = \"$typeDef[$i]\";");
	$done{$fromValue}++;
    }
    push(@returnValue, "\n         staticResultString = \"UNKNOWN\";");

    # print "cascade to string returns ", join('-',@returnValue),"\n";
    @returnValue;
}


sub castedType {
    local($_) = @_;
    local($decl,$type) = /\((.*)\)\s*(.*)/ ? ($1,$2) : ($_,$_);
    $decl =~ s/^.+Widget$/Widget/; 
    $decl = Widget if /Gadget$/; 
    return ($decl,$type);
}


sub stripComment {
    local($_) = @_;
    local($content,$comment) = 
	m/^(.*\S)\s*\#\s*(\S?[^\#]*)$/ ? ($1,$2) : ($_,"");
    return ($content,$comment);
}


sub widgetClassOptions {
    local($name,$className,@args) = @_;
    local($creationCmd,$comment,$createsShell) = ('','','');
    return "NULL" unless @args;
    $callbackClass{"$name$;$className"} = $PACKAGE;

    for ($[..$#args) {
	($args[$_],$comment) = &stripComment($args[$_]);
	if ($args[$_] =~ /^\s*include\s*(\S.*)$/) {
	    $include{"$PACKAGE$;$name"} = "${openIFDEFS}#include $1$closeIFDEFS";
	    $INCL .= "${openIFDEFS}#include $1$closeIFDEFS\n";
	    next;
	}
	if ($args[$_] =~ /^\s*addRes\s*(\S+)\s+(\S+)\s*$/) {
	    local($resName,$resType) = ($1,$2);
	    $addRes{"$PACKAGE$;$className"} .= "$resName:$resType$;";
	    next;
	}
	$creationCmd = $1,next if ($args[$_] =~ /^\s*createCmd\s*(\S.*)$/);
	$createsShell = 'True',next if ($args[$_] =~ /^\s*createsShell/);

	# what 's left are callbacks
	if ($args[$_] =~ /^(\S*)\s*(\S*)\s*(\S.*)\s*:(.*)$/) {
	    local($callbackNames,$percV,$toType,$reference) = ($1,$2,$3,$4);
	    if ($reference =~ /^\s*\$/) {
		eval '$reference = "'.$reference.'";';
	    }
	    local(@callbacks) = (split(/\|/,$callbackNames));
            foreach ($[ .. $#callbacks) {
		$callbacks[$_] .=  "Callback" 
		    unless $callbacks[$_] =~ /[Cc]allback$/ ||
			$callbacks[$_] =~ /[Pp]roc$/ ;
		if ($#callbacks == 1) {
		    &doc("\\callback{$callbacks[$_]}{\\\%$percV}{$comment}");
		} else {
		    if ($_ == $[) { 
			&doc("\\callbackbeg{$callbacks[$_]}");
		    } elsif ($_ == $#callbacks) {
			&doc("\\callbackend{$callbacks[$_]}{\\\%$percV}{$comment}");
		    } else {
			&doc("\\callbackmed{$callbacks[$_]}");
		    }
		}
		$callback{"$PACKAGE$;$name$;$callbacks[$_]$;$percV$;$className"} =
		          "$toType$;$reference";
	    }
	}
    }
    return ($creationCmd || "NULL",$createsShell);
}

sub pseudoWidgetClassOptions {
    local($name,@args) = @_;
    local($createCmd,$className,$createsShell) = ('','','');
    for ($[..$#args) {
	$args[$_] =~ s/\s*#.*$//;
	$createCmd = $1 if ($args[$_] =~ /^\s*createCmd\s*(\S.*)$/);
	$className = $1 if ($args[$_] =~ /^\s*className\s*(\S.*)$/);
	$createsShell = 'True' if ($args[$_] =~ /^\s*createsShell/);
    }
    return($createCmd,$className,$createsShell);
}

sub generateGenc {
    print OUT <<"genc";
/* 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.
 * 
 */

/*
 * This file was generated by genc.
 * Be aware that modifications of this file will be lost,
 * when genc is executed!

$creationNote
 */

#define ${PACKAGE}_C
#include <wafe.h>
/*
static _Xconst Proc_signature cmds[];
static WidgetCreate_signature wccs[];
*/
genc

    if (!$UBIQUITUS) {
	print OUT "#ifdef $PACKAGE\n";
    }

    print OUT $INCL.$TCLD;

# generate initialization code

    print OUT 
	"\nstatic _Xconst Proc_signature cmds[] = {\n    "
        .join("\n    ",split(/\n/,$TCLC))
        ."\n    { NULL, NULL }\n    };\n"
	."\nstatic WidgetCreate_signature wccs[] = {\n    "
        .join("\n    ",split(/\n/,$WCC))
        ."\n    { NULL,NULL,NULL,False }\n    };\n"
	."\nstatic _Xconst String pkgs[] = {\n"
        .$PKGS
	."    NULL\n     };\n\n\n";

    print OUT 
	$GENC;
}

sub generateCallback {
    local($bools,$includes,$cascade,%CBQuark,$quarks,$quarkInit,%cbNeeded,
	  $reason,$quark,$package,%quarkPackage,$packageInit,
	  @pre,@post,%isGlobalQuark,%isStrippedGlobalQuark);
    
    foreach (keys %globalQuark) {
	($package,$quark) = split(/$;/);
	$isGlobalQuark{$quark} = 1;
	$quark = &quarkCore($quark);
	$isStrippedGlobalQuark{$quark} = 1;
	$quarkPackage{$package} = 1;
    }
    local($pquarks);
    foreach $p (keys %quarkPackage) {
	$pquarks = "";
	($pre,$post) = ($definedPackage{$p} == 2) ?
	    ("","") : ("#ifdef $p\n","#endif\n") ;
        foreach (keys %isGlobalQuark) { 
	    $quark  = &quarkName($_),
	    $pquarks .= "CB_EXTERN XrmQuark $quark;\n"
		if $globalQuark{"$p$;$_"};
	}
	$quarks .= $pre.$pquarks.$post."\n" if $pquarks;
    }
    open(CB,">wafe_quarks.h");

    print CB "#ifdef CALLBACK_C\n#define CB_EXTERN\n#else\n"
            ."#define CB_EXTERN extern\n#endif\n\n";
    print CB $quarks;
    close CB;
    $quarks = "#include \"wafe_quarks.h\"\n\n";

    # package init declararations
    foreach (keys %definedPackage) {
	($pre,$post) = $definedPackage{$_} == 2 ? 
	    ("","") : ("#ifdef $_\n","#endif\n") ;
	$packageInit .= 
	    "$pre     extern wafeInitialize_$_();\n$post";
    }
    $packageInit .= "\n\n";   

    # package init calls
    foreach (keys %definedPackage) {
	next if /^XT$/;
	($pre,$post) = $definedPackage{$_} == 2 ? 
	    ("","") : ("#ifdef $_\n","#endif\n") ;
	$packageInit .= 
	    "$pre     wafeInitialize_$_();\n$post";
    }
    $packageInit .= "     wafeInitialize_XT();\n";    # should be the last one

    open(CB,">callback.c");
#    open(CB,">-");

    foreach(sort grep($include{$_}, keys %include)) {
	local($package) = $1 if /^(\w+)\b/;
        $includes .= "#ifdef $package\n$include{$_}\n#endif\n";
    }

    foreach(sort keys %callback) {
	local($conv,$post);
	local($package,$name,$callbackName,$percV,$typeName) = split(/$;/,$_);
	local($toType,$reference) = split(/$;/,$callback{$_});
	next unless $reference;
	$cbNeeded{$name} = 1;
	if ($toString{$toType}) {
	    $post = "";
	    if ($toString{$toType} =~ /OUTPUT/) {
		$conv = "$toString{$toType};";
		$conv =~ s/OUTPUT/ws/;
		$conv =~ s/INPUT/$reference/;
	    } elsif ($toString{$toType} =~ /^%s/) {
		$conv = "wafeStringAppend(ws, $reference);";
	    } elsif ($toString{$toType} =~ /^%ld/) {
		$conv = "wafeStringAppendLong(ws, $reference);";
	    } elsif ($toString{$toType} =~ /^%d/) {
		$conv = "wafeStringAppendInt(ws, $reference);";
	    } elsif ($toString{$toType} =~ /^%f/) {
		$conv = "double f = $reference; \n"
		    ."      wafeStringAppendFloat(ws, f);";
	    } elsif ($toString{$toType} =~ /^%hd/) {
		$conv = "wafeStringAppendShort(ws, $reference);";
	    } elsif ($toString{$toType} =~ /^%p/) {
		$conv = "wafeStringAppendPointer(ws, $reference);";
	    } else {
		$conv = "char *p = (char *)$toString{$toType}($reference);"
  		       ."wafeStringAppend(ws,p);";
		$post = "XtFree(p);\n                    ";
	    }
	}

	$reason = $package =~ /MOTIF/ ? 
	    $reasonCode{$callbackName} : 
	    $reasonCode{"$typeName,$callbackName"};
	if ($reason) {
	    local(@rsons);
	    foreach (split(/\s+/,$reason)) {
		push(@rsons,"((XmAnyCallbackStruct *)callData)->reason == $_");
	    }
	    $selector = "(".join(" || ",@rsons).")";
	} else {
	    $CBQuark{$callbackName} = 1 
		unless $isStrippedGlobalQuark{$callbackName};
	    $selector = "attrib == q$callbackName";
	}

	$key = 
	    "$percV$;$package$;$typeName$;      $conv\n      ${post}break;";
	$switchcounter++;
        $switchcode{$key} .= "$;$selector";

#	$cascade .= 
#	    "#ifdef $package\n"
#	    ."            else if (chi == '$percV' &&\n"
#	    ."                     wClass == $typeName &&\n"
#	    ."                     $selector)\n"
#	    ."                {\n"
#	    ."                $conv\n"
#	    ."                $post}\n"
#	    ."#endif\n"
#	;
    }

    local($percV,$last_percV,   $package,$last_package,  
          $cl,$last_cl,         $code,$last_code);
    local($close_package, $close_cl);

    foreach (sort keys %switchcode) {
	($percV,$package,$cl,$code) = split(/$;/);
	$close_cl      = $last_cl   ? "  }\n" : '';
	$close_package = $close_cl.($last_package ? 
	    "#endif /* $last_package */ \n" : '');

	if ($percV ne $last_percV) {
	    $cascade .= $close_package."    goto UNHANDLED;\n\n\n"
		if $last_package;
	    $cascade .= " case '$percV':\n";
	    $close_package = $last_package = ''; 
	}
	if ($package ne $last_package) {
	    $cascade .= $close_package."#ifdef  $package\n";
	    $close_cl = $last_cl = '';
	}
	if ($cl ne $last_cl) {
	    $cascade .= "$close_cl  if (wClass == $cl) {  "
		."/* $package: %$percV */\n";
	    $last_code = ''; 
	}
	if ($code ne $last_code) {
	    $close_cl = '';
	}
	$switchcode{$_} =~ s/^$;//;
	$cascade .=
	    "    if (  "
	    .join("\n       || ",split(/$;/,$switchcode{$_}))
	    ."\n       ) {\n"
            ."$code}\n$close_cl";

	$last_percV    = $percV;
	$last_package  = $package;
	$last_cl       = $cl;
	$last_code     = $code;
    }
    $close_cl      = $last_cl      ? "  }\n" : '';
    $close_package = $last_package ? 
	"$close_cl#endif /* $last_package */ \n" : $close_cl;

    $cascade .= $close_package if $last_package;

    foreach(keys %CBQuark) {
	$quarks .= "static XrmQuark q$_;\n";
	$quarkInit .= "     q$_ = WafePermStringToQuark("
	    .&quarkValue($_).");\n"; 
    }

    foreach $a (sort keys %addRes) {
	local($package,$className) = split(/$;/,$a);
 	local($l) = join("\n",grep($_ = '               {'.join(', ',split(/:/,$_)).'},',
				   split(/$;/,$addRes{$a})));
                
	$addResCode .= 
	    "#ifdef $package\n"
	    ."      if (wClass == $className)\n"
	    ."           {\n"
	    ."           static addResInfo ${className}_addResList[] = {\n"
	    ."$l\n"
	    ."               {NULL,NULL}\n"
  	    ."           };\n"
	    ."           *num = " . ($addRes{$a} =~ tr/:/:/) . ";\n"
	    ."           return ${className}_addResList;\n"
	    ."           }"
	    ."\n#endif\n";
    }

    print CB <<"cbProc";
/*
 * This file was generated by genc.
 * Be aware that modifications of this file will be lost,
 * when genc is executed!

$creationNote

 */

#define CALLBACK_C

#include "wafe.h"
#include <X11/IntrinsicP.h>

$includes

#ifndef X11R6
extern WidgetClass hookObjectClass;
#endif

$quarks

void
wafeInitializeGeneratedCode()
     {
$packageInit

$quarkInit
     }



addResInfo *
wafeGetAdditionalResources(wClass,num)
WidgetClass wClass;
Cardinal    *num;
      {
$addResCode
      *num = 0;
      return (NULL);
      }

void
wafeExecCallbackProc(w, clientData, callData)
Widget     w;
XtPointer  clientData, callData;
    {
    XrmQuark     attrib = *(XrmQuark *) clientData;
    char        *input  = ((char *)clientData + sizeof(XrmQuark));
    char        *start;
    wafeStringStruct   wss;
    wafeString   ws = &wss;
    WidgetClass  wClass = XtClass(w);

    DBUG_ENTER("execCallbackProc");
    DBUG_PRINT("callback", ("client data %p <%s>", input,input));

#ifdef MOTIF
    wafeCurrentCallData = callData;
    if (callData)
	wafeCurrentEvent = ((XmAnyCallbackStruct *)callData)->event;
#endif

    wafeStringInit(ws);
    do 
        {
        for (start = input; *input && *input != '%'; input++);
	wafeStringAppendN(ws,start,input-start);

        if (*input == '%')
            {
            char chi = *++input;
	    if (!callData) /* without calldata, we can handle only [wW] */
                {
		if (chi == 'w')
		    wafeStringAppend(ws, XtName(w));
                else if (chi == 'W')
                    wafeStringAppendLong(ws, (long)w);
                else 
                    goto UNHANDLED;
		}
            else 
	    switch (chi) 
               {
                case 'w':
#ifndef PRER6
		   wafeStringAppend(ws, XtName(
                       wClass == hookObjectClass ?
		       ((XtDestroyHookDataRec *)callData)->widget : w));
#else
		   wafeStringAppend(ws, XtName(w));
#endif
		   break;

                case 'W':
#ifndef PRER6
                   wafeStringAppendLong(ws,(long)
                       (wClass == hookObjectClass ?
			((XtDestroyHookDataRec *)callData)->widget : w));
#else
                   wafeStringAppendLong(ws, (long)w);
#endif
		   break;

                case '=':
#ifdef MOTIF
                   wafeActionPercentcode(ws,*++input,wafeCurrentEvent,w);
                   break;
#else
                   goto UNHANDLED;
#endif
$cascade
UNHANDLED:
#ifndef PRER6
	    if (chi == 't' &&  /* this should be really under case 't' */
		(wClass == hookObjectClass) && callData
		) {
		wafeStringAppend(ws,((XtDestroyHookDataRec *)callData)->type);
                break;
	    }
#endif

                default: input--; /* fall through */
                case '%': wafeStringAppendChar(ws,'%');
               }
            input++;
            }
        } while (*input != '\\0');

    wafeStringAppendChar(ws,'\\0');
    (void)wafeEval(wafeInterpreter, ws->buffer, "execCallbackProc");
    wafeStringClear(ws);
#ifdef MOTIF
    if (callData)
	wafeCurrentEvent = NULL;
    wafeCurrentCallData = NULL;
#endif

    DBUG_VOID_RETURN;
    }

cbProc
    
    close(CB);


#
#   save callback specification in perl format
#
    open(CB,">callback.perl");
    print CB "# this file was generated by genc; not intended for human readers\n";
    foreach(keys %definedPackage) {
	print CB "\$definedPackage{'$_'} = '$definedPackage{$_}';\n" 
	    if $definedPackage{$_};
    }
    foreach(keys %callbackClass) {
	print CB "\$callbackClass{'$_'} = '$callbackClass{$_}';\n" 
	    if $callbackClass{$_};
    }
    foreach(keys %include) {
	print CB "\$include{'$_'} = '$include{$_}';\n" if $include{$_};
    }
    foreach(keys %callback) {
	print CB "\$callback{'$_'} = '$callback{$_}';\n" if $callback{$_};
    }
    foreach(keys %addRes) {
	print CB "\$addRes{'$_'} = '$addRes{$_}';\n" if $addRes{$_};
    }
    foreach(keys %globalQuark) {
	print CB "\$globalQuark{'$_'} = '$globalQuark{$_}';\n" 
	    if $globalQuark{$_};
    }
    close(CB);
}


sub loadAndClearCallbackSpec {
    if (-s "callback.perl") {
	require "callback.perl" || print "cannot require callback.perl\n";
    }
    foreach(keys %callbackClass) {
	undef $callbackClass{$_} if $callbackClass{$_} eq $PACKAGE;
    }
    foreach(keys %include) {
	undef $include{$_} if /^$PACKAGE/;
    }
    foreach(keys %callback) {
	undef $callback{$_} if /^$PACKAGE/;
    }
    foreach (keys %addRes) {
	undef $addRes{$_} if /^$PACKAGE/;
    }
    foreach (keys %globalQuark) {
	undef $globalQuark{$_} if /^$PACKAGE/;
    }
}

sub className {
    local($_,$type) = @_;
#   Athena 'inconsistency'
    s/^Text/asciiText/;
#   HTML inconsistency
    s/^HTML/html/;
#    s/^Xm/xm/;
    $_ = "\l$_";
    # otherwise we get a XmLabelGadgetGadgetClass!
    return $_."Class" if m/$type$/;  
    "$_${type}Class";
}

sub sharedString {
    local($_) = @_;
    return $sharedString{$_} if defined $sharedString{$_};
    print "not shared <$_>\n" if $opt_s;
    return '"'.$_.'"';
}

$tcl_cmdCounter=-1;
$wcc_cmdCounter=-1;
sub addPrivateString {
    local($_,$type) = @_;
    local($priv,$string) = ("WS_$_", '"'.$_.'"');
    $sharedString{$_} = $priv;
    if ($type eq 'tclCmd') {
	$tcl_cmdCounter ++;
	$GENC .=  "#define $priv cmds[$tcl_cmdCounter].name\n";
	return $string;
    } elsif ($type eq 'widgetCreateCmd') {
	$wcc_cmdCounter ++;
	$GENC .=  "#define $priv wccs[$wcc_cmdCounter].name\n";
	return $string;
    } else {
	$GENC .=  " static _Xconst String $priv = $string;\n";
	return $priv;
    }
}

sub quarkCore {
    local($_) = @_;
    return $1 if m/^\"(.*)\"$/;
    return $1 if m/^X[tm][RN](.*)$/;
    return $_;
}

sub quarkName {
    local($_) = @_;
    return 'q'.&quarkCore($_);
}

sub quarkValue {
    local($_) = @_;
    return $_ if m/^\".*\"$/ || m/^X[tm][RN]/;
    return "\"$_\"";
}

sub quarkInitCmd {
    local($quark,$_) = @_;
    return " $quark = WafePermStringToQuark(".&quarkValue($_).");\n";
}


sub reference {
    local($kind,$var) = @_;
    return "&${var}list, &${var}count" if $kind eq "list+count";
    return "&${var}count, &${var}list" if $kind eq "count+list";
}
#
#
# the following routines are for the generation of the 
# TeX file.
sub doc {
    local($_) = @_;
    return if $noDoc;
    print DOC "$_\n";;
}

sub docReturnValue {
    local($_) = @_;
    s/TCL_RETURN_CODE//;
    s/\s*\(\)//;
    return "$1" if /\((.+)\)/;
    return "String" if /XrmQuark/;
    $_;
}

sub help {
    local($cmd,$cmdType,$args) = @_;

    print HELP "proc $cmd-type {} { return {$cmdType $args}}\n";
    if ($procNeeds) {
	print HELP "set wafeCmdNeeds($cmd) {$procNeeds}\n";
	$procComment = '';
    }
    if ($procComment) {
	print HELP "set wafeHelp($cmd) {$procComment}\n";
	$procComment = '';
    }
    print HELP "\n";
}
#
#
#  ---------------------- main program ------------------

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

open(DEFS,"<$opt_f") || die "cannot open $opt_f for reading";
open(OUT, ">$outputfile") || die "cannot open $outputfile for writing";
open(DOC, ">$stem.tex") || die "cannot open $stem.tex for writing";
open(HELP, ">tcllib/$stem.tcl") || die "cannot open $stem.tex for writing";

# package init commands
$ICMD = '';
# tcl command signatures
$TCLC = '';
# widget create command signatures
$WCC = '';
# packages
$PKGS = '';
# genarated package specific code
$GENC = '';

$autoPackage{'MOTIF11'} = 'MOTIF';
$autoPackage{'MOTIF12'} = 'MOTIF';
$autoPackage{'ATHENAR5'} = 'ATHENA';


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

$*=1; $file =~ s/^\s+$//g; $*=0;

foreach(split(/\s*\n\n+/,$file)) {
        if (/^(#include|#ifdef|#define|#ifndef|#endif|extern)/) {
	    $GENC .=  "$_\n\n";
	    next;
	}
        if (/^%/ || /^@/ || /^\$/) {
	    eval $_;
	    die "ERROR: $@" if $@;
	    if (/^\$PACKAGE/) {
		$definedPackage{$PACKAGE} = 1;

		if ($UBIQUITUS) {
		    $definedPackage{$PACKAGE} = 2;
		    &doc($procComment
			."The commands listed in this section are available "
			."in all versions of Wafe.\n"
			 );
		} else {
		    local($flag) = $autoPackage{$PACKAGE} || $PACKAGE;
		    &doc($procComment
			 ." In order to compile Wafe with support for the  "
			 ."commands listed in this section use the flag "
			 ."{\\tt $flag} during compilation.\n");
		}
		&doc("\n\\begin{itemize}\n");
	    }
	    &loadAndClearCallbackSpec();
            unlink "tcllib/bc/$PACKAGE.tcl" if -r "tcllib/bc/$PACKAGE.tcl";
	    next;
	}
	$procComment = join("\n",split(/\n\#>/,$')), next if /^\#>/;
        next if /^\#/;
        next unless (@items = split(/[ \t]*\n[ \t]*/));
        $procNeeds = '';

	$openIFDEFS = $closeIFDEFS = $elseIFDEFS = $prototype = $noDoc = "";
	if ($items[$[] =~ /hints?\s*:\s*(\S.*)/) {
	    foreach (split(/\s*,\s*/,$1)) {
		$prototype = 1,next if /\bprototype\b/;
		$noDoc = 1,next if /\bnoDoc\b/;
		$openIFDEFS .= "#if !defined(PRER5) || defined(XAW3D)\n", 
		   $closeIFDEFS .= "\n#endif",
		   $procNeeds .= "R5\|XAW3D ",
		   next if /\bR5\|XAW3D\b/;
		$openIFDEFS .= "#ifndef PRER5\n", $closeIFDEFS .= "\n#endif",
		   $procNeeds .= "R5 ",
		   next if /\bR5\b/;
		$openIFDEFS .= "#ifdef PRER6\n", $closeIFDEFS .= "\n#endif",
		   $procNeeds .= "!R6 ",
		   next if /!R6\b/;
		$openIFDEFS .= "#ifndef PRER6\n", $closeIFDEFS .= "\n#endif",
		   $procNeeds .= "R6 ",
		   next if /\bR6\b/;
		$openIFDEFS .= "#ifndef $1\n", $closeIFDEFS .= "\n#endif",
		   $procNeeds .= "!$1 ",
		   next if /\!\s*(\S+)\b$/;
		$openIFDEFS .= "#ifdef $_\n", $closeIFDEFS .="\n#endif",
		   $procNeeds .= "$_ ";
	    }
	    shift(@items);
	} 

        ($returnType,$name,@args) = @items;

        if ($returnType eq "~handles") {
	    foreach($name,@args) {
		if ($_ ne $PACKAGE) {
		    $PKGS .= "#ifdef $_\n     \"$_\",\n#endif\n";
		} else {
		    $PKGS .= "     \"$_\",\n";
		}
	    }
	    next;
	} elsif ($returnType eq "~require") {
            open(REQUIRE,"<$name") || die "cannot open $name for reading";
	    undef($/); $req = <REQUIRE>; $/ = "\n";
	    foreach(@args) {
		if (/^init\S*\s+(\S+.*)$/) {
		    local($cmd) = $1; 
	            $cmd = " ".$cmd if $cmd !~ /^#/;
		    $ICMD .= "$cmd\n";
		} elsif (/^quark\s+(\S+)\s*$/) {
		    local($attrib) = $1;
		    local($quark)  = &quarkName($attrib);
		    $globalQuark{"$PACKAGE$;$attrib"} = 1;
		    $TCLD .=  " extern XrmQuark $quark;\n";
		    $ICMD .= &quarkInitCmd($quark,$attrib);
		} elsif (/^privateQuark\s*(\S+)\s*$/) {
		    local($attrib) = $1;
		    local($quark)  = &quarkName($attrib);
		    $TCLD .=  " static XrmQuark $quark;\n";
		    $ICMD .= &quarkInitCmd($quark,$attrib);
		} elsif (/^privateString\s*(\S+)\s*$/) {
		    &addPrivateString($1);
		} elsif (/^conv\S*\s+(\S+.*)$/) {
		    local($from,$to,$cnvCache,$cnvCall,$arg,$free) = 
			split(/\s+/,$1);
	            local($toQuark) = &quarkName($to);
		    local($argCnt);
		    $arg = '' if $arg eq "NULL";
		    if ($arg) {
			$argCnt =  "XtNumber($arg)";
		    } else {
			$argCnt = 0;
			$arg = "NULL";
		    }
		    $free = "NULL" unless $free;
		    $ICMD .= $openIFDEFS
			." XtSetTypeConverter($from, $to,\n"
			."\t(XtTypeConverter)$cnvCall, \n"
			."\t$arg, $argCnt, XtCache$cnvCache, $free);"
			."$closeIFDEFS\n";
		}
	    }
	    $TCLD .=  "\n$req\n";
	    next;

	} elsif ($returnType eq "~alias") {
	    local($aliasName, $oldName);
	    foreach($name,@args) {
		if (/^\s*(\S+)\s*(\S+)$/) {
		    ($aliasName,$oldName) = ($1,$2);
#		    local($tclName,$XtName) = &tclName($2);
		    $TCLC .= "{ ".&sharedString($aliasName)
			.", cmd_$oldName }, /* alias */\n";
#		    $ICMD .= " /* alias */  Tcl_CreateCommand(wafeInterpreter,\"$1\","
#			    ."cmd_$2, NULL,NULL);\n";
		    &doc("\\alias{$aliasName}{$oldName2}");
		    &help($aliasName,"alias",$oldName);
		}
	    }
	    next;
	} elsif ($returnType eq "~bcAlias") {
	    foreach($name,@args) {
		if (/^\s*(\S+)\s*(\S+)$/) {
		    &alias($1,$2);
		}
	    }
	    next;
        }

	($tclName,$XtName) = &tclName($name);
	    
        if ($returnType =~ "~(widget|object|gadget)Class") {
	    local($classType) = "\u$1";
	    local($className) = &className($XtName,$classType);
	    $sharedTclName = &addPrivateString($XtName,'widgetCreateCmd');
	    &doc("\\widget{$tclName}{$classType}");
	    &help($tclName,"creationCommand",$classType);
            local($createCmd,$createsShell) = 
		&widgetClassOptions($XtName,$className,@args);
	    $createsShell = 'False' unless $createsShell;
	    $WCC .= "{ $sharedTclName,NULL,$createCmd,$createsShell },\n";
	    $CWC .= 
		$openIFDEFS
		." wccs[$wcc_cmdCounter].wClass = $className; /* not a constant! */"
	        .$closeIFDEFS
                ."\n";
	    next;
        } elsif ($returnType eq "~pseudoWidgetClass") {
            local($createCmd,$className,$createsShell) = 
		&pseudoWidgetClassOptions($XtName,@args);
	    $sharedTclName = &addPrivateString($XtName,'widgetCreateCmd');
	    $createsShell = 'False' unless $createsShell;
	    local($tn,$xn) = &tclName($className);
	    &doc("\\pseudoWidget{$tclName}{$createCmd}{$tn}");
	    &help($tclName,"creationCommand",$tn);
	    $className = &className($className,'Widget');
	    $WCC .= "{ $sharedTclName,NULL,$createCmd,$createsShell },\n";
	    $CWC .= " wccs[$wcc_cmdCounter].wClass = $className;\n";
	    next;
	} 

	$sharedTclName = &addPrivateString($tclName,'tclCmd');
	&printComment( "\n$_\n");

	# print STDERR "--- new ---\n";
	$localVars = $body = $preCode = $postCode = $endCode = $freeProc = "";
        $repeatCall = $nrArgs = 0;
	@cVar = @inOut = @type = @inFunction = @toRemove = 
	    @prototypes = @array = @additional = ();
	%localVarNeeded = ();

	for ($[..$#args) {
	    ($args[$_],$comment[$_]) = &stripComment($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*(.*)$/;
	}
	($usXtName = $XtName) =~ s/_/\\_/g;
	($usTclName = $tclName) =~ s/_/\\_/g;
	$usXtName = "" if $usXtName eq $tclName;
	($functionComment = join(", ",grep($_,@comment))) =~ s/_/\\_/g;
        $functionComment =~ s/\|/\\I\\/g;
	$docReturnValue = &docReturnValue($returnType);
        &doc("\\function{$usTclName}{$usXtName}{$functionComment}"
	    ."{$docReturnValue}");
        @docArgs = grep($_,@args);
        &help($tclName,"function",
	      "{$docReturnValue}".' {'
	      .join('} {',grep((s/([{}])/\\\1/,$_),@docArgs)).'} ## {'
	      .join('} {',grep($_,@comment)).'}');
	undef @comment;

        foreach (@toRemove) { splice(@args,$_,1); }

        $tclArgs = $nrConst = $nrConstBeforeArray = 0;
	for ($[..$#args) {
	    ($inOut[$_], $type[$_]) = split(/:\s*/,$args[$_]);
            $nrConst++,next if $inOut[$_] =~ /[Cc]onst/;
            $tclArgs-- if $inOut[$_] =~ /[Ff]ree/;
	    $cVar[$_] = "localVar". ($_ - $nrConst);
	    # print STDERR "cVar[$_] = <$cVar[$_]>\n";

	    ($type[$_],$array[$_],$nrConstBeforeArray) = 
		$type[$_] =~ /^(.*)\[(.*)\](.*)$/ ? 
		    ($1.$2.$3,1,$nrConst) : 
		    ($type[$_],0,0);

	    ($type[$_],$additional[$_]) = 
		$type[$_] =~ /(\w+)\s*\|\s*(.*)/ ? 
		    ($2,$1) : 
		    ($type[$_], "");


	    ($type[$_],$inFunction[$_]) = 
		$type[$_] =~ /^(\w+)\((.*)\)/ ? 
		    ($2,$1) : 
		    ($type[$_], "");

	    if ($inOut[$_] =~ /[Oo]ut/ && $inFunction[$_] eq "list") {
		# special case output list (should be more sophisticated)
		local($arg1,$arg2) = ($type[$_] =~ /^([^,]+),(.+)$/);
		if ($arg1 =~ /\*/) {
		    $inFunction[$_] = "list+count";
		    $localVars .= "     $arg1 $cVar[$_]list;\n"
                                 ."     $arg2 $cVar[$_]count;\n";
		} else {
		    $inFunction[$_] = "count+list";
		    $localVars .= "     $arg2 $cVar[$_]list;\n"
                                 ."     $arg1 $cVar[$_]count;\n";
		}
	    } else {
		($typeDecl[$_],$type[$_]) = &castedType($type[$_]);
		$typeDecl[$_] .= " *" if $array[$_];

		$localVars .= "     $typeDecl[$_] $cVar[$_];\n" 
		    unless $type[$_] =~ /^args/ ||
			($stringTo{$type[$_]} eq "%s" && 
			 $inOut[$_]=~/[Ii]n/ &&
			 !$additional[$_] &&
			 !$array[$_] &&
			 !$repeatCall);
		
		$localVars .= "     Boolean freeArgv = False;\n"
		             ."     char **argvArg;\n" 
				 if $type[$_] =~ /^args\s+avp/;

		push(@prototypes,$typeDecl[$_]) if $prototype;
	    }
	    $tclArgs++;
	}

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

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

	$argList = $repeatCall || grep(/1/,@array);

	local($argNum) = 
	    ($type[$#array] =~ /^args.*opt/) ? $tclArgs : $tclArgs+1;

	($argCountTest,$quant) = 
	     (($argList ? 'argc < ' : 'argc != ').($argNum),
	      ($argList ? "at least " : ""));

        if ($type[$#array] =~ /^args\s+(.*)/) {
	    if ($1 eq "opt") {
	    } elsif ($1 eq "avp") {
	    } else {
		$argCountTest .= 
		    " || " . ($1 eq "even" ? "" : "!")
			."((argc-".($#array-$nrConstBeforeArray).") % 2)";
		$quant = "$1 number of arguments and $quant";
	    }
	}
	    
        $argBreak = $#args;
        $argBreak = $repeatCall -1 if $repeatCall;

	$localVars .= "     int count;\n" if $repeatCall;
	$TCLC .= "{ $sharedTclName, cmd_$tclName },\n";
#        $TCLD .= "static int cmd_$tclName();\n";
#	$ICMD .= 
#	    $openIFDEFS
#	    . " Tcl_CreateCommand(wafeInterpreter, "
#	    . &sharedString($tclName)
#	    . ", cmd_$tclName, NULL, NULL);"
#	    . "$closeIFDEFS\n";




        $argc=0;
	for ($[..$argBreak) {
            $argc++, next if $inOut[$_] =~ /^[Oo]ut/;
            next if $inOut[$_] !~ /^[Ii]n/;
	    $argc++;
	    if ($array[$_]) {
                local($arg) = $_ - $nrConstBeforeArray;

		if ($type[$_] !~ /^args/) {
		    $body .=
			"     {    $type[$_] *ptr;\n          argv += $arg;\n"
		       ."          $cVar[$_] = ptr =\n             "
		       ."($type[$_] *)XtMalloc((argc-$arg)*sizeof($type[$_]));\n\n"
		       ."          while (*argv)\n             {\n";
    		    $body.=&inConversion("*argv","*ptr","",$type[$_],$arg,3,1);
		    $body.="          ptr ++; argv++;\n          }\n     }\n";
		} else {
		    $body.= "     argc -= $arg;\n";
		    if ($type[$_] =~ /^args\s+avp/) {
			$body.= 
			    "     argvArg = &argv[$argc];\n"
			   ."     if (argc == 1)\n        {\n"
			   ."        if (wafeMergeArguments(argv[$argc],argv[0],&argc,&argvArg))\n"
			   ."           freeArgv = True;\n"
		           ."        else \n"
                           ."           DBUG_RETURN (TCL_ERROR);\n" 
			   ."        }\n"
			   ."     if (argc%2)\n"
			   ."        {\n"
                           ."        if (freeArgv) XtFree((char*)argvArg);\n" 
			   ."        DBUG_RETURN(wafeArgcError(argc+$arg, argv,\"even number of attribute value pairs such as 2 or \",4));\n"

			   ."        }\n\n";

			$postCode .= "     if (freeArgv) XtFree((char *)argvArg);\n";
			$cVar[$_] = "argc,argvArg";
		    } else {
			$cVar[$_] = "argc,&argv[$argc]";
		    }
		}
	    } else {
		# print STDERR "inConversion: cVar[$_] = <$cVar[$_]>  min=$[, #=$#cVar, \n";
		$body.=&inConversion("argv[$argc]",$cVar[$_],"($typeDecl[$_])",
				     $type[$_],$_,1,0);
	    }
        } #for


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

         $cCall= $returnType =~ /[Vv]oid/ ?  $XtName : 
	     ($returnType eq '' ?  ### it is empty, if there was a cast
	          "returnVar = ($typeDecl) $XtName" : 
		  "returnVar = $XtName");

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

         if ($array[$#array] && $type[$#array] !~ /^args/ ) {
	     local($nthLocalVar) = ($#array-$nrConstBeforeArray);
	     if ($nthLocalVar>1) {
		 $body .= "     wafeMMreplace(localVar1,NULL,"
		         ."WafePermStringToQuark(\"$tclName\"),"
			 ."(char*)localVar$nthLocalVar,XtFree);\n";
             } else {
		 $body .= "     XtFree((char *)localVar1);\n";
	     }
	 }
        $tcl_return = "TCL_OK";
	for ($[..$#args) {
            next if $inOut[$_] !~ /^[Oo]ut/;
            ($convCode,$convData) = 
		&outConversion($cVar[$_], $type[$_],$_, "argv[$_]");
	    $localVarNeeded{$convData} = 1;
 	    $convData =  "$convData ? $convData :wafe_EMPTY" 
	        unless $convCode || $convData =~ m.\(.;

            $body .= "\n     $convCode" if $convCode;
	    if ($convData) {
		$body .= &setVar("     ",
				 "Tcl_SetVar(wafeInterpreter,argv[$_],",
				 $type[$_],$convData);
	    }
        }

	if ($returnType !~ /[Vv]oid/) {
	    $freeProc = $toStringGarbage{$returnType} 
		if !$freeProc && $toStringGarbage{$returnType};

	    ($convCode,$convData) = 
		&outConversion("returnVar", $returnType||$typeDecl,"");
	    $localVarNeeded{$convData} = 1;
            if ($convData eq "staticResultString") {
		$body .=
		    "\n     $convCode     " 
		        ."Tcl_SetResult(comInterpreter, $convData, "
			."TCL_STATIC);\n";

	    } elsif ($convData ne "" && $convCode eq "") {
		# it must be an expression, we assume static or free proc
		$body .= 
		    "\n     " 
			."Tcl_SetResult(comInterpreter, $convData, "
			.($freeProc || 'TCL_STATIC').");\n";
	    } elsif ($convData ne "") {
		$body .= 
		    "\n     $convCode     " 
			."Tcl_SetResult(comInterpreter, $convData, "
			.($freeProc || 'TCL_VOLATILE').");\n";
	    } else {
		$tcl_return = "returnVar";
	    }
	 }
         $body .= "\n$endCode" if $endCode; 

         $localVars .= "     char conversionBuffer[100];\n" 
	    if $localVarNeeded{'conversionBuffer'};
         $localVars .= "     char *staticResultString;\n" 
	    if $localVarNeeded{'staticResultString'};
         $localVars .= "     char *ptr;\n" 
	    if $localVarNeeded{'ptr'};

	 local($string) = &sharedString($quant);
         local($cArgNum) = $argNum-1;

	 if ($openIFDEFS) {
	     $TCLD .= 
		 "${openIFDEFS}static int cmd_$tclName();"
		."\n#else\n#define cmd_$tclName NULL"
		."$closeIFDEFS\n";
	 } else {
	     $TCLD .= "static int cmd_$tclName();\n";
	 }

	 $elseIFDEFS = "#else\n#define cmd_$tclName NULL"
	    if $openIFDEFS;

	 $GENC .=  <<"cProc";
$openIFDEFS
static int 
cmd_$tclName(clientData, comInterpreter, argc, argv)
ClientData    clientData;
Tcl_Interp   *comInterpreter;
int           argc;
char        **argv;
     {
$localVars
     DBUG_ENTER(argv[0]);  

     if ($argCountTest) 
	 DBUG_RETURN(wafeArgcError(argc,argv,$string,$cArgNum));

$body
     DBUG_RETURN ($tcl_return);
     }
$elseIFDEFS
$closeIFDEFS

cProc

}

if ($UBIQUITUS) {
    $GENC .=  
	"\nvoid\nwafeInitialize_$PACKAGE()\n{\n"
	.$CWC
        .$ICMD
        ." wafeCreateTclCmds(pkgs,wccs,cmds);\n"
        ."}\n";
} else {
    $GENC .=  
	"#endif  /* of ifdef $PACKAGE */\n" 
        ."\nvoid\nwafeInitialize_$PACKAGE()\n{\n"
        ."#ifdef $PACKAGE\n"
        .$CWC
        .$ICMD
        ." wafeCreateTclCmds(pkgs,wccs,cmds);\n"
        ."#endif /* of ifdef $PACKAGE */\n"
        ."}\n";
}

&doc("\\end{itemize}\n");

&generateGenc();
&generateCallback();

close DEFS;
close OUT;
close DOC;
close HELP;




