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

$version = 0.97;

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>
    -o <output file>
EndOfUsage
unless &Getopts('f: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';

sub printComment {
    local($_) = @_;
    s/\n(.)/\n * $1/g;
    print OUT "/* $_ */\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;
   
    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(XXX,\l${class}${2}Class,\"$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
	local($tmp) = $cVar[$_];
	$cVar[$_] = $fromTcl;
	return "    /* no need to assign  << $tmp = $fromTcl >>  */ \n\n";
    }

    if ($conv) {
        if ($conv =~ /^%/) {
	    $convCode = "sscanf($fromTcl, \"$conv\", &$cVar)";
	} else {
	    $convCode = ($conv =~ s/XXX/$fromTcl/) ?
		"$cVar = $cast $conv" :
                "$cVar = $cast $conv($fromTcl)";
	    $postCode .= "     $stringToGarbage{$type}($cVar);\n" 
		if $stringToGarbage{$type};
#	    print STDERR "adding automatically <$stringToGarbage{$type}($cVar)>\n"
#		if $stringToGarbage{$type};
	}
	return $pre.<<"cConversion";
$t if (!($convCode))
$t      {
$t      wafeConvError(argv[0],"$_",$fromTcl,"$origType");
$t      DBUG_RETURN (TCL_ERROR);
$t      }

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


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

    foreach (split(/,\s*/,$Structure{$type})) {
	next if /^\*/;
	($compType,$compName) = ($1,$2) if /\((.*)\)\s*(.*)/;
        $cmds .= "         if (!(charp="
	    ."Tcl_GetVar2(wafeInterpreter,$fromTcl,\"$compName\", 0)))\n"
	    ."               {\n               "
	    ."wafeNoVarCompError(\"$tclName\",$fromTcl,\"$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 ("",$cVar) if $toString{$type} eq "%s";

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


sub conversionFromStructure {
    local($cVar,$type,$name,$data, $target) = @_;
    local($cmds);
    
    $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,"");
	$cmds .= "     $convCode\n"
	    ."     Tcl_SetVar2(wafeInterpreter,"
		               .($target||$name)
			       .",\"$compName\", $convData,0);\n";
    }
    
    return ($cmds,$target ? "" : $data);
}


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

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

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

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


sub castedType {
    local($_) = @_;
    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";
	    print OUT "${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);
	    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 generateCallback {
    local($bools,$includes,$cascade,%Quark,$quarks,$quarkInit,%cbNeeded,
	  $reason);
    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;
        $Quark{$callbackName} = 1;
	if ($toString{$toType}) {
	    ($conv,$post) = 
		($toString{$toType} !~ /^%/) ?
		    (($toString{$toType} =~ /^(.*)\-2$/) ?
			("$1(output,$reference);","")
			:
		        ("char *p = (char *)$toString{$toType}($reference);strcpy(output,p);",
		        "XtFree(p);\n                    " ) 
		    ) :
		    ("sprintf(output, \"$toString{$toType}\", $reference);","");
	};

	$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 {
	    $selector = "attrib == q$callbackName";
	}

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

#    foreach(sort grep($callbackClass{$_},keys %callbackClass)){ 
#	local($name,$typeName) = split(/$;/);
#	$bools .= "#ifdef $callbackClass{$_}\n"
#	    ."     Boolean is${name}Widget = (XtClass(w) == $typeName);"
#	    ."\n#endif\n"
#		if $name !~ /Shell/ && $cbNeeded{$name};
#    }

    foreach(keys %Quark) {
	$quarks .= "XrmQuark q$_;\n";
	$quarkInit .= "     q$_ = WafePermStringToQuark(\"$_\");\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";
    }

    foreach(sort grep($freeFunc{$_}, keys %freeFunc)) {
	local($package,$att) = split(/$;/);
        $GFF .= 
	    "#ifdef $package\n     "
	   ."{extern XrmQuark $att;\n     "
           ."if (attribute == $att)\n          "
           ."return (freeProc)$freeFunc{$_};\n     "
           ."}\n"
           ."#endif\n";
	$extFreeFuncs .= 
	    "#ifdef $package\n"
	   ."void $freeFunc{$_}();\n"
           ."#endif\n"
	       unless $freeFunc{$_} =~ /^X[tm]/ || 
		      $freeFunc{$_} eq "NULL"; 
    } 

    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

$extFreeFuncs

$quarks

void
wafeCallbackQuarkInitialize()
     {
$quarkInit     }



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


freeProc
wafeGetFreeProc(attribute)
XrmQuark attribute;
     {
$GFF
     return XtFree;
     }


void
wafeExecCallbackProc(w, clientData, callData)
Widget     w;
XtPointer  clientData, callData;
     {
     char     command[MESSAGE_COMMAND_LENGTH];       
     XrmQuark attrib = *(XrmQuark *) clientData;
     char    *input = ((char *)clientData + sizeof(XrmQuark));
     char    *output = command;
     WidgetClass wClass = XtClass(w);

$bools

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

     while (*input != '\\0')
          {
          if (*input == '%')
               {
               char chi = *++input;
               if (chi == 'w')
                    {
#ifndef PRER6
		    strcpy(output, XtName(
                        (strcmp(wClass->core_class.class_name,"Hook")) ?
			w : ((XtDestroyHookDataRec *)callData)->widget));
#else
		    strcpy(output, XtName(w));
#endif
                    output += strlen(output);
                    }
	       else
               if (chi == 'W')
                    {
#ifndef PRER6
                    sprintf(output, "%ld", (long)
                        (strcmp(wClass->core_class.class_name,"Hook")) ?
			    w : ((XtDestroyHookDataRec *)callData)->widget);
#else
                    sprintf(output, "%ld", (long)w);
#endif
                    output += strlen(output);
                    }

$cascade

#ifndef PRER6
               else 
	       if (chi == 't' &&  
                   (!strcmp(wClass->core_class.class_name,"Hook"))
		  )
                    {
		    strcpy(output, ((XtDestroyHookDataRec *)callData)->type);
                    output += strlen(output);
		    }
#endif
               else
		    {
                    *output = '%';
                    output++;
                    input--;
	            }
               }
          else 
               {
               *output = *input;
               output++;
               }
          input++;
          }

     *output = '\\0';
     (void)wafeEval(wafeInterpreter, command, "execCallbackProc");
     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 %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 %freeFunc) {
	print CB "\$freeFunc{'$_'} = '$freeFunc{$_}';\n" if $freeFunc{$_};
    }
    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 %freeFunc) {
	undef $freeFunc{$_} 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 quarkName {
    local($_) = @_;
    return "q$1" if m/^\"(.*)\"$/;
    return "q$1" if m/^XtR(.*)$/;
    return "q$_";
}

sub quarkInitCmd {
    local($_) = @_;
    local($quark) = &quarkName($_);
    return " $quark = WafePermStringToQuark(\"$_\");\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($_) = @_;
    return "$1" if /\((.*)\)/;
    return "String" if /XrmQuark/;
    $_;
}
#
#
#  ---------------------- 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";

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


&printComment(<<"Copyright");
Copyright (C) 1992 by Gustaf Neumann, Stefan Nusser

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

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

$creationNote

Copyright

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

foreach(split(/\s*\n\n+/,$file)) {
        if (/^(#include|#ifdef|#define|#ifndef|#endif|extern)/) {
	    print OUT "$_\n\n";
	    next;
	}
        if (/^%/ || /^@/ || /^\$/) {
	    eval $_;
	    die "ERROR: $@" if $@;
	    print OUT 
                 "#define ${PACKAGE}_C\n"
		."#include <wafe.h>\n"
		."#ifdef $PACKAGE\n\n" 
		if /^\$PACKAGE/;
	    &loadAndClearCallbackSpec();
            unlink "tcllib/bc/$PACKAGE.tcl" if -r "tcllib/bc/$PACKAGE.tcl";
	    next;
	}
        next if /^#/;
        next unless (@items = split(/[ \t]*\n[ \t]*/));

	$openIFDEFS = $closeIFDEFS = $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",
		   next if /\bR5\|XAW3D\b/;
		$openIFDEFS .= "#ifndef PRER5\n", $closeIFDEFS .= "\n#endif",
		   next if /\bR5\b/;
		$openIFDEFS .= "#ifndef $1\n", $closeIFDEFS .= "\n#endif",
		   next if /\!\s*(\S+)\b$/;
		$openIFDEFS .= "#ifdef $_\n", $closeIFDEFS .="\n#endif";
	    }
	    shift(@items);
	} 

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

        if ($returnType eq "~handles") {
	    foreach($name,@args) {
		$ICMD .= "#ifdef $_\n "
		  ."Tcl_SetVar(wafeInterpreter,\"PACKAGES\",\"$_\","
                  ."TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);"
                  ."\n#endif\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*$/) {
		    $ICMD .= &quarkInitCmd($1);
		} elsif (/^pseudoAttrib\s*(\S+)\s+(\S+)\s*$/) {
		    local($attrib,$freeProc) = ($1,$2);
		    local($quark) = &quarkName($attrib);
		    print OUT " XrmQuark $quark;\n";
		    $ICMD .= &quarkInitCmd($attrib);
		    $freeProc = "NULL" if $freeProc =~ /[Nn]one/;
		    $freeFunc{"$PACKAGE$;$quark"} = $freeProc unless 
			$cnvFree eq "XtFree";
		} elsif (/^conv\S*\s+(\S+.*)$/) {
		    local($from,$to,$cnvCache,$cnvCall,$cnvFree,$cnvOpt) = 
			    split(/\s+/,$1);
	            local($toQuark) = &quarkName($to);
                    $freeFunc{"$PACKAGE$;$toQuark"} = $cnvFree unless 
			    $to eq "XtRString" ||
			    $cnvFree =~ /[Nn]one/;
		    if ($cnvOpt) {
			local($v,$t,$c) = (split(/-/,$cnvOpt),1);
			$ICMD .= $openIFDEFS
			        ." { static XtConvertArgRec argRec = \n"
				."\t{XtImmediate,(XtPointer)$v,sizeof($t)};\n"
			        ."\n XtSetTypeConverter($from, $to,\n"
			        ."\t(XtTypeConverter)$cnvCall, \n"
				."\t&argRec, $c, XtCache$cnvCache, NULL);\n }"
				."$closeIFDEFS\n";
		    } else {
			$ICMD .= $openIFDEFS
			        ." XtSetTypeConverter($from, $to,\n"
			        ."\t(XtTypeConverter)$cnvCall, \n"
				."\tNULL, 0, XtCache$cnvCache, NULL);"
				."$closeIFDEFS\n";
		    }
		}
	    }
	    &printComment("\n******* begin required file <$name> *******\n");
	    print OUT "$req\n";
	    &printComment("\n******* end required file <$name> *******\n");
	    next;

	} elsif ($returnType eq "~alias") {
	    foreach($name,@args) {
		if (/^\s*(\S+)\s*(\S+)$/) {
#		    local($tclName,$XtName) = &tclName($2);
		    $ICMD .= " /* alias */  Tcl_CreateCommand(wafeInterpreter,\"$1\","
			    ."cmd_$2, NULL,NULL);\n";
		    &doc("\\alias{$1}{$XtName}");
		}
	    }
	    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);
	    &doc("\\widget{$tclName}{}{$classType}");
            local($createCmd,$createsShell) = 
		&widgetClassOptions($XtName,$className,@args);
#	    local($createTxt) = $createCmd eq "NULL" ? 
#		"XtCreateManagedWidget" : $createCmd;
	    $createsShell = 'False' unless $createsShell;
            $CWC .= 
		$openIFDEFS
               ." wafeCreateWidgetCommand(\"$XtName\",$className,$createCmd"
	       .",$createsShell);"
               ."$closeIFDEFS\n";
            $CWCU .= " wafeCreateWidgetCommand(\"$XtName\",NULL,NULL,False);\n" 
		if $generateWarnings;
	    next;
        } elsif ($returnType eq "~pseudoWidgetClass") {
            local($createCmd,$className,$createsShell) = 
		&pseudoWidgetClassOptions($XtName,@args);
	    $createsShell = 'False' unless $createsShell;
	    local($tn,$xn) = &tclName($className);
	    &doc("\\pseudoWidget{$tclName}{$createCmd}{$tn}");
	    $className = &className($className,'Widget');
            $CWC .= 
		$openIFDEFS
	       ." wafeCreateWidgetCommand(\"$tclName\",$className,$createCmd"
               .",$createsShell);"
	       ."$closeIFDEFS\n";
            $CWCU .= "wafeCreateWidgetCommand(\"$tclName\",NULL,NULL,False);\n" 
		if $generateWarnings;
	    next;
	} elsif ($returnType eq "~alias") {
	    foreach($name,@args) {
		if (/^\s*(\S+)\s*(\S+)$/) {
#		    local($tclName,$XtName) = &tclName($2);
		    $ICMD .= " /* alias */  Tcl_CreateCommand(wafeInterpreter,\"$1\","
			    ."cmd_$2, NULL,NULL);\n";
		    &doc("\\alias{$1}{$XtName}");
		}
	    }
	    next;
	}

	&printComment( "\n$_\n");

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

	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;
        &doc("\\function{$usTclName}{$usXtName}{$functionComment}"
	    ."{".&docReturnValue($returnType)."}");
	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) ;

	    ($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++;
	}

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

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

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

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

	$ICMD .= 
	    $openIFDEFS
	    . " Tcl_CreateCommand(wafeInterpreter, \"$tclName\", cmd_$tclName, NULL, NULL);"
	    . "$closeIFDEFS\n";

	print OUT <<"cHeader";
$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) 
	 {
	 wafeArgcError(argv[0],"$quant",$tclArgs,argc);
	 DBUG_RETURN (TCL_ERROR);
         }

