added GetBaseClassName1 and 2 for memory.cpp compiles

[wxWidgets.git] / wxPython / wxSWIG / Modules / tcl8.cxx

/*******************************************************************************
 * Simplified Wrapper and Interface Generator  (SWIG)
 * 
 * Author : David Beazley
 *
 * Department of Computer Science        
 * University of Chicago
 * 1100 E 58th Street
 * Chicago, IL  60637
 * beazley@cs.uchicago.edu
 *
 * Please read the file LICENSE for the copyright and terms by which SWIG
 * can be used and distributed.
 *******************************************************************************/

/***********************************************************************
 * $Header$
 *
 * tcl8.cxx
 *
 * Module for creating Tcl 8.0 native wrapper functions.  Older SWIG
 * modules will work with Tcl 8.0, but this one provides a significant
 * boost in performance.
 ***********************************************************************/

#include "swig.h"
#include "tcl8.h"
#include <ctype.h>

static char *Tcl_config="swigtcl.swg";
static char *usage = "\
Tcl 8.0 Options (available with -tcl)\n\
     -module name    - Set name of module\n\
     -prefix name    - Set a prefix to be appended to all names\n\
     -namespace      - Build module into a Tcl 8 namespace. \n\
     -noobject       - Omit code for object oriented interface.\n\
     -old            - Use old SWIG interface (same as -noobject).\n\n";

static char *ns_name = 0;

static String mod_init;
static String mod_extern;

// ---------------------------------------------------------------------
// TCL8::parse_args(int argc, char *argv[])
//
// Parse tcl specific command line options
// ---------------------------------------------------------------------

void TCL8::parse_args(int argc, char *argv[]) {
  
  int i = 1;
  sprintf(LibDir,"%s",tcl_path);

  // Look for certain command line options

  for (i = 1; i < argc; i++) {
      if (argv[i]) {
	  if (strcmp(argv[i],"-prefix") == 0) {
	    if (argv[i+1]) {
	      prefix = new char[strlen(argv[i+1])+2];
	      strcpy(prefix, argv[i+1]);
	      mark_arg(i);
	      mark_arg(i+1);
	      i++;
	    } else {
	      arg_error();
	    }
	  } else if (strcmp(argv[i],"-module") == 0) {
	    if (argv[i+1]) {
	      set_module(argv[i+1],0);
	      mark_arg(i);
	      mark_arg(i+1);
	      i++;
	    } else {
	      arg_error();
	    }
	  } else if (strcmp(argv[i],"-namespace") == 0) {
	    nspace = 1;
	    mark_arg(i);
	  } else if (strcmp(argv[i],"-old") == 0) {
	    shadow = 0;
	    mark_arg(i);
          } else if (strcmp(argv[i],"-noobject") == 0) {
	    shadow = 0;
	    mark_arg(i);
	  } else if (strcmp(argv[i],"-help") == 0) {
	    fputs(usage,stderr);
	  }
      }
  }

  // If a package has been specified, make sure it ends with a '_'

  if (prefix) {
    ns_name = copy_string(prefix);
    if (prefix[strlen(prefix)] != '_') {
      prefix[strlen(prefix)+1] = 0;
      prefix[strlen(prefix)] = '_';
    }
  } else 
    prefix = "";

  // Create a symbol SWIGTCL

  add_symbol("SWIGTCL",0,0);
  add_symbol("SWIGTCL8",0,0);

  // Set name of typemaps

  typemap_lang = "tcl8";

  // Attempt to load up the C++ configuration files

  get_file("delcmd8.swg",delcmd);
  get_file("methodcmd8.swg",methodcmd);
  get_file("objcmd8.swg",objcmd);

}

// ---------------------------------------------------------------------
// void TCL8::parse()
//
// Start parsing an interface file for Tcl.
// ---------------------------------------------------------------------

void TCL8::parse() {

  fprintf(stderr,"Making wrappers for Tcl 8.x\n");

  // Print out TCL specific headers
  
  headers();
  
  // Run the parser
  
  yyparse();

}

// ---------------------------------------------------------------------
// TCL8::set_module(char *mod_name,char **mod_list)
//
// Sets the module name.
// Does nothing if it's already set (so it can be overridden as a command
// line option).
//
// mod_list is a NULL-terminated list of additional modules.  This
// is really only useful when building static executables and other
// things.
//----------------------------------------------------------------------

void TCL8::set_module(char *mod_name, char **mod_list) {

  char temp[256], *c;
  int  i;

  if (module) return;
  
  module = new char[strlen(mod_name)+1];
  strcpy(module,mod_name);

  // Fix capitalization for Tcl 

  c = module;
  while (*c) {
    *c = (char) tolower(*c);
    c++;
  }

  // Now create an initialization function

  sprintf(temp,"%s_Init", module);
  init_name = new char[strlen(temp) + 1];
  strcpy(init_name, temp);
  *init_name = toupper(*init_name);

  if (!ns_name) ns_name = copy_string(module);

  // If namespaces have been specified, set the prefix to the module name

  if ((nspace) && (strlen(prefix) < 1)) {
    prefix = new char[strlen(module)+2];
    strcpy(prefix,module);
    prefix[strlen(module)] = '_';
    prefix[strlen(module)+1] = 0;
  }

  // If additional modules have been specified, create some code for
  // initializing them.

  if (mod_list) {
    i = 0;
    while (mod_list[i]) {
      c = mod_list[i];
      while (*c) {
	*c = (char) tolower(*c);
	c++;
      }
      sprintf(temp,"%s_Init",mod_list[i]);
      temp[0] = toupper(temp[0]);
      
      // Dump out some initialization code
      
      mod_init << tab4 << "if (" << temp << "(" << interp_name << ") == TCL_ERROR) {\n"
	       << tab8 << "return TCL_ERROR;\n"
	       << tab4 << "}\n\n";
      mod_extern << "extern int " << temp << "(Tcl_Interp *);\n";
      i++;
    }
  }
}


