diff options
Diffstat (limited to 'Source/Modules/guile.cxx')
| -rw-r--r-- | Source/Modules/guile.cxx | 1759 |
1 files changed, 1759 insertions, 0 deletions
diff --git a/Source/Modules/guile.cxx b/Source/Modules/guile.cxx new file mode 100644 index 0000000..2520a07 --- /dev/null +++ b/Source/Modules/guile.cxx @@ -0,0 +1,1759 @@ +/* ----------------------------------------------------------------------------- + * See the LICENSE file for information on copyright, usage and redistribution + * of SWIG, and the README file for authors - http://www.swig.org/release.html. + * + * guile.cxx + * + * Guile language module for SWIG. + * ----------------------------------------------------------------------------- */ + +char cvsroot_guile_cxx[] = "$Id: guile.cxx 11133 2009-02-20 07:52:24Z wsfulton $"; + +#include "swigmod.h" + +#include <ctype.h> + +// Note string broken in half for compilers that can't handle long strings +static const char *guile_usage = (char *) "\ +Guile Options (available with -guile)\n\ + -prefix <name> - Use <name> as prefix [default \"gswig_\"]\n\ + -package <name> - Set the path of the module to <name>\n\ + (default NULL)\n\ + -emitsetters - Emit procedures-with-setters for variables\n\ + and structure slots.\n\ + -onlysetters - Don't emit traditional getter and setter\n\ + procedures for structure slots,\n\ + only emit procedures-with-setters.\n\ + -procdoc <file> - Output procedure documentation to <file>\n\ + -procdocformat <format> - Output procedure documentation in <format>;\n\ + one of `guile-1.4', `plain', `texinfo'\n\ + -linkage <lstyle> - Use linkage protocol <lstyle> (default `simple')\n\ + Use `module' for native Guile module linking\n\ + (requires Guile >= 1.5.0). Use `passive' for\n\ + passive linking (no C-level module-handling code),\n\ + `ltdlmod' for Guile's old dynamic module\n\ + convention (Guile <= 1.4), or `hobbit' for hobbit\n\ + modules.\n\ + -scmstub - Output Scheme file with module declaration and\n\ + exports; only with `passive' and `simple' linkage\n\ + -gh - Use the gh_ Guile API. (Guile <= 1.8) \n\ + -scm - Use the scm Guile API. (Guile >= 1.6, default) \n\ + -proxy - Export GOOPS class definitions\n\ + -emitslotaccessors - Emit accessor methods for all GOOPS slots\n" "\ + -primsuffix <suffix> - Name appended to primitive module when exporting\n\ + GOOPS classes. (default = \"primitive\")\n\ + -goopsprefix <prefix> - Prepend <prefix> to all goops identifiers\n\ + -useclassprefix - Prepend the class name to all goops identifiers\n\ + -exportprimitive - Add the (export ...) code from scmstub into the\n\ + GOOPS file.\n"; + +static File *f_begin = 0; +static File *f_runtime = 0; +static File *f_header = 0; +static File *f_wrappers = 0; +static File *f_init = 0; + + +static char *prefix = (char *) "gswig_"; +static char *module = 0; +static char *package = 0; +static enum { + GUILE_LSTYLE_SIMPLE, // call `SWIG_init()' + GUILE_LSTYLE_PASSIVE, // passive linking (no module code) + GUILE_LSTYLE_MODULE, // native guile module linking (Guile >= 1.4.1) + GUILE_LSTYLE_LTDLMOD_1_4, // old (Guile <= 1.4) dynamic module convention + GUILE_LSTYLE_HOBBIT // use (hobbit4d link) +} linkage = GUILE_LSTYLE_SIMPLE; + +static File *procdoc = 0; +static bool scmstub = false; +static String *scmtext; +static bool goops = false; +static String *goopstext; +static String *goopscode; +static String *goopsexport; + +static enum { + GUILE_1_4, + PLAIN, + TEXINFO +} docformat = GUILE_1_4; + +static int emit_setters = 0; +static int only_setters = 0; +static int emit_slot_accessors = 0; +static int struct_member = 0; + +static String *beforereturn = 0; +static String *return_nothing_doc = 0; +static String *return_one_doc = 0; +static String *return_multi_doc = 0; + +static String *exported_symbols = 0; + +static int use_scm_interface = 1; +static int exporting_destructor = 0; +static String *swigtype_ptr = 0; + +/* GOOPS stuff */ +static String *primsuffix = 0; +static String *class_name = 0; +static String *short_class_name = 0; +static String *goops_class_methods; +static int in_class = 0; +static int have_constructor = 0; +static int useclassprefix = 0; // -useclassprefix argument +static String *goopsprefix = 0; // -goopsprefix argument +static int primRenamer = 0; // if (use-modules ((...) :renamer ...) is exported to GOOPS file +static int exportprimitive = 0; // -exportprimitive argument +static String *memberfunction_name = 0; + +extern "C" { + static int has_classname(Node *class_node) { + return Getattr(class_node, "guile:goopsclassname") != NULL; + } +} + +class GUILE:public Language { +public: + + /* ------------------------------------------------------------ + * main() + * ------------------------------------------------------------ */ + + virtual void main(int argc, char *argv[]) { + int i, orig_len; + + SWIG_library_directory("guile"); + SWIG_typemap_lang("guile"); + + // Look for certain command line options + for (i = 1; i < argc; i++) { + if (argv[i]) { + if (strcmp(argv[i], "-help") == 0) { + fputs(guile_usage, stdout); + SWIG_exit(EXIT_SUCCESS); + } else if (strcmp(argv[i], "-prefix") == 0) { + if (argv[i + 1]) { + prefix = new char[strlen(argv[i + 1]) + 2]; + strcpy(prefix, argv[i + 1]); + Swig_mark_arg(i); + Swig_mark_arg(i + 1); + i++; + } else { + Swig_arg_error(); + } + } else if (strcmp(argv[i], "-package") == 0) { + if (argv[i + 1]) { + package = new char[strlen(argv[i + 1]) + 2]; + strcpy(package, argv[i + 1]); + Swig_mark_arg(i); + Swig_mark_arg(i + 1); + i++; + } else { + Swig_arg_error(); + } + } else if (strcmp(argv[i], "-Linkage") == 0 || strcmp(argv[i], "-linkage") == 0) { + if (argv[i + 1]) { + if (0 == strcmp(argv[i + 1], "ltdlmod")) + linkage = GUILE_LSTYLE_LTDLMOD_1_4; + else if (0 == strcmp(argv[i + 1], "hobbit")) + linkage = GUILE_LSTYLE_HOBBIT; + else if (0 == strcmp(argv[i + 1], "simple")) + linkage = GUILE_LSTYLE_SIMPLE; + else if (0 == strcmp(argv[i + 1], "passive")) + linkage = GUILE_LSTYLE_PASSIVE; + else if (0 == strcmp(argv[i + 1], "module")) + linkage = GUILE_LSTYLE_MODULE; + else + Swig_arg_error(); + Swig_mark_arg(i); + Swig_mark_arg(i + 1); + i++; + } else { + Swig_arg_error(); + } + } else if (strcmp(argv[i], "-procdoc") == 0) { + if (argv[i + 1]) { + procdoc = NewFile(argv[i + 1], "w", SWIG_output_files()); + if (!procdoc) { + FileErrorDisplay(argv[i + 1]); + SWIG_exit(EXIT_FAILURE); + } + Swig_mark_arg(i); + Swig_mark_arg(i + 1); + i++; + } else { + Swig_arg_error(); + } + } else if (strcmp(argv[i], "-procdocformat") == 0) { + if (strcmp(argv[i + 1], "guile-1.4") == 0) + docformat = GUILE_1_4; + else if (strcmp(argv[i + 1], "plain") == 0) + docformat = PLAIN; + else if (strcmp(argv[i + 1], "texinfo") == 0) + docformat = TEXINFO; + else + Swig_arg_error(); + Swig_mark_arg(i); + Swig_mark_arg(i + 1); + i++; + } else if (strcmp(argv[i], "-emit-setters") == 0 || strcmp(argv[i], "-emitsetters") == 0) { + emit_setters = 1; + Swig_mark_arg(i); + } else if (strcmp(argv[i], "-only-setters") == 0 || strcmp(argv[i], "-onlysetters") == 0) { + emit_setters = 1; + only_setters = 1; + Swig_mark_arg(i); + } else if (strcmp(argv[i], "-emit-slot-accessors") == 0 || strcmp(argv[i], "-emitslotaccessors") == 0) { + emit_slot_accessors = 1; + Swig_mark_arg(i); + } else if (strcmp(argv[i], "-scmstub") == 0) { + scmstub = true; + Swig_mark_arg(i); + } else if ((strcmp(argv[i], "-shadow") == 0) || ((strcmp(argv[i], "-proxy") == 0))) { + goops = true; + Swig_mark_arg(i); + } else if (strcmp(argv[i], "-gh") == 0) { + use_scm_interface = 0; + Swig_mark_arg(i); + } else if (strcmp(argv[i], "-scm") == 0) { + use_scm_interface = 1; + Swig_mark_arg(i); + } else if (strcmp(argv[i], "-primsuffix") == 0) { + if (argv[i + 1]) { + primsuffix = NewString(argv[i + 1]); + Swig_mark_arg(i); + Swig_mark_arg(i + 1); + i++; + } else { + Swig_arg_error(); + } + } else if (strcmp(argv[i], "-goopsprefix") == 0) { + if (argv[i + 1]) { + goopsprefix = NewString(argv[i + 1]); + Swig_mark_arg(i); + Swig_mark_arg(i + 1); + i++; + } else { + Swig_arg_error(); + } + } else if (strcmp(argv[i], "-useclassprefix") == 0) { + useclassprefix = 1; + Swig_mark_arg(i); + } else if (strcmp(argv[i], "-exportprimitive") == 0) { + exportprimitive = 1; + // should use Swig_warning() here? + Swig_mark_arg(i); + } + } + } + + // set default value for primsuffix + if (primsuffix == NULL) + primsuffix = NewString("primitive"); + + //goops support can only be enabled if passive or module linkage is used + if (goops) { + if (linkage != GUILE_LSTYLE_PASSIVE && linkage != GUILE_LSTYLE_MODULE) { + Printf(stderr, "guile: GOOPS support requires passive or module linkage\n"); + exit(1); + } + } + + if (goops) { + // -proxy implies -emit-setters + emit_setters = 1; + } + + if ((linkage == GUILE_LSTYLE_PASSIVE && scmstub) || linkage == GUILE_LSTYLE_MODULE) + primRenamer = 1; + + if (exportprimitive && primRenamer) { + // should use Swig_warning() ? + Printf(stderr, "guile: Warning: -exportprimitive only makes sense with passive linkage without a scmstub.\n"); + } + // Make sure `prefix' ends in an underscore + + orig_len = strlen(prefix); + if (prefix[orig_len - 1] != '_') { + prefix[1 + orig_len] = 0; + prefix[orig_len] = '_'; + } + + /* Add a symbol for this module */ + Preprocessor_define("SWIGGUILE 1", 0); + /* Read in default typemaps */ + if (use_scm_interface) + SWIG_config_file("guile_scm.swg"); + else + SWIG_config_file("guile_gh.swg"); + allow_overloading(); + + } + + /* ------------------------------------------------------------ + * top() + * ------------------------------------------------------------ */ + + virtual int top(Node *n) { + /* Initialize all of the output files */ + String *outfile = Getattr(n, "outfile"); + + f_begin = NewFile(outfile, "w", SWIG_output_files()); + if (!f_begin) { + FileErrorDisplay(outfile); + SWIG_exit(EXIT_FAILURE); + } + f_runtime = NewString(""); + f_init = NewString(""); + f_header = NewString(""); + f_wrappers = NewString(""); + + /* Register file targets with the SWIG file handler */ + Swig_register_filebyname("header", f_header); + Swig_register_filebyname("wrapper", f_wrappers); + Swig_register_filebyname("begin", f_begin); + Swig_register_filebyname("runtime", f_runtime); + Swig_register_filebyname("init", f_init); + + scmtext = NewString(""); + Swig_register_filebyname("scheme", scmtext); + exported_symbols = NewString(""); + goopstext = NewString(""); + Swig_register_filebyname("goops", goopstext); + goopscode = NewString(""); + goopsexport = NewString(""); + + Swig_banner(f_begin); + + Printf(f_runtime, "\n"); + Printf(f_runtime, "#define SWIGGUILE\n"); + + if (!use_scm_interface) { + if (SwigRuntime == 1) + Printf(f_runtime, "#define SWIG_GLOBAL\n"); + if (SwigRuntime == 2) + Printf(f_runtime, "#define SWIG_NOINCLUDE\n"); + } + + /* Write out directives and declarations */ + + module = Swig_copy_string(Char(Getattr(n, "name"))); + + switch (linkage) { + case GUILE_LSTYLE_SIMPLE: + /* Simple linkage; we have to export the SWIG_init function. The user can + rename the function by a #define. */ + Printf(f_runtime, "#define SWIG_GUILE_INIT_STATIC extern\n"); + break; + default: + /* Other linkage; we make the SWIG_init function static */ + Printf(f_runtime, "#define SWIG_GUILE_INIT_STATIC static\n"); + break; + } + + if (CPlusPlus) { + Printf(f_runtime, "extern \"C\" {\n\n"); + } + Printf(f_runtime, "SWIG_GUILE_INIT_STATIC void\nSWIG_init (void);\n"); + if (CPlusPlus) { + Printf(f_runtime, "\n}\n"); + } + + Printf(f_runtime, "\n"); + + Language::top(n); + + /* Close module */ + + Printf(f_wrappers, "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"); + + SwigType_emit_type_table(f_runtime, f_wrappers); + + Printf(f_init, "}\n\n"); + Printf(f_init, "#ifdef __cplusplus\n}\n#endif\n"); + + String *module_name = NewString(""); + + if (!module) + Printv(module_name, "swig", NIL); + else { + if (package) + Printf(module_name, "%s/%s", package, module); + else + Printv(module_name, module, NIL); + } + emit_linkage(module_name); + + Delete(module_name); + + if (procdoc) { + Delete(procdoc); + procdoc = NULL; + } + Delete(goopscode); + Delete(goopsexport); + Delete(goopstext); + + /* Close all of the files */ + Dump(f_runtime, f_begin); + Dump(f_header, f_begin); + Dump(f_wrappers, f_begin); + Wrapper_pretty_print(f_init, f_begin); + Delete(f_header); + Delete(f_wrappers); + Delete(f_init); + Close(f_begin); + Delete(f_runtime); + Delete(f_begin); + return SWIG_OK; + } + + void emit_linkage(String *module_name) { + String *module_func = NewString(""); + + if (CPlusPlus) { + Printf(f_init, "extern \"C\" {\n\n"); + } + + Printv(module_func, module_name, NIL); + Replaceall(module_func, "-", "_"); + + switch (linkage) { + case GUILE_LSTYLE_SIMPLE: + Printf(f_init, "\n/* Linkage: simple */\n"); + break; + case GUILE_LSTYLE_PASSIVE: + Printf(f_init, "\n/* Linkage: passive */\n"); + Replaceall(module_func, "/", "_"); + Insert(module_func, 0, "scm_init_"); + Append(module_func, "_module"); + + Printf(f_init, "SCM\n%s (void)\n{\n", module_func); + Printf(f_init, " SWIG_init();\n"); + Printf(f_init, " return SCM_UNSPECIFIED;\n"); + Printf(f_init, "}\n"); + break; + case GUILE_LSTYLE_LTDLMOD_1_4: + Printf(f_init, "\n/* Linkage: ltdlmod */\n"); + Replaceall(module_func, "/", "_"); + Insert(module_func, 0, "scm_init_"); + Append(module_func, "_module"); + Printf(f_init, "SCM\n%s (void)\n{\n", module_func); + { + String *mod = NewString(module_name); + Replaceall(mod, "/", " "); + Printf(f_init, " scm_register_module_xxx (\"%s\", (void *) SWIG_init);\n", mod); + Printf(f_init, " return SCM_UNSPECIFIED;\n"); + Delete(mod); + } + Printf(f_init, "}\n"); + break; + case GUILE_LSTYLE_MODULE: + Printf(f_init, "\n/* Linkage: module */\n"); + Replaceall(module_func, "/", "_"); + Insert(module_func, 0, "scm_init_"); + Append(module_func, "_module"); + + Printf(f_init, "static void SWIG_init_helper(void *data)\n"); + Printf(f_init, "{\n SWIG_init();\n"); + if (Len(exported_symbols) > 0) + Printf(f_init, " scm_c_export(%sNULL);", exported_symbols); + Printf(f_init, "\n}\n\n"); + + Printf(f_init, "SCM\n%s (void)\n{\n", module_func); + { + String *mod = NewString(module_name); + if (goops) + Printv(mod, "-", primsuffix, NIL); + Replaceall(mod, "/", " "); + Printf(f_init, " scm_c_define_module(\"%s\",\n", mod); + Printf(f_init, " SWIG_init_helper, NULL);\n"); + Printf(f_init, " return SCM_UNSPECIFIED;\n"); + Delete(mod); + } + Printf(f_init, "}\n"); + break; + case GUILE_LSTYLE_HOBBIT: + Printf(f_init, "\n/* Linkage: hobbit */\n"); + Replaceall(module_func, "/", "_slash_"); + Insert(module_func, 0, "scm_init_"); + Printf(f_init, "SCM\n%s (void)\n{\n", module_func); + { + String *mod = NewString(module_name); + Replaceall(mod, "/", " "); + Printf(f_init, " scm_register_module_xxx (\"%s\", (void *) SWIG_init);\n", mod); + Printf(f_init, " return SCM_UNSPECIFIED;\n"); + Delete(mod); + } + Printf(f_init, "}\n"); + break; + default: + abort(); // for now + } + + if (scmstub) { + /* Emit Scheme stub if requested */ + String *primitive_name = NewString(module_name); + if (goops) + Printv(primitive_name, "-", primsuffix, NIL); + + String *mod = NewString(primitive_name); + Replaceall(mod, "/", " "); + + String *fname = NewStringf("%s%s.scm", + SWIG_output_directory(), + primitive_name); + Delete(primitive_name); + File *scmstubfile = NewFile(fname, "w", SWIG_output_files()); + if (!scmstubfile) { + FileErrorDisplay(fname); + SWIG_exit(EXIT_FAILURE); + } + Delete(fname); + + Swig_banner_target_lang(scmstubfile, ";;;"); + Printf(scmstubfile, "\n"); + if (linkage == GUILE_LSTYLE_SIMPLE || linkage == GUILE_LSTYLE_PASSIVE) + Printf(scmstubfile, "(define-module (%s))\n\n", mod); + Delete(mod); + Printf(scmstubfile, "%s", scmtext); + if ((linkage == GUILE_LSTYLE_SIMPLE || linkage == GUILE_LSTYLE_PASSIVE) + && Len(exported_symbols) > 0) { + String *ex = NewString(exported_symbols); + Replaceall(ex, ", ", "\n "); + Replaceall(ex, "\"", ""); + Chop(ex); + Printf(scmstubfile, "\n(export %s)\n", ex); + Delete(ex); + } + Delete(scmstubfile); + } + + if (goops) { + String *mod = NewString(module_name); + Replaceall(mod, "/", " "); + + String *fname = NewStringf("%s%s.scm", SWIG_output_directory(), + module_name); + File *goopsfile = NewFile(fname, "w", SWIG_output_files()); + if (!goopsfile) { + FileErrorDisplay(fname); + SWIG_exit(EXIT_FAILURE); + } + Delete(fname); + Swig_banner_target_lang(goopsfile, ";;;"); + Printf(goopsfile, "\n"); + Printf(goopsfile, "(define-module (%s))\n", mod); + Printf(goopsfile, "%s\n", goopstext); + Printf(goopsfile, "(use-modules (oop goops) (Swig common))\n"); + if (primRenamer) { + Printf(goopsfile, "(use-modules ((%s-%s) :renamer (symbol-prefix-proc 'primitive:)))\n", mod, primsuffix); + } + Printf(goopsfile, "%s\n(export %s)", goopscode, goopsexport); + if (exportprimitive) { + String *ex = NewString(exported_symbols); + Replaceall(ex, ", ", "\n "); + Replaceall(ex, "\"", ""); + Chop(ex); + Printf(goopsfile, "\n(export %s)", ex); + Delete(ex); + } + Delete(mod); + Delete(goopsfile); + } + + Delete(module_func); + if (CPlusPlus) { + Printf(f_init, "\n}\n"); + } + } + + /* Return true iff T is a pointer type */ + + int is_a_pointer(SwigType *t) { + return SwigType_ispointer(SwigType_typedef_resolve_all(t)); + } + + /* Report an error handling the given type. */ + + void throw_unhandled_guile_type_error(SwigType *d) { + Swig_warning(WARN_TYPEMAP_UNDEF, input_file, line_number, "Unable to handle type %s.\n", SwigType_str(d, 0)); + } + + /* Write out procedure documentation */ + + void write_doc(const String *proc_name, const String *signature, const String *doc, const String *signature2 = NULL) { + switch (docformat) { + case GUILE_1_4: + Printv(procdoc, "\f\n", NIL); + Printv(procdoc, "(", signature, ")\n", NIL); + if (signature2) + Printv(procdoc, "(", signature2, ")\n", NIL); + Printv(procdoc, doc, "\n", NIL); + break; + case PLAIN: + Printv(procdoc, "\f", proc_name, "\n\n", NIL); + Printv(procdoc, "(", signature, ")\n", NIL); + if (signature2) + Printv(procdoc, "(", signature2, ")\n", NIL); + Printv(procdoc, doc, "\n\n", NIL); + break; + case TEXINFO: + Printv(procdoc, "\f", proc_name, "\n", NIL); + Printv(procdoc, "@deffn primitive ", signature, "\n", NIL); + if (signature2) + Printv(procdoc, "@deffnx primitive ", signature2, "\n", NIL); + Printv(procdoc, doc, "\n", NIL); + Printv(procdoc, "@end deffn\n\n", NIL); + break; + } + } + + /* returns false if the typemap is an empty string */ + bool handle_documentation_typemap(String *output, + const String *maybe_delimiter, Parm *p, const String *typemap, const String *default_doc, const String *name = NULL) { + String *tmp = NewString(""); + String *tm; + if (!(tm = Getattr(p, typemap))) { + Printf(tmp, "%s", default_doc); + tm = tmp; + } + bool result = (Len(tm) > 0); + if (maybe_delimiter && Len(output) > 0 && Len(tm) > 0) { + Printv(output, maybe_delimiter, NIL); + } + const String *pn = (name == NULL) ? (const String *) Getattr(p, "name") : name; + String *pt = Getattr(p, "type"); + Replaceall(tm, "$name", pn); // legacy for $parmname + Replaceall(tm, "$type", SwigType_str(pt, 0)); + /* $NAME is like $name, but marked-up as a variable. */ + String *ARGNAME = NewString(""); + if (docformat == TEXINFO) + Printf(ARGNAME, "@var{%s}", pn); + else + Printf(ARGNAME, "%(upper)s", pn); + Replaceall(tm, "$NAME", ARGNAME); + Replaceall(tm, "$PARMNAME", ARGNAME); + Printv(output, tm, NIL); + Delete(tmp); + return result; + } + + /* ------------------------------------------------------------ + * functionWrapper() + * Create a function declaration and register it with the interpreter. + * ------------------------------------------------------------ */ + + virtual int functionWrapper(Node *n) { + String *iname = Getattr(n, "sym:name"); + SwigType *d = Getattr(n, "type"); + ParmList *l = Getattr(n, "parms"); + Parm *p; + String *proc_name = 0; + char source[256]; + Wrapper *f = NewWrapper();; + String *cleanup = NewString(""); + String *outarg = NewString(""); + String *signature = NewString(""); + String *doc_body = NewString(""); + String *returns = NewString(""); + String *method_signature = NewString(""); + String *primitive_args = NewString(""); + Hash *scheme_arg_names = NewHash(); + int num_results = 1; + String *tmp = NewString(""); + String *tm; + int i; + int numargs = 0; + int numreq = 0; + String *overname = 0; + int args_passed_as_array = 0; + int scheme_argnum = 0; + bool any_specialized_arg = false; + + // Make a wrapper name for this + String *wname = Swig_name_wrapper(iname); + if (Getattr(n, "sym:overloaded")) { + overname = Getattr(n, "sym:overname"); + args_passed_as_array = 1; + } else { + if (!addSymbol(iname, n)) { + DelWrapper(f); + return SWIG_ERROR; + } + } + if (overname) { + Append(wname, overname); + } + Setattr(n, "wrap:name", wname); + + // Build the name for scheme. + proc_name = NewString(iname); + Replaceall(proc_name, "_", "-"); + + /* Emit locals etc. into f->code; figure out which args to ignore */ + emit_parameter_variables(l, f); + + /* Attach the standard typemaps */ + emit_attach_parmmaps(l, f); + Setattr(n, "wrap:parms", l); + + /* Get number of required and total arguments */ + numargs = emit_num_arguments(l); + numreq = emit_num_required(l); + + /* Declare return variable */ + + Wrapper_add_local(f, "gswig_result", "SCM gswig_result"); + Wrapper_add_local(f, "gswig_list_p", "SWIGUNUSED int gswig_list_p = 0"); + + /* Open prototype and signature */ + + Printv(f->def, "static SCM\n", wname, " (", NIL); + if (args_passed_as_array) { + Printv(f->def, "int argc, SCM *argv", NIL); + } + Printv(signature, proc_name, NIL); + + /* Now write code to extract the parameters */ + + for (i = 0, p = l; i < numargs; i++) { + + while (checkAttribute(p, "tmap:in:numinputs", "0")) { + p = Getattr(p, "tmap:in:next"); + } + + SwigType *pt = Getattr(p, "type"); + int opt_p = (i >= numreq); + + // Produce names of source and target + if (args_passed_as_array) + sprintf(source, "argv[%d]", i); + else + sprintf(source, "s_%d", i); + String *target = Getattr(p, "lname"); + + if (!args_passed_as_array) { + if (i != 0) + Printf(f->def, ", "); + Printf(f->def, "SCM s_%d", i); + } + if (opt_p) { + Printf(f->code, " if (%s != SCM_UNDEFINED) {\n", source); + } + if ((tm = Getattr(p, "tmap:in"))) { + Replaceall(tm, "$source", source); + Replaceall(tm, "$target", target); + Replaceall(tm, "$input", source); + Setattr(p, "emit:input", source); + Printv(f->code, tm, "\n", NIL); + + SwigType *pb = SwigType_typedef_resolve_all(SwigType_base(pt)); + SwigType *pn = Getattr(p, "name"); + String *argname; + scheme_argnum++; + if (pn && !Getattr(scheme_arg_names, pn)) + argname = pn; + else { + /* Anonymous arg or re-used argument name -- choose a name that cannot clash */ + argname = NewStringf("%%arg%d", scheme_argnum); + } + + if (procdoc) { + if (i == numreq) { + /* First optional argument */ + Printf(signature, " #:optional"); + } + /* Add to signature (arglist) */ + handle_documentation_typemap(signature, " ", p, "tmap:in:arglist", "$name", argname); + /* Document the type of the arg in the documentation body */ + handle_documentation_typemap(doc_body, ", ", p, "tmap:in:doc", "$NAME is of type <$type>", argname); + } + + if (goops) { + if (i < numreq) { + if (strcmp("void", Char(pt)) != 0) { + Node *class_node = Swig_symbol_clookup_check(pb, Getattr(n, "sym:symtab"), + has_classname); + String *goopsclassname = (class_node == NULL) ? NULL : Getattr(class_node, "guile:goopsclassname"); + /* do input conversion */ + if (goopsclassname) { + Printv(method_signature, " (", argname, " ", goopsclassname, ")", NIL); + any_specialized_arg = true; + } else { + Printv(method_signature, " ", argname, NIL); + } + Printv(primitive_args, " ", argname, NIL); + Setattr(scheme_arg_names, argname, p); + } + } + } + + if (!pn) { + Delete(argname); + } + p = Getattr(p, "tmap:in:next"); + } else { + throw_unhandled_guile_type_error(pt); + p = nextSibling(p); + } + if (opt_p) + Printf(f->code, " }\n"); + } + if (Len(doc_body) > 0) + Printf(doc_body, ".\n"); + + /* Insert constraint checking code */ + for (p = l; p;) { + if ((tm = Getattr(p, "tmap:check"))) { + Replaceall(tm, "$target", Getattr(p, "lname")); + Printv(f->code, tm, "\n", NIL); + p = Getattr(p, "tmap:check:next"); + } else { + p = nextSibling(p); + } + } + /* Pass output arguments back to the caller. */ + + /* Insert argument output code */ + String *returns_argout = NewString(""); + for (p = l; p;) { + if ((tm = Getattr(p, "tmap:argout"))) { + Replaceall(tm, "$source", Getattr(p, "lname")); + Replaceall(tm, "$target", Getattr(p, "lname")); + Replaceall(tm, "$arg", Getattr(p, "emit:input")); + Replaceall(tm, "$input", Getattr(p, "emit:input")); + Printv(outarg, tm, "\n", NIL); + if (procdoc) { + if (handle_documentation_typemap(returns_argout, ", ", p, "tmap:argout:doc", "$NAME (of type $type)")) { + /* A documentation typemap that is not the empty string + indicates that a value is returned to Scheme. */ + num_results++; + } + } + p = Getattr(p, "tmap:argout:next"); + } else { + p = nextSibling(p); + } + } + + /* Insert cleanup code */ + for (p = l; p;) { + if ((tm = Getattr(p, "tmap:freearg"))) { + Replaceall(tm, "$target", Getattr(p, "lname")); + Replaceall(tm, "$input", Getattr(p, "emit:input")); + Printv(cleanup, tm, "\n", NIL); + p = Getattr(p, "tmap:freearg:next"); + } else { + p = nextSibling(p); + } + } + + if (use_scm_interface && exporting_destructor) { + /* Mark the destructor's argument as destroyed. */ + String *tm = NewString("SWIG_Guile_MarkPointerDestroyed($input);"); + Replaceall(tm, "$input", Getattr(l, "emit:input")); + Printv(cleanup, tm, "\n", NIL); + Delete(tm); + } + + /* Close prototype */ + + Printf(f->def, ")\n{\n"); + + /* Define the scheme name in C. This define is used by several Guile + macros. */ + Printv(f->def, "#define FUNC_NAME \"", proc_name, "\"", NIL); + + // Now write code to make the function call + if (!use_scm_interface) + Printv(f->code, tab4, "gh_defer_ints();\n", NIL); + + String *actioncode = emit_action(n); + + if (!use_scm_interface) + Printv(actioncode, tab4, "gh_allow_ints();\n", NIL); + + // Now have return value, figure out what to do with it. + if ((tm = Swig_typemap_lookup_out("out", n, "result", f, actioncode))) { + Replaceall(tm, "$result", "gswig_result"); + Replaceall(tm, "$target", "gswig_result"); + Replaceall(tm, "$source", "result"); + if (GetFlag(n, "feature:new")) + Replaceall(tm, "$owner", "1"); + else + Replaceall(tm, "$owner", "0"); + Printv(f->code, tm, "\n", NIL); + } else { + throw_unhandled_guile_type_error(d); + } + emit_return_variable(n, d, f); + + // Documentation + if ((tm = Getattr(n, "tmap:out:doc"))) { + Printv(returns, tm, NIL); + if (Len(tm) > 0) + num_results = 1; + else + num_results = 0; + } else { + String *s = SwigType_str(d, 0); + Chop(s); + Printf(returns, "<%s>", s); + Delete(s); + num_results = 1; + } + Append(returns, returns_argout); + + + // Dump the argument output code + Printv(f->code, outarg, NIL); + + // Dump the argument cleanup code + Printv(f->code, cleanup, NIL); + + // Look for any remaining cleanup + + if (GetFlag(n, "feature:new")) { + if ((tm = Swig_typemap_lookup("newfree", n, "result", 0))) { + Replaceall(tm, "$source", "result"); + Printv(f->code, tm, "\n", NIL); + } + } + // Free any memory allocated by the function being wrapped.. + if ((tm = Swig_typemap_lookup("ret", n, "result", 0))) { + Replaceall(tm, "$source", "result"); + Printv(f->code, tm, "\n", NIL); + } + // Wrap things up (in a manner of speaking) + + if (beforereturn) + Printv(f->code, beforereturn, "\n", NIL); + Printv(f->code, "return gswig_result;\n", NIL); + + /* Substitute the function name */ + Replaceall(f->code, "$symname", iname); + // Undefine the scheme name + + Printf(f->code, "#undef FUNC_NAME\n"); + Printf(f->code, "}\n"); + + Wrapper_print(f, f_wrappers); + + if (!Getattr(n, "sym:overloaded")) { + if (numargs > 10) { + int i; + /* gh_new_procedure would complain: too many args */ + /* Build a wrapper wrapper */ + Printv(f_wrappers, "static SCM\n", wname, "_rest (SCM rest)\n", NIL); + Printv(f_wrappers, "{\n", NIL); + Printf(f_wrappers, "SCM arg[%d];\n", numargs); + Printf(f_wrappers, "SWIG_Guile_GetArgs (arg, rest, %d, %d, \"%s\");\n", numreq, numargs - numreq, proc_name); + Printv(f_wrappers, "return ", wname, "(", NIL); + Printv(f_wrappers, "arg[0]", NIL); + for (i = 1; i < numargs; i++) + Printf(f_wrappers, ", arg[%d]", i); + Printv(f_wrappers, ");\n", NIL); + Printv(f_wrappers, "}\n", NIL); + /* Register it */ + if (use_scm_interface) { + Printf(f_init, "scm_c_define_gsubr(\"%s\", 0, 0, 1, (swig_guile_proc) %s_rest);\n", proc_name, wname); + } else { + Printf(f_init, "gh_new_procedure(\"%s\", (swig_guile_proc) %s_rest, 0, 0, 1);\n", proc_name, wname); + } + } else if (emit_setters && struct_member && strlen(Char(proc_name)) > 3) { + int len = Len(proc_name); + const char *pc = Char(proc_name); + /* MEMBER-set and MEMBER-get functions. */ + int is_setter = (pc[len - 3] == 's'); + if (is_setter) { + Printf(f_init, "SCM setter = "); + struct_member = 2; /* have a setter */ + } else + Printf(f_init, "SCM getter = "); + if (use_scm_interface) { + /* GOOPS support uses the MEMBER-set and MEMBER-get functions, + so ignore only_setters in this case. */ + if (only_setters && !goops) + Printf(f_init, "scm_c_make_gsubr(\"%s\", %d, %d, 0, (swig_guile_proc) %s);\n", proc_name, numreq, numargs - numreq, wname); + else + Printf(f_init, "scm_c_define_gsubr(\"%s\", %d, %d, 0, (swig_guile_proc) %s);\n", proc_name, numreq, numargs - numreq, wname); + } else { + if (only_setters && !goops) + Printf(f_init, "scm_make_gsubr(\"%s\", %d, %d, 0, (swig_guile_proc) %s);\n", proc_name, numreq, numargs - numreq, wname); + else + Printf(f_init, "gh_new_procedure(\"%s\", (swig_guile_proc) %s, %d, %d, 0);\n", proc_name, wname, numreq, numargs - numreq); + } + if (!is_setter) { + /* Strip off "-get" */ + char *pws_name = (char *) malloc(sizeof(char) * (len - 3)); + strncpy(pws_name, pc, len - 3); + pws_name[len - 4] = 0; + if (struct_member == 2) { + /* There was a setter, so create a procedure with setter */ + if (use_scm_interface) { + Printf(f_init, "scm_c_define"); + } else { + Printf(f_init, "gh_define"); + } + Printf(f_init, "(\"%s\", " "scm_make_procedure_with_setter(getter, setter));\n", pws_name); + } else { + /* There was no setter, so make an alias to the getter */ + if (use_scm_interface) { + Printf(f_init, "scm_c_define"); + } else { + Printf(f_init, "gh_define"); + } + Printf(f_init, "(\"%s\", getter);\n", pws_name); + } + Printf(exported_symbols, "\"%s\", ", pws_name); + free(pws_name); + } + } else { + /* Register the function */ + if (use_scm_interface) { + if (exporting_destructor) { + Printf(f_init, "((swig_guile_clientdata *)(SWIGTYPE%s->clientdata))->destroy = (guile_destructor) %s;\n", swigtype_ptr, wname); + //Printf(f_init, "SWIG_TypeClientData(SWIGTYPE%s, (void *) %s);\n", swigtype_ptr, wname); + } + Printf(f_init, "scm_c_define_gsubr(\"%s\", %d, %d, 0, (swig_guile_proc) %s);\n", proc_name, numreq, numargs - numreq, wname); + } else { + Printf(f_init, "gh_new_procedure(\"%s\", (swig_guile_proc) %s, %d, %d, 0);\n", proc_name, wname, numreq, numargs - numreq); + } + } + } else { /* overloaded function; don't export the single methods */ + if (!Getattr(n, "sym:nextSibling")) { + /* Emit overloading dispatch function */ + + int maxargs; + String *dispatch = Swig_overload_dispatch(n, "return %s(argc,argv);", &maxargs); + + /* Generate a dispatch wrapper for all overloaded functions */ + + Wrapper *df = NewWrapper(); + String *dname = Swig_name_wrapper(iname); + + Printv(df->def, "static SCM\n", dname, "(SCM rest)\n{\n", NIL); + Printf(df->code, "#define FUNC_NAME \"%s\"\n", proc_name); + Printf(df->code, "SCM argv[%d];\n", maxargs); + Printf(df->code, "int argc = SWIG_Guile_GetArgs (argv, rest, %d, %d, \"%s\");\n", 0, maxargs, proc_name); + Printv(df->code, dispatch, "\n", NIL); + Printf(df->code, "scm_misc_error(\"%s\", \"No matching method for generic function `%s'\", SCM_EOL);\n", proc_name, iname); + Printf(df->code, "#undef FUNC_NAME\n"); + Printv(df->code, "}\n", NIL); + Wrapper_print(df, f_wrappers); + if (use_scm_interface) { + Printf(f_init, "scm_c_define_gsubr(\"%s\", 0, 0, 1, (swig_guile_proc) %s);\n", proc_name, dname); + } else { + Printf(f_init, "gh_new_procedure(\"%s\", (swig_guile_proc) %s, 0, 0, 1);\n", proc_name, dname); + } + DelWrapper(df); + Delete(dispatch); + Delete(dname); + } + } + Printf(exported_symbols, "\"%s\", ", proc_name); + + if (!in_class || memberfunction_name) { + // export wrapper into goops file + String *method_def = NewString(""); + String *goops_name; + if (in_class) + goops_name = NewString(memberfunction_name); + else + goops_name = goopsNameMapping(proc_name, (char *) ""); + String *primitive_name = NewString(""); + if (primRenamer) + Printv(primitive_name, "primitive:", proc_name, NIL); + else + Printv(primitive_name, proc_name, NIL); + Replaceall(method_signature, "_", "-"); + Replaceall(primitive_args, "_", "-"); + if (!any_specialized_arg) { + /* If there would not be any specialized argument in + the method declaration, we simply re-export the + function. This is a performance optimization. */ + Printv(method_def, "(define ", goops_name, " ", primitive_name, ")\n", NIL); + } else if (numreq == numargs) { + Printv(method_def, "(define-method (", goops_name, method_signature, ")\n", NIL); + Printv(method_def, " (", primitive_name, primitive_args, "))\n", NIL); + } else { + /* Handle optional args. For the rest argument, use a name + that cannot clash. */ + Printv(method_def, "(define-method (", goops_name, method_signature, " . %args)\n", NIL); + Printv(method_def, " (apply ", primitive_name, primitive_args, " %args))\n", NIL); + } + if (in_class) { + /* Defer method definition till end of class definition. */ + Printv(goops_class_methods, method_def, NIL); + } else { + Printv(goopscode, method_def, NIL); + } + Printf(goopsexport, "%s ", goops_name); + Delete(primitive_name); + Delete(goops_name); + Delete(method_def); + } + + if (procdoc) { + String *returns_text = NewString(""); + if (num_results == 0) + Printv(returns_text, return_nothing_doc, NIL); + else if (num_results == 1) + Printv(returns_text, return_one_doc, NIL); + else + Printv(returns_text, return_multi_doc, NIL); + /* Substitute documentation variables */ + static const char *numbers[] = { "zero", "one", "two", "three", + "four", "five", "six", "seven", + "eight", "nine", "ten", "eleven", + "twelve" + }; + if (num_results <= 12) + Replaceall(returns_text, "$num_values", numbers[num_results]); + else { + String *num_results_str = NewStringf("%d", num_results); + Replaceall(returns_text, "$num_values", num_results_str); + Delete(num_results_str); + } + Replaceall(returns_text, "$values", returns); + Printf(doc_body, "\n%s", returns_text); + write_doc(proc_name, signature, doc_body); + Delete(returns_text); + } + + Delete(proc_name); + Delete(outarg); + Delete(cleanup); + Delete(signature); + Delete(method_signature); + Delete(primitive_args); + Delete(doc_body); + Delete(returns_argout); + Delete(returns); + Delete(tmp); + Delete(scheme_arg_names); + DelWrapper(f); + return SWIG_OK; + } + + /* ------------------------------------------------------------ + * variableWrapper() + * + * Create a link to a C variable. + * This creates a single function PREFIX_var_VARNAME(). + * This function takes a single optional argument. If supplied, it means + * we are setting this variable to some value. If omitted, it means we are + * simply evaluating this variable. Either way, we return the variables + * value. + * ------------------------------------------------------------ */ + + virtual int variableWrapper(Node *n) { + + char *name = GetChar(n, "name"); + char *iname = GetChar(n, "sym:name"); + SwigType *t = Getattr(n, "type"); + + String *proc_name; + Wrapper *f; + String *tm; + + if (!addSymbol(iname, n)) + return SWIG_ERROR; + + f = NewWrapper(); + // evaluation function names + + String *var_name = Swig_name_wrapper(iname); + + // Build the name for scheme. + proc_name = NewString(iname); + Replaceall(proc_name, "_", "-"); + Setattr(n, "wrap:name", proc_name); + + if (1 || (SwigType_type(t) != T_USER) || (is_a_pointer(t))) { + + Printf(f->def, "static SCM\n%s(SCM s_0)\n{\n", var_name); + + /* Define the scheme name in C. This define is used by several Guile + macros. */ + Printv(f->def, "#define FUNC_NAME \"", proc_name, "\"", NIL); + + Wrapper_add_local(f, "gswig_result", "SCM gswig_result"); + + if (!GetFlag(n, "feature:immutable")) { + /* Check for a setting of the variable value */ + Printf(f->code, "if (s_0 != SCM_UNDEFINED) {\n"); + if ((tm = Swig_typemap_lookup("varin", n, name, 0))) { + Replaceall(tm, "$source", "s_0"); + Replaceall(tm, "$input", "s_0"); + Replaceall(tm, "$target", name); + /* Printv(f->code,tm,"\n",NIL); */ + emit_action_code(n, f->code, tm); + } else { + throw_unhandled_guile_type_error(t); + } + Printf(f->code, "}\n"); + } + // Now return the value of the variable (regardless + // of evaluating or setting) + + if ((tm = Swig_typemap_lookup("varout", n, name, 0))) { + Replaceall(tm, "$source", name); + Replaceall(tm, "$target", "gswig_result"); + Replaceall(tm, "$result", "gswig_result"); + /* Printv(f->code,tm,"\n",NIL); */ + emit_action_code(n, f->code, tm); + } else { + throw_unhandled_guile_type_error(t); + } + Printf(f->code, "\nreturn gswig_result;\n"); + Printf(f->code, "#undef FUNC_NAME\n"); + Printf(f->code, "}\n"); + + Wrapper_print(f, f_wrappers); + + // Now add symbol to the Guile interpreter + + if (!emit_setters || GetFlag(n, "feature:immutable")) { + /* Read-only variables become a simple procedure returning the + value; read-write variables become a simple procedure with + an optional argument. */ + if (use_scm_interface) { + + if (!goops && GetFlag(n, "feature:constasvar")) { + /* need to export this function as a variable instead of a procedure */ + if (scmstub) { + /* export the function in the wrapper, and (set!) it in scmstub */ + Printf(f_init, "scm_c_define_gsubr(\"%s\", 0, %d, 0, (swig_guile_proc) %s);\n", proc_name, !GetFlag(n, "feature:immutable"), var_name); + Printf(scmtext, "(set! %s (%s))\n", proc_name, proc_name); + } else { + /* export the variable directly */ + Printf(f_init, "scm_c_define(\"%s\", %s(SCM_UNDEFINED));\n", proc_name, var_name); + } + + } else { + /* Export the function as normal */ + Printf(f_init, "scm_c_define_gsubr(\"%s\", 0, %d, 0, (swig_guile_proc) %s);\n", proc_name, !GetFlag(n, "feature:immutable"), var_name); + } + + } else { + Printf(f_init, "\t gh_new_procedure(\"%s\", (swig_guile_proc) %s, 0, %d, 0);\n", proc_name, var_name, !GetFlag(n, "feature:immutable")); + } + } else { + /* Read/write variables become a procedure with setter. */ + if (use_scm_interface) { + Printf(f_init, "{ SCM p = scm_c_define_gsubr(\"%s\", 0, 1, 0, (swig_guile_proc) %s);\n", proc_name, var_name); + Printf(f_init, "scm_c_define"); + } else { + Printf(f_init, "\t{ SCM p = gh_new_procedure(\"%s\", (swig_guile_proc) %s, 0, 1, 0);\n", proc_name, var_name); + Printf(f_init, "gh_define"); + } + Printf(f_init, "(\"%s\", " "scm_make_procedure_with_setter(p, p)); }\n", proc_name); + } + Printf(exported_symbols, "\"%s\", ", proc_name); + + // export wrapper into goops file + if (!in_class) { // only if the variable is not part of a class + String *class_name = SwigType_typedef_resolve_all(SwigType_base(t)); + String *goops_name = goopsNameMapping(proc_name, (char *) ""); + String *primitive_name = NewString(""); + if (primRenamer) + Printv(primitive_name, "primitive:", NIL); + Printv(primitive_name, proc_name, NIL); + /* Simply re-export the procedure */ + if ((!emit_setters || GetFlag(n, "feature:immutable")) + && GetFlag(n, "feature:constasvar")) { + Printv(goopscode, "(define ", goops_name, " (", primitive_name, "))\n", NIL); + } else { + Printv(goopscode, "(define ", goops_name, " ", primitive_name, ")\n", NIL); + } + Printf(goopsexport, "%s ", goops_name); + Delete(primitive_name); + Delete(class_name); + Delete(goops_name); + } + + if (procdoc) { + /* Compute documentation */ + String *signature = NewString(""); + String *signature2 = NULL; + String *doc = NewString(""); + + if (GetFlag(n, "feature:immutable")) { + Printv(signature, proc_name, NIL); + if (GetFlag(n, "feature:constasvar")) { + Printv(doc, "Is constant ", NIL); + } else { + Printv(doc, "Returns constant ", NIL); + } + if ((tm = Getattr(n, "tmap:varout:doc"))) { + Printv(doc, tm, NIL); + } else { + String *s = SwigType_str(t, 0); + Chop(s); + Printf(doc, "<%s>", s); + Delete(s); + } + } else if (emit_setters) { + Printv(signature, proc_name, NIL); + signature2 = NewString(""); + Printv(signature2, "set! (", proc_name, ") ", NIL); + handle_documentation_typemap(signature2, NIL, n, "tmap:varin:arglist", "new-value"); + Printv(doc, "Get or set the value of the C variable, \n", NIL); + Printv(doc, "which is of type ", NIL); + handle_documentation_typemap(doc, NIL, n, "tmap:varout:doc", "$1_type"); + Printv(doc, "."); + } else { + Printv(signature, proc_name, " #:optional ", NIL); + if ((tm = Getattr(n, "tmap:varin:doc"))) { + Printv(signature, tm, NIL); + } else { + String *s = SwigType_str(t, 0); + Chop(s); + Printf(signature, "new-value <%s>", s); + Delete(s); + } + + Printv(doc, "If NEW-VALUE is provided, " "set C variable to this value.\n", NIL); + Printv(doc, "Returns variable value ", NIL); + if ((tm = Getattr(n, "tmap:varout:doc"))) { + Printv(doc, tm, NIL); + } else { + String *s = SwigType_str(t, 0); + Chop(s); + Printf(doc, "<%s>", s); + Delete(s); + } + } + write_doc(proc_name, signature, doc, signature2); + Delete(signature); + if (signature2) + Delete(signature2); + Delete(doc); + } + + } else { + Swig_warning(WARN_TYPEMAP_VAR_UNDEF, input_file, line_number, "Unsupported variable type %s (ignored).\n", SwigType_str(t, 0)); + } + Delete(var_name); + Delete(proc_name); + DelWrapper(f); + return SWIG_OK; + } + + /* ------------------------------------------------------------ + * constantWrapper() + * + * We create a read-only variable. + * ------------------------------------------------------------ */ + + virtual int constantWrapper(Node *n) { + char *name = GetChar(n, "name"); + char *iname = GetChar(n, "sym:name"); + SwigType *type = Getattr(n, "type"); + String *value = Getattr(n, "value"); + int constasvar = GetFlag(n, "feature:constasvar"); + + + String *proc_name; + String *var_name; + String *rvalue; + Wrapper *f; + SwigType *nctype; + String *tm; + + f = NewWrapper(); + + // Make a static variable; + var_name = NewStringf("%sconst_%s", prefix, iname); + + // Strip const qualifier from type if present + + nctype = NewString(type); + if (SwigType_isconst(nctype)) { + Delete(SwigType_pop(nctype)); + } + // Build the name for scheme. + proc_name = NewString(iname); + Replaceall(proc_name, "_", "-"); + + if ((SwigType_type(nctype) == T_USER) && (!is_a_pointer(nctype))) { + Swig_warning(WARN_TYPEMAP_CONST_UNDEF, input_file, line_number, "Unsupported constant value.\n"); + Delete(var_name); + DelWrapper(f); + return SWIG_NOWRAP; + } + // See if there's a typemap + + if (SwigType_type(nctype) == T_STRING) { + rvalue = NewStringf("\"%s\"", value); + } else if (SwigType_type(nctype) == T_CHAR) { + rvalue = NewStringf("\'%s\'", value); + } else { + rvalue = NewString(value); + } + + if ((tm = Swig_typemap_lookup("constant", n, name, 0))) { + Replaceall(tm, "$source", rvalue); + Replaceall(tm, "$value", rvalue); + Replaceall(tm, "$target", name); + Printv(f_header, tm, "\n", NIL); + } else { + // Create variable and assign it a value + Printf(f_header, "static %s = %s;\n", SwigType_lstr(nctype, var_name), rvalue); + } + { + /* Hack alert: will cleanup later -- Dave */ + Node *n = NewHash(); + Setattr(n, "name", var_name); + Setattr(n, "sym:name", iname); + Setattr(n, "type", nctype); + SetFlag(n, "feature:immutable"); + if (constasvar) { + SetFlag(n, "feature:constasvar"); + } + variableWrapper(n); + Delete(n); + } + Delete(var_name); + Delete(nctype); + Delete(proc_name); + Delete(rvalue); + DelWrapper(f); + return SWIG_OK; + } + + /* ------------------------------------------------------------ + * classDeclaration() + * ------------------------------------------------------------ */ + virtual int classDeclaration(Node *n) { + String *class_name = NewStringf("<%s>", Getattr(n, "sym:name")); + Setattr(n, "guile:goopsclassname", class_name); + return Language::classDeclaration(n); + } + + /* ------------------------------------------------------------ + * classHandler() + * ------------------------------------------------------------ */ + virtual int classHandler(Node *n) { + /* Create new strings for building up a wrapper function */ + have_constructor = 0; + + class_name = NewString(""); + short_class_name = NewString(""); + Printv(class_name, "<", Getattr(n, "sym:name"), ">", NIL); + Printv(short_class_name, Getattr(n, "sym:name"), NIL); + Replaceall(class_name, "_", "-"); + Replaceall(short_class_name, "_", "-"); + + if (!addSymbol(class_name, n)) + return SWIG_ERROR; + + /* Handle inheritance */ + String *base_class = NewString("<"); + List *baselist = Getattr(n, "bases"); + if (baselist && Len(baselist)) { + Iterator i = First(baselist); + while (i.item) { + Printv(base_class, Getattr(i.item, "sym:name"), NIL); + i = Next(i); + if (i.item) { + Printf(base_class, "> <"); + } + } + } + Printf(base_class, ">"); + Replaceall(base_class, "_", "-"); + + Printv(goopscode, "(define-class ", class_name, " ", NIL); + Printf(goopsexport, "%s ", class_name); + + if (Len(base_class) > 2) { + Printv(goopscode, "(", base_class, ")\n", NIL); + } else { + Printv(goopscode, "(<swig>)\n", NIL); + } + SwigType *ct = NewStringf("p.%s", Getattr(n, "name")); + swigtype_ptr = SwigType_manglestr(ct); + + String *mangled_classname = Swig_name_mangle(Getattr(n, "sym:name")); + /* Export clientdata structure */ + if (use_scm_interface) { + Printf(f_runtime, "static swig_guile_clientdata _swig_guile_clientdata%s = { NULL, SCM_EOL };\n", mangled_classname); + + Printv(f_init, "SWIG_TypeClientData(SWIGTYPE", swigtype_ptr, ", (void *) &_swig_guile_clientdata", mangled_classname, ");\n", NIL); + SwigType_remember(ct); + } + Delete(ct); + + /* Emit all of the members */ + goops_class_methods = NewString(""); + + in_class = 1; + Language::classHandler(n); + in_class = 0; + + Printv(goopscode, " #:metaclass <swig-metaclass>\n", NIL); + + if (have_constructor) + Printv(goopscode, " #:new-function ", primRenamer ? "primitive:" : "", "new-", short_class_name, "\n", NIL); + + Printf(goopscode, ")\n%s\n", goops_class_methods); + Delete(goops_class_methods); + goops_class_methods = 0; + + + /* export class initialization function */ + if (goops) { + /* export the wrapper function */ + String *funcName = NewString(mangled_classname); + Printf(funcName, "_swig_guile_setgoopsclass"); + String *guileFuncName = NewString(funcName); + Replaceall(guileFuncName, "_", "-"); + + Printv(f_wrappers, "static SCM ", funcName, "(SCM cl) \n", NIL); + Printf(f_wrappers, "#define FUNC_NAME %s\n{\n", guileFuncName); + Printv(f_wrappers, " ((swig_guile_clientdata *)(SWIGTYPE", swigtype_ptr, "->clientdata))->goops_class = cl;\n", NIL); + Printf(f_wrappers, " return SCM_UNSPECIFIED;\n"); + Printf(f_wrappers, "}\n#undef FUNC_NAME\n\n"); + + Printf(f_init, "scm_c_define_gsubr(\"%s\", 1, 0, 0, (swig_guile_proc) %s);\n", guileFuncName, funcName); + Printf(exported_symbols, "\"%s\", ", guileFuncName); + + /* export the call to the wrapper function */ + Printf(goopscode, "(%s%s %s)\n\n", primRenamer ? "primitive:" : "", guileFuncName, class_name); + + Delete(guileFuncName); + Delete(funcName); + } + + Delete(mangled_classname); + + Delete(swigtype_ptr); + swigtype_ptr = 0; + + Delete(class_name); + Delete(short_class_name); + class_name = 0; + short_class_name = 0; + + return SWIG_OK; + } + + /* ------------------------------------------------------------ + * memberfunctionHandler() + * ------------------------------------------------------------ */ + int memberfunctionHandler(Node *n) { + String *iname = Getattr(n, "sym:name"); + String *proc = NewString(iname); + Replaceall(proc, "_", "-"); + + memberfunction_name = goopsNameMapping(proc, short_class_name); + Language::memberfunctionHandler(n); + Delete(memberfunction_name); + memberfunction_name = NULL; + Delete(proc); + return SWIG_OK; + } + + /* ------------------------------------------------------------ + * membervariableHandler() + * ------------------------------------------------------------ */ + int membervariableHandler(Node *n) { + String *iname = Getattr(n, "sym:name"); + + if (emit_setters) { + struct_member = 1; + Printf(f_init, "{\n"); + } + + Language::membervariableHandler(n); + + if (emit_setters) { + Printf(f_init, "}\n"); + struct_member = 0; + } + + String *proc = NewString(iname); + Replaceall(proc, "_", "-"); + String *goops_name = goopsNameMapping(proc, short_class_name); + + /* The slot name is never qualified with the class, + even if useclassprefix is true. */ + Printv(goopscode, " (", proc, " #:allocation #:virtual", NIL); + /* GOOPS (at least in Guile 1.6.3) only accepts closures, not + primitive procedures for slot-ref and slot-set. */ + Printv(goopscode, "\n #:slot-ref (lambda (obj) (", primRenamer ? "primitive:" : "", short_class_name, "-", proc, "-get", " obj))", NIL); + if (!GetFlag(n, "feature:immutable")) { + Printv(goopscode, "\n #:slot-set! (lambda (obj value) (", primRenamer ? "primitive:" : "", short_class_name, "-", proc, "-set", " obj value))", NIL); + } else { + Printf(goopscode, "\n #:slot-set! (lambda (obj value) (error \"Immutable slot\"))"); + } + if (emit_slot_accessors) { + if (GetFlag(n, "feature:immutable")) { + Printv(goopscode, "\n #:getter ", goops_name, NIL); + } else { + Printv(goopscode, "\n #:accessor ", goops_name, NIL); + } + Printf(goopsexport, "%s ", goops_name); + } + Printv(goopscode, ")\n", NIL); + Delete(proc); + Delete(goops_name); + return SWIG_OK; + } + + /* ------------------------------------------------------------ + * constructorHandler() + * ------------------------------------------------------------ */ + int constructorHandler(Node *n) { + Language::constructorHandler(n); + have_constructor = 1; + return SWIG_OK; + } + + /* ------------------------------------------------------------ + * destructorHandler() + * ------------------------------------------------------------ */ + virtual int destructorHandler(Node *n) { + exporting_destructor = true; + Language::destructorHandler(n); + exporting_destructor = false; + return SWIG_OK; + } + + /* ------------------------------------------------------------ + * pragmaDirective() + * ------------------------------------------------------------ */ + + virtual int pragmaDirective(Node *n) { + if (!ImportMode) { + String *lang = Getattr(n, "lang"); + String *cmd = Getattr(n, "name"); + String *value = Getattr(n, "value"); + +# define store_pragma(PRAGMANAME) \ + if (Strcmp(cmd, #PRAGMANAME) == 0) { \ + if (PRAGMANAME) Delete(PRAGMANAME); \ + PRAGMANAME = value ? NewString(value) : NULL; \ + } + + if (Strcmp(lang, "guile") == 0) { + store_pragma(beforereturn) + store_pragma(return_nothing_doc) + store_pragma(return_one_doc) + store_pragma(return_multi_doc); +# undef store_pragma + } + } + return Language::pragmaDirective(n); + } + + + /* ------------------------------------------------------------ + * goopsNameMapping() + * Maps the identifier from C++ to the GOOPS based * on command + * line parameters and such. + * If class_name = "" that means the mapping is for a function or + * variable not attached to any class. + * ------------------------------------------------------------ */ + String *goopsNameMapping(String *name, const_String_or_char_ptr class_name) { + String *n = NewString(""); + + if (Strcmp(class_name, "") == 0) { + // not part of a class, so no class name to prefix + if (goopsprefix) { + Printf(n, "%s%s", goopsprefix, name); + } else { + Printf(n, "%s", name); + } + } else { + if (useclassprefix) { + Printf(n, "%s-%s", class_name, name); + } else { + if (goopsprefix) { + Printf(n, "%s%s", goopsprefix, name); + } else { + Printf(n, "%s", name); + } + } + } + return n; + } + + + /* ------------------------------------------------------------ + * validIdentifier() + * ------------------------------------------------------------ */ + + virtual int validIdentifier(String *s) { + char *c = Char(s); + /* Check whether we have an R5RS identifier. Guile supports a + superset of R5RS identifiers, but it's probably a bad idea to use + those. */ + /* <identifier> --> <initial> <subsequent>* | <peculiar identifier> */ + /* <initial> --> <letter> | <special initial> */ + if (!(isalpha(*c) || (*c == '!') || (*c == '$') || (*c == '%') + || (*c == '&') || (*c == '*') || (*c == '/') || (*c == ':') + || (*c == '<') || (*c == '=') || (*c == '>') || (*c == '?') + || (*c == '^') || (*c == '_') || (*c == '~'))) { + /* <peculiar identifier> --> + | - | ... */ + if ((strcmp(c, "+") == 0) + || strcmp(c, "-") == 0 || strcmp(c, "...") == 0) + return 1; + else + return 0; + } + /* <subsequent> --> <initial> | <digit> | <special subsequent> */ + while (*c) { + if (!(isalnum(*c) || (*c == '!') || (*c == '$') || (*c == '%') + || (*c == '&') || (*c == '*') || (*c == '/') || (*c == ':') + || (*c == '<') || (*c == '=') || (*c == '>') || (*c == '?') + || (*c == '^') || (*c == '_') || (*c == '~') || (*c == '+') + || (*c == '-') || (*c == '.') || (*c == '@'))) + return 0; + c++; + } + return 1; + } + + String *runtimeCode() { + String *s; + if (use_scm_interface) { + s = Swig_include_sys("guile_scm_run.swg"); + if (!s) { + Printf(stderr, "*** Unable to open 'guile_scm_run.swg"); + s = NewString(""); + } + } else { + s = Swig_include_sys("guile_gh_run.swg"); + if (!s) { + Printf(stderr, "*** Unable to open 'guile_gh_run.swg"); + s = NewString(""); + } + } + return s; + } + + String *defaultExternalRuntimeFilename() { + if (use_scm_interface) { + return NewString("swigguilerun.h"); + } else { + return NewString("swigguileghrun.h"); + } + } +}; + +/* ----------------------------------------------------------------------------- + * swig_guile() - Instantiate module + * ----------------------------------------------------------------------------- */ + +static Language *new_swig_guile() { + return new GUILE(); +} +extern "C" Language *swig_guile(void) { + return new_swig_guile(); +} |