cHeader

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

		if ($type[$_] !~ /^args/) {
		    print OUT 
			"     {    $type[$_] *ptr;\n          argv += $arg;\n"
		       ."          $cVar[$_] = ptr =\n             "
		       ."($type[$_] *)XtMalloc((argc-$arg)*sizeof($type[$_]));\n\n"
		       ."          while (*argv)\n             {\n";
#		    print OUT &inConversion("*argv","*ptr","($typeDecl[$_])",
		    print OUT &inConversion("*argv","*ptr","",
					    $type[$_],$arg,3,1);
		    print OUT "          ptr ++; argv++;\n          }\n     }\n";
		} else {
		    print OUT "     argc -= $arg;\n";
		    if ($type[$_] =~ /^args\s+avp/) {
			print OUT 
			    "     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"
			   ."        wafeArgcError(argv[0],\"even number of arguments such as 2 or \",4,argc+1);\n"
                           ."        if (freeArgv) XtFree((char*)argvArg);\n" 
                           ."        DBUG_RETURN (TCL_ERROR);\n" 
			   ."        }\n\n";

			$postCode .= "     if (freeArgv) XtFree((char *)argvArg);\n";
			$cVar[$_] = "argc,argvArg";
		    } else {
			$cVar[$_] = "argc,&argv[$argc]";
		    }
		}
	    } else {
		print OUT &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 ++;
	     print OUT 
		 "$preCode     "
		."for (count = $argBreak; count < argc; count++)\n"
		."          {\n";
	     for ($argBreak .. $#args) {
		 print OUT 
                     &inConversion("argv[count]",
                                   $cVar[$_],
                                   "($typeDecl[$_])",$type[$_],"count",2,1);
	     }
	     print OUT 
		 "         $cCall(",join(",",@realArgs),");\n"
	        ."          }\n$postCode";
	 } else {
	     print OUT 
		 "$preCode     "
		."$cCall(",join(",",@realArgs),");\n$postCode";
	 }

         if ($array[$#array] && $type[$#array] !~ /^args/ ) {
	     local($nthLocalVar) = ($#array-$nrConstBeforeArray);
	     if ($nthLocalVar>1) {
		 print OUT "     wafeMMreplace(wafeMMgetAttribList(localVar1,True),"
		         ."WafePermStringToQuark(\"$tclName\"),"
			 ."(char*)localVar$nthLocalVar,XtFree);\n";
             } else {
		 print OUT "     XtFree((char *)localVar1);\n";
	     }
	 }

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

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

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


         print OUT <<"cFooter";

     DBUG_RETURN (TCL_OK);
     }     
$closeIFDEFS

cFooter

}


#
# generate initialization code

print OUT 
    "#else\n"    # of ifdef $PACKAGE
#    . "#include <string.h>\n" 
#    . "#include \"wafe.h\"\n" 
    . "#endif\n\n" # of ifdef $PACKAGE
    . "void\nwafeInitialize_$stem()\n{\n"
    . "#ifdef $PACKAGE\n"
    .$CWC
    .$ICMD
    . "\n#else\n"
    .$CWCU
    . "#endif\n"
    ."}\n";


&generateCallback();

close DEFS;
close OUT;
close DOC;