// ---------------------------------------------------------------------
// TCL8::set_init(char *iname)
//
// Sets the initialization function name.
// Does nothing if it's already set
//
//----------------------------------------------------------------------

void TCL8::set_init(char *iname) {

  if (init_name) return;
  init_name = new char[strlen(iname)+1];
  strcpy(init_name, iname);

}

// ---------------------------------------------------------------------
// TCL8::headers(void)
//
// Generate the appropriate header files for TCL interface.
// ----------------------------------------------------------------------

void TCL8::headers(void)
{

  emit_banner(f_header);
  fprintf(f_header,"/* Implementation : TCL 8.0 */\n\n");
  fprintf(f_header,"#include <tcl.h>\n");
  fprintf(f_header,"#include <string.h>\n");
  fprintf(f_header,"#include <stdlib.h>\n");
  fprintf(f_header,"#define SWIGTCL\n");
  fprintf(f_header,"#define SWIGTCL8\n");
  
  // Include a Tcl configuration file for Unix,Mac,Wintel.

  if (NoInclude) {
    fprintf(f_header,"#define SWIG_NOINCLUDE\n");
  }

  if (insert_file("swigtcl8.swg",f_header) == -1) {
    fprintf(stderr,"SWIG : Fatal error. Unable to locate 'swigtcl8.swg' in SWIG library.\n");
    SWIG_exit(1);
  }
}

// --------------------------------------------------------------------
// TCL8::initialize(void)
//
// Produces an initialization function.   Assumes that the init function
// name has already been specified.
// ---------------------------------------------------------------------

void TCL8::initialize() 
{

  if ((!ns_name) && (nspace)) {
    fprintf(stderr,"Tcl error.   Must specify a namespace.\n");
    SWIG_exit(1);
  }

  if (!init_name) {
    init_name = "Swig_Init";
    fprintf(stderr,"SWIG : *** Warning. No module name specified.\n");
  }

  fprintf(f_header,"#define SWIG_init    %s\n", init_name);
  if (!module) module = "swig";
  fprintf(f_header,"#define SWIG_name    \"%s\"\n", module);
  if (nspace) {
    fprintf(f_header,"#define SWIG_prefix  \"%s::\"\n", ns_name);
    fprintf(f_header,"#define SWIG_namespace \"%s\"\n\n", ns_name);
  } else {
    fprintf(f_header,"#define SWIG_prefix  \"%s\"\n", prefix);
    fprintf(f_header,"#define SWIG_namespace \"\"\n\n");
  }
  fprintf(f_header,"#ifdef __cplusplus\n");
  fprintf(f_header,"extern \"C\" {\n");
  fprintf(f_header,"#endif\n");
  fprintf(f_header,"#ifdef MAC_TCL\n");
  fprintf(f_header,"#pragma export on\n");
  fprintf(f_header,"#endif\n");
  fprintf(f_header,"SWIGEXPORT(int) %s(Tcl_Interp *);\n", init_name);
  fprintf(f_header,"#ifdef MAC_TCL\n");
  fprintf(f_header,"#pragma export off\n");
  fprintf(f_header,"#endif\n");
  fprintf(f_header,"#ifdef __cplusplus\n");
  fprintf(f_header,"}\n");
  fprintf(f_header,"#endif\n");
  

  fprintf(f_init,"SWIGEXPORT(int) %s(Tcl_Interp *%s) {\n", init_name, interp_name);
  if (nspace) {
    fprintf(f_init,"#ifdef ITCL_NAMESPACES\n");
    fprintf(f_init,"\t Itcl_Namespace spaceId;\n");
    fprintf(f_init,"#endif\n");
  }
  
  fprintf(f_init,"\t if (%s == 0) \n", interp_name);
  fprintf(f_init,"\t\t return TCL_ERROR;\n");

  /* Set up SwigPtrType table */

  fprintf(f_init,"\t SWIG_RegisterType();\n");

  /* Check to see if other initializations need to be performed */

  if (strlen(mod_extern.get())) {
    fprintf(f_init,"%s\n",mod_init.get());
    fprintf(f_header,"#ifdef __cplusplus\n");
    fprintf(f_header,"extern \"C\" {\n");
    fprintf(f_header,"#endif\n");
    fprintf(f_header,"%s\n",mod_extern.get());
    fprintf(f_header,"#ifdef __cplusplus\n");
    fprintf(f_header,"}\n");
    fprintf(f_header,"#endif\n");
  }


  /* Check to see if we're adding support for Tcl8 nspaces */
  if (nspace) {
    fprintf(f_init,"#if (TCL_MAJOR_VERSION >= 8)\n");
    fprintf(f_init,"\t Tcl_Eval(%s,\"namespace eval %s { }\");\n", interp_name, ns_name);
    fprintf(f_init,"#endif\n");
  }
}

// ---------------------------------------------------------------------
// TCL8::close(void)
//
// Wrap things up.  Close initialization function.
// ---------------------------------------------------------------------

void TCL8::close(void)
{

  // Dump the pointer equivalency table

  emit_ptr_equivalence(f_init);

  // Close the init file and quit

  fprintf(f_init,"%s",postinit.get());
  fprintf(f_init,"\t return TCL_OK;\n");
  fprintf(f_init,"}\n");

}

// ----------------------------------------------------------------------
// TCL8::get_pointer(char *iname, char *srcname, char *src, char *dest,
//                  DataType *t, String &f, char *ret)
//
// iname     = name of function or variable
// srcname   = name of source
// src       = source variable in wrapper code
// dest      = destination variable in wrapper code
// t         = Datatype 
// f         = String where output is going to go
// ret       = Return action
// ----------------------------------------------------------------------

