wxPython/wxSWIG/Modules/tcl.cxx

   1 /*******************************************************************************
   2  * Simplified Wrapper and Interface Generator  (SWIG)
   3  *
   4  * Author : David Beazley
   5  *
   6  * Department of Computer Science
   7  * University of Chicago
   8  * 1100 E 58th Street
   9  * Chicago, IL  60637
  10  * beazley@cs.uchicago.edu
  11  *
  12  * Please read the file LICENSE for the copyright and terms by which SWIG
  13  * can be used and distributed.
  14  *******************************************************************************/
  15
  16 /***********************************************************************
  17  * $Header$
  18  *
  19  * tcl.cxx
  20  *
  21  * Definitions for creating a simple, stand-alone TCL implementation.
  22  *
  23  ***********************************************************************/
  24
  25 #include "swig.h"
  26 #include "swigtcl.h"
  27 #include <ctype.h>
  28
  29 static char *Tcl_config="swigtcl.swg";
  30 static char *usage = "\
  31 Tcl Options (available with -tcl)\n\
  32      -module name    - Set name of module\n\
  33      -prefix name    - Set a prefix to be appended to all names\n\
  34      -namespace      - Build module into a Tcl8 namespace. \n\
  35      -noobject       - Omit code for object oriented interface.\n\
  36      -old            - Use old SWIG interface (same as -noobject).\n\n";
  37
  38
  39 static char *ns_name = 0;
  40 static String mod_init;
  41 static String mod_extern;
  42
  43 // ---------------------------------------------------------------------
  44 // TCL::parse_args(int argc, char *argv[])
  45 //
  46 // Parse tcl specific command line options
  47 // ---------------------------------------------------------------------
  48
  49 void TCL::parse_args(int argc, char *argv[]) {
  50
  51   int i = 1;
  52   sprintf(LibDir,"%s",tcl_path);
  53
  54   // Look for certain command line options
  55
  56   for (i = 1; i < argc; i++) {
  57       if (argv[i]) {
  58           if (strcmp(argv[i],"-prefix") == 0) {
  59             if (argv[i+1]) {
  60               prefix = new char[strlen(argv[i+1])+2];
  61               strcpy(prefix, argv[i+1]);
  62               mark_arg(i);
  63               mark_arg(i+1);
  64               i++;
  65             } else {
  66               arg_error();
  67             }
  68           } else if (strcmp(argv[i],"-module") == 0) {
  69             if (argv[i+1]) {
  70               set_module(argv[i+1],0);
  71               mark_arg(i);
  72               mark_arg(i+1);
  73               i++;
  74             } else {
  75               arg_error();
  76             }
  77           } else if (strcmp(argv[i],"-namespace") == 0) {
  78             nspace = 1;
  79             mark_arg(i);
  80           } else if (strcmp(argv[i],"-old") == 0) {
  81             shadow = 0;
  82             mark_arg(i);
  83           } else if (strcmp(argv[i],"-noobject") == 0) {
  84             shadow = 0;
  85             mark_arg(i);
  86           } else if (strcmp(argv[i],"-help") == 0) {
  87             fputs(usage,stderr);
  88           }
  89       }
  90   }
  91
  92   // If a package has been specified, make sure it ends with a '_'
  93
  94   if (prefix) {
  95     ns_name = copy_string(prefix);
  96     if (prefix[strlen(prefix)] != '_') {
  97       prefix[strlen(prefix)+1] = 0;
  98       prefix[strlen(prefix)] = '_';
  99     }
 100   } else
 101     prefix = "";
 102
 103   // Create a symbol SWIGTCL
 104
 105   add_symbol("SWIGTCL",0,0);
 106   typemap_lang = "tcl";
 107
 108   // Attempt to load up the C++ configuration files
 109
 110   get_file("delcmd.swg",delcmd);
 111   get_file("methodcmd.swg",methodcmd);
 112   get_file("objcmd.swg",objcmd);
 113
 114 }
 115
 116 // ---------------------------------------------------------------------
 117 // void TCL::parse()
 118 //
 119 // Start parsing an interface file for Tcl.
 120 // ---------------------------------------------------------------------
 121
 122 void TCL::parse() {
 123
 124   fprintf(stderr,"Making wrappers for Tcl\n");
 125
 126   // Print out TCL specific headers
 127
 128   headers();
 129
 130   // Run the parser
 131
 132   yyparse();
 133
 134 }
 135
 136 // ---------------------------------------------------------------------
 137 // TCL::set_module(char *mod_name,char **mod_list)
 138 //
 139 // Sets the module name.
 140 // Does nothing if it's already set (so it can be overridden as a command
 141 // line option).
 142 //
 143 // mod_list is a NULL-terminated list of additional modules.  This
 144 // is really only useful when building static executables and other
 145 // things.
 146 //----------------------------------------------------------------------
 147
 148 void TCL::set_module(char *mod_name, char **mod_list) {
 149
 150   char temp[256], *c;
 151   int  i;
 152
 153   if (module) return;
 154
 155   module = new char[strlen(mod_name)+1];
 156   strcpy(module,mod_name);
 157
 158   // Fix capitalization for Tcl
 159
 160   c = module;
 161   while (*c) {
 162     *c = (char) tolower(*c);
 163     c++;
 164   }
 165
 166   // Now create an initialization function
 167
 168   sprintf(temp,"%s_Init", module);
 169   init_name = new char[strlen(temp) + 1];
 170   strcpy(init_name, temp);
 171   *init_name = toupper(*init_name);
 172
 173   if (!ns_name) ns_name = copy_string(module);
 174
 175   // If namespaces have been specified, set the prefix to the module name
 176
 177   if ((nspace) && (strlen(prefix) < 1)) {
 178     prefix = new char[strlen(module)+2];
 179     strcpy(prefix,module);
 180     prefix[strlen(module)] = '_';
 181     prefix[strlen(module)+1] = 0;
 182   }
 183
 184   // If additional modules have been specified, create some code for
 185   // initializing them.
 186
 187   if (mod_list) {
 188     i = 0;
 189     while (mod_list[i]) {
 190       c = mod_list[i];
 191       while (*c) {
 192         *c = (char) tolower(*c);
 193         c++;
 194       }
 195       sprintf(temp,"%s_Init",mod_list[i]);
 196       temp[0] = toupper(temp[0]);
 197
 198       // Dump out some initialization code
 199
 200       mod_init << tab4 << "if (" << temp << "(" << interp_name << ") == TCL_ERROR) {\n"
 201                << tab8 << "return TCL_ERROR;\n"
 202                << tab4 << "}\n\n";
 203       mod_extern << "extern int " << temp << "(Tcl_Interp *);\n";
 204       i++;
 205     }
 206   }
 207 }
 208
 209
 210 // ---------------------------------------------------------------------
 211 // TCL::set_init(char *iname)
 212 //
 213 // Sets the initialization function name.
 214 // Does nothing if it's already set
 215 //
 216 //----------------------------------------------------------------------
 217
 218 void TCL::set_init(char *iname) {
 219
 220   if (init_name) return;
 221
 222   init_name = new char[strlen(iname)+1];
 223   strcpy(init_name, iname);
 224
 225 }
 226
 227 // ---------------------------------------------------------------------
 228 // TCL::headers(void)
 229 //
 230 // Generate the appropriate header files for TCL interface.
 231 // ----------------------------------------------------------------------
 232
 233 void TCL::headers(void)
 234 {
 235
 236   emit_banner(f_header);
 237   fprintf(f_header,"/* Implementation : TCL 7.x */\n\n");
 238   fprintf(f_header,"#include <tcl.h>\n");
 239   fprintf(f_header,"#include <string.h>\n");
 240   fprintf(f_header,"#include <stdlib.h>\n");
 241   fprintf(f_header,"#define SWIGTCL\n");
 242
 243   if (NoInclude) {
 244     fprintf(f_header,"#define SWIG_NOINCLUDE\n");
 245   }
 246
 247   if (insert_file("swigtcl.swg", f_header) == -1) {
 248     fprintf(stderr,"Unable to find 'swigtcl.swg'. Possible installation problem.\n");
 249     SWIG_exit(1);
 250   }
 251 }
 252
 253 // --------------------------------------------------------------------
 254 // TCL::initialize(void)
 255 //
 256 // Produces an initialization function.   Assumes that the init function
 257 // name has already been specified.
 258 // ---------------------------------------------------------------------
 259
 260 void TCL::initialize()
 261 {
 262
 263   if ((!ns_name) && (nspace)) {
 264     fprintf(stderr,"Tcl error.   Must specify a namespace.\n");
 265     SWIG_exit(1);
 266   }
 267
 268   if (!init_name) {
 269     init_name = "Swig_Init";
 270     fprintf(stderr,"SWIG : *** Warning. No module name specified.\n");
 271   }
 272
 273   fprintf(f_header,"#define SWIG_init    %s\n", init_name);
 274   if (!module) module = "swig";
 275   fprintf(f_header,"#define SWIG_name    \"%s\"\n", module);
 276   if (nspace) {
 277     fprintf(f_header,"#define SWIG_prefix  \"%s::\"\n", ns_name);
 278     fprintf(f_header,"#define SWIG_namespace \"%s\"\n\n", ns_name);
 279   } else {
 280     fprintf(f_header,"#define SWIG_prefix  \"%s\"\n", prefix);
 281     fprintf(f_header,"#define SWIG_namespace \"\"\n\n");
 282   }
 283   fprintf(f_header,"#ifdef __cplusplus\n");
 284   fprintf(f_header,"extern \"C\" {\n");
 285   fprintf(f_header,"#endif\n");
 286   fprintf(f_header,"#ifdef MAC_TCL\n");
 287   fprintf(f_header,"#pragma export on\n");
 288   fprintf(f_header,"#endif\n");
 289   fprintf(f_header,"SWIGEXPORT(int) %s(Tcl_Interp *);\n", init_name);
 290   fprintf(f_header,"#ifdef MAC_TCL\n");
 291   fprintf(f_header,"#pragma export off\n");
 292   fprintf(f_header,"#endif\n");
 293   fprintf(f_header,"#ifdef __cplusplus\n");
 294   fprintf(f_header,"}\n");
 295   fprintf(f_header,"#endif\n");
 296
 297   fprintf(f_init,"SWIGEXPORT(int) %s(Tcl_Interp *%s) {\n", init_name, interp_name);
 298
 299   fprintf(f_init,"\t if (%s == 0) \n", interp_name);
 300   fprintf(f_init,"\t\t return TCL_ERROR;\n");
 301
 302   /* Check to see if other initializations need to be performed */
 303
 304   if (strlen(mod_extern.get())) {
 305     fprintf(f_init,"%s\n",mod_init.get());
 306     fprintf(f_header,"#ifdef __cplusplus\n");
 307     fprintf(f_header,"extern \"C\" {\n");
 308     fprintf(f_header,"#endif\n");
 309     fprintf(f_header,"%s\n",mod_extern.get());
 310     fprintf(f_header,"#ifdef __cplusplus\n");
 311     fprintf(f_header,"}\n");
 312     fprintf(f_header,"#endif\n");
 313   }
 314
 315   /* Check to see if we're adding support for Tcl8 nspaces */
 316   if (nspace) {
 317     fprintf(f_init,"#if (TCL_MAJOR_VERSION >= 8)\n");
 318     fprintf(f_init,"\t Tcl_Eval(%s,\"namespace eval %s { }\");\n", interp_name, ns_name);
 319     fprintf(f_init,"#endif\n");
 320   }
 321 }
 322
 323 // ---------------------------------------------------------------------
 324 // TCL::close(void)
 325 //
 326 // Wrap things up.  Close initialization function.
 327 // ---------------------------------------------------------------------
 328
 329 void TCL::close(void)
 330 {
 331
 332   // Dump the pointer equivalency table
 333
 334   emit_ptr_equivalence(f_init);
 335
 336   // Close the init file and quit
 337   fprintf(f_init,"%s",postinit.get());
 338   fprintf(f_init,"\t return TCL_OK;\n");
 339   fprintf(f_init,"}\n");
 340 }
 341
 342 // ----------------------------------------------------------------------
 343 // TCL::get_pointer(char *iname, char *srcname, char *src, char *dest,
 344 //                  DataType *t, String &f, char *ret)
 345 //
 346 // iname     = name of function or variable
 347 // srcname   = name of source
 348 // src       = source variable in wrapper code
 349 // dest      = destination variable in wrapper code
 350 // t         = Datatype
 351 // f         = String where output is going to go
 352 // ret       = Return action
 353 // ----------------------------------------------------------------------
 354
 355 void TCL::get_pointer(char *iname, char *srcname, char *src, char *dest,
 356                       DataType *t, String &f, char *ret) {
 357
 358   // Pointers are read as hex-strings with encoded type information
 359
 360   f << tab4 << "if (SWIG_GetPtr(" << src << ",(void **) &" << dest << ",";
 361
 362   if (t->type == T_VOID) f << "(char *) 0)) {\n";
 363   else
 364     f << "\"" << t->print_mangle() << "\")) {\n";
 365
 366   // Now emit code according to the level of strictness desired
 367
 368   switch(TypeStrict) {
 369   case 0: // No type checking
 370     f << tab4 << "}\n";
 371     break;
 372   case 1: // Warning message only
 373     f << tab8 << "fprintf(stderr,\"Warning : type mismatch in " << srcname
 374       << " of " << iname << ". Expected " << t->print_mangle()
 375       << ", received %s\\n\"," << src << ");\n"
 376       << tab4 << "}\n";
 377   case 2: // Super strict mode.
 378     f << tab8 << "Tcl_SetResult(interp, \"Type error in " << srcname << " of " << iname
 379       << ". Expected " << t->print_mangle() << ", received \", TCL_STATIC);\n"
 380       << tab8 << "Tcl_AppendResult(interp, " << src << ", (char *) NULL);\n"
 381       << tab8 << ret << ";\n"
 382       << tab4 << "}\n";
 383     break;
 384   default :
 385     fprintf(stderr,"Unknown strictness level\n");
 386     break;
 387   }
 388 }
 389
 390 // ----------------------------------------------------------------------
 391 // TCL::create_command(char *cname, char *iname)
 392 //
 393 // Creates a Tcl command from a C function.
 394 // ----------------------------------------------------------------------
 395
 396 void TCL::create_command(char *cname, char *iname) {
 397
 398
 399   char *wname = name_wrapper(cname,prefix);
 400
 401   fprintf(f_init,"\t Tcl_CreateCommand(%s,SWIG_prefix \"%s\",%s, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);\n", interp_name, iname, wname);
 402
 403   // Add interpreter name to repeatcmd hash table.  This hash is used in C++ code
 404   // generation to try and find repeated wrapper functions.
 405
 406   repeatcmd.add(iname,copy_string(wname));
 407 }
 408
 409 // ----------------------------------------------------------------------
 410 // TCL::create_function(char *name, char *iname, DataType *d, ParmList *l)
 411 //
 412 // Create a function declaration and register it with the interpreter.
 413 // ----------------------------------------------------------------------
 414
 415 void TCL::create_function(char *name, char *iname, DataType *d, ParmList *l)
 416 {
 417   Parm            *p;
 418   int              pcount,i,j;
 419   char             *wname;
 420   char            *usage = 0;
 421   char             source[256], target[256], argnum[32], *tm;
 422   String           cleanup, outarg;
 423   int              numopt;
 424   int              have_build = 0;        // Status indicating build typemap
 425   String           build;
 426
 427   WrapperFunction  f;
 428
 429   // Make a wrapper name for this function
 430
 431   wname = name_wrapper(iname,prefix);
 432
 433   // Now write the wrapper function itself....this is pretty ugly
 434
 435   f.def << "static int " << wname << "(ClientData clientData, Tcl_Interp *interp, int argc, char *argv[]) {\n";
 436   f.code << tab4 << "clientData = clientData; argv = argv;\n";
 437
 438   // Print out variables for storing arguments.
 439
 440   pcount = emit_args(d, l, f);
 441
 442   // Get number of optional arguments
 443
 444   numopt = l->numopt();
 445
 446   // Check the number of arguments
 447
 448   usage = usage_func(iname,d,l);       // Create a usage string
 449   f.code << tab4 << "if ((argc < " << (pcount-numopt) +1 << ") || (argc > " << l->numarg()+1 << ")) {\n"
 450          << tab8 << "Tcl_SetResult(interp, \"Wrong # args. " << usage << "\",TCL_STATIC);\n"
 451          << tab8 << "return TCL_ERROR;\n"
 452          << tab4 << "}\n";
 453
 454   // Extract parameters.    This case statement should be used to extract
 455   // Function parameters.   Add more cases if you want to do more.
 456
 457   i = 0;
 458   j = 0;
 459   p = l->get_first();
 460   while (p != 0) {
 461     // Produce string representations of the source and target arguments
 462     sprintf(source,"argv[%d]",j+1);
 463     sprintf(target,"_arg%d",i);
 464     sprintf(argnum,"%d",j+1);
 465
 466     // See if this argument is being ignored
 467
 468     if (!p->ignore) {
 469       if (j >= (pcount-numopt))
 470         f.code << tab4 << "if (argc >" << j+1 << ") { \n";
 471
 472       // See if there is a type-mapping
 473
 474       if ((tm = typemap_lookup("in","tcl",p->t,p->name,source,target,&f))) {
 475         // Yep.  Use it instead of the default
 476         f.code << tm << "\n";
 477         f.code.replace("$argnum",argnum);
 478         f.code.replace("$arg",source);
 479       } else {
 480
 481         if (!p->t->is_pointer) {
 482
 483           // Extract a parameter by value.
 484
 485           switch(p->t->type) {
 486
 487             // Signed Integers
 488
 489           case T_BOOL:
 490           case T_INT:
 491           case T_SINT:
 492           case T_SHORT:
 493           case T_SSHORT:
 494           case T_LONG:
 495           case T_SLONG:
 496           case T_SCHAR:
 497             f.code << tab4 << "_arg" << i << " = " << p->t->print_cast() << " atol(argv[" << j+1 << "]);\n";
 498             break;
 499
 500             // Unsigned Integers
 501
 502           case T_UINT:
 503           case T_USHORT:
 504           case T_ULONG:
 505           case T_UCHAR:
 506             f.code << tab4 << "_arg" << i << " = " << p->t->print_cast() << " strtoul(argv[" << j+1
 507                    << "],(char **) NULL,0);\n";
 508             break;
 509
 510             // Floating point
 511
 512           case T_FLOAT:
 513           case T_DOUBLE:
 514             f.code << tab4 << "_arg" << i << " = " << p->t->print_cast() << " atof(argv[" << j+1 << "]);\n";
 515             break;
 516
 517             // A single character
 518
 519           case T_CHAR :
 520             f.code << tab4 << "_arg" << i << " = *argv[" << j+1 << "];\n";
 521             break;
 522
 523             // Void.. Do nothing.
 524
 525           case T_VOID :
 526             break;
 527
 528             // User defined.   This is an error.
 529
 530           case T_USER:
 531
 532             // Unsupported data type
 533
 534           default :
 535             fprintf(stderr,"%s : Line %d: Unable to use type %s as a function argument.\n",
 536                     input_file, line_number, p->t->print_type());
 537             break;
 538           }
 539         } else { /* Pointer type */
 540
 541           // Function argument is some sort of pointer
 542           // Look for a string.   Otherwise, just pull off a pointer.
 543
 544           if ((p->t->type == T_CHAR) && (p->t->is_pointer == 1)) {
 545             f.code << tab4 << "_arg" << i << " = argv[" << j+1 << "];\n";
 546           } else {
 547
 548             // Have a generic pointer type here.    Read it in as
 549             // a hex-string
 550
 551             char arg_temp[256];
 552             sprintf(arg_temp,"argument %d",j+1);
 553             get_pointer(iname,arg_temp,source,target,p->t,f.code,"return TCL_ERROR");
 554           }
 555         }
 556       }
 557       if (j >= (pcount-numopt))
 558         f.code << tab4 << "} \n";
 559       j++;
 560     }
 561
 562     // Check to see if there is any sort of "build" typemap (highly complicated)
 563
 564     if ((tm = typemap_lookup("build","tcl",p->t,p->name,source,target))) {
 565       build << tm << "\n";
 566       have_build = 1;
 567     }
 568
 569     // Check to see if there was any sort of a constaint typemap
 570     if ((tm = typemap_lookup("check","tcl",p->t,p->name,source,target))) {
 571       // Yep.  Use it instead of the default
 572       f.code << tm << "\n";
 573       f.code.replace("$argnum",argnum);
 574       f.code.replace("$arg",source);
 575     }
 576
 577     // Check if there was any cleanup code (save it for later)
 578     if ((tm = typemap_lookup("freearg","tcl",p->t,p->name,target,"interp->result"))) {
 579       // Yep.  Use it instead of the default
 580       cleanup << tm << "\n";
 581       cleanup.replace("$argnum",argnum);
 582       cleanup.replace("$arg",source);
 583     }
 584     if ((tm = typemap_lookup("argout","tcl",p->t,p->name,target,"interp->result"))) {
 585       // Yep.  Use it instead of the default
 586       outarg << tm << "\n";
 587       outarg.replace("$argnum",argnum);
 588       outarg.replace("$arg",source);
 589     }
 590     p = l->get_next();   // Get next parameter and continue
 591     i++;
 592   }
 593
 594   // If there was a "build" typemap, we need to go in and perform a serious hack
 595
 596   if (have_build) {
 597     char temp1[32];
 598     char temp2[256];
 599     l->sub_parmnames(build);            // Replace all parameter names
 600     j = 1;
 601     for (i = 0; i < l->nparms; i++) {
 602       p = l->get(i);
 603       if (strlen(p->name) > 0) {
 604         sprintf(temp1,"_in_%s", p->name);
 605       } else {
 606         sprintf(temp1,"_in_arg%d", i);
 607       }
 608       sprintf(temp2,"argv[%d]",j);
 609       build.replaceid(temp1,temp2);
 610       if (!p->ignore)
 611         j++;
 612     }
 613     f.code << build;
 614   }
 615
 616   // Now write code to make the function call
 617
 618   emit_func_call(name,d,l,f);
 619
 620   // Return value if necessary
 621
 622   if ((tm = typemap_lookup("out","tcl",d,name,"_result","interp->result"))) {
 623     // Yep.  Use it instead of the default
 624     f.code << tm << "\n";
 625   } else if ((d->type != T_VOID) || (d->is_pointer)) {
 626     // Normal SWIG mappings
 627
 628     if (!d->is_pointer) {
 629
 630       // Function returns a "value"
 631
 632       switch(d->type) {
 633         // Is a signed integer
 634       case T_BOOL:
 635       case T_INT:
 636       case T_SINT:
 637       case T_SHORT:
 638       case T_SSHORT:
 639       case T_LONG :
 640       case T_SLONG:
 641       case T_SCHAR:
 642         f.code << tab4 << "sprintf(interp->result,\"%ld\", (long) _result);\n";
 643         break;
 644
 645         // Is an unsigned integer
 646       case T_UINT:
 647       case T_USHORT:
 648       case T_ULONG:
 649       case T_UCHAR:
 650         f.code << tab4 << "sprintf(interp->result,\"%lu\", (unsigned long) _result);\n";
 651         break;
 652
 653         // Is a single character.  Assume we return it as a string
 654       case T_CHAR :
 655         f.code << tab4 << "sprintf(interp->result,\"%c\", _result);\n";
 656         break;
 657
 658         // Floating point number
 659       case T_DOUBLE :
 660       case T_FLOAT :
 661         f.code << tab4 << "Tcl_PrintDouble(interp,(double) _result, interp->result);\n";
 662         //sprintf(interp->result,\"%0.17f\",(double) _result);\n";
 663         break;
 664
 665         // User defined type
 666       case T_USER :
 667
 668         // Okay. We're returning malloced memory at this point.
 669         // Probably dangerous, but what the hell
 670
 671         d->is_pointer++;
 672         f.code << tab4 << "SWIG_MakePtr(interp->result, (void *) _result,\"" << d->print_mangle()
 673                << "\");\n";
 674         d->is_pointer--;
 675         break;
 676
 677         // Unknown type
 678       default :
 679         fprintf(stderr,"%s : Line %d: Unable to use return type %s in function %s.\n",
 680                 input_file, line_number, d->print_type(), name);
 681         break;
 682       }
 683     } else {
 684
 685       // Is a pointer return type
 686
 687       if ((d->type == T_CHAR) && (d->is_pointer == 1)) {
 688         // Return a character string
 689         f.code << tab4 << "Tcl_SetResult(interp, (char *) _result, " << char_result << ");\n";
 690       } else {
 691         f.code << tab4 << "SWIG_MakePtr(interp->result, (void *) _result,\"" << d->print_mangle() << "\");\n";
 692       }
 693     }
 694   }
 695
 696   // Dump argument output code;
 697   f.code << outarg;
 698
 699   // Dump the argument cleanup code
 700   f.code << cleanup;
 701
 702   // Look for any remaining cleanup
 703
 704   if (NewObject) {
 705     if ((tm = typemap_lookup("newfree","tcl",d,iname,"_result",""))) {
 706       f.code << tm << "\n";
 707     }
 708   }
 709
 710   if ((tm = typemap_lookup("ret","tcl",d,name,"_result",""))) {
 711     // Yep.  Use it instead of the default
 712     f.code << tm << "\n";
 713   }
 714
 715   // Wrap things up (in a manner of speaking)
 716
 717   f.code << tab4 << "return TCL_OK;\n}";
 718
 719   // Substitute the cleanup code
 720   f.code.replace("$cleanup",cleanup);
 721   f.code.replace("$name",iname);
 722
 723   // Dump out the function
 724
 725   f.print(f_wrappers);
 726
 727   // Add interpreter name to repeatcmd hash table.  This hash is used in C++ code
 728   // generation to try and find repeated wrapper functions.
 729
 730   fprintf(f_init,"\t Tcl_CreateCommand(%s, SWIG_prefix \"%s\", %s, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);\n", interp_name, iname, wname);
 731
 732   // If there's a documentation entry, produce a usage string
 733
 734   if (doc_entry) {
 735
 736     static DocEntry *last_doc_entry = 0;
 737
 738     // Use usage as description
 739     doc_entry->usage << usage;
 740
 741     // Set the cinfo field to specific a return type
 742
 743     if (last_doc_entry != doc_entry) {
 744       doc_entry->cinfo << "returns " << d->print_type();
 745       last_doc_entry = doc_entry;
 746     }
 747   }
 748 }
 749
 750 // -----------------------------------------------------------------------
 751 // TCL::link_variable(char *name, char *iname, DataType *t,
 752 //                           int ex)
 753 //
 754 // Create a TCL link to a variable.
 755 // -----------------------------------------------------------------------
 756
 757 void TCL::link_variable(char *name, char *iname, DataType *t)
 758 {
 759
 760   String    s;
 761   char *tm,*tm1;
 762   String    realname;
 763
 764
 765   // See if there were any typemaps
 766
 767   tm = typemap_lookup("varin","tcl",t,name,"","");
 768   tm1 = typemap_lookup("varout","tcl",t,name,"","");
 769   if (tm || tm1) {
 770     fprintf(stderr,"%s : Line %d. Warning. varin/varout typemap methods not supported.",
 771             input_file, line_number);
 772   }
 773
 774   // Check the datatype.  Must be a valid Tcl type (there aren't many)
 775
 776   if (((t->type == T_INT) && (!t->is_pointer)) ||
 777       ((t->type == T_UINT) && (!t->is_pointer)) ||
 778       ((t->type == T_SINT) && (!t->is_pointer)) ||
 779       ((t->type == T_DOUBLE) && (!t->is_pointer)) ||
 780       ((t->type == T_BOOL) && (!t->is_pointer)) ||
 781       ((t->type == T_CHAR) && (t->is_pointer == 1))) {
 782
 783     // This is a valid TCL type.
 784
 785     if (t->type == T_UINT)
 786       fprintf(stderr,"%s : Line %d : ** Warning. Linkage of unsigned type may be unsafe.\n",
 787               input_file,  line_number);
 788
 789     // Now add symbol to the TCL interpreter
 790
 791     switch(t->type) {
 792     case T_CHAR :
 793       if (t->arraystr) {
 794         // Is an array.  We have to do something different
 795         fprintf(f_wrappers,"static char *tclvar%s = %s;\n",name,name);
 796         s << "(char *) &tclvar" << name << ", TCL_LINK_STRING";
 797       } else {
 798         s << "(char *) &" << name << ", TCL_LINK_STRING";
 799       }
 800       break;
 801     case T_BOOL:
 802     case T_INT :
 803     case T_UINT:
 804     case T_SINT:
 805       s << "(char *) &" << name << ", TCL_LINK_INT";
 806       break;
 807     case T_DOUBLE :
 808       s << "(char *) &" << name << ", TCL_LINK_DOUBLE";
 809       break;
 810     default :
 811       fprintf(f_init,"Fatal error. Internal error (Tcl:link_variable)\n");
 812       break;
 813     }
 814
 815     if (Status & STAT_READONLY)
 816       s << " | TCL_LINK_READ_ONLY);\n";
 817     else
 818       s << ");\n";
 819
 820     fprintf(f_init,"\t Tcl_LinkVar(%s, SWIG_prefix \"%s\", %s",interp_name, iname, s.get());
 821
 822     // Make a usage string for it
 823
 824     if (doc_entry) {
 825       doc_entry->usage << usage_var(iname,t);
 826       doc_entry->cinfo = "";
 827       doc_entry->cinfo << "Global : " << t->print_type() << " " << name;
 828     }
 829   } else {
 830
 831     // Have some sort of "other" type.
 832     // We're going to emit some functions to set/get it's value instead
 833
 834     emit_set_get(name,iname, t);
 835     if (doc_entry) {
 836       doc_entry->cinfo = "";
 837       doc_entry->cinfo << "Global : " << t->print_type() << " " << iname;
 838     }
 839
 840     // If shadow classes are enabled and we have a user-defined type
 841     // that we know about, create a command for it.
 842
 843     if (shadow) {
 844       if ((t->type == T_USER) && (t->is_pointer < 1)) {
 845         // See if the datatype is in our hash table
 846         if (hash.lookup(t->name)) {
 847           // Yep.  Try to create a command for it
 848           //      postinit << tab4 << "Tcl_CreateCommand(interp, SWIG_prefix \"" << iname << "\",Tcl" << (char *) hash.lookup(t->name)
 849           // << "MethodCmd, (ClientData)";
 850
 851           postinit << tab4 << "{\n"
 852                    << tab8 << "char cmd[] = \""
 853                    << (char *) hash.lookup(t->name) << " " << iname << " -this ["
 854                    << iname << "_get ]\";\n"
 855                    << tab8 << "Tcl_GlobalEval(interp,cmd);\n"
 856                    << tab4 << "}\n";
 857
 858           //      postinit << tab4 << "Tcl_GlobalEval(interp,\"set " << iname << " [" << iname << "_get ];"
 859           //               << (char *) hash.lookup(t->name) << " -this $" << iname << "\");\n";
 860
 861         }
 862       }
 863     }
 864   }
 865 }
 866
 867 // -----------------------------------------------------------------------
 868 // TCL::declare_const(char *name, char *iname, DataType *type, char *value)
 869 //
 870 // Makes a constant.  Really just creates a variable and links to it.
 871 // Tcl variable linkage allows read-only variables so we'll use that
 872 // instead of just creating a Tcl variable.
 873 // ------------------------------------------------------------------------
 874
 875 void TCL::declare_const(char *name, char *, DataType *type, char *value) {
 876
 877   int OldStatus = Status;      // Save old status flags
 878   DataType *t;
 879   char   var_name[256];
 880   char     *tm;
 881   String   rvalue;
 882
 883   Status = STAT_READONLY;      // Enable readonly mode.
 884
 885   // Make a static variable;
 886
 887   sprintf(var_name,"_wrap_const_%s",name);
 888
 889   // See if there's a typemap
 890
 891   rvalue = value;
 892   if ((type->type == T_CHAR) && (type->is_pointer == 1)) {
 893     rvalue << "\"";
 894     "\"" >> rvalue;
 895   }
 896   if ((type->type == T_CHAR) && (type->is_pointer == 0)) {
 897     rvalue << "'";
 898     "'" >> rvalue;
 899   }
 900   if ((tm = typemap_lookup("const","tcl",type,name,rvalue.get(),name))) {
 901     // Yep.  Use it instead of the default
 902     fprintf(f_init,"%s\n",tm);
 903   } else {
 904
 905     // Create variable and assign it a value
 906
 907     if (type->is_pointer == 0) {
 908       switch(type->type) {
 909       case T_BOOL: case T_INT: case T_SINT: case T_DOUBLE:
 910         fprintf(f_header,"static %s %s = %s;\n", type->print_type(), var_name, value);
 911         link_variable(var_name,name,type);
 912         break;
 913       case T_SHORT:
 914       case T_LONG:
 915       case T_SSHORT:
 916       case T_SCHAR:
 917       case T_SLONG:
 918         fprintf(f_header,"static %s %s = %s;\n", type->print_type(), var_name, value);
 919         fprintf(f_header,"static char *%s_char;\n", var_name);
 920         if (CPlusPlus)
 921           fprintf(f_init,"\t %s_char = new char[32];\n",var_name);
 922         else
 923           fprintf(f_init,"\t %s_char = (char *) malloc(32);\n",var_name);
 924
 925         fprintf(f_init,"\t sprintf(%s_char,\"%%ld\", (long) %s);\n", var_name, var_name);
 926         sprintf(var_name,"%s_char",var_name);
 927         t = new DataType(T_CHAR);
 928         t->is_pointer = 1;
 929         link_variable(var_name,name,t);
 930         delete t;
 931         break;
 932       case T_UINT:
 933       case T_USHORT:
 934       case T_ULONG:
 935       case T_UCHAR:
 936         fprintf(f_header,"static %s %s = %s;\n", type->print_type(), var_name, value);
 937         fprintf(f_header,"static char *%s_char;\n", var_name);
 938         if (CPlusPlus)
 939           fprintf(f_init,"\t %s_char = new char[32];\n",var_name);
 940         else
 941           fprintf(f_init,"\t %s_char = (char *) malloc(32);\n",var_name);
 942
 943         fprintf(f_init,"\t sprintf(%s_char,\"%%lu\", (unsigned long) %s);\n", var_name, var_name);
 944         sprintf(var_name,"%s_char",var_name);
 945         t = new DataType(T_CHAR);
 946         t->is_pointer = 1;
 947         link_variable(var_name,name,t);
 948         delete t;
 949         break;
 950       case T_FLOAT:
 951         type->type = T_DOUBLE;
 952         strcpy(type->name,"double");
 953         fprintf(f_header,"static %s %s = %s (%s);\n", type->print_type(), var_name, type->print_cast(), value);
 954         link_variable(var_name,name,type);
 955         break;
 956
 957       case T_CHAR:
 958         type->is_pointer++;
 959         fprintf(f_header,"static %s %s = \"%s\";\n", type->print_type(), var_name, value);
 960         link_variable(var_name,name,type);
 961         type->is_pointer--;
 962         break;
 963       default:
 964         fprintf(stderr,"%s : Line %d. Unsupported constant value.\n", input_file, line_number);
 965         break;
 966       }
 967     } else {
 968       // Have some sort of pointer value here
 969       if ((type->type == T_CHAR) && (type->is_pointer == 1)) {
 970         // Character string
 971         fprintf(f_header,"static %s %s = \"%s\";\n", type->print_type(), var_name, value);
 972         link_variable(var_name,name,type);
 973       } else {
 974         // Something else.   Some sort of pointer value
 975         fprintf(f_header,"static %s %s = %s;\n", type->print_type(), var_name, value);
 976         fprintf(f_header,"static char *%s_char;\n", var_name);
 977         if (CPlusPlus)
 978           fprintf(f_init,"\t %s_char = new char[%d];\n",var_name,(int) strlen(type->print_mangle())+ 20);
 979         else
 980           fprintf(f_init,"\t %s_char = (char *) malloc(%d);\n",var_name,(int) strlen(type->print_mangle())+ 20);
 981
 982         t = new DataType(T_CHAR);
 983         t->is_pointer = 1;
 984         fprintf(f_init,"\t SWIG_MakePtr(%s_char, (void *) %s,\"%s\");\n",
 985                 var_name, var_name, type->print_mangle());
 986         sprintf(var_name,"%s_char",var_name);
 987         link_variable(var_name,name,t);
 988         delete t;
 989       }
 990     }
 991   }
 992
 993   // Create a documentation entry for this
 994
 995   if (doc_entry) {
 996     doc_entry->usage = "";       // Destroy any previous information from linking
 997     doc_entry->usage << usage_const(name, type, value);
 998     doc_entry->cinfo = "";
 999     doc_entry->cinfo << "Constant : " << type->print_type();
1000   }
1001   Status = OldStatus;
1002 }
1003
1004 // ----------------------------------------------------------------------
1005 // TCL::usage_var(char *iname, DataType *t, char **s)
1006 //
1007 // Produces a usage string for a tcl variable.  Stores it in s
1008 // ----------------------------------------------------------------------
1009
1010 char *TCL::usage_var(char *iname, DataType *t) {
1011
1012   static String temp;
1013
1014   temp = "";
1015   if (!nspace) {
1016     temp << "$" << prefix << iname;
1017   } else {
1018     temp << ns_name << "::" << iname;
1019   }
1020   if (!(((t->type == T_INT) && (!t->is_pointer)) ||
1021         ((t->type == T_UINT) && (!t->is_pointer)) ||
1022         ((t->type == T_DOUBLE) && (!t->is_pointer)) ||
1023         ((t->type == T_BOOL) && (!t->is_pointer)) ||
1024         ((t->type == T_CHAR) && (t->is_pointer)))) {
1025     /* We emitted a pair of set/get functions instead.  Doc will be generated for that */
1026     return temp;
1027   }
1028   return temp;
1029 }
1030
1031
1032 // ---------------------------------------------------------------------------
1033 // char *TCL::usage_string(char *iname, DataType *t, ParmList *l),
1034 //
1035 // Generates a generic usage string for a Tcl function.
1036 // ---------------------------------------------------------------------------
1037
1038 char * TCL::usage_string(char *iname, DataType *, ParmList *l) {
1039
1040   static String temp;
1041   Parm  *p;
1042   int   i, numopt,pcount;
1043
1044   temp = "";
1045   temp << iname << " ";
1046
1047   /* Now go through and print parameters */
1048   i = 0;
1049   pcount = l->nparms;
1050   numopt = l->numopt();
1051   p = l->get_first();
1052   while (p != 0) {
1053
1054     // Only print an argument if not ignored
1055
1056     if (!typemap_check("ignore","tcl",p->t,p->name)) {
1057       if (i >= (pcount-numopt))
1058         temp << "?";
1059
1060       /* If parameter has been named, use that.   Otherwise, just print a type  */
1061
1062       if ((p->t->type != T_VOID) || (p->t->is_pointer)) {
1063         if (strlen(p->name) > 0) {
1064           temp << p->name;
1065         }
1066         else {
1067           temp << "{ " << p->t->print_type() << " }";
1068         }
1069       }
1070       if (i >= (pcount-numopt))
1071         temp << "?";
1072       temp << " ";
1073       i++;
1074     }
1075     p = l->get_next();
1076   }
1077   return temp;
1078 }
1079
1080 // ---------------------------------------------------------------------------
1081 // char *TCL::usage_func(char *iname, DataType *t, ParmList *l),
1082 //
1083 // Produces a usage string for a function in Tcl
1084 // ---------------------------------------------------------------------------
1085
1086 char * TCL::usage_func(char *iname, DataType *t, ParmList *l) {
1087
1088   String temp;
1089
1090   if (nspace) {
1091     temp << ns_name << "::" << iname;
1092   } else {
1093     temp << prefix << iname;
1094   }
1095   return usage_string(temp,t,l);
1096 }
1097
1098 // -----------------------------------------------------------------
1099 // TCL::usage_const(char *name, DataType *type, char *value)
1100 //                         char **s)
1101 //
1102 // Makes a usage string and returns it
1103 // -----------------------------------------------------------------
1104
1105 char *TCL::usage_const(char *name, DataType *, char *value) {
1106   static String temp;
1107   temp = "";
1108   if (nspace) {
1109     temp << ns_name << "::" << name << " = " << value;
1110   } else {
1111     temp << "$" << prefix << name << " = " << value;
1112   }
1113   return temp;
1114 }
1115
1116 // -------------------------------------------------------------------
1117 // TCL::add_native(char *name, char *funcname)
1118 //
1119 // This adds an already written Tcl wrapper function to our
1120 // initialization function.
1121 // -------------------------------------------------------------------
1122
1123
1124 void TCL::add_native(char *name, char *funcname) {
1125
1126   fprintf(f_init,"\t Tcl_CreateCommand(%s, SWIG_prefix \"%s\", %s, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);\n",interp_name, name, funcname);
1127
1128   if (doc_entry) {
1129     if (nspace)
1130       doc_entry->usage << ns_name << "::" << name << " args";
1131     else
1132       doc_entry->usage << prefix << name << " args";
1133
1134     doc_entry->cinfo << "Native method : " << funcname;
1135   }
1136
1137 }
1138
1139 // -------------------------------------------------------------------
1140 // TCL::pragma(char *lname, char *name, char *value)
1141 //
1142 // This is an experimental %pragma handler.  Officially unsupported
1143 // in this release, but requested in e-mail.
1144 // --------------------------------------------------------------------
1145
1146 void TCL::pragma(char *lname, char *name, char *) {
1147
1148   if (strcmp(lname,"tcl") == 0) {
1149     if (strcmp(name,"dynamic") == 0) {
1150       char_result = "TCL_DYNAMIC";
1151     } else if (strcmp(name,"static") == 0) {
1152       char_result = "TCL_STATIC";
1153     } else if (strcmp(name,"volatile") == 0) {
1154       char_result = "TCL_VOLATILE";
1155     }
1156   }
1157 }
1158
1159
1160 // ---------------------------------------------------------------------
1161 // C++ Handling
1162 //
1163 // The following functions provide some support for C++ classes and
1164 // C structs.
1165 // ---------------------------------------------------------------------
1166
1167 void TCL::cpp_open_class(char *classname, char *rename, char *ctype, int strip) {
1168   char temp[256];
1169   this->Language::cpp_open_class(classname,rename,ctype,strip);
1170
1171   if (shadow) {
1172
1173     config = "";
1174     cget = "";
1175     methods = "";
1176     options = "";
1177     config_options = "";
1178     methodnames = "";
1179
1180     have_constructor = 0;
1181     have_destructor = 0;
1182     have_methods = 0;
1183     have_config = 0;
1184     have_cget = 0;
1185
1186     if (rename)
1187       class_name = copy_string(rename);
1188     else
1189       class_name = copy_string(classname);
1190
1191     base_class = (char *) 0;
1192     if (!strip) {
1193       class_type = new char[strlen(ctype)+2];
1194       sprintf(class_type,"%s ", ctype);
1195     } else
1196       class_type = "";
1197
1198     real_classname = copy_string(classname);
1199
1200     // Build up the hash table
1201
1202     hash.add(real_classname,copy_string(class_name));
1203     sprintf(temp,"%s %s", class_type, real_classname);
1204     hash.add(temp,copy_string(class_name));
1205   }
1206 }
1207
1208 void TCL::cpp_close_class() {
1209   String code;
1210   DataType *t;
1211   String temp;
1212
1213   this->Language::cpp_close_class();
1214   if (shadow) {
1215
1216     t = new DataType;
1217     sprintf(t->name,"%s%s", class_type, real_classname);
1218     t->type = T_USER;
1219     t->is_pointer = 1;
1220
1221     // Note : The object oriented interface is defined by three files
1222     //     delcmd.swg          - Object deletion wrapper
1223     //     methodcmd.swg       - Method invocation command
1224     //     objcmd.swg          - Command to create a new object
1225     //
1226     // These files are located in the SWIG library.  This module
1227     // grabs the files and performs marker replacements to
1228     // build the wrapper function.
1229
1230     // Generate a Tcl function for object destruction
1231
1232     if (have_destructor) {
1233       code << delcmd;
1234     }
1235
1236     // Dump out method code
1237     code << methodcmd;
1238
1239     // Dump out object creation command
1240     code << objcmd;
1241
1242     // Now perform marker replacements
1243     code.replace("@CLASS@",class_name);
1244     temp = "";
1245     temp << name_destroy(class_name);
1246     code.replace("@DESTRUCTOR@",temp);
1247     code.replace("@CLASSTYPE@",t->print_type());
1248     "configure " >> methodnames;
1249     "cget " >> methodnames;
1250     code.replace("@METHODLIST@", methodnames);
1251     code.replace("@CLASSMANGLE@",t->print_mangle());
1252     code.replace("@METHODS@",methods);
1253     code.replace("@CONFIGMETHODS@",config);
1254     code.replace("@CGETMETHODS@",cget);
1255     if (have_constructor) {
1256       temp = "";
1257       temp << name_wrapper(name_construct(class_name),prefix);
1258     } else {
1259       temp = "0";
1260     }
1261     code.replace("@TCLCONSTRUCTOR@",temp);
1262     code.replace("@CONFIGLIST@",config_options);
1263     code.replace("@CGETLIST@",options);
1264     if (have_destructor) {
1265       temp = "TclDelete";
1266       temp << class_name;
1267     } else {
1268       temp = "0";
1269     }
1270     code.replace("@TCLDESTRUCTOR@",temp);
1271     fprintf(f_wrappers,"%s\n", code.get());
1272     fprintf(f_init,"\t Tcl_CreateCommand(interp, SWIG_prefix \"%s\",Tcl%sCmd, (ClientData) NULL, NULL);\n", class_name, class_name);
1273   }
1274 }
1275
1276 void TCL::cpp_member_func(char *name, char *iname, DataType *t, ParmList *l) {
1277
1278   char *realname;
1279   String temp;
1280   char *rname;
1281
1282   this->Language::cpp_member_func(name,iname,t,l);
1283
1284   if (shadow) {
1285     if (iname)
1286       realname = iname;
1287     else
1288       realname = name;
1289
1290     // Add stubs for this member to our class handler function
1291
1292     if (have_methods)
1293       methods << tab4 << "else ";
1294     else
1295       methods << tab4;
1296
1297     // Try to figure out if there is a wrapper for this function
1298
1299     temp = "";
1300     temp << name_member(realname,class_name);
1301
1302     rname = (char *) repeatcmd.lookup(temp);
1303
1304     if (!rname)
1305       rname = name_wrapper(temp.get(),prefix);
1306
1307     methods << "if (strcmp(argv[1],\"" << realname << "\") == 0) {\n"
1308             << tab4 << tab4 << "cmd = " << rname << ";\n"
1309             << tab4 << "}";
1310
1311     have_methods = 1;
1312     methodnames << realname << " ";
1313
1314     if (doc_entry) {
1315       doc_entry->usage = "";
1316       doc_entry->usage << usage_string(realname,t,l);
1317     }
1318   }
1319 }
1320
1321 void TCL::cpp_variable(char *name, char *iname, DataType *t) {
1322   char *realname;
1323   String temp, temp1;
1324   char *rname;
1325
1326   this->Language::cpp_variable(name, iname, t);
1327
1328   if (shadow) {
1329     if (iname)
1330       realname = iname;
1331     else
1332       realname = name;
1333
1334     // Write config code
1335
1336     char *bc = class_name;
1337
1338     if (!(Status & STAT_READONLY)) {
1339       if (!have_config) {
1340         config << tab8 << tab8;
1341       } else {
1342         config << " else ";
1343       }
1344
1345       temp = "";
1346       temp << name_set(name_member(realname,bc));
1347       rname = (char *) repeatcmd.lookup(temp);
1348       if (!rname)
1349         rname = name_wrapper(temp.get(),prefix);
1350
1351       config << "if (strcmp(argv[i],\"-" << realname << "\") == 0) {\n"
1352              << tab8 << tab8 << tab4 << "cmd = " << rname << ";\n"
1353              << tab8 << tab8 << "} ";
1354
1355       have_config = 1;
1356     }
1357
1358     // Write cget code
1359
1360     if (!have_cget) {
1361       cget << tab8 << tab8;
1362     } else {
1363       cget << " else ";
1364     }
1365
1366     // Try to figure out if there is a wrapper for this function
1367     temp = "";
1368     temp << name_get(name_member(realname,bc));
1369     rname = (char *) repeatcmd.lookup(temp);
1370     if (!rname)
1371       rname = name_wrapper(temp.get(),prefix);
1372
1373     cget << "if (strcmp(argv[2],\"-" << realname << "\") == 0) {\n"
1374          << tab8 << tab8 << tab4 << "cmd = " << rname << ";\n"
1375          << tab8 << tab8 << "} ";
1376     have_cget = 1;
1377
1378     options << "-" << realname << " ";
1379     if (!(Status & STAT_READONLY)) {
1380       config_options << "-" << realname << " ";
1381     }
1382     if (doc_entry){
1383       doc_entry->usage = "";
1384       doc_entry->usage << "-" << realname << "\n";
1385     }
1386   }
1387 }
1388
1389 void TCL::cpp_constructor(char *name, char *iname, ParmList *l) {
1390   this->Language::cpp_constructor(name,iname,l);
1391
1392   if (shadow) {
1393     if ((!have_constructor) && (doc_entry)) {
1394       doc_entry->usage = "";
1395       doc_entry->usage << class_name << usage_string(" name",0,l);
1396     }
1397     have_constructor = 1;
1398   }
1399 }
1400 void TCL::cpp_destructor(char *name, char *newname) {
1401   this->Language::cpp_destructor(name,newname);
1402   if (shadow) {
1403     if (!have_destructor) {
1404       if (doc_entry) {
1405         doc_entry->usage = "rename obj {}";
1406       }
1407     }
1408     have_destructor = 1;
1409   }
1410 }
1411
1412 void TCL::cpp_inherit(char **baseclass, int) {
1413   this->Language::cpp_inherit(baseclass);
1414 }
1415
1416 void TCL::cpp_declare_const(char *name, char *iname, DataType *type, char *value) {
1417   this->Language::cpp_declare_const(name,iname,type,value);
1418 }
1419
1420
1421 // --------------------------------------------------------------------------------
1422 // TCL::add_typedef(DataType *t, char *name)
1423 //
1424 // This is called whenever a typedef is encountered.   When shadow classes are
1425 // used, this function lets us discovered hidden uses of a class.  For example :
1426 //
1427 //     struct FooBar {
1428 //            ...
1429 //     }
1430 //
1431 // typedef FooBar *FooBarPtr;
1432 //
1433 // --------------------------------------------------------------------------------
1434
1435 void TCL::add_typedef(DataType *t, char *name) {
1436
1437   if (!shadow) return;
1438
1439   // First check to see if there aren't too many pointers
1440
1441   if (t->is_pointer > 1) return;
1442   if (hash.lookup(name)) return;      // Already added
1443
1444   // Now look up the datatype in our shadow class hash table
1445
1446   if (hash.lookup(t->name)) {
1447
1448     // Yep.   This datatype is in the hash
1449     // Put this types 'new' name into the hash
1450     hash.add(name,copy_string((char *) hash.lookup(t->name)));
1451   }
1452 }
1453
1454 // -----------------------------------------------------------------------
1455 // TCL::cpp_class_decl(char *name, char *rename, char *type)
1456 //
1457 // Treatment of an empty class definition.    Used to handle
1458 // shadow classes across modules.
1459 // -----------------------------------------------------------------------
1460
1461 void TCL::cpp_class_decl(char *name, char *rename, char *type) {
1462   char temp[256];
1463   this->Language::cpp_class_decl(name,rename, type);
1464   if (shadow) {
1465     hash.add(name,copy_string(rename));
1466     // Add full name of datatype to the hash table
1467     if (strlen(type) > 0) {
1468       sprintf(temp,"%s %s", type, name);
1469       hash.add(temp,copy_string(rename));
1470     }
1471   }
1472 }