--- /dev/null
+/*******************************************************************************
+ * 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));
+ }
+ }
+}
projects / wxWidgets.git / blobdiff