XS-MLVP
/
swig
mirror of https://github.com/swig/swig
5
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity
swig/Source/Modules/guile.cxx

1663 lines
53 KiB
C++
Raw Blame History

/* -----------------------------------------------------------------------------
* This file is part of SWIG, which is licensed as a whole under version 3
* (or any later version) of the GNU General Public License. Some additional
* terms also apply to certain portions of SWIG. The full details of the SWIG
* license and copyrights can be found in the LICENSE and COPYRIGHT files
* included with the SWIG source code as distributed by the SWIG developers
* and at https://www.swig.org/legal.html.
*
* guile.cxx
*
* Guile language module for SWIG.
* ----------------------------------------------------------------------------- */
#include "swigmod.h"
#include <ctype.h>
// Note string broken in half for compilers that can't handle long strings
static const char *usage = "\
Guile Options (available with -guile)\n\
-emitsetters - Emit procedures-with-setters for variables\n\
and structure slots.\n\
-emitslotaccessors - Emit accessor methods for all GOOPS slots\n" "\
-exportprimitive - Add the (export ...) code from scmstub into the\n\
GOOPS file.\n\
-goopsprefix <prefix> - Prepend <prefix> to all goops identifiers\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\
-onlysetters - Don't emit traditional getter and setter\n\
procedures for structure slots,\n\
only emit procedures-with-setters.\n\
-package <name> - Set the path of the module to <name>\n\
(default NULL)\n\
-prefix <name> - Use <name> as prefix [default \"gswig_\"]\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\
-proxy - Export GOOPS class definitions\n\
-primsuffix <suffix> - Name appended to primitive module when exporting\n\
GOOPS classes. (default = \"primitive\")\n\
-scmstub - Output Scheme file with module declaration and\n\
exports; only with `passive' and `simple' linkage\n\
-useclassprefix - Prepend the class name to all goops identifiers\n\
\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 String *prefix = NewString("gswig_");
static char *module = 0;
static String *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 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") ? 1 : 0;
}
}
class GUILE:public Language {
public:
/* ------------------------------------------------------------
* main()
* ------------------------------------------------------------ */
virtual void main(int argc, char *argv[]) {
int i;
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(usage, stdout);
Exit(EXIT_SUCCESS);
} else if (strcmp(argv[i], "-prefix") == 0) {
if (argv[i + 1]) {
prefix = NewString(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 = NewString(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]);
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) {
Printf(stderr, "Deprecated command line option: -gh. Wrappers are always generated for the SCM interface. See documentation for more information regarding the deprecated GH interface.\n");
Swig_mark_arg(i);
} else if (strcmp(argv[i], "-scm") == 0) {
Printf(stderr, "Deprecated command line option: -scm. Wrappers are always generated for the SCM interface. See documentation for more information regarding the deprecated GH interface.\n");
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)
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(EXIT_FAILURE);
}
}
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
if (prefix) {
const char *px = Char(prefix);
if (px[Len(prefix) - 1] != '_')
Printf(prefix, "_");
}
/* Add a symbol for this module */
Preprocessor_define("SWIGGUILE 1", 0);
/* Read in default typemaps */
SWIG_config_file("guile_scm.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);
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\n#ifndef SWIGGUILE\n#define SWIGGUILE\n#endif\n\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);
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:
fputs("Fatal internal error: Invalid Guile linkage setting.\n", stderr);
Exit(EXIT_FAILURE);
}
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);
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);
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 ? (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);
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, "$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 : 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"))) {
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, "$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, "$input", Getattr(p, "emit:input"));
Printv(cleanup, tm, "\n", NIL);
p = Getattr(p, "tmap:freearg:next");
} else {
p = nextSibling(p);
}
}
if (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
String *actioncode = emit_action(n);
// Now have return value, figure out what to do with it.
if ((tm = Swig_typemap_lookup_out("out", n, Swig_cresult_name(), f, actioncode))) {
Replaceall(tm, "$result", "gswig_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, Swig_cresult_name(), 0))) {
Printv(f->code, tm, "\n", NIL);
}
}
// Free any memory allocated by the function being wrapped..
if ((tm = Swig_typemap_lookup("ret", n, Swig_cresult_name(), 0))) {
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 */
Printf(f_init, "scm_c_define_gsubr(\"%s\", 0, 0, 1, (swig_guile_proc) %s_rest);\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 = ");
/* 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);
if (!is_setter) {
/* Strip off "-get" */
if (struct_member == 2) {
/* There was a setter, so create a procedure with setter */
Printf(f_init, "scm_c_define");
Printf(f_init, "(\"%.*s\", " "scm_make_procedure_with_setter(getter, setter));\n", pc, len - 4);
} else {
/* There was no setter, so make an alias to the getter */
Printf(f_init, "scm_c_define");
Printf(f_init, "(\"%.*s\", getter);\n", pc, len - 4);
}
Printf(exported_symbols, "\"%.*s\", ", pc, len - 4);
}
} else {
/* Register the function */
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 { /* 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);
Printf(f_init, "scm_c_define_gsubr(\"%s\", 0, 0, 1, (swig_guile_proc) %s);\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, "");
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, "$input", "s_0");
/* 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, "$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 (!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 {
/* Read/write variables become a procedure with setter. */
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");
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, "");
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 *rawval = Getattr(n, "rawval");
String *value = rawval ? rawval : Getattr(n, "value");
int constasvar = GetFlag(n, "feature:constasvar");
String *proc_name;
String *var_name;
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 ((tm = Swig_typemap_lookup("constant", n, name, 0))) {
Replaceall(tm, "$value", value);
Printv(f_header, tm, "\n", NIL);
} else {
// Create variable and assign it a value
Printf(f_header, "static %s = (%s)(%s);\n", SwigType_str(type, var_name), SwigType_str(type, 0), value);
}
{
/* Hack alert: will cleanup later -- Dave */
Node *nn = NewHash();
Setfile(nn, Getfile(n));
Setline(nn, Getline(n));
Setattr(nn, "name", var_name);
Setattr(nn, "sym:name", iname);
Setattr(nn, "type", nctype);
SetFlag(nn, "feature:immutable");
if (constasvar) {
SetFlag(nn, "feature:constasvar");
}
variableWrapper(nn);
Delete(nn);
}
Delete(var_name);
Delete(nctype);
Delete(proc_name);
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 */
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;
s = Swig_include_sys("guile_scm_run.swg");
if (!s) {
Printf(stderr, "*** Unable to open 'guile_scm_run.swg");
s = NewString("");
}
return s;
}
String *defaultExternalRuntimeFilename() {
return NewString("swigguilerun.h");
}
};
/* -----------------------------------------------------------------------------
* swig_guile() - Instantiate module
* ----------------------------------------------------------------------------- */
static Language *new_swig_guile() {
return new GUILE();
}
extern "C" Language *swig_guile(void) {
return new_swig_guile();
}
Reference in New Issue View Git Blame Copy Permalink