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