/*******************************************************************************
* Simplified Wrapper and Interface Generator (SWIG)
*
* Dave Beazley
*
* Department of Computer Science Theoretical Division (T-11)
* University of Utah Los Alamos National Laboratory
* Salt Lake City, Utah 84112 Los Alamos, New Mexico 87545
* beazley@cs.utah.edu beazley@lanl.gov
*
* Copyright (c) 1995-1997
* The University of Utah and the Regents of the University of California
* All Rights Reserved
*
* Permission is hereby granted, without written agreement and without
* license or royalty fees, to use, copy, modify, and distribute this
* software and its documentation for any purpose, provided that
* (1) The above copyright notice and the following two paragraphs
* appear in all copies of the source code and (2) redistributions
* including binaries reproduces these notices in the supporting
* documentation. Substantial modifications to this software may be
* copyrighted by their authors and need not follow the licensing terms
* described here, provided that the new terms are clearly indicated in
* all files where they apply.
*
* IN NO EVENT SHALL THE AUTHOR, THE UNIVERSITY OF CALIFORNIA, THE
* UNIVERSITY OF UTAH OR DISTRIBUTORS OF THIS SOFTWARE BE LIABLE TO ANY
* PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL
* DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION,
* EVEN IF THE AUTHORS OR ANY OF THE ABOVE PARTIES HAVE BEEN ADVISED OF
* THE POSSIBILITY OF SUCH DAMAGE.
*
* THE AUTHOR, THE UNIVERSITY OF CALIFORNIA, AND THE UNIVERSITY OF UTAH
* SPECIFICALLY DISCLAIM ANY WARRANTIES,INCLUDING, BUT NOT LIMITED TO,
* THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
* PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS ON AN "AS IS" BASIS, AND
* THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE,
* SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
*
*******************************************************************************/
/***********************************************************************
* $Header: /home/beazley/SWIG/SWIG1.2/Modules/RCS/tcl8.cxx,v 1.24 1997/07/25 05:51:13 beazley Exp $
*
* 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\
-htcl tcl.h - Specify the name of the \"tcl.h\" header file\n\
-htk tk.h - Specify the name of the \"tk.h\" header file\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],"-htcl") == 0) {
if (argv[i+1]) {
strcpy(tcl_include,argv[i+1]);
mark_arg(i);
mark_arg(i+1);
i++;
} else {
arg_error();
}
} else if (strcmp(argv[i],"-htk") == 0) {
if (argv[i+1]) {
strcpy(tk_include,argv[i+1]);
mark_arg(i);
mark_arg(i+1);
i++;
} else {
arg_error();
}
} else 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,"#define INCLUDE_TCL <%s>\n", tcl_include);
fprintf(f_header,"#define INCLUDE_TK <%s>\n", tk_include);
fprintf(f_header,"#include INCLUDE_TCL\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 (insert_file(Tcl_config, f_header) == -1) {
fprintf(f_header,"#define SWIGEXPORT(a,b) a b\n");
}
// Get special Tcl 8.0 code for pointer conversion
if (!NoInclude) {
if (insert_file("tcl8ptr.swg",f_header) == -1) {
fprintf(stderr,"SWIG : Fatal error. Unable to locate 'tcl8ptr.swg' in SWIG library.\n");
SWIG_exit(1);
}
} else {
fprintf(f_header,"#ifdef __cplusplus\n");
fprintf(f_header,"extern \"C\" {\n");
fprintf(f_header,"#endif\n");
fprintf(f_header,"extern void SWIG_SetPointerObj(Tcl_Obj *, void *, char *);\n");
fprintf(f_header,"extern void SWIG_RegisterMapping(char *, char *, void *(*)(void *));\n");
fprintf(f_header,"extern char *SWIG_GetPointerObj(Tcl_Interp *, Tcl_Obj *, void **, char *);\n");
fprintf(f_header,"extern int SWIG_MakePtr(char *, const void *, char *);\n");
fprintf(f_header,"extern void SWIG_RegisterType();\n");
fprintf(f_header,"#ifdef __cplusplus\n");
fprintf(f_header,"}\n");
fprintf(f_header,"#endif\n");
}
}
// --------------------------------------------------------------------
// 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));
}
}
}
/*********************************************************************************
* -- Revision History
* $Log: tcl8.cxx,v $
* Revision 1.24 1997/07/25 05:51:13 beazley
* Minor patch for to integer parsing to work properly with enums.
*
* Revision 1.23 1997/07/09 02:51:27 beazley
* First crack at eliminating compiler warnings.
*
* Revision 1.22 1997/06/29 19:08:15 beazley
* Changed EXPORT to SWIGEXPORT
*
* Revision 1.21 1997/06/17 04:42:52 beazley
* Added support for Tcl8.0b1. Fixed %name(). Moved to
* unified naming functions.
*
* Revision 1.20 1997/05/28 21:43:58 beazley
* Moved revision history to end.
*
* Revision 1.19 1997/05/24 05:15:25 beazley
* Added the "build" typemap.
*
* Revision 1.18 1997/05/19 16:28:11 beazley
* Added a few more typemap variables.
*
* Revision 1.17 1997/05/08 05:42:06 beazley
* Added $cleanup symbol.
*
* Revision 1.16 1997/05/05 15:49:02 beazley
* Added support for parameterized typemaps.
*
* Revision 1.15 1997/04/19 21:25:35 beazley
* Added support for %new directive.
*
* Revision 1.14 1997/03/29 17:43:54 beazley
* Minor code generation fix.
*
* Revision 1.13 1997/03/24 23:05:24 beazley
* Added a few tweaks for Macintosh support
*
* Revision 1.12 1997/03/19 23:47:06 beazley
* Changed "constrain" typemap to "check"
*
* Revision 1.11 1997/03/18 22:27:19 beazley
* Added constrain typemap
*
* Revision 1.10 1997/03/18 21:47:37 beazley
* Minor changes to typemap handling.
*
* Revision 1.9 1997/03/11 19:41:50 beazley
* Fixed to work with Tcl 8.0a2.
*
* Revision 1.8 1997/03/02 22:40:57 beazley
* Minor bug fixes. Removed warnings.
*
* Revision 1.7 1997/02/19 23:03:28 beazley
* Added create_command() function needed for C++ optimization.
*
* Revision 1.6 1997/02/16 19:56:07 beazley
* Added support for ignored arguments.
*
* Revision 1.5 1997/01/09 01:21:42 beazley
* Changed inherit method slightly
*
* Revision 1.4 1997/01/08 05:43:06 beazley
* Pre 1.1b3 checkin
*
* Revision 1.3 1997/01/06 17:12:03 beazley
* Added support for typemaps. Multiple inheritance.
*
* Revision 1.2 1996/12/26 23:03:19 beazley
* Modified to use new pointer type-checker
*
* Revision 1.1 1996/12/26 04:48:00 beazley
* Initial revision
*
*
*********************************************************************************/
syntax highlighted by Code2HTML, v. 0.9.1