Source/Modules/chicken.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  * chicken.cxx
   6  *
   7  * CHICKEN language module for SWIG.
   8  * ----------------------------------------------------------------------------- */
   9
  10 char cvsroot_chicken_cxx[] = "$Id: chicken.cxx 11133 2009-02-20 07:52:24Z wsfulton $";
  11
  12 #include "swigmod.h"
  13
  14 #include <ctype.h>
  15
  16 static const char *chicken_usage = (char *) "\
  17 \
  18 CHICKEN Options (available with -chicken)\n\
  19      -proxy                 - Export TinyCLOS class definitions\n\
  20      -closprefix <prefix>   - Prepend <prefix> to all clos identifiers\n\
  21      -useclassprefix        - Prepend the class name to all clos identifiers\n\
  22      -unhideprimitive       - Unhide the primitive: symbols\n\
  23      -nounit                - Do not (declare (unit ...)) in scheme file\n\
  24      -noclosuses            - Do not (declare (uses ...)) in scheme file\n\
  25      -nocollection          - Do not register pointers with chicken garbage\n\
  26                               collector and export destructors\n\
  27 \n";
  28
  29 static char *module = 0;
  30 static char *chicken_path = (char *) "chicken";
  31 static int num_methods = 0;
  32
  33 static File *f_begin = 0;
  34 static File *f_runtime = 0;
  35 static File *f_header = 0;
  36 static File *f_wrappers = 0;
  37 static File *f_init = 0;
  38 static String *chickentext = 0;
  39 static String *closprefix = 0;
  40 static String *swigtype_ptr = 0;
  41
  42
  43 static String *f_sym_size = 0;
  44
  45 /* some options */
  46 static int declare_unit = 1;
  47 static int no_collection = 0;
  48 static int clos_uses = 1;
  49
  50 /* C++ Support + Clos Classes */
  51 static int clos = 0;
  52 static String *c_class_name = 0;
  53 static String *class_name = 0;
  54 static String *short_class_name = 0;
  55
  56 static int in_class = 0;
  57 static int have_constructor = 0;
  58 static bool exporting_destructor = false;
  59 static bool exporting_constructor = false;
  60 static String *constructor_name = 0;
  61 static String *member_name = 0;
  62
  63 /* sections of the .scm code */
  64 static String *scm_const_defs = 0;
  65 static String *clos_class_defines = 0;
  66 static String *clos_methods = 0;
  67
  68 /* Some clos options */
  69 static int useclassprefix = 0;
  70 static String *clossymnameprefix = 0;
  71 static int hide_primitive = 1;
  72 static Hash *primitive_names = 0;
  73
  74 /* Used for overloading constructors */
  75 static int has_constructor_args = 0;
  76 static List *constructor_arg_types = 0;
  77 static String *constructor_dispatch = 0;
  78
  79 static Hash *overload_parameter_lists = 0;
  80
  81 class CHICKEN:public Language {
  82 public:
  83
  84   virtual void main(int argc, char *argv[]);
  85   virtual int top(Node *n);
  86   virtual int functionWrapper(Node *n);
  87   virtual int variableWrapper(Node *n);
  88   virtual int constantWrapper(Node *n);
  89   virtual int classHandler(Node *n);
  90   virtual int memberfunctionHandler(Node *n);
  91   virtual int membervariableHandler(Node *n);
  92   virtual int constructorHandler(Node *n);
  93   virtual int destructorHandler(Node *n);
  94   virtual int validIdentifier(String *s);
  95   virtual int staticmembervariableHandler(Node *n);
  96   virtual int staticmemberfunctionHandler(Node *n);
  97   virtual int importDirective(Node *n);
  98
  99 protected:
 100   void addMethod(String *scheme_name, String *function);
 101   /* Return true iff T is a pointer type */
 102   int isPointer(SwigType *t);
 103   void dispatchFunction(Node *n);
 104
 105   String *chickenNameMapping(String *, const_String_or_char_ptr );
 106   String *chickenPrimitiveName(String *);
 107
 108   String *runtimeCode();
 109   String *defaultExternalRuntimeFilename();
 110   String *buildClosFunctionCall(List *types, const_String_or_char_ptr closname, const_String_or_char_ptr funcname);
 111 };
 112
 113 /* -----------------------------------------------------------------------
 114  * swig_chicken()    - Instantiate module
 115  * ----------------------------------------------------------------------- */
 116
 117 static Language *new_swig_chicken() {
 118   return new CHICKEN();
 119 }
 120
 121 extern "C" {
 122   Language *swig_chicken(void) {
 123     return new_swig_chicken();
 124   }
 125 }
 126
 127 void CHICKEN::main(int argc, char *argv[]) {
 128   int i;
 129
 130   SWIG_library_directory(chicken_path);
 131
 132   // Look for certain command line options
 133   for (i = 1; i < argc; i++) {
 134     if (argv[i]) {
 135       if (strcmp(argv[i], "-help") == 0) {
 136         fputs(chicken_usage, stdout);
 137         SWIG_exit(0);
 138       } else if (strcmp(argv[i], "-proxy") == 0) {
 139         clos = 1;
 140         Swig_mark_arg(i);
 141       } else if (strcmp(argv[i], "-closprefix") == 0) {
 142         if (argv[i + 1]) {
 143           clossymnameprefix = NewString(argv[i + 1]);
 144           Swig_mark_arg(i);
 145           Swig_mark_arg(i + 1);
 146           i++;
 147         } else {
 148           Swig_arg_error();
 149         }
 150       } else if (strcmp(argv[i], "-useclassprefix") == 0) {
 151         useclassprefix = 1;
 152         Swig_mark_arg(i);
 153       } else if (strcmp(argv[i], "-unhideprimitive") == 0) {
 154         hide_primitive = 0;
 155         Swig_mark_arg(i);
 156       } else if (strcmp(argv[i], "-nounit") == 0) {
 157         declare_unit = 0;
 158         Swig_mark_arg(i);
 159       } else if (strcmp(argv[i], "-noclosuses") == 0) {
 160         clos_uses = 0;
 161         Swig_mark_arg(i);
 162       } else if (strcmp(argv[i], "-nocollection") == 0) {
 163         no_collection = 1;
 164         Swig_mark_arg(i);
 165       }
 166     }
 167   }
 168
 169   if (!clos)
 170     hide_primitive = 0;
 171
 172   // Add a symbol for this module
 173   Preprocessor_define("SWIGCHICKEN 1", 0);
 174
 175   // Set name of typemaps
 176
 177   SWIG_typemap_lang("chicken");
 178
 179   // Read in default typemaps */
 180   SWIG_config_file("chicken.swg");
 181   allow_overloading();
 182 }
 183
 184 int CHICKEN::top(Node *n) {
 185   String *chicken_filename = NewString("");
 186   File *f_scm;
 187   String *scmmodule;
 188
 189   /* Initialize all of the output files */
 190   String *outfile = Getattr(n, "outfile");
 191
 192   f_begin = NewFile(outfile, "w", SWIG_output_files());
 193   if (!f_begin) {
 194     FileErrorDisplay(outfile);
 195     SWIG_exit(EXIT_FAILURE);
 196   }
 197   f_runtime = NewString("");
 198   f_init = NewString("");
 199   f_header = NewString("");
 200   f_wrappers = NewString("");
 201   chickentext = NewString("");
 202   closprefix = NewString("");
 203   f_sym_size = NewString("");
 204   primitive_names = NewHash();
 205   overload_parameter_lists = NewHash();
 206
 207   /* Register file targets with the SWIG file handler */
 208   Swig_register_filebyname("header", f_header);
 209   Swig_register_filebyname("wrapper", f_wrappers);
 210   Swig_register_filebyname("begin", f_begin);
 211   Swig_register_filebyname("runtime", f_runtime);
 212   Swig_register_filebyname("init", f_init);
 213
 214   Swig_register_filebyname("chicken", chickentext);
 215   Swig_register_filebyname("closprefix", closprefix);
 216
 217   clos_class_defines = NewString("");
 218   clos_methods = NewString("");
 219   scm_const_defs = NewString("");
 220
 221   Swig_banner(f_begin);
 222
 223   Printf(f_runtime, "\n");
 224   Printf(f_runtime, "#define SWIGCHICKEN\n");
 225
 226   if (no_collection)
 227     Printf(f_runtime, "#define SWIG_CHICKEN_NO_COLLECTION 1\n");
 228
 229   Printf(f_runtime, "\n");
 230
 231   /* Set module name */
 232   module = Swig_copy_string(Char(Getattr(n, "name")));
 233   scmmodule = NewString(module);
 234   Replaceall(scmmodule, "_", "-");
 235
 236   Printf(f_header, "#define SWIG_init swig_%s_init\n", module);
 237   Printf(f_header, "#define SWIG_name \"%s\"\n", scmmodule);
 238
 239   Printf(f_wrappers, "#ifdef __cplusplus\n");
 240   Printf(f_wrappers, "extern \"C\" {\n");
 241   Printf(f_wrappers, "#endif\n\n");
 242
 243   Language::top(n);
 244
 245   SwigType_emit_type_table(f_runtime, f_wrappers);
 246
 247   Printf(f_wrappers, "#ifdef __cplusplus\n");
 248   Printf(f_wrappers, "}\n");
 249   Printf(f_wrappers, "#endif\n");
 250
 251   Printf(f_init, "C_kontinue (continuation, ret);\n");
 252   Printf(f_init, "}\n\n");
 253
 254   Printf(f_init, "#ifdef __cplusplus\n");
 255   Printf(f_init, "}\n");
 256   Printf(f_init, "#endif\n");
 257
 258   Printf(chicken_filename, "%s%s.scm", SWIG_output_directory(), module);
 259   if ((f_scm = NewFile(chicken_filename, "w", SWIG_output_files())) == 0) {
 260     FileErrorDisplay(chicken_filename);
 261     SWIG_exit(EXIT_FAILURE);
 262   }
 263
 264   Swig_banner_target_lang(f_scm, ";;");
 265   Printf(f_scm, "\n");
 266
 267   if (declare_unit)
 268     Printv(f_scm, "(declare (unit ", scmmodule, "))\n\n", NIL);
 269   Printv(f_scm, "(declare \n",
 270          tab4, "(hide swig-init swig-init-return)\n",
 271          tab4, "(foreign-declare \"C_extern void swig_", module, "_init(C_word,C_word,C_word) C_noret;\"))\n", NIL);
 272   Printv(f_scm, "(define swig-init (##core#primitive \"swig_", module, "_init\"))\n", NIL);
 273   Printv(f_scm, "(define swig-init-return (swig-init))\n\n", NIL);
 274
 275   if (clos) {
 276     //Printf (f_scm, "(declare (uses tinyclos))\n");
 277     //New chicken versions have tinyclos as an egg
 278     Printf(f_scm, "(require-extension tinyclos)\n");
 279     Replaceall(closprefix, "$module", scmmodule);
 280     Printf(f_scm, "%s\n", closprefix);
 281     Printf(f_scm, "%s\n", clos_class_defines);
 282     Printf(f_scm, "%s\n", clos_methods);
 283   } else {
 284     Printf(f_scm, "%s\n", scm_const_defs);
 285   }
 286
 287   Printf(f_scm, "%s\n", chickentext);
 288
 289
 290   Close(f_scm);
 291   Delete(f_scm);
 292
 293   char buftmp[20];
 294   sprintf(buftmp, "%d", num_methods);
 295   Replaceall(f_init, "$nummethods", buftmp);
 296   Replaceall(f_init, "$symsize", f_sym_size);
 297
 298   if (hide_primitive)
 299     Replaceall(f_init, "$veclength", buftmp);
 300   else
 301     Replaceall(f_init, "$veclength", "0");
 302
 303   Delete(chicken_filename);
 304   Delete(chickentext);
 305   Delete(closprefix);
 306   Delete(overload_parameter_lists);
 307
 308   Delete(clos_class_defines);
 309   Delete(clos_methods);
 310   Delete(scm_const_defs);
 311
 312   /* Close all of the files */
 313   Delete(primitive_names);
 314   Delete(scmmodule);
 315   Dump(f_runtime, f_begin);
 316   Dump(f_header, f_begin);
 317   Dump(f_wrappers, f_begin);
 318   Wrapper_pretty_print(f_init, f_begin);
 319   Delete(f_header);
 320   Delete(f_wrappers);
 321   Delete(f_sym_size);
 322   Delete(f_init);
 323   Close(f_begin);
 324   Delete(f_runtime);
 325   Delete(f_begin);
 326   return SWIG_OK;
 327 }
 328
 329 int CHICKEN::functionWrapper(Node *n) {
 330
 331   String *name = Getattr(n, "name");
 332   String *iname = Getattr(n, "sym:name");
 333   SwigType *d = Getattr(n, "type");
 334   ParmList *l = Getattr(n, "parms");
 335
 336   Parm *p;
 337   int i;
 338   String *wname;
 339   Wrapper *f;
 340   String *mangle = NewString("");
 341   String *get_pointers;
 342   String *cleanup;
 343   String *argout;
 344   String *tm;
 345   String *overname = 0;
 346   String *declfunc = 0;
 347   String *scmname;
 348   bool any_specialized_arg = false;
 349   List *function_arg_types = NewList();
 350
 351   int num_required;
 352   int num_arguments;
 353   int have_argout;
 354
 355   Printf(mangle, "\"%s\"", SwigType_manglestr(d));
 356
 357   if (Getattr(n, "sym:overloaded")) {
 358     overname = Getattr(n, "sym:overname");
 359   } else {
 360     if (!addSymbol(iname, n))
 361       return SWIG_ERROR;
 362   }
 363
 364   f = NewWrapper();
 365   wname = NewString("");
 366   get_pointers = NewString("");
 367   cleanup = NewString("");
 368   argout = NewString("");
 369   declfunc = NewString("");
 370   scmname = NewString(iname);
 371   Replaceall(scmname, "_", "-");
 372
 373   /* Local vars */
 374   Wrapper_add_local(f, "resultobj", "C_word resultobj");
 375
 376   /* Write code to extract function parameters. */
 377   emit_parameter_variables(l, f);
 378
 379   /* Attach the standard typemaps */
 380   emit_attach_parmmaps(l, f);
 381   Setattr(n, "wrap:parms", l);
 382
 383   /* Get number of required and total arguments */
 384   num_arguments = emit_num_arguments(l);
 385   num_required = emit_num_required(l);
 386
 387   Append(wname, Swig_name_wrapper(iname));
 388   if (overname) {
 389     Append(wname, overname);
 390   }
 391   // Check for interrupts
 392   Printv(f->code, "C_trace(\"", scmname, "\");\n", NIL);
 393
 394   Printv(f->def, "static ", "void ", wname, " (C_word argc, C_word closure, C_word continuation", NIL);
 395   Printv(declfunc, "void ", wname, "(C_word,C_word,C_word", NIL);
 396
 397   /* Generate code for argument marshalling */
 398   for (i = 0, p = l; i < num_arguments; i++) {
 399
 400     while (checkAttribute(p, "tmap:in:numinputs", "0")) {
 401       p = Getattr(p, "tmap:in:next");
 402     }
 403
 404     SwigType *pt = Getattr(p, "type");
 405     String *ln = Getattr(p, "lname");
 406
 407     Printf(f->def, ", C_word scm%d", i + 1);
 408     Printf(declfunc, ",C_word");
 409
 410     /* Look for an input typemap */
 411     if ((tm = Getattr(p, "tmap:in"))) {
 412       String *parse = Getattr(p, "tmap:in:parse");
 413       if (!parse) {
 414         String *source = NewStringf("scm%d", i + 1);
 415         Replaceall(tm, "$source", source);
 416         Replaceall(tm, "$target", ln);
 417         Replaceall(tm, "$input", source);
 418         Setattr(p, "emit:input", source);       /* Save the location of
 419                                                    the object */
 420
 421         if (Getattr(p, "wrap:disown") || (Getattr(p, "tmap:in:disown"))) {
 422           Replaceall(tm, "$disown", "SWIG_POINTER_DISOWN");
 423         } else {
 424           Replaceall(tm, "$disown", "0");
 425         }
 426
 427         if (i >= num_required)
 428           Printf(get_pointers, "if (argc-2>%i && (%s)) {\n", i, source);
 429         Printv(get_pointers, tm, "\n", NIL);
 430         if (i >= num_required)
 431           Printv(get_pointers, "}\n", NIL);
 432
 433         if (clos) {
 434           if (i < num_required) {
 435             if (strcmp("void", Char(pt)) != 0) {
 436               Node *class_node = 0;
 437               String *clos_code = Getattr(p, "tmap:in:closcode");
 438               class_node = classLookup(pt);
 439               if (clos_code && class_node) {
 440                 String *class_name = NewStringf("<%s>", Getattr(class_node, "sym:name"));
 441                 Replaceall(class_name, "_", "-");
 442                 Append(function_arg_types, class_name);
 443                 Append(function_arg_types, Copy(clos_code));
 444                 any_specialized_arg = true;
 445                 Delete(class_name);
 446               } else {
 447                 Append(function_arg_types, "<top>");
 448                 Append(function_arg_types, "$input");
 449               }
 450             }
 451           }
 452         }
 453         Delete(source);
 454       }
 455
 456       p = Getattr(p, "tmap:in:next");
 457       continue;
 458     } else {
 459       Swig_warning(WARN_TYPEMAP_IN_UNDEF, input_file, line_number, "Unable to use type %s as a function argument.\n", SwigType_str(pt, 0));
 460       break;
 461     }
 462   }
 463
 464   /* finish argument marshalling */
 465
 466   Printf(f->def, ") {");
 467   Printf(declfunc, ")");
 468
 469   if (num_required != num_arguments) {
 470     Append(function_arg_types, "^^##optional$$");
 471   }
 472
 473   /* First check the number of arguments is correct */
 474   if (num_arguments != num_required)
 475     Printf(f->code, "if (argc-2<%i || argc-2>%i) C_bad_argc(argc,%i);\n", num_required, num_arguments, num_required + 2);
 476   else
 477     Printf(f->code, "if (argc!=%i) C_bad_argc(argc,%i);\n", num_arguments + 2, num_arguments + 2);
 478
 479   /* Now piece together the first part of the wrapper function */
 480   Printv(f->code, get_pointers, NIL);
 481
 482   /* Insert constraint checking code */
 483   for (p = l; p;) {
 484     if ((tm = Getattr(p, "tmap:check"))) {
 485       Replaceall(tm, "$target", Getattr(p, "lname"));
 486       Printv(f->code, tm, "\n", NIL);
 487       p = Getattr(p, "tmap:check:next");
 488     } else {
 489       p = nextSibling(p);
 490     }
 491   }
 492
 493   /* Insert cleanup code */
 494   for (p = l; p;) {
 495     if ((tm = Getattr(p, "tmap:freearg"))) {
 496       Replaceall(tm, "$source", Getattr(p, "lname"));
 497       Printv(cleanup, tm, "\n", NIL);
 498       p = Getattr(p, "tmap:freearg:next");
 499     } else {
 500       p = nextSibling(p);
 501     }
 502   }
 503
 504   /* Insert argument output code */
 505   have_argout = 0;
 506   for (p = l; p;) {
 507     if ((tm = Getattr(p, "tmap:argout"))) {
 508
 509       if (!have_argout) {
 510         have_argout = 1;
 511         // Print initial argument output code
 512         Printf(argout, "SWIG_Chicken_SetupArgout\n");
 513       }
 514
 515       Replaceall(tm, "$source", Getattr(p, "lname"));
 516       Replaceall(tm, "$target", "resultobj");
 517       Replaceall(tm, "$arg", Getattr(p, "emit:input"));
 518       Replaceall(tm, "$input", Getattr(p, "emit:input"));
 519       Printf(argout, "%s", tm);
 520       p = Getattr(p, "tmap:argout:next");
 521     } else {
 522       p = nextSibling(p);
 523     }
 524   }
 525
 526   Setattr(n, "wrap:name", wname);
 527
 528   /* Emit the function call */
 529   String *actioncode = emit_action(n);
 530
 531   /* Return the function value */
 532   if ((tm = Swig_typemap_lookup_out("out", n, "result", f, actioncode))) {
 533     Replaceall(tm, "$source", "result");
 534     Replaceall(tm, "$target", "resultobj");
 535     Replaceall(tm, "$result", "resultobj");
 536     if (GetFlag(n, "feature:new")) {
 537       Replaceall(tm, "$owner", "1");
 538     } else {
 539       Replaceall(tm, "$owner", "0");
 540     }
 541
 542     Printf(f->code, "%s", tm);
 543
 544     if (have_argout)
 545       Printf(f->code, "\nSWIG_APPEND_VALUE(resultobj);\n");
 546
 547   } else {
 548     Swig_warning(WARN_TYPEMAP_OUT_UNDEF, input_file, line_number, "Unable to use return type %s in function %s.\n", SwigType_str(d, 0), name);
 549   }
 550   emit_return_variable(n, d, f);
 551
 552   /* Insert the argumetn output code */
 553   Printv(f->code, argout, NIL);
 554
 555   /* Output cleanup code */
 556   Printv(f->code, cleanup, NIL);
 557
 558   /* Look to see if there is any newfree cleanup code */
 559   if (GetFlag(n, "feature:new")) {
 560     if ((tm = Swig_typemap_lookup("newfree", n, "result", 0))) {
 561       Replaceall(tm, "$source", "result");
 562       Printf(f->code, "%s\n", tm);
 563     }
 564   }
 565
 566   /* See if there is any return cleanup code */
 567   if ((tm = Swig_typemap_lookup("ret", n, "result", 0))) {
 568     Replaceall(tm, "$source", "result");
 569     Printf(f->code, "%s\n", tm);
 570   }
 571
 572
 573   if (have_argout) {
 574     Printf(f->code, "C_kontinue(continuation,C_SCHEME_END_OF_LIST);\n");
 575   } else {
 576     if (exporting_constructor && clos && hide_primitive) {
 577       /* Don't return a proxy, the wrapped CLOS class is the proxy */
 578       Printf(f->code, "C_kontinue(continuation,resultobj);\n");
 579     } else {
 580       // make the continuation the proxy creation function, if one exists
 581       Printv(f->code, "{\n",
 582              "C_word func;\n",
 583              "SWIG_Chicken_FindCreateProxy(func, resultobj)\n",
 584              "if (C_swig_is_closurep(func))\n",
 585              "  ((C_proc4)(void *)C_block_item(func, 0))(4,func,continuation,resultobj,C_SCHEME_FALSE);\n",
 586              "else\n", "  C_kontinue(continuation, resultobj);\n", "}\n", NIL);
 587     }
 588   }
 589
 590   /* Error handling code */
 591 #ifdef USE_FAIL
 592   Printf(f->code, "fail:\n");
 593   Printv(f->code, cleanup, NIL);
 594   Printf(f->code, "swig_panic (\"failure in " "'$symname' SWIG function wrapper\");\n");
 595 #endif
 596   Printf(f->code, "}\n");
 597
 598   /* Substitute the cleanup code */
 599   Replaceall(f->code, "$cleanup", cleanup);
 600
 601   /* Substitute the function name */
 602   Replaceall(f->code, "$symname", iname);
 603   Replaceall(f->code, "$result", "resultobj");
 604
 605   /* Dump the function out */
 606   Printv(f_wrappers, "static ", declfunc, " C_noret;\n", NIL);
 607   Wrapper_print(f, f_wrappers);
 608
 609   /* Now register the function with the interpreter.   */
 610   if (!Getattr(n, "sym:overloaded")) {
 611     if (exporting_destructor && !no_collection) {
 612       Printf(f_init, "((swig_chicken_clientdata *)(SWIGTYPE%s->clientdata))->destroy = (swig_chicken_destructor) %s;\n", swigtype_ptr, wname);
 613     } else {
 614       addMethod(scmname, wname);
 615     }
 616
 617     /* Only export if we are not in a class, or if in a class memberfunction */
 618     if (!in_class || member_name) {
 619       String *method_def;
 620       String *clos_name;
 621       if (in_class)
 622         clos_name = NewString(member_name);
 623       else
 624         clos_name = chickenNameMapping(scmname, (char *) "");
 625
 626       if (!any_specialized_arg) {
 627         method_def = NewString("");
 628         Printv(method_def, "(define ", clos_name, " ", chickenPrimitiveName(scmname), ")", NIL);
 629       } else {
 630         method_def = buildClosFunctionCall(function_arg_types, clos_name, chickenPrimitiveName(scmname));
 631       }
 632       Printv(clos_methods, method_def, "\n", NIL);
 633       Delete(clos_name);
 634       Delete(method_def);
 635     }
 636
 637     if (have_constructor && !has_constructor_args && any_specialized_arg) {
 638       has_constructor_args = 1;
 639       constructor_arg_types = Copy(function_arg_types);
 640     }
 641   } else {
 642     /* add function_arg_types to overload hash */
 643     List *flist = Getattr(overload_parameter_lists, scmname);
 644     if (!flist) {
 645       flist = NewList();
 646       Setattr(overload_parameter_lists, scmname, flist);
 647     }
 648
 649     Append(flist, Copy(function_arg_types));
 650
 651     if (!Getattr(n, "sym:nextSibling")) {
 652       dispatchFunction(n);
 653     }
 654   }
 655
 656
 657   Delete(wname);
 658   Delete(get_pointers);
 659   Delete(cleanup);
 660   Delete(declfunc);
 661   Delete(mangle);
 662   Delete(function_arg_types);
 663   DelWrapper(f);
 664   return SWIG_OK;
 665 }
 666
 667 int CHICKEN::variableWrapper(Node *n) {
 668   char *name = GetChar(n, "name");
 669   char *iname = GetChar(n, "sym:name");
 670   SwigType *t = Getattr(n, "type");
 671   ParmList *l = Getattr(n, "parms");
 672
 673   String *wname = NewString("");
 674   String *mangle = NewString("");
 675   String *tm;
 676   String *tm2 = NewString("");;
 677   String *argnum = NewString("0");
 678   String *arg = NewString("argv[0]");
 679   Wrapper *f;
 680   String *overname = 0;
 681   String *scmname;
 682
 683   int num_required;
 684   int num_arguments;
 685
 686   scmname = NewString(iname);
 687   Replaceall(scmname, "_", "-");
 688
 689   Printf(mangle, "\"%s\"", SwigType_manglestr(t));
 690
 691   if (Getattr(n, "sym:overloaded")) {
 692     overname = Getattr(n, "sym:overname");
 693   } else {
 694     if (!addSymbol(iname, n))
 695       return SWIG_ERROR;
 696   }
 697
 698   f = NewWrapper();
 699
 700   /* Attach the standard typemaps */
 701   emit_attach_parmmaps(l, f);
 702   Setattr(n, "wrap:parms", l);
 703
 704   /* Get number of required and total arguments */
 705   num_arguments = emit_num_arguments(l);
 706   num_required = emit_num_required(l);
 707
 708   // evaluation function names
 709   Append(wname, Swig_name_wrapper(iname));
 710   if (overname) {
 711     Append(wname, overname);
 712   }
 713   Setattr(n, "wrap:name", wname);
 714
 715   // Check for interrupts
 716   Printv(f->code, "C_trace(\"", scmname, "\");\n", NIL);
 717
 718   if (1 || (SwigType_type(t) != T_USER) || (isPointer(t))) {
 719
 720     Printv(f->def, "static ", "void ", wname, "(C_word, C_word, C_word, C_word) C_noret;\n", NIL);
 721     Printv(f->def, "static " "void ", wname, "(C_word argc, C_word closure, " "C_word continuation, C_word value) {\n", NIL);
 722
 723     Wrapper_add_local(f, "resultobj", "C_word resultobj");
 724
 725     Printf(f->code, "if (argc!=2 && argc!=3) C_bad_argc(argc,2);\n");
 726
 727     /* Check for a setting of the variable value */
 728     if (!GetFlag(n, "feature:immutable")) {
 729       Printf(f->code, "if (argc > 2) {\n");
 730       if ((tm = Swig_typemap_lookup("varin", n, name, 0))) {
 731         Replaceall(tm, "$source", "value");
 732         Replaceall(tm, "$target", name);
 733         Replaceall(tm, "$input", "value");
 734         /* Printv(f->code, tm, "\n",NIL); */
 735         emit_action_code(n, f->code, tm);
 736       } else {
 737         Swig_warning(WARN_TYPEMAP_VARIN_UNDEF, input_file, line_number, "Unable to set variable of type %s.\n", SwigType_str(t, 0));
 738       }
 739       Printf(f->code, "}\n");
 740     }
 741
 742     String *varname;
 743     if (SwigType_istemplate((char *) name)) {
 744       varname = SwigType_namestr((char *) name);
 745     } else {
 746       varname = name;
 747     }
 748
 749     // Now return the value of the variable - regardless
 750     // of evaluating or setting.
 751     if ((tm = Swig_typemap_lookup("varout", n, name, 0))) {
 752       Replaceall(tm, "$source", varname);
 753       Replaceall(tm, "$varname", varname);
 754       Replaceall(tm, "$target", "resultobj");
 755       Replaceall(tm, "$result", "resultobj");
 756       /* Printf(f->code, "%s\n", tm); */
 757       emit_action_code(n, f->code, tm);
 758     } else {
 759       Swig_warning(WARN_TYPEMAP_VAROUT_UNDEF, input_file, line_number, "Unable to read variable of type %s\n", SwigType_str(t, 0));
 760     }
 761
 762     Printv(f->code, "{\n",
 763            "C_word func;\n",
 764            "SWIG_Chicken_FindCreateProxy(func, resultobj)\n",
 765            "if (C_swig_is_closurep(func))\n",
 766            "  ((C_proc4)(void *)C_block_item(func, 0))(4,func,continuation,resultobj,C_SCHEME_FALSE);\n",
 767            "else\n", "  C_kontinue(continuation, resultobj);\n", "}\n", NIL);
 768
 769     /* Error handling code */
 770 #ifdef USE_FAIL
 771     Printf(f->code, "fail:\n");
 772     Printf(f->code, "swig_panic (\"failure in " "'%s' SWIG wrapper\");\n", proc_name);
 773 #endif
 774     Printf(f->code, "}\n");
 775
 776     Wrapper_print(f, f_wrappers);
 777
 778     /* Now register the variable with the interpreter.   */
 779     addMethod(scmname, wname);
 780
 781     if (!in_class || member_name) {
 782       String *clos_name;
 783       if (in_class)
 784         clos_name = NewString(member_name);
 785       else
 786         clos_name = chickenNameMapping(scmname, (char *) "");
 787
 788       Node *class_node = classLookup(t);
 789       String *clos_code = Getattr(n, "tmap:varin:closcode");
 790       if (class_node && clos_code && !GetFlag(n, "feature:immutable")) {
 791         Replaceall(clos_code, "$input", "(car lst)");
 792         Printv(clos_methods, "(define (", clos_name, " . lst) (if (null? lst) (", chickenPrimitiveName(scmname), ") (",
 793                chickenPrimitiveName(scmname), " ", clos_code, ")))\n", NIL);
 794       } else {
 795         /* Simply re-export the procedure */
 796         if (GetFlag(n, "feature:immutable") && GetFlag(n, "feature:constasvar")) {
 797           Printv(clos_methods, "(define ", clos_name, " (", chickenPrimitiveName(scmname), "))\n", NIL);
 798           Printv(scm_const_defs, "(set! ", scmname, " (", scmname, "))\n", NIL);
 799         } else {
 800           Printv(clos_methods, "(define ", clos_name, " ", chickenPrimitiveName(scmname), ")\n", NIL);
 801         }
 802       }
 803       Delete(clos_name);
 804     }
 805   } else {
 806     Swig_warning(WARN_TYPEMAP_VAR_UNDEF, input_file, line_number, "Unsupported variable type %s (ignored).\n", SwigType_str(t, 0));
 807   }
 808
 809   Delete(wname);
 810   Delete(argnum);
 811   Delete(arg);
 812   Delete(tm2);
 813   Delete(mangle);
 814   DelWrapper(f);
 815   return SWIG_OK;
 816 }
 817
 818 /* ------------------------------------------------------------
 819  * constantWrapper()
 820  * ------------------------------------------------------------ */
 821
 822 int CHICKEN::constantWrapper(Node *n) {
 823
 824   char *name = GetChar(n, "name");
 825   char *iname = GetChar(n, "sym:name");
 826   SwigType *t = Getattr(n, "type");
 827   ParmList *l = Getattr(n, "parms");
 828   String *value = Getattr(n, "value");
 829
 830   String *proc_name = NewString("");
 831   String *wname = NewString("");
 832   String *mangle = NewString("");
 833   String *tm;
 834   String *tm2 = NewString("");
 835   String *source = NewString("");
 836   String *argnum = NewString("0");
 837   String *arg = NewString("argv[0]");
 838   Wrapper *f;
 839   String *overname = 0;
 840   String *scmname;
 841   String *rvalue;
 842   SwigType *nctype;
 843
 844   int num_required;
 845   int num_arguments;
 846
 847   scmname = NewString(iname);
 848   Replaceall(scmname, "_", "-");
 849
 850   Printf(source, "swig_const_%s", iname);
 851   Replaceall(source, "::", "__");
 852
 853   Printf(mangle, "\"%s\"", SwigType_manglestr(t));
 854
 855   if (Getattr(n, "sym:overloaded")) {
 856     overname = Getattr(n, "sym:overname");
 857   } else {
 858     if (!addSymbol(iname, n))
 859       return SWIG_ERROR;
 860   }
 861
 862   Append(wname, Swig_name_wrapper(iname));
 863   if (overname) {
 864     Append(wname, overname);
 865   }
 866
 867   nctype = NewString(t);
 868   if (SwigType_isconst(nctype)) {
 869     Delete(SwigType_pop(nctype));
 870   }
 871
 872   if (SwigType_type(nctype) == T_STRING) {
 873     rvalue = NewStringf("\"%s\"", value);
 874   } else if (SwigType_type(nctype) == T_CHAR) {
 875     rvalue = NewStringf("\'%s\'", value);
 876   } else {
 877     rvalue = NewString(value);
 878   }
 879
 880   /* Special hook for member pointer */
 881   if (SwigType_type(t) == T_MPOINTER) {
 882     Printf(f_header, "static %s = %s;\n", SwigType_str(t, source), rvalue);
 883   } else {
 884     if ((tm = Swig_typemap_lookup("constcode", n, name, 0))) {
 885       Replaceall(tm, "$source", rvalue);
 886       Replaceall(tm, "$target", source);
 887       Replaceall(tm, "$result", source);
 888       Replaceall(tm, "$value", rvalue);
 889       Printf(f_header, "%s\n", tm);
 890     } else {
 891       Swig_warning(WARN_TYPEMAP_CONST_UNDEF, input_file, line_number, "Unsupported constant value.\n");
 892       return SWIG_NOWRAP;
 893     }
 894   }
 895
 896   f = NewWrapper();
 897
 898   /* Attach the standard typemaps */
 899   emit_attach_parmmaps(l, f);
 900   Setattr(n, "wrap:parms", l);
 901
 902   /* Get number of required and total arguments */
 903   num_arguments = emit_num_arguments(l);
 904   num_required = emit_num_required(l);
 905
 906   // evaluation function names
 907
 908   // Check for interrupts
 909   Printv(f->code, "C_trace(\"", scmname, "\");\n", NIL);
 910
 911   if (1 || (SwigType_type(t) != T_USER) || (isPointer(t))) {
 912
 913     Setattr(n, "wrap:name", wname);
 914     Printv(f->def, "static ", "void ", wname, "(C_word, C_word, C_word) C_noret;\n", NIL);
 915
 916     Printv(f->def, "static ", "void ", wname, "(C_word argc, C_word closure, " "C_word continuation) {\n", NIL);
 917
 918     Wrapper_add_local(f, "resultobj", "C_word resultobj");
 919
 920     Printf(f->code, "if (argc!=2) C_bad_argc(argc,2);\n");
 921
 922     // Return the value of the variable
 923     if ((tm = Swig_typemap_lookup("varout", n, name, 0))) {
 924
 925       Replaceall(tm, "$source", source);
 926       Replaceall(tm, "$varname", source);
 927       Replaceall(tm, "$target", "resultobj");
 928       Replaceall(tm, "$result", "resultobj");
 929       /* Printf(f->code, "%s\n", tm); */
 930       emit_action_code(n, f->code, tm);
 931     } else {
 932       Swig_warning(WARN_TYPEMAP_VAROUT_UNDEF, input_file, line_number, "Unable to read variable of type %s\n", SwigType_str(t, 0));
 933     }
 934
 935     Printv(f->code, "{\n",
 936            "C_word func;\n",
 937            "SWIG_Chicken_FindCreateProxy(func, resultobj)\n",
 938            "if (C_swig_is_closurep(func))\n",
 939            "  ((C_proc4)(void *)C_block_item(func, 0))(4,func,continuation,resultobj,C_SCHEME_FALSE);\n",
 940            "else\n", "  C_kontinue(continuation, resultobj);\n", "}\n", NIL);
 941
 942     /* Error handling code */
 943 #ifdef USE_FAIL
 944     Printf(f->code, "fail:\n");
 945     Printf(f->code, "swig_panic (\"failure in " "'%s' SWIG wrapper\");\n", proc_name);
 946 #endif
 947     Printf(f->code, "}\n");
 948
 949     Wrapper_print(f, f_wrappers);
 950
 951     /* Now register the variable with the interpreter.   */
 952     addMethod(scmname, wname);
 953
 954     if (!in_class || member_name) {
 955       String *clos_name;
 956       if (in_class)
 957         clos_name = NewString(member_name);
 958       else
 959         clos_name = chickenNameMapping(scmname, (char *) "");
 960       if (GetFlag(n, "feature:constasvar")) {
 961         Printv(clos_methods, "(define ", clos_name, " (", chickenPrimitiveName(scmname), "))\n", NIL);
 962         Printv(scm_const_defs, "(set! ", scmname, " (", scmname, "))\n", NIL);
 963       } else {
 964         Printv(clos_methods, "(define ", clos_name, " ", chickenPrimitiveName(scmname), ")\n", NIL);
 965       }
 966       Delete(clos_name);
 967     }
 968
 969   } else {
 970     Swig_warning(WARN_TYPEMAP_VAR_UNDEF, input_file, line_number, "Unsupported variable type %s (ignored).\n", SwigType_str(t, 0));
 971   }
 972
 973   Delete(wname);
 974   Delete(nctype);
 975   Delete(proc_name);
 976   Delete(argnum);
 977   Delete(arg);
 978   Delete(tm2);
 979   Delete(mangle);
 980   Delete(source);
 981   Delete(rvalue);
 982   DelWrapper(f);
 983   return SWIG_OK;
 984 }
 985
 986 int CHICKEN::classHandler(Node *n) {
 987   /* Create new strings for building up a wrapper function */
 988   have_constructor = 0;
 989   constructor_dispatch = 0;
 990   constructor_name = 0;
 991
 992   c_class_name = NewString(Getattr(n, "sym:name"));
 993   class_name = NewString("");
 994   short_class_name = NewString("");
 995   Printv(class_name, "<", c_class_name, ">", NIL);
 996   Printv(short_class_name, c_class_name, NIL);
 997   Replaceall(class_name, "_", "-");
 998   Replaceall(short_class_name, "_", "-");
 999
1000   if (!addSymbol(class_name, n))
1001     return SWIG_ERROR;
1002
1003   /* Handle inheritance */
1004   String *base_class = NewString("");
1005   List *baselist = Getattr(n, "bases");
1006   if (baselist && Len(baselist)) {
1007     Iterator base = First(baselist);
1008     while (base.item) {
1009       if (!Getattr(base.item, "feature:ignore"))
1010         Printv(base_class, "<", Getattr(base.item, "sym:name"), "> ", NIL);
1011       base = Next(base);
1012     }
1013   }
1014
1015   Replaceall(base_class, "_", "-");
1016
1017   String *scmmod = NewString(module);
1018   Replaceall(scmmod, "_", "-");
1019
1020   Printv(clos_class_defines, "(define ", class_name, "\n", "  (make <swig-metaclass-", scmmod, "> 'name \"", short_class_name, "\"\n", NIL);
1021   Delete(scmmod);
1022
1023   if (Len(base_class)) {
1024     Printv(clos_class_defines, "    'direct-supers (list ", base_class, ")\n", NIL);
1025   } else {
1026     Printv(clos_class_defines, "    'direct-supers (list <object>)\n", NIL);
1027   }
1028
1029   Printf(clos_class_defines, "    'direct-slots (list 'swig-this\n");
1030
1031   String *mangled_classname = Swig_name_mangle(Getattr(n, "sym:name"));
1032
1033   SwigType *ct = NewStringf("p.%s", Getattr(n, "name"));
1034   swigtype_ptr = SwigType_manglestr(ct);
1035
1036   Printf(f_runtime, "static swig_chicken_clientdata _swig_chicken_clientdata%s = { 0 };\n", mangled_classname);
1037   Printv(f_init, "SWIG_TypeClientData(SWIGTYPE", swigtype_ptr, ", (void *) &_swig_chicken_clientdata", mangled_classname, ");\n", NIL);
1038   SwigType_remember(ct);
1039
1040   /* Emit all of the members */
1041
1042   in_class = 1;
1043   Language::classHandler(n);
1044   in_class = 0;
1045
1046   Printf(clos_class_defines, ")))\n\n");
1047
1048   if (have_constructor) {
1049     Printv(clos_methods, "(define-method (initialize (obj ", class_name, ") initargs)\n", "  (swig-initialize obj initargs ", NIL);
1050     if (constructor_arg_types) {
1051       String *initfunc_name = NewStringf("%s@@SWIG@initmethod", class_name);
1052       String *func_call = buildClosFunctionCall(constructor_arg_types, initfunc_name, chickenPrimitiveName(constructor_name));
1053       Printf(clos_methods, "%s)\n)\n", initfunc_name);
1054       Printf(clos_methods, "(declare (hide %s))\n", initfunc_name);
1055       Printf(clos_methods, "%s\n", func_call);
1056       Delete(func_call);
1057       Delete(initfunc_name);
1058       Delete(constructor_arg_types);
1059       constructor_arg_types = 0;
1060     } else if (constructor_dispatch) {
1061       Printf(clos_methods, "%s)\n)\n", constructor_dispatch);
1062       Delete(constructor_dispatch);
1063       constructor_dispatch = 0;
1064     } else {
1065       Printf(clos_methods, "%s)\n)\n", chickenPrimitiveName(constructor_name));
1066     }
1067     Delete(constructor_name);
1068     constructor_name = 0;
1069   } else {
1070     Printv(clos_methods, "(define-method (initialize (obj ", class_name, ") initargs)\n", "  (swig-initialize obj initargs (lambda x #f)))\n", NIL);
1071   }
1072
1073   /* export class initialization function */
1074   if (clos) {
1075     String *funcname = NewString(mangled_classname);
1076     Printf(funcname, "_swig_chicken_setclosclass");
1077     String *closfuncname = NewString(funcname);
1078     Replaceall(closfuncname, "_", "-");
1079
1080     Printv(f_wrappers, "static void ", funcname, "(C_word,C_word,C_word,C_word) C_noret;\n",
1081            "static void ", funcname, "(C_word argc, C_word closure, C_word continuation, C_word cl) {\n",
1082            "  C_trace(\"", funcname, "\");\n",
1083            "  if (argc!=3) C_bad_argc(argc,3);\n",
1084            "  swig_chicken_clientdata *cdata = (swig_chicken_clientdata *) SWIGTYPE", swigtype_ptr, "->clientdata;\n",
1085            "  cdata->gc_proxy_create = CHICKEN_new_gc_root();\n",
1086            "  CHICKEN_gc_root_set(cdata->gc_proxy_create, cl);\n", "  C_kontinue(continuation, C_SCHEME_UNDEFINED);\n", "}\n", NIL);
1087     addMethod(closfuncname, funcname);
1088
1089     Printv(clos_methods, "(", chickenPrimitiveName(closfuncname), " (lambda (x lst) (if lst ",
1090            "(cons (make ", class_name, " 'swig-this x) lst) ", "(make ", class_name, " 'swig-this x))))\n\n", NIL);
1091     Delete(closfuncname);
1092     Delete(funcname);
1093   }
1094
1095   Delete(mangled_classname);
1096   Delete(swigtype_ptr);
1097   swigtype_ptr = 0;
1098
1099   Delete(class_name);
1100   Delete(short_class_name);
1101   Delete(c_class_name);
1102   class_name = 0;
1103   short_class_name = 0;
1104   c_class_name = 0;
1105
1106   return SWIG_OK;
1107 }
1108
1109 int CHICKEN::memberfunctionHandler(Node *n) {
1110   String *iname = Getattr(n, "sym:name");
1111   String *proc = NewString(iname);
1112   Replaceall(proc, "_", "-");
1113
1114   member_name = chickenNameMapping(proc, short_class_name);
1115   Language::memberfunctionHandler(n);
1116   Delete(member_name);
1117   member_name = NULL;
1118   Delete(proc);
1119
1120   return SWIG_OK;
1121 }
1122
1123 int CHICKEN::staticmemberfunctionHandler(Node *n) {
1124   String *iname = Getattr(n, "sym:name");
1125   String *proc = NewString(iname);
1126   Replaceall(proc, "_", "-");
1127
1128   member_name = NewStringf("%s-%s", short_class_name, proc);
1129   Language::staticmemberfunctionHandler(n);
1130   Delete(member_name);
1131   member_name = NULL;
1132   Delete(proc);
1133
1134   return SWIG_OK;
1135 }
1136
1137 int CHICKEN::membervariableHandler(Node *n) {
1138   String *iname = Getattr(n, "sym:name");
1139   //String *pb = SwigType_typedef_resolve_all(SwigType_base(Getattr(n, "type")));
1140
1141   Language::membervariableHandler(n);
1142
1143   String *proc = NewString(iname);
1144   Replaceall(proc, "_", "-");
1145
1146   //Node *class_node = Swig_symbol_clookup(pb, Getattr(n, "sym:symtab"));
1147   Node *class_node = classLookup(Getattr(n, "type"));
1148
1149   //String *getfunc = NewStringf("%s-%s-get", short_class_name, proc);
1150   //String *setfunc = NewStringf("%s-%s-set", short_class_name, proc);
1151   String *getfunc = Swig_name_get(Swig_name_member(c_class_name, iname));
1152   Replaceall(getfunc, "_", "-");
1153   String *setfunc = Swig_name_set(Swig_name_member(c_class_name, iname));
1154   Replaceall(setfunc, "_", "-");
1155
1156   Printv(clos_class_defines, "        (list '", proc, " ':swig-virtual ':swig-get ", chickenPrimitiveName(getfunc), NIL);
1157
1158   if (!GetFlag(n, "feature:immutable")) {
1159     if (class_node) {
1160       Printv(clos_class_defines, " ':swig-set (lambda (x y) (", chickenPrimitiveName(setfunc), " x (slot-ref y 'swig-this))))\n", NIL);
1161     } else {
1162       Printv(clos_class_defines, " ':swig-set ", chickenPrimitiveName(setfunc), ")\n", NIL);
1163     }
1164   } else {
1165     Printf(clos_class_defines, ")\n");
1166   }
1167
1168   Delete(proc);
1169   Delete(setfunc);
1170   Delete(getfunc);
1171   return SWIG_OK;
1172 }
1173
1174 int CHICKEN::staticmembervariableHandler(Node *n) {
1175   String *iname = Getattr(n, "sym:name");
1176   String *proc = NewString(iname);
1177   Replaceall(proc, "_", "-");
1178
1179   member_name = NewStringf("%s-%s", short_class_name, proc);
1180   Language::staticmembervariableHandler(n);
1181   Delete(member_name);
1182   member_name = NULL;
1183   Delete(proc);
1184
1185   return SWIG_OK;
1186 }
1187
1188 int CHICKEN::constructorHandler(Node *n) {
1189   have_constructor = 1;
1190   has_constructor_args = 0;
1191
1192
1193   exporting_constructor = true;
1194   Language::constructorHandler(n);
1195   exporting_constructor = false;
1196
1197   has_constructor_args = 1;
1198
1199   String *iname = Getattr(n, "sym:name");
1200   constructor_name = Swig_name_construct(iname);
1201   Replaceall(constructor_name, "_", "-");
1202   return SWIG_OK;
1203 }
1204
1205 int CHICKEN::destructorHandler(Node *n) {
1206
1207   if (no_collection)
1208     member_name = NewStringf("delete-%s", short_class_name);
1209
1210   exporting_destructor = true;
1211   Language::destructorHandler(n);
1212   exporting_destructor = false;
1213
1214   if (no_collection) {
1215     Delete(member_name);
1216     member_name = NULL;
1217   }
1218
1219   return SWIG_OK;
1220 }
1221
1222 int CHICKEN::importDirective(Node *n) {
1223   String *modname = Getattr(n, "module");
1224   if (modname && clos_uses) {
1225
1226     // Find the module node for this imported module.  It should be the
1227     // first child but search just in case.
1228     Node *mod = firstChild(n);
1229     while (mod && Strcmp(nodeType(mod), "module") != 0)
1230       mod = nextSibling(mod);
1231
1232     if (mod) {
1233       String *name = Getattr(mod, "name");
1234       if (name) {
1235         Printf(closprefix, "(declare (uses %s))\n", name);
1236       }
1237     }
1238   }
1239
1240   return Language::importDirective(n);
1241 }
1242
1243 String *CHICKEN::buildClosFunctionCall(List *types, const_String_or_char_ptr closname, const_String_or_char_ptr funcname) {
1244   String *method_signature = NewString("");
1245   String *func_args = NewString("");
1246   String *func_call = NewString("");
1247
1248   Iterator arg_type;
1249   int arg_count = 0;
1250   int optional_arguments = 0;
1251
1252   for (arg_type = First(types); arg_type.item; arg_type = Next(arg_type)) {
1253     if (Strcmp(arg_type.item, "^^##optional$$") == 0) {
1254       optional_arguments = 1;
1255     } else {
1256       Printf(method_signature, " (arg%i %s)", arg_count, arg_type.item);
1257       arg_type = Next(arg_type);
1258       if (!arg_type.item)
1259         break;
1260
1261       String *arg = NewStringf("arg%i", arg_count);
1262       String *access_arg = Copy(arg_type.item);
1263
1264       Replaceall(access_arg, "$input", arg);
1265       Printf(func_args, " %s", access_arg);
1266
1267       Delete(arg);
1268       Delete(access_arg);
1269     }
1270     arg_count++;
1271   }
1272
1273   if (optional_arguments) {
1274     Printf(func_call, "(define-method (%s %s . args) (apply %s %s args))", closname, method_signature, funcname, func_args);
1275   } else {
1276     Printf(func_call, "(define-method (%s %s) (%s %s))", closname, method_signature, funcname, func_args);
1277   }
1278
1279   Delete(method_signature);
1280   Delete(func_args);
1281
1282   return func_call;
1283 }
1284
1285 extern "C" {
1286
1287   /* compares based on non-primitive names */
1288   static int compareTypeListsHelper(const DOH *a, const DOH *b, int opt_equal) {
1289     List *la = (List *) a;
1290     List *lb = (List *) b;
1291
1292     Iterator ia = First(la);
1293     Iterator ib = First(lb);
1294
1295     while (ia.item && ib.item) {
1296       int ret = Strcmp(ia.item, ib.item);
1297       if (ret)
1298         return ret;
1299       ia = Next(Next(ia));
1300       ib = Next(Next(ib));
1301     } if (opt_equal && ia.item && Strcmp(ia.item, "^^##optional$$") == 0)
1302       return 0;
1303     if (ia.item)
1304       return -1;
1305     if (opt_equal && ib.item && Strcmp(ib.item, "^^##optional$$") == 0)
1306       return 0;
1307     if (ib.item)
1308       return 1;
1309
1310     return 0;
1311   }
1312
1313   static int compareTypeLists(const DOH *a, const DOH *b) {
1314     return compareTypeListsHelper(a, b, 0);
1315   }
1316 }
1317
1318 void CHICKEN::dispatchFunction(Node *n) {
1319   /* Last node in overloaded chain */
1320
1321   int maxargs;
1322   String *tmp = NewString("");
1323   String *dispatch = Swig_overload_dispatch(n, "%s (2+$numargs,closure," "continuation$commaargs);", &maxargs);
1324
1325   /* Generate a dispatch wrapper for all overloaded functions */
1326
1327   Wrapper *f = NewWrapper();
1328   String *iname = Getattr(n, "sym:name");
1329   String *wname = NewString("");
1330   String *scmname = NewString(iname);
1331   Replaceall(scmname, "_", "-");
1332
1333   Append(wname, Swig_name_wrapper(iname));
1334
1335   Printv(f->def, "static void real_", wname, "(C_word, C_word, C_word, C_word) C_noret;\n", NIL);
1336
1337   Printv(f->def, "static void real_", wname, "(C_word oldargc, C_word closure, C_word continuation, C_word args) {", NIL);
1338
1339   Wrapper_add_local(f, "argc", "int argc");
1340   Printf(tmp, "C_word argv[%d]", maxargs + 1);
1341   Wrapper_add_local(f, "argv", tmp);
1342   Wrapper_add_local(f, "ii", "int ii");
1343   Wrapper_add_local(f, "t", "C_word t = args");
1344   Printf(f->code, "if (!C_swig_is_list (args)) {\n");
1345   Printf(f->code, "  swig_barf (SWIG_BARF1_BAD_ARGUMENT_TYPE, " "\"Argument #1 must be a list of overloaded arguments\");\n");
1346   Printf(f->code, "}\n");
1347   Printf(f->code, "argc = C_unfix (C_i_length (args));\n");
1348   Printf(f->code, "for (ii = 0; (ii < argc) && (ii < %d); ii++, t = C_block_item (t, 1)) {\n", maxargs);
1349   Printf(f->code, "argv[ii] = C_block_item (t, 0);\n");
1350   Printf(f->code, "}\n");
1351
1352   Printv(f->code, dispatch, "\n", NIL);
1353   Printf(f->code, "swig_barf (SWIG_BARF1_BAD_ARGUMENT_TYPE," "\"No matching function for overloaded '%s'\");\n", iname);
1354   Printv(f->code, "}\n", NIL);
1355   Wrapper_print(f, f_wrappers);
1356   addMethod(scmname, wname);
1357
1358   DelWrapper(f);
1359   f = NewWrapper();
1360
1361   /* varargs */
1362   Printv(f->def, "void ", wname, "(C_word, C_word, C_word, ...) C_noret;\n", NIL);
1363   Printv(f->def, "void ", wname, "(C_word c, C_word t0, C_word t1, ...) {", NIL);
1364   Printv(f->code,
1365          "C_word t2;\n",
1366          "va_list v;\n",
1367          "C_word *a, c2 = c;\n",
1368          "C_save_rest (t1, c2, 2);\n", "a = C_alloc((c-2)*3);\n", "t2 = C_restore_rest (a, C_rest_count (0));\n", "real_", wname, " (3, t0, t1, t2);\n", NIL);
1369   Printv(f->code, "}\n", NIL);
1370   Wrapper_print(f, f_wrappers);
1371
1372   /* Now deal with overloaded function when exporting clos */
1373   if (clos) {
1374     List *flist = Getattr(overload_parameter_lists, scmname);
1375     if (flist) {
1376       Delattr(overload_parameter_lists, scmname);
1377
1378       SortList(flist, compareTypeLists);
1379
1380       String *clos_name;
1381       int construct = 0;
1382       if (have_constructor && !has_constructor_args) {
1383         has_constructor_args = 1;
1384         constructor_dispatch = NewStringf("%s@SWIG@new@dispatch", short_class_name);
1385         clos_name = Copy(constructor_dispatch);
1386         construct = 1;
1387         Printf(clos_methods, "(declare (hide %s))\n", clos_name);
1388       } else if (in_class)
1389         clos_name = NewString(member_name);
1390       else
1391         clos_name = chickenNameMapping(scmname, (char *) "");
1392
1393       Iterator f;
1394       List *prev = 0;
1395       int all_primitive = 1;
1396
1397       /* first check for duplicates and an empty call */
1398       String *newlist = NewList();
1399       for (f = First(flist); f.item; f = Next(f)) {
1400         /* check if cur is a duplicate of prev */
1401         if (prev && compareTypeListsHelper(f.item, prev, 1) == 0) {
1402           Delete(f.item);
1403         } else {
1404           Append(newlist, f.item);
1405           prev = f.item;
1406           Iterator j;
1407           for (j = First(f.item); j.item; j = Next(j)) {
1408             if (Strcmp(j.item, "^^##optional$$") != 0 && Strcmp(j.item, "<top>") != 0)
1409               all_primitive = 0;
1410           }
1411         }
1412       }
1413       Delete(flist);
1414       flist = newlist;
1415
1416       if (all_primitive) {
1417         Printf(clos_methods, "(define %s %s)\n", clos_name, chickenPrimitiveName(scmname));
1418       } else {
1419         for (f = First(flist); f.item; f = Next(f)) {
1420           /* now export clos code for argument */
1421           String *func_call = buildClosFunctionCall(f.item, clos_name, chickenPrimitiveName(scmname));
1422           Printf(clos_methods, "%s\n", func_call);
1423           Delete(f.item);
1424           Delete(func_call);
1425         }
1426       }
1427
1428       Delete(clos_name);
1429       Delete(flist);
1430     }
1431   }
1432
1433   DelWrapper(f);
1434   Delete(dispatch);
1435   Delete(tmp);
1436   Delete(wname);
1437 }
1438
1439 int CHICKEN::isPointer(SwigType *t) {
1440   return SwigType_ispointer(SwigType_typedef_resolve_all(t));
1441 }
1442
1443 void CHICKEN::addMethod(String *scheme_name, String *function) {
1444   String *sym = NewString("");
1445   if (clos) {
1446     Append(sym, "primitive:");
1447   }
1448   Append(sym, scheme_name);
1449
1450   /* add symbol to Chicken internal symbol table */
1451   if (hide_primitive) {
1452     Printv(f_init, "{\n",
1453            "  C_word *p0 = a;\n", "  *(a++)=C_CLOSURE_TYPE|1;\n", "  *(a++)=(C_word)", function, ";\n", "  C_mutate(return_vec++, (C_word)p0);\n", "}\n", NIL);
1454   } else {
1455     Printf(f_sym_size, "+C_SIZEOF_INTERNED_SYMBOL(%d)", Len(sym));
1456     Printf(f_init, "sym = C_intern (&a, %d, \"%s\");\n", Len(sym), sym);
1457     Printv(f_init, "C_mutate ((C_word*)sym+1, (*a=C_CLOSURE_TYPE|1, a[1]=(C_word)", function, ", tmp=(C_word)a, a+=2, tmp));\n", NIL);
1458   }
1459
1460   if (hide_primitive) {
1461     Setattr(primitive_names, scheme_name, NewStringf("(vector-ref swig-init-return %i)", num_methods));
1462   } else {
1463     Setattr(primitive_names, scheme_name, Copy(sym));
1464   }
1465
1466   num_methods++;
1467
1468   Delete(sym);
1469 }
1470
1471 String *CHICKEN::chickenPrimitiveName(String *name) {
1472   String *value = Getattr(primitive_names, name);
1473   if (value)
1474     return value;
1475   else {
1476     Swig_error(input_file, line_number, "Internal Error: attempting to reference non-existant primitive name %s\n", name);
1477     return NewString("#f");
1478   }
1479 }
1480
1481 int CHICKEN::validIdentifier(String *s) {
1482   char *c = Char(s);
1483   /* Check whether we have an R5RS identifier. */
1484   /* <identifier> --> <initial> <subsequent>* | <peculiar identifier> */
1485   /* <initial> --> <letter> | <special initial> */
1486   if (!(isalpha(*c) || (*c == '!') || (*c == '$') || (*c == '%')
1487         || (*c == '&') || (*c == '*') || (*c == '/') || (*c == ':')
1488         || (*c == '<') || (*c == '=') || (*c == '>') || (*c == '?')
1489         || (*c == '^') || (*c == '_') || (*c == '~'))) {
1490     /* <peculiar identifier> --> + | - | ... */
1491     if ((strcmp(c, "+") == 0)
1492         || strcmp(c, "-") == 0 || strcmp(c, "...") == 0)
1493       return 1;
1494     else
1495       return 0;
1496   }
1497   /* <subsequent> --> <initial> | <digit> | <special subsequent> */
1498   while (*c) {
1499     if (!(isalnum(*c) || (*c == '!') || (*c == '$') || (*c == '%')
1500           || (*c == '&') || (*c == '*') || (*c == '/') || (*c == ':')
1501           || (*c == '<') || (*c == '=') || (*c == '>') || (*c == '?')
1502           || (*c == '^') || (*c == '_') || (*c == '~') || (*c == '+')
1503           || (*c == '-') || (*c == '.') || (*c == '@')))
1504       return 0;
1505     c++;
1506   }
1507   return 1;
1508 }
1509
1510   /* ------------------------------------------------------------
1511    * closNameMapping()
1512    * Maps the identifier from C++ to the CLOS based on command
1513    * line parameters and such.
1514    * If class_name = "" that means the mapping is for a function or
1515    * variable not attached to any class.
1516    * ------------------------------------------------------------ */
1517 String *CHICKEN::chickenNameMapping(String *name, const_String_or_char_ptr class_name) {
1518   String *n = NewString("");
1519
1520   if (Strcmp(class_name, "") == 0) {
1521     // not part of a class, so no class name to prefix
1522     if (clossymnameprefix) {
1523       Printf(n, "%s%s", clossymnameprefix, name);
1524     } else {
1525       Printf(n, "%s", name);
1526     }
1527   } else {
1528     if (useclassprefix) {
1529       Printf(n, "%s-%s", class_name, name);
1530     } else {
1531       if (clossymnameprefix) {
1532         Printf(n, "%s%s", clossymnameprefix, name);
1533       } else {
1534         Printf(n, "%s", name);
1535       }
1536     }
1537   }
1538   return n;
1539 }
1540
1541 String *CHICKEN::runtimeCode() {
1542   String *s = Swig_include_sys("chickenrun.swg");
1543   if (!s) {
1544     Printf(stderr, "*** Unable to open 'chickenrun.swg'\n");
1545     s = NewString("");
1546   }
1547   return s;
1548 }
1549
1550 String *CHICKEN::defaultExternalRuntimeFilename() {
1551   return NewString("swigchickenrun.h");
1552 }