wxPython/wxSWIG/Modules/guile.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  * guile.cxx
  20  *
  21  * Definitions for adding functions to Guile 3.0
  22  ***********************************************************************/
  23
  24 #include "swig.h"
  25 #include "guile.h"
  26
  27 static char *guile_usage = "\
  28 Guile Options (available with -guile)\n\
  29      None available. \n\n";
  30
  31 // ---------------------------------------------------------------------
  32 // GUILE::parse_args(int argc, char *argv[])
  33 //
  34 // Parse arguments.
  35 // ---------------------------------------------------------------------
  36
  37 void GUILE::parse_args(int argc, char *argv[]) {
  38
  39   int i;
  40
  41   sprintf(LibDir,"%s",guile_path);
  42
  43   // Look for certain command line options
  44
  45   // Look for additional command line options.
  46   for (i = 1; i < argc; i++) {
  47       if (argv[i]) {
  48           if (strcmp(argv[i],"-help") == 0) {
  49             fputs(guile_usage,stderr);
  50             SWIG_exit(0);
  51           }
  52       }
  53   }
  54   // Add a symbol for this module
  55
  56   add_symbol("SWIGGUILE",0,0);
  57
  58   // Set name of typemaps
  59
  60   typemap_lang = "guile";
  61
  62 }
  63
  64 // --------------------------------------------------------------------
  65 // GUILE::parse()
  66 //
  67 // Parse the input file
  68 // --------------------------------------------------------------------
  69
  70 void GUILE::parse()
  71 {
  72
  73   printf("Generating wrappers for Guile\n");
  74
  75   // Print out GUILE specific headers
  76
  77   headers();
  78
  79   // Run the parser
  80
  81   yyparse();
  82
  83 }
  84
  85 // ---------------------------------------------------------------------
  86 // GUILE::set_module(char *mod_name)
  87 //
  88 // Sets the module name.
  89 // Does nothing if it's already set (so it can be overridden as a command
  90 // line option).
  91 //
  92 //----------------------------------------------------------------------
  93
  94 void GUILE::set_module(char *mod_name, char **) {
  95
  96   if (module) return;
  97
  98   module = new char[strlen(mod_name)+1];
  99   strcpy(module,mod_name);
 100
 101 }
 102
 103 // ---------------------------------------------------------------------
 104 // GUILE::set_init(char *iname)
 105 //
 106 // Sets the initialization function name.
 107 // Does nothing if it's already set
 108 //
 109 //----------------------------------------------------------------------
 110
 111 void GUILE::set_init(char *iname) {
 112   set_module(iname,0);
 113 }
 114
 115 // ---------------------------------------------------------------------
 116 // GUILE::headers(void)
 117 //
 118 // Generate the appropriate header files for GUILE interface.
 119 // ----------------------------------------------------------------------
 120
 121 void GUILE::headers(void)
 122 {
 123
 124   emit_banner(f_header);
 125
 126   fprintf(f_header,"/* Implementation : GUILE */\n\n");
 127   fprintf(f_header,"#define SWIGGUILE\n");
 128   fprintf(f_header,"#include <stdio.h>\n");
 129   fprintf(f_header,"#include <string.h>\n");
 130   fprintf(f_header,"#include <stdlib.h>\n");
 131
 132   // Write out hex conversion functions
 133
 134   if (!NoInclude) {
 135       if (insert_file("guile.swg", f_header) == -1) {
 136           fprintf(stderr,"SWIG : Fatal error.  Unable to locate 'guile.swg' in SWIG library.\n");
 137           SWIG_exit(1);
 138       }
 139       emit_hex(f_header);
 140   } else {
 141     fprintf(f_header,"#ifdef __cplusplus\n");
 142     fprintf(f_header,"extern \"C\" {\n");
 143     fprintf(f_header,"#endif\n");
 144     fprintf(f_header,"extern void SWIG_MakePtr(char *, void *, char *);\n");
 145     fprintf(f_header,"extern void SWIG_RegisterMapping(char *, char *, void *(*)(void *));\n");
 146     fprintf(f_header,"extern char *SWIG_GetPtr(char *, void **, char *);\n");
 147     fprintf(f_header,"#ifdef __cplusplus\n");
 148     fprintf(f_header,"}\n");
 149     fprintf(f_header,"#endif\n");
 150   }
 151 }
 152
 153 // --------------------------------------------------------------------
 154 // GUILE::initialize()
 155 //
 156 // Output initialization code that registers functions with the
 157 // interface.
 158 // ---------------------------------------------------------------------
 159 void GUILE::initialize()
 160 {
 161
 162   int i;
 163
 164   if (!module) {
 165     module = "swig_init";
 166     fprintf(stderr,"SWIG : *** Warning. No module name specified.\n");
 167   }
 168
 169   fprintf(f_header,"#define SWIG_init    %s\n\n", module);
 170   fprintf(f_init,"void %s() {\n", module);
 171
 172   if (InitNames) {
 173     i = 0;
 174     while (InitNames[i]) {
 175       fprintf(f_init,"\t %s();\n",InitNames[i]);
 176       i++;
 177     }
 178   }
 179 }
 180
 181 // ---------------------------------------------------------------------
 182 // GUILE::close(void)
 183 //
 184 // Wrap things up.  Close initialization function.
 185 // ---------------------------------------------------------------------
 186
 187 void GUILE::close(void)
 188 {
 189
 190   emit_ptr_equivalence(f_init);
 191   fprintf(f_init,"}\n");
 192
 193 }
 194
 195 // ----------------------------------------------------------------------
 196 // GUILE::get_pointer(int parm, DataType *t)
 197 //
 198 // Emits code to get a pointer from a parameter and do type checking.
 199 // parm is the parameter number.   This function is only used
 200 // in create_function().
 201 // ----------------------------------------------------------------------
 202
 203 void GUILE::get_pointer(char *iname, int parm, DataType *t) {
 204
 205   // Pointers are read as hex-strings with encoded type information
 206   fprintf(f_wrappers,"\t _tempc = gh_scm2newstr(s_%d, &_len);\n",parm);
 207   fprintf(f_wrappers,"\t if (SWIG_GetPtr(_tempc, (void **) &_arg%d,",parm);
 208   if (t->type == T_VOID) fprintf(f_wrappers,"(char *) 0)) {\n");
 209   else
 210     fprintf(f_wrappers,"\"%s\")) {\n", t->print_mangle());
 211
 212   // Now emit code according to the level of strictness desired
 213
 214   switch(TypeStrict) {
 215   case 0: // No type checking
 216     fprintf(f_wrappers,"\t}\n");
 217     break;
 218   case 1: // Warning message only
 219     fprintf(f_wrappers,
 220       "\t fprintf(stderr,\"Warning : type mismatch in argument %d of %s. Expected %s, received %%s\\n\", _tempc);\n", parm+1,iname, t->print_mangle());
 221     fprintf(f_wrappers,"\t }\n");
 222     break;
 223   case 2: // Super strict mode.
 224
 225 //    fprintf(f_wrappers,"\t\t gscm_error(\"Type error in argument %d of %s. Expected %s.\", s_%d);\n", parm+1,iname,t->print_mangle(),parm);
 226     fprintf(f_wrappers,"\t}\n");
 227     break;
 228
 229   default :
 230     fprintf(stderr,"Unknown strictness level\n");
 231     break;
 232   }
 233 }
 234
 235 // ----------------------------------------------------------------------
 236 // GUILE::create_function(char *name, char *iname, DataType *d,
 237 //                             ParmList *l)
 238 //
 239 // Create a function declaration and register it with the interpreter.
 240 // ----------------------------------------------------------------------
 241
 242 void GUILE::create_function(char *name, char *iname, DataType *d, ParmList *l)
 243 {
 244
 245   Parm *p;
 246   int   pcount;
 247   char  wname[256];
 248   char  source[64];
 249   char  target[64];
 250   char  *tm;
 251   String cleanup;
 252   int need_len = 0;
 253   int need_tempc = 0;
 254
 255   // Make a wrapper name for this
 256
 257   strcpy(wname,iname);
 258   make_wrap_name(wname);
 259
 260   // Now write the wrapper function itself....this is pretty ugly
 261
 262   fprintf(f_wrappers,"SCM _wrap_gscm_%s(",wname);
 263
 264   int i = 0;
 265   p = l->get_first();
 266   while (p != 0) {
 267     if (p->t->is_pointer)
 268       need_len = 1;
 269     if ((p->t->type != T_CHAR) && (p->t->is_pointer))
 270       need_tempc = 1;
 271
 272     if ((p->t->type != T_VOID) || (p->t->is_pointer))
 273       fprintf(f_wrappers,"SCM s_%d", i);
 274     if ((p = l->get_next()))
 275        fprintf(f_wrappers,", ");
 276     i++;
 277   }
 278   fprintf(f_wrappers,")\n{\n");
 279
 280   // Declare return variable and arguments
 281
 282   pcount = emit_args(d,l,f_wrappers);
 283
 284   // Now declare a few helper variables here
 285   if (d->is_pointer && (d->type != T_CHAR) &&
 286       !typemap_lookup("out","guile",d,name,"_result","scmresult"))
 287     fprintf(f_wrappers,"  char _ptemp[128];\n");
 288   if (need_tempc)
 289     fprintf(f_wrappers,"  char *_tempc;\n");
 290   if (need_len)
 291     fprintf(f_wrappers,"  int _len;\n");
 292   fprintf(f_wrappers,"  SCM scmresult;  /* fun1 */\n");
 293
 294   // Now write code to extract the parameters(this is super ugly)
 295
 296   i = 0;
 297   p = l->get_first();
 298   while (p != 0) {
 299     // Produce names of source and target
 300     sprintf(source,"s_%d",i);
 301     sprintf(target,"_arg%d",i);
 302
 303     if ((tm = typemap_lookup("in","guile",p->t,p->name,source,target))) {
 304       // Yep.  Use it instead of the default
 305       fprintf(f_wrappers,"%s\n", tm);
 306     } else {
 307       if (!p->t->is_pointer) {
 308         switch(p->t->type) {
 309
 310           // Signed Integers
 311
 312         case T_INT :
 313         case T_SINT :
 314         case T_SHORT:
 315         case T_SSHORT:
 316         case T_LONG:
 317         case T_SLONG:
 318         case T_SCHAR:
 319           fprintf(f_wrappers,"\t _arg%d = %s gh_scm2long(s_%d);\n",i, p->t->print_cast(), i);
 320           break;
 321
 322           // Unsigned Integers
 323
 324         case T_UINT:
 325         case T_USHORT:
 326         case T_ULONG:
 327         case T_UCHAR:
 328           fprintf(f_wrappers,"\t _arg%d = %s gh_scm2ulong(s_%d);\n", i, p->t->print_cast(), i);
 329           break;
 330
 331           // A single character
 332
 333         case T_CHAR :
 334           fprintf(f_wrappers,"\t _arg%d = %s gh_scm2char(s_%d);\n", i, p->t->print_cast(), i);
 335           break;
 336
 337           // Floating point
 338
 339         case T_DOUBLE :
 340         case T_FLOAT:
 341           fprintf(f_wrappers,"\t _arg%d = %s gh_scm2double(s_%d);\n", i, p->t->print_cast(), i);
 342           break;
 343
 344           // Void.. Do nothing.
 345
 346         case T_VOID :
 347           break;
 348
 349           // This is some sort of user-defined call by value type.   We're
 350           // going to try and wing it here....
 351
 352         case T_USER:
 353
 354           // User defined type not allowed by value.
 355
 356         default :
 357           fprintf(stderr,"%s : Line %d. Unable to use type %s as a function argument.\n",
 358                   input_file, line_number, p->t->print_type());
 359           break;
 360         }
 361       } else {
 362
 363         // Argument is a pointer type.   Special case is for char *
 364         // since that is usually a string.
 365
 366         if ((p->t->type == T_CHAR) && (p->t->is_pointer == 1)) {
 367           fprintf(f_wrappers,"\t _arg%d = gh_scm2newstr(s_%d, &_len);\n",i,i);
 368         } else {
 369
 370           // Have a generic pointer type here.
 371
 372           get_pointer(iname, i, p->t);
 373         }
 374       }
 375     }
 376     if ((tm = typemap_lookup("check","guile",p->t,p->name,source,target))) {
 377       // Yep.  Use it instead of the default
 378       fprintf(f_wrappers,"%s\n",tm);
 379     }
 380     if ((tm = typemap_lookup("freearg","guile",p->t,p->name,target,"scmresult"))) {
 381       // Yep.  Use it instead of the default
 382       cleanup << tm << "\n";
 383     }
 384     p = l->get_next();
 385     i++;
 386   }
 387
 388   // Now write code to make the function call
 389
 390   fprintf(f_wrappers,"\t SCM_DEFER_INTS;\n");
 391   emit_func_call(name,d,l,f_wrappers);
 392
 393   fprintf(f_wrappers,"\t SCM_ALLOW_INTS;\n");
 394   // Now have return value, figure out what to do with it.
 395
 396   if ((d->type != T_VOID) || (d->is_pointer)) {
 397     if ((tm = typemap_lookup("out","guile",d,name,"_result","scmresult"))) {
 398       // Yep.  Use it instead of the default
 399       fprintf(f_wrappers,"%s\n",tm);
 400     } else {
 401       if (!d->is_pointer) {
 402         switch(d->type) {
 403         case T_INT:  case T_SINT:
 404         case T_SHORT: case T_SSHORT:
 405         case T_LONG: case T_SLONG:
 406         case T_SCHAR:
 407           fprintf(f_wrappers,"\t scmresult = gh_long2scm((long) _result);\n");
 408           break;
 409         case T_UINT:
 410         case T_USHORT:
 411         case T_ULONG:
 412         case T_UCHAR:
 413           fprintf(f_wrappers,"\t scmresult = gh_ulong2scm((unsigned long) _result);\n");
 414           break;
 415         case T_DOUBLE :
 416         case T_FLOAT:
 417           fprintf(f_wrappers,"\t scmresult = gh_double2scm((double) _result);\n");
 418           break;
 419         case T_CHAR :
 420           fprintf(f_wrappers,"\t scmresult = gh_char2scm(_result);\n");
 421           break;
 422         default:
 423           fprintf(stderr,"%s : Line %d: Unable to use return type %s in function %s.\n",
 424                   input_file, line_number, d->print_type(), name);
 425           break;
 426         }
 427       } else {
 428
 429         // Is a pointer return type
 430
 431         if ((d->type == T_CHAR) && (d->is_pointer == 1)) {
 432           fprintf(f_wrappers,"\t scmresult = gh_str02scm(_result);\n");
 433         } else {
 434
 435           // Is an ordinary pointer type.
 436
 437           fprintf(f_wrappers,"\t  SWIG_MakePtr(_ptemp, _result,\"%s\");\n",
 438                   d->print_mangle());
 439           fprintf(f_wrappers,"\t scmresult = gh_str02scm(_ptemp);\n");
 440         }
 441       }
 442     }
 443   } else {
 444     /* Some void type.   Need to return something.  I'll return 1 */
 445     fprintf(f_wrappers,"\t scmresult = gh_int2scm(1);\n");
 446   }
 447
 448   // Dump the argument cleanup code
 449   fprintf(f_wrappers,"%s\n",cleanup.get());
 450
 451   // Look for any remaining cleanup
 452
 453   if (NewObject) {
 454     if ((tm = typemap_lookup("newfree","guile",d,iname,"_result",""))) {
 455       fprintf(f_wrappers,"%s\n",tm);
 456     }
 457   }
 458
 459   if ((tm = typemap_lookup("ret","guile",d,name,"_result",""))) {
 460     // Yep.  Use it instead of the default
 461     fprintf(f_wrappers,"%s\n",tm);
 462   }
 463
 464   // Wrap things up (in a manner of speaking)
 465
 466   fprintf(f_wrappers,"\t return scmresult;\n");
 467   fprintf(f_wrappers,"}\n");
 468
 469   // Now register the function
 470   fprintf(f_init,"\t gh_new_procedure(\"%s\", _wrap_gscm_%s, %d, 0, 0);\n",
 471           iname, wname, pcount);
 472
 473   // Make a documentation entry for this
 474
 475   if (doc_entry) {
 476     static DocEntry *last_doc_entry = 0;
 477     char *usage = 0;
 478     usage_func(iname,d,l,&usage);
 479     doc_entry->usage << usage;
 480     if (last_doc_entry != doc_entry) {
 481       doc_entry->cinfo << "returns " << d->print_type();
 482       last_doc_entry = doc_entry;
 483     }
 484     delete usage;
 485   }
 486 }
 487
 488 // -----------------------------------------------------------------------
 489 // GUILE::link_variable(char *name, char *iname, DataType *d)
 490 //
 491 // Create a link to a C variable.
 492 // This creates a single function _wrap_gscm_var_varname().
 493 // This function takes a single optional argument.   If supplied, it means
 494 // we are setting this variable to some value.  If ommitted, it means we are
 495 // simply evaluating this variable.  Either way, we return the variables
 496 // value.
 497 // -----------------------------------------------------------------------
 498
 499 void GUILE::link_variable(char *name, char *iname, DataType *t)
 500 {
 501
 502   char  var_name[256];
 503   char  *tm;
 504   char  *tm2 = typemap_lookup("varout","guile",t,name,name,"scmresult");
 505
 506   // evaluation function names
 507
 508   sprintf(var_name,"_wrap_gscm_var_%s",iname);
 509
 510   if ((t->type != T_USER) || (t->is_pointer)) {
 511
 512     fprintf(f_wrappers,"SCM %s(SCM s_0) {\n", var_name);
 513
 514     if (!(Status & STAT_READONLY) && (t->is_pointer)) {
 515       fprintf(f_wrappers,"\t char *_temp;\n");
 516       fprintf(f_wrappers,"\t int  _len;\n");
 517     }
 518
 519     if (tm2) {
 520       fprintf(f_wrappers,"\t char _ptemp[128];\n");
 521     }
 522     fprintf(f_wrappers,"\t SCM scmresult; /* fun2 */\n");
 523
 524     // Check for a setting of the variable value
 525
 526     fprintf(f_wrappers,"\t if (s_0 != GH_NOT_PASSED) {\n");
 527
 528     // Yup. Extract the type from s_0 and set variable value
 529     if (Status & STAT_READONLY) {
 530 //      fprintf(f_wrappers,"\t\t gscm_error(\"Unable to set %s. Variable is read only.\", s_0);\n", iname);
 531     } else {
 532       if ((tm = typemap_lookup("varin","guile",t,name,"s_0",name))) {
 533         // Yep.  Use it instead of the default
 534         fprintf(f_wrappers,"%s\n",tm);
 535       } else {
 536         if (!t->is_pointer) {
 537
 538           switch(t->type) {
 539             // Signed Integer
 540
 541           case T_INT:  case T_SINT:
 542           case T_SHORT: case T_SSHORT:
 543           case T_LONG: case T_SLONG:
 544           case T_SCHAR:
 545             fprintf(f_wrappers,"\t\t %s = %s gh_scm2long(s_0);\n",name, t->print_cast());
 546             break;
 547
 548             // Unsigned integer
 549
 550           case T_UINT:
 551           case T_USHORT:
 552           case T_ULONG:
 553           case T_UCHAR:
 554             fprintf(f_wrappers,"\t\t %s = %s gh_scm2ulong(s_0);\n",name, t->print_cast());
 555             break;
 556
 557             // Floating point
 558
 559           case T_FLOAT:
 560           case T_DOUBLE:
 561             fprintf(f_wrappers,"\t\t %s = %s gh_scm2double(s_0);\n",name, t->print_cast());
 562             break;
 563
 564             // Character value
 565
 566           case T_CHAR:
 567             fprintf(f_wrappers,"\t\t %s = gh_scm2char(s_0);\n", name);
 568             break;
 569
 570             // Unknown value
 571
 572           default:
 573             fprintf(stderr,"Line %d.  Error, unsupported data-type.\n", line_number);
 574             break;
 575           }
 576         } else {
 577
 578           // Have some sort of pointer type here, Process it differently
 579
 580           if ((t->type == T_CHAR) && (t->is_pointer == 1)) {
 581             fprintf(f_wrappers,"\t\t _temp = gh_scm2newstr(s_0, &_len);\n");
 582             fprintf(f_wrappers,"\t\t if (%s) { free(%s);}\n", name,name);
 583             fprintf(f_wrappers,"\t\t %s = (char *) malloc((_len+1)*sizeof(char));\n",name);
 584             fprintf(f_wrappers,"\t\t strncpy(%s,_temp,_len);\n",name);
 585             fprintf(f_wrappers,"\t\t %s[_len] = 0;\n", name);
 586           } else {
 587             // Set the value of a pointer
 588             fprintf(f_wrappers,"\t\t _temp = gh_scm2newstr(s_0,&_len);\n");
 589             fprintf(f_wrappers,"\t if (SWIG_GetPtr(_temp, (void **) &%s,",name);
 590             if (t->type == T_VOID) fprintf(f_wrappers,"(char *) 0)) {\n");
 591             else
 592               fprintf(f_wrappers,"\"%s\")) {\n", t->print_mangle());
 593
 594             // Now emit code according to the level of strictness desired
 595
 596             switch(TypeStrict) {
 597             case 0: // No type checking
 598               fprintf(f_wrappers,"\t}\n");
 599               break;
 600             case 1: // Warning message only
 601               fprintf(f_wrappers,
 602                       "\t fprintf(stderr,\"Warning : type mismatch in variable %s. Expected %s, received %%s\\n\", _temp);\n", name, t->print_mangle());
 603               fprintf(f_wrappers,"\t }\n");
 604               break;
 605             case 2: // Super strict mode.
 606
 607 //            fprintf(f_wrappers,"\t\t gscm_error(\"Type error in variable %s. Expected %s.\", s_0);\n", name,t->print_mangle());
 608               fprintf(f_wrappers,"\t}\n");
 609               break;
 610
 611             default :
 612               fprintf(stderr,"Unknown strictness level\n");
 613               break;
 614             }
 615           }
 616         }
 617       }
 618     }
 619     fprintf(f_wrappers,"\t}\n");
 620
 621     // Now return the value of the variable (regardless of evaluating or setting)
 622
 623     if (tm2) {
 624       // Yep.  Use it instead of the default
 625       fprintf(f_wrappers,"%s\n",tm);
 626     } else {
 627       if (!t->is_pointer) {
 628         /* Return variable by value */
 629
 630         switch(t->type) {
 631
 632           // Signed Integer
 633
 634         case T_INT: case T_SINT:
 635         case T_SHORT: case T_SSHORT:
 636         case T_LONG: case T_SLONG:
 637         case T_SCHAR:
 638           fprintf(f_wrappers,"\t scmresult = gh_long2scm((long) %s);\n", name);
 639           break;
 640
 641           // Unsigned integer
 642
 643         case T_UINT:
 644         case T_USHORT:
 645         case T_ULONG:
 646         case T_UCHAR:
 647           fprintf(f_wrappers,"\t scmresult = gh_ulong2scm((unsigned long) %s);\n",name);
 648           break;
 649
 650           // Floats
 651
 652         case T_DOUBLE:
 653         case T_FLOAT:
 654           fprintf(f_wrappers,"\t scmresult = gh_double2scm((double) %s);\n", name);
 655           break;
 656         case T_CHAR:
 657           fprintf(f_wrappers,"\t scmresult = gh_char2scm(%s);\n",name);
 658           break;
 659         default :
 660           /* Unknown type */
 661           break;
 662         }
 663       } else {
 664
 665         // Is a pointer return type
 666
 667         if ((t->type == T_CHAR) && (t->is_pointer == 1)) {
 668           fprintf(f_wrappers,"\t scmresult = gh_str02scm(%s);\n",name);
 669         } else {
 670           // Is an ordinary pointer type.
 671           fprintf(f_wrappers,"\t  SWIG_MakePtr(_ptemp, %s,\"%s\");\n",name,
 672                   t->print_mangle());
 673           fprintf(f_wrappers,"\t scmresult = gh_str02scm(_ptemp);\n");
 674         }
 675       }
 676     }
 677     fprintf(f_wrappers,"\t return scmresult;\n");
 678     fprintf(f_wrappers,"}\n");
 679
 680     // Now add symbol to the Guile interpreter
 681
 682     fprintf(f_init,"\t gh_new_procedure(\"%s\", %s, 0, 1, 0);\n",iname, var_name);
 683
 684   } else {
 685     fprintf(stderr,"%s : Line %d. ** Warning. Unable to link with type %s (ignored).\n",
 686             input_file, line_number, t->print_type());
 687   }
 688
 689   // Add a documentation entry
 690
 691   if (doc_entry) {
 692     char *usage = 0;
 693     usage_var(iname,t,&usage);
 694     doc_entry->usage << usage;
 695     doc_entry->cinfo << "Global : " << t->print_type() << " " << name;
 696     delete usage;
 697   }
 698
 699 }
 700
 701 // -----------------------------------------------------------------------
 702 // GUILE::declare_const(char *name, char *iname, DataType *type, char *value)
 703 //
 704 // Makes a constant.   Not sure how this is really supposed to work.
 705 // I'm going to fake out SWIG and create a variable instead.
 706 // ------------------------------------------------------------------------
 707
 708 void GUILE::declare_const(char *name, char *, DataType *type, char *value) {
 709
 710   int OldStatus = Status;      // Save old status flags
 711   char   var_name[256];
 712
 713   Status = STAT_READONLY;      // Enable readonly mode.
 714
 715   // Make a static variable;
 716
 717   sprintf(var_name,"_wrap_const_%s",name);
 718
 719   if ((type->type == T_USER) && (!type->is_pointer)) {
 720     fprintf(stderr,"%s : Line %d.  Unsupported constant value.\n", input_file, line_number);
 721     return;
 722   }
 723
 724   // Create variable and assign it a value
 725
 726   fprintf(f_header,"static %s %s = ", type->print_type(), var_name);
 727   if ((type->type == T_CHAR) && (type->is_pointer <= 1)) {
 728     fprintf(f_header,"\"%s\";\n", value);
 729   } else {
 730     fprintf(f_header,"%s;\n", value);
 731   }
 732
 733   // Now create a variable declaration
 734
 735   link_variable(var_name, name, type);
 736   Status = OldStatus;
 737
 738   if (doc_entry) {
 739     char *usage = 0;
 740     usage_const(name,type,value,&usage);
 741     doc_entry->usage = "";
 742     doc_entry->usage << usage;
 743     doc_entry->cinfo = "";
 744     doc_entry->cinfo << "Constant: " << type->print_type();
 745     delete usage;
 746   }
 747
 748 }
 749
 750 // ----------------------------------------------------------------------
 751 // GUILE::usage_var(char *iname, DataType *t, char **s)
 752 //
 753 // Produces a usage string for a Guile variable.
 754 // ----------------------------------------------------------------------
 755
 756 void GUILE::usage_var(char *iname, DataType *t, char **s) {
 757
 758   char temp[1024], *c;
 759
 760   sprintf(temp,"(%s)", iname);
 761   c = temp + strlen(temp);
 762
 763   if (!((t->type != T_USER) || (t->is_pointer))) {
 764     sprintf(c," - unsupported");
 765   }
 766
 767   if (*s == 0)
 768     *s = new char[strlen(temp)+1];
 769   strcpy(*s,temp);
 770 }
 771
 772 // ---------------------------------------------------------------------------
 773 // GUILE::usage_func(char *iname, DataType *t, ParmList *l, char **s)
 774 //
 775 // Produces a usage string for a function in Guile
 776 // ---------------------------------------------------------------------------
 777
 778 void GUILE::usage_func(char *iname, DataType *, ParmList *l,
 779                         char **s) {
 780
 781   char temp[1024];
 782   char *c;
 783   int  i;
 784   Parm  *p;
 785
 786   sprintf(temp,"(%s ", iname);
 787   c = temp + strlen(temp);
 788
 789   /* Now go through and print parameters */
 790
 791   p = l->get_first();
 792   while (p != 0) {
 793
 794     /* If parameter has been named, use that.   Otherwise, just print a type  */
 795
 796     if ((p->t->type != T_VOID) || (p->t->is_pointer)) {
 797       if (strlen(p->name) > 0) {
 798         sprintf(c,"%s ",p->name);
 799         c += strlen(p->name)+1;
 800       }
 801       else {
 802         sprintf(c,"%s",p->t->name);
 803         c += strlen(p->t->name);
 804         if (p->t->is_pointer) {
 805           for (i = 0; i < (p->t->is_pointer-p->t->implicit_ptr); i++) {
 806             sprintf(c,"*");
 807             c++;
 808           }
 809         }
 810       }
 811     }
 812       p = l->get_next();
 813       if (p != 0) {
 814         sprintf(c," ");
 815         c++;
 816       }
 817   }
 818   sprintf(c,")");
 819   if (*s == 0)
 820     *s = new char[strlen(temp)+1];
 821   strcpy(*s,temp);
 822 }
 823
 824
 825 // ----------------------------------------------------------------------
 826 // GUILE::usage_const(char *iname, DataType *type, char *value, char **s)
 827 //
 828 // Produces a usage string for a Guile constant
 829 // ----------------------------------------------------------------------
 830
 831 void GUILE::usage_const(char *iname, DataType *, char *value, char **s) {
 832
 833   char temp[1024];
 834
 835   sprintf(temp,"(%s %s)", iname, value);
 836
 837   if (*s == 0)
 838     *s = new char[strlen(temp)+1];
 839   strcpy(*s,temp);
 840
 841 }