void TCL8::get_pointer(char *iname, char *srcname, char *src, char *dest,
		      DataType *t, String &f, char *ret) {

  // Pointers are read as hex-strings with encoded type information
  
  f << tab4 << "if ((rettype = SWIG_GetPointerObj(interp," << src << ",(void **) &" << dest << ",";

  if (t->type == T_VOID) f << "(char *) 0))) {\n";
  else 
    f << "\"" << t->print_mangle() << "\"))) {\n";

  // Now emit code according to the level of strictness desired

  switch(TypeStrict) {
  case 0: // No type checking
    f << tab4 << "}\n";
    break;
  case 1: // Warning message only
    f << tab8 << "fprintf(stderr,\"Warning : type mismatch in " << srcname 
      << " of " << iname << ". Expected " << t->print_mangle() 
      << ", received %s\\n\", rettype);\n"
      << tab4 << "}\n";
  case 2: // Super strict mode.
    f << tab8 << "Tcl_SetStringObj(tcl_result, \"Type error in " << srcname << " of " << iname
      << ". Expected " << t->print_mangle() << ", received \", -1);\n"
      << tab8 << "Tcl_AppendToObj(tcl_result, rettype, -1);\n"
      << tab8 << ret << ";\n"
      << tab4 << "}\n";
    break;
  default :
    fprintf(stderr,"Unknown strictness level\n");
    break;
  }
}


// ----------------------------------------------------------------------
// TCL8::create_command(char *cname, char *iname)
//
// Creates a Tcl command from a C function.
// ----------------------------------------------------------------------

void TCL8::create_command(char *cname, char *iname) {

  char *wname = name_wrapper(cname,prefix);

  fprintf(f_init,"\t Tcl_CreateObjCommand(%s, SWIG_prefix \"%s\",%s, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);\n", interp_name, iname, wname);

  // Add interpreter name to repeatcmd hash table.  This hash is used in C++ code
  // generation to try and find repeated wrapper functions.

  repeatcmd.add(iname,copy_string(wname));
}

// ----------------------------------------------------------------------
// TCL8::create_function(char *name, char *iname, DataType *d, ParmList *l)
//
// Create a function declaration and register it with the interpreter.
// ----------------------------------------------------------------------

