Source/Modules/guile.cxx

   1 /* -----------------------------------------------------------------------------
   2  * See the LICENSE file for information on copyright, usage and redistribution
   3  * of SWIG, and the README file for authors - http://www.swig.org/release.html.
   4  *
   5  * guile.cxx
   6  *
   7  * Guile language module for SWIG.
   8  * ----------------------------------------------------------------------------- */
   9
  10 char cvsroot_guile_cxx[] = "$Id: guile.cxx 11133 2009-02-20 07:52:24Z wsfulton $";
  11
  12 #include "swigmod.h"
  13
  14 #include <ctype.h>
  15
  16 // Note string broken in half for compilers that can't handle long strings
  17 static const char *guile_usage = (char *) "\
  18 Guile Options (available with -guile)\n\
  19      -prefix <name>          - Use <name> as prefix [default \"gswig_\"]\n\
  20      -package <name>         - Set the path of the module to <name>\n\
  21                                (default NULL)\n\
  22      -emitsetters            - Emit procedures-with-setters for variables\n\
  23                                and structure slots.\n\
  24      -onlysetters            - Don't emit traditional getter and setter\n\
  25                                procedures for structure slots,\n\
  26                                only emit procedures-with-setters.\n\
  27      -procdoc <file>         - Output procedure documentation to <file>\n\
  28      -procdocformat <format> - Output procedure documentation in <format>;\n\
  29                                one of `guile-1.4', `plain', `texinfo'\n\
  30      -linkage <lstyle>       - Use linkage protocol <lstyle> (default `simple')\n\
  31                                Use `module' for native Guile module linking\n\
  32                                (requires Guile >= 1.5.0).  Use `passive' for\n\
  33                                passive linking (no C-level module-handling code),\n\
  34                                `ltdlmod' for Guile's old dynamic module\n\
  35                                convention (Guile <= 1.4), or `hobbit' for hobbit\n\
  36                                modules.\n\
  37      -scmstub                - Output Scheme file with module declaration and\n\
  38                                exports; only with `passive' and `simple' linkage\n\
  39      -gh                     - Use the gh_ Guile API. (Guile <= 1.8) \n\
  40      -scm                    - Use the scm Guile API. (Guile >= 1.6, default) \n\
  41      -proxy                  - Export GOOPS class definitions\n\
  42      -emitslotaccessors      - Emit accessor methods for all GOOPS slots\n" "\
  43      -primsuffix <suffix>    - Name appended to primitive module when exporting\n\
  44                                GOOPS classes. (default = \"primitive\")\n\
  45      -goopsprefix <prefix>   - Prepend <prefix> to all goops identifiers\n\
  46      -useclassprefix         - Prepend the class name to all goops identifiers\n\
  47      -exportprimitive        - Add the (export ...) code from scmstub into the\n\
  48                                GOOPS file.\n";
  49
  50 static File *f_begin = 0;
  51 static File *f_runtime = 0;
  52 static File *f_header = 0;
  53 static File *f_wrappers = 0;
  54 static File *f_init = 0;
  55
  56
  57 static char *prefix = (char *) "gswig_";
  58 static char *module = 0;
  59 static char *package = 0;
  60 static enum {
  61   GUILE_LSTYLE_SIMPLE,          // call `SWIG_init()'
  62   GUILE_LSTYLE_PASSIVE,         // passive linking (no module code)
  63   GUILE_LSTYLE_MODULE,          // native guile module linking (Guile >= 1.4.1)
  64   GUILE_LSTYLE_LTDLMOD_1_4,     // old (Guile <= 1.4) dynamic module convention
  65   GUILE_LSTYLE_HOBBIT           // use (hobbit4d link)
  66 } linkage = GUILE_LSTYLE_SIMPLE;
  67
  68 static File *procdoc = 0;
  69 static bool scmstub = false;
  70 static String *scmtext;
  71 static bool goops = false;
  72 static String *goopstext;
  73 static String *goopscode;
  74 static String *goopsexport;
  75
  76 static enum {
  77   GUILE_1_4,
  78   PLAIN,
  79   TEXINFO
  80 } docformat = GUILE_1_4;
  81
  82 static int emit_setters = 0;
  83 static int only_setters = 0;
  84 static int emit_slot_accessors = 0;
  85 static int struct_member = 0;
  86
  87 static String *beforereturn = 0;
  88 static String *return_nothing_doc = 0;
  89 static String *return_one_doc = 0;
  90 static String *return_multi_doc = 0;
  91
  92 static String *exported_symbols = 0;
  93
  94 static int use_scm_interface = 1;
  95 static int exporting_destructor = 0;
  96 static String *swigtype_ptr = 0;
  97
  98 /* GOOPS stuff */
  99 static String *primsuffix = 0;
 100 static String *class_name = 0;
 101 static String *short_class_name = 0;
 102 static String *goops_class_methods;
 103 static int in_class = 0;
 104 static int have_constructor = 0;
 105 static int useclassprefix = 0;  // -useclassprefix argument
 106 static String *goopsprefix = 0; // -goopsprefix argument
 107 static int primRenamer = 0;     // if (use-modules ((...) :renamer ...) is exported to GOOPS file
 108 static int exportprimitive = 0; // -exportprimitive argument
 109 static String *memberfunction_name = 0;
 110
 111 extern "C" {
 112   static int has_classname(Node *class_node) {
 113     return Getattr(class_node, "guile:goopsclassname") != NULL;
 114   }
 115 }
 116
 117 class GUILE:public Language {
 118 public:
 119
 120   /* ------------------------------------------------------------
 121    * main()
 122    * ------------------------------------------------------------ */
 123
 124   virtual void main(int argc, char *argv[]) {
 125     int i, orig_len;
 126
 127      SWIG_library_directory("guile");
 128      SWIG_typemap_lang("guile");
 129
 130     // Look for certain command line options
 131     for (i = 1; i < argc; i++) {
 132       if (argv[i]) {
 133         if (strcmp(argv[i], "-help") == 0) {
 134           fputs(guile_usage, stdout);
 135           SWIG_exit(EXIT_SUCCESS);
 136         } else if (strcmp(argv[i], "-prefix") == 0) {
 137           if (argv[i + 1]) {
 138             prefix = new char[strlen(argv[i + 1]) + 2];
 139             strcpy(prefix, argv[i + 1]);
 140             Swig_mark_arg(i);
 141             Swig_mark_arg(i + 1);
 142             i++;
 143           } else {
 144             Swig_arg_error();
 145           }
 146         } else if (strcmp(argv[i], "-package") == 0) {
 147           if (argv[i + 1]) {
 148             package = new char[strlen(argv[i + 1]) + 2];
 149             strcpy(package, argv[i + 1]);
 150             Swig_mark_arg(i);
 151             Swig_mark_arg(i + 1);
 152             i++;
 153           } else {
 154             Swig_arg_error();
 155           }
 156         } else if (strcmp(argv[i], "-Linkage") == 0 || strcmp(argv[i], "-linkage") == 0) {
 157           if (argv[i + 1]) {
 158             if (0 == strcmp(argv[i + 1], "ltdlmod"))
 159               linkage = GUILE_LSTYLE_LTDLMOD_1_4;
 160             else if (0 == strcmp(argv[i + 1], "hobbit"))
 161               linkage = GUILE_LSTYLE_HOBBIT;
 162             else if (0 == strcmp(argv[i + 1], "simple"))
 163               linkage = GUILE_LSTYLE_SIMPLE;
 164             else if (0 == strcmp(argv[i + 1], "passive"))
 165               linkage = GUILE_LSTYLE_PASSIVE;
 166             else if (0 == strcmp(argv[i + 1], "module"))
 167               linkage = GUILE_LSTYLE_MODULE;
 168             else
 169               Swig_arg_error();
 170             Swig_mark_arg(i);
 171             Swig_mark_arg(i + 1);
 172             i++;
 173           } else {
 174             Swig_arg_error();
 175           }
 176         } else if (strcmp(argv[i], "-procdoc") == 0) {
 177           if (argv[i + 1]) {
 178             procdoc = NewFile(argv[i + 1], "w", SWIG_output_files());
 179             if (!procdoc) {
 180               FileErrorDisplay(argv[i + 1]);
 181               SWIG_exit(EXIT_FAILURE);
 182             }
 183             Swig_mark_arg(i);
 184             Swig_mark_arg(i + 1);
 185             i++;
 186           } else {
 187             Swig_arg_error();
 188           }
 189         } else if (strcmp(argv[i], "-procdocformat") == 0) {
 190           if (strcmp(argv[i + 1], "guile-1.4") == 0)
 191             docformat = GUILE_1_4;
 192           else if (strcmp(argv[i + 1], "plain") == 0)
 193             docformat = PLAIN;
 194           else if (strcmp(argv[i + 1], "texinfo") == 0)
 195             docformat = TEXINFO;
 196           else
 197             Swig_arg_error();
 198           Swig_mark_arg(i);
 199           Swig_mark_arg(i + 1);
 200           i++;
 201         } else if (strcmp(argv[i], "-emit-setters") == 0 || strcmp(argv[i], "-emitsetters") == 0) {
 202           emit_setters = 1;
 203           Swig_mark_arg(i);
 204         } else if (strcmp(argv[i], "-only-setters") == 0 || strcmp(argv[i], "-onlysetters") == 0) {
 205           emit_setters = 1;
 206           only_setters = 1;
 207           Swig_mark_arg(i);
 208         } else if (strcmp(argv[i], "-emit-slot-accessors") == 0 || strcmp(argv[i], "-emitslotaccessors") == 0) {
 209           emit_slot_accessors = 1;
 210           Swig_mark_arg(i);
 211         } else if (strcmp(argv[i], "-scmstub") == 0) {
 212           scmstub = true;
 213           Swig_mark_arg(i);
 214         } else if ((strcmp(argv[i], "-shadow") == 0) || ((strcmp(argv[i], "-proxy") == 0))) {
 215           goops = true;
 216           Swig_mark_arg(i);
 217         } else if (strcmp(argv[i], "-gh") == 0) {
 218           use_scm_interface = 0;
 219           Swig_mark_arg(i);
 220         } else if (strcmp(argv[i], "-scm") == 0) {
 221           use_scm_interface = 1;
 222           Swig_mark_arg(i);
 223         } else if (strcmp(argv[i], "-primsuffix") == 0) {
 224           if (argv[i + 1]) {
 225             primsuffix = NewString(argv[i + 1]);
 226             Swig_mark_arg(i);
 227             Swig_mark_arg(i + 1);
 228             i++;
 229           } else {
 230             Swig_arg_error();
 231           }
 232         } else if (strcmp(argv[i], "-goopsprefix") == 0) {
 233           if (argv[i + 1]) {
 234             goopsprefix = NewString(argv[i + 1]);
 235             Swig_mark_arg(i);
 236             Swig_mark_arg(i + 1);
 237             i++;
 238           } else {
 239             Swig_arg_error();
 240           }
 241         } else if (strcmp(argv[i], "-useclassprefix") == 0) {
 242           useclassprefix = 1;
 243           Swig_mark_arg(i);
 244         } else if (strcmp(argv[i], "-exportprimitive") == 0) {
 245           exportprimitive = 1;
 246           // should use Swig_warning() here?
 247           Swig_mark_arg(i);
 248         }
 249       }
 250     }
 251
 252     // set default value for primsuffix
 253     if (primsuffix == NULL)
 254       primsuffix = NewString("primitive");
 255
 256     //goops support can only be enabled if passive or module linkage is used
 257     if (goops) {
 258       if (linkage != GUILE_LSTYLE_PASSIVE && linkage != GUILE_LSTYLE_MODULE) {
 259         Printf(stderr, "guile: GOOPS support requires passive or module linkage\n");
 260         exit(1);
 261       }
 262     }
 263
 264     if (goops) {
 265       // -proxy implies -emit-setters
 266       emit_setters = 1;
 267     }
 268
 269     if ((linkage == GUILE_LSTYLE_PASSIVE && scmstub) || linkage == GUILE_LSTYLE_MODULE)
 270       primRenamer = 1;
 271
 272     if (exportprimitive && primRenamer) {
 273       // should use Swig_warning() ?
 274       Printf(stderr, "guile: Warning: -exportprimitive only makes sense with passive linkage without a scmstub.\n");
 275     }
 276     // Make sure `prefix' ends in an underscore
 277
 278     orig_len = strlen(prefix);
 279     if (prefix[orig_len - 1] != '_') {
 280       prefix[1 + orig_len] = 0;
 281       prefix[orig_len] = '_';
 282     }
 283
 284     /* Add a symbol for this module */
 285     Preprocessor_define("SWIGGUILE 1", 0);
 286     /* Read in default typemaps */
 287     if (use_scm_interface)
 288       SWIG_config_file("guile_scm.swg");
 289     else
 290       SWIG_config_file("guile_gh.swg");
 291     allow_overloading();
 292
 293   }
 294
 295   /* ------------------------------------------------------------
 296    * top()
 297    * ------------------------------------------------------------ */
 298
 299   virtual int top(Node *n) {
 300     /* Initialize all of the output files */
 301     String *outfile = Getattr(n, "outfile");
 302
 303     f_begin = NewFile(outfile, "w", SWIG_output_files());
 304     if (!f_begin) {
 305       FileErrorDisplay(outfile);
 306       SWIG_exit(EXIT_FAILURE);
 307     }
 308     f_runtime = NewString("");
 309     f_init = NewString("");
 310     f_header = NewString("");
 311     f_wrappers = NewString("");
 312
 313     /* Register file targets with the SWIG file handler */
 314     Swig_register_filebyname("header", f_header);
 315     Swig_register_filebyname("wrapper", f_wrappers);
 316     Swig_register_filebyname("begin", f_begin);
 317     Swig_register_filebyname("runtime", f_runtime);
 318     Swig_register_filebyname("init", f_init);
 319
 320     scmtext = NewString("");
 321     Swig_register_filebyname("scheme", scmtext);
 322     exported_symbols = NewString("");
 323     goopstext = NewString("");
 324     Swig_register_filebyname("goops", goopstext);
 325     goopscode = NewString("");
 326     goopsexport = NewString("");
 327
 328     Swig_banner(f_begin);
 329
 330     Printf(f_runtime, "\n");
 331     Printf(f_runtime, "#define SWIGGUILE\n");
 332
 333     if (!use_scm_interface) {
 334       if (SwigRuntime == 1)
 335         Printf(f_runtime, "#define SWIG_GLOBAL\n");
 336       if (SwigRuntime == 2)
 337         Printf(f_runtime, "#define SWIG_NOINCLUDE\n");
 338     }
 339
 340     /* Write out directives and declarations */
 341
 342     module = Swig_copy_string(Char(Getattr(n, "name")));
 343
 344     switch (linkage) {
 345     case GUILE_LSTYLE_SIMPLE:
 346       /* Simple linkage; we have to export the SWIG_init function. The user can
 347          rename the function by a #define. */
 348       Printf(f_runtime, "#define SWIG_GUILE_INIT_STATIC extern\n");
 349       break;
 350     default:
 351       /* Other linkage; we make the SWIG_init function static */
 352       Printf(f_runtime, "#define SWIG_GUILE_INIT_STATIC static\n");
 353       break;
 354     }
 355
 356     if (CPlusPlus) {
 357       Printf(f_runtime, "extern \"C\" {\n\n");
 358     }
 359     Printf(f_runtime, "SWIG_GUILE_INIT_STATIC void\nSWIG_init (void);\n");
 360     if (CPlusPlus) {
 361       Printf(f_runtime, "\n}\n");
 362     }
 363
 364     Printf(f_runtime, "\n");
 365
 366     Language::top(n);
 367
 368     /* Close module */
 369
 370     Printf(f_wrappers, "#ifdef __cplusplus\nextern \"C\" {\n#endif\n");
 371
 372     SwigType_emit_type_table(f_runtime, f_wrappers);
 373
 374     Printf(f_init, "}\n\n");
 375     Printf(f_init, "#ifdef __cplusplus\n}\n#endif\n");
 376
 377     String *module_name = NewString("");
 378
 379     if (!module)
 380       Printv(module_name, "swig", NIL);
 381     else {
 382       if (package)
 383         Printf(module_name, "%s/%s", package, module);
 384       else
 385         Printv(module_name, module, NIL);
 386     }
 387     emit_linkage(module_name);
 388
 389     Delete(module_name);
 390
 391     if (procdoc) {
 392       Delete(procdoc);
 393       procdoc = NULL;
 394     }
 395     Delete(goopscode);
 396     Delete(goopsexport);
 397     Delete(goopstext);
 398
 399     /* Close all of the files */
 400     Dump(f_runtime, f_begin);
 401     Dump(f_header, f_begin);
 402     Dump(f_wrappers, f_begin);
 403     Wrapper_pretty_print(f_init, f_begin);
 404     Delete(f_header);
 405     Delete(f_wrappers);
 406     Delete(f_init);
 407     Close(f_begin);
 408     Delete(f_runtime);
 409     Delete(f_begin);
 410     return SWIG_OK;
 411   }
 412
 413   void emit_linkage(String *module_name) {
 414     String *module_func = NewString("");
 415
 416     if (CPlusPlus) {
 417       Printf(f_init, "extern \"C\" {\n\n");
 418     }
 419
 420     Printv(module_func, module_name, NIL);
 421     Replaceall(module_func, "-", "_");
 422
 423     switch (linkage) {
 424     case GUILE_LSTYLE_SIMPLE:
 425       Printf(f_init, "\n/* Linkage: simple */\n");
 426       break;
 427     case GUILE_LSTYLE_PASSIVE:
 428       Printf(f_init, "\n/* Linkage: passive */\n");
 429       Replaceall(module_func, "/", "_");
 430       Insert(module_func, 0, "scm_init_");
 431       Append(module_func, "_module");
 432
 433       Printf(f_init, "SCM\n%s (void)\n{\n", module_func);
 434       Printf(f_init, "  SWIG_init();\n");
 435       Printf(f_init, "  return SCM_UNSPECIFIED;\n");
 436       Printf(f_init, "}\n");
 437       break;
 438     case GUILE_LSTYLE_LTDLMOD_1_4:
 439       Printf(f_init, "\n/* Linkage: ltdlmod */\n");
 440       Replaceall(module_func, "/", "_");
 441       Insert(module_func, 0, "scm_init_");
 442       Append(module_func, "_module");
 443       Printf(f_init, "SCM\n%s (void)\n{\n", module_func);
 444       {
 445         String *mod = NewString(module_name);
 446         Replaceall(mod, "/", " ");
 447         Printf(f_init, "    scm_register_module_xxx (\"%s\", (void *) SWIG_init);\n", mod);
 448         Printf(f_init, "    return SCM_UNSPECIFIED;\n");
 449         Delete(mod);
 450       }
 451       Printf(f_init, "}\n");
 452       break;
 453     case GUILE_LSTYLE_MODULE:
 454       Printf(f_init, "\n/* Linkage: module */\n");
 455       Replaceall(module_func, "/", "_");
 456       Insert(module_func, 0, "scm_init_");
 457       Append(module_func, "_module");
 458
 459       Printf(f_init, "static void SWIG_init_helper(void *data)\n");
 460       Printf(f_init, "{\n    SWIG_init();\n");
 461       if (Len(exported_symbols) > 0)
 462         Printf(f_init, "    scm_c_export(%sNULL);", exported_symbols);
 463       Printf(f_init, "\n}\n\n");
 464
 465       Printf(f_init, "SCM\n%s (void)\n{\n", module_func);
 466       {
 467         String *mod = NewString(module_name);
 468         if (goops)
 469           Printv(mod, "-", primsuffix, NIL);
 470         Replaceall(mod, "/", " ");
 471         Printf(f_init, "    scm_c_define_module(\"%s\",\n", mod);
 472         Printf(f_init, "      SWIG_init_helper, NULL);\n");
 473         Printf(f_init, "    return SCM_UNSPECIFIED;\n");
 474         Delete(mod);
 475       }
 476       Printf(f_init, "}\n");
 477       break;
 478     case GUILE_LSTYLE_HOBBIT:
 479       Printf(f_init, "\n/* Linkage: hobbit */\n");
 480       Replaceall(module_func, "/", "_slash_");
 481       Insert(module_func, 0, "scm_init_");
 482       Printf(f_init, "SCM\n%s (void)\n{\n", module_func);
 483       {
 484         String *mod = NewString(module_name);
 485         Replaceall(mod, "/", " ");
 486         Printf(f_init, "    scm_register_module_xxx (\"%s\", (void *) SWIG_init);\n", mod);
 487         Printf(f_init, "    return SCM_UNSPECIFIED;\n");
 488         Delete(mod);
 489       }
 490       Printf(f_init, "}\n");
 491       break;
 492     default:
 493       abort();                  // for now
 494     }
 495
 496     if (scmstub) {
 497       /* Emit Scheme stub if requested */
 498       String *primitive_name = NewString(module_name);
 499       if (goops)
 500         Printv(primitive_name, "-", primsuffix, NIL);
 501
 502       String *mod = NewString(primitive_name);
 503       Replaceall(mod, "/", " ");
 504
 505       String *fname = NewStringf("%s%s.scm",
 506                                  SWIG_output_directory(),
 507                                  primitive_name);
 508       Delete(primitive_name);
 509       File *scmstubfile = NewFile(fname, "w", SWIG_output_files());
 510       if (!scmstubfile) {
 511         FileErrorDisplay(fname);
 512         SWIG_exit(EXIT_FAILURE);
 513       }
 514       Delete(fname);
 515
 516       Swig_banner_target_lang(scmstubfile, ";;;");
 517       Printf(scmstubfile, "\n");
 518       if (linkage == GUILE_LSTYLE_SIMPLE || linkage == GUILE_LSTYLE_PASSIVE)
 519         Printf(scmstubfile, "(define-module (%s))\n\n", mod);
 520       Delete(mod);
 521       Printf(scmstubfile, "%s", scmtext);
 522       if ((linkage == GUILE_LSTYLE_SIMPLE || linkage == GUILE_LSTYLE_PASSIVE)
 523           && Len(exported_symbols) > 0) {
 524         String *ex = NewString(exported_symbols);
 525         Replaceall(ex, ", ", "\n        ");
 526         Replaceall(ex, "\"", "");
 527         Chop(ex);
 528         Printf(scmstubfile, "\n(export %s)\n", ex);
 529         Delete(ex);
 530       }
 531       Delete(scmstubfile);
 532     }
 533
 534     if (goops) {
 535       String *mod = NewString(module_name);
 536       Replaceall(mod, "/", " ");
 537
 538       String *fname = NewStringf("%s%s.scm", SWIG_output_directory(),
 539                                  module_name);
 540       File *goopsfile = NewFile(fname, "w", SWIG_output_files());
 541       if (!goopsfile) {
 542         FileErrorDisplay(fname);
 543         SWIG_exit(EXIT_FAILURE);
 544       }
 545       Delete(fname);
 546       Swig_banner_target_lang(goopsfile, ";;;");
 547       Printf(goopsfile, "\n");
 548       Printf(goopsfile, "(define-module (%s))\n", mod);
 549       Printf(goopsfile, "%s\n", goopstext);
 550       Printf(goopsfile, "(use-modules (oop goops) (Swig common))\n");
 551       if (primRenamer) {
 552         Printf(goopsfile, "(use-modules ((%s-%s) :renamer (symbol-prefix-proc 'primitive:)))\n", mod, primsuffix);
 553       }
 554       Printf(goopsfile, "%s\n(export %s)", goopscode, goopsexport);
 555       if (exportprimitive) {
 556         String *ex = NewString(exported_symbols);
 557         Replaceall(ex, ", ", "\n        ");
 558         Replaceall(ex, "\"", "");
 559         Chop(ex);
 560         Printf(goopsfile, "\n(export %s)", ex);
 561         Delete(ex);
 562       }
 563       Delete(mod);
 564       Delete(goopsfile);
 565     }
 566
 567     Delete(module_func);
 568     if (CPlusPlus) {
 569       Printf(f_init, "\n}\n");
 570     }
 571   }
 572
 573   /* Return true iff T is a pointer type */
 574
 575   int is_a_pointer(SwigType *t) {
 576     return SwigType_ispointer(SwigType_typedef_resolve_all(t));
 577   }
 578
 579   /* Report an error handling the given type. */
 580
 581   void throw_unhandled_guile_type_error(SwigType *d) {
 582     Swig_warning(WARN_TYPEMAP_UNDEF, input_file, line_number, "Unable to handle type %s.\n", SwigType_str(d, 0));
 583   }
 584
 585   /* Write out procedure documentation */
 586
 587   void write_doc(const String *proc_name, const String *signature, const String *doc, const String *signature2 = NULL) {
 588     switch (docformat) {
 589     case GUILE_1_4:
 590       Printv(procdoc, "\f\n", NIL);
 591       Printv(procdoc, "(", signature, ")\n", NIL);
 592       if (signature2)
 593         Printv(procdoc, "(", signature2, ")\n", NIL);
 594       Printv(procdoc, doc, "\n", NIL);
 595       break;
 596     case PLAIN:
 597       Printv(procdoc, "\f", proc_name, "\n\n", NIL);
 598       Printv(procdoc, "(", signature, ")\n", NIL);
 599       if (signature2)
 600         Printv(procdoc, "(", signature2, ")\n", NIL);
 601       Printv(procdoc, doc, "\n\n", NIL);
 602       break;
 603     case TEXINFO:
 604       Printv(procdoc, "\f", proc_name, "\n", NIL);
 605       Printv(procdoc, "@deffn primitive ", signature, "\n", NIL);
 606       if (signature2)
 607         Printv(procdoc, "@deffnx primitive ", signature2, "\n", NIL);
 608       Printv(procdoc, doc, "\n", NIL);
 609       Printv(procdoc, "@end deffn\n\n", NIL);
 610       break;
 611     }
 612   }
 613
 614   /* returns false if the typemap is an empty string */
 615   bool handle_documentation_typemap(String *output,
 616                                     const String *maybe_delimiter, Parm *p, const String *typemap, const String *default_doc, const String *name = NULL) {
 617     String *tmp = NewString("");
 618     String *tm;
 619     if (!(tm = Getattr(p, typemap))) {
 620       Printf(tmp, "%s", default_doc);
 621       tm = tmp;
 622     }
 623     bool result = (Len(tm) > 0);
 624     if (maybe_delimiter && Len(output) > 0 && Len(tm) > 0) {
 625       Printv(output, maybe_delimiter, NIL);
 626     }
 627     const String *pn = (name == NULL) ? (const String *) Getattr(p, "name") : name;
 628     String *pt = Getattr(p, "type");
 629     Replaceall(tm, "$name", pn);        // legacy for $parmname
 630     Replaceall(tm, "$type", SwigType_str(pt, 0));
 631     /* $NAME is like $name, but marked-up as a variable. */
 632     String *ARGNAME = NewString("");
 633     if (docformat == TEXINFO)
 634       Printf(ARGNAME, "@var{%s}", pn);
 635     else
 636       Printf(ARGNAME, "%(upper)s", pn);
 637     Replaceall(tm, "$NAME", ARGNAME);
 638     Replaceall(tm, "$PARMNAME", ARGNAME);
 639     Printv(output, tm, NIL);
 640     Delete(tmp);
 641     return result;
 642   }
 643
 644   /* ------------------------------------------------------------
 645    * functionWrapper()
 646    * Create a function declaration and register it with the interpreter.
 647    * ------------------------------------------------------------ */
 648
 649   virtual int functionWrapper(Node *n) {
 650     String *iname = Getattr(n, "sym:name");
 651     SwigType *d = Getattr(n, "type");
 652     ParmList *l = Getattr(n, "parms");
 653     Parm *p;
 654     String *proc_name = 0;
 655     char source[256];
 656     Wrapper *f = NewWrapper();;
 657     String *cleanup = NewString("");
 658     String *outarg = NewString("");
 659     String *signature = NewString("");
 660     String *doc_body = NewString("");
 661     String *returns = NewString("");
 662     String *method_signature = NewString("");
 663     String *primitive_args = NewString("");
 664     Hash *scheme_arg_names = NewHash();
 665     int num_results = 1;
 666     String *tmp = NewString("");
 667     String *tm;
 668     int i;
 669     int numargs = 0;
 670     int numreq = 0;
 671     String *overname = 0;
 672     int args_passed_as_array = 0;
 673     int scheme_argnum = 0;
 674     bool any_specialized_arg = false;
 675
 676     // Make a wrapper name for this
 677     String *wname = Swig_name_wrapper(iname);
 678     if (Getattr(n, "sym:overloaded")) {
 679       overname = Getattr(n, "sym:overname");
 680       args_passed_as_array = 1;
 681     } else {
 682       if (!addSymbol(iname, n)) {
 683         DelWrapper(f);
 684         return SWIG_ERROR;
 685       }
 686     }
 687     if (overname) {
 688       Append(wname, overname);
 689     }
 690     Setattr(n, "wrap:name", wname);
 691
 692     // Build the name for scheme.
 693     proc_name = NewString(iname);
 694     Replaceall(proc_name, "_", "-");
 695
 696     /* Emit locals etc. into f->code; figure out which args to ignore */
 697     emit_parameter_variables(l, f);
 698
 699     /* Attach the standard typemaps */
 700     emit_attach_parmmaps(l, f);
 701     Setattr(n, "wrap:parms", l);
 702
 703     /* Get number of required and total arguments */
 704     numargs = emit_num_arguments(l);
 705     numreq = emit_num_required(l);
 706
 707     /* Declare return variable */
 708
 709     Wrapper_add_local(f, "gswig_result", "SCM gswig_result");
 710     Wrapper_add_local(f, "gswig_list_p", "SWIGUNUSED int gswig_list_p = 0");
 711
 712     /* Open prototype and signature */
 713
 714     Printv(f->def, "static SCM\n", wname, " (", NIL);
 715     if (args_passed_as_array) {
 716       Printv(f->def, "int argc, SCM *argv", NIL);
 717     }
 718     Printv(signature, proc_name, NIL);
 719
 720     /* Now write code to extract the parameters */
 721
 722     for (i = 0, p = l; i < numargs; i++) {
 723
 724       while (checkAttribute(p, "tmap:in:numinputs", "0")) {
 725         p = Getattr(p, "tmap:in:next");
 726       }
 727
 728       SwigType *pt = Getattr(p, "type");
 729       int opt_p = (i >= numreq);
 730
 731       // Produce names of source and target
 732       if (args_passed_as_array)
 733         sprintf(source, "argv[%d]", i);
 734       else
 735         sprintf(source, "s_%d", i);
 736       String *target = Getattr(p, "lname");
 737
 738       if (!args_passed_as_array) {
 739         if (i != 0)
 740           Printf(f->def, ", ");
 741         Printf(f->def, "SCM s_%d", i);
 742       }
 743       if (opt_p) {
 744         Printf(f->code, "    if (%s != SCM_UNDEFINED) {\n", source);
 745       }
 746       if ((tm = Getattr(p, "tmap:in"))) {
 747         Replaceall(tm, "$source", source);
 748         Replaceall(tm, "$target", target);
 749         Replaceall(tm, "$input", source);
 750         Setattr(p, "emit:input", source);
 751         Printv(f->code, tm, "\n", NIL);
 752
 753         SwigType *pb = SwigType_typedef_resolve_all(SwigType_base(pt));
 754         SwigType *pn = Getattr(p, "name");
 755         String *argname;
 756         scheme_argnum++;
 757         if (pn && !Getattr(scheme_arg_names, pn))
 758           argname = pn;
 759         else {
 760           /* Anonymous arg or re-used argument name -- choose a name that cannot clash */
 761           argname = NewStringf("%%arg%d", scheme_argnum);
 762         }
 763
 764         if (procdoc) {
 765           if (i == numreq) {
 766             /* First optional argument */
 767             Printf(signature, " #:optional");
 768           }
 769           /* Add to signature (arglist) */
 770           handle_documentation_typemap(signature, " ", p, "tmap:in:arglist", "$name", argname);
 771           /* Document the type of the arg in the documentation body */
 772           handle_documentation_typemap(doc_body, ", ", p, "tmap:in:doc", "$NAME is of type <$type>", argname);
 773         }
 774
 775         if (goops) {
 776           if (i < numreq) {
 777             if (strcmp("void", Char(pt)) != 0) {
 778               Node *class_node = Swig_symbol_clookup_check(pb, Getattr(n, "sym:symtab"),
 779                                                            has_classname);
 780               String *goopsclassname = (class_node == NULL) ? NULL : Getattr(class_node, "guile:goopsclassname");
 781               /* do input conversion */
 782               if (goopsclassname) {
 783                 Printv(method_signature, " (", argname, " ", goopsclassname, ")", NIL);
 784                 any_specialized_arg = true;
 785               } else {
 786                 Printv(method_signature, " ", argname, NIL);
 787               }
 788               Printv(primitive_args, " ", argname, NIL);
 789               Setattr(scheme_arg_names, argname, p);
 790             }
 791           }
 792         }
 793
 794         if (!pn) {
 795           Delete(argname);
 796         }
 797         p = Getattr(p, "tmap:in:next");
 798       } else {
 799         throw_unhandled_guile_type_error(pt);
 800         p = nextSibling(p);
 801       }
 802       if (opt_p)
 803         Printf(f->code, "    }\n");
 804     }
 805     if (Len(doc_body) > 0)
 806       Printf(doc_body, ".\n");
 807
 808     /* Insert constraint checking code */
 809     for (p = l; p;) {
 810       if ((tm = Getattr(p, "tmap:check"))) {
 811         Replaceall(tm, "$target", Getattr(p, "lname"));
 812         Printv(f->code, tm, "\n", NIL);
 813         p = Getattr(p, "tmap:check:next");
 814       } else {
 815         p = nextSibling(p);
 816       }
 817     }
 818     /* Pass output arguments back to the caller. */
 819
 820     /* Insert argument output code */
 821     String *returns_argout = NewString("");
 822     for (p = l; p;) {
 823       if ((tm = Getattr(p, "tmap:argout"))) {
 824         Replaceall(tm, "$source", Getattr(p, "lname"));
 825         Replaceall(tm, "$target", Getattr(p, "lname"));
 826         Replaceall(tm, "$arg", Getattr(p, "emit:input"));
 827         Replaceall(tm, "$input", Getattr(p, "emit:input"));
 828         Printv(outarg, tm, "\n", NIL);
 829         if (procdoc) {
 830           if (handle_documentation_typemap(returns_argout, ", ", p, "tmap:argout:doc", "$NAME (of type $type)")) {
 831             /* A documentation typemap that is not the empty string
 832                indicates that a value is returned to Scheme. */
 833             num_results++;
 834           }
 835         }
 836         p = Getattr(p, "tmap:argout:next");
 837       } else {
 838         p = nextSibling(p);
 839       }
 840     }
 841
 842     /* Insert cleanup code */
 843     for (p = l; p;) {
 844       if ((tm = Getattr(p, "tmap:freearg"))) {
 845         Replaceall(tm, "$target", Getattr(p, "lname"));
 846         Replaceall(tm, "$input", Getattr(p, "emit:input"));
 847         Printv(cleanup, tm, "\n", NIL);
 848         p = Getattr(p, "tmap:freearg:next");
 849       } else {
 850         p = nextSibling(p);
 851       }
 852     }
 853
 854     if (use_scm_interface && exporting_destructor) {
 855       /* Mark the destructor's argument as destroyed. */
 856       String *tm = NewString("SWIG_Guile_MarkPointerDestroyed($input);");
 857       Replaceall(tm, "$input", Getattr(l, "emit:input"));
 858       Printv(cleanup, tm, "\n", NIL);
 859       Delete(tm);
 860     }
 861
 862     /* Close prototype */
 863
 864     Printf(f->def, ")\n{\n");
 865
 866     /* Define the scheme name in C. This define is used by several Guile
 867        macros. */
 868     Printv(f->def, "#define FUNC_NAME \"", proc_name, "\"", NIL);
 869
 870     // Now write code to make the function call
 871     if (!use_scm_interface)
 872       Printv(f->code, tab4, "gh_defer_ints();\n", NIL);
 873
 874     String *actioncode = emit_action(n);
 875
 876     if (!use_scm_interface)
 877       Printv(actioncode, tab4, "gh_allow_ints();\n", NIL);
 878
 879     // Now have return value, figure out what to do with it.
 880     if ((tm = Swig_typemap_lookup_out("out", n, "result", f, actioncode))) {
 881       Replaceall(tm, "$result", "gswig_result");
 882       Replaceall(tm, "$target", "gswig_result");
 883       Replaceall(tm, "$source", "result");
 884       if (GetFlag(n, "feature:new"))
 885         Replaceall(tm, "$owner", "1");
 886       else
 887         Replaceall(tm, "$owner", "0");
 888       Printv(f->code, tm, "\n", NIL);
 889     } else {
 890       throw_unhandled_guile_type_error(d);
 891     }
 892     emit_return_variable(n, d, f);
 893
 894     // Documentation
 895     if ((tm = Getattr(n, "tmap:out:doc"))) {
 896       Printv(returns, tm, NIL);
 897       if (Len(tm) > 0)
 898         num_results = 1;
 899       else
 900         num_results = 0;
 901     } else {
 902       String *s = SwigType_str(d, 0);
 903       Chop(s);
 904       Printf(returns, "<%s>", s);
 905       Delete(s);
 906       num_results = 1;
 907     }
 908     Append(returns, returns_argout);
 909
 910
 911     // Dump the argument output code
 912     Printv(f->code, outarg, NIL);
 913
 914     // Dump the argument cleanup code
 915     Printv(f->code, cleanup, NIL);
 916
 917     // Look for any remaining cleanup
 918
 919     if (GetFlag(n, "feature:new")) {
 920       if ((tm = Swig_typemap_lookup("newfree", n, "result", 0))) {
 921         Replaceall(tm, "$source", "result");
 922         Printv(f->code, tm, "\n", NIL);
 923       }
 924     }
 925     // Free any memory allocated by the function being wrapped..
 926     if ((tm = Swig_typemap_lookup("ret", n, "result", 0))) {
 927       Replaceall(tm, "$source", "result");
 928       Printv(f->code, tm, "\n", NIL);
 929     }
 930     // Wrap things up (in a manner of speaking)
 931
 932     if (beforereturn)
 933       Printv(f->code, beforereturn, "\n", NIL);
 934     Printv(f->code, "return gswig_result;\n", NIL);
 935
 936     /* Substitute the function name */
 937     Replaceall(f->code, "$symname", iname);
 938     // Undefine the scheme name
 939
 940     Printf(f->code, "#undef FUNC_NAME\n");
 941     Printf(f->code, "}\n");
 942
 943     Wrapper_print(f, f_wrappers);
 944
 945     if (!Getattr(n, "sym:overloaded")) {
 946       if (numargs > 10) {
 947         int i;
 948         /* gh_new_procedure would complain: too many args */
 949         /* Build a wrapper wrapper */
 950         Printv(f_wrappers, "static SCM\n", wname, "_rest (SCM rest)\n", NIL);
 951         Printv(f_wrappers, "{\n", NIL);
 952         Printf(f_wrappers, "SCM arg[%d];\n", numargs);
 953         Printf(f_wrappers, "SWIG_Guile_GetArgs (arg, rest, %d, %d, \"%s\");\n", numreq, numargs - numreq, proc_name);
 954         Printv(f_wrappers, "return ", wname, "(", NIL);
 955         Printv(f_wrappers, "arg[0]", NIL);
 956         for (i = 1; i < numargs; i++)
 957           Printf(f_wrappers, ", arg[%d]", i);
 958         Printv(f_wrappers, ");\n", NIL);
 959         Printv(f_wrappers, "}\n", NIL);
 960         /* Register it */
 961         if (use_scm_interface) {
 962           Printf(f_init, "scm_c_define_gsubr(\"%s\", 0, 0, 1, (swig_guile_proc) %s_rest);\n", proc_name, wname);
 963         } else {
 964           Printf(f_init, "gh_new_procedure(\"%s\", (swig_guile_proc) %s_rest, 0, 0, 1);\n", proc_name, wname);
 965         }
 966       } else if (emit_setters && struct_member && strlen(Char(proc_name)) > 3) {
 967         int len = Len(proc_name);
 968         const char *pc = Char(proc_name);
 969         /* MEMBER-set and MEMBER-get functions. */
 970         int is_setter = (pc[len - 3] == 's');
 971         if (is_setter) {
 972           Printf(f_init, "SCM setter = ");
 973           struct_member = 2;    /* have a setter */
 974         } else
 975           Printf(f_init, "SCM getter = ");
 976         if (use_scm_interface) {
 977           /* GOOPS support uses the MEMBER-set and MEMBER-get functions,
 978              so ignore only_setters in this case. */
 979           if (only_setters && !goops)
 980             Printf(f_init, "scm_c_make_gsubr(\"%s\", %d, %d, 0, (swig_guile_proc) %s);\n", proc_name, numreq, numargs - numreq, wname);
 981           else
 982             Printf(f_init, "scm_c_define_gsubr(\"%s\", %d, %d, 0, (swig_guile_proc) %s);\n", proc_name, numreq, numargs - numreq, wname);
 983         } else {
 984           if (only_setters && !goops)
 985             Printf(f_init, "scm_make_gsubr(\"%s\", %d, %d, 0, (swig_guile_proc) %s);\n", proc_name, numreq, numargs - numreq, wname);
 986           else
 987             Printf(f_init, "gh_new_procedure(\"%s\", (swig_guile_proc) %s, %d, %d, 0);\n", proc_name, wname, numreq, numargs - numreq);
 988         }
 989         if (!is_setter) {
 990           /* Strip off "-get" */
 991           char *pws_name = (char *) malloc(sizeof(char) * (len - 3));
 992           strncpy(pws_name, pc, len - 3);
 993           pws_name[len - 4] = 0;
 994           if (struct_member == 2) {
 995             /* There was a setter, so create a procedure with setter */
 996             if (use_scm_interface) {
 997               Printf(f_init, "scm_c_define");
 998             } else {
 999               Printf(f_init, "gh_define");
1000             }
1001             Printf(f_init, "(\"%s\", " "scm_make_procedure_with_setter(getter, setter));\n", pws_name);
1002           } else {
1003             /* There was no setter, so make an alias to the getter */
1004             if (use_scm_interface) {
1005               Printf(f_init, "scm_c_define");
1006             } else {
1007               Printf(f_init, "gh_define");
1008             }
1009             Printf(f_init, "(\"%s\", getter);\n", pws_name);
1010           }
1011           Printf(exported_symbols, "\"%s\", ", pws_name);
1012           free(pws_name);
1013         }
1014       } else {
1015         /* Register the function */
1016         if (use_scm_interface) {
1017           if (exporting_destructor) {
1018             Printf(f_init, "((swig_guile_clientdata *)(SWIGTYPE%s->clientdata))->destroy = (guile_destructor) %s;\n", swigtype_ptr, wname);
1019             //Printf(f_init, "SWIG_TypeClientData(SWIGTYPE%s, (void *) %s);\n", swigtype_ptr, wname);
1020           }
1021           Printf(f_init, "scm_c_define_gsubr(\"%s\", %d, %d, 0, (swig_guile_proc) %s);\n", proc_name, numreq, numargs - numreq, wname);
1022         } else {
1023           Printf(f_init, "gh_new_procedure(\"%s\", (swig_guile_proc) %s, %d, %d, 0);\n", proc_name, wname, numreq, numargs - numreq);
1024         }
1025       }
1026     } else {                    /* overloaded function; don't export the single methods */
1027       if (!Getattr(n, "sym:nextSibling")) {
1028         /* Emit overloading dispatch function */
1029
1030         int maxargs;
1031         String *dispatch = Swig_overload_dispatch(n, "return %s(argc,argv);", &maxargs);
1032
1033         /* Generate a dispatch wrapper for all overloaded functions */
1034
1035         Wrapper *df = NewWrapper();
1036         String *dname = Swig_name_wrapper(iname);
1037
1038         Printv(df->def, "static SCM\n", dname, "(SCM rest)\n{\n", NIL);
1039         Printf(df->code, "#define FUNC_NAME \"%s\"\n", proc_name);
1040         Printf(df->code, "SCM argv[%d];\n", maxargs);
1041         Printf(df->code, "int argc = SWIG_Guile_GetArgs (argv, rest, %d, %d, \"%s\");\n", 0, maxargs, proc_name);
1042         Printv(df->code, dispatch, "\n", NIL);
1043         Printf(df->code, "scm_misc_error(\"%s\", \"No matching method for generic function `%s'\", SCM_EOL);\n", proc_name, iname);
1044         Printf(df->code, "#undef FUNC_NAME\n");
1045         Printv(df->code, "}\n", NIL);
1046         Wrapper_print(df, f_wrappers);
1047         if (use_scm_interface) {
1048           Printf(f_init, "scm_c_define_gsubr(\"%s\", 0, 0, 1, (swig_guile_proc) %s);\n", proc_name, dname);
1049         } else {
1050           Printf(f_init, "gh_new_procedure(\"%s\", (swig_guile_proc) %s, 0, 0, 1);\n", proc_name, dname);
1051         }
1052         DelWrapper(df);
1053         Delete(dispatch);
1054         Delete(dname);
1055       }
1056     }
1057     Printf(exported_symbols, "\"%s\", ", proc_name);
1058
1059     if (!in_class || memberfunction_name) {
1060       // export wrapper into goops file
1061       String *method_def = NewString("");
1062       String *goops_name;
1063       if (in_class)
1064         goops_name = NewString(memberfunction_name);
1065       else
1066         goops_name = goopsNameMapping(proc_name, (char *) "");
1067       String *primitive_name = NewString("");
1068       if (primRenamer)
1069         Printv(primitive_name, "primitive:", proc_name, NIL);
1070       else
1071         Printv(primitive_name, proc_name, NIL);
1072       Replaceall(method_signature, "_", "-");
1073       Replaceall(primitive_args, "_", "-");
1074       if (!any_specialized_arg) {
1075         /* If there would not be any specialized argument in
1076            the method declaration, we simply re-export the
1077            function.  This is a performance optimization. */
1078         Printv(method_def, "(define ", goops_name, " ", primitive_name, ")\n", NIL);
1079       } else if (numreq == numargs) {
1080         Printv(method_def, "(define-method (", goops_name, method_signature, ")\n", NIL);
1081         Printv(method_def, "  (", primitive_name, primitive_args, "))\n", NIL);
1082       } else {
1083         /* Handle optional args. For the rest argument, use a name
1084            that cannot clash. */
1085         Printv(method_def, "(define-method (", goops_name, method_signature, " . %args)\n", NIL);
1086         Printv(method_def, "  (apply ", primitive_name, primitive_args, " %args))\n", NIL);
1087       }
1088       if (in_class) {
1089         /* Defer method definition till end of class definition. */
1090         Printv(goops_class_methods, method_def, NIL);
1091       } else {
1092         Printv(goopscode, method_def, NIL);
1093       }
1094       Printf(goopsexport, "%s ", goops_name);
1095       Delete(primitive_name);
1096       Delete(goops_name);
1097       Delete(method_def);
1098     }
1099
1100     if (procdoc) {
1101       String *returns_text = NewString("");
1102       if (num_results == 0)
1103         Printv(returns_text, return_nothing_doc, NIL);
1104       else if (num_results == 1)
1105         Printv(returns_text, return_one_doc, NIL);
1106       else
1107         Printv(returns_text, return_multi_doc, NIL);
1108       /* Substitute documentation variables */
1109       static const char *numbers[] = { "zero", "one", "two", "three",
1110         "four", "five", "six", "seven",
1111         "eight", "nine", "ten", "eleven",
1112         "twelve"
1113       };
1114       if (num_results <= 12)
1115         Replaceall(returns_text, "$num_values", numbers[num_results]);
1116       else {
1117         String *num_results_str = NewStringf("%d", num_results);
1118         Replaceall(returns_text, "$num_values", num_results_str);
1119         Delete(num_results_str);
1120       }
1121       Replaceall(returns_text, "$values", returns);
1122       Printf(doc_body, "\n%s", returns_text);
1123       write_doc(proc_name, signature, doc_body);
1124       Delete(returns_text);
1125     }
1126
1127     Delete(proc_name);
1128     Delete(outarg);
1129     Delete(cleanup);
1130     Delete(signature);
1131     Delete(method_signature);
1132     Delete(primitive_args);
1133     Delete(doc_body);
1134     Delete(returns_argout);
1135     Delete(returns);
1136     Delete(tmp);
1137     Delete(scheme_arg_names);
1138     DelWrapper(f);
1139     return SWIG_OK;
1140   }
1141
1142   /* ------------------------------------------------------------
1143    * variableWrapper()
1144    *
1145    * Create a link to a C variable.
1146    * This creates a single function PREFIX_var_VARNAME().
1147    * This function takes a single optional argument.   If supplied, it means
1148    * we are setting this variable to some value.  If omitted, it means we are
1149    * simply evaluating this variable.  Either way, we return the variables
1150    * value.
1151    * ------------------------------------------------------------ */
1152
1153   virtual int variableWrapper(Node *n) {
1154
1155     char *name = GetChar(n, "name");
1156     char *iname = GetChar(n, "sym:name");
1157     SwigType *t = Getattr(n, "type");
1158
1159     String *proc_name;
1160     Wrapper *f;
1161     String *tm;
1162
1163     if (!addSymbol(iname, n))
1164       return SWIG_ERROR;
1165
1166     f = NewWrapper();
1167     // evaluation function names
1168
1169     String *var_name = Swig_name_wrapper(iname);
1170
1171     // Build the name for scheme.
1172     proc_name = NewString(iname);
1173     Replaceall(proc_name, "_", "-");
1174     Setattr(n, "wrap:name", proc_name);
1175
1176     if (1 || (SwigType_type(t) != T_USER) || (is_a_pointer(t))) {
1177
1178       Printf(f->def, "static SCM\n%s(SCM s_0)\n{\n", var_name);
1179
1180       /* Define the scheme name in C. This define is used by several Guile
1181          macros. */
1182       Printv(f->def, "#define FUNC_NAME \"", proc_name, "\"", NIL);
1183
1184       Wrapper_add_local(f, "gswig_result", "SCM gswig_result");
1185
1186       if (!GetFlag(n, "feature:immutable")) {
1187         /* Check for a setting of the variable value */
1188         Printf(f->code, "if (s_0 != SCM_UNDEFINED) {\n");
1189         if ((tm = Swig_typemap_lookup("varin", n, name, 0))) {
1190           Replaceall(tm, "$source", "s_0");
1191           Replaceall(tm, "$input", "s_0");
1192           Replaceall(tm, "$target", name);
1193           /* Printv(f->code,tm,"\n",NIL); */
1194           emit_action_code(n, f->code, tm);
1195         } else {
1196           throw_unhandled_guile_type_error(t);
1197         }
1198         Printf(f->code, "}\n");
1199       }
1200       // Now return the value of the variable (regardless
1201       // of evaluating or setting)
1202
1203       if ((tm = Swig_typemap_lookup("varout", n, name, 0))) {
1204         Replaceall(tm, "$source", name);
1205         Replaceall(tm, "$target", "gswig_result");
1206         Replaceall(tm, "$result", "gswig_result");
1207         /* Printv(f->code,tm,"\n",NIL); */
1208         emit_action_code(n, f->code, tm);
1209       } else {
1210         throw_unhandled_guile_type_error(t);
1211       }
1212       Printf(f->code, "\nreturn gswig_result;\n");
1213       Printf(f->code, "#undef FUNC_NAME\n");
1214       Printf(f->code, "}\n");
1215
1216       Wrapper_print(f, f_wrappers);
1217
1218       // Now add symbol to the Guile interpreter
1219
1220       if (!emit_setters || GetFlag(n, "feature:immutable")) {
1221         /* Read-only variables become a simple procedure returning the
1222            value; read-write variables become a simple procedure with
1223            an optional argument. */
1224         if (use_scm_interface) {
1225
1226           if (!goops && GetFlag(n, "feature:constasvar")) {
1227             /* need to export this function as a variable instead of a procedure */
1228             if (scmstub) {
1229               /* export the function in the wrapper, and (set!) it in scmstub */
1230               Printf(f_init, "scm_c_define_gsubr(\"%s\", 0, %d, 0, (swig_guile_proc) %s);\n", proc_name, !GetFlag(n, "feature:immutable"), var_name);
1231               Printf(scmtext, "(set! %s (%s))\n", proc_name, proc_name);
1232             } else {
1233               /* export the variable directly */
1234               Printf(f_init, "scm_c_define(\"%s\", %s(SCM_UNDEFINED));\n", proc_name, var_name);
1235             }
1236
1237           } else {
1238             /* Export the function as normal */
1239             Printf(f_init, "scm_c_define_gsubr(\"%s\", 0, %d, 0, (swig_guile_proc) %s);\n", proc_name, !GetFlag(n, "feature:immutable"), var_name);
1240           }
1241
1242         } else {
1243           Printf(f_init, "\t gh_new_procedure(\"%s\", (swig_guile_proc) %s, 0, %d, 0);\n", proc_name, var_name, !GetFlag(n, "feature:immutable"));
1244         }
1245       } else {
1246         /* Read/write variables become a procedure with setter. */
1247         if (use_scm_interface) {
1248           Printf(f_init, "{ SCM p = scm_c_define_gsubr(\"%s\", 0, 1, 0, (swig_guile_proc) %s);\n", proc_name, var_name);
1249           Printf(f_init, "scm_c_define");
1250         } else {
1251           Printf(f_init, "\t{ SCM p = gh_new_procedure(\"%s\", (swig_guile_proc) %s, 0, 1, 0);\n", proc_name, var_name);
1252           Printf(f_init, "gh_define");
1253         }
1254         Printf(f_init, "(\"%s\", " "scm_make_procedure_with_setter(p, p)); }\n", proc_name);
1255       }
1256       Printf(exported_symbols, "\"%s\", ", proc_name);
1257
1258       // export wrapper into goops file
1259       if (!in_class) {          // only if the variable is not part of a class
1260         String *class_name = SwigType_typedef_resolve_all(SwigType_base(t));
1261         String *goops_name = goopsNameMapping(proc_name, (char *) "");
1262         String *primitive_name = NewString("");
1263         if (primRenamer)
1264           Printv(primitive_name, "primitive:", NIL);
1265         Printv(primitive_name, proc_name, NIL);
1266         /* Simply re-export the procedure */
1267         if ((!emit_setters || GetFlag(n, "feature:immutable"))
1268             && GetFlag(n, "feature:constasvar")) {
1269           Printv(goopscode, "(define ", goops_name, " (", primitive_name, "))\n", NIL);
1270         } else {
1271           Printv(goopscode, "(define ", goops_name, " ", primitive_name, ")\n", NIL);
1272         }
1273         Printf(goopsexport, "%s ", goops_name);
1274         Delete(primitive_name);
1275         Delete(class_name);
1276         Delete(goops_name);
1277       }
1278
1279       if (procdoc) {
1280         /* Compute documentation */
1281         String *signature = NewString("");
1282         String *signature2 = NULL;
1283         String *doc = NewString("");
1284
1285         if (GetFlag(n, "feature:immutable")) {
1286           Printv(signature, proc_name, NIL);
1287           if (GetFlag(n, "feature:constasvar")) {
1288             Printv(doc, "Is constant ", NIL);
1289           } else {
1290             Printv(doc, "Returns constant ", NIL);
1291           }
1292           if ((tm = Getattr(n, "tmap:varout:doc"))) {
1293             Printv(doc, tm, NIL);
1294           } else {
1295             String *s = SwigType_str(t, 0);
1296             Chop(s);
1297             Printf(doc, "<%s>", s);
1298             Delete(s);
1299           }
1300         } else if (emit_setters) {
1301           Printv(signature, proc_name, NIL);
1302           signature2 = NewString("");
1303           Printv(signature2, "set! (", proc_name, ") ", NIL);
1304           handle_documentation_typemap(signature2, NIL, n, "tmap:varin:arglist", "new-value");
1305           Printv(doc, "Get or set the value of the C variable, \n", NIL);
1306           Printv(doc, "which is of type ", NIL);
1307           handle_documentation_typemap(doc, NIL, n, "tmap:varout:doc", "$1_type");
1308           Printv(doc, ".");
1309         } else {
1310           Printv(signature, proc_name, " #:optional ", NIL);
1311           if ((tm = Getattr(n, "tmap:varin:doc"))) {
1312             Printv(signature, tm, NIL);
1313           } else {
1314             String *s = SwigType_str(t, 0);
1315             Chop(s);
1316             Printf(signature, "new-value <%s>", s);
1317             Delete(s);
1318           }
1319
1320           Printv(doc, "If NEW-VALUE is provided, " "set C variable to this value.\n", NIL);
1321           Printv(doc, "Returns variable value ", NIL);
1322           if ((tm = Getattr(n, "tmap:varout:doc"))) {
1323             Printv(doc, tm, NIL);
1324           } else {
1325             String *s = SwigType_str(t, 0);
1326             Chop(s);
1327             Printf(doc, "<%s>", s);
1328             Delete(s);
1329           }
1330         }
1331         write_doc(proc_name, signature, doc, signature2);
1332         Delete(signature);
1333         if (signature2)
1334           Delete(signature2);
1335         Delete(doc);
1336       }
1337
1338     } else {
1339       Swig_warning(WARN_TYPEMAP_VAR_UNDEF, input_file, line_number, "Unsupported variable type %s (ignored).\n", SwigType_str(t, 0));
1340     }
1341     Delete(var_name);
1342     Delete(proc_name);
1343     DelWrapper(f);
1344     return SWIG_OK;
1345   }
1346
1347   /* ------------------------------------------------------------
1348    * constantWrapper()
1349    *
1350    * We create a read-only variable.
1351    * ------------------------------------------------------------ */
1352
1353   virtual int constantWrapper(Node *n) {
1354     char *name = GetChar(n, "name");
1355     char *iname = GetChar(n, "sym:name");
1356     SwigType *type = Getattr(n, "type");
1357     String *value = Getattr(n, "value");
1358     int constasvar = GetFlag(n, "feature:constasvar");
1359
1360
1361     String *proc_name;
1362     String *var_name;
1363     String *rvalue;
1364     Wrapper *f;
1365     SwigType *nctype;
1366     String *tm;
1367
1368     f = NewWrapper();
1369
1370     // Make a static variable;
1371     var_name = NewStringf("%sconst_%s", prefix, iname);
1372
1373     // Strip const qualifier from type if present
1374
1375     nctype = NewString(type);
1376     if (SwigType_isconst(nctype)) {
1377       Delete(SwigType_pop(nctype));
1378     }
1379     // Build the name for scheme.
1380     proc_name = NewString(iname);
1381     Replaceall(proc_name, "_", "-");
1382
1383     if ((SwigType_type(nctype) == T_USER) && (!is_a_pointer(nctype))) {
1384       Swig_warning(WARN_TYPEMAP_CONST_UNDEF, input_file, line_number, "Unsupported constant value.\n");
1385       Delete(var_name);
1386       DelWrapper(f);
1387       return SWIG_NOWRAP;
1388     }
1389     // See if there's a typemap
1390
1391     if (SwigType_type(nctype) == T_STRING) {
1392       rvalue = NewStringf("\"%s\"", value);
1393     } else if (SwigType_type(nctype) == T_CHAR) {
1394       rvalue = NewStringf("\'%s\'", value);
1395     } else {
1396       rvalue = NewString(value);
1397     }
1398
1399     if ((tm = Swig_typemap_lookup("constant", n, name, 0))) {
1400       Replaceall(tm, "$source", rvalue);
1401       Replaceall(tm, "$value", rvalue);
1402       Replaceall(tm, "$target", name);
1403       Printv(f_header, tm, "\n", NIL);
1404     } else {
1405       // Create variable and assign it a value
1406       Printf(f_header, "static %s = %s;\n", SwigType_lstr(nctype, var_name), rvalue);
1407     }
1408     {
1409       /* Hack alert: will cleanup later -- Dave */
1410       Node *n = NewHash();
1411       Setattr(n, "name", var_name);
1412       Setattr(n, "sym:name", iname);
1413       Setattr(n, "type", nctype);
1414       SetFlag(n, "feature:immutable");
1415       if (constasvar) {
1416         SetFlag(n, "feature:constasvar");
1417       }
1418       variableWrapper(n);
1419       Delete(n);
1420     }
1421     Delete(var_name);
1422     Delete(nctype);
1423     Delete(proc_name);
1424     Delete(rvalue);
1425     DelWrapper(f);
1426     return SWIG_OK;
1427   }
1428
1429   /* ------------------------------------------------------------
1430    * classDeclaration()
1431    * ------------------------------------------------------------ */
1432   virtual int classDeclaration(Node *n) {
1433     String *class_name = NewStringf("<%s>", Getattr(n, "sym:name"));
1434     Setattr(n, "guile:goopsclassname", class_name);
1435     return Language::classDeclaration(n);
1436   }
1437
1438   /* ------------------------------------------------------------
1439    * classHandler()
1440    * ------------------------------------------------------------ */
1441   virtual int classHandler(Node *n) {
1442     /* Create new strings for building up a wrapper function */
1443     have_constructor = 0;
1444
1445     class_name = NewString("");
1446     short_class_name = NewString("");
1447     Printv(class_name, "<", Getattr(n, "sym:name"), ">", NIL);
1448     Printv(short_class_name, Getattr(n, "sym:name"), NIL);
1449     Replaceall(class_name, "_", "-");
1450     Replaceall(short_class_name, "_", "-");
1451
1452     if (!addSymbol(class_name, n))
1453       return SWIG_ERROR;
1454
1455     /* Handle inheritance */
1456     String *base_class = NewString("<");
1457     List *baselist = Getattr(n, "bases");
1458     if (baselist && Len(baselist)) {
1459       Iterator i = First(baselist);
1460       while (i.item) {
1461         Printv(base_class, Getattr(i.item, "sym:name"), NIL);
1462         i = Next(i);
1463         if (i.item) {
1464           Printf(base_class, "> <");
1465         }
1466       }
1467     }
1468     Printf(base_class, ">");
1469     Replaceall(base_class, "_", "-");
1470
1471     Printv(goopscode, "(define-class ", class_name, " ", NIL);
1472     Printf(goopsexport, "%s ", class_name);
1473
1474     if (Len(base_class) > 2) {
1475       Printv(goopscode, "(", base_class, ")\n", NIL);
1476     } else {
1477       Printv(goopscode, "(<swig>)\n", NIL);
1478     }
1479     SwigType *ct = NewStringf("p.%s", Getattr(n, "name"));
1480     swigtype_ptr = SwigType_manglestr(ct);
1481
1482     String *mangled_classname = Swig_name_mangle(Getattr(n, "sym:name"));
1483     /* Export clientdata structure */
1484     if (use_scm_interface) {
1485       Printf(f_runtime, "static swig_guile_clientdata _swig_guile_clientdata%s = { NULL, SCM_EOL };\n", mangled_classname);
1486
1487       Printv(f_init, "SWIG_TypeClientData(SWIGTYPE", swigtype_ptr, ", (void *) &_swig_guile_clientdata", mangled_classname, ");\n", NIL);
1488       SwigType_remember(ct);
1489     }
1490     Delete(ct);
1491
1492     /* Emit all of the members */
1493     goops_class_methods = NewString("");
1494
1495     in_class = 1;
1496     Language::classHandler(n);
1497     in_class = 0;
1498
1499     Printv(goopscode, "  #:metaclass <swig-metaclass>\n", NIL);
1500
1501     if (have_constructor)
1502       Printv(goopscode, "  #:new-function ", primRenamer ? "primitive:" : "", "new-", short_class_name, "\n", NIL);
1503
1504     Printf(goopscode, ")\n%s\n", goops_class_methods);
1505     Delete(goops_class_methods);
1506     goops_class_methods = 0;
1507
1508
1509     /* export class initialization function */
1510     if (goops) {
1511       /* export the wrapper function */
1512       String *funcName = NewString(mangled_classname);
1513       Printf(funcName, "_swig_guile_setgoopsclass");
1514       String *guileFuncName = NewString(funcName);
1515       Replaceall(guileFuncName, "_", "-");
1516
1517       Printv(f_wrappers, "static SCM ", funcName, "(SCM cl) \n", NIL);
1518       Printf(f_wrappers, "#define FUNC_NAME %s\n{\n", guileFuncName);
1519       Printv(f_wrappers, "  ((swig_guile_clientdata *)(SWIGTYPE", swigtype_ptr, "->clientdata))->goops_class = cl;\n", NIL);
1520       Printf(f_wrappers, "  return SCM_UNSPECIFIED;\n");
1521       Printf(f_wrappers, "}\n#undef FUNC_NAME\n\n");
1522
1523       Printf(f_init, "scm_c_define_gsubr(\"%s\", 1, 0, 0, (swig_guile_proc) %s);\n", guileFuncName, funcName);
1524       Printf(exported_symbols, "\"%s\", ", guileFuncName);
1525
1526       /* export the call to the wrapper function */
1527       Printf(goopscode, "(%s%s %s)\n\n", primRenamer ? "primitive:" : "", guileFuncName, class_name);
1528
1529       Delete(guileFuncName);
1530       Delete(funcName);
1531     }
1532
1533     Delete(mangled_classname);
1534
1535     Delete(swigtype_ptr);
1536     swigtype_ptr = 0;
1537
1538     Delete(class_name);
1539     Delete(short_class_name);
1540     class_name = 0;
1541     short_class_name = 0;
1542
1543     return SWIG_OK;
1544   }
1545
1546   /* ------------------------------------------------------------
1547    * memberfunctionHandler()
1548    * ------------------------------------------------------------ */
1549   int memberfunctionHandler(Node *n) {
1550     String *iname = Getattr(n, "sym:name");
1551     String *proc = NewString(iname);
1552     Replaceall(proc, "_", "-");
1553
1554     memberfunction_name = goopsNameMapping(proc, short_class_name);
1555     Language::memberfunctionHandler(n);
1556     Delete(memberfunction_name);
1557     memberfunction_name = NULL;
1558     Delete(proc);
1559     return SWIG_OK;
1560   }
1561
1562   /* ------------------------------------------------------------
1563    * membervariableHandler()
1564    * ------------------------------------------------------------ */
1565   int membervariableHandler(Node *n) {
1566     String *iname = Getattr(n, "sym:name");
1567
1568     if (emit_setters) {
1569       struct_member = 1;
1570       Printf(f_init, "{\n");
1571     }
1572
1573     Language::membervariableHandler(n);
1574
1575     if (emit_setters) {
1576       Printf(f_init, "}\n");
1577       struct_member = 0;
1578     }
1579
1580     String *proc = NewString(iname);
1581     Replaceall(proc, "_", "-");
1582     String *goops_name = goopsNameMapping(proc, short_class_name);
1583
1584     /* The slot name is never qualified with the class,
1585        even if useclassprefix is true. */
1586     Printv(goopscode, "  (", proc, " #:allocation #:virtual", NIL);
1587     /* GOOPS (at least in Guile 1.6.3) only accepts closures, not
1588        primitive procedures for slot-ref and slot-set. */
1589     Printv(goopscode, "\n   #:slot-ref (lambda (obj) (", primRenamer ? "primitive:" : "", short_class_name, "-", proc, "-get", " obj))", NIL);
1590     if (!GetFlag(n, "feature:immutable")) {
1591       Printv(goopscode, "\n   #:slot-set! (lambda (obj value) (", primRenamer ? "primitive:" : "", short_class_name, "-", proc, "-set", " obj value))", NIL);
1592     } else {
1593       Printf(goopscode, "\n   #:slot-set! (lambda (obj value) (error \"Immutable slot\"))");
1594     }
1595     if (emit_slot_accessors) {
1596       if (GetFlag(n, "feature:immutable")) {
1597         Printv(goopscode, "\n   #:getter ", goops_name, NIL);
1598       } else {
1599         Printv(goopscode, "\n   #:accessor ", goops_name, NIL);
1600       }
1601       Printf(goopsexport, "%s ", goops_name);
1602     }
1603     Printv(goopscode, ")\n", NIL);
1604     Delete(proc);
1605     Delete(goops_name);
1606     return SWIG_OK;
1607   }
1608
1609   /* ------------------------------------------------------------
1610    * constructorHandler()
1611    * ------------------------------------------------------------ */
1612   int constructorHandler(Node *n) {
1613     Language::constructorHandler(n);
1614     have_constructor = 1;
1615     return SWIG_OK;
1616   }
1617
1618   /* ------------------------------------------------------------
1619    * destructorHandler()
1620    * ------------------------------------------------------------ */
1621   virtual int destructorHandler(Node *n) {
1622     exporting_destructor = true;
1623     Language::destructorHandler(n);
1624     exporting_destructor = false;
1625     return SWIG_OK;
1626   }
1627
1628   /* ------------------------------------------------------------
1629    * pragmaDirective()
1630    * ------------------------------------------------------------ */
1631
1632   virtual int pragmaDirective(Node *n) {
1633     if (!ImportMode) {
1634       String *lang = Getattr(n, "lang");
1635       String *cmd = Getattr(n, "name");
1636       String *value = Getattr(n, "value");
1637
1638 #     define store_pragma(PRAGMANAME)                   \
1639         if (Strcmp(cmd, #PRAGMANAME) == 0) {            \
1640           if (PRAGMANAME) Delete(PRAGMANAME);           \
1641           PRAGMANAME = value ? NewString(value) : NULL; \
1642         }
1643
1644       if (Strcmp(lang, "guile") == 0) {
1645         store_pragma(beforereturn)
1646             store_pragma(return_nothing_doc)
1647             store_pragma(return_one_doc)
1648             store_pragma(return_multi_doc);
1649 #     undef store_pragma
1650       }
1651     }
1652     return Language::pragmaDirective(n);
1653   }
1654
1655
1656   /* ------------------------------------------------------------
1657    * goopsNameMapping()
1658    * Maps the identifier from C++ to the GOOPS based * on command
1659    * line parameters and such.
1660    * If class_name = "" that means the mapping is for a function or
1661    * variable not attached to any class.
1662    * ------------------------------------------------------------ */
1663   String *goopsNameMapping(String *name, const_String_or_char_ptr class_name) {
1664     String *n = NewString("");
1665
1666     if (Strcmp(class_name, "") == 0) {
1667       // not part of a class, so no class name to prefix
1668       if (goopsprefix) {
1669         Printf(n, "%s%s", goopsprefix, name);
1670       } else {
1671         Printf(n, "%s", name);
1672       }
1673     } else {
1674       if (useclassprefix) {
1675         Printf(n, "%s-%s", class_name, name);
1676       } else {
1677         if (goopsprefix) {
1678           Printf(n, "%s%s", goopsprefix, name);
1679         } else {
1680           Printf(n, "%s", name);
1681         }
1682       }
1683     }
1684     return n;
1685   }
1686
1687
1688   /* ------------------------------------------------------------
1689    * validIdentifier()
1690    * ------------------------------------------------------------ */
1691
1692   virtual int validIdentifier(String *s) {
1693     char *c = Char(s);
1694     /* Check whether we have an R5RS identifier.  Guile supports a
1695        superset of R5RS identifiers, but it's probably a bad idea to use
1696        those. */
1697     /* <identifier> --> <initial> <subsequent>* | <peculiar identifier> */
1698     /* <initial> --> <letter> | <special initial> */
1699     if (!(isalpha(*c) || (*c == '!') || (*c == '$') || (*c == '%')
1700           || (*c == '&') || (*c == '*') || (*c == '/') || (*c == ':')
1701           || (*c == '<') || (*c == '=') || (*c == '>') || (*c == '?')
1702           || (*c == '^') || (*c == '_') || (*c == '~'))) {
1703       /* <peculiar identifier> --> + | - | ... */
1704       if ((strcmp(c, "+") == 0)
1705           || strcmp(c, "-") == 0 || strcmp(c, "...") == 0)
1706         return 1;
1707       else
1708         return 0;
1709     }
1710     /* <subsequent> --> <initial> | <digit> | <special subsequent> */
1711     while (*c) {
1712       if (!(isalnum(*c) || (*c == '!') || (*c == '$') || (*c == '%')
1713             || (*c == '&') || (*c == '*') || (*c == '/') || (*c == ':')
1714             || (*c == '<') || (*c == '=') || (*c == '>') || (*c == '?')
1715             || (*c == '^') || (*c == '_') || (*c == '~') || (*c == '+')
1716             || (*c == '-') || (*c == '.') || (*c == '@')))
1717         return 0;
1718       c++;
1719     }
1720     return 1;
1721   }
1722
1723   String *runtimeCode() {
1724     String *s;
1725     if (use_scm_interface) {
1726       s = Swig_include_sys("guile_scm_run.swg");
1727       if (!s) {
1728         Printf(stderr, "*** Unable to open 'guile_scm_run.swg");
1729         s = NewString("");
1730       }
1731     } else {
1732       s = Swig_include_sys("guile_gh_run.swg");
1733       if (!s) {
1734         Printf(stderr, "*** Unable to open 'guile_gh_run.swg");
1735         s = NewString("");
1736       }
1737     }
1738     return s;
1739   }
1740
1741   String *defaultExternalRuntimeFilename() {
1742     if (use_scm_interface) {
1743       return NewString("swigguilerun.h");
1744     } else {
1745       return NewString("swigguileghrun.h");
1746     }
1747   }
1748 };
1749
1750 /* -----------------------------------------------------------------------------
1751  * swig_guile()    - Instantiate module
1752  * ----------------------------------------------------------------------------- */
1753
1754 static Language *new_swig_guile() {
1755   return new GUILE();
1756 }
1757 extern "C" Language *swig_guile(void) {
1758   return new_swig_guile();
1759 }