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 * ocaml.cxx 6 * 7 * Ocaml language module for SWIG. 8 * ----------------------------------------------------------------------------- */ 9 10char cvsroot_ocaml_cxx[] = "$Id: ocaml.cxx 11246 2009-06-05 17:19:29Z wsfulton $"; 11 12#include "swigmod.h" 13 14#include <ctype.h> 15 16static const char *usage = (char *) 17 ("Ocaml Options (available with -ocaml)\n" 18 "-prefix <name> - Set a prefix <name> to be prepended to all names\n" 19 "-where - Emit library location\n" 20 "-suffix <name> - Change .cxx to something else\n" "-oldvarnames - old intermediary method names for variable wrappers\n" "\n"); 21 22static int classmode = 0; 23static int in_constructor = 0, in_destructor = 0, in_copyconst = 0; 24static int const_enum = 0; 25static int static_member_function = 0; 26static int generate_sizeof = 0; 27static char *prefix = 0; 28static char *ocaml_path = (char *) "ocaml"; 29static bool old_variable_names = false; 30static String *classname = 0; 31static String *module = 0; 32static String *init_func_def = 0; 33static String *f_classtemplate = 0; 34static String *name_qualifier = 0; 35 36static Hash *seen_enums = 0; 37static Hash *seen_enumvalues = 0; 38static Hash *seen_constructors = 0; 39 40static File *f_header = 0; 41static File *f_begin = 0; 42static File *f_runtime = 0; 43static File *f_wrappers = 0; 44static File *f_directors = 0; 45static File *f_directors_h = 0; 46static File *f_init = 0; 47static File *f_mlout = 0; 48static File *f_mliout = 0; 49static File *f_mlbody = 0; 50static File *f_mlibody = 0; 51static File *f_mltail = 0; 52static File *f_mlitail = 0; 53static File *f_enumtypes_type = 0; 54static File *f_enumtypes_value = 0; 55static File *f_class_ctors = 0; 56static File *f_class_ctors_end = 0; 57static File *f_enum_to_int = 0; 58static File *f_int_to_enum = 0; 59 60class OCAML:public Language { 61public: 62 63 OCAML() { 64 director_prot_ctor_code = NewString(""); 65 Printv(director_prot_ctor_code, 66 "if ( $comparison ) { /* subclassed */\n", 67 " $director_new \n", "} else {\n", " failwith(\"accessing abstract class or protected constructor\"); \n", "}\n", NIL); 68 director_multiple_inheritance = 1; 69 director_language = 1; 70 } 71 72 String *Swig_class_name(Node *n) { 73 String *name; 74 name = Copy(Getattr(n, "sym:name")); 75 return name; 76 } 77 78 void PrintIncludeArg() { 79 Printv(stdout, SWIG_LIB, SWIG_FILE_DELIMITER, ocaml_path, "\n", NIL); 80 } 81 82 /* ------------------------------------------------------------ 83 * main() 84 * ------------------------------------------------------------ */ 85 86 virtual void main(int argc, char *argv[]) { 87 int i; 88 89 prefix = 0; 90 91 SWIG_library_directory(ocaml_path); 92 93 // Look for certain command line options 94 for (i = 1; i < argc; i++) { 95 if (argv[i]) { 96 if (strcmp(argv[i], "-help") == 0) { 97 fputs(usage, stdout); 98 SWIG_exit(0); 99 } else if (strcmp(argv[i], "-where") == 0) { 100 PrintIncludeArg(); 101 SWIG_exit(0); 102 } else if (strcmp(argv[i], "-prefix") == 0) { 103 if (argv[i + 1]) { 104 prefix = new char[strlen(argv[i + 1]) + 2]; 105 strcpy(prefix, argv[i + 1]); 106 Swig_mark_arg(i); 107 Swig_mark_arg(i + 1); 108 i++; 109 } else { 110 Swig_arg_error(); 111 } 112 } else if (strcmp(argv[i], "-suffix") == 0) { 113 if (argv[i + 1]) { 114 SWIG_config_cppext(argv[i + 1]); 115 Swig_mark_arg(i); 116 Swig_mark_arg(i + 1); 117 i++; 118 } else 119 Swig_arg_error(); 120 } else if (strcmp(argv[i], "-oldvarnames") == 0) { 121 Swig_mark_arg(i); 122 old_variable_names = true; 123 } 124 } 125 } 126 127 // If a prefix has been specified make sure it ends in a '_' 128 129 if (prefix) { 130 if (prefix[strlen(prefix)] != '_') { 131 prefix[strlen(prefix) + 1] = 0; 132 prefix[strlen(prefix)] = '_'; 133 } 134 } else 135 prefix = (char *) "swig_"; 136 137 // Add a symbol for this module 138 139 Preprocessor_define("SWIGOCAML 1", 0); 140 // Set name of typemaps 141 142 SWIG_typemap_lang("ocaml"); 143 144 // Read in default typemaps */ 145 SWIG_config_file("ocaml.i"); 146 allow_overloading(); 147 148 } 149 150 /* Swig_director_declaration() 151 * 152 * Generate the full director class declaration, complete with base classes. 153 * e.g. "class SwigDirector_myclass : public myclass, public Swig::Director {" 154 * 155 */ 156 157 String *Swig_director_declaration(Node *n) { 158 String *classname = Swig_class_name(n); 159 String *directorname = NewStringf("SwigDirector_%s", classname); 160 String *base = Getattr(n, "classtype"); 161 String *declaration = Swig_class_declaration(n, directorname); 162 Printf(declaration, " : public %s, public Swig::Director {\n", base); 163 Delete(classname); 164 Delete(directorname); 165 return declaration; 166 } 167 168 /* ------------------------------------------------------------ 169 * top() 170 * 171 * Recognize the %module, and capture the module name. 172 * Create the default enum cases. 173 * Set up the named outputs: 174 * 175 * init 176 * ml 177 * mli 178 * wrapper 179 * header 180 * runtime 181 * directors 182 * directors_h 183 * ------------------------------------------------------------ */ 184 185 virtual int top(Node *n) { 186 /* Set comparison with none for ConstructorToFunction */ 187 setSubclassInstanceCheck(NewString("caml_list_nth(args,0) != Val_unit")); 188 189 /* check if directors are enabled for this module. note: this 190 * is a "master" switch, without which no director code will be 191 * emitted. %feature("director") statements are also required 192 * to enable directors for individual classes or methods. 193 * 194 * use %module(directors="1") modulename at the start of the 195 * interface file to enable director generation. 196 */ 197 { 198 Node *module = Getattr(n, "module"); 199 if (module) { 200 Node *options = Getattr(module, "options"); 201 if (options) { 202 if (Getattr(options, "directors")) { 203 allow_directors(); 204 } 205 if (Getattr(options, "dirprot")) { 206 allow_dirprot(); 207 } 208 if (Getattr(options, "sizeof")) { 209 generate_sizeof = 1; 210 } 211 } 212 } 213 } 214 215 /* Initialize all of the output files */ 216 String *outfile = Getattr(n, "outfile"); 217 218 f_begin = NewFile(outfile, "w", SWIG_output_files()); 219 if (!f_begin) { 220 FileErrorDisplay(outfile); 221 SWIG_exit(EXIT_FAILURE); 222 } 223 f_runtime = NewString(""); 224 f_init = NewString(""); 225 f_header = NewString(""); 226 f_wrappers = NewString(""); 227 f_directors = NewString(""); 228 f_directors_h = NewString(""); 229 f_enumtypes_type = NewString(""); 230 f_enumtypes_value = NewString(""); 231 init_func_def = NewString(""); 232 f_mlbody = NewString(""); 233 f_mlibody = NewString(""); 234 f_mltail = NewString(""); 235 f_mlitail = NewString(""); 236 f_class_ctors = NewString(""); 237 f_class_ctors_end = NewString(""); 238 f_enum_to_int = NewString(""); 239 f_int_to_enum = NewString(""); 240 f_classtemplate = NewString(""); 241 242 module = Getattr(n, "name"); 243 244 seen_constructors = NewHash(); 245 seen_enums = NewHash(); 246 seen_enumvalues = NewHash(); 247 248 /* Register file targets with the SWIG file handler */ 249 Swig_register_filebyname("init", init_func_def); 250 Swig_register_filebyname("header", f_header); 251 Swig_register_filebyname("wrapper", f_wrappers); 252 Swig_register_filebyname("begin", f_begin); 253 Swig_register_filebyname("runtime", f_runtime); 254 Swig_register_filebyname("mli", f_mlibody); 255 Swig_register_filebyname("ml", f_mlbody); 256 Swig_register_filebyname("mlitail", f_mlitail); 257 Swig_register_filebyname("mltail", f_mltail); 258 Swig_register_filebyname("director", f_directors); 259 Swig_register_filebyname("director_h", f_directors_h); 260 Swig_register_filebyname("classtemplate", f_classtemplate); 261 Swig_register_filebyname("class_ctors", f_class_ctors); 262 263 if (old_variable_names) { 264 Swig_name_register("set", "%v__set__"); 265 Swig_name_register("get", "%v__get__"); 266 } 267 268 Swig_banner(f_begin); 269 270 Printf(f_runtime, "\n"); 271 Printf(f_runtime, "#define SWIGOCAML\n"); 272 Printf(f_runtime, "#define SWIG_MODULE \"%s\"\n", module); 273 /* Module name */ 274 Printf(f_mlbody, "let module_name = \"%s\"\n", module); 275 Printf(f_mlibody, "val module_name : string\n"); 276 Printf(f_enum_to_int, 277 "let enum_to_int x (v : c_obj) =\n" 278 " match v with\n" 279 " C_enum _y ->\n" 280 " (let y = _y in match (x : c_enum_type) with\n" 281 " `unknown -> " " (match y with\n" " `Int x -> (Swig.C_int x)\n" " | _ -> raise (LabelNotFromThisEnum v))\n"); 282 283 Printf(f_int_to_enum, "let int_to_enum x y =\n" " match (x : c_enum_type) with\n" " `unknown -> C_enum (`Int y)\n"); 284 285 if (directorsEnabled()) { 286 Printf(f_runtime, "#define SWIG_DIRECTORS\n"); 287 } 288 289 Printf(f_runtime, "\n"); 290 291 /* Produce the enum_to_int and int_to_enum functions */ 292 293 Printf(f_enumtypes_type, "open Swig\n" "type c_enum_type = [ \n `unknown\n"); 294 Printf(f_enumtypes_value, "type c_enum_value = [ \n `Int of int\n"); 295 String *mlfile = NewString(""); 296 String *mlifile = NewString(""); 297 298 Printv(mlfile, module, ".ml", NIL); 299 Printv(mlifile, module, ".mli", NIL); 300 301 String *mlfilen = NewStringf("%s%s", SWIG_output_directory(), mlfile); 302 if ((f_mlout = NewFile(mlfilen, "w", SWIG_output_files())) == 0) { 303 FileErrorDisplay(mlfilen); 304 SWIG_exit(EXIT_FAILURE); 305 } 306 String *mlifilen = NewStringf("%s%s", SWIG_output_directory(), mlifile); 307 if ((f_mliout = NewFile(mlifilen, "w", SWIG_output_files())) == 0) { 308 FileErrorDisplay(mlifilen); 309 SWIG_exit(EXIT_FAILURE); 310 } 311 312 Language::top(n); 313 314 Printf(f_enum_to_int, ") | _ -> (C_int (get_int v))\n" "let _ = Callback.register \"%s_enum_to_int\" enum_to_int\n", module); 315 Printf(f_mlibody, "val enum_to_int : c_enum_type -> c_obj -> Swig.c_obj\n"); 316 317 Printf(f_int_to_enum, "let _ = Callback.register \"%s_int_to_enum\" int_to_enum\n", module); 318 Printf(f_mlibody, "val int_to_enum : c_enum_type -> int -> c_obj\n"); 319 Printf(f_init, "#define SWIG_init f_%s_init\n" "%s" "}\n", module, init_func_def); 320 Printf(f_mlbody, "external f_init : unit -> unit = \"f_%s_init\" ;;\n" "let _ = f_init ()\n", module); 321 Printf(f_enumtypes_type, "]\n"); 322 Printf(f_enumtypes_value, "]\n\n" "type c_obj = c_enum_value c_obj_t\n"); 323 324 if (directorsEnabled()) { 325 // Insert director runtime into the f_runtime file (make it occur before %header section) 326 Swig_insert_file("director.swg", f_runtime); 327 } 328 329 SwigType_emit_type_table(f_runtime, f_wrappers); 330 /* Close all of the files */ 331 Dump(f_runtime, f_begin); 332 Dump(f_directors_h, f_header); 333 Dump(f_header, f_begin); 334 Dump(f_directors, f_wrappers); 335 Dump(f_wrappers, f_begin); 336 Wrapper_pretty_print(f_init, f_begin); 337 Delete(f_header); 338 Delete(f_wrappers); 339 Delete(f_init); 340 Close(f_begin); 341 Delete(f_runtime); 342 Delete(f_begin); 343 344 Dump(f_enumtypes_type, f_mlout); 345 Dump(f_enumtypes_value, f_mlout); 346 Dump(f_mlbody, f_mlout); 347 Dump(f_enum_to_int, f_mlout); 348 Dump(f_int_to_enum, f_mlout); 349 Delete(f_int_to_enum); 350 Delete(f_enum_to_int); 351 Dump(f_class_ctors, f_mlout); 352 Dump(f_class_ctors_end, f_mlout); 353 Dump(f_mltail, f_mlout); 354 Close(f_mlout); 355 Delete(f_mlout); 356 357 Dump(f_enumtypes_type, f_mliout); 358 Dump(f_enumtypes_value, f_mliout); 359 Dump(f_mlibody, f_mliout); 360 Dump(f_mlitail, f_mliout); 361 Close(f_mliout); 362 Delete(f_mliout); 363 364 return SWIG_OK; 365 } 366 367 /* Produce an error for the given type */ 368 void throw_unhandled_ocaml_type_error(SwigType *d, const char *types) { 369 Swig_warning(WARN_TYPEMAP_UNDEF, input_file, line_number, "Unable to handle type %s (%s).\n", SwigType_str(d, 0), types); 370 } 371 372 /* Return true iff T is a pointer type */ 373 int 374 is_a_pointer(SwigType *t) { 375 return SwigType_ispointer(SwigType_typedef_resolve_all(t)); 376 } 377 378 /* 379 * Delete one reference from a given type. 380 */ 381 382 void oc_SwigType_del_reference(SwigType *t) { 383 char *c = Char(t); 384 if (strncmp(c, "q(", 2) == 0) { 385 Delete(SwigType_pop(t)); 386 c = Char(t); 387 } 388 if (strncmp(c, "r.", 2)) { 389 printf("Fatal error. SwigType_del_pointer applied to non-pointer.\n"); 390 abort(); 391 } 392 Replace(t, "r.", "", DOH_REPLACE_ANY | DOH_REPLACE_FIRST); 393 } 394 395 void oc_SwigType_del_array(SwigType *t) { 396 char *c = Char(t); 397 if (strncmp(c, "q(", 2) == 0) { 398 Delete(SwigType_pop(t)); 399 c = Char(t); 400 } 401 if (strncmp(c, "a(", 2) == 0) { 402 Delete(SwigType_pop(t)); 403 } 404 } 405 406 /* 407 * Return true iff T is a reference type 408 */ 409 410 int 411 is_a_reference(SwigType *t) { 412 return SwigType_isreference(SwigType_typedef_resolve_all(t)); 413 } 414 415 int 416 is_an_array(SwigType *t) { 417 return SwigType_isarray(SwigType_typedef_resolve_all(t)); 418 } 419 420 /* ------------------------------------------------------------ 421 * functionWrapper() 422 * Create a function declaration and register it with the interpreter. 423 * ------------------------------------------------------------ */ 424 425 virtual int functionWrapper(Node *n) { 426 char *iname = GetChar(n, "sym:name"); 427 SwigType *d = Getattr(n, "type"); 428 String *return_type_normalized = normalizeTemplatedClassName(d); 429 ParmList *l = Getattr(n, "parms"); 430 int director_method = 0; 431 Parm *p; 432 433 Wrapper *f = NewWrapper(); 434 String *proc_name = NewString(""); 435 String *source = NewString(""); 436 String *target = NewString(""); 437 String *arg = NewString(""); 438 String *cleanup = NewString(""); 439 String *outarg = NewString(""); 440 String *build = NewString(""); 441 String *tm; 442 int argout_set = 0; 443 int i = 0; 444 int numargs; 445 int numreq; 446 int newobj = GetFlag(n, "feature:new"); 447 String *nodeType = Getattr(n, "nodeType"); 448 int destructor = (!Cmp(nodeType, "destructor")); 449 String *overname = 0; 450 bool isOverloaded = Getattr(n, "sym:overloaded") ? true : false; 451 452 // Make a wrapper name for this 453 String *wname = Swig_name_wrapper(iname); 454 if (isOverloaded) { 455 overname = Getattr(n, "sym:overname"); 456 } else { 457 if (!addSymbol(iname, n)) { 458 DelWrapper(f); 459 return SWIG_ERROR; 460 } 461 } 462 if (overname) { 463 Append(wname, overname); 464 } 465 /* Do this to disambiguate functions emitted from different modules */ 466 Append(wname, module); 467 468 Setattr(n, "wrap:name", wname); 469 470 // Build the name for Scheme. 471 Printv(proc_name, "_", iname, NIL); 472 String *mangled_name = mangleNameForCaml(proc_name); 473 474 if (classmode && in_constructor) { // Emit constructor for object 475 String *mangled_name_nounder = NewString((char *) (Char(mangled_name)) + 1); 476 Printf(f_class_ctors_end, "let %s clst = _%s clst\n", mangled_name_nounder, mangled_name_nounder); 477 Printf(f_mlibody, "val %s : c_obj -> c_obj\n", mangled_name_nounder); 478 Delete(mangled_name_nounder); 479 } else if (classmode && in_destructor) { 480 Printf(f_class_ctors, " \"~\", %s ;\n", mangled_name); 481 } else if (classmode && !in_constructor && !in_destructor && !static_member_function) { 482 String *opname = Copy(Getattr(n, "memberfunctionHandler:sym:name")); 483 484 Replaceall(opname, "operator ", ""); 485 486 if (strstr(Char(mangled_name), "__get__")) { 487 String *set_name = Copy(mangled_name); 488 if (!GetFlag(n, "feature:immutable")) { 489 Replaceall(set_name, "__get__", "__set__"); 490 Printf(f_class_ctors, " \"%s\", (fun args -> " "if args = (C_list [ raw_ptr ]) then %s args else %s args) ;\n", opname, mangled_name, set_name); 491 Delete(set_name); 492 } else { 493 Printf(f_class_ctors, " \"%s\", (fun args -> " "if args = (C_list [ raw_ptr ]) then %s args else C_void) ;\n", opname, mangled_name); 494 } 495 } else if (strstr(Char(mangled_name), "__set__")) { 496 ; /* Nothing ... handled by the case above */ 497 } else { 498 Printf(f_class_ctors, " \"%s\", %s ;\n", opname, mangled_name); 499 } 500 501 Delete(opname); 502 } 503 504 if (classmode && in_constructor) { 505 Setattr(seen_constructors, mangled_name, "true"); 506 } 507 // writing the function wrapper function 508 Printv(f->def, "SWIGEXT CAML_VALUE ", wname, " (", NIL); 509 Printv(f->def, "CAML_VALUE args", NIL); 510 Printv(f->def, ")\n{", NIL); 511 512 /* Define the scheme name in C. This define is used by several 513 macros. */ 514 //Printv(f->def, "#define FUNC_NAME \"", mangled_name, "\"", NIL); 515 516 // adds local variables 517 Wrapper_add_local(f, "args", "CAMLparam1(args)"); 518 Wrapper_add_local(f, "ret", "SWIG_CAMLlocal2(swig_result,rv)"); 519 Wrapper_add_local(f, "_v", "int _v = 0"); 520 if (isOverloaded) { 521 Wrapper_add_local(f, "i", "int i"); 522 Wrapper_add_local(f, "argc", "int argc = caml_list_length(args)"); 523 Wrapper_add_local(f, "argv", "CAML_VALUE *argv"); 524 525 Printv(f->code, 526 "argv = (CAML_VALUE *)malloc( argc * sizeof( CAML_VALUE ) );\n" 527 "for( i = 0; i < argc; i++ ) {\n" " argv[i] = caml_list_nth(args,i);\n" "}\n", NIL); 528 } 529 d = SwigType_typedef_qualified(d); 530 emit_parameter_variables(l, f); 531 532 /* Attach the standard typemaps */ 533 emit_attach_parmmaps(l, f); 534 Setattr(n, "wrap:parms", l); 535 536 numargs = emit_num_arguments(l); 537 numreq = emit_num_required(l); 538 539 Printf(f->code, "swig_result = Val_unit;\n"); 540 541 // Now write code to extract the parameters (this is super ugly) 542 543 for (i = 0, p = l; i < numargs; i++) { 544 /* Skip ignored arguments */ 545 while (checkAttribute(p, "tmap:in:numinputs", "0")) { 546 p = Getattr(p, "tmap:in:next"); 547 } 548 549 SwigType *pt = Getattr(p, "type"); 550 String *ln = Getattr(p, "lname"); 551 pt = SwigType_typedef_qualified(pt); 552 553 // Produce names of source and target 554 Clear(source); 555 Clear(target); 556 Clear(arg); 557 Printf(source, "caml_list_nth(args,%d)", i); 558 Printf(target, "%s", ln); 559 Printv(arg, Getattr(p, "name"), NIL); 560 561 if (i >= numreq) { 562 Printf(f->code, "if (caml_list_length(args) > %d) {\n", i); 563 } 564 // Handle parameter types. 565 if ((tm = Getattr(p, "tmap:in"))) { 566 Replaceall(tm, "$source", source); 567 Replaceall(tm, "$target", target); 568 Replaceall(tm, "$input", source); 569 Setattr(p, "emit:input", source); 570 Printv(f->code, tm, "\n", NIL); 571 p = Getattr(p, "tmap:in:next"); 572 } else { 573 // no typemap found 574 // check if typedef and resolve 575 throw_unhandled_ocaml_type_error(pt, "in"); 576 p = nextSibling(p); 577 } 578 if (i >= numreq) { 579 Printf(f->code, "}\n"); 580 } 581 } 582 583 /* Insert constraint checking code */ 584 for (p = l; p;) { 585 if ((tm = Getattr(p, "tmap:check"))) { 586 Replaceall(tm, "$target", Getattr(p, "lname")); 587 Printv(f->code, tm, "\n", NIL); 588 p = Getattr(p, "tmap:check:next"); 589 } else { 590 p = nextSibling(p); 591 } 592 } 593 594 // Pass output arguments back to the caller. 595 596 for (p = l; p;) { 597 if ((tm = Getattr(p, "tmap:argout"))) { 598 Replaceall(tm, "$source", Getattr(p, "emit:input")); /* Deprecated */ 599 Replaceall(tm, "$target", Getattr(p, "lname")); /* Deprecated */ 600 Replaceall(tm, "$arg", Getattr(p, "emit:input")); 601 Replaceall(tm, "$input", Getattr(p, "emit:input")); 602 Replaceall(tm, "$ntype", normalizeTemplatedClassName(Getattr(p, "type"))); 603 Printv(outarg, tm, "\n", NIL); 604 p = Getattr(p, "tmap:argout:next"); 605 argout_set = 1; 606 } else { 607 p = nextSibling(p); 608 } 609 } 610 611 // Free up any memory allocated for the arguments. 612 613 /* Insert cleanup code */ 614 for (p = l; p;) { 615 if ((tm = Getattr(p, "tmap:freearg"))) { 616 Replaceall(tm, "$target", Getattr(p, "lname")); 617 Printv(cleanup, tm, "\n", NIL); 618 p = Getattr(p, "tmap:freearg:next"); 619 } else { 620 p = nextSibling(p); 621 } 622 } 623 624 /* if the object is a director, and the method call originated from its 625 * underlying python object, resolve the call by going up the c++ 626 * inheritance chain. otherwise try to resolve the method in python. 627 * without this check an infinite loop is set up between the director and 628 * shadow class method calls. 629 */ 630 631 // NOTE: this code should only be inserted if this class is the 632 // base class of a director class. however, in general we haven't 633 // yet analyzed all classes derived from this one to see if they are 634 // directors. furthermore, this class may be used as the base of 635 // a director class defined in a completely different module at a 636 // later time, so this test must be included whether or not directorbase 637 // is true. we do skip this code if directors have not been enabled 638 // at the command line to preserve source-level compatibility with 639 // non-polymorphic swig. also, if this wrapper is for a smart-pointer 640 // method, there is no need to perform the test since the calling object 641 // (the smart-pointer) and the director object (the "pointee") are 642 // distinct. 643 644 director_method = is_member_director(n) && !is_smart_pointer() && !destructor; 645 if (director_method) { 646 Wrapper_add_local(f, "director", "Swig::Director *director = 0"); 647 Printf(f->code, "director = dynamic_cast<Swig::Director *>(arg1);\n"); 648 Wrapper_add_local(f, "upcall", "bool upcall = false"); 649 Append(f->code, "upcall = (director);\n"); 650 } 651 652 // Now write code to make the function call 653 Swig_director_emit_dynamic_cast(n, f); 654 String *actioncode = emit_action(n); 655 656 if ((tm = Swig_typemap_lookup_out("out", n, "result", f, actioncode))) { 657 Replaceall(tm, "$source", "swig_result"); 658 Replaceall(tm, "$target", "rv"); 659 Replaceall(tm, "$result", "rv"); 660 Replaceall(tm, "$ntype", return_type_normalized); 661 Printv(f->code, tm, "\n", NIL); 662 } else { 663 throw_unhandled_ocaml_type_error(d, "out"); 664 } 665 emit_return_variable(n, d, f); 666 667 // Dump the argument output code 668 Printv(f->code, Char(outarg), NIL); 669 670 // Dump the argument cleanup code 671 Printv(f->code, Char(cleanup), NIL); 672 673 // Look for any remaining cleanup 674 675 if (GetFlag(n, "feature:new")) { 676 if ((tm = Swig_typemap_lookup("newfree", n, "result", 0))) { 677 Replaceall(tm, "$source", "swig_result"); 678 Printv(f->code, tm, "\n", NIL); 679 } 680 } 681 // Free any memory allocated by the function being wrapped.. 682 683 if ((tm = Swig_typemap_lookup("swig_result", n, "result", 0))) { 684 Replaceall(tm, "$source", "result"); 685 Printv(f->code, tm, "\n", NIL); 686 } 687 // Wrap things up (in a manner of speaking) 688 689 Printv(f->code, tab4, "swig_result = caml_list_append(swig_result,rv);\n", NIL); 690 if (isOverloaded) 691 Printv(f->code, "free(argv);\n", NIL); 692 Printv(f->code, tab4, "CAMLreturn(swig_result);\n", NIL); 693 Printv(f->code, "}\n", NIL); 694 695 /* Substitute the function name */ 696 Replaceall(f->code, "$symname", iname); 697 698 Wrapper_print(f, f_wrappers); 699 700 if (isOverloaded) { 701 if (!Getattr(n, "sym:nextSibling")) { 702 int maxargs; 703 Wrapper *df = NewWrapper(); 704 String *dispatch = Swig_overload_dispatch(n, 705 "free(argv);\n" "CAMLreturn(%s(args));\n", 706 &maxargs); 707 708 Wrapper_add_local(df, "_v", "int _v = 0"); 709 Wrapper_add_local(df, "argv", "CAML_VALUE *argv"); 710 711 /* Undifferentiate name .. this is the dispatch function */ 712 wname = Swig_name_wrapper(iname); 713 /* Do this to disambiguate functions emitted from different 714 * modules */ 715 Append(wname, module); 716 717 Printv(df->def, 718 "SWIGEXT CAML_VALUE ", wname, "(CAML_VALUE args) {\n" " CAMLparam1(args);\n" " int i;\n" " int argc = caml_list_length(args);\n", NIL); 719 Printv(df->code, 720 "argv = (CAML_VALUE *)malloc( argc * sizeof( CAML_VALUE ) );\n" 721 "for( i = 0; i < argc; i++ ) {\n" " argv[i] = caml_list_nth(args,i);\n" "}\n", NIL); 722 Printv(df->code, dispatch, "\n", NIL); 723 Printf(df->code, "failwith(\"No matching function for overloaded '%s'\");\n", iname); 724 Printv(df->code, "}\n", NIL); 725 Wrapper_print(df, f_wrappers); 726 727 DelWrapper(df); 728 Delete(dispatch); 729 } 730 } 731 732 Printf(f_mlbody, 733 "external %s_f : c_obj list -> c_obj list = \"%s\" ;;\n" 734 "let %s arg = match %s_f (fnhelper arg) with\n" 735 " [] -> C_void\n" 736 "| [x] -> (if %s then Gc.finalise \n" 737 " (fun x -> ignore ((invoke x) \"~\" C_void)) x) ; x\n" 738 "| lst -> C_list lst ;;\n", mangled_name, wname, mangled_name, mangled_name, newobj ? "true" : "false"); 739 740 if (!classmode || in_constructor || in_destructor || static_member_function) 741 Printf(f_mlibody, "val %s : c_obj -> c_obj\n", mangled_name); 742 743 Delete(proc_name); 744 Delete(source); 745 Delete(target); 746 Delete(arg); 747 Delete(outarg); 748 Delete(cleanup); 749 Delete(build); 750 DelWrapper(f); 751 return SWIG_OK; 752 } 753 754 /* ------------------------------------------------------------ 755 * variableWrapper() 756 * 757 * Create a link to a C variable. 758 * This creates a single function _wrap_swig_var_varname(). 759 * This function takes a single optional argument. If supplied, it means 760 * we are setting this variable to some value. If omitted, it means we are 761 * simply evaluating this variable. In the set case we return C_void. 762 * 763 * symname is the name of the variable with respect to C. This 764 * may need to differ from the original name in the case of enums. 765 * enumvname is the name of the variable with respect to ocaml. This 766 * will vary if the variable has been renamed. 767 * ------------------------------------------------------------ */ 768 769 virtual int variableWrapper(Node *n) { 770 char *name = GetChar(n, "feature:symname"); 771 String *iname = Getattr(n, "feature:enumvname"); 772 String *mname = mangleNameForCaml(iname); 773 SwigType *t = Getattr(n, "type"); 774 775 String *proc_name = NewString(""); 776 String *tm; 777 String *tm2 = NewString("");; 778 String *argnum = NewString("0"); 779 String *arg = NewString("SWIG_Field(args,0)"); 780 Wrapper *f; 781 782 if (!name) { 783 name = GetChar(n, "name"); 784 } 785 786 if (!iname) { 787 iname = Getattr(n, "sym:name"); 788 mname = mangleNameForCaml(NewString(iname)); 789 } 790 791 if (!iname || !addSymbol(iname, n)) 792 return SWIG_ERROR; 793 794 f = NewWrapper(); 795 796 // evaluation function names 797 String *var_name = Swig_name_wrapper(iname); 798 799 // Build the name for scheme. 800 Printv(proc_name, iname, NIL); 801 Setattr(n, "wrap:name", proc_name); 802 803 Printf(f->def, "SWIGEXT CAML_VALUE %s(CAML_VALUE args) {\n", var_name); 804 // Printv(f->def, "#define FUNC_NAME \"", proc_name, "\"", NIL); 805 806 Wrapper_add_local(f, "swig_result", "CAML_VALUE swig_result"); 807 808 if (!GetFlag(n, "feature:immutable")) { 809 /* Check for a setting of the variable value */ 810 Printf(f->code, "if (args != Val_int(0)) {\n"); 811 if ((tm = Swig_typemap_lookup("varin", n, name, 0))) { 812 Replaceall(tm, "$source", "args"); 813 Replaceall(tm, "$target", name); 814 Replaceall(tm, "$input", "args"); 815 /* Printv(f->code, tm, "\n",NIL); */ 816 emit_action_code(n, f->code, tm); 817 } else if ((tm = Swig_typemap_lookup("in", n, name, 0))) { 818 Replaceall(tm, "$source", "args"); 819 Replaceall(tm, "$target", name); 820 Replaceall(tm, "$input", "args"); 821 Printv(f->code, tm, "\n", NIL); 822 } else { 823 throw_unhandled_ocaml_type_error(t, "varin/in"); 824 } 825 Printf(f->code, "}\n"); 826 } 827 // Now return the value of the variable (regardless 828 // of evaluating or setting) 829 830 if ((tm = Swig_typemap_lookup("varout", n, name, 0))) { 831 Replaceall(tm, "$source", name); 832 Replaceall(tm, "$target", "swig_result"); 833 Replaceall(tm, "$result", "swig_result"); 834 emit_action_code(n, f->code, tm); 835 } else if ((tm = Swig_typemap_lookup("out", n, name, 0))) { 836 Replaceall(tm, "$source", name); 837 Replaceall(tm, "$target", "swig_result"); 838 Replaceall(tm, "$result", "swig_result"); 839 Printf(f->code, "%s\n", tm); 840 } else { 841 throw_unhandled_ocaml_type_error(t, "varout/out"); 842 } 843 844 Printf(f->code, "\nreturn swig_result;\n"); 845 Printf(f->code, "}\n"); 846 847 Wrapper_print(f, f_wrappers); 848 849 // Now add symbol to the Ocaml interpreter 850 851 if (GetFlag(n, "feature:immutable")) { 852 Printf(f_mlbody, "external _%s : c_obj -> Swig.c_obj = \"%s\" \n", mname, var_name); 853 Printf(f_mlibody, "val _%s : c_obj -> Swig.c_obj\n", iname); 854 if (const_enum) { 855 Printf(f_enum_to_int, " | `%s -> _%s C_void\n", mname, mname); 856 Printf(f_int_to_enum, " if y = (get_int (_%s C_void)) then `%s else\n", mname, mname); 857 } 858 } else { 859 Printf(f_mlbody, "external _%s : c_obj -> c_obj = \"%s\"\n", mname, var_name); 860 Printf(f_mlibody, "external _%s : c_obj -> c_obj = \"%s\"\n", mname, var_name); 861 } 862 863 Delete(var_name); 864 Delete(proc_name); 865 Delete(argnum); 866 Delete(arg); 867 Delete(tm2); 868 DelWrapper(f); 869 return SWIG_OK; 870 } 871 872 /* ------------------------------------------------------------ 873 * staticmemberfunctionHandler -- 874 * Overridden to set static_member_function 875 * ------------------------------------------------------------ */ 876 877 virtual int staticmemberfunctionHandler(Node *n) { 878 int rv; 879 static_member_function = 1; 880 rv = Language::staticmemberfunctionHandler(n); 881 static_member_function = 0; 882 return SWIG_OK; 883 } 884 885 /* ------------------------------------------------------------ 886 * constantWrapper() 887 * 888 * The one trick here is that we have to make sure we rename the 889 * constant to something useful that doesn't collide with the 890 * original if any exists. 891 * ------------------------------------------------------------ */ 892 893 virtual int constantWrapper(Node *n) { 894 String *name = Getattr(n, "feature:symname"); 895 SwigType *type = Getattr(n, "type"); 896 String *value = Getattr(n, "value"); 897 String *qvalue = Getattr(n, "qualified:value"); 898 String *rvalue = NewString(""); 899 String *temp = 0; 900 901 if (qvalue) 902 value = qvalue; 903 904 if (!name) { 905 name = mangleNameForCaml(Getattr(n, "name")); 906 Insert(name, 0, "_swig_wrap_"); 907 Setattr(n, "feature:symname", name); 908 } 909 // See if there's a typemap 910 911 Printv(rvalue, value, NIL); 912 if ((SwigType_type(type) == T_CHAR) && (is_a_pointer(type) == 1)) { 913 temp = Copy(rvalue); 914 Clear(rvalue); 915 Printv(rvalue, "\"", temp, "\"", NIL); 916 Delete(temp); 917 } 918 if ((SwigType_type(type) == T_CHAR) && (is_a_pointer(type) == 0)) { 919 temp = Copy(rvalue); 920 Clear(rvalue); 921 Printv(rvalue, "'", temp, "'", NIL); 922 Delete(temp); 923 } 924 // Create variable and assign it a value 925 926 Printf(f_header, "static %s = ", SwigType_lstr(type, name)); 927 if ((SwigType_type(type) == T_STRING)) { 928 Printf(f_header, "\"%s\";\n", value); 929 } else if (SwigType_type(type) == T_CHAR) { 930 Printf(f_header, "\'%s\';\n", value); 931 } else { 932 Printf(f_header, "%s;\n", value); 933 } 934 935 SetFlag(n, "feature:immutable"); 936 variableWrapper(n); 937 return SWIG_OK; 938 } 939 940 int constructorHandler(Node *n) { 941 int ret; 942 943 in_constructor = 1; 944 ret = Language::constructorHandler(n); 945 in_constructor = 0; 946 947 return ret; 948 } 949 950 /* destructorHandler: 951 * Turn on destructor flag to inform decisions in functionWrapper 952 */ 953 954 int destructorHandler(Node *n) { 955 int ret; 956 957 in_destructor = 1; 958 ret = Language::destructorHandler(n); 959 in_destructor = 0; 960 961 return ret; 962 } 963 964 /* copyconstructorHandler: 965 * Turn on constructor and copyconstructor flags for functionWrapper 966 */ 967 968 int copyconstructorHandler(Node *n) { 969 int ret; 970 971 in_copyconst = 1; 972 in_constructor = 1; 973 ret = Language::copyconstructorHandler(n); 974 in_constructor = 0; 975 in_copyconst = 0; 976 977 return ret; 978 } 979 980 /** 981 * A simple, somewhat general purpose function for writing to multiple 982 * streams from a source template. This allows the user to define the 983 * class definition in ways different from the one I have here if they 984 * want to. It will also make the class definition system easier to 985 * fiddle with when I want to change methods, etc. 986 */ 987 988 void Multiwrite(String *s) { 989 char *find_marker = strstr(Char(s), "(*Stream:"); 990 while (find_marker) { 991 char *next = strstr(find_marker, "*)"); 992 find_marker += strlen("(*Stream:"); 993 994 if (next) { 995 int num_chars = next - find_marker; 996 String *stream_name = NewString(find_marker); 997 Delslice(stream_name, num_chars, Len(stream_name)); 998 File *fout = Swig_filebyname(stream_name); 999 if (fout) { 1000 next += strlen("*)"); 1001 char *following = strstr(next, "(*Stream:"); 1002 find_marker = following; 1003 if (!following) 1004 following = next + strlen(next); 1005 String *chunk = NewString(next); 1006 Delslice(chunk, following - next, Len(chunk)); 1007 Printv(fout, chunk, NIL); 1008 } 1009 } 1010 } 1011 } 1012 1013 bool isSimpleType(String *name) { 1014 char *ch = Char(name); 1015 1016 return !(strchr(ch, '(') || strchr(ch, '<') || strchr(ch, ')') || strchr(ch, '>')); 1017 } 1018 1019 /* We accept all chars in identifiers because we use strings to index 1020 * them. */ 1021 int validIdentifier(String *name) { 1022 return Len(name) > 0 ? 1 : 0; 1023 } 1024 1025 /* classHandler 1026 * 1027 * Create a "class" definition for ocaml. I thought quite a bit about 1028 * how I should do this part of it, and arrived here, using a function 1029 * invocation to select a method, and dispatch. This can obviously be 1030 * done better, but I can't see how, given that I want to support 1031 * overloaded methods, out parameters, and operators. 1032 * 1033 * I needed a system that would do this: 1034 * 1035 * a Be able to call these methods: 1036 * int foo( int x ); 1037 * float foo( int x, int &out ); 1038 * 1039 * b Be typeable, even in the presence of mutually dependent classes. 1040 * 1041 * c Support some form of operator invocation. 1042 * 1043 * (c) I chose strings for the method names so that "+=" would be a 1044 * valid method name, and the somewhat natural << (invoke x) "+=" y >> 1045 * would work. 1046 * 1047 * (a) (b) Since the c_obj type exists, it's easy to return C_int in one 1048 * case and C_list [ C_float ; C_int ] in the other. This makes tricky 1049 * problems with out parameters disappear; they're simply appended to the 1050 * return list. 1051 * 1052 * (b) Since every item that comes from C++ is the same type, there is no 1053 * problem with the following: 1054 * 1055 * class Foo; 1056 * class Bar { Foo *toFoo(); } 1057 * class Foo { Bar *toBar(); } 1058 * 1059 * Since the Objective caml types of Foo and Bar are the same. Now that 1060 * I correctly incorporate SWIG's typechecking, this isn't a big deal. 1061 * 1062 * The class is in the form of a function returning a c_obj. The c_obj 1063 * is a C_obj containing a function which invokes a method on the 1064 * underlying object given its type. 1065 * 1066 * The name emitted here is normalized before being sent to 1067 * Callback.register, because we need this string to look up properly 1068 * when the typemap passes the descriptor string. I've been considering 1069 * some, possibly more forgiving method that would do some transformations 1070 * on the $descriptor in order to find a potential match. This is for 1071 * later. 1072 * 1073 * Important things to note: 1074 * 1075 * We rely on exception handling (BadMethodName) in order to call an 1076 * ancestor. This can be improved. 1077 * 1078 * The method used to get :classof could be improved to look at the type 1079 * info that the base pointer contains. It's really an error to have a 1080 * SWIG-generated object that does not contain type info, since the 1081 * existence of the object means that SWIG knows the type. 1082 * 1083 * :parents could use :classof to tell what class it is and make a better 1084 * decision. This could be nice, (i.e. provide a run-time graph of C++ 1085 * classes represented);. 1086 * 1087 * I can't think of a more elegant way of converting a C_obj fun to a 1088 * pointer than "operator &"... 1089 * 1090 * Added a 'sizeof' that will allow you to do the expected thing. 1091 * This should help users to fill buffer structs and the like (as is 1092 * typical in windows-styled code). It's only enabled if you give 1093 * %feature(sizeof) and then, only for simple types. 1094 * 1095 * Overall, carrying the list of methods and base classes has worked well. 1096 * It allows me to give the Ocaml user introspection over their objects. 1097 */ 1098 1099 int classHandler(Node *n) { 1100 String *name = Getattr(n, "name"); 1101 1102 if (!name) 1103 return SWIG_OK; 1104 1105 String *mangled_sym_name = mangleNameForCaml(name); 1106 String *this_class_def = NewString(f_classtemplate); 1107 String *name_normalized = normalizeTemplatedClassName(name); 1108 String *old_class_ctors = f_class_ctors; 1109 String *base_classes = NewString(""); 1110 f_class_ctors = NewString(""); 1111 bool sizeof_feature = generate_sizeof && isSimpleType(name); 1112 1113 1114 classname = mangled_sym_name; 1115 classmode = true; 1116 int rv = Language::classHandler(n); 1117 classmode = false; 1118 1119 if (sizeof_feature) { 1120 Printf(f_wrappers, 1121 "SWIGEXT CAML_VALUE _wrap_%s_sizeof( CAML_VALUE args ) {\n" 1122 " CAMLparam1(args);\n" " CAMLreturn(Val_int(sizeof(%s)));\n" "}\n", mangled_sym_name, name_normalized); 1123 1124 Printf(f_mlbody, "external __%s_sizeof : unit -> int = " "\"_wrap_%s_sizeof\"\n", classname, mangled_sym_name); 1125 } 1126 1127 1128 /* Insert sizeof operator for concrete classes */ 1129 if (sizeof_feature) { 1130 Printv(f_class_ctors, "\"sizeof\" , (fun args -> C_int (__", classname, "_sizeof ())) ;\n", NIL); 1131 } 1132 /* Handle up-casts in a nice way */ 1133 List *baselist = Getattr(n, "bases"); 1134 if (baselist && Len(baselist)) { 1135 Iterator b; 1136 b = First(baselist); 1137 while (b.item) { 1138 String *bname = Getattr(b.item, "name"); 1139 if (bname) { 1140 String *base_create = NewString(""); 1141 Printv(base_create, "(create_class \"", bname, "\")", NIL); 1142 Printv(f_class_ctors, " \"::", bname, "\", (fun args -> ", base_create, " args) ;\n", NIL); 1143 Printv(base_classes, base_create, " ;\n", NIL); 1144 } 1145 b = Next(b); 1146 } 1147 } 1148 1149 Replaceall(this_class_def, "$classname", classname); 1150 Replaceall(this_class_def, "$normalized", name_normalized); 1151 Replaceall(this_class_def, "$realname", name); 1152 Replaceall(this_class_def, "$baselist", base_classes); 1153 Replaceall(this_class_def, "$classbody", f_class_ctors); 1154 1155 Delete(f_class_ctors); 1156 f_class_ctors = old_class_ctors; 1157 1158 // Actually write out the class definition 1159 1160 Multiwrite(this_class_def); 1161 1162 Setattr(n, "ocaml:ctor", classname); 1163 1164 return rv; 1165 } 1166 1167 String *normalizeTemplatedClassName(String *name) { 1168 String *name_normalized = SwigType_typedef_resolve_all(name); 1169 bool took_action; 1170 1171 do { 1172 took_action = false; 1173 1174 if (is_a_pointer(name_normalized)) { 1175 SwigType_del_pointer(name_normalized); 1176 took_action = true; 1177 } 1178 1179 if (is_a_reference(name_normalized)) { 1180 oc_SwigType_del_reference(name_normalized); 1181 took_action = true; 1182 } 1183 1184 if (is_an_array(name_normalized)) { 1185 oc_SwigType_del_array(name_normalized); 1186 took_action = true; 1187 } 1188 } while (took_action); 1189 1190 return SwigType_str(name_normalized, 0); 1191 } 1192 1193 /* 1194 * Produce the symbol name that ocaml will use when referring to the 1195 * target item. I wonder if there's a better way to do this: 1196 * 1197 * I shudder to think about doing it with a hash lookup, but that would 1198 * make a couple of things easier: 1199 */ 1200 1201 String *mangleNameForCaml(String *s) { 1202 String *out = Copy(s); 1203 Replaceall(out, " ", "_xx"); 1204 Replaceall(out, "::", "_xx"); 1205 Replaceall(out, ",", "_x"); 1206 Replaceall(out, "+", "_xx_plus"); 1207 Replaceall(out, "-", "_xx_minus"); 1208 Replaceall(out, "<", "_xx_ldbrace"); 1209 Replaceall(out, ">", "_xx_rdbrace"); 1210 Replaceall(out, "!", "_xx_not"); 1211 Replaceall(out, "%", "_xx_mod"); 1212 Replaceall(out, "^", "_xx_xor"); 1213 Replaceall(out, "*", "_xx_star"); 1214 Replaceall(out, "&", "_xx_amp"); 1215 Replaceall(out, "|", "_xx_or"); 1216 Replaceall(out, "(", "_xx_lparen"); 1217 Replaceall(out, ")", "_xx_rparen"); 1218 Replaceall(out, "[", "_xx_lbrace"); 1219 Replaceall(out, "]", "_xx_rbrace"); 1220 Replaceall(out, "~", "_xx_bnot"); 1221 Replaceall(out, "=", "_xx_equals"); 1222 Replaceall(out, "/", "_xx_slash"); 1223 Replaceall(out, ".", "_xx_dot"); 1224 return out; 1225 } 1226 1227 String *fully_qualify_enum_name(Node *n, String *name) { 1228 Node *parent = 0; 1229 String *qualification = NewString(""); 1230 String *fully_qualified_name = NewString(""); 1231 String *parent_type = 0; 1232 String *normalized_name; 1233 1234 parent = parentNode(n); 1235 while (parent) { 1236 parent_type = nodeType(parent); 1237 if (Getattr(parent, "name")) { 1238 String *parent_copy = NewStringf("%s::", Getattr(parent, "name")); 1239 if (!Cmp(parent_type, "class") || !Cmp(parent_type, "namespace")) 1240 Insert(qualification, 0, parent_copy); 1241 Delete(parent_copy); 1242 } 1243 if (!Cmp(parent_type, "class")) 1244 break; 1245 parent = parentNode(parent); 1246 } 1247 1248 Printf(fully_qualified_name, "%s%s", qualification, name); 1249 1250 normalized_name = normalizeTemplatedClassName(fully_qualified_name); 1251 if (!strncmp(Char(normalized_name), "enum ", 5)) { 1252 Insert(normalized_name, 5, qualification); 1253 } 1254 1255 return normalized_name; 1256 } 1257 1258 /* Benedikt Grundmann inspired --> Enum wrap styles */ 1259 1260 int enumvalueDeclaration(Node *n) { 1261 String *name = Getattr(n, "name"); 1262 String *qvalue = 0; 1263 1264 if (name_qualifier) { 1265 qvalue = Copy(name_qualifier); 1266 Printv(qvalue, name, NIL); 1267 } 1268 1269 if (const_enum && name && !Getattr(seen_enumvalues, name)) { 1270 Setattr(seen_enumvalues, name, "true"); 1271 SetFlag(n, "feature:immutable"); 1272 Setattr(n, "feature:enumvalue", "1"); // this does not appear to be used 1273 1274 if (qvalue) 1275 Setattr(n, "qualified:value", qvalue); 1276 1277 String *evname = SwigType_manglestr(qvalue); 1278 Insert(evname, 0, "SWIG_ENUM_"); 1279 1280 Setattr(n, "feature:enumvname", name); 1281 Setattr(n, "feature:symname", evname); 1282 Delete(evname); 1283 Printf(f_enumtypes_value, "| `%s\n", name); 1284 1285 return Language::enumvalueDeclaration(n); 1286 } else 1287 return SWIG_OK; 1288 } 1289 1290 /* ------------------------------------------------------------------- 1291 * This function is a bit uglier than it deserves. 1292 * 1293 * I used to direct lookup the name of the enum. Now that certain fixes 1294 * have been made in other places, the names of enums are now fully 1295 * qualified, which is a good thing, overall, but requires me to do 1296 * some legwork. 1297 * 1298 * The other thing that uglifies this function is the varying way that 1299 * typedef enum and enum are handled. I need to produce consistent names, 1300 * which means looking up and registering by typedef and enum name. */ 1301 int enumDeclaration(Node *n) { 1302 String *name = Getattr(n, "name"); 1303 if (name) { 1304 String *oname = NewString(name); 1305 /* name is now fully qualified */ 1306 String *fully_qualified_name = NewString(name); 1307 bool seen_enum = false; 1308 if (name_qualifier) 1309 Delete(name_qualifier); 1310 char *strip_position; 1311 name_qualifier = fully_qualify_enum_name(n, NewString("")); 1312 1313 strip_position = strstr(Char(oname), "::"); 1314 1315 while (strip_position) { 1316 strip_position += 2; 1317 oname = NewString(strip_position); 1318 strip_position = strstr(Char(oname), "::"); 1319 } 1320 1321 seen_enum = (Getattr(seen_enums, fully_qualified_name) ? true : false); 1322 1323 if (!seen_enum) { 1324 const_enum = true; 1325 Printf(f_enum_to_int, "| `%s -> (match y with\n", oname); 1326 Printf(f_int_to_enum, "| `%s -> C_enum (\n", oname); 1327 /* * * * A note about enum name resolution * * * * 1328 * This code should now work, but I think we can do a bit better. 1329 * The problem I'm having is that swig isn't very precise about 1330 * typedef name resolution. My opinion is that SwigType_typedef 1331 * resolve_all should *always* return the enum tag if one exists, 1332 * rather than the admittedly friendlier enclosing typedef. 1333 * 1334 * This would make one of the cases below unnecessary. 1335 * * * */ 1336 Printf(f_mlbody, "let _ = Callback.register \"%s_marker\" (`%s)\n", fully_qualified_name, oname); 1337 if (!strncmp(Char(fully_qualified_name), "enum ", 5)) { 1338 String *fq_noenum = NewString(Char(fully_qualified_name) + 5); 1339 Printf(f_mlbody, 1340 "let _ = Callback.register \"%s_marker\" (`%s)\n" "let _ = Callback.register \"%s_marker\" (`%s)\n", fq_noenum, oname, fq_noenum, name); 1341 } 1342 1343 Printf(f_enumtypes_type, "| `%s\n", oname); 1344 Insert(fully_qualified_name, 0, "enum "); 1345 Setattr(seen_enums, fully_qualified_name, n); 1346 } 1347 } 1348 1349 int ret = Language::enumDeclaration(n); 1350 1351 if (const_enum) { 1352 Printf(f_int_to_enum, "`Int y)\n"); 1353 Printf(f_enum_to_int, "| `Int x -> Swig.C_int x\n" "| _ -> raise (LabelNotFromThisEnum v))\n"); 1354 } 1355 1356 const_enum = false; 1357 1358 return ret; 1359 } 1360 1361 /* ---------------------------------------------------------------------------- 1362 * BEGIN C++ Director Class modifications 1363 * ------------------------------------------------------------------------- */ 1364 1365 /* 1366 * Modified polymorphism code for Ocaml language module. 1367 * Original: 1368 * C++/Python polymorphism demo code, copyright (C) 2002 Mark Rose 1369 * <mrose@stm.lbl.gov> 1370 * 1371 * TODO 1372 * 1373 * Move some boilerplate code generation to Swig_...() functions. 1374 * 1375 */ 1376 1377 /* --------------------------------------------------------------- 1378 * classDirectorMethod() 1379 * 1380 * Emit a virtual director method to pass a method call on to the 1381 * underlying Python object. 1382 * 1383 * --------------------------------------------------------------- */ 1384 1385 int classDirectorMethod(Node *n, Node *parent, String *super) { 1386 int is_void = 0; 1387 int is_pointer = 0; 1388 String *storage; 1389 String *value; 1390 String *decl; 1391 String *type; 1392 String *name; 1393 String *classname; 1394 String *c_classname = Getattr(parent, "name"); 1395 String *declaration; 1396 ParmList *l; 1397 Wrapper *w; 1398 String *tm; 1399 String *wrap_args = NewString(""); 1400 String *return_type; 1401 int status = SWIG_OK; 1402 int idx; 1403 bool pure_virtual = false; 1404 bool ignored_method = GetFlag(n, "feature:ignore") ? true : false; 1405 1406 storage = Getattr(n, "storage"); 1407 value = Getattr(n, "value"); 1408 classname = Getattr(parent, "sym:name"); 1409 type = Getattr(n, "type"); 1410 name = Getattr(n, "name"); 1411 1412 if (Cmp(storage, "virtual") == 0) { 1413 if (Cmp(value, "0") == 0) { 1414 pure_virtual = true; 1415 } 1416 } 1417 1418 w = NewWrapper(); 1419 declaration = NewString(""); 1420 Wrapper_add_local(w, "swig_result", "CAMLparam0();\n" "SWIG_CAMLlocal2(swig_result,args)"); 1421 1422 /* determine if the method returns a pointer */ 1423 decl = Getattr(n, "decl"); 1424 is_pointer = SwigType_ispointer_return(decl); 1425 is_void = (!Cmp(type, "void") && !is_pointer); 1426 1427 /* form complete return type */ 1428 return_type = Copy(type); 1429 { 1430 SwigType *t = Copy(decl); 1431 SwigType *f = 0; 1432 f = SwigType_pop_function(t); 1433 SwigType_push(return_type, t); 1434 Delete(f); 1435 Delete(t); 1436 } 1437 1438 /* virtual method definition */ 1439 l = Getattr(n, "parms"); 1440 String *target; 1441 String *pclassname = NewStringf("SwigDirector_%s", classname); 1442 String *qualified_name = NewStringf("%s::%s", pclassname, name); 1443 SwigType *rtype = Getattr(n, "conversion_operator") ? 0 : type; 1444 target = Swig_method_decl(rtype, decl, qualified_name, l, 0, 0); 1445 Printf(w->def, "%s {", target); 1446 Delete(qualified_name); 1447 Delete(target); 1448 /* header declaration */ 1449 target = Swig_method_decl(rtype, decl, name, l, 0, 1); 1450 Printf(declaration, " virtual %s;", target); 1451 Delete(target); 1452 1453 /* declare method return value 1454 * if the return value is a reference or const reference, a specialized typemap must 1455 * handle it, including declaration of c_result ($result). 1456 */ 1457 if (!is_void) { 1458 if (!(ignored_method && !pure_virtual)) { 1459 Wrapper_add_localv(w, "c_result", SwigType_lstr(return_type, "c_result"), NIL); 1460 } 1461 } 1462 1463 if (ignored_method) { 1464 if (!pure_virtual) { 1465 if (!is_void) 1466 Printf(w->code, "return "); 1467 String *super_call = Swig_method_call(super, l); 1468 Printf(w->code, "%s;\n", super_call); 1469 Delete(super_call); 1470 } else { 1471 Printf(w->code, "Swig::DirectorPureVirtualException::raise(\"Attempted to invoke pure virtual method %s::%s\");\n", SwigType_namestr(c_classname), 1472 SwigType_namestr(name)); 1473 } 1474 } else { 1475 /* attach typemaps to arguments (C/C++ -> Ocaml) */ 1476 String *arglist = NewString(""); 1477 1478 Swig_typemap_attach_parms("in", l, 0); 1479 Swig_typemap_attach_parms("directorin", l, 0); 1480 Swig_typemap_attach_parms("directorargout", l, w); 1481 1482 Parm *p; 1483 int num_arguments = emit_num_arguments(l); 1484 int i; 1485 char source[256]; 1486 1487 int outputs = 0; 1488 if (!is_void) 1489 outputs++; 1490 1491 /* build argument list and type conversion string */ 1492 for (i = 0, idx = 0, p = l; i < num_arguments; i++) { 1493 1494 while (Getattr(p, "tmap:ignore")) { 1495 p = Getattr(p, "tmap:ignore:next"); 1496 } 1497 1498 if (Getattr(p, "tmap:directorargout") != 0) 1499 outputs++; 1500 1501 String *pname = Getattr(p, "name"); 1502 String *ptype = Getattr(p, "type"); 1503 1504 Putc(',', arglist); 1505 if ((tm = Getattr(p, "tmap:directorin")) != 0) { 1506 Replaceall(tm, "$input", pname); 1507 Replaceall(tm, "$owner", "0"); 1508 if (Len(tm) == 0) 1509 Append(tm, pname); 1510 Printv(wrap_args, tm, "\n", NIL); 1511 p = Getattr(p, "tmap:directorin:next"); 1512 continue; 1513 } else if (Cmp(ptype, "void")) { 1514 /* special handling for pointers to other C++ director classes. 1515 * ideally this would be left to a typemap, but there is currently no 1516 * way to selectively apply the dynamic_cast<> to classes that have 1517 * directors. in other words, the type "SwigDirector_$1_lname" only exists 1518 * for classes with directors. we avoid the problem here by checking 1519 * module.wrap::directormap, but it's not clear how to get a typemap to 1520 * do something similar. perhaps a new default typemap (in addition 1521 * to SWIGTYPE) called DIRECTORTYPE? 1522 */ 1523 if (SwigType_ispointer(ptype) || SwigType_isreference(ptype)) { 1524 Node *module = Getattr(parent, "module"); 1525 Node *target = Swig_directormap(module, ptype); 1526 sprintf(source, "obj%d", idx++); 1527 String *nonconst = 0; 1528 /* strip pointer/reference --- should move to Swig/stype.c */ 1529 String *nptype = NewString(Char(ptype) + 2); 1530 /* name as pointer */ 1531 String *ppname = Copy(pname); 1532 if (SwigType_isreference(ptype)) { 1533 Insert(ppname, 0, "&"); 1534 } 1535 /* if necessary, cast away const since Python doesn't support it! */ 1536 if (SwigType_isconst(nptype)) { 1537 nonconst = NewStringf("nc_tmp_%s", pname); 1538 String *nonconst_i = NewStringf("= const_cast<%s>(%s)", SwigType_lstr(ptype, 0), ppname); 1539 Wrapper_add_localv(w, nonconst, SwigType_lstr(ptype, 0), nonconst, nonconst_i, NIL); 1540 Delete(nonconst_i); 1541 Swig_warning(WARN_LANG_DISCARD_CONST, input_file, line_number, 1542 "Target language argument '%s' discards const in director method %s::%s.\n", SwigType_str(ptype, pname), 1543 SwigType_namestr(c_classname), SwigType_namestr(name)); 1544 } else { 1545 nonconst = Copy(ppname); 1546 } 1547 Delete(nptype); 1548 Delete(ppname); 1549 String *mangle = SwigType_manglestr(ptype); 1550 if (target) { 1551 String *director = NewStringf("director_%s", mangle); 1552 Wrapper_add_localv(w, director, "Swig::Director *", director, "= 0", NIL); 1553 Wrapper_add_localv(w, source, "CAML_VALUE", source, "= Val_unit", NIL); 1554 Printf(wrap_args, "%s = dynamic_cast<Swig::Director *>(%s);\n", director, nonconst); 1555 Printf(wrap_args, "if (!%s) {\n", director); 1556 Printf(wrap_args, "%s = SWIG_NewPointerObj(%s, SWIGTYPE%s, 0);\n", source, nonconst, mangle); 1557 Printf(wrap_args, "} else {\n"); 1558 Printf(wrap_args, "%s = %s->swig_get_self();\n", source, director); 1559 Printf(wrap_args, "}\n"); 1560 Delete(director); 1561 Printv(arglist, source, NIL); 1562 } else { 1563 Wrapper_add_localv(w, source, "CAML_VALUE", source, "= Val_unit", NIL); 1564 Printf(wrap_args, "%s = SWIG_NewPointerObj(%s, SWIGTYPE%s, 0);\n", source, nonconst, mangle); 1565 //Printf(wrap_args, "%s = SWIG_NewPointerObj(%s, SWIGTYPE_p_%s, 0);\n", 1566 // source, nonconst, base); 1567 Printv(arglist, source, NIL); 1568 } 1569 Delete(mangle); 1570 Delete(nonconst); 1571 } else { 1572 Swig_warning(WARN_TYPEMAP_DIRECTORIN_UNDEF, input_file, line_number, 1573 "Unable to use type %s as a function argument in director method %s::%s (skipping method).\n", SwigType_str(ptype, 0), 1574 SwigType_namestr(c_classname), SwigType_namestr(name)); 1575 status = SWIG_NOWRAP; 1576 break; 1577 } 1578 } 1579 p = nextSibling(p); 1580 } 1581 1582 Printv(w->code, "swig_result = Val_unit;\n", 0); 1583 Printf(w->code, "args = Val_unit;\n"); 1584 1585 /* wrap complex arguments to values */ 1586 Printv(w->code, wrap_args, NIL); 1587 1588 /* pass the method call on to the Python object */ 1589 Printv(w->code, 1590 "swig_result = caml_swig_alloc(1,C_list);\n" "SWIG_Store_field(swig_result,0,args);\n" "args = swig_result;\n" "swig_result = Val_unit;\n", 0); 1591 Printf(w->code, "swig_result = " "callback3(*caml_named_value(\"swig_runmethod\")," "swig_get_self(),copy_string(\"%s\"),args);\n", Getattr(n, "name")); 1592 /* exception handling */ 1593 tm = Swig_typemap_lookup("director:except", n, "result", 0); 1594 if (!tm) { 1595 tm = Getattr(n, "feature:director:except"); 1596 } 1597 if ((tm) && Len(tm) && (Strcmp(tm, "1") != 0)) { 1598 Printf(w->code, "if (result == NULL) {\n"); 1599 Printf(w->code, " CAML_VALUE error = *caml_named_value(\"director_except\");\n"); 1600 Replaceall(tm, "$error", "error"); 1601 Printv(w->code, Str(tm), "\n", NIL); 1602 Printf(w->code, "}\n"); 1603 } 1604 1605 /* 1606 * Python method may return a simple object, or a tuple. 1607 * for in/out aruments, we have to extract the appropriate values from the 1608 * argument list, then marshal everything back to C/C++ (return value and 1609 * output arguments). 1610 */ 1611 1612 /* marshal return value and other outputs (if any) from value to C/C++ 1613 * type */ 1614 1615 String *cleanup = NewString(""); 1616 String *outarg = NewString(""); 1617 1618 idx = 0; 1619 1620 /* this seems really silly. the node's type excludes 1621 * qualifier/pointer/reference markers, which have to be retrieved 1622 * from the decl field to construct return_type. but the typemap 1623 * lookup routine uses the node's type, so we have to swap in and 1624 * out the correct type. it's not just me, similar silliness also 1625 * occurs in Language::cDeclaration(). 1626 */ 1627 Setattr(n, "type", return_type); 1628 tm = Swig_typemap_lookup("directorout", n, "c_result", w); 1629 Setattr(n, "type", type); 1630 if (tm != 0) { 1631 Replaceall(tm, "$input", "swig_result"); 1632 /* TODO check this */ 1633 if (Getattr(n, "wrap:disown")) { 1634 Replaceall(tm, "$disown", "SWIG_POINTER_DISOWN"); 1635 } else { 1636 Replaceall(tm, "$disown", "0"); 1637 } 1638 Replaceall(tm, "$result", "c_result"); 1639 Printv(w->code, tm, "\n", NIL); 1640 } 1641 1642 /* marshal outputs */ 1643 for (p = l; p;) { 1644 if ((tm = Getattr(p, "tmap:directorargout")) != 0) { 1645 Replaceall(tm, "$input", "swig_result"); 1646 Replaceall(tm, "$result", Getattr(p, "name")); 1647 Printv(w->code, tm, "\n", NIL); 1648 p = Getattr(p, "tmap:directorargout:next"); 1649 } else { 1650 p = nextSibling(p); 1651 } 1652 } 1653 1654 Delete(arglist); 1655 Delete(cleanup); 1656 Delete(outarg); 1657 } 1658 1659 /* any existing helper functions to handle this? */ 1660 if (!is_void) { 1661 if (!(ignored_method && !pure_virtual)) { 1662 /* A little explanation: 1663 * The director_enum test case makes a method whose return type 1664 * is an enum type. return_type here is "int". gcc complains 1665 * about an implicit enum conversion, and although i don't strictly 1666 * agree with it, I'm working on fixing the error: 1667 * 1668 * Below is what I came up with. It's not great but it should 1669 * always essentially work. 1670 */ 1671 if (!SwigType_isreference(return_type)) { 1672 Printf(w->code, "CAMLreturn_type((%s)c_result);\n", SwigType_lstr(return_type, "")); 1673 } else { 1674 Printf(w->code, "CAMLreturn_type(*c_result);\n"); 1675 } 1676 } 1677 } 1678 1679 Printf(w->code, "}\n"); 1680 1681 // We expose protected methods via an extra public inline method which makes a straight call to the wrapped class' method 1682 String *inline_extra_method = NewString(""); 1683 if (dirprot_mode() && !is_public(n) && !pure_virtual) { 1684 Printv(inline_extra_method, declaration, NIL); 1685 String *extra_method_name = NewStringf("%sSwigPublic", name); 1686 Replaceall(inline_extra_method, name, extra_method_name); 1687 Replaceall(inline_extra_method, ";\n", " {\n "); 1688 if (!is_void) 1689 Printf(inline_extra_method, "return "); 1690 String *methodcall = Swig_method_call(super, l); 1691 Printv(inline_extra_method, methodcall, ";\n }\n", NIL); 1692 Delete(methodcall); 1693 Delete(extra_method_name); 1694 } 1695 1696 /* emit the director method */ 1697 if (status == SWIG_OK) { 1698 if (!Getattr(n, "defaultargs")) { 1699 Wrapper_print(w, f_directors); 1700 Printv(f_directors_h, declaration, NIL); 1701 Printv(f_directors_h, inline_extra_method, NIL); 1702 } 1703 } 1704 1705 /* clean up */ 1706 Delete(wrap_args); 1707 Delete(return_type); 1708 Delete(pclassname); 1709 DelWrapper(w); 1710 return status; 1711 } 1712 1713 /* ------------------------------------------------------------ 1714 * classDirectorConstructor() 1715 * ------------------------------------------------------------ */ 1716 1717 int classDirectorConstructor(Node *n) { 1718 Node *parent = Getattr(n, "parentNode"); 1719 String *sub = NewString(""); 1720 String *decl = Getattr(n, "decl"); 1721 String *supername = Swig_class_name(parent); 1722 String *classname = NewString(""); 1723 Printf(classname, "SwigDirector_%s", supername); 1724 1725 /* insert self parameter */ 1726 Parm *p, *q; 1727 ParmList *superparms = Getattr(n, "parms"); 1728 ParmList *parms = CopyParmList(superparms); 1729 String *type = NewString("CAML_VALUE"); 1730 p = NewParm(type, NewString("self")); 1731 q = Copy(p); 1732 set_nextSibling(q, superparms); 1733 set_nextSibling(p, parms); 1734 parms = p; 1735 1736 if (!Getattr(n, "defaultargs")) { 1737 /* constructor */ 1738 { 1739 Wrapper *w = NewWrapper(); 1740 String *call; 1741 String *basetype = Getattr(parent, "classtype"); 1742 String *target = Swig_method_decl(0, decl, classname, parms, 0, 0); 1743 call = Swig_csuperclass_call(0, basetype, superparms); 1744 Printf(w->def, "%s::%s: %s, Swig::Director(self) { }", classname, target, call); 1745 Delete(target); 1746 Wrapper_print(w, f_directors); 1747 Delete(call); 1748 DelWrapper(w); 1749 } 1750 1751 /* constructor header */ 1752 { 1753 String *target = Swig_method_decl(0, decl, classname, parms, 0, 1); 1754 Printf(f_directors_h, " %s;\n", target); 1755 Delete(target); 1756 } 1757 } 1758 1759 Setattr(n, "parms", q); 1760 Language::classDirectorConstructor(n); 1761 1762 Delete(sub); 1763 Delete(classname); 1764 Delete(supername); 1765 //Delete(parms); 1766 1767 return SWIG_OK; 1768 } 1769 1770 /* ------------------------------------------------------------ 1771 * classDirectorDefaultConstructor() 1772 * ------------------------------------------------------------ */ 1773 1774 int classDirectorDefaultConstructor(Node *n) { 1775 String *classname; 1776 classname = Swig_class_name(n); 1777 1778 /* insert self parameter */ 1779 Parm *p, *q; 1780 ParmList *superparms = Getattr(n, "parms"); 1781 ParmList *parms = CopyParmList(superparms); 1782 String *type = NewString("CAML_VALUE"); 1783 p = NewParm(type, NewString("self")); 1784 q = Copy(p); 1785 set_nextSibling(p, parms); 1786 parms = p; 1787 1788 { 1789 Wrapper *w = NewWrapper(); 1790 Printf(w->def, "SwigDirector_%s::SwigDirector_%s(CAML_VALUE self) : Swig::Director(self) { }", classname, classname); 1791 Wrapper_print(w, f_directors); 1792 DelWrapper(w); 1793 } 1794 Printf(f_directors_h, " SwigDirector_%s(CAML_VALUE self);\n", classname); 1795 Delete(classname); 1796 Setattr(n, "parms", q); 1797 return Language::classDirectorDefaultConstructor(n); 1798 } 1799 1800 int classDirectorInit(Node *n) { 1801 String *declaration = Swig_director_declaration(n); 1802 Printf(f_directors_h, "\n" "%s\n" "public:\n", declaration); 1803 Delete(declaration); 1804 return Language::classDirectorInit(n); 1805 } 1806 1807 int classDirectorEnd(Node *n) { 1808 Printf(f_directors_h, "};\n\n"); 1809 return Language::classDirectorEnd(n); 1810 } 1811 1812 /* --------------------------------------------------------------------- 1813 * typedefHandler 1814 * 1815 * This is here in order to maintain the correct association between 1816 * typedef names and enum names. 1817 * 1818 * Since I implement enums as polymorphic variant tags, I need to call 1819 * back into ocaml to evaluate them. This requires a string that can 1820 * be generated in the typemaps, and also at SWIG time to be the same 1821 * string. The problem that arises is that SWIG variously generates 1822 * enum e_name_tag 1823 * e_name_tag 1824 * e_typedef_name 1825 * for 1826 * typedef enum e_name_tag { ... } e_typedef_name; 1827 * 1828 * Since I need these strings to be consistent, I must maintain a correct 1829 * association list between typedef and enum names. 1830 * --------------------------------------------------------------------- */ 1831 int typedefHandler(Node *n) { 1832 String *type = Getattr(n, "type"); 1833 Node *enum_node = type ? Getattr(seen_enums, type) : 0; 1834 if (enum_node) { 1835 String *name = Getattr(enum_node, "name"); 1836 1837 Printf(f_mlbody, "let _ = Callback.register \"%s_marker\" (`%s)\n", Getattr(n, "name"), name); 1838 1839 } 1840 return SWIG_OK; 1841 } 1842 1843 String *runtimeCode() { 1844 String *s = Swig_include_sys("ocaml.swg"); 1845 if (!s) { 1846 Printf(stderr, "*** Unable to open 'ocaml.swg'\n"); 1847 s = NewString(""); 1848 } 1849 return s; 1850 } 1851 1852 String *defaultExternalRuntimeFilename() { 1853 return NewString("swigocamlrun.h"); 1854 } 1855}; 1856 1857/* ------------------------------------------------------------------------- 1858 * swig_ocaml() - Instantiate module 1859 * ------------------------------------------------------------------------- */ 1860 1861static Language *new_swig_ocaml() { 1862 return new OCAML(); 1863} 1864extern "C" Language *swig_ocaml(void) { 1865 return new_swig_ocaml(); 1866} 1867