void TCL8::create_function(char *name, char *iname, DataType *d, ParmList *l)
{
  Parm            *p;
  int              pcount,i,j;
  char            *wname;
  char            *usage = 0, *tm;
  char             source[64];
  char             target[64];
  char             argnum[32];
  WrapperFunction  f;
  String           cleanup, outarg, build;
  int              numopt= 0;
  int              have_build = 0;

  // Make a wrapper name for this function

  wname = name_wrapper(iname,prefix);

  // Now write the wrapper function itself....this is pretty ugly

  f.def << "static int " << wname << "(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {\n";

  f.code << tab4 << "clientData = clientData; objv = objv;\n";

  // Print out variables for storing arguments.

  pcount = emit_args(d, l, f);
  numopt = l->numopt();

  // Create a local variable for holding the interpreter result value

  f.add_local("Tcl_Obj *", "tcl_result");

  // Extract the tcl result object

  f.code << tab4 << "tcl_result = Tcl_GetObjResult(interp);\n";

  // Check the number of arguments

  usage = usage_func(iname,d,l);       // Create a usage string
  f.code << tab4 << "if ((objc < " << (pcount-numopt) +1 << ") || (objc > " << l->numarg()+1 << ")) {\n"
	 << tab8 << "Tcl_SetStringObj(tcl_result,\"Wrong # args. " << usage << "\",-1);\n"
	 << tab8 << "return TCL_ERROR;\n"
	 << tab4 << "}\n";

  // Extract parameters.    This case statement should be used to extract
  // Function parameters.   Add more cases if you want to do more.

  i = 0;
  j = 0;
  p = l->get_first();
  while (p != 0) {
    // Produce string representations of the source and target arguments
    sprintf(source,"objv[%d]",j+1);
    sprintf(target,"_arg%d",i);
    sprintf(argnum,"%d",j+1);

    // See if this argument is being ignored
    
    if (!p->ignore) {
      if (j >= (pcount-numopt)) 
	f.code << tab4 << "if (objc >" << j+1 << ") { \n";

      if ((tm = typemap_lookup("in","tcl8",p->t,p->name,source,target,&f))) {
	// Yep.  Use it instead of the default
	f.code << tm << "\n";
	f.code.replace("$argnum",argnum);
	f.code.replace("$arg",source);
      } else {
	if (!p->t->is_pointer) {
	
	  // Extract a parameter by value.
	
	  switch(p->t->type) {
	    
	    // Signed Integers
	  
	  case T_BOOL:
	  case T_INT:
	  case T_SINT:
	  case T_SHORT:
	  case T_SSHORT:
	  case T_LONG:
	  case T_SLONG:
	  case T_SCHAR:
	    
	    // Unsigned integers
	  
	  case T_UINT:
	  case T_USHORT:
	  case T_ULONG:
	  case T_UCHAR:
	    f.add_local("int","tempint");
	    f.code << tab4 << "if (Tcl_GetIntFromObj(interp,objv[" << j+1 << "],&tempint) == TCL_ERROR) return TCL_ERROR;\n";
	    f.code << tab4 << "_arg" << i << " = " << p->t->print_cast() << " tempint;\n";
	  break;
	  
	  // Floating point

	  case T_FLOAT:
	  case T_DOUBLE:
	    f.add_local("double","tempdouble");
	    f.add_local("Tcl_Obj *", "dupobj");
	    f.code << tab4 << "dupobj = Tcl_DuplicateObj(objv[" << j+1 << "]);\n"
		   << tab4 << "if (Tcl_GetDoubleFromObj(interp,dupobj,&tempdouble) == TCL_ERROR) {\n"
		   << tab8 << "Tcl_DecrRefCount(dupobj);\n"
		   << tab8 << "return TCL_ERROR;\n"
		   << tab4 << "}\n"
		   << tab4 << "Tcl_DecrRefCount(dupobj);\n"
		   << tab4 << "_arg" << i << " = " << p->t->print_cast() << " tempdouble;\n";
	    break;
	  
	    // A single character
	    
	  case T_CHAR :
	    f.add_local("char *","tempstr");
	    f.add_local("int","templength");
	    f.code << tab4 << "if ((tempstr = Tcl_GetStringFromObj(objv[" << j+1 << "],&templength)) == NULL) return TCL_ERROR;\n"
		   << tab4 << "_arg" << i << " = *tempstr;\n";
	    break;
	  
	    // Void.. Do nothing.
	  
	  case T_VOID :
	    break;
	    
	    // User defined.   This is an error.
	    
	  case T_USER:
	    
	    // Unsupported data type
	    
	  default :
	    fprintf(stderr,"%s : Line %d: Unable to use type %s as a function argument.\n",
		    input_file, line_number, p->t->print_type());
	    break;
	  }
	} else {
	  
	  // Function argument is some sort of pointer
	  // Look for a string.   Otherwise, just pull off a pointer.
	  
	  if ((p->t->type == T_CHAR) && (p->t->is_pointer == 1)) {
	    f.add_local("int","templength");
	    f.code << tab4 << "if ((_arg" << i << " = Tcl_GetStringFromObj(objv[" << j+1 << "], &templength)) == NULL) return TCL_ERROR;\n";
	  } else {
	  
	    // Have a generic pointer type here.    Read it in as
	    // a hex-string
	    char arg_temp[256];
	    
	    // Try to parse pointer value directly
	    
#ifdef OLD
	    f.add_local("char *", "tempstr");
	    f.add_local("int","templength");
	    f.code << tab4 << "if ((tempstr = Tcl_GetStringFromObj(objv[" << j+1 << "],&templength)) == NULL) return TCL_ERROR;\n";
	    get_pointer(iname,arg_temp,"tempstr",target,p->t,f.code,"return TCL_ERROR");
#endif
	    sprintf(arg_temp,"argument %d",j+1);
	    f.add_local("char *", "rettype");
	    get_pointer(iname,arg_temp,source,target,p->t,f.code,"return TCL_ERROR");
	  }
	}
      }
      if (j >= (pcount-numopt))
	f.code << tab4 << "}\n";
      j++;
    }


    // Check to see if there is any sort of "build" typemap (highly complicated)

    if ((tm = typemap_lookup("build","tcl8",p->t,p->name,source,target))) {
      build << tm << "\n";
      have_build = 1;
    }

    // Check to see if there was any sort of a constaint typemap
    if ((tm = typemap_lookup("check","tcl8",p->t,p->name,source,target))) {
      // Yep.  Use it instead of the default
      f.code << tm << "\n";
      f.code.replace("$argnum",argnum);
      f.code.replace("$arg",source);
    }

    // Check if there was any cleanup code (save it for later)
    if ((tm = typemap_lookup("freearg","tcl8",p->t,p->name,target,"tcl_result"))) {
      // Yep.  Use it instead of the default
      cleanup << tm << "\n";
      cleanup.replace("$argnum",argnum);
      cleanup.replace("$arg",source);
    }
    // Look for output arguments
    if ((tm = typemap_lookup("argout","tcl8",p->t,p->name,target,"tcl_result"))) {
      outarg << tm << "\n";
      outarg.replace("$argnum",argnum);
      outarg.replace("$arg",source);
    }
    i++;
    p = l->get_next();   // Get next parameter and continue
  }


  // If there was a "build" typemap, we need to go in and perform a serious hack
  
  if (have_build) {
    char temp1[32];
    char temp2[256];
    l->sub_parmnames(build);            // Replace all parameter names
    j = 1;
    for (i = 0; i < l->nparms; i++) {
      p = l->get(i);
      if (strlen(p->name) > 0) {
	sprintf(temp1,"_in_%s", p->name);
      } else {
	sprintf(temp1,"_in_arg%d", i);
      }
      sprintf(temp2,"argv[%d]",j);
      build.replaceid(temp1,temp2);
      if (!p->ignore) 
	j++;
    }
    f.code << build;
  }

  // Now write code to make the function call

  emit_func_call(name,d,l,f);

  // Extract the tcl result object

  f.code << tab4 << "tcl_result = Tcl_GetObjResult(interp);\n";


  // Return value if necessary 

  if ((tm = typemap_lookup("out","tcl8",d,name,"_result","tcl_result"))) {
    // Yep.  Use it instead of the default
    f.code << tm << "\n";
  } else if ((d->type != T_VOID) || (d->is_pointer)) {
    if (!d->is_pointer) {
	
      // Function returns a "value"
	
      switch(d->type) {
	// Is an integer
      case T_BOOL:
      case T_INT:
      case T_SINT:
      case T_SHORT:
      case T_SSHORT:
      case T_LONG :
      case T_SLONG:
      case T_SCHAR:
      case T_UINT:
      case T_USHORT:
      case T_ULONG:
      case T_UCHAR:
	f.code << tab4 << "Tcl_SetIntObj(tcl_result,(long) _result);\n";
	break;
	
	// Is a single character.  Assume we return it as a string
      case T_CHAR :
	f.code << tab4 << "Tcl_SetStringObj(tcl_result,&_result,1);\n";
	break;
	
	// Floating point number
      case T_DOUBLE :
      case T_FLOAT :
	f.code << tab4 << "Tcl_SetDoubleObj(tcl_result,(double) _result);\n";
	break;
	
	// User defined type
      case T_USER :
	
	// Okay. We're returning malloced memory at this point.
	// Probably dangerous, but who said safety was a good thing?
	
	//	f.add_local("char","resultchar[256]");
	d->is_pointer++;
#ifdef OLD
	f.code << tab4 << "SWIG_MakePtr(resultchar, (void *) _result,\"" << d->print_mangle() << "\");\n"
	       << tab4 << "Tcl_SetStringObj(tcl_result,resultchar,-1);\n";
#endif
	f.code << tab4 << "SWIG_SetPointerObj(tcl_result,(void *) _result,\"" << d->print_mangle() << "\");\n";
	
	d->is_pointer--;
	break;
	
	// Unknown type
      default :
	fprintf(stderr,"%s : Line %d: Unable to use return type %s in function %s.\n",
		input_file, line_number, d->print_type(), name);
	break;
      }
    } else {
	
      // Is a pointer return type
      
      if ((d->type == T_CHAR) && (d->is_pointer == 1)) {
	// Return a character string
	f.code << tab4 << "Tcl_SetStringObj(tcl_result,_result,-1);\n";
      } else {
#ifdef OLD
	f.add_local("char","resultchar[256]");
	f.code << tab4 << "SWIG_MakePtr(resultchar, (void *) _result,\"" << d->print_mangle() << "\");\n"
	       << tab4 << "Tcl_SetStringObj(tcl_result,resultchar,-1);\n";
#endif
	
	f.code << tab4 << "SWIG_SetPointerObj(tcl_result,(void *) _result,\"" << d->print_mangle() << "\");\n";	
      }
    }
  }


  // Dump output argument code
  f.code << outarg;

  // Dump the argument cleanup code
  f.code << cleanup;

  // Look for any remaining cleanup

  if (NewObject) {
    if ((tm = typemap_lookup("newfree","tcl8",d,iname,"_result",""))) {
      f.code << tm << "\n";
    }
  }

  if ((tm = typemap_lookup("ret","tcl8",d,name,"_result",""))) {
    // Yep.  Use it instead of the default
    f.code << tm << "\n";
  }
  
  // Wrap things up (in a manner of speaking)

  f.code << tab4 << "return TCL_OK;\n}";

  // Substitute the cleanup code
  f.code.replace("$cleanup",cleanup);
  f.code.replace("$name",iname);

  // Dump out the function

  f.print(f_wrappers);

  // Now register the function with Tcl

  fprintf(f_init,"\t Tcl_CreateObjCommand(%s, SWIG_prefix \"%s\", %s, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);\n",interp_name, iname, wname);

  // If there's a documentation entry, produce a usage string

  if (doc_entry) {

    static DocEntry *last_doc_entry = 0;

    // Use usage as description
    doc_entry->usage << usage;

    // Set the cinfo field to specific a return type 

    if (last_doc_entry != doc_entry) {
      doc_entry->cinfo << "returns " << d->print_type();
      last_doc_entry = doc_entry;
    }
  }
}

