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

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(INPUT,\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";
    }

    local($convCode) = $stringToStore{$type};
    if ($conv || $convCode) {
        if ($conv =~ /^%/) {
	    $convCode = "sscanf($fromTcl, \"$conv\", &$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 (/\./) {
	    
	    return $pre.<<"cConversion";
$t if (!($convCode))
$t     {
$t     wafeConvError(argc, argv, $`,"$'" ,"$origType");
$t     DBUG_RETURN (TCL_ERROR);
$t     }

cConversion

	} else {
	    return $pre.<<"cConversion";
$t if (!($convCode))
$t     {
$t     wafeConvError(argc, argv, $_ ,NULL, "$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(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} !~ /^%/;
	return ("sprintf(conversionBuffer, \"$toString{$type}\", $cVar);\n","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 ("", $expression) 
	    if ($expression = $toStringStaticExpression{$type}) =~ 
		s/EXPRESSION/$cVar/;
	return (join("\n     else ", &cascadeToString($cVar,$type))."\n\n", 
			"staticResultString");
    }
}


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,"");
	$localVarNeeded{$convData} = 1;
	$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(argc,argv, $_,NULL, \"$type\");\n"
                             ."$t     DBUG_RETURN (TCL_ERROR);\n$t    }\n");
    @return;
}

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

    for ($i=$[; $i < $#typeDef; $i += 2) {
	$fromValue = $typeDef[$i+1];
	next if $done{$fromValue};
	push(@return, "if ($cVar == ".$fromValue.") \n"
	     . "         staticResultString = \"$typeDef[$i]\";");
#	     . "         strcpy(conversionBuffer, \"$typeDef[$i]\");");
	$done{$fromValue}++;
    }
    @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,%quarkPackage,%isGlobalQuark);

    foreach (keys %globalQuark) {
	($quarkPackage{$1},$isGlobalQuark{$2}) = (1,1) if /^(.*)$;(.*)$/;
    }
    foreach $p (keys %quarkPackage) {
	$quarks .= "#ifdef $p\n" unless $p eq 'XT';
        foreach (keys %isGlobalQuark) { 
	    $quarks .= "CB_EXTERN XrmQuark q$_;\n" if $globalQuark{"$p$;$_"};
	}
	$quarks .= "#endif\n"  unless $p eq 'XT';
	$quarks .= "\n";
    }
    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";

    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/output/;
		$conv =~ s/INPUT/$reference/;
	    } elsif ($toString{$toType} =~ /^%/) {
		$conv = "sprintf(output, \"$toString{$toType}\", $reference);";
	    } else {
		$conv = "char *p = (char *)$toString{$toType}($reference);"
  		       ."strcpy(output,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 {
	    $Quark{$callbackName} = 1 unless $isGlobalQuark{$callbackName};
	    $selector = "attrib == q$callbackName";
	}

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

    foreach(keys %Quark) {
	$quarks .= "static 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";
    }

    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

$quarks

void
wafeCallbackQuarkInitialize()
     {
$quarkInit     }



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

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

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

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

     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
                    }
	       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
                    }
               else
               if (!callData)
		    {
                    *output++ = '%';
                    if (chi != '%') 
			input--;
		    *output = '\\0';
	            }
$cascade
#ifndef PRER6
               else 
	       if (chi == 't' &&  
                   (!strcmp(wClass->core_class.class_name,"Hook"))
		  )
                    {
		    strcpy(output, ((XtDestroyHookDataRec *)callData)->type);
		    }
#endif
#ifdef MOTIF
	       else
	       if (chi == '=') 
	            {
		    wafeActionPercentcode(*++input,&output,wafeCurrentEvent,w);
		    }
#endif
               else
		    {
                    *output++ = '%';
                    if (chi != '%') 
			input--;
		    *output = '\\0';
	            }
	       output += strlen(output);
               }
          else 
               {
               *output++ = *input;
               }
          input++;
          }

     *output = '\\0';
     (void)wafeEval(wafeInterpreter, command, "execCallbackProc");

#ifdef MOTIF
     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 %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 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($_) = @_;
    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";

$[=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"
                ."typedef int TCL_RETURN_CODE;\n"
		."#ifdef $PACKAGE\n\n" 
		if /^\$PACKAGE/;
	    &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 = $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 .= "#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) {
		$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*$/) {
		    local($attrib) = $1;
		    local($quark)  = &quarkName($attrib);
		    $globalQuark{"$PACKAGE$;$attrib"} = 1;
		    print OUT " extern XrmQuark $quark;\n";
		    $ICMD .= &quarkInitCmd($attrib);
		} elsif (/^privateQuark\s*(\S+)\s*$/) {
		    local($attrib) = $1;
		    local($quark)  = &quarkName($attrib);
		    print OUT " static XrmQuark $quark;\n";
		    $ICMD .= &quarkInitCmd($attrib);
		} elsif (/^conv\S*\s+(\S+.*)$/) {
		    local($from,$to,$cnvCache,$cnvCall) = split(/\s+/,$1);
	            local($toQuark) = &quarkName($to);
		    $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 "\n$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}{$2}");
		    &help($1,"alias",$2);
		}
	    }
	    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}");
	    &help($tclName,"creationCommand",$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}");
	    &help($tclName,"creationCommand",$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+)$/) {
		    $ICMD .= " /* alias */  Tcl_CreateCommand(wafeInterpreter,\"$1\","
			    ."cmd_$2, NULL,NULL);\n";
		    &doc("\\alias{$1}{$XtName}");
		    &help($tclName,"alias",$XtName);
		}
	    }
	    next;
	}

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

	$localVars = $body = $preCode = $postCode = $endCode = $freeProc = "";
        $repeatCall = $nrArgs = 0;
	@cVars = @inOut = @type = @inFunction = @toRemove = 
	    @prototypes = @array = ();
	%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) ;

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

	# 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;

	$ICMD .= 
	    $openIFDEFS
	    . " Tcl_CreateCommand(wafeInterpreter, \"$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"
			   ."        wafeArgcError(argc+$arg, argv,\"even number of attribute value pairs such as 2 or \",4);\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 {
		$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(wafeMMgetAttribList(localVar1,True),"
		         ."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;
            $body .= "\n     $convCode\n";
	    $body .=  "     Tcl_SetVar(wafeInterpreter, argv[$_], $convData, 0);\n"
		if $convData;
        }

	if ($returnType !~ /[Vv]oid/) {
#    print STDERR " toStringG($returnType):    $toStringGarbage{$returnType};\n";
	    $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'};

         local($cArgNum) = $argNum-1;
	 print OUT <<"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) 
	 {
	 wafeArgcError(argc,argv,"$quant",$cArgNum);
	 DBUG_RETURN (TCL_ERROR);
         }

$body
     DBUG_RETURN ($tcl_return);
     }     
$closeIFDEFS

cProc

}


#
# 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;
close HELP;




