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 * allegrocl.cxx 6 * 7 * ALLEGROCL language module for SWIG. 8 * ----------------------------------------------------------------------------- */ 9 10char cvsroot_allegrocl_cxx[] = "$Id: allegrocl.cxx 11471 2009-07-29 20:52:29Z wsfulton $"; 11 12#include "swigmod.h" 13#include "cparse.h" 14#include <ctype.h> 15 16// #define ALLEGROCL_DEBUG 17// #define ALLEGROCL_WRAP_DEBUG 18// #define ALLEGROCL_TYPE_DEBUG 19// #define ALLEGROCL_CLASS_DEBUG 20 21static File *f_cl = 0; 22String *f_clhead = NewString(""); 23String *f_clwrap = NewString("(swig-in-package ())\n\n"); 24static File *f_begin; 25static File *f_runtime; 26static File *f_cxx_header = 0; 27static File *f_cxx_wrapper = 0; 28 29static String *module_name = 0; 30static String *swig_package = 0; 31 32const char *identifier_converter = "identifier-convert-null"; 33 34static bool CWrap = true; // generate wrapper file for C code by default. most correct. 35static bool Generate_Wrapper = false; 36static bool unique_swig_package = false; 37 38static SwigType *fwdref_ffi_type = NewString("__SWIGACL_FwdReference"); 39 40static String *current_namespace = NewString(""); 41static String *current_package = NewString(""); 42static Hash *defined_namespace_packages = NewHash(); 43static Node *in_class = 0; 44 45static Node *first_linked_type = 0; 46static Hash *defined_foreign_types = NewHash(); 47static Hash *defined_foreign_ltypes = NewHash(); 48 49static String *anon_type_name = NewString("anontype"); 50static int anon_type_count = 0; 51 52// stub 53String *convert_literal(String *num_param, String *type, bool try_to_split = true); 54 55class ALLEGROCL:public Language { 56public: 57 virtual void main(int argc, char *argv[]); 58 virtual int top(Node *n); 59 virtual int functionWrapper(Node *n); 60 virtual int namespaceDeclaration(Node *n); 61 virtual int constructorHandler(Node *n); 62 virtual int destructorHandler(Node *n); 63 virtual int globalvariableHandler(Node *n); 64 virtual int variableWrapper(Node *n); 65 virtual int constantWrapper(Node *n); 66 virtual int memberfunctionHandler(Node *n); 67 virtual int membervariableHandler(Node *n); 68 virtual int classHandler(Node *n); 69 virtual int emit_one(Node *n); 70 virtual int enumDeclaration(Node *n); 71 virtual int enumvalueDeclaration(Node *n); 72 virtual int typedefHandler(Node *n); 73 virtual int classforwardDeclaration(Node *n); 74 virtual int templateDeclaration(Node *n); 75 virtual int validIdentifier(String *s); 76private: 77 int emit_defun(Node *n, File *f_cl); 78 int emit_dispatch_defun(Node *n); 79 int emit_buffered_defuns(Node *n); 80 int cClassHandler(Node *n); 81 int cppClassHandler(Node *n); 82}; 83static ALLEGROCL *allegrocl = 0; 84 85static String *trim(String *str) { 86 char *c = Char(str); 87 while (*c != '\0' && isspace((int) *c)) 88 ++c; 89 String *result = NewString(c); 90 Chop(result); 91 return result; 92} 93 94int is_integer(String *s) { 95 char *c = Char(s); 96 if (c[0] == '#' && (c[1] == 'x' || c[1] == 'o')) 97 c += 2; 98 99 while (*c) { 100 if (!isdigit(*c)) 101 return 0; 102 c++; 103 } 104 return 1; 105} 106 107String *class_from_class_or_class_ref(String *type) { 108 SwigType *stripped = SwigType_strip_qualifiers(type); 109 if (SwigType_isclass(stripped)) 110 return stripped; 111 112 if (SwigType_ispointer(stripped) || SwigType_isreference(stripped)) { 113 // Printf(stderr,"It is a pointer/reference. Is it a class?\n"); 114 SwigType_pop(stripped); 115 if (SwigType_isclass(stripped)) { 116 return stripped; 117 } 118 } 119 return 0; 120} 121 122String *lookup_defined_foreign_type(String *k) { 123 124#ifdef ALLEGROCL_TYPE_DEBUG 125 Printf(stderr, "Looking up defined type '%s'.\n Found: '%s'\n", k, Getattr(defined_foreign_types, k)); 126#endif 127 128 return Getattr(defined_foreign_types, k); 129} 130 131String *listify_namespace(String *namespaze) { 132 if (Len(namespaze) == 0) 133 return NewString("()"); 134 String *result = NewStringf("(\"%s\")", namespaze); 135 Replaceall(result, "::", "\" \""); 136 return result; 137} 138 139String *namespaced_name(Node *n, String *ns = current_namespace) { 140 141 return NewStringf("%s%s%s", ns, (Len(ns) != 0) ? "::" : "", Getattr(n, "sym:name")); 142} 143 144// "Namespace::Nested::Class2::Baz" -> "Baz" 145static String *strip_namespaces(String *str) { 146 char *result = Char(str); 147 String *stripped_one; 148 while ((stripped_one = Strstr(result, "::"))) 149 result = Char(stripped_one) + 2; 150 return NewString(result); 151} 152 153static String *namespace_of(String *str) { 154 char *p = Char(str); 155 char *start = Char(str); 156 char *result = 0; 157 String *stripped_one; 158 159 while ((stripped_one = Strstr(p, "::"))) { 160 p = Char(stripped_one) + 2; 161 } 162 if (p > start) { 163 int len = p - start - 1; 164 result = (char *) malloc(len); 165 strncpy(result, start, len - 1); 166 result[len - 1] = 0; 167 } 168 return Char(result); 169} 170 171void add_linked_type(Node *n) { 172#ifdef ALLEGROCL_CLASS_DEBUG 173 Printf(stderr, "Adding linked node of type: %s(%s) %s(%x)\n\n", nodeType(n), Getattr(n, "storage"), Getattr(n, "name"), n); 174 // Swig_print_node(n); 175#endif 176 if (!first_linked_type) { 177 first_linked_type = n; 178 Setattr(n, "allegrocl:last_linked_type", n); 179 } else { 180 Node *t = Getattr(first_linked_type, "allegrocl:last_linked_type"); 181 Setattr(t, "allegrocl:next_linked_type", n); 182 Setattr(first_linked_type, "allegrocl:last_linked_type", n); 183 } 184} 185 186void replace_linked_type(Node *old, Node *new_node) { 187 Node *prev = Getattr(old, "allegrocl:prev_linked_type"); 188 189 Setattr(new_node, "allegrocl:next_linked_type", Getattr(old, "allegrocl:next_linked_type")); 190 if (prev) 191 Setattr(prev, "allegrocl:next_linked_type", new_node); 192 Delattr(old, "allegrocl:next_linked_type"); 193 Delattr(old, "allegrocl:prev_linked_type"); 194 195 // check if we're replacing the first link. 196 if (first_linked_type == old) { 197 first_linked_type = new_node; 198 Setattr(first_linked_type, "allegrocl:last_linked_type", Getattr(old, "allegrocl:last_linked_type")); 199 } 200 // check if we're replacing the last link. 201 if (Getattr(first_linked_type, "allegrocl:last_linked_type") == old) 202 Setattr(first_linked_type, "allegrocl:last_linked_type", new_node); 203} 204 205void insert_linked_type_at(Node *old, Node *new_node, int before = 1) { 206 Node *p = 0; 207 208 if (!first_linked_type) { 209 add_linked_type(new_node); 210 return; 211 } 212 213 if (!before) { 214 Setattr(new_node, "allegrocl:next_linked_type", Getattr(old, "allegrocl:next_linked_type")); 215 Setattr(old, "allegrocl:next_linked_type", new_node); 216 if (Getattr(first_linked_type, "allegrocl:last_linked_type") == old) 217 Setattr(first_linked_type, "allegrocl:last_linked_type", new_node); 218 } else { 219 Node *c = first_linked_type; 220 while (c) { 221 if (c == old) { 222 break; 223 } else { 224 p = c; 225 c = Getattr(c, "allegrocl:next_linked_type"); 226 } 227 } 228 if (c == old) { 229 Setattr(new_node, "allegrocl:next_linked_type", c); 230 if (first_linked_type == c) { 231 first_linked_type = new_node; 232 Setattr(first_linked_type, "allegrocl:last_linked_type", Getattr(c, "allegrocl:last_linked_type")); 233 Delattr(c, "allegrocl:last_linked_type"); 234 } 235 if (p) 236 Setattr(p, "allegrocl:next_linked_type", new_node); 237 } 238 } 239} 240 241Node *find_linked_type_by_name(String *name) { 242 Node *p = 0; 243 Node *c = first_linked_type; 244 245 // Printf(stderr,"in find_linked_type_by_name '%s'...", name); 246 while (c) { 247 String *key = Getattr(c, "name"); 248 if (!Strcmp(key, name)) { 249 break; 250 } else { 251 p = c; 252 c = Getattr(c, "allegrocl:next_linked_type"); 253 } 254 } 255 // Printf(stderr,"exit find_linked_type_by_name.\n"); 256 257 if (p && c) 258 Setattr(c, "allegrocl:prev_linked_type", p); 259 // Printf(stderr,"find_linked_type_by_name: DONE\n"); 260 return c; 261} 262 263Node *get_primary_synonym_of(Node *n) { 264 Node *p = Getattr(n, "allegrocl:synonym-of"); 265 Node *prim = n; 266 267 // Printf(stderr, "getting primary synonym of %x\n", n); 268 while (p) { 269 // Printf(stderr, " found one! %x\n", p); 270 prim = p; 271 p = Getattr(p, "allegrocl:synonym-of"); 272 } 273 // Printf(stderr,"get_primary_syn: DONE. returning %s(%x)\n", Getattr(prim,"name"),prim); 274 return prim; 275} 276 277void add_forward_referenced_type(Node *n, int overwrite = 0) { 278 String *k = Getattr(n, "name"); 279 String *name = Getattr(n, "sym:name"); 280 String *ns = listify_namespace(current_namespace); 281 282 String *val = Getattr(defined_foreign_types, k); 283 284 if (!val || overwrite) { 285#ifdef ALLEGROCL_TYPE_DEBUG 286 Printf(stderr, "Adding forward reference for %s (overwrite=%d)\n", k, overwrite); 287#endif 288 Setattr(defined_foreign_types, Copy(k), NewString("forward-reference")); 289 290 String *mangled_lname_gen = NewStringf("#.(swig-insert-id \"%s\" %s :type :class)", name, ns); 291 292 Setattr(defined_foreign_ltypes, Copy(k), mangled_lname_gen); 293 // Printf(f_cl, ";; forward reference stub\n" 294 // "(swig-def-foreign-class \"%s\" (ff:foreign-pointer) (:class ))\n\n" 295 // , name); 296 297#ifdef ALLEGROCL_CLASS_DEBUG 298 Printf(stderr, "Linking forward reference type = %s(%x)\n", k, n); 299#endif 300 add_linked_type(n); 301 } 302} 303 304void add_defined_foreign_type(Node *n, int overwrite = 0, String *k = 0, 305 String *name = 0, String *ns = current_namespace) { 306 307 String *val; 308 String *ns_list = listify_namespace(ns); 309 String *templated = n ? Getattr(n, "template") : 0; 310 String *cDeclName = n ? Getattr(n, "classDeclaration:name") : 0; 311 312#ifdef ALLEGROCL_CLASS_DEBUG 313 Printf(stderr, "IN A-D-F-T. (n=%x, ow=%d, k=%s, name=%s, ns=%s\n", n, overwrite, k, name, ns); 314 Printf(stderr, " templated = '%x', classDecl = '%x'\n", templated, cDeclName); 315#endif 316 if (n) { 317 if (!name) 318 name = Getattr(n, "sym:name"); 319 if (!name) 320 name = strip_namespaces(Getattr(n, "name")); 321 if (templated) { 322 k = namespaced_name(n); 323 } else { 324 String *kind_of_type = Getattr(n, "kind"); 325 326 /* 327 For typedefs of the form: 328 329 typedef struct __xxx { ... } xxx; 330 331 behavior differs between C mode and C++ mode. 332 333 C Mode: 334 add_defined_foreign_type will be called once via classHandler 335 to define the type for 'struct __xxx' and add the mapping from 336 'struct __xxx' -> 'xxx' 337 338 It will also be called once via typedefHandler to add the 339 mapping 'xxx' -> 'xxx' 340 341 C++ Mode: 342 add_defined_foreign_type will be called once via classHandler 343 to define the type for 'xxx'. it also adds the mapping from 344 'xxx' -> 'xxx' and also for 'struct xxx' -> 'xxx' 345 346 In typedefHandler, we again try to add the mapping from 347 'xxx' -> 'xxx', which already exists. This second mapping 348 is ignored. 349 350 Both modes: 351 352 All references to this typedef'd struct will appear in 353 generated lisp code as an objectd of type 'xxx'. For 354 non-typedef'd structs, the classHand mapping will be 355 356 struct __xxx -> (swig-insert-id "__xxx") 357 */ 358 // Swig_print_node(n); 359 String *unnamed = Getattr(n, "unnamed"); 360 if (kind_of_type && (!Strcmp(kind_of_type, "struct") 361 || !Strcmp(kind_of_type, "union")) && cDeclName && !unnamed) { 362 k = NewStringf("%s %s", kind_of_type, cDeclName); 363 } else { 364 if (!Strcmp(nodeType(n), "enum") && unnamed) { 365 name = NewStringf("%s%d", anon_type_name, anon_type_count++); 366 k = NewStringf("enum %s", name); 367 Setattr(n, "allegrocl:name", name); 368 369 } else { 370 k = k ? k : Getattr(n, "name"); 371 } 372 } 373 } 374 // Swig_print_node(n); 375 } 376 377 if (SwigType_istemplate(name)) { 378 String *temp = strip_namespaces(SwigType_templateprefix(name)); 379 name = NewStringf("%s%s%s", temp, SwigType_templateargs(name), SwigType_templatesuffix(name)); 380 } 381 382 val = lookup_defined_foreign_type(k); 383 384 int is_fwd_ref = 0; 385 if (val) 386 is_fwd_ref = !Strcmp(val, "forward-reference"); 387 388 if (!val || overwrite || is_fwd_ref) { 389#ifdef ALLEGROCL_CLASS_DEBUG 390 Printf(stderr, "Adding defined type '%s' = '%s' '%s' (overwrite=%d, in-class=%d)\n", k, ns, name, overwrite, in_class); 391#endif 392 String *mangled_name_gen = NewStringf("#.(swig-insert-id \"%s\" %s :type :type)", name, ns_list); 393 String *mangled_lname_gen = NewStringf("#.(swig-insert-id \"%s\" %s :type :class)", name, ns_list); 394 395 Setattr(defined_foreign_types, Copy(k), Copy(mangled_name_gen)); 396 Setattr(defined_foreign_ltypes, Copy(k), Copy(mangled_lname_gen)); 397 398 if (CPlusPlus) { 399 bool cpp_struct = Strstr(k, "struct ") ? true : false; 400 bool cpp_union = Strstr(k, "union ") ? true : false; 401 402 String *cpp_type = 0; 403 if (cpp_struct) { 404 cpp_type = Copy(k); 405 Replaceall(cpp_type, "struct ", ""); 406 } else if (cpp_union) { 407 cpp_type = Copy(k); 408 Replaceall(cpp_type, "union ", ""); 409 } 410 411 if (cpp_struct || cpp_union) { 412#ifdef ALLEGROCL_CLASS_DEBUG 413 Printf(stderr, " Also adding defined type '%s' = '%s' '%s' (overwrite=%d)\n", cpp_type, ns, name, overwrite); 414#endif 415 Setattr(defined_foreign_types, Copy(cpp_type), Copy(mangled_name_gen)); 416 Setattr(defined_foreign_ltypes, Copy(cpp_type), Copy(mangled_lname_gen)); 417 } 418 } 419#ifdef ALLEGROCL_CLASS_DEBUG 420 Printf(stderr, "looking to add %s/%s(%x) to linked_type_list...\n", k, name, n); 421#endif 422 if (is_fwd_ref) { 423 // Printf(stderr,"*** 1\n"); 424 add_linked_type(n); 425 } else { 426 // Printf(stderr,"*** 1-a\n"); 427 if (SwigType_istemplate(k)) { 428 SwigType *resolved = SwigType_typedef_resolve_all(k); 429 // Printf(stderr,"*** 1-b\n"); 430 Node *match = find_linked_type_by_name(resolved); 431 Node *new_node = 0; 432 // Printf(stderr, "*** temp-1\n"); 433 if (n) { 434 new_node = n; 435 } else { 436#ifdef ALLEGROCL_CLASS_DEBUG 437 Printf(stderr, "Creating a new templateInst:\n"); 438 Printf(stderr, " name = %s\n", resolved); 439 Printf(stderr, " sym:name = %s\n", name); 440 Printf(stderr, " real-name = %s\n", k); 441 Printf(stderr, " type = %s\n", resolved); 442 Printf(stderr, " ns = %s\n\n", ns); 443#endif 444 new_node = NewHash(); 445 Setattr(new_node, "nodeType", "templateInst"); 446 Setattr(new_node, "name", Copy(resolved)); 447 Setattr(new_node, "sym:name", Copy(name)); 448 Setattr(new_node, "real-name", Copy(k)); 449 Setattr(new_node, "type", Copy(resolved)); 450 Setattr(new_node, "allegrocl:namespace", ns); 451 Setattr(new_node, "allegrocl:package", ns); 452 } 453 454 if (!match) { 455 if (!Strcmp(nodeType(new_node), "templateInst") && in_class) { 456 /* this is an implicit template instantiation found while 457 walking a class. need to insert this into the 458 linked_type list before the current class definition */ 459#ifdef ALLEGROCL_CLASS_DEBUG 460 Printf(stderr, "trying to insert a templateInst before a class\n"); 461#endif 462 insert_linked_type_at(in_class, new_node); 463#ifdef ALLEGROCL_CLASS_DEBUG 464 Printf(stderr, "DID IT!\n"); 465#endif 466 } else { 467 // Printf(stderr,"*** 3\n"); 468 add_linked_type(new_node); 469 } 470 Setattr(new_node, "allegrocl:synonym:is-primary", "1"); 471 } else { 472 // a synonym type was found (held in variable 'match') 473 // Printf(stderr, "setting primary synonym of %x to %x\n", new_node, match); 474 if (new_node == match) 475 Printf(stderr, "Hey-4 * - '%s' is a synonym of iteself!\n", Getattr(new_node, "name")); 476 Setattr(new_node, "allegrocl:synonym-of", match); 477 // Printf(stderr,"*** 4\n"); 478 add_linked_type(new_node); 479 } 480 } else { 481 Node *match; 482 483 if (!Strcmp(nodeType(n), "cdecl") && !Strcmp(Getattr(n, "storage"), "typedef")) { 484 SwigType *type = SwigType_strip_qualifiers(Getattr(n, "type")); 485#ifdef ALLEGROCL_CLASS_DEBUG 486 Printf(stderr, "Examining typedef '%s' for class references. (%d)\n", type, SwigType_isclass(type)); 487#endif 488 if (SwigType_isclass(type)) { 489#ifdef ALLEGROCL_CLASS_DEBUG 490 Printf(stderr, "Found typedef of a class '%s'\n", type); 491#endif 492 /* 493 For the following parsed expression: 494 495 typedef struct __xxx { ... } xxx; 496 497 if n is of kind "class" (defining the class 'struct __xxx' 498 then we add n to the linked type list. 499 500 if n is "cdecl" node of storage "typedef" (to note 501 that xxx is equivalent to 'struct __xxx' then we don't 502 want to add this node to the linked type list. 503 */ 504 String *defined_type = lookup_defined_foreign_type(type); 505 String *defined_key_type = lookup_defined_foreign_type(k); 506 507 if ((Strstr(type, "struct ") || Strstr(type, "union ")) 508 && defined_type && !Strcmp(defined_type, defined_key_type)) { 509 // mark as a synonym but don't add to linked_type list 510 // Printf(stderr,"*** 4.8\n"); 511 Setattr(n, "allegrocl:synonym", "1"); 512 } else { 513 SwigType *lookup_type = SwigType_istemplate(type) ? SwigType_typedef_resolve_all(type) : Copy(type); 514 match = find_linked_type_by_name(lookup_type); 515 if (match) { 516 Setattr(n, "allegrocl:synonym", "1"); 517 Setattr(n, "allegrocl:synonym-of", match); 518 Setattr(n, "real-name", Copy(lookup_type)); 519 520 // Printf(stderr, "*** pre-5: found match of '%s'(%x)\n", Getattr(match,"name"),match); 521 // if(n == match) Printf(stderr, "Hey-5 *** setting synonym of %x to %x\n", n, match); 522 // Printf(stderr,"*** 5\n"); 523 add_linked_type(n); 524 } else { 525#ifdef ALLEGROCL_CLASS_DEBUG 526 Printf(stderr, "Creating classfoward node for struct stub in typedef.\n"); 527#endif 528 Node *new_node = NewHash(); 529 String *symname = Copy(type); 530 Replaceall(symname, "struct ", ""); 531 Setattr(new_node, "nodeType", "classforward"); 532 Setattr(new_node, "name", Copy(type)); 533 Setattr(new_node, "sym:name", symname); 534 Setattr(new_node, "allegrocl:namespace", ns); 535 Setattr(new_node, "allegrocl:package", ns); 536 537 String *mangled_new_name = NewStringf("#.(swig-insert-id \"%s\" %s)", symname, ns_list); 538 String *mangled_new_lname = NewStringf("#.(swig-insert-id \"%s\" %s :type :class)", symname, ns_list); 539 Setattr(defined_foreign_types, Copy(symname), Copy(mangled_new_name)); 540 Setattr(defined_foreign_ltypes, Copy(symname), Copy(mangled_new_lname)); 541 542 // Printf(stderr,"Weird! Can't find the type!\n"); 543 add_forward_referenced_type(new_node); 544 add_linked_type(new_node); 545 546 Setattr(n, "allegrocl:synonym", "1"); 547 Setattr(n, "allegrocl:synonym-of", new_node); 548 549 add_linked_type(n); 550 } 551 Delete(lookup_type); 552 } 553 } else { 554 // check if it's a pointer or reference to a class. 555 // Printf(stderr,"Checking if '%s' is a p. or r. to a class\n", type); 556 String *class_ref = class_from_class_or_class_ref(type); 557 if (class_ref) { 558 match = find_linked_type_by_name(class_ref); 559 Setattr(n, "allegrocl:synonym", "1"); 560 Setattr(n, "allegrocl:synonym-of", match); 561 add_linked_type(n); 562 } 563 } 564 Delete(type); 565 // synonym types have already been added. 566 // Printf(stderr,"*** 10\n"); 567 if (!Getattr(n, "allegrocl:synonym")) 568 add_linked_type(n); 569 } else if (Getattr(n, "template")) { 570 // Printf(stderr, "this is a class template node(%s)\n", nodeType(n)); 571 String *resolved = SwigType_typedef_resolve_all(Getattr(n, "name")); 572 573#ifdef ALLEGROCL_CLASS_DEBUG 574 Printf(stderr, " looking up %s for linked type match with %s...\n", Getattr(n, "sym:name"), resolved); 575#endif 576 match = find_linked_type_by_name(resolved); 577 if (!match) { 578#ifdef ALLEGROCL_CLASS_DEBUG 579 Printf(stderr, "found no implicit instantiation of %%template node %s(%x)\n", Getattr(n, "name"), n); 580#endif 581 add_linked_type(n); 582 } else { 583 Node *primary = get_primary_synonym_of(match); 584 585 Setattr(n, "allegrocl:synonym:is-primary", "1"); 586 Delattr(primary, "allegrocl:synonym:is-primary"); 587 if (n == match) 588 Printf(stderr, "Hey-7 * setting synonym of %x to %x\n (match = %x)", primary, n, match); 589 Setattr(primary, "allegrocl:synonym-of", n); 590 // Printf(stderr,"*** 7\n"); 591 add_linked_type(n); 592 } 593 } else { 594#ifdef ALLEGROCL_CLASS_DEBUG 595 Printf(stderr, "linking type '%s'(%x)\n", k, n); 596#endif 597 // Printf(stderr,"*** 8\n"); 598 add_linked_type(n); 599 } 600 } 601 } 602 Delete(mangled_name_gen); 603 Delete(mangled_lname_gen); 604 } else { 605 if (!CPlusPlus || Strcmp(Getattr(n,"kind"),"typedef")) { 606 Swig_warning(WARN_TYPE_REDEFINED, Getfile(n), Getline(n), 607 "Attempting to store a foreign type that exists: %s (%s)\n", 608 k, val); 609 } 610 } 611 612 Delete(ns_list); 613 614#ifdef ALLEGROCL_CLASS_DEBUG 615 Printf(stderr, "OUT A-D-F-T\n"); 616#endif 617} 618 619void note_implicit_template_instantiation(SwigType *t) { 620 // the namespace of the implicit instantiation is not necessarily 621 // current_namespace. Attempt to cull this from the type. 622#ifdef ALLEGROCL_CLASS_DEBUG 623 Printf(stderr, "culling namespace of '%s' from '%s'\n", t, SwigType_templateprefix(t)); 624#endif 625 String *implicit_ns = namespace_of(SwigType_templateprefix(t)); 626 add_defined_foreign_type(0, 0, t, t, implicit_ns ? implicit_ns : current_namespace); 627} 628 629String *get_ffi_type(Node *n, SwigType *ty, const_String_or_char_ptr name) { 630 /* lookup defined foreign type. 631 if it exists, it will return a form suitable for placing 632 into lisp code to generate the def-foreign-type name */ 633 634#ifdef ALLEGROCL_TYPE_DEBUG 635 Printf(stderr, "inside g_f_t: looking up '%s' '%s'\n", ty, name); 636#endif 637 638 String *found_type = lookup_defined_foreign_type(ty); 639 640 if (found_type) { 641#ifdef ALLEGROCL_TYPE_DEBUG 642 Printf(stderr, "found_type '%s'\n", found_type); 643#endif 644 return (Strcmp(found_type, "forward-reference") ? Copy(found_type) : get_ffi_type(n, fwdref_ffi_type, "")); 645 } else { 646 Node *node = NewHash(); 647 Setattr(node, "type", ty); 648 Setfile(node, Getfile(n)); 649 Setline(node, Getline(n)); 650 const String *tm = Swig_typemap_lookup("ffitype", node, name, 0); 651 Delete(node); 652 653 if (tm) { 654#ifdef ALLEGROCL_TYPE_DEBUG 655 Printf(stderr, "g-f-t: found ffitype typemap '%s'\n", tm); 656#endif 657 return NewString(tm); 658 } 659 660 if (SwigType_istemplate(ty)) { 661 note_implicit_template_instantiation(ty); 662 return Copy(lookup_defined_foreign_type(ty)); 663 } 664 } 665 return 0; 666} 667 668String *lookup_defined_foreign_ltype(String *l) { 669 670#ifdef ALLEGROCL_TYPE_DEBUG 671 Printf(stderr, "Looking up defined ltype '%s'.\n Found: '%s'\n", l, Getattr(defined_foreign_ltypes, l)); 672#endif 673 return Getattr(defined_foreign_ltypes, l); 674} 675 676/* walk type and return string containing lisp version. 677 recursive. */ 678String *internal_compose_foreign_type(Node *n, SwigType *ty) { 679 680 SwigType *tok; 681 String *ffiType = NewString(""); 682 683 // for a function type, need to walk the parm list. 684 while (Len(ty) != 0) { 685 tok = SwigType_pop(ty); 686 687 if (SwigType_isfunction(tok)) { 688 // Generate Function wrapper 689 Printf(ffiType, "(:function "); 690 // walk parm list 691 List *pl = SwigType_parmlist(tok); 692 693 Printf(ffiType, "("); // start parm list 694 for (Iterator i = First(pl); i.item; i = Next(i)) { 695 SwigType *f_arg = SwigType_strip_qualifiers(i.item); 696 Printf(ffiType, "%s ", internal_compose_foreign_type(n, f_arg)); 697 Delete(f_arg); 698 } 699 Printf(ffiType, ")"); // end parm list. 700 701 // do function return type. 702 Printf(ffiType, " %s)", internal_compose_foreign_type(n, ty)); 703 break; 704 } else if (SwigType_ispointer(tok) || SwigType_isreference(tok)) { 705 Printf(ffiType, "(* %s)", internal_compose_foreign_type(n, ty)); 706 } else if (SwigType_isarray(tok)) { 707 Printf(ffiType, "(:array %s", internal_compose_foreign_type(n, ty)); 708 String *atype = NewString("int"); 709 String *dim = convert_literal(SwigType_array_getdim(tok, 0), atype); 710 Delete(atype); 711 if (is_integer(dim)) { 712 Printf(ffiType, " %s)", dim); 713 } else { 714 Printf(ffiType, " #| %s |#)", SwigType_array_getdim(tok, 0)); 715 } 716 } else if (SwigType_ismemberpointer(tok)) { 717 // temp 718 Printf(ffiType, "(* %s)", internal_compose_foreign_type(n, ty)); 719 } else { 720 String *res = get_ffi_type(n, tok, ""); 721 if (res) { 722 Printf(ffiType, "%s", res); 723 } else { 724 SwigType *resolved_type = SwigType_typedef_resolve(tok); 725 if (resolved_type) { 726 res = get_ffi_type(n, resolved_type, ""); 727 if (res) { 728 } else { 729 res = internal_compose_foreign_type(n, resolved_type); 730 } 731 if (res) 732 Printf(ffiType, "%s", res); 733 } 734 735 if (!res) { 736 String *is_struct = 0; 737 String *tok_remove_text = 0; 738 String *tok_name = Copy(tok); 739 String *tok_key = SwigType_str(tok,0); 740 if ((is_struct = Strstr(tok_key, "struct ")) || Strstr(tok_key, "union ")) { 741 tok_remove_text = NewString(is_struct ? "struct " : "union "); 742 } 743 744 /* be more permissive of opaque types. This is the swig way. 745 compiles will notice if these types are ultimately not 746 present. */ 747 748 if(tok_remove_text) { 749 Replaceall(tok_name,tok_remove_text,""); 750 } 751 tok_name = strip_namespaces(tok_name); 752 Delete(tok_remove_text); 753 // Swig_warning(WARN_TYPE_UNDEFINED_CLASS, Getfile(tok), Getline(tok), "Unable to find definition of '%s', assuming forward reference.\n", tok); 754 755#ifdef ALLEGROCL_TYPE_DEBUG 756 Printf(stderr, "i-c-f-t: adding forward reference for unknown type '%s'. mapping: %s -> %s\n", tok, tok_key, tok_name); 757#endif 758 Node *nn = NewHash(); 759 Setattr(nn,"nodeType","classforward"); 760 Setattr(nn,"kind","class"); 761 Setattr(nn,"sym:name",tok_name); 762 Setattr(nn,"name",tok_key); 763 Setattr(nn,"allegrocl:package",current_namespace); 764 765 add_forward_referenced_type(nn, 0); 766 // tok_name is dangling here, unused. ouch. why? 767 Printf(ffiType, "%s", get_ffi_type(n, tok, ""), tok_name); 768 } 769 } 770 } 771 } 772 return ffiType; 773} 774 775String *compose_foreign_type(Node *n, SwigType *ty, String * /*id*/ = 0) { 776 777#ifdef ALLEGROCL_TYPE_DEBUG 778 Printf(stderr, "compose_foreign_type: ENTER (%s)...\n ", ty); 779 // Printf(stderr, "compose_foreign_type: ENTER (%s)(%s)...\n ", ty, (id ? id : 0)); 780 /* String *id_ref = SwigType_str(ty, id); 781 Printf(stderr, "looking up typemap for %s, found '%s'(%x)\n", 782 id_ref, lookup_res ? Getattr(lookup_res, "code") : 0, lookup_res); 783 if (lookup_res) Swig_print_node(lookup_res); 784 */ 785#endif 786 787 /* should we allow named lookups in the typemap here? YES! */ 788 /* unnamed lookups should be found in get_ffi_type, called 789 by internal_compose_foreign_type(), below. */ 790 791 /* I'm reverting to 'no' for the question above. I can no longer 792 remember why I needed it. If a user needed it, I'll find out 793 as soon as they upgrade. Sigh. -mutandiz 9/16/2008. */ 794 795/* 796 if(id && lookup_res) { 797#ifdef ALLEGROCL_TYPE_DEBUG 798 Printf(stderr, "compose_foreign_type: EXIT-1 (%s)\n ", Getattr(lookup_res, "code")); 799#endif 800 return NewString(Getattr(lookup_res, "code")); 801 } 802*/ 803 804 SwigType *temp = SwigType_strip_qualifiers(ty); 805 String *res = internal_compose_foreign_type(n, temp); 806 Delete(temp); 807 808#ifdef ALLEGROCL_TYPE_DEBUG 809 Printf(stderr, "compose_foreign_type: EXIT (%s)\n ", res); 810#endif 811 812 return res; 813} 814 815void update_package_if_needed(Node *n, File *f = f_clwrap) { 816#ifdef ALLEGROCL_DEBUG 817 Printf(stderr, "update_package: ENTER... \n"); 818 Printf(stderr, " current_package = '%s'\n", current_package); 819 Printf(stderr, " node_package = '%s'\n", Getattr(n, "allegrocl:package")); 820 Printf(stderr, " node(%x) = '%s'\n", n, Getattr(n, "name")); 821#endif 822 String *node_package = Getattr(n, "allegrocl:package"); 823 if (Strcmp(current_package, node_package)) { 824 String *lispy_package = listify_namespace(node_package); 825 826 Delete(current_package); 827 current_package = Copy(node_package); 828 Printf(f, "\n(swig-in-package %s)\n", lispy_package); 829 Delete(lispy_package); 830 } 831#ifdef ALLEGROCL_DEBUG 832 Printf(stderr, "update_package: EXIT.\n"); 833#endif 834} 835 836static String *mangle_name(Node *n, char const *prefix = "ACL", String *ns = current_namespace) { 837 String *suffix = Getattr(n, "sym:overname"); 838 String *pre_mangled_name = NewStringf("%s_%s__%s%s", prefix, ns, Getattr(n, "sym:name"), suffix); 839 String *mangled_name = Swig_name_mangle(pre_mangled_name); 840 Delete(pre_mangled_name); 841 return mangled_name; 842} 843 844/* utilities */ 845 846/* remove a pointer from ffitype. non-destructive. 847 (* :char) ==> :char 848 (* (:array :int 30)) ==> (:array :int 30) */ 849String *dereference_ffitype(String *ffitype) { 850 char *start; 851 char *temp = Char(ffitype); 852 String *reduced_type = 0; 853 854 if(temp && temp[0] == '(' && temp[1] == '*') { 855 temp += 2; 856 857 // walk past start of pointer references 858 while(*temp == ' ') temp++; 859 start = temp; 860 // temp = Char(reduced_type); 861 reduced_type = NewString(start); 862 temp = Char(reduced_type); 863 // walk to end of string. remove closing paren 864 while(*temp != '\0') temp++; 865 *(--temp) = '\0'; 866 } 867 868 return reduced_type ? reduced_type : Copy(ffitype); 869} 870 871/* returns new string w/ parens stripped */ 872String *strip_parens(String *string) { 873 string = Copy(string); 874 Replaceall(string, "(", ""); 875 Replaceall(string, ")", ""); 876 return string; 877} 878 879int ALLEGROCL::validIdentifier(String *s) { 880#ifdef ALLEGROCL_DEBUG 881 Printf(stderr, "validIdentifier %s\n", s); 882#endif 883 884 char *c = Char(s); 885 886 bool got_dot = false; 887 bool only_dots = true; 888 889 /* Check that s is a valid common lisp symbol. There's a lot of leeway here. 890 A common lisp symbol is essentially any token that's not a number and 891 does not consist of only dots. 892 893 We are expressly not allowing spaces in identifiers here, but spaces 894 could be added via the identifier converter. */ 895 while (*c) { 896 if (*c == '.') { 897 got_dot = true; 898 } else { 899 only_dots = false; 900 } 901 if (!isgraph(*c)) 902 return 0; 903 c++; 904 } 905 906 return (got_dot && only_dots) ? 0 : 1; 907} 908 909String *infix_to_prefix(String *val, char split_op, const String *op, String *type) { 910 List *ored = Split(val, split_op, -1); 911 912 // some float hackery 913 if (((split_op == '+') || (split_op == '-')) && Len(ored) == 2 && 914 (SwigType_type(type) == T_FLOAT || SwigType_type(type) == T_DOUBLE || SwigType_type(type) == T_LONGDOUBLE)) { 915 // check that we're not splitting a float 916 String *possible_result = convert_literal(val, type, false); 917 if (possible_result) 918 return possible_result; 919 920 } 921 // try parsing the split results. if any part fails, kick out. 922 bool part_failed = false; 923 if (Len(ored) > 1) { 924 String *result = NewStringf("(%s", op); 925 for (Iterator i = First(ored); i.item; i = Next(i)) { 926 String *converted = convert_literal(i.item, type); 927 if (converted) { 928 Printf(result, " %s", converted); 929 Delete(converted); 930 } else { 931 part_failed = true; 932 break; 933 } 934 } 935 Printf(result, ")"); 936 Delete(ored); 937 return part_failed ? 0 : result; 938 } 939 Delete(ored); 940 return 0; 941} 942 943/* To be called by code generating the lisp interface 944 Will return a containing the literal based on type. 945 Will return null if there are problems. 946 947 try_to_split defaults to true (see stub above). 948 */ 949String *convert_literal(String *literal, String *type, bool try_to_split) { 950 String *num_param = Copy(literal); 951 String *trimmed = trim(num_param); 952 String *num = strip_parens(trimmed), *res = 0; 953 char *s = Char(num); 954 955 String *ns = listify_namespace(current_namespace); 956 957 // very basic parsing of infix expressions. 958 if (try_to_split && SwigType_type(type) != T_STRING) { 959 if ((res = infix_to_prefix(num, '|', "logior", type))) 960 return res; 961 if ((res = infix_to_prefix(num, '&', "logand", type))) 962 return res; 963 if ((res = infix_to_prefix(num, '^', "logxor", type))) 964 return res; 965 if ((res = infix_to_prefix(num, '*', "*", type))) 966 return res; 967 if ((res = infix_to_prefix(num, '/', "/", type))) 968 return res; 969 if ((res = infix_to_prefix(num, '+', "+", type))) 970 return res; 971 if ((res = infix_to_prefix(num, '-', "-", type))) 972 return res; 973 // if ((res = infix_to_prefix(num, '~', "lognot", type))) return res; 974 // if( (res = infix_to_prefix(num, '<<', "ash", type)) ) return res; 975 } 976 977 // unary complement... 978 if (s[0] == '~' && Len(num) >= 2) { 979 String *id = NewString(++s); 980 String *id_conv = convert_literal(id, type, false); 981 Delete(id); 982 if (id_conv) 983 return NewStringf("(lognot %s)", id_conv); 984 s--; 985 } 986 987 if (SwigType_type(type) == T_FLOAT || SwigType_type(type) == T_DOUBLE || SwigType_type(type) == T_LONGDOUBLE) { 988 // Use CL syntax for float literals 989 String *oldnum = Copy(num); 990 991 // careful. may be a float identifier or float constant. 992 char *num_start = Char(num); 993 char *num_end = num_start + strlen(num_start) - 1; 994 995 bool is_literal = isdigit(*num_start) || (*num_start == '.'); 996 997 String *lisp_exp = 0; 998 if (is_literal) { 999 if (*num_end == 'f' || *num_end == 'F') { 1000 lisp_exp = NewString("f"); 1001 } else { 1002 lisp_exp = NewString("d"); 1003 } 1004 1005 if (*num_end == 'l' || *num_end == 'L' || *num_end == 'f' || *num_end == 'F') { 1006 *num_end = '\0'; 1007 num_end--; 1008 } 1009 1010 int exponents = Replaceall(num, "e", lisp_exp) + Replaceall(num, "E", lisp_exp); 1011 1012 if (!exponents) 1013 Printf(num, "%s0", lisp_exp); 1014 1015 if (exponents > 1 || (exponents + Replaceall(num, ".", ".") == 0)) { 1016 // Printf(stderr, "Can't parse '%s' as type '%s'.\n", oldnum, type); 1017 Delete(num); 1018 num = 0; 1019 } 1020 Delete(lisp_exp); 1021 } else { 1022 String *id = NewStringf("#.(swig-insert-id \"%s\" %s :type :constant)", 1023 num, ns); 1024 Delete(num); 1025 num = id; 1026 } 1027 1028 Delete(oldnum); 1029 Delete(trimmed); 1030 Delete(ns); 1031 return num; 1032 } else if (SwigType_type(type) == T_CHAR) { 1033 /* Use CL syntax for character literals */ 1034 Delete(num); 1035 Delete(trimmed); 1036 return NewStringf("#\\%s", num_param); 1037 } else if (SwigType_type(type) == T_STRING) { 1038 /* Use CL syntax for string literals */ 1039 Delete(num); 1040 Delete(trimmed); 1041 return NewStringf("\"%s\"", num_param); 1042 } else if (Len(num) >= 1 && (isdigit(s[0]) || s[0] == '+' || s[0] == '-')) { 1043 /* use CL syntax for numbers */ 1044 String *oldnum = Copy(num); 1045 int usuffixes = Replaceall(num, "u", "") + Replaceall(num, "U", ""); 1046 int lsuffixes = Replaceall(num, "l", "") + Replaceall(num, "L", ""); 1047 if (usuffixes > 1 || lsuffixes > 1) { 1048 Printf(stderr, "Weird!! number %s looks invalid.\n", oldnum); 1049 SWIG_exit(EXIT_FAILURE); 1050 } 1051 s = Char(num); 1052 if (s[0] == '0' && Len(num) >= 2) { 1053 /*octal or hex */ 1054 res = NewStringf("#%c%s", tolower(s[1]) == 'x' ? 'x' : 'o', s + 2); 1055 Delete(num); 1056 } else { 1057 res = num; 1058 } 1059 Delete(oldnum); 1060 Delete(trimmed); 1061 return res; 1062 } else if (allegrocl->validIdentifier(num)) { 1063 /* convert C/C++ identifiers to CL symbols */ 1064 res = NewStringf("#.(swig-insert-id \"%s\" %s :type :constant)", num, ns); 1065 Delete(num); 1066 Delete(trimmed); 1067 Delete(ns); 1068 return res; 1069 } else { 1070 Delete(trimmed); 1071 return num; 1072 } 1073} 1074 1075 1076void emit_stub_class(Node *n) { 1077 1078#ifdef ALLEGROCL_WRAP_DEBUG 1079 Printf(stderr, "emit_stub_class: ENTER... '%s'(%x)\n", Getattr(n, "sym:name"), n); 1080#endif 1081 1082 1083 String *name = Getattr(n, "sym:name"); 1084 1085 if (Getattr(n, "allegrocl:synonym:already-been-stubbed")) 1086 return; 1087 1088 if (SwigType_istemplate(name)) { 1089 String *temp = strip_namespaces(SwigType_templateprefix(name)); 1090 name = NewStringf("%s%s%s", temp, SwigType_templateargs(name), SwigType_templatesuffix(name)); 1091 1092 Delete(temp); 1093 } else { 1094 name = strip_namespaces(name); 1095 } 1096 1097 // Printf(f_clhead, ";; from emit-stub-class\n"); 1098 update_package_if_needed(n, f_clhead); 1099 Printf(f_clhead, ";; class template stub.\n"); 1100 Printf(f_clhead, "(swig-def-foreign-stub \"%s\")\n", name); 1101 1102 Setattr(n, "allegrocl:synonym:already-been-stubbed", "1"); 1103 1104#ifdef ALLEGROCL_WRAP_DEBUG 1105 Printf(stderr, "emit_stub_class: EXIT\n"); 1106#endif 1107} 1108 1109void emit_synonym(Node *synonym) { 1110 1111#ifdef ALLEGROCL_WRAP_DEBUG 1112 Printf(stderr, "emit_synonym: ENTER... \n"); 1113#endif 1114 1115 // Printf(stderr,"in emit_synonym for %s(%x)\n", Getattr(synonym,"name"),synonym); 1116 int is_tempInst = !Strcmp(nodeType(synonym), "templateInst"); 1117 String *synonym_type; 1118 1119 Node *of = get_primary_synonym_of(synonym); 1120 1121 if (is_tempInst) { 1122 // Printf(stderr, "*** using real-name '%s'\n", Getattr(synonym,"real-name")); 1123 synonym_type = Getattr(synonym, "real-name"); 1124 } else { 1125 // Printf(stderr, "*** using name '%s'\n", Getattr(synonym,"name")); 1126 synonym_type = Getattr(synonym, "name"); 1127 } 1128 1129 String *synonym_ns = listify_namespace(Getattr(synonym, "allegrocl:namespace")); 1130 String *syn_ltype, *syn_type, *of_ltype; 1131 // String *of_cdeclname = Getattr(of,"allegrocl:classDeclarationName"); 1132 String *of_ns = Getattr(of, "allegrocl:namespace"); 1133 String *of_ns_list = listify_namespace(of_ns); 1134 // String *of_name = of_cdeclname ? NewStringf("struct %s", Getattr(of,"name")) : NewStringf("%s::%s", of_ns, Getattr(of,"sym:name")); 1135 // String *of_name = NewStringf("%s::%s", of_ns, Getattr(of,"sym:name")); 1136 String *of_name = namespaced_name(of, of_ns); 1137 1138 if (CPlusPlus && !Strcmp(nodeType(synonym), "cdecl")) { 1139 syn_ltype = NewStringf("#.(swig-insert-id \"%s\" %s :type :class)", 1140 strip_namespaces(Getattr(synonym, "real-name")), synonym_ns); 1141 syn_type = NewStringf("#.(swig-insert-id \"%s\" %s :type :type)", 1142 strip_namespaces(Getattr(synonym, "real-name")), synonym_ns); 1143 } else { 1144 syn_ltype = lookup_defined_foreign_ltype(synonym_type); 1145 syn_type = lookup_defined_foreign_type(synonym_type); 1146 } 1147 1148 of_ltype = lookup_defined_foreign_ltype(of_name); 1149 1150 // Printf(stderr,";; from emit-synonym syn='%s' of_ltype='%s'\n", syn_ltype, of_ltype); 1151 if( of_ltype ) 1152 Printf(f_clhead, "(swig-def-synonym-type %s\n %s\n %s)\n", syn_ltype, of_ltype, syn_type); 1153 1154 Delete(synonym_ns); 1155 Delete(of_ns_list); 1156 Delete(of_name); 1157 1158#ifdef ALLEGROCL_WRAP_DEBUG 1159 Printf(stderr, "emit_synonym: EXIT\n"); 1160#endif 1161} 1162 1163void emit_full_class(Node *n) { 1164 1165#ifdef ALLEGROCL_WRAP_DEBUG 1166 Printf(stderr, "emit_full_class: ENTER... \n"); 1167#endif 1168 1169 String *name = Getattr(n, "sym:name"); 1170 String *kind = Getattr(n, "kind"); 1171 1172 // Printf(stderr,"in emit_full_class: '%s'(%x).", Getattr(n,"name"),n); 1173 if (Getattr(n, "allegrocl:synonym-of")) { 1174 // Printf(stderr,"but it's a synonym of something.\n"); 1175 update_package_if_needed(n, f_clhead); 1176 emit_synonym(n); 1177 return; 1178 } 1179 // collect superclasses 1180 String *bases = Getattr(n, "bases"); 1181 String *supers = NewString("("); 1182 if (bases) { 1183 int first = 1; 1184 for (Iterator i = First(bases); i.item; i = Next(i)) { 1185 if (!first) 1186 Printf(supers, " "); 1187 String *s = lookup_defined_foreign_ltype(Getattr(i.item, "name")); 1188 // String *name = Getattr(i.item,"name"); 1189 if (s) { 1190 Printf(supers, "%s", s); 1191 } else { 1192#ifdef ALLEGROCL_TYPE_DEBUG 1193 Printf(stderr, "emit_templ_inst: did not find ltype for base class %s (%s)", Getattr(i.item, "name"), Getattr(n, "allegrocl:namespace")); 1194#endif 1195 } 1196 } 1197 } else { 1198 Printf(supers, "ff:foreign-pointer"); 1199 } 1200 1201 Printf(supers, ")"); 1202 1203 // Walk children to generate type definition. 1204 String *slotdefs = NewString(" "); 1205 1206#ifdef ALLEGROCL_WRAP_DEBUG 1207 Printf(stderr, " walking children...\n"); 1208#endif 1209 1210 Node *c; 1211 for (c = firstChild(n); c; c = nextSibling(c)) { 1212 String *storage_type = Getattr(c, "storage"); 1213 if ((!Strcmp(nodeType(c), "cdecl") && (!storage_type || Strcmp(storage_type, "typedef")))) { 1214 String *access = Getattr(c, "access"); 1215 1216 // hack. why would decl have a value of "variableHandler" and now "0"? 1217 String *childDecl = Getattr(c, "decl"); 1218 // Printf(stderr,"childDecl = '%s' (%s)\n", childDecl, Getattr(c,"view")); 1219 if (!Strcmp(childDecl, "0")) 1220 childDecl = NewString(""); 1221 1222 SwigType *childType; 1223 String *cname; 1224 1225 // don't include types for private slots (yet). spr33959. 1226 if(access && Strcmp(access,"public")) { 1227 childType = NewStringf("int"); 1228 cname = NewString("nil"); 1229 } else { 1230 childType = NewStringf("%s%s", childDecl, Getattr(c, "type")); 1231 cname = Copy(Getattr(c, "name")); 1232 } 1233 1234 if (!SwigType_isfunction(childType)) { 1235 // Printf(slotdefs, ";;; member functions don't appear as slots.\n "); 1236 // Printf(slotdefs, ";; "); 1237 String *ns = listify_namespace(Getattr(n, "allegrocl:package")); 1238 1239#ifdef ALLEGROCL_WRAP_DEBUG 1240 Printf(stderr, "slot name = '%s' ns = '%s' class-of '%s' and type = '%s'\n", cname, ns, name, childType); 1241#endif 1242 Printf(slotdefs, "(#.(swig-insert-id \"%s\" %s :type :slot :class \"%s\") %s)", cname, ns, name, compose_foreign_type(n, childType)); 1243 Delete(ns); 1244 if (access && Strcmp(access, "public")) 1245 Printf(slotdefs, " ;; %s member", access); 1246 1247 Printf(slotdefs, "\n "); 1248 } 1249 Delete(childType); 1250 Delete(cname); 1251 } 1252 } 1253 1254 String *ns_list = listify_namespace(Getattr(n, "allegrocl:namespace")); 1255 update_package_if_needed(n, f_clhead); 1256 Printf(f_clhead, "(swig-def-foreign-class \"%s\"\n %s\n (:%s\n%s))\n\n", name, supers, kind, slotdefs); 1257 1258 Delete(supers); 1259 Delete(ns_list); 1260 1261 Setattr(n, "allegrocl:synonym:already-been-stubbed", "1"); 1262#ifdef ALLEGROCL_WRAP_DEBUG 1263 Printf(stderr, "emit_full_class: EXIT\n"); 1264#endif 1265 1266} 1267 1268void emit_class(Node *n) { 1269 1270#ifdef ALLEGROCL_WRAP_DEBUG 1271 Printf(stderr, "emit_class: ENTER... '%s'(%x)\n", Getattr(n, "sym:name"), n); 1272#endif 1273 1274 int is_tempInst = !Strcmp(nodeType(n), "templateInst"); 1275 1276 String *ns_list = listify_namespace(Getattr(n, "allegrocl:namespace")); 1277 String *name = Getattr(n, is_tempInst ? "real-name" : "name"); 1278 1279 if (SwigType_istemplate(name)) { 1280 String *temp = strip_namespaces(SwigType_templateprefix(name)); 1281 name = NewStringf("%s%s%s", temp, SwigType_templateargs(name), SwigType_templatesuffix(name)); 1282 1283 Delete(temp); 1284 } else { 1285 name = strip_namespaces(name); 1286 } 1287 1288 if (Getattr(n, "allegrocl:synonym:is-primary")) { 1289 // Printf(stderr," is primary... "); 1290 if (is_tempInst) { 1291 emit_stub_class(n); 1292 } else { 1293 emit_full_class(n); 1294 } 1295 } else { 1296 // Node *primary = Getattr(n,"allegrocl:synonym-of"); 1297 Node *primary = get_primary_synonym_of(n); 1298 if (primary && (primary != n)) { 1299 // Printf(stderr," emitting synonym... "); 1300 emit_stub_class(primary); 1301 update_package_if_needed(n, f_clhead); 1302 emit_synonym(n); 1303 } else { 1304 emit_full_class(n); 1305 } 1306 } 1307 // Printf(stderr,"DONE\n"); 1308 Delete(name); 1309 Delete(ns_list); 1310 1311#ifdef ALLEGROCL_WRAP_DEBUG 1312 Printf(stderr, "emit_class: EXIT\n"); 1313#endif 1314} 1315 1316void emit_typedef(Node *n) { 1317 1318#ifdef ALLEGROCL_WRAP_DEBUG 1319 Printf(stderr, "emit_typedef: ENTER... \n"); 1320#endif 1321 1322 String *name; 1323 String *sym_name = Getattr(n, "sym:name"); 1324 String *type = NewStringf("%s%s", Getattr(n, "decl"), Getattr(n, "type")); 1325 String *lisp_type = compose_foreign_type(n, type); 1326 Delete(type); 1327 Node *in_class = Getattr(n, "allegrocl:typedef:in-class"); 1328 1329 // Printf(stderr,"in emit_typedef: '%s'(%x).",Getattr(n,"name"),n); 1330 if (Getattr(n, "allegrocl:synonym-of")) { 1331 // Printf(stderr," but it's a synonym of something.\n"); 1332 emit_synonym(n); 1333 return; 1334 } 1335 1336 if (in_class) { 1337 String *class_name = Getattr(in_class, "name"); 1338 if (SwigType_istemplate(class_name)) { 1339 String *temp = strip_namespaces(SwigType_templateprefix(class_name)); 1340 class_name = NewStringf("%s%s%s", temp, SwigType_templateargs(class_name), SwigType_templatesuffix(class_name)); 1341 Delete(temp); 1342 } 1343 1344 name = NewStringf("%s__%s", class_name, sym_name); 1345 Setattr(n, "allegrocl:in-class", in_class); 1346 } else { 1347 name = sym_name ? Copy(sym_name) : Copy(Getattr(n, "name")); 1348 } 1349 1350 // leave these in for now. might want to change these to def-foreign-class at some point. 1351// Printf(f_clhead, ";; %s\n", SwigType_typedef_resolve_all(lisp_type)); 1352 Printf(f_clhead, "(swig-def-foreign-type \"%s\"\n %s)\n", name, lisp_type); 1353 1354 Delete(name); 1355 1356#ifdef ALLEGROCL_WRAP_DEBUG 1357 Printf(stderr, "emit_typedef: EXIT\n"); 1358#endif 1359} 1360 1361void emit_enum_type_no_wrap(Node *n) { 1362 1363#ifdef ALLEGROCL_WRAP_DEBUG 1364 Printf(stderr, "emit_enum_type_no_wrap: ENTER... \n"); 1365#endif 1366 1367 String *unnamed = Getattr(n, "unnamed"); 1368 String *name; 1369 // SwigType *enumtype; 1370 1371 name = unnamed ? Getattr(n, "allegrocl:name") : Getattr(n, "sym:name"); 1372 SwigType *tmp = NewStringf("enum %s", unnamed ? unnamed : name); 1373 1374 Node *node = NewHash(); 1375 Setattr(node, "type", tmp); 1376 Setfile(node, Getfile(n)); 1377 Setline(node, Getline(n)); 1378 const String *enumtype = Swig_typemap_lookup("ffitype", node, "", 0); 1379 Delete(node); 1380 1381 Delete(tmp); 1382 1383 if (name) { 1384 String *ns = listify_namespace(current_namespace); 1385 1386 Printf(f_clhead, "(swig-def-foreign-type \"%s\" %s)\n", name, enumtype); 1387 Delete(ns); 1388 1389 // walk children. 1390 Node *c; 1391 for (c = firstChild(n); c; c = nextSibling(c)) { 1392 if (!Getattr(c, "error")) { 1393 String *val = Getattr(c, "enumvalue"); 1394 if (!val) 1395 val = Getattr(c, "enumvalueex"); 1396 String *converted_val = convert_literal(val, Getattr(c, "type")); 1397 String *valname = Getattr(c, "sym:name"); 1398 1399 if (converted_val) { 1400 Printf(f_clhead, "(swig-defconstant \"%s\" %s)\n", valname, converted_val); 1401 Delete(converted_val); 1402 } else { 1403 Swig_warning(WARN_LANG_DISCARD_CONST, Getfile(n), Getline(n), "Unable to parse enum value '%s'. Setting to NIL\n", val); 1404 Printf(f_clhead, "(swig-defconstant \"%s\" nil #| %s |#)\n", valname, val); 1405 } 1406 } 1407 } 1408 } 1409 Printf(f_clhead, "\n"); 1410 1411#ifdef ALLEGROCL_WRAP_DEBUG 1412 Printf(stderr, "emit_enum_type_no_wrap: EXIT\n"); 1413#endif 1414 1415} 1416 1417void emit_enum_type(Node *n) { 1418 1419#ifdef ALLEGROCL_WRAP_DEBUG 1420 Printf(stderr, "emit_enum_type: ENTER... \n"); 1421#endif 1422 1423 if (!Generate_Wrapper) { 1424 emit_enum_type_no_wrap(n); 1425 return; 1426 } 1427 1428 String *unnamed = Getattr(n, "unnamed"); 1429 String *name; 1430 // SwigType *enumtype; 1431 1432 name = unnamed ? Getattr(n, "allegrocl:name") : Getattr(n, "sym:name"); 1433 SwigType *tmp = NewStringf("enum %s", unnamed ? unnamed : name); 1434 1435 Node *node = NewHash(); 1436 Setattr(node, "type", tmp); 1437 Setfile(node, Getfile(n)); 1438 Setline(node, Getline(n)); 1439 const String *enumtype = Swig_typemap_lookup("ffitype", node, "", 0); 1440 Delete(node); 1441 1442 Delete(tmp); 1443 1444 if (name) { 1445 String *ns = listify_namespace(current_namespace); 1446 1447 Printf(f_clhead, "(swig-def-foreign-type \"%s\" %s)\n", name, enumtype); 1448 Delete(ns); 1449 1450 // walk children. 1451 Node *c; 1452 for(c = firstChild(n); c; c=nextSibling(c)) { 1453 String *mangled_name = mangle_name(c, "ACL_ENUM", Getattr(c,"allegrocl:package")); 1454 Printf(f_clhead, "(swig-defvar \"%s\" \"%s\" :type :constant :ftype :signed-long)\n", Getattr(c, "sym:name"), mangled_name); 1455 Delete(mangled_name); 1456 } 1457 } 1458#ifdef ALLEGROCL_WRAP_DEBUG 1459 Printf(stderr, "emit_enum_type: EXIT\n"); 1460#endif 1461 1462} 1463 1464void emit_default_linked_type(Node *n) { 1465 1466#ifdef ALLEGROCL_WRAP_DEBUG 1467 Printf(stderr, "emit_default_linked_type: ENTER... \n"); 1468#endif 1469 1470 // catchall for non class types. 1471 if (!Strcmp(nodeType(n), "classforward")) { 1472 Printf(f_clhead, ";; forward referenced stub.\n"); 1473 Printf(f_clhead, "(swig-def-foreign-class \"%s\" (ff:foreign-pointer) (:class ))\n\n", Getattr(n, "sym:name")); 1474 } else if (!Strcmp(nodeType(n), "enum")) { 1475 emit_enum_type(n); 1476 } else { 1477 Printf(stderr, "Don't know how to emit node type '%s' named '%s'\n", nodeType(n), Getattr(n, "name")); 1478 } 1479 1480#ifdef ALLEGROCL_WRAP_DEBUG 1481 Printf(stderr, "emit_default_linked_type: EXIT\n"); 1482#endif 1483 1484} 1485 1486void dump_linked_types(File *f) { 1487 Node *n = first_linked_type; 1488 int i = 0; 1489 while (n) { 1490 Printf(f, "%d: (%x) node '%s' name '%s'\n", i++, n, nodeType(n), Getattr(n, "sym:name")); 1491 1492 Node *t = Getattr(n, "allegrocl:synonym-of"); 1493 if (t) 1494 Printf(f, " synonym-of %s(%x)\n", Getattr(t, "name"), t); 1495 n = Getattr(n, "allegrocl:next_linked_type"); 1496 } 1497} 1498 1499void emit_linked_types() { 1500 1501#ifdef ALLEGROCL_WRAP_DEBUG 1502 Printf(stderr, "emit_linked_types: ENTER... "); 1503#endif 1504 1505 Node *n = first_linked_type; 1506 1507 while (n) { 1508 String *node_type = nodeType(n); 1509 1510 // Printf(stderr,"emitting node %s(%x) of type %s.", Getattr(n,"name"),n, nodeType(n)); 1511 if (!Strcmp(node_type, "class") || !Strcmp(node_type, "templateInst")) { 1512 // may need to emit a stub, so it will update the package itself. 1513 // Printf(stderr," Passing to emit_class."); 1514 emit_class(n); 1515 } else if (!Strcmp(nodeType(n), "cdecl")) { 1516 // Printf(stderr," Passing to emit_typedef."); 1517 update_package_if_needed(n, f_clhead); 1518 emit_typedef(n); 1519 } else { 1520 // Printf(stderr," Passing to default_emitter."); 1521 update_package_if_needed(n, f_clhead); 1522 emit_default_linked_type(n); 1523 } 1524 1525 n = Getattr(n, "allegrocl:next_linked_type"); 1526 // Printf(stderr,"returned.\n"); 1527 } 1528 1529#ifdef ALLEGROCL_WRAP_DEBUG 1530 Printf(stderr, "emit_linked_types: EXIT\n"); 1531#endif 1532} 1533 1534extern "C" Language *swig_allegrocl(void) { 1535 return (allegrocl = new ALLEGROCL()); 1536} 1537 1538void ALLEGROCL::main(int argc, char *argv[]) { 1539 int i; 1540 1541 Preprocessor_define("SWIGALLEGROCL 1", 0); 1542 SWIG_library_directory("allegrocl"); 1543 SWIG_config_file("allegrocl.swg"); 1544 1545 for (i = 1; i < argc; i++) { 1546 if (!strcmp(argv[i], "-identifier-converter")) { 1547 char *conv = argv[i + 1]; 1548 1549 if (!conv) 1550 Swig_arg_error(); 1551 1552 Swig_mark_arg(i); 1553 Swig_mark_arg(i + 1); 1554 i++; 1555 1556 /* check for built-ins */ 1557 if (!strcmp(conv, "lispify")) { 1558 identifier_converter = "identifier-convert-lispify"; 1559 } else if (!strcmp(conv, "null")) { 1560 identifier_converter = "identifier-convert-null"; 1561 } else { 1562 /* Must be user defined */ 1563 char *idconv = new char[strlen(conv) + 1]; 1564 strcpy(idconv, conv); 1565 identifier_converter = idconv; 1566 } 1567 } else if (!strcmp(argv[i], "-cwrap")) { 1568 CWrap = true; 1569 Swig_mark_arg(i); 1570 } else if (!strcmp(argv[i], "-nocwrap")) { 1571 CWrap = false; 1572 Swig_mark_arg(i); 1573 } else if (!strcmp(argv[i], "-isolate")) { 1574 unique_swig_package = true; 1575 Swig_mark_arg(i); 1576 } 1577 1578 if (!strcmp(argv[i], "-help")) { 1579 fprintf(stdout, "Allegro CL Options (available with -allegrocl)\n"); 1580 fprintf(stdout, 1581 " -identifier-converter <type or funcname>\n" 1582 "\tSpecifies the type of conversion to do on C identifiers to convert\n" 1583 "\tthem to symbols. There are two built-in converters: 'null' and\n" 1584 "\t 'lispify'. The default is 'null'. If you supply a name other\n" 1585 "\tthan one of the built-ins, then a function by that name will be\n" 1586 "\tcalled to convert identifiers to symbols.\n" 1587 "\n" 1588 " -[no]cwrap\n" 1589 "\tTurn on or turn off generation of an intermediate C file when\n" "\tcreating a C interface. By default this is only done for C++ code.\n" 1590 " -isolate\n" 1591 "Define all SWIG helper functions in a package unique to this module. Avoids redefinition warnings when loading multiple SWIGged modules\n" 1592 "into the same running Allegro CL image.\n"); 1593 1594 } 1595 1596 } 1597 1598 allow_overloading(); 1599} 1600 1601int ALLEGROCL::top(Node *n) { 1602 module_name = Getattr(n, "name"); 1603 String *cxx_filename = Getattr(n, "outfile"); 1604 String *cl_filename = NewString(""); 1605 1606 swig_package = unique_swig_package ? NewStringf("swig.%s", module_name) : NewString("swig"); 1607 1608 Printf(cl_filename, "%s%s.cl", SWIG_output_directory(), module_name); 1609 1610 f_cl = NewFile(cl_filename, "w", SWIG_output_files()); 1611 if (!f_cl) { 1612 Printf(stderr, "Unable to open %s for writing\n", cl_filename); 1613 SWIG_exit(EXIT_FAILURE); 1614 } 1615 1616 Generate_Wrapper = CPlusPlus || CWrap; 1617 1618 if (Generate_Wrapper) { 1619 f_begin = NewFile(cxx_filename, "w", SWIG_output_files()); 1620 if (!f_begin) { 1621 Close(f_cl); 1622 Delete(f_cl); 1623 Printf(stderr, "Unable to open %s for writing\n", cxx_filename); 1624 SWIG_exit(EXIT_FAILURE); 1625 } 1626 } else 1627 f_begin = NewString(""); 1628 1629 f_runtime = NewString(""); 1630 f_cxx_header = f_runtime; 1631 f_cxx_wrapper = NewString(""); 1632 1633 Swig_register_filebyname("header", f_cxx_header); 1634 Swig_register_filebyname("wrapper", f_cxx_wrapper); 1635 Swig_register_filebyname("begin", f_begin); 1636 Swig_register_filebyname("runtime", f_runtime); 1637 Swig_register_filebyname("lisp", f_clwrap); 1638 Swig_register_filebyname("lisphead", f_cl); 1639 1640 Swig_banner(f_begin); 1641 1642 Printf(f_runtime, "\n"); 1643 Printf(f_runtime, "#define SWIGALLEGROCL\n"); 1644 Printf(f_runtime, "\n"); 1645 1646 Swig_banner_target_lang(f_cl, ";;"); 1647 1648 Printf(f_cl, "\n" 1649 "(defpackage :%s\n" 1650 " (:use :common-lisp :ff :excl)\n" 1651 " (:export #:*swig-identifier-converter* #:*swig-module-name*\n" 1652 " #:*void* #:*swig-export-list*))\n" 1653 "(in-package :%s)\n\n" 1654 "(eval-when (:compile-toplevel :load-toplevel :execute)\n" 1655 " (defparameter *swig-identifier-converter* '%s)\n" 1656 " (defparameter *swig-module-name* :%s))\n\n", swig_package, swig_package, identifier_converter, module_name); 1657 Printf(f_cl, "(defpackage :%s\n" " (:use :common-lisp :%s :ff :excl))\n\n", module_name, swig_package); 1658 1659 Printf(f_clhead, "(in-package :%s)\n", module_name); 1660 1661 // Swig_print_tree(n); 1662 1663 Language::top(n); 1664 1665 // SwigType_emit_type_table(f_runtime,f_cxx_wrapper); 1666 1667 // Swig_print_tree(n); 1668#ifdef ALLEGROCL_TYPE_DEBUG 1669 dump_linked_types(stderr); 1670#endif 1671 emit_linked_types(); 1672 1673 Printf(f_clwrap, "\n(cl::in-package :%s)\n", swig_package); 1674 Printf(f_clwrap, "\n(macrolet ((swig-do-export ()\n"); 1675 Printf(f_clwrap, " `(dolist (s ',*swig-export-list*)\n"); 1676 Printf(f_clwrap, " (apply #'export s))))\n"); 1677 Printf(f_clwrap, " (swig-do-export))\n"); 1678 Printf(f_clwrap, "\n(setq *swig-export-list* nil)\n"); 1679 1680 Printf(f_cl, "%s\n", f_clhead); 1681 Printf(f_cl, "%s\n", f_clwrap); 1682 1683 Close(f_cl); 1684 Delete(f_cl); // Delete the handle, not the file 1685 Delete(f_clhead); 1686 Delete(f_clwrap); 1687 1688 Dump(f_runtime, f_begin); 1689 Printf(f_begin, "%s\n", f_cxx_wrapper); 1690 1691 Close(f_begin); 1692 Delete(f_runtime); 1693 Delete(f_begin); 1694 Delete(f_cxx_wrapper); 1695 1696 // Swig_print_tree(n); 1697 1698 return SWIG_OK; 1699} 1700 1701/* very shamelessly 'borrowed' from overload.cxx, which 1702 keeps the below Swig_overload_rank() code to itself. 1703 We don't need a dispatch function in the C++ wrapper 1704 code; we want it over on the lisp side. */ 1705 1706#define MAX_OVERLOAD 256 1707 1708/* Overload "argc" and "argv" */ 1709// String *argv_template_string; 1710// String *argc_template_string; 1711 1712struct Overloaded { 1713 Node *n; /* Node */ 1714 int argc; /* Argument count */ 1715 ParmList *parms; /* Parameters used for overload check */ 1716 int error; /* Ambiguity error */ 1717}; 1718 1719/* ----------------------------------------------------------------------------- 1720 * Swig_overload_rank() 1721 * 1722 * This function takes an overloaded declaration and creates a list that ranks 1723 * all overloaded methods in an order that can be used to generate a dispatch 1724 * function. 1725 * Slight difference in the way this function is used by scripting languages and 1726 * statically typed languages. The script languages call this method via 1727 * Swig_overload_dispatch() - where wrappers for all overloaded methods are generated, 1728 * however sometimes the code can never be executed. The non-scripting languages 1729 * call this method via Swig_overload_check() for each overloaded method in order 1730 * to determine whether or not the method should be wrapped. Note the slight 1731 * difference when overloading methods that differ by const only. The 1732 * scripting languages will ignore the const method, whereas the non-scripting 1733 * languages ignore the first method parsed. 1734 * ----------------------------------------------------------------------------- */ 1735 1736static List *Swig_overload_rank(Node *n, bool script_lang_wrapping) { 1737 Overloaded nodes[MAX_OVERLOAD]; 1738 int nnodes = 0; 1739 Node *o = Getattr(n, "sym:overloaded"); 1740 Node *c; 1741 1742 if (!o) 1743 return 0; 1744 1745 c = o; 1746 while (c) { 1747 if (Getattr(c, "error")) { 1748 c = Getattr(c, "sym:nextSibling"); 1749 continue; 1750 } 1751 /* if (SmartPointer && Getattr(c,"cplus:staticbase")) { 1752 c = Getattr(c,"sym:nextSibling"); 1753 continue; 1754 } */ 1755 1756 /* Make a list of all the declarations (methods) that are overloaded with 1757 * this one particular method name */ 1758 if (Getattr(c, "wrap:name")) { 1759 nodes[nnodes].n = c; 1760 nodes[nnodes].parms = Getattr(c, "wrap:parms"); 1761 nodes[nnodes].argc = emit_num_required(nodes[nnodes].parms); 1762 nodes[nnodes].error = 0; 1763 nnodes++; 1764 } 1765 c = Getattr(c, "sym:nextSibling"); 1766 } 1767 1768 /* Sort the declarations by required argument count */ 1769 { 1770 int i, j; 1771 for (i = 0; i < nnodes; i++) { 1772 for (j = i + 1; j < nnodes; j++) { 1773 if (nodes[i].argc > nodes[j].argc) { 1774 Overloaded t = nodes[i]; 1775 nodes[i] = nodes[j]; 1776 nodes[j] = t; 1777 } 1778 } 1779 } 1780 } 1781 1782 /* Sort the declarations by argument types */ 1783 { 1784 int i, j; 1785 for (i = 0; i < nnodes - 1; i++) { 1786 if (nodes[i].argc == nodes[i + 1].argc) { 1787 for (j = i + 1; (j < nnodes) && (nodes[j].argc == nodes[i].argc); j++) { 1788 Parm *p1 = nodes[i].parms; 1789 Parm *p2 = nodes[j].parms; 1790 int differ = 0; 1791 int num_checked = 0; 1792 while (p1 && p2 && (num_checked < nodes[i].argc)) { 1793 // Printf(stdout,"p1 = '%s', p2 = '%s'\n", Getattr(p1,"type"), Getattr(p2,"type")); 1794 if (checkAttribute(p1, "tmap:in:numinputs", "0")) { 1795 p1 = Getattr(p1, "tmap:in:next"); 1796 continue; 1797 } 1798 if (checkAttribute(p2, "tmap:in:numinputs", "0")) { 1799 p2 = Getattr(p2, "tmap:in:next"); 1800 continue; 1801 } 1802 String *t1 = Getattr(p1, "tmap:typecheck:precedence"); 1803 String *t2 = Getattr(p2, "tmap:typecheck:precedence"); 1804 if ((!t1) && (!nodes[i].error)) { 1805 Swig_warning(WARN_TYPEMAP_TYPECHECK, Getfile(nodes[i].n), Getline(nodes[i].n), 1806 "Overloaded method %s not supported (no type checking rule for '%s').\n", 1807 Swig_name_decl(nodes[i].n), SwigType_str(Getattr(p1, "type"), 0)); 1808 nodes[i].error = 1; 1809 } else if ((!t2) && (!nodes[j].error)) { 1810 Swig_warning(WARN_TYPEMAP_TYPECHECK, Getfile(nodes[j].n), Getline(nodes[j].n), 1811 "Overloaded method %s not supported (no type checking rule for '%s').\n", 1812 Swig_name_decl(nodes[j].n), SwigType_str(Getattr(p2, "type"), 0)); 1813 nodes[j].error = 1; 1814 } 1815 if (t1 && t2) { 1816 int t1v, t2v; 1817 t1v = atoi(Char(t1)); 1818 t2v = atoi(Char(t2)); 1819 differ = t1v - t2v; 1820 } else if (!t1 && t2) 1821 differ = 1; 1822 else if (t1 && !t2) 1823 differ = -1; 1824 else if (!t1 && !t2) 1825 differ = -1; 1826 num_checked++; 1827 if (differ > 0) { 1828 Overloaded t = nodes[i]; 1829 nodes[i] = nodes[j]; 1830 nodes[j] = t; 1831 break; 1832 } else if ((differ == 0) && (Strcmp(t1, "0") == 0)) { 1833 t1 = Getattr(p1, "ltype"); 1834 if (!t1) { 1835 t1 = SwigType_ltype(Getattr(p1, "type")); 1836 if (Getattr(p1, "tmap:typecheck:SWIGTYPE")) { 1837 SwigType_add_pointer(t1); 1838 } 1839 Setattr(p1, "ltype", t1); 1840 } 1841 t2 = Getattr(p2, "ltype"); 1842 if (!t2) { 1843 t2 = SwigType_ltype(Getattr(p2, "type")); 1844 if (Getattr(p2, "tmap:typecheck:SWIGTYPE")) { 1845 SwigType_add_pointer(t2); 1846 } 1847 Setattr(p2, "ltype", t2); 1848 } 1849 1850 /* Need subtype check here. If t2 is a subtype of t1, then we need to change the 1851 order */ 1852 1853 if (SwigType_issubtype(t2, t1)) { 1854 Overloaded t = nodes[i]; 1855 nodes[i] = nodes[j]; 1856 nodes[j] = t; 1857 } 1858 1859 if (Strcmp(t1, t2) != 0) { 1860 differ = 1; 1861 break; 1862 } 1863 } else if (differ) { 1864 break; 1865 } 1866 if (Getattr(p1, "tmap:in:next")) { 1867 p1 = Getattr(p1, "tmap:in:next"); 1868 } else { 1869 p1 = nextSibling(p1); 1870 } 1871 if (Getattr(p2, "tmap:in:next")) { 1872 p2 = Getattr(p2, "tmap:in:next"); 1873 } else { 1874 p2 = nextSibling(p2); 1875 } 1876 } 1877 if (!differ) { 1878 /* See if declarations differ by const only */ 1879 String *d1 = Getattr(nodes[i].n, "decl"); 1880 String *d2 = Getattr(nodes[j].n, "decl"); 1881 if (d1 && d2) { 1882 String *dq1 = Copy(d1); 1883 String *dq2 = Copy(d2); 1884 if (SwigType_isconst(d1)) { 1885 Delete(SwigType_pop(dq1)); 1886 } 1887 if (SwigType_isconst(d2)) { 1888 Delete(SwigType_pop(dq2)); 1889 } 1890 if (Strcmp(dq1, dq2) == 0) { 1891 1892 if (SwigType_isconst(d1) && !SwigType_isconst(d2)) { 1893 if (script_lang_wrapping) { 1894 // Swap nodes so that the const method gets ignored (shadowed by the non-const method) 1895 Overloaded t = nodes[i]; 1896 nodes[i] = nodes[j]; 1897 nodes[j] = t; 1898 } 1899 differ = 1; 1900 if (!nodes[j].error) { 1901 if (script_lang_wrapping) { 1902 Swig_warning(WARN_LANG_OVERLOAD_CONST, Getfile(nodes[j].n), Getline(nodes[j].n), 1903 "Overloaded %s(%s) const ignored. Non-const method at %s:%d used.\n", 1904 Getattr(nodes[j].n, "name"), ParmList_errorstr(nodes[j].parms), Getfile(nodes[i].n), Getline(nodes[i].n)); 1905 } else { 1906 if (!Getattr(nodes[j].n, "overload:ignore")) 1907 Swig_warning(WARN_LANG_OVERLOAD_IGNORED, Getfile(nodes[j].n), Getline(nodes[j].n), 1908 "Overloaded method %s(%s) ignored. Method %s(%s) const at %s:%d used.\n", 1909 Getattr(nodes[j].n, "name"), ParmList_errorstr(nodes[j].parms), 1910 Getattr(nodes[i].n, "name"), ParmList_errorstr(nodes[i].parms), Getfile(nodes[i].n), Getline(nodes[i].n)); 1911 } 1912 } 1913 nodes[j].error = 1; 1914 } else if (!SwigType_isconst(d1) && SwigType_isconst(d2)) { 1915 differ = 1; 1916 if (!nodes[j].error) { 1917 if (script_lang_wrapping) { 1918 Swig_warning(WARN_LANG_OVERLOAD_CONST, Getfile(nodes[j].n), Getline(nodes[j].n), 1919 "Overloaded %s(%s) const ignored. Non-const method at %s:%d used.\n", 1920 Getattr(nodes[j].n, "name"), ParmList_errorstr(nodes[j].parms), Getfile(nodes[i].n), Getline(nodes[i].n)); 1921 } else { 1922 if (!Getattr(nodes[j].n, "overload:ignore")) 1923 Swig_warning(WARN_LANG_OVERLOAD_IGNORED, Getfile(nodes[j].n), Getline(nodes[j].n), 1924 "Overloaded method %s(%s) const ignored. Method %s(%s) at %s:%d used.\n", 1925 Getattr(nodes[j].n, "name"), ParmList_errorstr(nodes[j].parms), 1926 Getattr(nodes[i].n, "name"), ParmList_errorstr(nodes[i].parms), Getfile(nodes[i].n), Getline(nodes[i].n)); 1927 } 1928 } 1929 nodes[j].error = 1; 1930 } 1931 } 1932 Delete(dq1); 1933 Delete(dq2); 1934 } 1935 } 1936 if (!differ) { 1937 if (!nodes[j].error) { 1938 if (script_lang_wrapping) { 1939 Swig_warning(WARN_LANG_OVERLOAD_SHADOW, Getfile(nodes[j].n), Getline(nodes[j].n), 1940 "Overloaded method %s is shadowed by %s at %s:%d.\n", 1941 Swig_name_decl(nodes[j].n), Swig_name_decl(nodes[i].n), 1942 Getfile(nodes[i].n), Getline(nodes[i].n)); 1943 } else { 1944 if (!Getattr(nodes[j].n, "overload:ignore")) 1945 Swig_warning(WARN_LANG_OVERLOAD_IGNORED, Getfile(nodes[j].n), Getline(nodes[j].n), 1946 "Overloaded method %s ignored. Method %s at %s:%d used.\n", 1947 Swig_name_decl(nodes[j].n), Swig_name_decl(nodes[i].n), 1948 Getfile(nodes[i].n), Getline(nodes[i].n)); 1949 } 1950 nodes[j].error = 1; 1951 } 1952 } 1953 } 1954 } 1955 } 1956 } 1957 List *result = NewList(); 1958 { 1959 int i; 1960 for (i = 0; i < nnodes; i++) { 1961 if (nodes[i].error) 1962 Setattr(nodes[i].n, "overload:ignore", "1"); 1963 Append(result, nodes[i].n); 1964 // Printf(stdout,"[ %d ] %s\n", i, ParmList_errorstr(nodes[i].parms)); 1965 // Swig_print_node(nodes[i].n); 1966 } 1967 } 1968 return result; 1969} 1970 1971/* end shameless borrowing */ 1972 1973int any_varargs(ParmList *pl) { 1974 Parm *p; 1975 1976 for (p = pl; p; p = nextSibling(p)) { 1977 if (SwigType_isvarargs(Getattr(p, "type"))) 1978 return 1; 1979 } 1980 1981 return 0; 1982} 1983 1984String *get_lisp_type(Node *n, SwigType *ty, const_String_or_char_ptr name) { 1985 Node *node = NewHash(); 1986 Setattr(node, "type", ty); 1987 Setattr(node, "name", name); 1988 Setfile(node, Getfile(n)); 1989 Setline(node, Getline(n)); 1990 const String *tm = Swig_typemap_lookup("lisptype", node, "", 0); 1991 Delete(node); 1992 1993 return tm ? NewString(tm) : NewString(""); 1994} 1995 1996Node *parent_node_skipping_extends(Node *n) { 1997 Node *result = n; 1998 do { 1999 result = parentNode(result); 2000 } 2001 while (Cmp("extend", nodeType(result)) == 0); 2002 return result; 2003} 2004 2005/* ----------------------------------------------------------------------------- 2006 * emit_num_lin_arguments() 2007 * 2008 * Calculate the total number of arguments. This function is safe for use 2009 * with multi-argument typemaps which may change the number of arguments in 2010 * strange ways. 2011 * ----------------------------------------------------------------------------- */ 2012 2013int emit_num_lin_arguments(ParmList *parms) { 2014 Parm *p = parms; 2015 int nargs = 0; 2016 2017 while (p) { 2018 // Printf(stderr,"enla: '%s' lin='%x'\n", Getattr(p,"name"), Getattr(p,"tmap:lin")); 2019 if (Getattr(p, "tmap:lin")) { 2020 nargs += GetInt(p, "tmap:lin:numinputs"); 2021 p = Getattr(p, "tmap:lin:next"); 2022 } else { 2023 p = nextSibling(p); 2024 } 2025 } 2026 2027 /* DB 04/02/2003: Not sure this is necessary with tmap:in:numinputs */ 2028 /* 2029 if (parms && (p = Getattr(parms,"emit:varargs"))) { 2030 if (!nextSibling(p)) { 2031 nargs--; 2032 } 2033 } 2034 */ 2035 return nargs; 2036} 2037 2038String *id_converter_type(SwigType const *type) { 2039 SwigType *t = Copy(type); 2040 String *result = 0; 2041 2042 if (SwigType_ispointer(t)) { 2043 SwigType_pop(t); 2044 String *pointee = id_converter_type(t); 2045 result = NewStringf("(:* %s)", pointee); 2046 Delete(pointee); 2047 } else if (SwigType_ismemberpointer(t)) { 2048 String *klass = SwigType_parm(t); 2049 SwigType_pop(t); 2050 String *member = id_converter_type(t); 2051 result = NewStringf("(:member \"%s\" %s)", klass, member); 2052 Delete(klass); 2053 Delete(member); 2054 } else if (SwigType_isreference(t)) { 2055 SwigType_pop(t); 2056 String *referencee = id_converter_type(t); 2057 result = NewStringf("(:& %s)", referencee); 2058 Delete(referencee); 2059 } else if (SwigType_isarray(t)) { 2060 String *size = SwigType_parm(t); 2061 SwigType_pop(t); 2062 String *element_type = id_converter_type(t); 2063 result = NewStringf("(:array %s \"%s\")", element_type, size); 2064 Delete(size); 2065 Delete(element_type); 2066 } else if (SwigType_isfunction(t)) { 2067 result = NewString("(:function ("); 2068 String *parmlist_str = SwigType_parm(t); 2069 List *parms = SwigType_parmlist(parmlist_str); 2070 2071 for (Iterator i = First(parms); i.item;) { 2072 String *parm = id_converter_type((SwigType *) i.item); 2073 Printf(result, "%s", parm); 2074 i = Next(i); 2075 if (i.item) 2076 Printf(result, " "); 2077 Delete(parm); 2078 } 2079 SwigType_pop(t); 2080 String *ret = id_converter_type(t); 2081 Printf(result, ") %s)", ret); 2082 2083 Delete(parmlist_str); 2084 Delete(parms); 2085 Delete(ret); 2086 } else if (SwigType_isqualifier(t)) { 2087 result = NewString("(:qualified ("); 2088 String *qualifiers_str = Copy(SwigType_parm(t)); // ?! 2089 // Replaceall below SEGVs if we don't put the Copy here... 2090 SwigType_pop(t); 2091 String *qualifiee = id_converter_type(t); 2092 2093 Replaceall(qualifiers_str, " ", " :"); 2094 if (Len(qualifiers_str) > 0) 2095 Printf(result, ":"); 2096 Printf(result, "%s) %s)", qualifiers_str, qualifiee); 2097 2098 Delete(qualifiers_str); 2099 Delete(qualifiee); 2100 } else if (SwigType_istemplate(t)) { 2101 result = NewStringf("(:template \"%s\")", t); 2102 } else { /* if (SwigType_issimple(t)) */ 2103 2104 if (Strstr(Char(t), "::")) { 2105 result = listify_namespace(t); 2106 } else { 2107 result = NewStringf("\"%s\"", t); 2108 } 2109 } 2110 2111 Delete(t); 2112 return result; 2113} 2114 2115static ParmList *parmlist_with_names(ParmList *pl) { 2116 ParmList *pl2 = CopyParmList(pl); 2117 for (Parm *p = pl, *p2 = pl2; p2; p = nextSibling(p), p2 = nextSibling(p2)) { 2118 if (!Getattr(p2, "name")) 2119 Setattr(p2, "name", Getattr(p2, "lname")); 2120 Setattr(p2, "name", strip_namespaces(Getattr(p2, "name"))); 2121 Setattr(p2, "tmap:ctype", Getattr(p, "tmap:ctype")); 2122 2123 String *temp = Getattr(p, "tmap:lin"); 2124 if (temp) { 2125 Setattr(p2, "tmap:lin", temp); 2126 Setattr(p2, "tmap:lin:next", Getattr(p, "tmap:lin:next")); 2127 } 2128 } 2129 return pl2; 2130} 2131 2132static String *parmlist_str_id_converter(ParmList *pl) { 2133 String *result = NewString(""); 2134 for (Parm *p = pl; p;) { 2135 String *lispy_type = id_converter_type(Getattr(p, "type")); 2136 Printf(result, "(\"%s\" %s)", Getattr(p, "name"), lispy_type); 2137 Delete(lispy_type); 2138 if ((p = nextSibling(p))) 2139 Printf(result, " "); 2140 } 2141 return result; 2142} 2143 2144String *collect_others_args(Node *overload) { 2145 String *overloaded_from = Getattr(overload, "sym:overloaded"); 2146 String *others_args = NewString(""); 2147 int first_overload = 1; 2148 2149 for (Node *overload2 = overloaded_from; overload2; overload2 = Getattr(overload2, "sym:nextSibling")) { 2150 if (overload2 == overload || GetInt(overload2, "overload:ignore")) 2151 continue; 2152 2153 ParmList *opl = parmlist_with_names(Getattr(overload2, "wrap:parms")); 2154 String *args = parmlist_str_id_converter(opl); 2155 if (!first_overload) 2156 Printf(others_args, "\n "); 2157 Printf(others_args, "(%s)", args); 2158 Delete(args); 2159 Delete(opl); 2160 first_overload = 0; 2161 } 2162 return others_args; 2163} 2164 2165struct IDargs { 2166 String *name; 2167 String *type; 2168 String *klass; 2169 String *arity; 2170 2171 IDargs():name(0), type(0), klass(0), arity(0) { 2172 } 2173 2174 String *full_quoted_str() { 2175 String *result = no_others_quoted_str(); 2176 if (arity) 2177 Printf(result, " :arity %s", arity); 2178 return result; 2179 } 2180 2181 String *no_others_quoted_str() { 2182 String *result = NewString(""); 2183 Printf(result, "\"%s\" :type :%s", name, type); 2184 if (klass) 2185 Printf(result, " :class \"%s\"", klass); 2186 return result; 2187 } 2188 2189 String *noname_str() { 2190 String *result = NewString(""); 2191 Printf(result, " :type :%s", type); 2192 if (klass) 2193 Printf(result, " :class \"%s\"", klass); 2194 if (arity) 2195 Printf(result, " :arity %s", arity); 2196 return result; 2197 } 2198}; 2199IDargs *id_converter_arguments(Node *n) { 2200 IDargs *result = (IDargs *) GetVoid(n, "allegrocl:id-converter-args"); 2201 if (!result) 2202 result = new IDargs; 2203 2204 // Base name 2205 if (!result->name) { 2206 result->name = Getattr(n, "allegrocl:old-sym:name"); 2207 if (!result->name) 2208 result->name = Getattr(n, "sym:name"); 2209 result->name = Copy(result->name); 2210 } 2211 // :type 2212 if (result->type) 2213 Delete(result->type); 2214 if (!Getattr(n, "allegrocl:kind")) 2215 Setattr(n, "allegrocl:kind", "function"); 2216 if (Strstr(Getattr(n, "name"), "operator ")) 2217 Replaceall(Getattr(n, "allegrocl:kind"), "function", "operator"); 2218 if (Strstr(Getattr(n, "allegrocl:kind"), "variable")) { 2219 int name_end = Len(Getattr(n, "sym:name")) - 4; 2220 char *str = Char(Getattr(n, "sym:name")); 2221 String *get_set = NewString(str + name_end + 1); 2222 result->type = Copy(Getattr(n, "allegrocl:kind")); 2223 Replaceall(result->type, "variable", ""); 2224 Printf(result->type, "%ster", get_set); 2225 Delete(get_set); 2226 } else { 2227 result->type = Copy(Getattr(n, "allegrocl:kind")); 2228 } 2229 2230 // :class 2231 if (Strstr(result->type, "member ")) { 2232 Replaceall(result->type, "member ", ""); 2233 if (!result->klass) 2234 result->klass = Copy(Getattr(parent_node_skipping_extends(n), "sym:name")); 2235 } 2236 // :arity 2237 if (Getattr(n, "sym:overloaded")) { 2238 if (result->arity) 2239 Delete(result->arity); 2240 result->arity = NewStringf("%d", 2241 // emit_num_arguments(Getattr(n, "wrap:parms"))); 2242 emit_num_lin_arguments(Getattr(n, "wrap:parms"))); 2243 // Printf(stderr, "got arity of '%s' node '%s' '%x'\n", result->arity, Getattr(n,"name"), Getattr(n,"wrap:parms")); 2244 } 2245 2246 SetVoid(n, "allegrocl:id-converter-args", result); 2247 return result; 2248} 2249 2250int ALLEGROCL::emit_buffered_defuns(Node *n) { 2251 2252 Node *overloaded_from = Getattr(n, "sym:overloaded"); 2253 2254 String *wrap; 2255 2256 if (!overloaded_from) { 2257 wrap = Getattr(n, "allegrocl:lisp-wrap"); 2258 2259 Printf(f_clwrap, "%s\n", wrap); 2260 Delattr(n, "allegrocl:lisp-wrap"); 2261 Delete(wrap); 2262 } else { 2263 for (Node *overload = overloaded_from; overload; overload = Getattr(overload, "sym:nextSibling")) { 2264 String *others_args = collect_others_args(overload); 2265 wrap = Getattr(overload, "allegrocl:lisp-wrap"); 2266 2267 Replaceall(wrap, "@@OTHERS-ARGS-GO-HERE@@", others_args); 2268// IDargs* id_args = id_converter_arguments(overload); 2269// Replaceall(id_args->others_args, "@@OTHERS-ARGS-GO-HERE@@", others_args); 2270 2271 if (!GetInt(overload, "overload:ignore")) 2272 Printf(f_clwrap, "%s", wrap); 2273 2274 Delattr(overload, "allegrocl:lisp-wrap"); 2275 Delete(wrap); 2276 } 2277 } 2278 return SWIG_OK; 2279} 2280 2281String *dispatching_type(Node *n, Parm *p) { 2282 String *result = 0; 2283 2284 String *parsed = Getattr(p, "type"); //Swig_cparse_type(Getattr(p,"tmap:ctype")); 2285 String *cl_t = SwigType_typedef_resolve_all(parsed); 2286 2287 Node *node = NewHash(); 2288 Setattr(node, "type", parsed); 2289 Setfile(node, Getfile(n)); 2290 Setline(node, Getline(n)); 2291 const String *tm = Swig_typemap_lookup("lispclass", node, Getattr(p, "name"), 0); 2292 Delete(node); 2293 2294 if (tm) { 2295 result = Copy(tm); 2296 } else { 2297 String *lookup_type = class_from_class_or_class_ref(parsed); 2298 if (lookup_type) 2299 result = lookup_defined_foreign_ltype(lookup_type); 2300 } 2301 2302 // if (!result && SwigType_ispointer(cl_t)) { 2303 // SwigType_pop(cl_t); 2304 // result = lookup_defined_foreign_ltype(cl_t); 2305 // } 2306 2307 if (!result) 2308 result = NewStringf("ff:foreign-pointer"); 2309 2310 // Delete(parsed); 2311 Delete(cl_t); 2312 return result; 2313} 2314 2315int ALLEGROCL::emit_dispatch_defun(Node *n) { 2316#ifdef ALLEGROCL_WRAP_DEBUG 2317 Printf(stderr, "emit_dispatch_defun: ENTER... "); 2318#endif 2319 List *overloads = Swig_overload_rank(n, true); 2320 2321 String *id_args = id_converter_arguments(n)->no_others_quoted_str(); 2322 Printf(f_clwrap, "(swig-dispatcher (%s :arities (", id_args); 2323 2324 int last_arity = -1; 2325 for (Iterator i = First(overloads); i.item; i = Next(i)) { 2326 int arity = emit_num_lin_arguments(Getattr(i.item, "wrap:parms")); 2327 if (arity == last_arity) 2328 continue; 2329 2330 Printf(f_clwrap, "%s%d", last_arity == -1 ? "" : " ", arity); 2331 2332 last_arity = arity; 2333 } 2334 Printf(f_clwrap, ")))\n"); 2335 2336 Delete(id_args); 2337 Delete(overloads); 2338 2339#ifdef ALLEGROCL_WRAP_DEBUG 2340 Printf(stderr, "emit_dispatch_defun: EXIT\n"); 2341#endif 2342 2343 return SWIG_OK; 2344} 2345 2346int ALLEGROCL::emit_defun(Node *n, File *fcl) { 2347#ifdef ALLEGROCL_WRAP_DEBUG 2348 Printf(stderr, "emit_defun: ENTER... "); 2349#endif 2350 2351#ifdef ALLEGROCL_DEBUG 2352 int auto_generated = Cmp(Getattr(n, "view"), "globalfunctionHandler"); 2353 Printf(stderr, "%s%sfunction %s%s%s\n", auto_generated ? "> " : "", Getattr(n, "sym:overloaded") 2354 ? "overloaded " : "", current_namespace, (current_namespace) > 0 ? "::" : "", Getattr(n, "sym:name")); 2355 Printf(stderr, " (view: %s)\n", Getattr(n, "view")); 2356#endif 2357 2358 String *funcname = Getattr(n, "allegrocl:old-sym:name"); 2359 if (!funcname) 2360 funcname = Getattr(n, "sym:name"); 2361 String *mangled_name = Getattr(n, "wrap:name"); 2362 ParmList *pl = parmlist_with_names(Getattr(n, "wrap:parms")); 2363 2364 // attach typemap info. 2365 Wrapper *wrap = NewWrapper(); 2366 Swig_typemap_attach_parms("lin", pl, wrap); 2367 // Swig_typemap_attach_parms("ffitype", pl, wrap); 2368 Swig_typemap_lookup("lout", n, "result", 0); 2369 2370 SwigType *result_type = Swig_cparse_type(Getattr(n, "tmap:ctype")); 2371 // prime the pump, with support for OUTPUT, INOUT typemaps. 2372 Printf(wrap->code, 2373 "(cl::let ((ACL_ffresult %s:*void*)\n ACL_result)\n $body\n (cl::if (cl::eq ACL_ffresult %s:*void*)\n (cl::values-list ACL_result)\n (cl::values-list (cl::cons ACL_ffresult ACL_result))))", 2374 swig_package, swig_package); 2375 2376 Parm *p; 2377 int largnum = 0, argnum = 0, first = 1; 2378 // int varargs=0; 2379 if (Generate_Wrapper) { 2380 String *extra_parms = id_converter_arguments(n)->noname_str(); 2381 if (Getattr(n, "sym:overloaded")) 2382 Printf(fcl, "(swig-defmethod (\"%s\" \"%s\"%s)\n", funcname, mangled_name, extra_parms); 2383 else 2384 Printf(fcl, "(swig-defun (\"%s\" \"%s\"%s)\n", funcname, mangled_name, extra_parms); 2385 Delete(extra_parms); 2386 } 2387 // Just C 2388 else { 2389 Printf(fcl, "(swig-defun (\"%s\" \"%s\")\n", funcname, Generate_Wrapper ? mangled_name : funcname); 2390 } 2391 2392 ////////////////////////////////////// 2393 // Lisp foreign call parameter list // 2394 ////////////////////////////////////// 2395 Printf(fcl, " ("); 2396 2397 /* Special cases */ 2398 2399 if (ParmList_len(pl) == 0) { 2400 Printf(fcl, ":void"); 2401/* } else if (any_varargs(pl)) { 2402 Printf(fcl, "#| varargs |#"); 2403 varargs=1; */ 2404 } else { 2405 String *largs = NewString(""); 2406 2407 for (p = pl; p; p = nextSibling(p), argnum++, largnum++) { 2408 // SwigType *argtype=Getattr(p, "type"); 2409 SwigType *argtype = Swig_cparse_type(Getattr(p, "tmap:ctype")); 2410 SwigType *parmtype = Getattr(p,"type"); 2411 2412 if (!first) { 2413 Printf(fcl, "\n "); 2414 } 2415 2416 /* by default, skip varargs */ 2417 if (!SwigType_isvarargs(parmtype)) { 2418 String *argname = NewStringf("PARM%d_%s", largnum, Getattr(p, "name")); 2419 2420 // Printf(stderr,"%s\n", Getattr(p,"tmap:lin")); 2421 String *ffitype = compose_foreign_type(n, argtype, Getattr(p,"name")); 2422 String *deref_ffitype = dereference_ffitype(ffitype); 2423 String *lisptype = get_lisp_type(n, parmtype, Getattr(p, "name")); 2424 2425#ifdef ALLEGROCL_DEBUG 2426 Printf(stderr, "lisptype of '%s' '%s' = '%s'\n", parmtype, 2427 Getattr(p, "name"), lisptype); 2428#endif 2429 2430 // while we're walking the parameters, generating LIN 2431 // wrapper code... 2432 Setattr(p, "lname", NewStringf("SWIG_arg%d", largnum)); 2433 2434 String *parm_code = Getattr(p, "tmap:lin"); 2435 if (parm_code) { 2436 String *lname = Getattr(p, "lname"); 2437 2438 Printf(largs, " %s", lname); 2439 Replaceall(parm_code, "$in_fftype", ffitype); // must come before $in 2440 Replaceall(parm_code, "$in", argname); 2441 Replaceall(parm_code, "$out", lname); 2442 Replaceall(parm_code, "$*in_fftype", deref_ffitype); 2443 Replaceall(wrap->code, "$body", parm_code); 2444 } 2445 2446 String *dispatchtype = Getattr(n, "sym:overloaded") ? dispatching_type(n, p) : NewString(""); 2447 2448 // if this parameter has been removed from the C/++ wrapper 2449 // it shouldn't be in the lisp wrapper either. 2450 if (!checkAttribute(p, "tmap:in:numinputs", "0")) { 2451 Printf(fcl, "(%s %s %s %s %s)", 2452 // parms in the ff wrapper, but not in the lisp wrapper. 2453 (checkAttribute(p, "tmap:lin:numinputs", "0") ? ":p-" : ":p+"), argname, dispatchtype, ffitype, lisptype); 2454 2455 first = 0; 2456 } 2457 2458 Delete(argname); 2459 Delete(ffitype); 2460 Delete(deref_ffitype); 2461 Delete(lisptype); 2462 } 2463 } 2464 2465 Printf(wrap->locals, "%s", largs); 2466 } 2467 2468 String *lout = Getattr(n, "tmap:lout"); 2469 Replaceall(lout, "$owner", GetFlag(n, "feature:new") ? "t" : "nil"); 2470 2471 Replaceall(wrap->code, "$body", lout); 2472 // $lclass handling. 2473 String *lclass = (String *) 0; 2474 SwigType *parsed = Swig_cparse_type(Getattr(n, "tmap:ctype")); 2475 // SwigType *cl_t = SwigType_typedef_resolve_all(parsed); 2476 SwigType *cl_t = class_from_class_or_class_ref(parsed); 2477 String *out_ffitype = compose_foreign_type(n, parsed); 2478 String *deref_out_ffitype; 2479 String *out_temp = Copy(parsed); 2480 2481 if (SwigType_ispointer(out_temp)) { 2482 SwigType_pop(out_temp); 2483 deref_out_ffitype = compose_foreign_type(n, out_temp); 2484 } else { 2485 deref_out_ffitype = Copy(out_ffitype); 2486 } 2487 2488 Delete(out_temp); 2489 2490 Delete(parsed); 2491 2492 int isPtrReturn = 0; 2493 2494 if (cl_t) { 2495 lclass = lookup_defined_foreign_ltype(cl_t); 2496 isPtrReturn = 1; 2497 } 2498 2499 int ff_foreign_ptr = 0; 2500 if (!lclass) { 2501 ff_foreign_ptr = 1; 2502 lclass = NewStringf("ff:foreign-pointer"); 2503 } 2504#ifdef ALLEGROCL_WRAP_DEBUG 2505 Printf(stderr, "for output wrapping %s: type=%s, ctype=%s\n", Getattr(n, "name"), 2506 Getattr(n, "type"), Swig_cparse_type(Getattr(n, "tmap:ctype"))); 2507#endif 2508 2509 if (lclass) 2510 Replaceall(wrap->code, "$lclass", lclass); 2511 if (out_ffitype) 2512 Replaceall(wrap->code, "$out_fftype", out_ffitype); 2513 if (deref_out_ffitype) 2514 Replaceall(wrap->code, "$*out_fftype", deref_out_ffitype); 2515 // if(Replaceall(wrap->code,"$lclass", lclass) && !isPtrReturn) { 2516 // Swig_warning(WARN_LANG_RETURN_TYPE,Getfile(n), Getline(n), 2517 // "While Wrapping %s, replaced a $lclass reference when return type is non-pointer %s!\n", 2518 // Getattr(n,"name"), cl_t); 2519 // } 2520 2521 Replaceall(wrap->code, "$body", NewStringf("(swig-ff-call%s)", wrap->locals)); 2522// Replaceall(wrap->code,"$body", 2523// (!Strcmp(result_type,"void") ? 2524// NewStringf("(swig-ff-call%s)", wrap->locals) : 2525// NewStringf("(push (swig-ff-call%s) ACL_result)", wrap->locals))); 2526 String *ldestructor = Copy(lclass); 2527 if (ff_foreign_ptr) 2528 Replaceall(ldestructor, ldestructor, "identity"); 2529 else 2530 Replaceall(ldestructor, ":type :class", ":type :destructor"); 2531 Replaceall(wrap->code, "$ldestructor", ldestructor); 2532 Delete(ldestructor); 2533 2534 Printf(fcl, ")\n"); /* finish arg list */ 2535 2536 ///////////////////////////////////////////////////// 2537 // Lisp foreign call return type and optimizations // 2538 ///////////////////////////////////////////////////// 2539 Printf(fcl, " (:returning (%s %s)", compose_foreign_type(n, result_type), get_lisp_type(n, Getattr(n, "type"), "result")); 2540 2541 for (Iterator option = First(n); option.item; option = Next(option)) { 2542 if (Strncmp("feature:ffargs:", option.key, 15)) 2543 continue; 2544 String *option_val = option.item; 2545 String *option_name = NewString(Char(option.key) + 14); 2546 Replaceall(option_name, "_", "-"); 2547 2548 // TODO: varargs vs call-direct ? 2549 Printf(fcl, "\n %s %s", option_name, option_val); 2550 2551 Delete(option_name); 2552 } 2553 2554 Printf(fcl, ")\n %s)\n\n", wrap->code); 2555 // Wrapper_print(wrap, stderr); 2556 2557 Delete(result_type); 2558 Delete(mangled_name); 2559 Delete(pl); 2560 DelWrapper(wrap); 2561 2562#ifdef ALLEGROCL_WRAP_DEBUG 2563 Printf(stderr, "emit_defun: EXIT\n"); 2564#endif 2565 2566 return SWIG_OK; 2567} 2568 2569int ALLEGROCL::functionWrapper(Node *n) { 2570#ifdef ALLEGROCL_DEBUG 2571 Printf(stderr, "functionWrapper %s\n", Getattr(n,"name")); 2572 Swig_print_node(n); 2573#endif 2574 2575 2576 ParmList *parms = CopyParmList(Getattr(n, "parms")); 2577 Wrapper *f = NewWrapper(); 2578 SwigType *t = Getattr(n, "type"); 2579 String *name = Getattr(n, "name"); 2580 2581 String *raw_return_type = Swig_typemap_lookup("ctype", n, "", 0); 2582 SwigType *return_type = Swig_cparse_type(raw_return_type); 2583 SwigType *resolved = SwigType_typedef_resolve_all(return_type); 2584 int is_void_return = (Cmp(resolved, "void") == 0); 2585 2586 Delete(resolved); 2587 2588 if (!is_void_return) { 2589 String *lresult_init = 2590 NewStringf("= (%s)0", 2591 SwigType_str(SwigType_strip_qualifiers(return_type),0)); 2592 Wrapper_add_localv(f, "lresult", 2593 SwigType_lstr(SwigType_ltype(return_type), "lresult"), 2594 lresult_init, NIL); 2595 Delete(lresult_init); 2596 } 2597 // Emit all of the local variables for holding arguments. 2598 emit_parameter_variables(parms, f); 2599 2600 // Attach the standard typemaps 2601 Swig_typemap_attach_parms("ctype", parms, f); 2602 Swig_typemap_attach_parms("lin", parms, f); 2603 emit_attach_parmmaps(parms, f); 2604 2605 String *mangled = mangle_name(n); 2606 Node *overloaded = Getattr(n, "sym:overloaded"); 2607 2608 // Parameter overloading 2609 Setattr(n, "wrap:parms", parms); 2610 Setattr(n, "wrap:name", mangled); 2611 2612 if (overloaded) { 2613 // emit warnings when overloading is impossible on the lisp side. 2614 // basically Swig_overload_check(n), but with script_lang_wrapping 2615 // set to true. 2616 Delete(Swig_overload_rank(n, true)); 2617 if (Getattr(n, "overload:ignore")) { 2618 // if we're the last overload, make sure to force the emit 2619 // of the rest of the overloads before we leave. 2620 Printf(stderr, "ignored overload %s(%x)\n", name, Getattr(n, "sym:nextSibling")); 2621 if (!Getattr(n, "sym:nextSibling")) { 2622 update_package_if_needed(n); 2623 emit_buffered_defuns(n); 2624 emit_dispatch_defun(n); 2625 } 2626 DelWrapper(f); 2627 return SWIG_OK; 2628 } 2629 } 2630 // Get number of required and total arguments 2631 int num_arguments = emit_num_arguments(parms); 2632 int gencomma = 0; 2633 2634#ifdef ALLEGROCL_DEBUG 2635 Printf(stderr, "Walking parameters for %s '%s'\n", Getattr(n, "allegrocl:kind"), name); 2636#endif 2637 // Now walk the function parameter list and generate code to get arguments 2638 String *name_and_parms = NewStringf("%s (", mangled); 2639 int i; 2640 Parm *p; 2641 for (i = 0, p = parms; i < num_arguments; i++) { 2642 2643 while (p && checkAttribute(p, "tmap:in:numinputs", "0")) { 2644 p = Getattr(p, "tmap:in:next"); 2645 } 2646 2647 if (!p) 2648 break; 2649 2650 SwigType *c_parm_type = Swig_cparse_type(Getattr(p, "tmap:ctype")); 2651 String *arg = NewStringf("l%s", Getattr(p, "lname")); 2652 2653 // Emit parameter declaration 2654 if (gencomma) 2655 Printf(name_and_parms, ", "); 2656 String *parm_decl = SwigType_str(c_parm_type, arg); 2657 Printf(name_and_parms, "%s", parm_decl); 2658#ifdef ALLEGROCL_DEBUG 2659 Printf(stderr, " param: %s\n", parm_decl); 2660#endif 2661 Delete(parm_decl); 2662 gencomma = 1; 2663 2664 // Emit parameter conversion code 2665 String *parm_code = Getattr(p, "tmap:in"); 2666 //if (!parm_code) { 2667 // Swig_warning(...); 2668 // p = nextSibling(p); 2669 /*} else */ { 2670 // canThrow(n, "in", p); 2671 Replaceall(parm_code, "$input", arg); 2672 Setattr(p, "emit:input", arg); 2673 Printf(f->code, "%s\n", parm_code); 2674 p = Getattr(p, "tmap:in:next"); 2675 } 2676 2677 Delete(arg); 2678 } 2679 Printf(name_and_parms, ")"); 2680 2681 // Emit the function definition 2682 String *signature = SwigType_str(return_type, name_and_parms); 2683 Printf(f->def, "EXPORT %s {", signature); 2684 if (CPlusPlus) 2685 Printf(f->code, " try {\n"); 2686 2687 String *actioncode = emit_action(n); 2688 2689 String *tm = Swig_typemap_lookup_out("out", n, "result", f, actioncode); 2690 if (!is_void_return && tm) { 2691 if (tm) { 2692 Replaceall(tm, "$result", "lresult"); 2693 Printf(f->code, "%s\n", tm); 2694 Printf(f->code, " return lresult;\n"); 2695 Delete(tm); 2696 } else { 2697 Swig_warning(WARN_TYPEMAP_OUT_UNDEF, input_file, line_number, 2698 "Unable to use return type %s in function %s.\n", 2699 SwigType_str(t, 0), name); 2700 } 2701 } 2702 2703 emit_return_variable(n, t, f); 2704 2705 if (CPlusPlus) { 2706 Printf(f->code, " } catch (...) {\n"); 2707 if (!is_void_return) 2708 Printf(f->code, " return (%s)0;\n", 2709 SwigType_str(SwigType_strip_qualifiers(return_type),0)); 2710 Printf(f->code, " }\n"); 2711 } 2712 Printf(f->code, "}\n"); 2713 2714 /* print this when in C mode? make this a command-line arg? */ 2715 if (Generate_Wrapper) 2716 Wrapper_print(f, f_cxx_wrapper); 2717 2718 String *f_buffer = NewString(""); 2719 2720 emit_defun(n, f_buffer); 2721 Setattr(n, "allegrocl:lisp-wrap", f_buffer); 2722 2723 if (!overloaded || !Getattr(n, "sym:nextSibling")) { 2724 update_package_if_needed(n); 2725 emit_buffered_defuns(n); 2726 // this is the last overload. 2727 if (overloaded) { 2728 emit_dispatch_defun(n); 2729 } 2730 } 2731 2732 DelWrapper(f); 2733 2734 return SWIG_OK; 2735} 2736 2737int ALLEGROCL::namespaceDeclaration(Node *n) { 2738#ifdef ALLEGROCL_DEBUG 2739 Printf(stderr, "namespaceDecl: '%s'(0x%x) (fc=0x%x)\n", Getattr(n, "sym:name"), n, firstChild(n)); 2740#endif 2741 2742 /* don't wrap a namespace with no contents. package bloat. 2743 also, test-suite/namespace_class.i claims an unnamed namespace 2744 is 'private' and should not be wrapped. Complying... 2745 */ 2746 if (Getattr(n,"unnamed") || !firstChild(n)) 2747 return SWIG_OK; 2748 2749 String *name = Getattr(n, "sym:name"); 2750 2751 String *old_namespace = current_namespace; 2752 if (Cmp(current_namespace, "") == 0) 2753 current_namespace = NewStringf("%s", name); 2754 else 2755 current_namespace = NewStringf("%s::%s", current_namespace, name); 2756 2757 if (!GetInt(defined_namespace_packages, current_namespace)) { 2758 SetInt(defined_namespace_packages, current_namespace, 1); 2759 String *lispy_namespace = listify_namespace(current_namespace); 2760 Printf(f_clhead, "(swig-defpackage %s)\n", lispy_namespace); 2761 Delete(lispy_namespace); 2762 } 2763 2764 emit_children(n); 2765 2766 Delete(current_namespace); 2767 current_namespace = old_namespace; 2768 return SWIG_OK; 2769} 2770 2771int ALLEGROCL::constructorHandler(Node *n) { 2772#ifdef ALLEGROCL_DEBUG 2773 Printf(stderr, "constructorHandler %s\n", Getattr(n, "name")); 2774#endif 2775 // Swig_print_node(n); 2776 Setattr(n, "allegrocl:kind", "constructor"); 2777 Setattr(n, "allegrocl:old-sym:name", Getattr(n, "sym:name")); 2778 2779 // Let SWIG generate a global forwarding function. 2780 return Language::constructorHandler(n); 2781} 2782 2783int ALLEGROCL::destructorHandler(Node *n) { 2784#ifdef ALLEGROCL_DEBUG 2785 Printf(stderr, "destructorHandler %s\n", Getattr(n, "name")); 2786#endif 2787 2788 Setattr(n, "allegrocl:kind", "destructor"); 2789 Setattr(n, "allegrocl:old-sym:name", Getattr(n, "sym:name")); 2790 2791 // Let SWIG generate a global forwarding function. 2792 return Language::destructorHandler(n); 2793} 2794 2795int ALLEGROCL::constantWrapper(Node *n) { 2796#ifdef ALLEGROCL_DEBUG 2797 Printf(stderr, "constantWrapper %s\n", Getattr(n, "name")); 2798#endif 2799 2800 if (Generate_Wrapper) { 2801 // Setattr(n,"wrap:name",mangle_name(n, "ACLPP")); 2802 String *const_type = Getattr(n, "type"); 2803 2804 String *const_val = 0; 2805 String *raw_const = Getattr(n, "value"); 2806 2807 if (SwigType_type(const_type) == T_STRING) { 2808 const_val = NewStringf("\"%s\"", raw_const); 2809 } else if (SwigType_type(const_type) == T_CHAR) { 2810 const_val = NewStringf("'%s'", raw_const); 2811 } else { 2812 const_val = Copy(raw_const); 2813 } 2814 2815 SwigType_add_qualifier(const_type, "const"); 2816 2817 String *ppcname = NewStringf("ACLppc_%s", Getattr(n, "sym:name")); 2818 // Printf(f_runtime, "static const %s = %s;\n", SwigType_lstr(const_type, ppcname), const_val); 2819 Printf(f_runtime, "static %s = %s;\n", SwigType_lstr(const_type, ppcname), const_val); 2820 2821 Setattr(n, "name", ppcname); 2822 SetFlag(n, "feature:immutable"); 2823 2824 Delete(const_val); 2825 return variableWrapper(n); 2826 } 2827 2828 String *type = Getattr(n, "type"); 2829 String *value = Getattr(n, "value"); 2830 String *converted_value = convert_literal(value, type); 2831 String *name = Getattr(n, "sym:name"); 2832 2833 Setattr(n, "allegrocl:kind", "constant"); 2834 Setattr(n, "allegrocl:old-sym:name", Getattr(n, "sym:name")); 2835 2836#if 0 2837 Printf(stdout, "constant %s is of type %s. value: %s\n", name, type, converted_value); 2838#endif 2839 2840 if (converted_value) { 2841 Printf(f_clwrap, "(swig-defconstant \"%s\" %s)\n", name, converted_value); 2842 } else { 2843 Swig_warning(WARN_LANG_DISCARD_CONST, Getfile(n), Getline(n), "Unable to parse constant value '%s'. Setting to NIL\n", value); 2844 Printf(f_clwrap, "(swig-defconstant \"%s\" nil #| %s |#)\n", name, value); 2845 } 2846 2847 Delete(converted_value); 2848 2849 return SWIG_OK; 2850} 2851 2852int ALLEGROCL::globalvariableHandler(Node *n) { 2853#ifdef ALLEGROCL_DEBUG 2854 Printf(stderr, "globalvariableHandler %s\n", Getattr(n, "name")); 2855#endif 2856 2857 if (Generate_Wrapper) 2858 return Language::globalvariableHandler(n); 2859 2860 // String *name = Getattr(n, "name"); 2861 SwigType *type = Getattr(n, "type"); 2862 SwigType *ctype; 2863 SwigType *rtype = SwigType_typedef_resolve_all(type); 2864 2865 int pointer_added = 0; 2866 2867 if (SwigType_isclass(rtype)) { 2868 SwigType_add_pointer(type); 2869 SwigType_add_pointer(rtype); 2870 pointer_added = 1; 2871 } 2872 2873 ctype = SwigType_str(type, 0); 2874 // EXPORT <SwigType_str> <mangled_name>; 2875 // <SwigType_str> <mangled_name> = <name>; 2876 // Printf(f_runtime, "EXPORT %s %s;\n%s %s = %s%s;\n", ctype, mangled_name, 2877 // ctype, mangled_name, (pointer_added ? "&" : ""), name); 2878 2879 Printf(f_clwrap, "(swig-defvar \"%s\" \"%s\" :type %s)\n", 2880 Getattr(n, "sym:name"), Getattr(n, "sym:name"), ((SwigType_isconst(type)) ? ":constant" : ":variable")); 2881 2882 return SWIG_OK; 2883} 2884 2885int ALLEGROCL::variableWrapper(Node *n) { 2886#ifdef ALLEGROCL_DEBUG 2887 Printf(stderr, "variableWrapper %s\n", Getattr(n, "name")); 2888#endif 2889 Setattr(n, "allegrocl:kind", "variable"); 2890 Setattr(n, "allegrocl:old-sym:name", Getattr(n, "sym:name")); 2891 2892 // Let SWIG generate a get/set function pair. 2893 if (Generate_Wrapper) 2894 return Language::variableWrapper(n); 2895 2896 String *name = Getattr(n, "name"); 2897 SwigType *type = Getattr(n, "type"); 2898 SwigType *ctype; 2899 SwigType *rtype = SwigType_typedef_resolve_all(type); 2900 2901 String *mangled_name = mangle_name(n); 2902 2903 int pointer_added = 0; 2904 2905 if (SwigType_isclass(rtype)) { 2906 SwigType_add_pointer(type); 2907 SwigType_add_pointer(rtype); 2908 pointer_added = 1; 2909 } 2910 2911 ctype = SwigType_str(type, 0); 2912 2913 // EXPORT <SwigType_str> <mangled_name>; 2914 // <SwigType_str> <mangled_name> = <name>; 2915 Printf(f_runtime, "EXPORT %s %s;\n%s %s = %s%s;\n", ctype, mangled_name, ctype, mangled_name, (pointer_added ? "&" : ""), name); 2916 2917 Printf(f_cl, "(swig-defvar \"%s\" :type %s)\n", mangled_name, ((SwigType_isconst(type)) ? ":constant" : ":variable")); 2918 2919 Printf(stderr,"***\n"); 2920 Delete(mangled_name); 2921 2922#ifdef ALLEGROCL_DEBUG 2923 Printf(stderr, "DONE variable %s\n", Getattr(n, "name")); 2924#endif 2925 2926 return SWIG_OK; 2927} 2928 2929int ALLEGROCL::memberfunctionHandler(Node *n) { 2930#ifdef ALLEGROCL_DEBUG 2931 Printf(stderr, "memberfunctionHandler %s::%s\n", Getattr(parent_node_skipping_extends(n), "name"), Getattr(n, "name")); 2932#endif 2933 Setattr(n, "allegrocl:kind", "member function"); 2934 Setattr(n, "allegrocl:old-sym:name", Getattr(n, "sym:name")); 2935 2936 // Let SWIG generate a global forwarding function. 2937 return Language::memberfunctionHandler(n); 2938} 2939 2940int ALLEGROCL::membervariableHandler(Node *n) { 2941#ifdef ALLEGROCL_DEBUG 2942 Printf(stderr, "membervariableHandler %s::%s\n", Getattr(parent_node_skipping_extends(n), "name"), Getattr(n, "name")); 2943#endif 2944 Setattr(n, "allegrocl:kind", "member variable"); 2945 Setattr(n, "allegrocl:old-sym:name", Getattr(n, "sym:name")); 2946 2947 // Let SWIG generate a get/set function pair. 2948 return Language::membervariableHandler(n); 2949} 2950 2951int ALLEGROCL::typedefHandler(Node *n) { 2952#ifdef ALLEGROCL_TYPE_DEBUG 2953 Printf(stderr, "In typedefHandler\n"); 2954#endif 2955 2956 SwigType *typedef_type = Getattr(n,"type"); 2957 // has the side-effect of noting any implicit 2958 // template instantiations in type. 2959 String *ff_type = compose_foreign_type(n, typedef_type); 2960 2961 String *sym_name = Getattr(n, "sym:name"); 2962 2963 String *name; 2964 String *type_ref; 2965 2966 if (in_class) { 2967#ifdef ALLEGROCL_TYPE_DEBUG 2968 Printf(stderr, " typedef in class '%s'(%x)\n", Getattr(in_class, "sym:name"), in_class); 2969#endif 2970 Setattr(n, "allegrocl:typedef:in-class", in_class); 2971 2972 String *class_name = Getattr(in_class, "name"); 2973 name = NewStringf("%s__%s", class_name, sym_name); 2974 type_ref = NewStringf("%s::%s", class_name, sym_name); 2975 Setattr(n, "allegrocl:in-class", in_class); 2976 } else { 2977 name = Copy(sym_name); 2978 type_ref = Copy(Getattr(n, "name")); 2979 } 2980 2981 Setattr(n, "allegrocl:namespace", current_namespace); 2982 2983 String *lookup = lookup_defined_foreign_type(typedef_type); 2984 2985#ifdef ALLEGROCL_TYPE_DEBUG 2986 Printf(stderr, "** lookup='%s'(%x), typedef_type='%s', strcmp = '%d' strstr = '%d'\n", lookup, lookup, typedef_type, Strcmp(typedef_type,"void"), Strstr(ff_type,"__SWIGACL_FwdReference")); 2987#endif 2988 2989 if(lookup || (!lookup && Strcmp(typedef_type,"void")) || 2990 (!lookup && Strstr(ff_type,"__SWIGACL_FwdReference"))) { 2991 add_defined_foreign_type(n, 0, type_ref, name); 2992 } else { 2993 add_forward_referenced_type(n); 2994 } 2995 2996#ifdef ALLEGROCL_TYPE_DEBUG 2997 Printf(stderr, "Out typedefHandler\n"); 2998#endif 2999 3000 Delete(ff_type); 3001 3002 return SWIG_OK; 3003} 3004 3005// forward referenced classes are added specially to defined_foreign_types 3006int ALLEGROCL::classforwardDeclaration(Node *n) { 3007#ifdef ALLEGROCL_DEBUG 3008 Printf(stderr, "classforwardDeclaration %s\n", Getattr(n, "name")); 3009#endif 3010 3011 add_forward_referenced_type(n); 3012 return SWIG_OK; 3013} 3014 3015int ALLEGROCL::classHandler(Node *n) { 3016#ifdef ALLEGROCL_DEBUG 3017 Printf(stderr, "classHandler %s::%s\n", current_namespace, Getattr(n, "sym:name")); 3018#endif 3019 3020 int result; 3021 3022 if (Generate_Wrapper) 3023 result = cppClassHandler(n); 3024 else 3025 result = cClassHandler(n); 3026 3027 return result; 3028} 3029 3030int ALLEGROCL::cClassHandler(Node *n) { 3031#ifdef ALLEGROCL_TYPE_DEBUG 3032 Printf(stderr, "In cClassHandler\n"); 3033#endif 3034 // String *cDeclName = Getattr(n,"classDeclaration:name"); 3035 // String *name= Getattr(n, "sym:name"); 3036 // String *kind = Getattr(n,"kind"); 3037 // Node *c; 3038 3039 /* Add this structure to the known lisp types */ 3040 // Printf(stderr, "Adding %s foreign type\n", name); 3041 String *ns = listify_namespace(current_namespace); 3042 3043 add_defined_foreign_type(n); 3044 3045 Delete(ns); 3046 3047#ifdef ALLEGROCL_TYPE_DEBUG 3048 Printf(stderr, "Out cClassHandler\n"); 3049#endif 3050 3051 return SWIG_OK; 3052} 3053 3054int ALLEGROCL::cppClassHandler(Node *n) { 3055#ifdef ALLEGROCL_DEBUG 3056 Printf(stderr, "cppClassHandler %s\n", Getattr(n, "name")); 3057#endif 3058 3059 // String *name=Getattr(n, "sym:name"); 3060 // String *kind = Getattr(n,"kind"); 3061 3062 /* Template instantiation. 3063 Careful. 3064 SWIG does not create instantiations of templated classes whenever 3065 it sees a templated class reference (say, as a return type, or 3066 in a parameter list). 3067 3068 The %template directive results in a templated class instantiation 3069 that will actually be seen by <LANG> :: classHandler(). 3070 3071 In this case, we don't want to error if the type already exists; 3072 the point is to force the creation of wrappers for the templated 3073 class. 3074 */ 3075 String *templated = Getattr(n, "template"); 3076 String *t_name; 3077 // String *ns = listify_namespace(current_namespace); 3078 3079 if (templated) { 3080 t_name = namespaced_name(n); 3081 } else { 3082 t_name = Getattr(n, "name"); 3083 } 3084 3085 Setattr(n, "allegrocl:namespace", current_namespace); 3086 3087 /* Add this structure to the known lisp types. 3088 Class may contain references to the type currently being 3089 defined */ 3090 if (!templated || !lookup_defined_foreign_type(t_name)) { 3091#ifdef ALLEGROCL_CLASS_DEBUG 3092 Printf(stderr, "Adding %s foreign type\n", Getattr(n, "sym:name")); 3093#endif 3094 add_defined_foreign_type(n); 3095 } else { 3096#ifdef ALLEGROCL_CLASS_DEBUG 3097 Printf(stderr, "cppClassHand: type %s already exists. Assuming %%template instantiation for wrapping purposes.\n", Getattr(n, "sym:name")); 3098#endif 3099 add_defined_foreign_type(n, 1); 3100 } 3101 3102 // Generate slot accessors, constructor, and destructor. 3103 Node *prev_class = in_class; 3104 in_class = n; 3105 3106 Node *c; 3107 // walk all member variables. 3108#ifdef ALLEGROCL_CLASS_DEBUG 3109 Printf(stderr, " MANUALLY walking class members... \n"); 3110#endif 3111 for (c = firstChild(n); c; c = nextSibling(c)) { 3112 // ping the types of all children--even protected and private 3113 // so their types can be added to the linked_type_list. 3114 SwigType *childType = NewStringf("%s%s", Getattr(c, "decl"), 3115 Getattr(c, "type")); 3116#ifdef ALLEGROCL_CLASS_DEBUG 3117 Printf(stderr, "looking at child '%x' of type '%s'\n", c, childType); 3118#endif 3119 if (!SwigType_isfunction(childType)) 3120 Delete(compose_foreign_type(n, childType)); 3121 3122 Delete(childType); 3123 } 3124#ifdef ALLEGROCL_CLASS_DEBUG 3125 Printf(stderr, " MANUAL walk DONE.\n"); 3126#endif 3127 3128 // this will walk all necessary methods. 3129#ifdef ALLEGROCL_CLASS_DEBUG 3130 Printf(stderr, " LANGUAGE walk of children...\n"); 3131#endif 3132 Language::classHandler(n); 3133#ifdef ALLEGROCL_CLASS_DEBUG 3134 Printf(stderr, " LANGUAGE walk DONE\n"); 3135#endif 3136 in_class = prev_class; 3137 3138 return SWIG_OK; 3139} 3140 3141int ALLEGROCL::emit_one(Node *n) { 3142 // When the current package does not correspond with the current 3143 // namespace we need to generate an IN-PACKAGE form, unless the 3144 // current node is another namespace node. 3145 if (Cmp(nodeType(n), "namespace") != 0 && Cmp(current_package, current_namespace) != 0) { 3146 String *lispy_namespace = listify_namespace(current_namespace); 3147 Printf(f_clwrap, "(swig-in-package %s)\n", lispy_namespace); 3148 Delete(lispy_namespace); 3149 Delete(current_package); 3150 current_package = NewStringf("%s", current_namespace); 3151 } 3152 3153 Setattr(n, "allegrocl:package", current_package); 3154 3155 return Language::emit_one(n); 3156} 3157 3158int ALLEGROCL::enumDeclaration(Node *n) { 3159#ifdef ALLEGROCL_DEBUG 3160 Printf(stderr, "enumDeclaration %s\n", Getattr(n, "name")); 3161#endif 3162 3163 if (Getattr(n, "sym:name")) { 3164 add_defined_foreign_type(n); 3165 } 3166 Node *c; 3167 for (c = firstChild(n); c; c = nextSibling(c)) { 3168 ALLEGROCL::enumvalueDeclaration(c); 3169 // since we walk our own children, we need to add 3170 // the current package ourselves. 3171 Setattr(c, "allegrocl:package", current_package); 3172 } 3173 return SWIG_OK; 3174} 3175 3176 3177int ALLEGROCL::enumvalueDeclaration(Node *n) { 3178#ifdef ALLEGROCL_DEBUG 3179 Printf(stderr, "enumvalueDeclaration %s\n", Getattr(n, "name")); 3180#endif 3181 /* print this when in C mode? make this a command-line arg? */ 3182 if (Generate_Wrapper) { 3183 SwigType *enum_type = Copy(Getattr(n,"type")); 3184 String *mangled_name = 3185 mangle_name(n, "ACL_ENUM", 3186 in_class ? Getattr(in_class,"name") : 3187 current_namespace); 3188 3189 SwigType_add_qualifier(enum_type,"const"); 3190 3191 String *enum_decl = SwigType_str(enum_type, mangled_name); 3192 Printf(f_cxx_wrapper, "EXPORT %s;\n", enum_decl); 3193 Printf(f_cxx_wrapper, "%s = %s;\n", enum_decl, Getattr(n, "value")); 3194 3195 Delete(mangled_name); 3196 Delete(enum_type); 3197 Delete(enum_decl); 3198 } 3199 return SWIG_OK; 3200} 3201 3202int ALLEGROCL::templateDeclaration(Node *n) { 3203#ifdef ALLEGROCL_DEBUG 3204 Printf(stderr, "templateDeclaration %s\n", Getattr(n, "name")); 3205#endif 3206 3207 String *type = Getattr(n, "templatetype"); 3208 3209 // Printf(stderr, "tempDecl: %s %s\n", Getattr(n,"name"), 3210 // type); 3211 // Swig_print_node(n); 3212 3213 if (!Strcmp(type, "cdecl")) { 3214 SwigType *ty = NewStringf("%s%s", Getattr(n, "decl"), 3215 Getattr(n, "type")); 3216 Delete(ty); 3217 } 3218 3219 Delete(type); 3220 3221 return SWIG_OK; 3222} 3223