// -----------------------------------------------------------------------
// TCL8::link_variable(char *name, char *iname, DataType *t,
//                           int ex)
//
// Create a TCL link to a variable.
// -----------------------------------------------------------------------

void TCL8::link_variable(char *name, char *iname, DataType *t)
{

  String    s;
  char      *tm, *tm1;

  // See if there were any typemaps

  tm = typemap_lookup("varin","tcl8",t,name,"","");
  tm1 = typemap_lookup("varout","tcl8",t,name,"","");
  if (tm || tm1) {
    fprintf(stderr,"%s : Line %d. Warning. varin/varout typemap methods not supported.",
	    input_file, line_number);
  }

  // Check the datatype.  Must be a valid Tcl type (there aren't many)

  if (((t->type == T_INT) && (!t->is_pointer)) ||
      ((t->type == T_UINT) && (!t->is_pointer)) ||
      ((t->type == T_SINT) && (!t->is_pointer)) ||
      ((t->type == T_DOUBLE) && (!t->is_pointer)) ||
      ((t->type == T_BOOL) && (!t->is_pointer)) ||
      ((t->type == T_CHAR) && (t->is_pointer == 1))) {

    // This is a valid TCL type. 

    if (t->type == T_UINT)
      fprintf(stderr,"%s : Line %d : ** Warning. Linkage of unsigned type may be unsafe.\n",
              input_file,  line_number);

    // Now add symbol to the TCL interpreter

    switch(t->type) {
    case T_CHAR :
      if (t->arraystr) {
	// Is an array.  We have to do something different
	fprintf(f_wrappers,"static char *tclvar%s = %s;\n",name,name);
	s << "(char *) &tclvar" << name << ", TCL_LINK_STRING";
      } else {
	s << "(char *) &" << name << ", TCL_LINK_STRING";
      }
      break;
    case T_BOOL:
    case T_INT :
    case T_UINT:
    case T_SINT:
      s << "(char *) &" << name << ", TCL_LINK_INT";
      break;
    case T_DOUBLE :
      s << "(char *) &" << name << ", TCL_LINK_DOUBLE";
      break;
    default :
      fprintf(f_init,"Fatal error. Internal error (Tcl:link_variable)\n");
      break;
    }

    if (Status & STAT_READONLY)
      s << " | TCL_LINK_READ_ONLY);\n";
    else
      s << ");\n";

    fprintf(f_init,"\t Tcl_LinkVar(%s, SWIG_prefix \"%s\", %s",interp_name, iname, s.get());    
    
    // Make a usage string for it

    if (doc_entry) {
      doc_entry->usage << usage_var(iname,t);
      doc_entry->cinfo = "";
      doc_entry->cinfo << "Global : " << t->print_type() << " " << name;
    }
  } else {

    // Have some sort of "other" type.
    // We're going to emit some functions to set/get it's value instead
    
    emit_set_get(name,iname, t);
    if (doc_entry) {
      doc_entry->cinfo = "";
      doc_entry->cinfo << "Global : " << t->print_type() << " " << iname;
    }

    // If shadow classes are enabled and we have a user-defined type
    // that we know about, create a command for it.  

    if (shadow) {
      if ((t->type == T_USER) && (t->is_pointer < 1)) {
	// See if the datatype is in our hash table
	if (hash.lookup(t->name)) {
	  // Yep.  Try to create a command for it

	  postinit << tab4 << "{\n"
		   << tab8 << "char cmd[] = \"" 
		   << (char *) hash.lookup(t->name) << " " << iname << " -this ["
		   << iname << "_get ]\";\n"
		   << tab8 << "Tcl_GlobalEval(interp,cmd);\n"
		   << tab4 << "}\n";
	}
      }
    }
  }  
}

