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 10char 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 17static const char *guile_usage = (char *) "\ 18Guile 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 50static File *f_begin = 0; 51static File *f_runtime = 0; 52static File *f_header = 0; 53static File *f_wrappers = 0; 54static File *f_init = 0; 55 56 57static char *prefix = (char *) "gswig_"; 58static char *module = 0; 59static char *package = 0; 60static 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 68static File *procdoc = 0; 69static bool scmstub = false; 70static String *scmtext; 71static bool goops = false; 72static String *goopstext; 73static String *goopscode; 74static String *goopsexport; 75 76static enum { 77 GUILE_1_4, 78 PLAIN, 79 TEXINFO 80} docformat = GUILE_1_4; 81 82static int emit_setters = 0; 83static int only_setters = 0; 84static int emit_slot_accessors = 0; 85static int struct_member = 0; 86 87static String *beforereturn = 0; 88static String *return_nothing_doc = 0; 89static String *return_one_doc = 0; 90static String *return_multi_doc = 0; 91 92static String *exported_symbols = 0; 93 94static int use_scm_interface = 1; 95static int exporting_destructor = 0; 96static String *swigtype_ptr = 0; 97 98/* GOOPS stuff */ 99static String *primsuffix = 0; 100static String *class_name = 0; 101static String *short_class_name = 0; 102static String *goops_class_methods; 103static int in_class = 0; 104static int have_constructor = 0; 105static int useclassprefix = 0; // -useclassprefix argument 106static String *goopsprefix = 0; // -goopsprefix argument 107static int primRenamer = 0; // if (use-modules ((...) :renamer ...) is exported to GOOPS file 108static int exportprimitive = 0; // -exportprimitive argument 109static String *memberfunction_name = 0; 110 111extern "C" { 112 static int has_classname(Node *class_node) { 113 return Getattr(class_node, "guile:goopsclassname") != NULL; 114 } 115} 116 117class GUILE:public Language { 118public: 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 1754static Language *new_swig_guile() { 1755 return new GUILE(); 1756} 1757extern "C" Language *swig_guile(void) { 1758 return new_swig_guile(); 1759} 1760