Source/Modules/mzscheme.cxx

   1 /* -----------------------------------------------------------------------------
   2  * See the LICENSE file for information on copyright, usage and redistribution
   3  * of SWIG, and the README file for authors - http://www.swig.org/release.html.
   4  *
   5  * mzscheme.cxx
   6  *
   7  * Mzscheme language module for SWIG.
   8  * ----------------------------------------------------------------------------- */
   9
  10 char cvsroot_mzscheme_cxx[] = "$Id: mzscheme.cxx 11133 2009-02-20 07:52:24Z wsfulton $";
  11
  12 #include "swigmod.h"
  13
  14 #include <ctype.h>
  15
  16 static const char *usage = (char *) "\
  17 Mzscheme Options (available with -mzscheme)\n\
  18      -prefix <name>                         - Set a prefix <name> to be prepended to all names\n\
  19      -declaremodule                         - Create extension that declares a module\n\
  20      -noinit                                - Do not emit scheme_initialize, scheme_reload,\n\
  21                                               scheme_module_name functions\n\
  22      -dynamic-load <library>,[library,...]  - Do not link with these libraries, dynamic load\n\
  23                                               them\n\
  24 ";
  25
  26 static String *fieldnames_tab = 0;
  27 static String *convert_tab = 0;
  28 static String *convert_proto_tab = 0;
  29 static String *struct_name = 0;
  30 static String *mangled_struct_name = 0;
  31
  32 static char *prefix = 0;
  33 static bool declaremodule = false;
  34 static bool noinit = false;
  35 //DLOPEN PATCH
  36 static char *load_libraries = NULL;
  37 //DLOPEN PATCH
  38 static String *module = 0;
  39 static char *mzscheme_path = (char *) "mzscheme";
  40 static String *init_func_def = 0;
  41
  42 static File *f_begin = 0;
  43 static File *f_runtime = 0;
  44 static File *f_header = 0;
  45 static File *f_wrappers = 0;
  46 static File *f_init = 0;
  47
  48 // Used for garbage collection
  49 static int exporting_destructor = 0;
  50 static String *swigtype_ptr = 0;
  51 static String *cls_swigtype = 0;
  52
  53 class MZSCHEME:public Language {
  54 public:
  55
  56   /* ------------------------------------------------------------
  57    * main()
  58    * ------------------------------------------------------------ */
  59
  60   virtual void main(int argc, char *argv[]) {
  61
  62     int i;
  63
  64      SWIG_library_directory(mzscheme_path);
  65
  66     // Look for certain command line options
  67     for (i = 1; i < argc; i++) {
  68       if (argv[i]) {
  69         if (strcmp(argv[i], "-help") == 0) {
  70           fputs(usage, stdout);
  71           SWIG_exit(0);
  72         } else if (strcmp(argv[i], "-prefix") == 0) {
  73           if (argv[i + 1]) {
  74             prefix = new char[strlen(argv[i + 1]) + 2];
  75             strcpy(prefix, argv[i + 1]);
  76             Swig_mark_arg(i);
  77             Swig_mark_arg(i + 1);
  78             i++;
  79           } else {
  80             Swig_arg_error();
  81           }
  82         } else if (strcmp(argv[i], "-declaremodule") == 0) {
  83           declaremodule = true;
  84           Swig_mark_arg(i);
  85         } else if (strcmp(argv[i], "-noinit") == 0) {
  86           noinit = true;
  87           Swig_mark_arg(i);
  88         }
  89 // DLOPEN PATCH
  90         else if (strcmp(argv[i], "-dynamic-load") == 0) {
  91           load_libraries = new char[strlen(argv[i + 1]) + 2];
  92           strcpy(load_libraries, argv[i + 1]);
  93           Swig_mark_arg(i++);
  94           Swig_mark_arg(i);
  95         }
  96 // DLOPEN PATCH
  97       }
  98     }
  99
 100     // If a prefix has been specified make sure it ends in a '_'
 101
 102     if (prefix) {
 103       if (prefix[strlen(prefix)] != '_') {
 104         prefix[strlen(prefix) + 1] = 0;
 105         prefix[strlen(prefix)] = '_';
 106       }
 107     } else
 108       prefix = (char *) "swig_";
 109
 110     // Add a symbol for this module
 111
 112     Preprocessor_define("SWIGMZSCHEME 1", 0);
 113
 114     // Set name of typemaps
 115
 116     SWIG_typemap_lang("mzscheme");
 117
 118     // Read in default typemaps */
 119     SWIG_config_file("mzscheme.swg");
 120     allow_overloading();
 121
 122   }
 123
 124   /* ------------------------------------------------------------
 125    * top()
 126    * ------------------------------------------------------------ */
 127
 128   virtual int top(Node *n) {
 129
 130     /* Initialize all of the output files */
 131     String *outfile = Getattr(n, "outfile");
 132
 133     f_begin = NewFile(outfile, "w", SWIG_output_files());
 134     if (!f_begin) {
 135       FileErrorDisplay(outfile);
 136       SWIG_exit(EXIT_FAILURE);
 137     }
 138     f_runtime = NewString("");
 139     f_init = NewString("");
 140     f_header = NewString("");
 141     f_wrappers = NewString("");
 142
 143     /* Register file targets with the SWIG file handler */
 144     Swig_register_filebyname("header", f_header);
 145     Swig_register_filebyname("wrapper", f_wrappers);
 146     Swig_register_filebyname("begin", f_begin);
 147     Swig_register_filebyname("runtime", f_runtime);
 148
 149     init_func_def = NewString("");
 150     Swig_register_filebyname("init", init_func_def);
 151
 152     Swig_banner(f_begin);
 153
 154     Printf(f_runtime, "\n");
 155     Printf(f_runtime, "#define SWIGMZSCHEME\n");
 156     Printf(f_runtime, "\n");
 157
 158     module = Getattr(n, "name");
 159
 160     Language::top(n);
 161
 162     SwigType_emit_type_table(f_runtime, f_wrappers);
 163     if (!noinit) {
 164       if (declaremodule) {
 165         Printf(f_init, "#define SWIG_MZSCHEME_CREATE_MENV(env) scheme_primitive_module(scheme_intern_symbol(\"%s\"), env)\n", module);
 166       } else {
 167         Printf(f_init, "#define SWIG_MZSCHEME_CREATE_MENV(env) (env)\n");
 168       }
 169       Printf(f_init, "%s\n", Char(init_func_def));
 170       if (declaremodule) {
 171         Printf(f_init, "\tscheme_finish_primitive_module(menv);\n");
 172       }
 173       Printf(f_init, "\treturn scheme_void;\n}\n");
 174       Printf(f_init, "Scheme_Object *scheme_initialize(Scheme_Env *env) {\n");
 175
 176       // DLOPEN PATCH
 177       if (load_libraries) {
 178         Printf(f_init, "mz_set_dlopen_libraries(\"%s\");\n", load_libraries);
 179       }
 180       // DLOPEN PATCH
 181
 182       Printf(f_init, "\treturn scheme_reload(env);\n");
 183       Printf(f_init, "}\n");
 184
 185       Printf(f_init, "Scheme_Object *scheme_module_name(void) {\n");
 186       if (declaremodule) {
 187         Printf(f_init, "   return scheme_intern_symbol((char*)\"%s\");\n", module);
 188       } else {
 189         Printf(f_init, "   return scheme_make_symbol((char*)\"%s\");\n", module);
 190       }
 191       Printf(f_init, "}\n");
 192     }
 193
 194     /* Close all of the files */
 195     Dump(f_runtime, f_begin);
 196     Dump(f_header, f_begin);
 197     Dump(f_wrappers, f_begin);
 198     Wrapper_pretty_print(f_init, f_begin);
 199     Delete(f_header);
 200     Delete(f_wrappers);
 201     Delete(f_init);
 202     Close(f_begin);
 203     Delete(f_runtime);
 204     Delete(f_begin);
 205     return SWIG_OK;
 206   }
 207
 208   /* ------------------------------------------------------------
 209    * functionWrapper()
 210    * Create a function declaration and register it with the interpreter.
 211    * ------------------------------------------------------------ */
 212
 213   void throw_unhandled_mzscheme_type_error(SwigType *d) {
 214     Swig_warning(WARN_TYPEMAP_UNDEF, input_file, line_number, "Unable to handle type %s.\n", SwigType_str(d, 0));
 215   }
 216
 217   /* Return true iff T is a pointer type */
 218
 219   int
 220    is_a_pointer(SwigType *t) {
 221     return SwigType_ispointer(SwigType_typedef_resolve_all(t));
 222   }
 223
 224   virtual int functionWrapper(Node *n) {
 225     char *iname = GetChar(n, "sym:name");
 226     SwigType *d = Getattr(n, "type");
 227     ParmList *l = Getattr(n, "parms");
 228     Parm *p;
 229
 230     Wrapper *f = NewWrapper();
 231     String *proc_name = NewString("");
 232     String *source = NewString("");
 233     String *target = NewString("");
 234     String *arg = NewString("");
 235     String *cleanup = NewString("");
 236     String *outarg = NewString("");
 237     String *build = NewString("");
 238     String *tm;
 239     int argout_set = 0;
 240     int i = 0;
 241     int numargs;
 242     int numreq;
 243     String *overname = 0;
 244
 245     // PATCH DLOPEN
 246     if (load_libraries) {
 247       ParmList *parms = Getattr(n, "parms");
 248       SwigType *type = Getattr(n, "type");
 249       String *name = NewString("caller");
 250       Setattr(n, "wrap:action", Swig_cresult(type, "result", Swig_cfunction_call(name, parms)));
 251     }
 252     // PATCH DLOPEN
 253
 254     // Make a wrapper name for this
 255     String *wname = Swig_name_wrapper(iname);
 256     if (Getattr(n, "sym:overloaded")) {
 257       overname = Getattr(n, "sym:overname");
 258     } else {
 259       if (!addSymbol(iname, n)) {
 260         DelWrapper(f);
 261         return SWIG_ERROR;
 262       }
 263     }
 264     if (overname) {
 265       Append(wname, overname);
 266     }
 267     Setattr(n, "wrap:name", wname);
 268
 269     // Build the name for Scheme.
 270     Printv(proc_name, iname, NIL);
 271     Replaceall(proc_name, "_", "-");
 272
 273     // writing the function wrapper function
 274     Printv(f->def, "static Scheme_Object *", wname, " (", NIL);
 275     Printv(f->def, "int argc, Scheme_Object **argv", NIL);
 276     Printv(f->def, ")\n{", NIL);
 277
 278     /* Define the scheme name in C. This define is used by several
 279        macros. */
 280     Printv(f->def, "#define FUNC_NAME \"", proc_name, "\"", NIL);
 281
 282     // Emit all of the local variables for holding arguments.
 283     emit_parameter_variables(l, f);
 284
 285     /* Attach the standard typemaps */
 286     emit_attach_parmmaps(l, f);
 287     Setattr(n, "wrap:parms", l);
 288
 289     numargs = emit_num_arguments(l);
 290     numreq = emit_num_required(l);
 291
 292     // DLOPEN PATCH
 293     /* Add the holder for the pointer to the function to be opened */
 294     if (load_libraries) {
 295       Wrapper_add_local(f, "_function_loaded", "static int _function_loaded=(1==0)");
 296       Wrapper_add_local(f, "_the_function", "static void *_the_function=NULL");
 297       {
 298         String *parms = ParmList_protostr(l);
 299         String *func = NewStringf("(*caller)(%s)", parms);
 300         Wrapper_add_local(f, "caller", SwigType_lstr(d, func)); /*"(*caller)()")); */
 301       }
 302     }
 303     // DLOPEN PATCH
 304
 305     // adds local variables
 306     Wrapper_add_local(f, "lenv", "int lenv = 1");
 307     Wrapper_add_local(f, "values", "Scheme_Object *values[MAXVALUES]");
 308
 309     // DLOPEN PATCH
 310     if (load_libraries) {
 311       Printf(f->code, "if (!_function_loaded) { _the_function=mz_load_function(\"%s\");_function_loaded=(1==1); }\n", iname);
 312       Printf(f->code, "if (!_the_function) { scheme_signal_error(\"Cannot load C function '%s'\"); }\n", iname);
 313       Printf(f->code, "caller=_the_function;\n");
 314     }
 315     // DLOPEN PATCH
 316
 317     // Now write code to extract the parameters (this is super ugly)
 318
 319     for (i = 0, p = l; i < numargs; i++) {
 320       /* Skip ignored arguments */
 321
 322       while (checkAttribute(p, "tmap:in:numinputs", "0")) {
 323         p = Getattr(p, "tmap:in:next");
 324       }
 325
 326       SwigType *pt = Getattr(p, "type");
 327       String *ln = Getattr(p, "lname");
 328
 329       // Produce names of source and target
 330       Clear(source);
 331       Clear(target);
 332       Clear(arg);
 333       Printf(source, "argv[%d]", i);
 334       Printf(target, "%s", ln);
 335       Printv(arg, Getattr(p, "name"), NIL);
 336
 337       if (i >= numreq) {
 338         Printf(f->code, "if (argc > %d) {\n", i);
 339       }
 340       // Handle parameter types.
 341       if ((tm = Getattr(p, "tmap:in"))) {
 342         Replaceall(tm, "$source", source);
 343         Replaceall(tm, "$target", target);
 344         Replaceall(tm, "$input", source);
 345         Setattr(p, "emit:input", source);
 346         Printv(f->code, tm, "\n", NIL);
 347         p = Getattr(p, "tmap:in:next");
 348       } else {
 349         // no typemap found
 350         // check if typedef and resolve
 351         throw_unhandled_mzscheme_type_error(pt);
 352         p = nextSibling(p);
 353       }
 354       if (i >= numreq) {
 355         Printf(f->code, "}\n");
 356       }
 357     }
 358
 359     /* Insert constraint checking code */
 360     for (p = l; p;) {
 361       if ((tm = Getattr(p, "tmap:check"))) {
 362         Replaceall(tm, "$target", Getattr(p, "lname"));
 363         Printv(f->code, tm, "\n", NIL);
 364         p = Getattr(p, "tmap:check:next");
 365       } else {
 366         p = nextSibling(p);
 367       }
 368     }
 369
 370     // Pass output arguments back to the caller.
 371
 372     for (p = l; p;) {
 373       if ((tm = Getattr(p, "tmap:argout"))) {
 374         Replaceall(tm, "$source", Getattr(p, "emit:input"));    /* Deprecated */
 375         Replaceall(tm, "$target", Getattr(p, "lname")); /* Deprecated */
 376         Replaceall(tm, "$arg", Getattr(p, "emit:input"));
 377         Replaceall(tm, "$input", Getattr(p, "emit:input"));
 378         Printv(outarg, tm, "\n", NIL);
 379         p = Getattr(p, "tmap:argout:next");
 380         argout_set = 1;
 381       } else {
 382         p = nextSibling(p);
 383       }
 384     }
 385
 386     // Free up any memory allocated for the arguments.
 387
 388     /* Insert cleanup code */
 389     for (p = l; p;) {
 390       if ((tm = Getattr(p, "tmap:freearg"))) {
 391         Replaceall(tm, "$target", Getattr(p, "lname"));
 392         Printv(cleanup, tm, "\n", NIL);
 393         p = Getattr(p, "tmap:freearg:next");
 394       } else {
 395         p = nextSibling(p);
 396       }
 397     }
 398
 399     // Now write code to make the function call
 400
 401     String *actioncode = emit_action(n);
 402
 403     // Now have return value, figure out what to do with it.
 404     if ((tm = Swig_typemap_lookup_out("out", n, "result", f, actioncode))) {
 405       Replaceall(tm, "$source", "result");
 406       Replaceall(tm, "$target", "values[0]");
 407       Replaceall(tm, "$result", "values[0]");
 408       if (GetFlag(n, "feature:new"))
 409         Replaceall(tm, "$owner", "1");
 410       else
 411         Replaceall(tm, "$owner", "0");
 412       Printv(f->code, tm, "\n", NIL);
 413     } else {
 414       throw_unhandled_mzscheme_type_error(d);
 415     }
 416     emit_return_variable(n, d, f);
 417
 418     // Dump the argument output code
 419     Printv(f->code, Char(outarg), NIL);
 420
 421     // Dump the argument cleanup code
 422     Printv(f->code, Char(cleanup), NIL);
 423
 424     // Look for any remaining cleanup
 425
 426     if (GetFlag(n, "feature:new")) {
 427       if ((tm = Swig_typemap_lookup("newfree", n, "result", 0))) {
 428         Replaceall(tm, "$source", "result");
 429         Printv(f->code, tm, "\n", NIL);
 430       }
 431     }
 432     // Free any memory allocated by the function being wrapped..
 433
 434     if ((tm = Swig_typemap_lookup("ret", n, "result", 0))) {
 435       Replaceall(tm, "$source", "result");
 436       Printv(f->code, tm, "\n", NIL);
 437     }
 438     // Wrap things up (in a manner of speaking)
 439
 440     Printv(f->code, tab4, "return SWIG_MzScheme_PackageValues(lenv, values);\n", NIL);
 441     Printf(f->code, "#undef FUNC_NAME\n");
 442     Printv(f->code, "}\n", NIL);
 443
 444     /* Substitute the function name */
 445     Replaceall(f->code, "$symname", iname);
 446
 447     Wrapper_print(f, f_wrappers);
 448
 449     if (!Getattr(n, "sym:overloaded")) {
 450
 451       // Now register the function
 452       char temp[256];
 453       sprintf(temp, "%d", numargs);
 454       if (exporting_destructor) {
 455         Printf(init_func_def, "SWIG_TypeClientData(SWIGTYPE%s, (void *) %s);\n", swigtype_ptr, wname);
 456       } else {
 457         Printf(init_func_def, "scheme_add_global(\"%s\", scheme_make_prim_w_arity(%s,\"%s\",%d,%d),menv);\n", proc_name, wname, proc_name, numreq, numargs);
 458       }
 459     } else {
 460       if (!Getattr(n, "sym:nextSibling")) {
 461         /* Emit overloading dispatch function */
 462
 463         int maxargs;
 464         String *dispatch = Swig_overload_dispatch(n, "return %s(argc,argv);", &maxargs);
 465
 466         /* Generate a dispatch wrapper for all overloaded functions */
 467
 468         Wrapper *df = NewWrapper();
 469         String *dname = Swig_name_wrapper(iname);
 470
 471         Printv(df->def, "static Scheme_Object *\n", dname, "(int argc, Scheme_Object **argv) {", NIL);
 472         Printv(df->code, dispatch, "\n", NIL);
 473         Printf(df->code, "scheme_signal_error(\"No matching function for overloaded '%s'\");\n", iname);
 474         Printv(df->code, "}\n", NIL);
 475         Wrapper_print(df, f_wrappers);
 476         Printf(init_func_def, "scheme_add_global(\"%s\", scheme_make_prim_w_arity(%s,\"%s\",%d,%d),menv);\n", proc_name, dname, proc_name, 0, maxargs);
 477         DelWrapper(df);
 478         Delete(dispatch);
 479         Delete(dname);
 480       }
 481     }
 482
 483     Delete(proc_name);
 484     Delete(source);
 485     Delete(target);
 486     Delete(arg);
 487     Delete(outarg);
 488     Delete(cleanup);
 489     Delete(build);
 490     DelWrapper(f);
 491     return SWIG_OK;
 492   }
 493
 494   /* ------------------------------------------------------------
 495    * variableWrapper()
 496    *
 497    * Create a link to a C variable.
 498    * This creates a single function _wrap_swig_var_varname().
 499    * This function takes a single optional argument.   If supplied, it means
 500    * we are setting this variable to some value.  If omitted, it means we are
 501    * simply evaluating this variable.  Either way, we return the variables
 502    * value.
 503    * ------------------------------------------------------------ */
 504
 505   virtual int variableWrapper(Node *n) {
 506
 507     char *name = GetChar(n, "name");
 508     char *iname = GetChar(n, "sym:name");
 509     SwigType *t = Getattr(n, "type");
 510
 511     String *proc_name = NewString("");
 512     String *tm;
 513     String *tm2 = NewString("");;
 514     String *argnum = NewString("0");
 515     String *arg = NewString("argv[0]");
 516     Wrapper *f;
 517
 518     if (!addSymbol(iname, n))
 519       return SWIG_ERROR;
 520
 521     f = NewWrapper();
 522
 523     // evaluation function names
 524     String *var_name = Swig_name_wrapper(iname);
 525
 526     // Build the name for scheme.
 527     Printv(proc_name, iname, NIL);
 528     Replaceall(proc_name, "_", "-");
 529     Setattr(n, "wrap:name", proc_name);
 530
 531     if ((SwigType_type(t) != T_USER) || (is_a_pointer(t))) {
 532
 533       Printf(f->def, "static Scheme_Object *%s(int argc, Scheme_Object** argv) {\n", var_name);
 534       Printv(f->def, "#define FUNC_NAME \"", proc_name, "\"", NIL);
 535
 536       Wrapper_add_local(f, "swig_result", "Scheme_Object *swig_result");
 537
 538       if (!GetFlag(n, "feature:immutable")) {
 539         /* Check for a setting of the variable value */
 540         Printf(f->code, "if (argc) {\n");
 541         if ((tm = Swig_typemap_lookup("varin", n, name, 0))) {
 542           Replaceall(tm, "$source", "argv[0]");
 543           Replaceall(tm, "$target", name);
 544           Replaceall(tm, "$input", "argv[0]");
 545           /* Printv(f->code, tm, "\n",NIL); */
 546           emit_action_code(n, f->code, tm);
 547         } else {
 548           throw_unhandled_mzscheme_type_error(t);
 549         }
 550         Printf(f->code, "}\n");
 551       }
 552       // Now return the value of the variable (regardless
 553       // of evaluating or setting)
 554
 555       if ((tm = Swig_typemap_lookup("varout", n, name, 0))) {
 556         Replaceall(tm, "$source", name);
 557         Replaceall(tm, "$target", "swig_result");
 558         Replaceall(tm, "$result", "swig_result");
 559         /* Printf (f->code, "%s\n", tm); */
 560         emit_action_code(n, f->code, tm);
 561       } else {
 562         throw_unhandled_mzscheme_type_error(t);
 563       }
 564       Printf(f->code, "\nreturn swig_result;\n");
 565       Printf(f->code, "#undef FUNC_NAME\n");
 566       Printf(f->code, "}\n");
 567
 568       Wrapper_print(f, f_wrappers);
 569
 570       // Now add symbol to the MzScheme interpreter
 571
 572       Printv(init_func_def,
 573              "scheme_add_global(\"", proc_name, "\", scheme_make_prim_w_arity(", var_name, ", \"", proc_name, "\", ", "0", ", ", "1", "), menv);\n", NIL);
 574
 575     } else {
 576       Swig_warning(WARN_TYPEMAP_VAR_UNDEF, input_file, line_number, "Unsupported variable type %s (ignored).\n", SwigType_str(t, 0));
 577     }
 578     Delete(var_name);
 579     Delete(proc_name);
 580     Delete(argnum);
 581     Delete(arg);
 582     Delete(tm2);
 583     DelWrapper(f);
 584     return SWIG_OK;
 585   }
 586
 587   /* ------------------------------------------------------------
 588    * constantWrapper()
 589    * ------------------------------------------------------------ */
 590
 591   virtual int constantWrapper(Node *n) {
 592     char *name = GetChar(n, "name");
 593     char *iname = GetChar(n, "sym:name");
 594     SwigType *type = Getattr(n, "type");
 595     String *value = Getattr(n, "value");
 596
 597     String *var_name = NewString("");
 598     String *proc_name = NewString("");
 599     String *rvalue = NewString("");
 600     String *temp = NewString("");
 601     String *tm;
 602
 603     // Make a static variable;
 604
 605     Printf(var_name, "_wrap_const_%s", Swig_name_mangle(Getattr(n, "sym:name")));
 606
 607     // Build the name for scheme.
 608     Printv(proc_name, iname, NIL);
 609     Replaceall(proc_name, "_", "-");
 610
 611     if ((SwigType_type(type) == T_USER) && (!is_a_pointer(type))) {
 612       Swig_warning(WARN_TYPEMAP_CONST_UNDEF, input_file, line_number, "Unsupported constant value.\n");
 613       return SWIG_NOWRAP;
 614     }
 615     // See if there's a typemap
 616
 617     Printv(rvalue, value, NIL);
 618     if ((SwigType_type(type) == T_CHAR) && (is_a_pointer(type) == 1)) {
 619       temp = Copy(rvalue);
 620       Clear(rvalue);
 621       Printv(rvalue, "\"", temp, "\"", NIL);
 622     }
 623     if ((SwigType_type(type) == T_CHAR) && (is_a_pointer(type) == 0)) {
 624       Delete(temp);
 625       temp = Copy(rvalue);
 626       Clear(rvalue);
 627       Printv(rvalue, "'", temp, "'", NIL);
 628     }
 629     if ((tm = Swig_typemap_lookup("constant", n, name, 0))) {
 630       Replaceall(tm, "$source", rvalue);
 631       Replaceall(tm, "$value", rvalue);
 632       Replaceall(tm, "$target", name);
 633       Printf(f_init, "%s\n", tm);
 634     } else {
 635       // Create variable and assign it a value
 636
 637       Printf(f_header, "static %s = ", SwigType_lstr(type, var_name));
 638       if ((SwigType_type(type) == T_STRING)) {
 639         Printf(f_header, "\"%s\";\n", value);
 640       } else if (SwigType_type(type) == T_CHAR) {
 641         Printf(f_header, "\'%s\';\n", value);
 642       } else {
 643         Printf(f_header, "%s;\n", value);
 644       }
 645
 646       // Now create a variable declaration
 647
 648       {
 649         /* Hack alert: will cleanup later -- Dave */
 650         Node *n = NewHash();
 651         Setattr(n, "name", var_name);
 652         Setattr(n, "sym:name", iname);
 653         Setattr(n, "type", type);
 654         SetFlag(n, "feature:immutable");
 655         variableWrapper(n);
 656         Delete(n);
 657       }
 658     }
 659     Delete(proc_name);
 660     Delete(rvalue);
 661     Delete(temp);
 662     return SWIG_OK;
 663   }
 664
 665   virtual int destructorHandler(Node *n) {
 666     exporting_destructor = true;
 667     Language::destructorHandler(n);
 668     exporting_destructor = false;
 669     return SWIG_OK;
 670   }
 671
 672   /* ------------------------------------------------------------
 673    * classHandler()
 674    * ------------------------------------------------------------ */
 675   virtual int classHandler(Node *n) {
 676     String *mangled_classname = 0;
 677     String *real_classname = 0;
 678     String *scm_structname = NewString("");
 679     SwigType *ctype_ptr = NewStringf("p.%s", Getattr(n, "classtype"));
 680
 681     SwigType *t = NewStringf("p.%s", Getattr(n, "name"));
 682     swigtype_ptr = SwigType_manglestr(t);
 683     Delete(t);
 684
 685     cls_swigtype = SwigType_manglestr(Getattr(n, "name"));
 686
 687
 688     fieldnames_tab = NewString("");
 689     convert_tab = NewString("");
 690     convert_proto_tab = NewString("");
 691
 692     struct_name = Getattr(n, "sym:name");
 693     mangled_struct_name = Swig_name_mangle(Getattr(n, "sym:name"));
 694
 695     Printv(scm_structname, struct_name, NIL);
 696     Replaceall(scm_structname, "_", "-");
 697
 698     real_classname = Getattr(n, "name");
 699     mangled_classname = Swig_name_mangle(real_classname);
 700
 701     Printv(fieldnames_tab, "static const char *_swig_struct_", cls_swigtype, "_field_names[] = { \n", NIL);
 702
 703     Printv(convert_proto_tab, "static Scheme_Object *_swig_convert_struct_", cls_swigtype, "(", SwigType_str(ctype_ptr, "ptr"), ");\n", NIL);
 704
 705     Printv(convert_tab, "static Scheme_Object *_swig_convert_struct_", cls_swigtype, "(", SwigType_str(ctype_ptr, "ptr"), ")\n {\n", NIL);
 706
 707     Printv(convert_tab,
 708            tab4, "Scheme_Object *obj;\n", tab4, "Scheme_Object *fields[_swig_struct_", cls_swigtype, "_field_names_cnt];\n", tab4, "int i = 0;\n\n", NIL);
 709
 710     /* Generate normal wrappers */
 711     Language::classHandler(n);
 712
 713     Printv(convert_tab, tab4, "obj = scheme_make_struct_instance(", "_swig_struct_type_", cls_swigtype, ", i, fields);\n", NIL);
 714     Printv(convert_tab, tab4, "return obj;\n}\n\n", NIL);
 715
 716     Printv(fieldnames_tab, "};\n", NIL);
 717
 718     Printv(f_header, "static Scheme_Object *_swig_struct_type_", cls_swigtype, ";\n", NIL);
 719
 720     Printv(f_header, fieldnames_tab, NIL);
 721     Printv(f_header, "#define  _swig_struct_", cls_swigtype, "_field_names_cnt (sizeof(_swig_struct_", cls_swigtype, "_field_names)/sizeof(char*))\n", NIL);
 722
 723     Printv(f_header, convert_proto_tab, NIL);
 724     Printv(f_wrappers, convert_tab, NIL);
 725
 726     Printv(init_func_def, "_swig_struct_type_", cls_swigtype,
 727            " = SWIG_MzScheme_new_scheme_struct(menv, \"", scm_structname, "\", ",
 728            "_swig_struct_", cls_swigtype, "_field_names_cnt,", "(char**) _swig_struct_", cls_swigtype, "_field_names);\n", NIL);
 729
 730     Delete(mangled_classname);
 731     Delete(swigtype_ptr);
 732     swigtype_ptr = 0;
 733     Delete(fieldnames_tab);
 734     Delete(convert_tab);
 735     Delete(ctype_ptr);
 736     Delete(convert_proto_tab);
 737     struct_name = 0;
 738     mangled_struct_name = 0;
 739     Delete(cls_swigtype);
 740     cls_swigtype = 0;
 741
 742     return SWIG_OK;
 743   }
 744
 745   /* ------------------------------------------------------------
 746    * membervariableHandler()
 747    * ------------------------------------------------------------ */
 748
 749   virtual int membervariableHandler(Node *n) {
 750     Language::membervariableHandler(n);
 751
 752     if (!is_smart_pointer()) {
 753       String *symname = Getattr(n, "sym:name");
 754       String *name = Getattr(n, "name");
 755       SwigType *type = Getattr(n, "type");
 756       String *swigtype = SwigType_manglestr(Getattr(n, "type"));
 757       String *tm = 0;
 758       String *access_mem = NewString("");
 759       SwigType *ctype_ptr = NewStringf("p.%s", Getattr(n, "type"));
 760
 761       Printv(fieldnames_tab, tab4, "\"", symname, "\",\n", NIL);
 762       Printv(access_mem, "(ptr)->", name, NIL);
 763       if ((SwigType_type(type) == T_USER) && (!is_a_pointer(type))) {
 764         Printv(convert_tab, tab4, "fields[i++] = ", NIL);
 765         Printv(convert_tab, "_swig_convert_struct_", swigtype, "((", SwigType_str(ctype_ptr, ""), ")&((ptr)->", name, "));\n", NIL);
 766       } else if ((tm = Swig_typemap_lookup("varout", n, access_mem, 0))) {
 767         Replaceall(tm, "$result", "fields[i++]");
 768         Printv(convert_tab, tm, "\n", NIL);
 769       } else
 770         Swig_warning(WARN_TYPEMAP_VAR_UNDEF, input_file, line_number, "Unsupported member variable type %s (ignored).\n", SwigType_str(type, 0));
 771
 772       Delete(access_mem);
 773     }
 774     return SWIG_OK;
 775   }
 776
 777
 778   /* ------------------------------------------------------------
 779    * validIdentifer()
 780    * ------------------------------------------------------------ */
 781
 782   virtual int validIdentifier(String *s) {
 783     char *c = Char(s);
 784     /* Check whether we have an R5RS identifier. */
 785     /* <identifier> --> <initial> <subsequent>* | <peculiar identifier> */
 786     /* <initial> --> <letter> | <special initial> */
 787     if (!(isalpha(*c) || (*c == '!') || (*c == '$') || (*c == '%')
 788           || (*c == '&') || (*c == '*') || (*c == '/') || (*c == ':')
 789           || (*c == '<') || (*c == '=') || (*c == '>') || (*c == '?')
 790           || (*c == '^') || (*c == '_') || (*c == '~'))) {
 791       /* <peculiar identifier> --> + | - | ... */
 792       if ((strcmp(c, "+") == 0)
 793           || strcmp(c, "-") == 0 || strcmp(c, "...") == 0)
 794         return 1;
 795       else
 796         return 0;
 797     }
 798     /* <subsequent> --> <initial> | <digit> | <special subsequent> */
 799     while (*c) {
 800       if (!(isalnum(*c) || (*c == '!') || (*c == '$') || (*c == '%')
 801             || (*c == '&') || (*c == '*') || (*c == '/') || (*c == ':')
 802             || (*c == '<') || (*c == '=') || (*c == '>') || (*c == '?')
 803             || (*c == '^') || (*c == '_') || (*c == '~') || (*c == '+')
 804             || (*c == '-') || (*c == '.') || (*c == '@')))
 805         return 0;
 806       c++;
 807     }
 808     return 1;
 809   }
 810
 811   String *runtimeCode() {
 812     String *s = Swig_include_sys("mzrun.swg");
 813     if (!s) {
 814       Printf(stderr, "*** Unable to open 'mzrun.swg'\n");
 815       s = NewString("");
 816     }
 817     return s;
 818   }
 819
 820   String *defaultExternalRuntimeFilename() {
 821     return NewString("swigmzrun.h");
 822   }
 823 };
 824
 825 /* -----------------------------------------------------------------------------
 826  * swig_mzscheme()    - Instantiate module
 827  * ----------------------------------------------------------------------------- */
 828
 829 static Language *new_swig_mzscheme() {
 830   return new MZSCHEME();
 831 }
 832 extern "C" Language *swig_mzscheme(void) {
 833   return new_swig_mzscheme();
 834 }