// -----------------------------------------------------------------------
// TCL8::declare_const(char *name, char *iname, DataType *type, char *value)
//
// Makes a constant.  Really just creates a variable and links to it.
// Tcl variable linkage allows read-only variables so we'll use that
// instead of just creating a Tcl variable.
// ------------------------------------------------------------------------

void TCL8::declare_const(char *name, char *, DataType *type, char *value) {

  int OldStatus = Status;      // Save old status flags
  DataType *t; 
  char   var_name[256];
  char     *tm;
  String  rvalue;
  Status = STAT_READONLY;      // Enable readonly mode.

  // Make a static variable;

  sprintf(var_name,"_wrap_const_%s",name);
  
  // See if there's a typemap
  rvalue = value;
  if ((type->type == T_CHAR) && (type->is_pointer == 1)) {
    rvalue << "\""; 
    "\"" >> rvalue;
  } 
  if ((type->type == T_CHAR) && (type->is_pointer == 0)) {
    rvalue << "'";
    "'" >> rvalue;
  }
  if ((tm = typemap_lookup("const","tcl8",type,name,rvalue.get(),name))) {
    // Yep.  Use it instead of the default
    fprintf(f_init,"%s\n",tm);
  } else {

    // Create variable and assign it a value
    
    if (type->is_pointer == 0) {
      switch(type->type) {
      case T_BOOL: case T_INT: case T_SINT: case T_DOUBLE:
	fprintf(f_header,"static %s %s = %s;\n", type->print_type(), var_name, value);
	link_variable(var_name,name,type);
	break;
      case T_SHORT:
      case T_LONG:
      case T_SSHORT:
      case T_SCHAR:
      case T_SLONG:
	fprintf(f_header,"static %s %s = %s;\n", type->print_type(), var_name, value);
	fprintf(f_header,"static char *%s_char;\n", var_name);
	if (CPlusPlus)
	  fprintf(f_init,"\t %s_char = new char[32];\n",var_name);
	else
	  fprintf(f_init,"\t %s_char = (char *) malloc(32);\n",var_name);
	
	fprintf(f_init,"\t sprintf(%s_char,\"%%ld\", (long) %s);\n", var_name, var_name);
	sprintf(var_name,"%s_char",var_name);
	t = new DataType(T_CHAR);
	t->is_pointer = 1;
	link_variable(var_name,name,t);
	delete t;
	break;
      case T_UINT:
      case T_USHORT:
      case T_ULONG:
      case T_UCHAR:
	fprintf(f_header,"static %s %s = %s;\n", type->print_type(), var_name, value);
	fprintf(f_header,"static char *%s_char;\n", var_name);
	if (CPlusPlus)
	  fprintf(f_init,"\t %s_char = new char[32];\n",var_name);
	else
	  fprintf(f_init,"\t %s_char = (char *) malloc(32);\n",var_name);
	
	fprintf(f_init,"\t sprintf(%s_char,\"%%lu\", (unsigned long) %s);\n", var_name, var_name);
	sprintf(var_name,"%s_char",var_name);
	t = new DataType(T_CHAR);
	t->is_pointer = 1;
	link_variable(var_name,name,t);
	delete t;
	break;
      case T_FLOAT:
	type->type = T_DOUBLE;
	strcpy(type->name,"double");
	fprintf(f_header,"static %s %s = %s (%s);\n", type->print_type(), var_name, type->print_cast(), value);
	link_variable(var_name,name,type);
	break;
	
      case T_CHAR:
	type->is_pointer++;
	fprintf(f_header,"static %s %s = \"%s\";\n", type->print_type(), var_name, value);
	link_variable(var_name,name,type);
	type->is_pointer--;
	break;
      default:
	fprintf(stderr,"%s : Line %d. Unsupported constant value.\n", input_file, line_number);
	break;
      }
    } else {
      // Have some sort of pointer value here
      if ((type->type == T_CHAR) && (type->is_pointer == 1)) {
	// Character string
	fprintf(f_header,"static %s %s = \"%s\";\n", type->print_type(), var_name, value);
	link_variable(var_name,name,type);
      } else {
	// Something else.   Some sort of pointer value
	fprintf(f_header,"static %s %s = %s;\n", type->print_type(), var_name, value);
	fprintf(f_header,"static char *%s_char;\n", var_name);
	if (CPlusPlus)
	  fprintf(f_init,"\t %s_char = new char[%d];\n",var_name,(int) strlen(type->print_mangle())+ 20);
	else
	  fprintf(f_init,"\t %s_char = (char *) malloc(%d);\n",var_name, (int) strlen(type->print_mangle())+ 20);
	
	t = new DataType(T_CHAR);
	t->is_pointer = 1;
	fprintf(f_init,"\t SWIG_MakePtr(%s_char, (void *) %s,\"%s\");\n",
		var_name, var_name, type->print_mangle());
	sprintf(var_name,"%s_char",var_name);
	link_variable(var_name,name,t);
	delete t;
      }
    }
  }

  // Create a documentation entry for this

  if (doc_entry) {
    doc_entry->usage = "";       // Destroy any previous information from linking
    doc_entry->usage << usage_const(name, type, value);
    doc_entry->cinfo = "";
    doc_entry->cinfo << "Constant : " << type->print_type();
  }

  Status = OldStatus;
}

// ----------------------------------------------------------------------
// TCL8::usage_var(char *iname, DataType *t, char **s)
//
// Produces a usage string for a tcl variable.  Stores it in s
// ----------------------------------------------------------------------

