#!/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.13";

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 postTest {
    local($test,$msg,$t) = @_;
    return "$t if (!($test))\n$t     wafeReturnTclError(argv[0],\"$msg\");\n";
}

sub inConversion {
    local($fromTcl,$cVar,$cast,$type,$_,$argc,$tab,$nsc,$argv) = @_;
    local($qual,$class,$ot,$postTest) = ('');
    local($t) = " " x (4*$tab);
    local(@pre,$pre,$stem,$component,$string);
    local($origType) = $type;

    #print STDERR "ininConverion: cVar[$_] = <$cVar[$_]> min=$[, #=$#cVar\n";
  
    $argc = $_ unless $argc;
    ($stem,$component) = /\./ ? ($`,"\"$'\"") : ($argc,'NULL');
  
    if ($additional[$_]) {
        @pre = &stringToCascade($fromTcl,$cVar,$additional[$_],$t,$argv);
	pop(@pre);   # remove error message 
	$pre .= join("\n",@pre)."\n$t else\n    ";
    }

    local($conv) = $stringTo{$type};
    if (!$conv && ($type =~ /^(.*)(Widget|Gadget|Object)(.*)$/)) {
	($class,$ot,$qual) = ($1,$2,$3);
	if ($class) {
	    $class =~ s/^Text/AsciiText/ if $PACKAGE eq 'ATHENA';
	    $conv = "name2WidgetOfClass(INPUT,\l${class}${ot}Class)";
	} else {
	    $conv = "name2Widget(INPUT)";
	}
	# print "class=$class, ot=$ot, qual=$qual\n";

	$postTest .= &postTest("XtIsWidget($cVar)",
			       "$class$ot (arg $argc) must have a display",$t)
	    if $qual =~ /Display/;
	$postTest .= &postTest("XtWindow($cVar)",
			       "$class$ot (arg $argc) must be realized",$t)
	    if $qual =~ /Window/;
	$postTest .= &postTest("XtParent($cVar)",
			       "$class$ot (arg $argc) must have a parent",$t)
	    if $qual =~ /Parent/;

	$type = "Widget";
	$cast = "";
	$origType = $1 if $origType =~ /^(.+){.*}$/;
    } elsif ($conv eq "%s") {
	return "$pre$t $cVar = XtNewString($fromTcl);\n" if $cVar =~ /^\*/;
	return "$pre$t $cVar = $fromTcl;\n" if $pre || $nsc;  # no shortcut possible
	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 = "*$fromTcl >= '0' && *$fromTcl <= '9' && "
		if $type =~ /unsigned/;
	    $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};

	$origType = &sharedString($origType);

	return $pre.<<"cConversion";
$t if (!($convCode))
$t     DBUG_RETURN(wafeConvError(argc, $argv, $stem, $component, $origType));
$postTest
cConversion
    }
    return $pre.&conversionToStructure($fromTcl,$cVar,$type,$_) 
	if $Structure{$type};
    return $pre.join("\n$t else\n", 
		     &stringToCascade($fromTcl,$cVar,$type,$t,$argv))."\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,'argv');
    }
    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",'argv');
    }
}


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,$argv) = @_;
    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/{.*}//g;
    $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 rConv {
    local($typeString,$cType,$direction,$strings,$values) = @_;
    local($initCode);
    $RCONV .= <<"_";
 static _Xconst String ${cType}_strings[] = {
  $strings,NULL };
 static _Xconst int ${cType}_values[] = {
  $values,0 };
 static XtConvertArgRec ${cType}_args[] = { {XtAddress, NULL, 0} };

_
    return <<"_";

 ${cType}_args[0].address_id= (XtPointer)
   wafeAddRConv($typeString,sizeof($cType),
		${cType}_strings, (XtPointer)${cType}_values);
 XtSetTypeConverter($typeString,XtRString,wafeCvtRToString,
		    ${cType}_args,XtNumber(${cType}_args),
                    XtCacheNone,NULL);
_
}


sub widgetClassOptions {
    local($name,$className,@args) = @_;
    local($creationCmd,$comment,$createsShell,$initOnCreate,$initCode) = 
	('','','','False','',0);
    return "NULL" unless @args;
    $callbackClass{"$name$;$className"} = $PACKAGE;
    local($arg);
    for ($[..$#args) {
	($arg,$comment) = &stripComment($args[$_]);
	if ($arg =~ /^\s*include\s*(\S.*)$/) {
	    $include{"$PACKAGE$;$name"}="${openIFDEFS}#include $1$closeIFDEFS";
	    $INCL .= "${openIFDEFS}#include $1$closeIFDEFS\n";
	    next;
	}
	if ($arg =~ /^\s*registersStringConverter\s*(\S.+)$/) {
	    foreach (split(/\s+/,$1)) {
		$stringConv{"$PACKAGE$;$_"} = $name;
		$initOnCreate = "True" if $wafeStringConv{$_};
	    }
	    next;
	}
	if ($arg =~ /^creates\s(\S+)\s+(\S.*)$/) {
	    local($pkg,$classes) = ($1,$2);
	    $classes =~ s/(\S+)/ wafeInitClass("$pkg","$1");\n/g;
	    $initCode .= "#ifdef $pkg\n$classes#endif /* $pkg */\n";
	    next;
	}
        if ($arg =~ /^createClassProcsAlways/) {
	    $createClassProcsAlways{$name} = 1;
	    next;
	}
        if ($arg =~ /^rConv\s+(.*)$/) {
	    $initCode .= &rConv(split(/\s+/,$1));
	    next;
	}
        if ($arg =~ /^nsConv\s+(.*)$/) {
	    local($varType,$resName,$secondaryName,$tertName,
		  $toStringProc,$toStringFreeProc,
		  $fromStringProc,$fromStringFreeProc) =
		      split(/\s+/,$1);
	    $privateQuark{$resName} = 1 
		unless $globalQuark{"$PACKAGE$;$resName"};
	    $resName = &quarkName($resName);
	    $initCode .= " wafeAddNsConv($resName,$secondaryName,$tertName,"
			     ."$className,sizeof($varType),\n\t"
                             ."$toStringProc,$toStringFreeProc, \n\t"
			     ."(pointerProc)$fromStringProc,"
			     ."$fromStringFreeProc);\n";
	    next;
	}

	if ($arg =~ /^\s*addRes\s*(\S+)\s+(\S+)\s*$/) {
	    local($resName,$resType) = ($1,$2);
	    $addRes{"$PACKAGE$;$className"} .= "$resName:$resType$;";
	    next;
	}
	$creationCmd = $1,next if ($arg =~ /^\s*createCmd\s*(\S.*)$/);
	$createsShell = 'True',next if ($arg =~ /^\s*createsShell/);

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

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,'False');
}

sub generateGenDotC {
    local($quark);

    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>
genc

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

    print OUT $INCL.$TCLD.$DEFINES;

# generate initialization code
    $WCC = '';
    $classInitProcs = "\n";
    foreach (@wcc_order) {
	$classInitProc = "XtInitializeWidgetClass";
	if ($createClassProcsAlways{$_}) {
	} elsif ($useInitProcFrom{$_}) {
	    $mainClass = $useInitProcFrom{$_};
	    if (defined($classInitCode{$mainClass}) ||
		defined($classProcs{$mainClass})) { 
		$classInitProc = 'wafeClassInit_'.$useInitProcFrom{$_};
	    }
	} elsif ($classInitCode{$_} || $classProcs{$_}) {
            $cmds = '';
            if ($classProcs{$_}) {
		$cmds = <<"_";
 static _Xconst Proc_signature cmds[] = {
$classProcs{$_} { NULL, NULL }
 };
_
		$createCmds = " wafeCreateTclProcs(cmds);\n";
                $classProcs{$_} = '';
            } else {
		$createCmds = '';
	    }
	    $classInitProc = "wafeClassInit_$_";
	    $classInitProcs .= <<"_";
static void wafeClassInit_$_(wClass)
WidgetClass wClass;
{
$cmds XtInitializeWidgetClass(wClass);
$createCmds$classInitCode{$_}}

_
	}
        print "!!! find nothing for <$_>\n"unless $createSignature{$_};
        $WCC .= "    {$createSignature{$_},$classInitProc},\n";
    }

    foreach (keys %classProcs) {
	$TCLC .= $classProcs{$_}, print "global: $_\n" if $classProcs{$_};
    }

    print OUT 
         "\n"
        .$RCONV
        .$classInitProcs
        ."\n\n";

    if ($TCLC eq '') {
	print OUT 
	    "\nstatic _Xconst Proc_signature *cmds = NULL; \n";
    } else {
	print OUT 
	    "\nstatic _Xconst Proc_signature cmds[] = {\n    "
	   .join("\n    ",split(/\n/,$TCLC))
           ."\n    { NULL, NULL }\n    };\n";
    }

    print OUT 
	 "\nstatic WidgetCreate_signature wccs[] = {\n"
        .$WCC
        ."    { NULL,NULL,NULL,False,False,NULL }\n    };\n"
	."\nstatic _Xconst String pkgs[] = {\n"
        .$PKGS
	."    NULL\n     };\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";

    }

    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 '"'.$_.'"';
}

@wcc_order = ();
$tcl_cmdCounter=-1;
$wcc_cmdCounter=-1;
sub addPrivateString {
    local($_,$type) = @_;
    local($priv,$string) = ("WS_$_", '"'.$_.'"');
    $sharedString{$_} = $priv;
    # print "adding private String <$_> -> <$priv>\n";
    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";
	push(@wcc_order,$_);
	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 texifyLine {
    local($_) = @_;
    s/([_%\^\$])/\\$1/g;
    s/-/-{}/g;
    s/\'([^\'\n]+)\'/{\\em $1}/g;
    print DOC "$_\n";
}

sub texifyComment {
    local($_) = @_;
    local($block) = 0;
    print DOC "\\par\n";
    foreach (split(/\n/,$_)) {
	if ($block) {
	    if (/^  /) {
		print DOC "$_\n";
		next;
	    }
	    print DOC "\\end{verbatim}\n\\end{footnotesize}\n";
	    $block = 0;
	    &texifyLine($_);
	} else {
	    if (/^  /) {
		print DOC "\\par\\begin{footnotesize}\n\\begin{verbatim}\n";
		print DOC "$_\n";
		$block = 1;
		next;
	    }
	    &texifyLine($_);
	}
    }
    if ($block) {
	print DOC "\\end{verbatim}\n\\end{footnotesize}\n";
    }
}

sub doc {
    local($_,$comment) = @_;
    return if $noDoc;
    print DOC "$_\n";
    &texifyComment($comment) if $comment;
}

sub docReturnValue {
    local($_) = @_;
    s/TCL_RETURN_CODE//;
    s/\s*\(\)//;
    s/_/\\_/g;
    $_ = 'void' unless $_;
    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";
	$procNeeds = '';
    }

    if ($helpComment) {
	$procComment .= "\n Special percentcode subsititutions are performed for listed callbacks:$helpComment";
	$helpComment = '';
    }
    if ($procComment) {
	print HELP "set wafeHelp($cmd) {$procComment}\n";
	$procComment = '';
    }
    print HELP "\n";
}
#
#
#  ---------------------- main program ------------------

$outputfile = $opt_o || "$stem.c"; 
system("rm -f $outputfile $stem.tex tcllib/$stem.tcl callback.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)/) {
	    $DEFINES .=  "$_\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 Motif or Athena versions of Wafe.\n"
			 );
		    $procComment = '';
		} 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");
		    $procComment = '';
		}
		&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*$/) {
		    $privateQuark{$1} = 1;
		} elsif (/^privateString\s*(\S+)\s*$/) {
		    &addPrivateString($1);
		} elsif (/^listResConv\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s*(\S*)$/) {
		    local($resName,$numResName,$wClass,$proc,$freeProc) = 
			($1,$2,$3,$4,$5);
		    $freeProc = "XtFree" if $freeProc eq "";
		    $privateQuark{$resName} = 1 
			unless $globalQuark{"$PACKAGE$;$resName"};
		    $resName = &quarkName($resName);
		    $ICMD .= " wafeSetListResConverter($resName,$numResName,$wClass,$proc,$freeProc);\n";
		} elsif (/^nsConv\s+(.*)$/) {
		    local($varType,$resName,$secondaryName,$tertName,
			  $toStringProc,$toStringFreeProc,
			  $fromStringProc,$fromStringFreeProc) =
			      split(/\s+/,$1);
		    $privateQuark{$resName} = 1 
			unless $globalQuark{"$PACKAGE$;$resName"};
		    $resName = &quarkName($resName);
		    $ICMD.= " wafeAddNsConv($resName,$secondaryName,$tertName,"
			     ."NULL,sizeof($varType),\n\t"
                             ."$toStringProc,$toStringFreeProc, \n\t"
			     ."(pointerProc)$fromStringProc,"
			     ."$fromStringFreeProc);\n";
		} elsif (/^rConv\s+(.*)$/) {
		    $ICMD .= &rConv(split(/\s+/,$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}{$oldName}",$procComment);
		    &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}");
            local($createCmd,$createsShell,$initOnCreate,$initCode) = 
		&widgetClassOptions($XtName,$className,@args);
	    &texifyComment($procComment);
	    &help($tclName,"creationCommand",$classType);
	    $createsShell = 'False' unless $createsShell;
	    $classInitCode{$XtName} .= $initCode if $initCode;
	    $createSignature{$XtName} =
		"$sharedTclName,NULL,$createCmd,$createsShell,$initOnCreate";
	    $CWC .= 
		$openIFDEFS
		." wccs[$wcc_cmdCounter].wClass = $className; /* not a C constant! */"
	        .$closeIFDEFS
                ."\n";
	    next;
        } elsif ($returnType eq "~pseudoWidgetClass") {
            local($createCmd,$className,$createsShell,$initOnCreate) = 
		&pseudoWidgetClassOptions($XtName,@args);

	    $sharedTclName = &addPrivateString($XtName,'widgetCreateCmd');
	    $createsShell = 'False' unless $createsShell;
	    $useInitProcFrom{$XtName} = $className;
	    $createSignature{$XtName} =
		"$sharedTclName,NULL,$createCmd,$createsShell,$initOnCreate";

	    local($tn,$xn) = &tclName($className);
	    &doc("\\pseudoWidget{$tclName}{$createCmd}{$tn}",$procComment);
	    &help($tclName,"creationCommand",$tn);
	    $className = &className($className,'Widget');
	    $CWC .= " wccs[$wcc_cmdCounter].wClass = $className;\n";
	    next;
	} 

	# $sharedTclName = &addPrivateString($tclName,'tclCmd');
        $sharedTclName = "\"$tclName\"";
	&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}{$procNeeds}",$procComment);
	@docArgs = @args;
	grep(s/{.*}//?$_:$_,@docArgs);
        &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;

	$tclCmdSignature = " { $sharedTclName, cmd_$tclName },\n"; 
        if ($type[$[] =~ /^(.+)(Widget|Gadget)$/) {
	    $classProcs{$1} .= $tclCmdSignature;
        } else {
	    $TCLC .= $tclCmdSignature;
	}

#       print "type of first arg = <$type[$[]>\n";
	$argc = $nrConst = 0;
	for ($[..$argBreak) {
            $nrConst++,next if $inOut[$_] =~ /[Cc]onst/;
            $argc++,next if $inOut[$_] =~ /^[Oo]ut/;
            next if $inOut[$_] !~ /^[Ii]n/;
	    $argc++;
	    if ($array[$_]) {
		if ($type[$_] !~ /^args/) {
		    local($origArgv) = 	'char **origArgv = argv;'
			unless $stringTo{$type[$_]} eq '%s';
		    local($type) = $type[$_];
		    $type =~ s/{.*}//;
		    $body .=
			"     {    $type *ptr;\n"
		       ."          $origArgv\n"
		       ."          argv += $argc;\n"
		       ."          $cVar[$_] = ptr =\n             "
		       ."($type *)XtMalloc((argc-$argc)*sizeof($type));\n\n"
		       ."          while (*argv)\n             {\n";
    		    $body.=&inConversion("*argv","*ptr","",$type[$_],$_,$argc,3,1,
					 'origArgv');
		    $body.="          ptr ++; argv++;\n          }\n     }\n";
		} else {
		    $body.= "     argc -= $argc;\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+$argc, 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[$_],$_,$argc,1,0,'argv');
	    }
        } #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,
				   'argv');
	     }
	     $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]);  
     WAFE_UNUSED(clientData);
     WAFE_UNUSED(comInterpreter);

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

$body
     DBUG_RETURN ($tcl_return);
     }
$closeIFDEFS

cProc

}


$quarkDefs = "";
$initQuarkCmds = "";
foreach (sort keys %privateQuark) {
    $quark = &quarkName($_);
    $quarkDefs .=  " static XrmQuark $quark;\n";
    $initQuarkCmds .= &quarkInitCmd($quark,$_);
}

$TCLD = $quarkDefs.$TCLD;
$ICMD = $initQuarkCmds.$ICMD;

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");

&generateGenDotC();
&generateCallback();

close DEFS;
close OUT;
close DOC;
close HELP;
system("chmod 444 $outputfile $stem.tex tcllib/$stem.tcl callback.c");


