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.
7 * Guile language module for SWIG.
8 * ----------------------------------------------------------------------------- */
10 char cvsroot_guile_cxx[] = "$Id: guile.cxx 11133 2009-02-20 07:52:24Z wsfulton $";
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\
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\
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\
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;
57 static char *prefix = (char *) "gswig_";
58 static char *module = 0;
59 static char *package = 0;
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;
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;
80 } docformat = GUILE_1_4;
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;
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;
92 static String *exported_symbols = 0;
94 static int use_scm_interface = 1;
95 static int exporting_destructor = 0;
96 static String *swigtype_ptr = 0;
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;
112 static int has_classname(Node *class_node) {
113 return Getattr(class_node, "guile:goopsclassname") != NULL;
117 class GUILE:public Language {
120 /* ------------------------------------------------------------
122 * ------------------------------------------------------------ */
124 virtual void main(int argc, char *argv[]) {
127 SWIG_library_directory("guile");
128 SWIG_typemap_lang("guile");
130 // Look for certain command line options
131 for (i = 1; i < argc; 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) {
138 prefix = new char[strlen(argv[i + 1]) + 2];
139 strcpy(prefix, argv[i + 1]);
141 Swig_mark_arg(i + 1);
146 } else if (strcmp(argv[i], "-package") == 0) {
148 package = new char[strlen(argv[i + 1]) + 2];
149 strcpy(package, argv[i + 1]);
151 Swig_mark_arg(i + 1);
156 } else if (strcmp(argv[i], "-Linkage") == 0 || strcmp(argv[i], "-linkage") == 0) {
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;
171 Swig_mark_arg(i + 1);
176 } else if (strcmp(argv[i], "-procdoc") == 0) {
178 procdoc = NewFile(argv[i + 1], "w", SWIG_output_files());
180 FileErrorDisplay(argv[i + 1]);
181 SWIG_exit(EXIT_FAILURE);
184 Swig_mark_arg(i + 1);
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)
194 else if (strcmp(argv[i + 1], "texinfo") == 0)
199 Swig_mark_arg(i + 1);
201 } else if (strcmp(argv[i], "-emit-setters") == 0 || strcmp(argv[i], "-emitsetters") == 0) {
204 } else if (strcmp(argv[i], "-only-setters") == 0 || strcmp(argv[i], "-onlysetters") == 0) {
208 } else if (strcmp(argv[i], "-emit-slot-accessors") == 0 || strcmp(argv[i], "-emitslotaccessors") == 0) {
209 emit_slot_accessors = 1;
211 } else if (strcmp(argv[i], "-scmstub") == 0) {
214 } else if ((strcmp(argv[i], "-shadow") == 0) || ((strcmp(argv[i], "-proxy") == 0))) {
217 } else if (strcmp(argv[i], "-gh") == 0) {
218 use_scm_interface = 0;
220 } else if (strcmp(argv[i], "-scm") == 0) {
221 use_scm_interface = 1;
223 } else if (strcmp(argv[i], "-primsuffix") == 0) {
225 primsuffix = NewString(argv[i + 1]);
227 Swig_mark_arg(i + 1);
232 } else if (strcmp(argv[i], "-goopsprefix") == 0) {
234 goopsprefix = NewString(argv[i + 1]);
236 Swig_mark_arg(i + 1);
241 } else if (strcmp(argv[i], "-useclassprefix") == 0) {
244 } else if (strcmp(argv[i], "-exportprimitive") == 0) {
246 // should use Swig_warning() here?
252 // set default value for primsuffix
253 if (primsuffix == NULL)
254 primsuffix = NewString("primitive");
256 //goops support can only be enabled if passive or module linkage is used
258 if (linkage != GUILE_LSTYLE_PASSIVE && linkage != GUILE_LSTYLE_MODULE) {
259 Printf(stderr, "guile: GOOPS support requires passive or module linkage\n");
265 // -proxy implies -emit-setters
269 if ((linkage == GUILE_LSTYLE_PASSIVE && scmstub) || linkage == GUILE_LSTYLE_MODULE)
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");
276 // Make sure `prefix' ends in an underscore
278 orig_len = strlen(prefix);
279 if (prefix[orig_len - 1] != '_') {
280 prefix[1 + orig_len] = 0;
281 prefix[orig_len] = '_';
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");
290 SWIG_config_file("guile_gh.swg");
295 /* ------------------------------------------------------------
297 * ------------------------------------------------------------ */
299 virtual int top(Node *n) {
300 /* Initialize all of the output files */
301 String *outfile = Getattr(n, "outfile");
303 f_begin = NewFile(outfile, "w", SWIG_output_files());
305 FileErrorDisplay(outfile);
306 SWIG_exit(EXIT_FAILURE);
308 f_runtime = NewString("");
309 f_init = NewString("");
310 f_header = NewString("");
311 f_wrappers = NewString("");
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);
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("");
328 Swig_banner(f_begin);
330 Printf(f_runtime, "\n");
331 Printf(f_runtime, "#define SWIGGUILE\n");
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");
340 /* Write out directives and declarations */
342 module = Swig_copy_string(Char(Getattr(n, "name")));
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");
351 /* Other linkage; we make the SWIG_init function static */
352 Printf(f_runtime, "#define SWIG_GUILE_INIT_STATIC static\n");
357 Printf(f_runtime, "extern \"C\" {\n\n");
359 Printf(f_runtime, "SWIG_GUILE_INIT_STATIC void\nSWIG_init (void);\n");
361 Printf(f_runtime, "\n}\n");
364 Printf(f_runtime, "\n");
370 Printf(f_wrappers, "#ifdef __cplusplus\nextern \"C\" {\n#endif\n");
372 SwigType_emit_type_table(f_runtime, f_wrappers);
374 Printf(f_init, "}\n\n");
375 Printf(f_init, "#ifdef __cplusplus\n}\n#endif\n");
377 String *module_name = NewString("");
380 Printv(module_name, "swig", NIL);
383 Printf(module_name, "%s/%s", package, module);
385 Printv(module_name, module, NIL);
387 emit_linkage(module_name);
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);
413 void emit_linkage(String *module_name) {
414 String *module_func = NewString("");
417 Printf(f_init, "extern \"C\" {\n\n");
420 Printv(module_func, module_name, NIL);
421 Replaceall(module_func, "-", "_");
424 case GUILE_LSTYLE_SIMPLE:
425 Printf(f_init, "\n/* Linkage: simple */\n");
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");
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");
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);
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");
451 Printf(f_init, "}\n");
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");
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");
465 Printf(f_init, "SCM\n%s (void)\n{\n", module_func);
467 String *mod = NewString(module_name);
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");
476 Printf(f_init, "}\n");
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);
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");
490 Printf(f_init, "}\n");
497 /* Emit Scheme stub if requested */
498 String *primitive_name = NewString(module_name);
500 Printv(primitive_name, "-", primsuffix, NIL);
502 String *mod = NewString(primitive_name);
503 Replaceall(mod, "/", " ");
505 String *fname = NewStringf("%s%s.scm",
506 SWIG_output_directory(),
508 Delete(primitive_name);
509 File *scmstubfile = NewFile(fname, "w", SWIG_output_files());
511 FileErrorDisplay(fname);
512 SWIG_exit(EXIT_FAILURE);
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);
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, "\"", "");
528 Printf(scmstubfile, "\n(export %s)\n", ex);
535 String *mod = NewString(module_name);
536 Replaceall(mod, "/", " ");
538 String *fname = NewStringf("%s%s.scm", SWIG_output_directory(),
540 File *goopsfile = NewFile(fname, "w", SWIG_output_files());
542 FileErrorDisplay(fname);
543 SWIG_exit(EXIT_FAILURE);
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");
552 Printf(goopsfile, "(use-modules ((%s-%s) :renamer (symbol-prefix-proc 'primitive:)))\n", mod, primsuffix);
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, "\"", "");
560 Printf(goopsfile, "\n(export %s)", ex);
569 Printf(f_init, "\n}\n");
573 /* Return true iff T is a pointer type */
575 int is_a_pointer(SwigType *t) {
576 return SwigType_ispointer(SwigType_typedef_resolve_all(t));
579 /* Report an error handling the given type. */
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));
585 /* Write out procedure documentation */
587 void write_doc(const String *proc_name, const String *signature, const String *doc, const String *signature2 = NULL) {
590 Printv(procdoc, "\f\n", NIL);
591 Printv(procdoc, "(", signature, ")\n", NIL);
593 Printv(procdoc, "(", signature2, ")\n", NIL);
594 Printv(procdoc, doc, "\n", NIL);
597 Printv(procdoc, "\f", proc_name, "\n\n", NIL);
598 Printv(procdoc, "(", signature, ")\n", NIL);
600 Printv(procdoc, "(", signature2, ")\n", NIL);
601 Printv(procdoc, doc, "\n\n", NIL);
604 Printv(procdoc, "\f", proc_name, "\n", NIL);
605 Printv(procdoc, "@deffn primitive ", signature, "\n", NIL);
607 Printv(procdoc, "@deffnx primitive ", signature2, "\n", NIL);
608 Printv(procdoc, doc, "\n", NIL);
609 Printv(procdoc, "@end deffn\n\n", NIL);
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("");
619 if (!(tm = Getattr(p, typemap))) {
620 Printf(tmp, "%s", default_doc);
623 bool result = (Len(tm) > 0);
624 if (maybe_delimiter && Len(output) > 0 && Len(tm) > 0) {
625 Printv(output, maybe_delimiter, NIL);
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);
636 Printf(ARGNAME, "%(upper)s", pn);
637 Replaceall(tm, "$NAME", ARGNAME);
638 Replaceall(tm, "$PARMNAME", ARGNAME);
639 Printv(output, tm, NIL);
644 /* ------------------------------------------------------------
646 * Create a function declaration and register it with the interpreter.
647 * ------------------------------------------------------------ */
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");
654 String *proc_name = 0;
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();
666 String *tmp = NewString("");
671 String *overname = 0;
672 int args_passed_as_array = 0;
673 int scheme_argnum = 0;
674 bool any_specialized_arg = false;
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;
682 if (!addSymbol(iname, n)) {
688 Append(wname, overname);
690 Setattr(n, "wrap:name", wname);
692 // Build the name for scheme.
693 proc_name = NewString(iname);
694 Replaceall(proc_name, "_", "-");
696 /* Emit locals etc. into f->code; figure out which args to ignore */
697 emit_parameter_variables(l, f);
699 /* Attach the standard typemaps */
700 emit_attach_parmmaps(l, f);
701 Setattr(n, "wrap:parms", l);
703 /* Get number of required and total arguments */
704 numargs = emit_num_arguments(l);
705 numreq = emit_num_required(l);
707 /* Declare return variable */
709 Wrapper_add_local(f, "gswig_result", "SCM gswig_result");
710 Wrapper_add_local(f, "gswig_list_p", "SWIGUNUSED int gswig_list_p = 0");
712 /* Open prototype and signature */
714 Printv(f->def, "static SCM\n", wname, " (", NIL);
715 if (args_passed_as_array) {
716 Printv(f->def, "int argc, SCM *argv", NIL);
718 Printv(signature, proc_name, NIL);
720 /* Now write code to extract the parameters */
722 for (i = 0, p = l; i < numargs; i++) {
724 while (checkAttribute(p, "tmap:in:numinputs", "0")) {
725 p = Getattr(p, "tmap:in:next");
728 SwigType *pt = Getattr(p, "type");
729 int opt_p = (i >= numreq);
731 // Produce names of source and target
732 if (args_passed_as_array)
733 sprintf(source, "argv[%d]", i);
735 sprintf(source, "s_%d", i);
736 String *target = Getattr(p, "lname");
738 if (!args_passed_as_array) {
740 Printf(f->def, ", ");
741 Printf(f->def, "SCM s_%d", i);
744 Printf(f->code, " if (%s != SCM_UNDEFINED) {\n", source);
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);
753 SwigType *pb = SwigType_typedef_resolve_all(SwigType_base(pt));
754 SwigType *pn = Getattr(p, "name");
757 if (pn && !Getattr(scheme_arg_names, pn))
760 /* Anonymous arg or re-used argument name -- choose a name that cannot clash */
761 argname = NewStringf("%%arg%d", scheme_argnum);
766 /* First optional argument */
767 Printf(signature, " #:optional");
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);
777 if (strcmp("void", Char(pt)) != 0) {
778 Node *class_node = Swig_symbol_clookup_check(pb, Getattr(n, "sym:symtab"),
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;
786 Printv(method_signature, " ", argname, NIL);
788 Printv(primitive_args, " ", argname, NIL);
789 Setattr(scheme_arg_names, argname, p);
797 p = Getattr(p, "tmap:in:next");
799 throw_unhandled_guile_type_error(pt);
803 Printf(f->code, " }\n");
805 if (Len(doc_body) > 0)
806 Printf(doc_body, ".\n");
808 /* Insert constraint checking code */
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");
818 /* Pass output arguments back to the caller. */
820 /* Insert argument output code */
821 String *returns_argout = NewString("");
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);
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. */
836 p = Getattr(p, "tmap:argout:next");
842 /* Insert cleanup code */
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");
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);
862 /* Close prototype */
864 Printf(f->def, ")\n{\n");
866 /* Define the scheme name in C. This define is used by several Guile
868 Printv(f->def, "#define FUNC_NAME \"", proc_name, "\"", NIL);
870 // Now write code to make the function call
871 if (!use_scm_interface)
872 Printv(f->code, tab4, "gh_defer_ints();\n", NIL);
874 String *actioncode = emit_action(n);
876 if (!use_scm_interface)
877 Printv(actioncode, tab4, "gh_allow_ints();\n", NIL);
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");
887 Replaceall(tm, "$owner", "0");
888 Printv(f->code, tm, "\n", NIL);
890 throw_unhandled_guile_type_error(d);
892 emit_return_variable(n, d, f);
895 if ((tm = Getattr(n, "tmap:out:doc"))) {
896 Printv(returns, tm, NIL);
902 String *s = SwigType_str(d, 0);
904 Printf(returns, "<%s>", s);
908 Append(returns, returns_argout);
911 // Dump the argument output code
912 Printv(f->code, outarg, NIL);
914 // Dump the argument cleanup code
915 Printv(f->code, cleanup, NIL);
917 // Look for any remaining cleanup
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);
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);
930 // Wrap things up (in a manner of speaking)
933 Printv(f->code, beforereturn, "\n", NIL);
934 Printv(f->code, "return gswig_result;\n", NIL);
936 /* Substitute the function name */
937 Replaceall(f->code, "$symname", iname);
938 // Undefine the scheme name
940 Printf(f->code, "#undef FUNC_NAME\n");
941 Printf(f->code, "}\n");
943 Wrapper_print(f, f_wrappers);
945 if (!Getattr(n, "sym:overloaded")) {
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);
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);
964 Printf(f_init, "gh_new_procedure(\"%s\", (swig_guile_proc) %s_rest, 0, 0, 1);\n", proc_name, wname);
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');
972 Printf(f_init, "SCM setter = ");
973 struct_member = 2; /* have a setter */
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);
982 Printf(f_init, "scm_c_define_gsubr(\"%s\", %d, %d, 0, (swig_guile_proc) %s);\n", proc_name, numreq, numargs - numreq, wname);
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);
987 Printf(f_init, "gh_new_procedure(\"%s\", (swig_guile_proc) %s, %d, %d, 0);\n", proc_name, wname, numreq, numargs - numreq);
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");
999 Printf(f_init, "gh_define");
1001 Printf(f_init, "(\"%s\", " "scm_make_procedure_with_setter(getter, setter));\n", pws_name);
1003 /* There was no setter, so make an alias to the getter */
1004 if (use_scm_interface) {
1005 Printf(f_init, "scm_c_define");
1007 Printf(f_init, "gh_define");
1009 Printf(f_init, "(\"%s\", getter);\n", pws_name);
1011 Printf(exported_symbols, "\"%s\", ", pws_name);
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);
1021 Printf(f_init, "scm_c_define_gsubr(\"%s\", %d, %d, 0, (swig_guile_proc) %s);\n", proc_name, numreq, numargs - numreq, wname);
1023 Printf(f_init, "gh_new_procedure(\"%s\", (swig_guile_proc) %s, %d, %d, 0);\n", proc_name, wname, numreq, numargs - numreq);
1026 } else { /* overloaded function; don't export the single methods */
1027 if (!Getattr(n, "sym:nextSibling")) {
1028 /* Emit overloading dispatch function */
1031 String *dispatch = Swig_overload_dispatch(n, "return %s(argc,argv);", &maxargs);
1033 /* Generate a dispatch wrapper for all overloaded functions */
1035 Wrapper *df = NewWrapper();
1036 String *dname = Swig_name_wrapper(iname);
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);
1050 Printf(f_init, "gh_new_procedure(\"%s\", (swig_guile_proc) %s, 0, 0, 1);\n", proc_name, dname);
1057 Printf(exported_symbols, "\"%s\", ", proc_name);
1059 if (!in_class || memberfunction_name) {
1060 // export wrapper into goops file
1061 String *method_def = NewString("");
1064 goops_name = NewString(memberfunction_name);
1066 goops_name = goopsNameMapping(proc_name, (char *) "");
1067 String *primitive_name = NewString("");
1069 Printv(primitive_name, "primitive:", proc_name, NIL);
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);
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);
1089 /* Defer method definition till end of class definition. */
1090 Printv(goops_class_methods, method_def, NIL);
1092 Printv(goopscode, method_def, NIL);
1094 Printf(goopsexport, "%s ", goops_name);
1095 Delete(primitive_name);
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);
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",
1114 if (num_results <= 12)
1115 Replaceall(returns_text, "$num_values", numbers[num_results]);
1117 String *num_results_str = NewStringf("%d", num_results);
1118 Replaceall(returns_text, "$num_values", num_results_str);
1119 Delete(num_results_str);
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);
1131 Delete(method_signature);
1132 Delete(primitive_args);
1134 Delete(returns_argout);
1137 Delete(scheme_arg_names);
1142 /* ------------------------------------------------------------
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
1151 * ------------------------------------------------------------ */
1153 virtual int variableWrapper(Node *n) {
1155 char *name = GetChar(n, "name");
1156 char *iname = GetChar(n, "sym:name");
1157 SwigType *t = Getattr(n, "type");
1163 if (!addSymbol(iname, n))
1167 // evaluation function names
1169 String *var_name = Swig_name_wrapper(iname);
1171 // Build the name for scheme.
1172 proc_name = NewString(iname);
1173 Replaceall(proc_name, "_", "-");
1174 Setattr(n, "wrap:name", proc_name);
1176 if (1 || (SwigType_type(t) != T_USER) || (is_a_pointer(t))) {
1178 Printf(f->def, "static SCM\n%s(SCM s_0)\n{\n", var_name);
1180 /* Define the scheme name in C. This define is used by several Guile
1182 Printv(f->def, "#define FUNC_NAME \"", proc_name, "\"", NIL);
1184 Wrapper_add_local(f, "gswig_result", "SCM gswig_result");
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);
1196 throw_unhandled_guile_type_error(t);
1198 Printf(f->code, "}\n");
1200 // Now return the value of the variable (regardless
1201 // of evaluating or setting)
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);
1210 throw_unhandled_guile_type_error(t);
1212 Printf(f->code, "\nreturn gswig_result;\n");
1213 Printf(f->code, "#undef FUNC_NAME\n");
1214 Printf(f->code, "}\n");
1216 Wrapper_print(f, f_wrappers);
1218 // Now add symbol to the Guile interpreter
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) {
1226 if (!goops && GetFlag(n, "feature:constasvar")) {
1227 /* need to export this function as a variable instead of a procedure */
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);
1233 /* export the variable directly */
1234 Printf(f_init, "scm_c_define(\"%s\", %s(SCM_UNDEFINED));\n", proc_name, var_name);
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);
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"));
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");
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");
1254 Printf(f_init, "(\"%s\", " "scm_make_procedure_with_setter(p, p)); }\n", proc_name);
1256 Printf(exported_symbols, "\"%s\", ", proc_name);
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("");
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);
1271 Printv(goopscode, "(define ", goops_name, " ", primitive_name, ")\n", NIL);
1273 Printf(goopsexport, "%s ", goops_name);
1274 Delete(primitive_name);
1280 /* Compute documentation */
1281 String *signature = NewString("");
1282 String *signature2 = NULL;
1283 String *doc = NewString("");
1285 if (GetFlag(n, "feature:immutable")) {
1286 Printv(signature, proc_name, NIL);
1287 if (GetFlag(n, "feature:constasvar")) {
1288 Printv(doc, "Is constant ", NIL);
1290 Printv(doc, "Returns constant ", NIL);
1292 if ((tm = Getattr(n, "tmap:varout:doc"))) {
1293 Printv(doc, tm, NIL);
1295 String *s = SwigType_str(t, 0);
1297 Printf(doc, "<%s>", s);
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");
1310 Printv(signature, proc_name, " #:optional ", NIL);
1311 if ((tm = Getattr(n, "tmap:varin:doc"))) {
1312 Printv(signature, tm, NIL);
1314 String *s = SwigType_str(t, 0);
1316 Printf(signature, "new-value <%s>", s);
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);
1325 String *s = SwigType_str(t, 0);
1327 Printf(doc, "<%s>", s);
1331 write_doc(proc_name, signature, doc, signature2);
1339 Swig_warning(WARN_TYPEMAP_VAR_UNDEF, input_file, line_number, "Unsupported variable type %s (ignored).\n", SwigType_str(t, 0));
1347 /* ------------------------------------------------------------
1350 * We create a read-only variable.
1351 * ------------------------------------------------------------ */
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");
1370 // Make a static variable;
1371 var_name = NewStringf("%sconst_%s", prefix, iname);
1373 // Strip const qualifier from type if present
1375 nctype = NewString(type);
1376 if (SwigType_isconst(nctype)) {
1377 Delete(SwigType_pop(nctype));
1379 // Build the name for scheme.
1380 proc_name = NewString(iname);
1381 Replaceall(proc_name, "_", "-");
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");
1389 // See if there's a typemap
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);
1396 rvalue = NewString(value);
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);
1405 // Create variable and assign it a value
1406 Printf(f_header, "static %s = %s;\n", SwigType_lstr(nctype, var_name), rvalue);
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");
1416 SetFlag(n, "feature:constasvar");
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);
1438 /* ------------------------------------------------------------
1440 * ------------------------------------------------------------ */
1441 virtual int classHandler(Node *n) {
1442 /* Create new strings for building up a wrapper function */
1443 have_constructor = 0;
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, "_", "-");
1452 if (!addSymbol(class_name, n))
1455 /* Handle inheritance */
1456 String *base_class = NewString("<");
1457 List *baselist = Getattr(n, "bases");
1458 if (baselist && Len(baselist)) {
1459 Iterator i = First(baselist);
1461 Printv(base_class, Getattr(i.item, "sym:name"), NIL);
1464 Printf(base_class, "> <");
1468 Printf(base_class, ">");
1469 Replaceall(base_class, "_", "-");
1471 Printv(goopscode, "(define-class ", class_name, " ", NIL);
1472 Printf(goopsexport, "%s ", class_name);
1474 if (Len(base_class) > 2) {
1475 Printv(goopscode, "(", base_class, ")\n", NIL);
1477 Printv(goopscode, "(<swig>)\n", NIL);
1479 SwigType *ct = NewStringf("p.%s", Getattr(n, "name"));
1480 swigtype_ptr = SwigType_manglestr(ct);
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);
1487 Printv(f_init, "SWIG_TypeClientData(SWIGTYPE", swigtype_ptr, ", (void *) &_swig_guile_clientdata", mangled_classname, ");\n", NIL);
1488 SwigType_remember(ct);
1492 /* Emit all of the members */
1493 goops_class_methods = NewString("");
1496 Language::classHandler(n);
1499 Printv(goopscode, " #:metaclass <swig-metaclass>\n", NIL);
1501 if (have_constructor)
1502 Printv(goopscode, " #:new-function ", primRenamer ? "primitive:" : "", "new-", short_class_name, "\n", NIL);
1504 Printf(goopscode, ")\n%s\n", goops_class_methods);
1505 Delete(goops_class_methods);
1506 goops_class_methods = 0;
1509 /* export class initialization function */
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, "_", "-");
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");
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);
1526 /* export the call to the wrapper function */
1527 Printf(goopscode, "(%s%s %s)\n\n", primRenamer ? "primitive:" : "", guileFuncName, class_name);
1529 Delete(guileFuncName);
1533 Delete(mangled_classname);
1535 Delete(swigtype_ptr);
1539 Delete(short_class_name);
1541 short_class_name = 0;
1546 /* ------------------------------------------------------------
1547 * memberfunctionHandler()
1548 * ------------------------------------------------------------ */
1549 int memberfunctionHandler(Node *n) {
1550 String *iname = Getattr(n, "sym:name");
1551 String *proc = NewString(iname);
1552 Replaceall(proc, "_", "-");
1554 memberfunction_name = goopsNameMapping(proc, short_class_name);
1555 Language::memberfunctionHandler(n);
1556 Delete(memberfunction_name);
1557 memberfunction_name = NULL;
1562 /* ------------------------------------------------------------
1563 * membervariableHandler()
1564 * ------------------------------------------------------------ */
1565 int membervariableHandler(Node *n) {
1566 String *iname = Getattr(n, "sym:name");
1570 Printf(f_init, "{\n");
1573 Language::membervariableHandler(n);
1576 Printf(f_init, "}\n");
1580 String *proc = NewString(iname);
1581 Replaceall(proc, "_", "-");
1582 String *goops_name = goopsNameMapping(proc, short_class_name);
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);
1593 Printf(goopscode, "\n #:slot-set! (lambda (obj value) (error \"Immutable slot\"))");
1595 if (emit_slot_accessors) {
1596 if (GetFlag(n, "feature:immutable")) {
1597 Printv(goopscode, "\n #:getter ", goops_name, NIL);
1599 Printv(goopscode, "\n #:accessor ", goops_name, NIL);
1601 Printf(goopsexport, "%s ", goops_name);
1603 Printv(goopscode, ")\n", NIL);
1609 /* ------------------------------------------------------------
1610 * constructorHandler()
1611 * ------------------------------------------------------------ */
1612 int constructorHandler(Node *n) {
1613 Language::constructorHandler(n);
1614 have_constructor = 1;
1618 /* ------------------------------------------------------------
1619 * destructorHandler()
1620 * ------------------------------------------------------------ */
1621 virtual int destructorHandler(Node *n) {
1622 exporting_destructor = true;
1623 Language::destructorHandler(n);
1624 exporting_destructor = false;
1628 /* ------------------------------------------------------------
1630 * ------------------------------------------------------------ */
1632 virtual int pragmaDirective(Node *n) {
1634 String *lang = Getattr(n, "lang");
1635 String *cmd = Getattr(n, "name");
1636 String *value = Getattr(n, "value");
1638 # define store_pragma(PRAGMANAME) \
1639 if (Strcmp(cmd, #PRAGMANAME) == 0) { \
1640 if (PRAGMANAME) Delete(PRAGMANAME); \
1641 PRAGMANAME = value ? NewString(value) : NULL; \
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
1652 return Language::pragmaDirective(n);
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("");
1666 if (Strcmp(class_name, "") == 0) {
1667 // not part of a class, so no class name to prefix
1669 Printf(n, "%s%s", goopsprefix, name);
1671 Printf(n, "%s", name);
1674 if (useclassprefix) {
1675 Printf(n, "%s-%s", class_name, name);
1678 Printf(n, "%s%s", goopsprefix, name);
1680 Printf(n, "%s", name);
1688 /* ------------------------------------------------------------
1690 * ------------------------------------------------------------ */
1692 virtual int validIdentifier(String *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
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)
1710 /* <subsequent> --> <initial> | <digit> | <special subsequent> */
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 == '@')))
1723 String *runtimeCode() {
1725 if (use_scm_interface) {
1726 s = Swig_include_sys("guile_scm_run.swg");
1728 Printf(stderr, "*** Unable to open 'guile_scm_run.swg");
1732 s = Swig_include_sys("guile_gh_run.swg");
1734 Printf(stderr, "*** Unable to open 'guile_gh_run.swg");
1741 String *defaultExternalRuntimeFilename() {
1742 if (use_scm_interface) {
1743 return NewString("swigguilerun.h");
1745 return NewString("swigguileghrun.h");
1750 /* -----------------------------------------------------------------------------
1751 * swig_guile() - Instantiate module
1752 * ----------------------------------------------------------------------------- */
1754 static Language *new_swig_guile() {
1757 extern "C" Language *swig_guile(void) {
1758 return new_swig_guile();