char *TCL8::usage_var(char *iname, DataType *t) {

  static char temp[1024];

  if (!nspace) {
    sprintf(temp,"$%s%s", prefix, iname);
  } else { 
    sprintf(temp,"%s::%s", ns_name, iname);
  }
  if (!(((t->type == T_INT) && (!t->is_pointer)) ||
	((t->type == T_UINT) && (!t->is_pointer)) ||
	((t->type == T_DOUBLE) && (!t->is_pointer)) ||
	((t->type == T_BOOL) && (!t->is_pointer)) ||
	((t->type == T_CHAR) && (t->is_pointer)))) {
    /* We emitted a pair of set/get functions instead.  Doc will be generated for that */
    return temp;
  }
  return temp;
}



// ---------------------------------------------------------------------------
// char *TCL8::usage_string(char *iname, DataType *t, ParmList *l),
// 
// Generates a generic usage string for a Tcl function.
// ---------------------------------------------------------------------------

char * TCL8::usage_string(char *iname, DataType *, ParmList *l) {

  static String temp;
  Parm  *p;
  int   i, numopt,pcount;

  temp = "";
  temp << iname << " ";
  
  /* Now go through and print parameters */
  i = 0;
  pcount = l->nparms;
  numopt = l->numopt();
  p = l->get_first();
  while (p != 0) {

    // Only print an argument if not ignored

    if (!typemap_check("ignore","tcl8",p->t,p->name)) {
      if (i >= (pcount-numopt))
	temp << "?";

      /* If parameter has been named, use that.   Otherwise, just print a type  */

      if ((p->t->type != T_VOID) || (p->t->is_pointer)) {
	if (strlen(p->name) > 0) {
	  temp << p->name;
	}
	else {
	  temp << "{ " << p->t->print_type() << " }";
	}
      }
      if (i >= (pcount-numopt))
	temp << "?";
      temp << " ";
      i++;
    }
    p = l->get_next();
  }
  return temp;
}

// ---------------------------------------------------------------------------
// char *TCL8::usage_func(char *iname, DataType *t, ParmList *l),
// 
// Produces a usage string for a function in Tcl
// ---------------------------------------------------------------------------

char * TCL8::usage_func(char *iname, DataType *t, ParmList *l) {

  String temp;

  if (nspace) {
    temp << ns_name << "::" << iname;
  } else {
    temp << prefix << iname;
  }
  return usage_string(temp,t,l);
}

// -----------------------------------------------------------------
// TCL8::usage_const(char *name, DataType *type, char *value)
//                         char **s)
//
// Makes a usage string and returns it
// -----------------------------------------------------------------

char *TCL8::usage_const(char *name, DataType *, char *value) {
  static String temp;
  temp = "";
  if (nspace) {
    temp << ns_name << "::" << name << " = " << value;
  } else {
    temp << "$" << prefix << name << " = " << value;
  }
  return temp.get();
}
    
// -------------------------------------------------------------------
// TCL8::add_native(char *name, char *funcname)
//
// This adds an already written Tcl wrapper function to our
// initialization function.
// -------------------------------------------------------------------


void TCL8::add_native(char *name, char *funcname) {

  fprintf(f_init,"\t Tcl_CreateCommand(%s, SWIG_prefix \"%s\", %s, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);\n",interp_name, name, funcname);
  
  if (doc_entry) {
    if (nspace) 
      doc_entry->usage << ns_name << "::" << name << " args";
    else
      doc_entry->usage << prefix << name << " args";

    doc_entry->cinfo << "Native method : " << funcname;
  }
    
}
 
// -------------------------------------------------------------------
// TCL8::pragma(char *lname, char *name, char *value)
//
// Handle pragmas.
// --------------------------------------------------------------------

void TCL8::pragma(char *, char *, char *) {

}

// ---------------------------------------------------------------------
// C++ Handling
//
// The following functions provide some support for C++ classes and
// C structs.   
// ---------------------------------------------------------------------

void TCL8::cpp_open_class(char *classname, char *rename, char *ctype, int strip) {

  this->Language::cpp_open_class(classname,rename,ctype,strip);

  if (shadow) {
  
    config = "";
    cget = "";
    methods = "";
    options = "";
    config_options = "";
    methodnames = "";
    
    have_constructor = 0;
    have_destructor = 0;
    have_methods = 0;
    have_config = 0;
    have_cget = 0;

    if (rename)
      class_name = copy_string(rename);
    else
      class_name = copy_string(classname);
  
    base_class = (char *) 0;
    if (!strip) {
      class_type = new char[strlen(ctype)+2];
      sprintf(class_type,"%s ", ctype);
    } else
      class_type = "";

    real_classname = copy_string(classname);
  }
}

void TCL8::cpp_close_class() {
  String code,temp;
  DataType *t;

  this->Language::cpp_close_class();
  if (shadow) {

    t = new DataType;
    sprintf(t->name,"%s%s", class_type, real_classname);
    t->type = T_USER;
    t->is_pointer = 1;
    
    // Note : The object oriented interface is defined by three files
    //     delcmd8.swg          - Object deletion wrapper
    //     methodcmd8.swg       - Method invocation command
    //     objcmd8.swg          - Command to create a new object
    //
    // These files are located in the SWIG library.  This module
    // grabs the files and performs marker replacements to
    // build the wrapper function.
    
    // Generate a Tcl function for object destruction
    
    if (have_destructor) {
      code << delcmd;
    }

    // Dump out method code
    code << methodcmd;

    // Dump out object creation command
    code << objcmd;

    // Now perform marker replacements
    code.replace("@CLASS@",class_name);
    temp = "";
    temp << name_destroy(class_name);
    code.replace("@DESTRUCTOR@",temp);
    code.replace("@CLASSTYPE@",t->print_type());
    "configure " >> methodnames;
    "cget " >> methodnames;
    code.replace("@METHODLIST@", methodnames);
    code.replace("@CLASSMANGLE@",t->print_mangle());
    code.replace("@METHODS@",methods);
    code.replace("@CONFIGMETHODS@",config);
    code.replace("@CGETMETHODS@",cget);
    if (have_constructor) {
      temp = "";
      temp << name_wrapper(name_construct(class_name),prefix);
    } else {
      temp = "0";
    }
    code.replace("@TCLCONSTRUCTOR@",temp);
    code.replace("@CONFIGLIST@",config_options);
    code.replace("@CGETLIST@",options);
    if (have_destructor) {
      temp = "TclDelete";
      temp << class_name;
    } else {
      temp = "0";
    }
    code.replace("@TCLDESTRUCTOR@",temp);
    fprintf(f_wrappers,"%s\n", code.get());

    fprintf(f_init,"\t Tcl_CreateObjCommand(interp,SWIG_prefix \"%s\",Tcl%sCmd, (ClientData) NULL, NULL);\n", class_name, class_name);
  }
}

