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 10char 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 16static const char *chicken_usage = (char *) "\ 17\ 18CHICKEN 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 29static char *module = 0; 30static char *chicken_path = (char *) "chicken"; 31static int num_methods = 0; 32 33static File *f_begin = 0; 34static File *f_runtime = 0; 35static File *f_header = 0; 36static File *f_wrappers = 0; 37static File *f_init = 0; 38static String *chickentext = 0; 39static String *closprefix = 0; 40static String *swigtype_ptr = 0; 41 42 43static String *f_sym_size = 0; 44 45/* some options */ 46static int declare_unit = 1; 47static int no_collection = 0; 48static int clos_uses = 1; 49 50/* C++ Support + Clos Classes */ 51static int clos = 0; 52static String *c_class_name = 0; 53static String *class_name = 0; 54static String *short_class_name = 0; 55 56static int in_class = 0; 57static int have_constructor = 0; 58static bool exporting_destructor = false; 59static bool exporting_constructor = false; 60static String *constructor_name = 0; 61static String *member_name = 0; 62 63/* sections of the .scm code */ 64static String *scm_const_defs = 0; 65static String *clos_class_defines = 0; 66static String *clos_methods = 0; 67 68/* Some clos options */ 69static int useclassprefix = 0; 70static String *clossymnameprefix = 0; 71static int hide_primitive = 1; 72static Hash *primitive_names = 0; 73 74/* Used for overloading constructors */ 75static int has_constructor_args = 0; 76static List *constructor_arg_types = 0; 77static String *constructor_dispatch = 0; 78 79static Hash *overload_parameter_lists = 0; 80 81class CHICKEN:public Language { 82public: 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 99protected: 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 117static Language *new_swig_chicken() { 118 return new CHICKEN(); 119} 120 121extern "C" { 122 Language *swig_chicken(void) { 123 return new_swig_chicken(); 124 } 125} 126 127void 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 184int 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 329int 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 667int 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 822int 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 986int 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 1109int 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 1123int 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 1137int 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 1174int 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 1188int 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 1205int 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 1222int 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 1243String *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 1285extern "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 1318void 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 1439int CHICKEN::isPointer(SwigType *t) { 1440 return SwigType_ispointer(SwigType_typedef_resolve_all(t)); 1441} 1442 1443void 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 1471String *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 1481int 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 * ------------------------------------------------------------ */ 1517String *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 1541String *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 1550String *CHICKEN::defaultExternalRuntimeFilename() { 1551 return NewString("swigchickenrun.h"); 1552} 1553