/******************************************************************************* * 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 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 \n"); fprintf(f_header,"#include \n"); fprintf(f_header,"#include \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)); } } }