void TCL8::cpp_member_func(char *name, char *iname, DataType *t, ParmList *l) {

  char *realname;
  String temp;
  char  *rname;

  this->Language::cpp_member_func(name,iname,t,l);

  if (shadow) {
    if (iname) 
      realname = iname;
    else
      realname = name;
    
    // Add stubs for this member to our class handler function

    if (have_methods) 
      methods << tab4 << "else ";
    else 
      methods << tab4;

    temp = "";
    temp << name_member(realname,class_name);
    rname = (char *) repeatcmd.lookup(temp);
    if (!rname)
      rname = name_wrapper(temp.get(),prefix);
    
    methods << "if (strcmp(_str,\"" << realname << "\") == 0) {\n"
	    << tab4 << tab4 << "cmd = " << rname << ";\n"
	    << tab4 << "}";

    have_methods = 1;
    methodnames << realname << " ";

    if (doc_entry) {
      doc_entry->usage = "";
      doc_entry->usage << usage_string(realname,t,l);
    }
  }
}

void TCL8::cpp_variable(char *name, char *iname, DataType *t) {
  char *realname;
  String temp;
  char *rname;

  this->Language::cpp_variable(name, iname, t);

  if (shadow) {
    if (iname)
      realname = iname;
    else
      realname = name;
    
    char *bc = class_name;

    // Write config code
    
    if (!(Status & STAT_READONLY)) {
      if (!have_config) {
	config << tab8 << tab8;
      } else {
	config << " else ";
      }

      // Try to figure out if there is already a wrapper for this
      
      temp = "";
      temp << name_set(name_member(realname,bc));
      rname = (char *) repeatcmd.lookup(temp);
      if (!rname) 
	rname = name_wrapper(temp.get(),prefix);

      config << "if (strcmp(_str,\"-" << realname << "\") == 0) {\n"
	     << tab8 << tab8 << tab4 << "cmd = " << rname << ";\n"
	     << tab8 << tab8 << "} ";
      
      have_config = 1;
    }
    
    // Write cget code
    
    if (!have_cget) {
      cget << tab8 << tab8;
    } else {
      cget << " else ";
    }


    // Try to figure out if there is a wrapper for this function
    temp = "";
    temp << name_get(name_member(realname,bc));
    rname = (char *) repeatcmd.lookup(temp);
    if (!rname) 
      rname = name_wrapper(temp.get(),prefix);

    cget << "if (strcmp(_str,\"-" << realname << "\") == 0) {\n"
	 << tab8 << tab8 << tab4 << "cmd = " << rname << ";\n"
	 << tab8 << tab8 << "} ";
    have_cget = 1;
    
    options << "-" << realname << " ";
    if (!(Status & STAT_READONLY)) {
      config_options << "-" << realname << " ";
    }
    if (doc_entry){
      doc_entry->usage = "";
      doc_entry->usage << "-" << realname << "\n";
    }
  }
}

void TCL8::cpp_constructor(char *name, char *iname, ParmList *l) {
  this->Language::cpp_constructor(name,iname,l);

  if (shadow) {
    if ((!have_constructor) && (doc_entry)) {
      doc_entry->usage = "";
      doc_entry->usage << class_name << usage_string(" name",0,l);
    }
    have_constructor = 1;
  }
}
void TCL8::cpp_destructor(char *name, char *newname) {
  this->Language::cpp_destructor(name,newname);
  if (shadow) {
    if (!have_destructor) {
      if (doc_entry) {
	doc_entry->usage = "rename obj {}";
      }
    }
    have_destructor = 1;
  }
}

void TCL8::cpp_inherit(char **baseclass, int) {
  this->Language::cpp_inherit(baseclass);
}

void TCL8::cpp_declare_const(char *name, char *iname, DataType *type, char *value) {
  this->Language::cpp_declare_const(name,iname,type,value);
}

// --------------------------------------------------------------------------------
// TCL8::add_typedef(DataType *t, char *name)
//
// This is called whenever a typedef is encountered.   When shadow classes are
// used, this function lets us discovered hidden uses of a class.  For example :
//
//     struct FooBar {
//            ...
//     }
//
// typedef FooBar *FooBarPtr;
//
// --------------------------------------------------------------------------------

void TCL8::add_typedef(DataType *t, char *name) {

  if (!shadow) return;

  // First check to see if there aren't too many pointers

  if (t->is_pointer > 1) return;
  if (hash.lookup(name)) return;      // Already added

  // Now look up the datatype in our shadow class hash table

  if (hash.lookup(t->name)) {

    // Yep.   This datatype is in the hash
    // Put this types 'new' name into the hash
    hash.add(name,copy_string((char *) hash.lookup(t->name)));
  }
}

// -----------------------------------------------------------------------
// TCL8::cpp_class_decl(char *name, char *rename, char *type)
//
// Treatment of an empty class definition.    Used to handle
// shadow classes across modules.
// -----------------------------------------------------------------------

void TCL8::cpp_class_decl(char *name, char *rename, char *type) {
  char temp[256];
  this->Language::cpp_class_decl(name,rename, type);

  if (shadow) {
    hash.add(name,copy_string(rename));
    // Add full name of datatype to the hash table
    if (strlen(type) > 0) {
      sprintf(temp,"%s %s", type, name);
      hash.add(temp,copy_string(rename));
    }
  }
}