jyapayne/swig
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
swig/SWIG/Source/Modules/allegrocl.cxx
Ahmon Dancy f7ebb5809b Huge update to the Allegrocl module. Better C support. C++ support 
added. Documentation! Makes use of typemaps for better interface
tuning. Improved type support. Wrapping of foreign pointers in
CLOS objects; hopefully a step toward being able to extend C++
classes from Lisp.


git-svn-id: https://swig.svn.sourceforge.net/svnroot/swig/trunk@7828 626c5289-ae23-0410-ae9c-e8d60b6d4f22
2005-11-09 20:44:22 +00:00

2686 lines
82 KiB
C++
Raw Blame History

char cvsroot_allegrocl_cxx[] = "$Header$";
#include <ctype.h>
#include "swigmod.h"
#include "cparse.h"
// #define ALLEGROCL_DEBUG
// #define ALLEGROCL_WRAP_DEBUG
// #define ALLEGROCL_TYPE_DEBUG
// #define ALLEGROCL_CLASS_DEBUG
static File *f_cl=0;
String *f_clhead = NewString("");
String *f_clwrap = NewString("(swig-in-package ())\n\n");
static File *f_cxx=0;
static File *f_cxx_header=0;
static File *f_cxx_wrapper=0;
const char *identifier_converter="identifier-convert-null";
static String *current_namespace=NewString("");
static String *current_package=NewString("");
static Hash *defined_namespace_packages=NewHash();
static Node *in_class = 0;
static Node *first_linked_type=0;
static Hash *defined_foreign_types=NewHash();
static Hash *defined_foreign_ltypes=NewHash();
// stub
String * convert_literal(String *num_param, String *type);
class ALLEGROCL : public Language {
public:
virtual void main(int argc, char *argv[]);
virtual int top(Node *n);
virtual int functionWrapper(Node *n);
virtual int namespaceDeclaration(Node *n);
virtual int constructorHandler(Node *n);
virtual int destructorHandler(Node *n);
virtual int globalvariableHandler(Node *n);
virtual int variableWrapper(Node *n);
virtual int constantWrapper(Node *n);
virtual int memberfunctionHandler(Node *n);
virtual int membervariableHandler(Node *n);
virtual int classHandler(Node *n);
virtual int emit_one(Node *n);
virtual int enumDeclaration(Node *n);
virtual int enumvalueDeclaration(Node *n);
virtual int typedefHandler(Node *n);
virtual int classforwardDeclaration(Node *n);
virtual int templateDeclaration(Node *n);
virtual int validIdentifier(String *s);
private:
int emit_defun(Node *n, File* f_cl);
int emit_dispatch_defun(Node *n);
int emit_buffered_defuns(Node *n);
int cClassHandler(Node *n);
int cppClassHandler(Node *n);
};
static ALLEGROCL* allegrocl = 0;
static String *trim(String *str) {
char *c = Char(str);
while (*c != '\0' && isspace((int)*c))
++c;
String *result = NewString(c);
Chop(result);
return result;
}
int is_integer(String *s) {
char *c = Char(s);
if(c[0] == '#' && (c[1] == 'x' || c[1] == 'o')) c+= 2;
while(*c) {
if(!isdigit(*c)) return 0;
c++;
}
return 1;
}
String *class_from_class_or_class_ref(String *type) {
SwigType *stripped = SwigType_strip_qualifiers(type);
if(SwigType_isclass(stripped)) return stripped;
if(SwigType_ispointer(stripped) || SwigType_isreference(stripped)) {
// Printf(stderr,"It is a pointer/reference. Is it a class?\n");
SwigType_pop(stripped);
if(SwigType_isclass(stripped)) {
return stripped;
}
}
return 0;
}
String *lookup_defined_foreign_type(String *k) {
#ifdef ALLEGROCL_TYPE_DEBUG
Printf(stderr, "Looking up defined type '%s'.\n Found: '%s'\n",
k, Getattr(defined_foreign_types, k));
#endif
return Getattr(defined_foreign_types, k);
}
String *listify_namespace(String *namespaze)
{
if (Len(namespaze) == 0)
return NewString("()");
String *result = NewStringf("(\"%s\")", namespaze);
Replaceall(result, "::", "\" \"");
return result;
}
String *namespaced_name(Node *n, String *ns = current_namespace) {
return NewStringf("%s%s%s",
ns, (Len(ns) != 0) ? "::" : "",
Getattr(n,"sym:name"));
}
// "Namespace::Nested::Class2::Baz" -> "Baz"
static String *strip_namespaces(String *str)
{
char *result = Char(str);
String *stripped_one;
while ((stripped_one = Strstr(result, "::")))
result = Char(stripped_one)+2;
return NewString(result);
}
static String *namespace_of(String *str) {
char *p = Char(str);
char *start = Char(str);
char *result = 0;
String *stripped_one;
while ((stripped_one = Strstr(p, "::")))
p = Char(stripped_one)+2;
if(p > str) {
int len = p - start - 1;
result = (char *)malloc(len);
strncpy(result, start, len-1);
result[len-1] = 0;
}
return Char(result);
}
void add_linked_type(Node *n) {
#ifdef ALLEGROCL_CLASS_DEBUG
Printf(stderr,"Adding linked node of type: %s(%s) %s(%x)\n\n", nodeType(n),
Getattr(n,"storage"), Getattr(n,"name"),n);
#endif
if(!first_linked_type) {
first_linked_type = n;
Setattr(n,"allegrocl:last_linked_type",n);
} else {
Node *t = Getattr(first_linked_type,"allegrocl:last_linked_type");
Setattr(t,"allegrocl:next_linked_type",n);
Setattr(first_linked_type,"allegrocl:last_linked_type",n);
}
}
void replace_linked_type(Node *old, Node *new_node) {
Node *prev = Getattr(old,"allegrocl:prev_linked_type");
Setattr(new_node,"allegrocl:next_linked_type",
Getattr(old,"allegrocl:next_linked_type"));
if(prev) Setattr(prev,"allegrocl:next_linked_type",new_node);
Delattr(old,"allegrocl:next_linked_type");
Delattr(old,"allegrocl:prev_linked_type");
// check if we're replacing the first link.
if(first_linked_type == old) {
first_linked_type = new_node;
Setattr(first_linked_type,"allegrocl:last_linked_type",
Getattr(old,"allegrocl:last_linked_type"));
}
// check if we're replacing the last link.
if(Getattr(first_linked_type,"allegrocl:last_linked_type") == old)
Setattr(first_linked_type,"allegrocl:last_linked_type",new_node);
}
void insert_linked_type_at(Node *old, Node *new_node, int before = 1) {
Node *p = 0;
if(!first_linked_type) {
add_linked_type(new_node);
return;
}
if(!before) {
Setattr(new_node,"allegrocl:next_linked_type",
Getattr(old,"allegrocl:next_linked_type"));
Setattr(old,"allegrocl:next_linked_type",new_node);
if(Getattr(first_linked_type,"allegrocl:last_linked_type") == old)
Setattr(first_linked_type,"allegrocl:last_linked_type",new_node);
} else {
Node *c = first_linked_type;
while(c) {
if(c == old) {
break;
} else {
p = c;
c = Getattr(c,"allegrocl:next_linked_type");
}
}
if(c == old) {
Setattr(new_node,"allegrocl:next_linked_type",c);
if(first_linked_type == c) {
first_linked_type = new_node;
Setattr(first_linked_type,"allegrocl:last_linked_type",
Getattr(c,"allegrocl:last_linked_type"));
Delattr(c,"allegrocl:last_linked_type");
}
if(p) Setattr(p,"allegrocl:next_linked_type",new_node);
}
}
}
Node *find_linked_type_by_name(String *name) {
Node *p = 0;
Node *c = first_linked_type;
// Printf(stderr,"in find_linked_type_by_name '%s'...", name);
while(c) {
// String *cdeclname = Getattr(c,"allegrocl:classDeclarationName");
// String *key = cdeclname ? NewStringf("struct %s",cdeclname) :
// Getattr(c,"name");
String *key = Getattr(c,"name");
// Printf(stderr," X '%s' '%s'", key, name);
// if(!Strcmp(Getattr(c,"name"),name)) {
if(!Strcmp(key,name)) {
break;
} else {
p = c;
c = Getattr(c,"allegrocl:next_linked_type");
}
}
// Printf(stderr,"exit find_linked_type_by_name.\n");
if(p && c) Setattr(c,"allegrocl:prev_linked_type",p);
// Printf(stderr,"DONE\n");
return c;
}
Node *get_primary_synonym_of(Node *n) {
Node *p = Getattr(n,"allegrocl:synonym-of");
Node *prim = n;
// Printf(stderr, "getting primary synonym of %x\n", n);
while(p) {
// Printf(stderr, " found one! %x\n", p);
prim = p;
p = Getattr(p,"allegrocl:synonym-of");
}
// Printf(stderr,"DONE. returning %s(%x)\n", Getattr(prim,"name"),prim);
return prim;
}
void add_defined_foreign_type(Node *n,
int overwrite=0,
String *k=0,
String *name=0,
String *ns=current_namespace) {
String *val;
String *ns_list = listify_namespace(ns);
String *templated = n ? Getattr(n,"template") : 0;
String *cDeclName = n ? Getattr(n,"classDeclaration:name") : 0;
#ifdef ALLEGROCL_TYPE_DEBUG
Printf(stderr,"IN A-D-F-T\n");
#endif
if(n) {
name=Getattr(n,"sym:name");
if(!name) name = Getattr(n,"name");
if(templated) {
k = namespaced_name(n);
} else {
String *kind_of_type = Getattr(n,"kind");
/*
For typedefs of the form:
typedef __xxx { ... } xxx;
add_defined_foreign_type will be called once via classHandler
to define the type for 'struct __xxx', and once via typedefHandler
to associate xxx with 'struct __xxx'.
We create the following type to identifier mappings:
struct __xxx -> (swig-insert-id "xxx") via classHand
xxx -> (swig-insert-id "xxx") via typedefHand
and all references to this typedef'd struct will appear in
generated code as 'xxx'. For non-typedef'd structs, the
classHand mapping will be
struct __xxx -> (swig-insert-id "__xxx")
*/
if(kind_of_type && !Strcmp(kind_of_type,"struct") && cDeclName) {
k = NewStringf("struct %s", cDeclName);
} else {
k = Getattr(n,"name");
// if (cDeclName) Setattr(n,"allegrocl:classDeclarationName",cDeclName);
}
}
// Swig_print_node(n);
}
if(SwigType_istemplate(name)) {
String *temp = strip_namespaces(SwigType_templateprefix(name));
name = NewStringf("%s%s%s", temp, SwigType_templateargs(name), SwigType_templatesuffix(name));
}
val = lookup_defined_foreign_type(k);
int is_fwd_ref = 0;
if(val) is_fwd_ref = !Strcmp(val,"forward-reference");
if(!val || overwrite || is_fwd_ref) {
#ifdef ALLEGROCL_TYPE_DEBUG
Printf(stderr, "Adding defined type '%s' = '%s' '%s' (overwrite=%d)\n",
k, ns, name, overwrite);
#endif
String *mangled_name_gen =
NewStringf("#.(swig-insert-id \"%s\" %s)", name, ns_list);
String *mangled_lname_gen =
NewStringf("#.(swig-insert-id \"%s\" %s :type :class)", name, ns_list);
Setattr(defined_foreign_types,Copy(k),Copy(mangled_name_gen));
Setattr(defined_foreign_ltypes,Copy(k),Copy(mangled_lname_gen));
#ifdef ALLEGROCL_TYPE_DEBUG
Printf(stderr,"looking to add %s/%s(%x) to linked_type_list...\n", k, name, n);
#endif
if(is_fwd_ref) {
// Printf(stderr,"*** 1\n");
add_linked_type(n);
} else {
// Printf(stderr,"*** 1-a\n");
if(SwigType_istemplate(k)) {
SwigType *resolved = SwigType_typedef_resolve_all(k);
// Printf(stderr,"*** 1-b\n");
Node *match = find_linked_type_by_name(resolved);
Node *new_node = 0;
// Printf(stderr, "*** temp-1\n");
if (n) {
new_node = n;
} else {
#ifdef ALLEGROCL_CLASS_DEBUG
Printf(stderr,"Creating a new templateInst:\n");
Printf(stderr," name = %s\n", resolved);
Printf(stderr," sym:name = %s\n", name);
Printf(stderr," real-name = %s\n", k);
Printf(stderr," type = %s\n", resolved);
Printf(stderr," ns = %s\n\n", ns);
#endif
new_node = NewHash();
Setattr(new_node,"nodeType","templateInst");
Setattr(new_node,"name",Copy(resolved));
Setattr(new_node,"sym:name",Copy(name));
Setattr(new_node,"real-name",Copy(k));
Setattr(new_node,"type",Copy(resolved));
Setattr(new_node,"allegrocl:namespace",ns);
Setattr(new_node,"allegrocl:package",ns);
}
if(!match) {
if(!Strcmp(nodeType(new_node),"templateInst") && in_class) {
/* this is an implicit template instantiation found while
walking a class. need to insert this into the
linked_type list before the current class definition */
#ifdef ALLEGROCL_CLASS_DEBUG
Printf(stderr,"trying to insert a templateInst before a class\n");
#endif
insert_linked_type_at(in_class,new_node);
#ifdef ALLEGROCL_CLASS_DEBUG
Printf(stderr,"DID IT!\n");
#endif
} else {
// Printf(stderr,"*** 3\n");
add_linked_type(new_node);
}
Setattr(new_node,"allegrocl:synonym:is-primary","1");
} else {
// a synonym type was found (held in variable 'match')
// Printf(stderr, "setting primary synonym of %x to %x\n", new_node, match);
if(new_node == match) Printf(stderr,"Hey-4 * - '%s' is a synonym of iteself!\n", Getattr(new_node,"name"));
Setattr(new_node,"allegrocl:synonym-of",match);
// Printf(stderr,"*** 4\n");
add_linked_type(new_node);
}
} else {
Node *match;
if(!Strcmp(nodeType(n),"cdecl") &&
!Strcmp(Getattr(n,"storage"),"typedef")) {
SwigType *type = SwigType_strip_qualifiers(Getattr(n,"type"));
#ifdef ALLEGROCL_TYPE_DEBUG
Printf(stderr,"Examining typedef '%s' for class references.\n", type);
// Printf(stderr," k='%s' v='%s'\n k='%s' v='%s'\n",
// type, Getattr(defined_foreign_types,type),
// k, Getattr(defined_foreign_types,k));
Printf(stderr," the strstr() = %d, strcmp() = %d", Strstr(type,"struct "), !Strcmp(Getattr(defined_foreign_types,type),Getattr(defined_foreign_types,k)));
bool a = Strstr(type,"struct ") && !Strcmp(Getattr(defined_foreign_types,type),Getattr(defined_foreign_types,k));
bool b = !a;
Printf(stderr,", and'd=%d, not-and'd=%d\n", a, b);
#endif
if(SwigType_isclass(type)) {
#ifdef ALLEGROCL_CLASS_DEBUG
Printf(stderr,"Found typedef of a class '%s'\n", type);
#endif
/*
For the following parsed expression:
typedef struct __xxx { ... } xxx;
if n is of kind "class" (defining the class 'struct __xxx'
then we add n to the linked type list.
if n is "cdecl" node of storage "typedef" (to note
that xxx is equivalent to 'struct __xxx' then we don't
want to add this node to the linked type list.
*/
if(Strstr(type,"struct ") &&
!Strcmp(lookup_defined_foreign_type(type),
lookup_defined_foreign_type(k))) {
// mark as a synonym but don't add to linked_type list
Setattr(n,"allegrocl:synonym","1");
} else {
SwigType *lookup_type = SwigType_istemplate(type) ?
SwigType_typedef_resolve_all(type) : Copy(type);
match = find_linked_type_by_name(lookup_type);
if(match) {
Setattr(n,"allegrocl:synonym","1");
Setattr(n,"allegrocl:synonym-of",match);
// if(n == match) Printf(stderr, "Hey-5 * setting synonym of %x to %x\n", n, match);
// Printf(stderr,"*** 5\n");
add_linked_type(n);
} else {
// Printf(stderr,"Weird! Can't find the type!\n");
}
Delete(lookup_type);
}
} else {
// check if it's a pointer or reference to a class.
// Printf(stderr,"Checking if '%s' is a p. or r. to a class\n", type);
String *class_ref = class_from_class_or_class_ref(type);
if(class_ref) {
match = find_linked_type_by_name(class_ref);
Setattr(n,"allegrocl:synonym","1");
Setattr(n,"allegrocl:synonym-of",match);
add_linked_type(n);
}
}
Delete(type);
// synonym types have already been added.
// Printf(stderr,"*** 10\n");
if(!Getattr(n,"allegrocl:synonym")) add_linked_type(n);
} else if(Getattr(n,"template")) {
// Printf(stderr, "this is a class template node(%s)\n", nodeType(n));
String *resolved = SwigType_typedef_resolve_all(Getattr(n,"name"));
#ifdef ALLEGROCL_CLASS_DEBUG
Printf(stderr, " looking up %s for linked type match with %s...\n", Getattr(n,"sym:name"), resolved);
#endif
match = find_linked_type_by_name(resolved);
if (!match) {
#ifdef ALLEGROCL_CLASS_DEBUG
Printf(stderr, "found no implicit instantiation of %%template node %s(%x)\n", Getattr(n,"name"),n);
#endif
add_linked_type(n);
} else {
Node *primary = get_primary_synonym_of(match);
Setattr(n,"allegrocl:synonym:is-primary","1");
Delattr(primary,"allegrocl:synonym:is-primary");
if(n == match) Printf(stderr, "Hey-7 * setting synonym of %x to %x\n (match = %x)", primary, n, match);
Setattr(primary,"allegrocl:synonym-of",n);
// Printf(stderr,"*** 7\n");
add_linked_type(n);
}
} else {
#ifdef ALLEGROCL_CLASS_DEBUG
Printf(stderr, "linking type %s(%x)\n", k, n);
#endif
// Printf(stderr,"*** 8\n");
add_linked_type(n);
}
}
}
Delete(mangled_name_gen);
Delete(mangled_lname_gen);
} else {
Swig_warning(WARN_TYPE_REDEFINED, Getfile(n), Getline(n),
"Attempting to store a foreign type that exists: %s\n", k);
}
Delete(ns_list);
#ifdef ALLEGROCL_TYPE_DEBUG
Printf(stderr,"OUT A-D-F-T\n");
#endif
}
void note_implicit_template_instantiation(SwigType *t) {
// the namespace of the implicit instantiation is not necessarily
// current_namespace. Attempt to cull this from the type.
#ifdef ALLEGROCL_CLASS_DEBUG
Printf(stderr,"culling namespace of '%s' from '%s'\n", t, SwigType_templateprefix(t));
#endif
String *implicit_ns = namespace_of(SwigType_templateprefix(t));
add_defined_foreign_type(0, 0, t, t, implicit_ns ? implicit_ns : current_namespace);
}
String *get_ffi_type(SwigType *ty, const String_or_char *name) {
/* lookup defined foreign type.
if it exists, it will return a form suitable for placing
into lisp code to generate the def-foreign-type name */
#ifdef ALLEGROCL_TYPE_DEBUG
Printf(stderr, "inside g_f_t: looking up %s\n", ty);
#endif
String *found_type = lookup_defined_foreign_type(ty);
if (found_type) {
return (Strcmp(found_type,"forward-reference") ?
Copy(found_type) : NewString(":void"));
} else {
Hash *typemap = Swig_typemap_search("ffitype", ty, name, 0);
if (typemap) {
String *typespec = Getattr(typemap, "code");
return NewString(typespec);
}
if(SwigType_istemplate(ty)) {
note_implicit_template_instantiation(ty);
return Copy(lookup_defined_foreign_type(ty));
}
}
return 0;
}
String *lookup_defined_foreign_ltype(String *l) {
#ifdef ALLEGROCL_TYPE_DEBUG
Printf(stderr, "Looking up defined ltype '%s'.\n Found: '%s'\n",
l, Getattr(defined_foreign_ltypes, l));
#endif
return Getattr(defined_foreign_ltypes, l);
}
/* walk type and return string containing lisp version.
recursive. */
String *internal_compose_foreign_type(SwigType *ty) {
SwigType *tok;
String *ffiType = NewString("");
// for a function type, need to walk the parm list.
while(Len(ty) != 0) {
tok = SwigType_pop(ty);
if(SwigType_isfunction(tok)) {
// Generate Function wrapper
Printf(ffiType, "(:function ");
// walk parm list
List *pl = SwigType_parmlist(tok);
Printf(ffiType, "("); // start parm list
for (Iterator i=First(pl); i.item; i = Next(i)) {
SwigType *f_arg = SwigType_strip_qualifiers(i.item);
Printf(ffiType, "%s ", internal_compose_foreign_type(f_arg));
Delete(f_arg);
}
Printf(ffiType, ")"); // end parm list.
// do function return type.
Printf(ffiType, " %s)", internal_compose_foreign_type(ty));
break;
} else if (SwigType_ispointer(tok) || SwigType_isreference(tok)) {
Printf(ffiType, "(* %s)", internal_compose_foreign_type(ty));
} else if (SwigType_isarray(tok)) {
Printf(ffiType, "(:array %s", internal_compose_foreign_type(ty));
String *atype = NewString("int");
String *dim = convert_literal(SwigType_array_getdim(tok, 0),atype);
Delete(atype);
if(is_integer(dim)) {
Printf(ffiType, " %s)", dim);
} else {
Printf(ffiType, " #| %s |#)", SwigType_array_getdim(tok,0));
}
} else if (SwigType_ismemberpointer(tok)) {
// temp
Printf(ffiType, "(* %s)", internal_compose_foreign_type(ty));
} else {
String *res;
if ((res = get_ffi_type(tok, ""))) {
Printf(ffiType, "%s", res);
} else {
SwigType *resolved_type = SwigType_typedef_resolve(tok);
while(resolved_type) {
res = get_ffi_type(resolved_type, "");
if (res) {
Printf(ffiType, "%s", res);
break;
} else {
resolved_type = SwigType_typedef_resolve(tok);
}
}
if(!resolved_type) {
Printf(stderr,"Unknown datatype: %s\n", tok);
Printf(ffiType, "(* :void)");
}
}
}
}
return ffiType;
}
String *compose_foreign_type(SwigType *ty) {
/* should we allow named lookups in the typemap here? */
SwigType *temp = SwigType_strip_qualifiers(ty);
String *res = internal_compose_foreign_type(temp);
Delete(temp);
return res;
}
void update_package_if_needed(Node *n, File *f = f_clwrap) {
#ifdef ALLEGROCL_DEBUG
Printf(stderr, "update_package: ENTER... ");
Printf(stderr, " current_package = '%s'\n", current_package);
Printf(stderr, " node_package = '%s'\n", Getattr(n,"allegrocl:package"));
Printf(stderr, " node(%x) = '%s'\n", n, Getattr(n,"name"));
#endif
String *node_package = Getattr(n,"allegrocl:package");
if(Strcmp(current_package,node_package)) {
String *lispy_package = listify_namespace(node_package);
Delete(current_package);
current_package = Copy(node_package);
Printf(f,"\n(swig-in-package %s)\n", lispy_package);
Delete(lispy_package);
}
#ifdef ALLEGROCL_DEBUG
Printf(stderr,"EXIT\n");
#endif
}
static String *mangle_name(Node *n, char const *prefix = "ACL",
String *ns = current_namespace)
{
String* suffix = Getattr(n, "sym:overname");
String *pre_mangled_name =
NewStringf("%s_%s__%s%s", prefix, ns, Getattr(n, "sym:name"), suffix);
String *mangled_name = Swig_name_mangle(pre_mangled_name);
Delete(pre_mangled_name);
return mangled_name;
}
/* utilities */
/* returns new string w/ parens stripped */
String *strip_parens(String *string) {
string = Copy(string);
Replaceall(string, "(", "");
Replaceall(string, ")", "");
return string;
/*
char *s=Char(string), *p;
int len=Len(string);
String *res;
if (len==0 || s[0] != '(' || s[len-1] != ')') {
return NewString(string);
}
p=(char *)malloc(len-2+1);
if (!p) {
Printf(stderr, "Malloc failed\n");
SWIG_exit(EXIT_FAILURE);
}
strncpy(p, s+1, len-1);
p[len-2]=0; // null terminate
res=NewString(p);
free(p);
return res;
*/
}
int ALLEGROCL :: validIdentifier(String *s) {
char *c = Char(s);
if (*c && !isalpha(*c) && *c != '_') return 0;
while (*c) {
if (!isalnum(*c) && *c != '_') return 0;
c++;
}
return 1;
}
String *infix_to_prefix(String *val, char split_op, const String *op, String *type) {
List *ored = Split(val, split_op, -1);
if (Len(ored) > 1) {
String *result = NewStringf("(%s", op);
for (Iterator i = First(ored); i.item; i = Next(i)) {
String *converted = convert_literal(i.item, type);
Printf(result, " %s", converted);
Delete(converted);
}
Printf(result, ")");
Delete(ored);
return result;
}
else {
Delete(ored);
}
return 0;
}
/* to be called by code generating the lisp interface */
String * convert_literal(String *num_param, String *type) {
String *trimmed = trim(num_param);
String *num=strip_parens(trimmed), *res=0;
char *s=Char(num);
// very basic parsing of infix expressions.
if(res = infix_to_prefix(num, '|', "logior", type)) return res;
if(res = infix_to_prefix(num, '&', "logand", type)) return res;
if(res = infix_to_prefix(num, '*', "*", type)) return res;
if(res = infix_to_prefix(num, '/', "/", type)) return res;
if(res = infix_to_prefix(num, '+', "+", type)) return res;
if(res = infix_to_prefix(num, '-', "-", type)) return res;
if (SwigType_type(type) == T_FLOAT ||
SwigType_type(type) == T_DOUBLE ||
SwigType_type(type) == T_LONGDOUBLE) {
// Use CL syntax for float literals
String *oldnum = Copy(num);
int fsuffixes = Replaceall(num, "f", "") + Replaceall(num, "F", "");
int lsuffixes = Replaceall(num, "l", "") + Replaceall(num, "L", "");
char const *lisp_exp = fsuffixes ? "f" : (lsuffixes ? "l" : "d");
int exponents = Replaceall(num, "e", lisp_exp) +
Replaceall(num, "E", lisp_exp);
if ((fsuffixes + lsuffixes) > 1 || exponents > 1) {
Printf(stderr, "Weird!! number %s looks invalid.\n", oldnum);
SWIG_exit(EXIT_FAILURE);
}
if (!exponents)
Printf(num, "%s0", lisp_exp);
Delete(oldnum); Delete(trimmed);
return num;
}
else if (SwigType_type(type) == T_CHAR) {
/* Use CL syntax for character literals */
Delete(num); Delete(trimmed);
return NewStringf("#\\%s", num_param);
}
else if (SwigType_type(type) == T_STRING) {
/* Use CL syntax for string literals */
Delete(num); Delete(trimmed);
return NewStringf("\"%s\"", num_param);
}
else if (allegrocl->validIdentifier(num)) {
/* convert C/C++ identifiers to CL symbols */
String *ns = listify_namespace(current_namespace);
res = NewStringf("#.(swig-insert-id \"%s\" %s :type :constant)", num, ns);
Delete(num); Delete(trimmed); Delete(ns);
return res;
}
else if (Len(num) >= 1 && isdigit(s[0])) {
/* use CL syntax for numbers */
String *oldnum = Copy(num);
int usuffixes = Replaceall(num, "u", "") + Replaceall(num, "U", "");
int lsuffixes = Replaceall(num, "l", "") + Replaceall(num, "L", "");
if (usuffixes > 1 || lsuffixes > 1) {
Printf(stderr, "Weird!! number %s looks invalid.\n", oldnum);
SWIG_exit(EXIT_FAILURE);
}
s = Char(num);
if (s[0] == '0' && Len(num) >= 2) {
/*octal or hex */
res=NewStringf("#%c%s",
tolower(s[1]) == 'x' ? 'x' : 'o',
s+2);
Delete(num);
}
else
{
res=num;
}
Delete(oldnum); Delete(trimmed);
return res;
} else {
Delete(trimmed);
return num;
}
}
void emit_stub_class(Node *n) {
String *name = Getattr(n,"sym:name");
if(Getattr(n,"allegrocl:synonym:already-been-stubbed")) return;
if(SwigType_istemplate(name)) {
String *temp = strip_namespaces(SwigType_templateprefix(name));
name = NewStringf("%s%s%s", temp,
SwigType_templateargs(name),
SwigType_templatesuffix(name));
Delete(temp);
} else {
name = strip_namespaces(name);
}
// Printf(f_clhead, ";; from emit-stub-class\n");
update_package_if_needed(n,f_clhead);
Printf(f_clhead, ";; class template stub.\n");
Printf(f_clhead,"(swig-def-foreign-stub \"%s\")\n", name);
Setattr(n,"allegrocl:synonym:already-been-stubbed","1");
}
void emit_synonym(Node *synonym) {
// Printf(stderr,"in emit_synonym for %s(%x)\n", Getattr(synonym,"name"),synonym);
int is_tempInst = !Strcmp(nodeType(synonym),"templateInst");
String *synonym_type;
Node *of = get_primary_synonym_of(synonym);
if(is_tempInst) {
synonym_type = Getattr(synonym,"real-name");
} else {
synonym_type = Getattr(synonym,"name");
}
String *synonym_ns = listify_namespace(Getattr(synonym,"allegrocl:namespace"));
// String *of_cdeclname = Getattr(of,"allegrocl:classDeclarationName");
String *of_ns = Getattr(of,"allegrocl:namespace");
String *of_ns_list = listify_namespace(of_ns);
// String *of_name = of_cdeclname ? NewStringf("struct %s", Getattr(of,"name")) : NewStringf("%s::%s", of_ns, Getattr(of,"sym:name"));
// String *of_name = NewStringf("%s::%s", of_ns, Getattr(of,"sym:name"));
String *of_name = namespaced_name(of, of_ns);
String *syn_ltype = lookup_defined_foreign_ltype(synonym_type);
String *syn_type = lookup_defined_foreign_type(synonym_type);
String *of_ltype = lookup_defined_foreign_ltype(of_name);
// Printf(f_clhead,";; from emit-synonym\n");
Printf(f_clhead,"(swig-def-synonym-type %s\n %s\n %s)\n", syn_ltype, of_ltype, syn_type);
Delete(synonym_ns);
Delete(of_ns_list);
Delete(of_name);
}
void emit_full_class(Node *n) {
String *name=Getattr(n, "sym:name");
String *kind = Getattr(n,"kind");
// Printf(stderr,"in emit_full_class: '%s'(%x).", Getattr(n,"name"),n);
if(Getattr(n,"allegrocl:synonym-of")) {
// Printf(stderr,"but it's a synonym of something.\n");
update_package_if_needed(n,f_clhead);
emit_synonym(n);
return;
}
// collect superclasses
String *bases = Getattr(n,"bases");
String *supers = NewString("(");
if(bases) {
int first=1;
for (Iterator i=First(bases); i.item; i = Next(i)) {
if (!first) Printf(supers," ");
String *s = lookup_defined_foreign_ltype(Getattr(i.item,"name"));
// String *name = Getattr(i.item,"name");
if(s) {
Printf(supers,"%s",s);
} else {
#ifdef ALLEGROCL_TYPE_DEBUG
Printf(stderr,"emit_templ_inst: did not find ltype for base class %s (%s)", Getattr(i.item,"name"), Getattr(n,"allegrocl:namespace"));
#endif
}
}
} else {
Printf(supers,"ff:foreign-pointer");
}
Printf(supers,")");
// Walk children to generate type definition.
String *slotdefs = NewString(" ");
Node *c;
for (c=firstChild(n); c; c=nextSibling(c)) {
String *storage_type = Getattr(c,"storage");
if((!Strcmp(nodeType(c),"cdecl") &&
(!storage_type || Strcmp(storage_type,"typedef")))) {
String *access = Getattr(c,"access");
SwigType *childType=NewStringf("%s%s", Getattr(c,"decl"),
Getattr(c,"type"));
String *cname = (access && Strcmp(access,"public")) ?
NewString("nil") : Copy(Getattr(c,"name"));
if(!SwigType_isfunction(childType)) {
// Printf(slotdefs, ";;; member functions don't appear as slots.\n ");
// Printf(slotdefs, ";; ");
String *ns = listify_namespace(Getattr(n, "allegrocl:package"));
Printf(slotdefs, "(#.(swig-insert-id \"%s\" %s :type :slot :class \"%s\") %s)",
cname, ns, name, compose_foreign_type(childType));
Delete(ns);
if(access && Strcmp(access,"public"))
Printf(slotdefs, " ;; %s member", access);
Printf(slotdefs, "\n ");
}
Delete(childType);
Delete(cname);
}
}
String *ns_list = listify_namespace(Getattr(n,"allegrocl:namespace"));
update_package_if_needed(n,f_clhead);
Printf(f_clhead,
"(swig-def-foreign-class \"%s\"\n %s\n (:%s\n%s))\n\n",
name, supers, kind, slotdefs);
Delete(supers);
Delete(ns_list);
}
void emit_class(Node *n) {
int is_tempInst = !Strcmp(nodeType(n),"templateInst");
String *ns_list = listify_namespace(Getattr(n,"allegrocl:namespace"));
String *name = Getattr(n,is_tempInst ? "real-name" : "name");
if(SwigType_istemplate(name)) {
String *temp = strip_namespaces(SwigType_templateprefix(name));
name = NewStringf("%s%s%s", temp,
SwigType_templateargs(name),
SwigType_templatesuffix(name));
Delete(temp);
} else {
name = strip_namespaces(name);
}
// Printf(stderr,"in emit-class: %s(%x)\n", name, n);
if(Getattr(n,"allegrocl:synonym:is-primary")) {
// Printf(stderr," is primary... ");
if(is_tempInst) {
emit_stub_class(n);
} else {
emit_full_class(n);
}
} else {
// Node *primary = Getattr(n,"allegrocl:synonym-of");
Node *primary = get_primary_synonym_of(n);
if(primary && (primary != n)) {
// Printf(stderr," emitting synonym... ");
emit_stub_class(primary);
update_package_if_needed(n,f_clhead);
emit_synonym(n);
} else {
emit_full_class(n);
}
}
// Printf(stderr,"DONE\n");
Delete(name);
Delete(ns_list);
}
void emit_typedef(Node *n) {
String *name;
String *sym_name = Getattr(n,"sym:name");
String *type = NewStringf("%s%s", Getattr(n,"decl"), Getattr(n,"type"));
String *lisp_type = compose_foreign_type(type);
Delete(type);
Node *in_class = Getattr(n,"allegrocl:typedef:in-class");
// Printf(stderr,"in emit_typedef: '%s'(%x).",Getattr(n,"name"),n);
if(Getattr(n,"allegrocl:synonym-of")) {
// Printf(stderr," but it's a synonym of something.\n");
emit_synonym(n);
return;
}
if(in_class) {
String *class_name = Getattr(in_class,"name");
if(SwigType_istemplate(class_name)) {
String *temp = strip_namespaces(SwigType_templateprefix(class_name));
class_name = NewStringf("%s%s%s", temp,
SwigType_templateargs(class_name),
SwigType_templatesuffix(class_name));
Delete(temp);
}
name = NewStringf("%s__%s",class_name,sym_name);
Setattr(n,"allegrocl:in-class",in_class);
} else {
name = Copy(sym_name);
}
// leave these in for now. might want to change these to def-foreign-class at some point.
// Printf(f_clhead, ";; %s\n", SwigType_typedef_resolve_all(lisp_type));
Printf(f_clhead, "(swig-def-foreign-type \"%s\"\n %s)\n", name, lisp_type);
Delete(name);
}
void emit_enum_type_no_wrap(Node *n) {
if(String *name=Getattr(n,"sym:name")) {
String *ns = listify_namespace(current_namespace);
SwigType *enumtype = compose_foreign_type(Getattr(n,"type"));
Printf(f_clhead,"(swig-def-foreign-type \"%s\" %s)\n", name, enumtype);
Delete(ns);
// walk children.
Node *c;
for(c = firstChild(n); c; c=nextSibling(c)) {
if(!Getattr(c,"error")) {
String *val = Getattr(c,"enumvalue");
if(!val) val = Getattr(c,"enumvalueex");
val = convert_literal(val,Getattr(c,"type"));
String *valname = Getattr(c,"sym:name");
Printf(f_clhead,"(swig-defconstant \"%s\" %s)\n", valname, val);
}
}
}
Printf(f_clhead,"\n");
}
void emit_enum_type(Node *n) {
if(!CPlusPlus) {
emit_enum_type_no_wrap(n);
return;
}
if(String *name=Getattr(n,"sym:name")) {
String *ns = listify_namespace(current_namespace);
SwigType *enumtype = compose_foreign_type(Getattr(n,"type"));
Printf(f_clhead,"(swig-def-foreign-type \"%s\" %s)\n", name, enumtype);
Delete(ns);
// walk children.
Node *c;
for(c = firstChild(n); c; c=nextSibling(c)) {
String *mangled_name = mangle_name(c, "ACL_ENUM", Getattr(c,"allegrocl:package"));
Printf(f_clhead, "(swig-defvar \"%s\" \"%s\" :type :constant)\n",
Getattr(c, "sym:name"), mangled_name);
Delete(mangled_name);
}
}
}
void emit_default_linked_type(Node *n) {
// catchall for non class types.
if(!Strcmp(nodeType(n),"classforward")) {
Printf(f_clhead,";; forward referenced stub.\n");
Printf(f_clhead,"(swig-def-foreign-type \"%s\" (:class ))\n\n",
Getattr(n,"sym:name"));
} else if(!Strcmp(nodeType(n),"enum")) {
emit_enum_type(n);
} else {
Printf(stderr,"Don't know how to emit node type '%s' named '%s'\n",
nodeType(n), Getattr(n,"name"));
}
}
void dump_linked_types(File *f) {
Node *n = first_linked_type;
int i = 0;
while(n) {
Printf(f,"%d: (%x) node '%s' name '%s'\n", i++, n, nodeType(n), Getattr(n,"sym:name"));
Node *t;
if(t = Getattr(n,"allegrocl:synonym-of"))
Printf(f," synonym-of %s(%x)\n",Getattr(t,"name"),t);
n = Getattr(n,"allegrocl:next_linked_type");
}
}
void emit_linked_types() {
Node *n = first_linked_type;
while(n) {
String *node_type = nodeType(n);
// Printf(stderr,"emitting node %s(%x) of type %s.", Getattr(n,"name"),n, nodeType(n));
if(!Strcmp(node_type,"class") || !Strcmp(node_type,"templateInst")) {
// may need to emit a stub, so it will update the package itself.
// Printf(stderr," Passing to emit_class.");
emit_class(n);
} else if(!Strcmp(nodeType(n),"cdecl")) {
// Printf(stderr," Passing to emit_typedef.");
update_package_if_needed(n,f_clhead);
emit_typedef(n);
} else {
// Printf(stderr," Passing to default_emitter.");
update_package_if_needed(n,f_clhead);
emit_default_linked_type(n);
}
n = Getattr(n,"allegrocl:next_linked_type");
// Printf(stderr,"returned.\n");
}
}
extern "C" Language *swig_allegrocl(void) {
return (allegrocl = new ALLEGROCL());
}
void ALLEGROCL :: main(int argc, char *argv[]) {
int i;
SWIG_library_directory("allegrocl");
SWIG_config_file("allegrocl.swg");
for(i=1; i<argc; i++) {
if (!strcmp(argv[i], "-identifier-converter")) {
char *conv=argv[i+1];
if (!conv)
Swig_arg_error();
Swig_mark_arg(i);
Swig_mark_arg(i+1);
i++;
/* check for built-ins */
if (!strcmp(conv, "lispify")) {
identifier_converter="identifier-convert-lispify";
} else if (!strcmp(conv, "null")) {
identifier_converter="identifier-convert-null";
} else {
/* Must be user defined */
char *idconv = new char[strlen(conv)+1];
strcpy(idconv, conv);
identifier_converter=idconv;
}
}
if (!strcmp(argv[i], "-help")) {
fprintf(stdout, "Allegro CL Options (available with -allegrocl)\n");
fprintf(stdout,
" -identifier-converter <type or funcname>\n"
"\tSpecifies the type of conversion to do on C identifiers to convert\n"
"\tthem to symbols. There are two built-in converters: 'null' and\n"
"\t 'lispify'. The default is 'null'. If you supply a name other\n"
"\tthan one of the built-ins, then a function by that name will be\n"
"\tcalled to convert identifiers to symbols.\n");
}
}
allow_overloading();
}
int ALLEGROCL :: top(Node *n) {
String *module=Getattr(n, "name");
String *cxx_filename=Getattr(n, "outfile");
String *cl_filename=NewString("");
Printf(cl_filename, "%s%s.cl", SWIG_output_directory(), module);
f_cl=NewFile(cl_filename, "w");
if (!f_cl) {
Printf(stderr, "Unable to open %s for writing\n", cl_filename);
SWIG_exit(EXIT_FAILURE);
}
if (CPlusPlus)
{
f_cxx=NewFile(cxx_filename, "w");
if (!f_cxx) {
Close(f_cl); Delete(f_cl);
Printf(stderr, "Unable to open %s for writing\n", cxx_filename);
SWIG_exit(EXIT_FAILURE);
}
}
else f_cxx=NewString("");
f_cxx_header = f_cxx;
f_cxx_wrapper=NewString("");
Swig_register_filebyname("header",f_cxx_header);
Swig_register_filebyname("wrapper",f_cxx_wrapper);
Swig_register_filebyname("runtime",f_cxx);
Swig_register_filebyname("lisp", f_clwrap);
Swig_register_filebyname("lisphead", f_cl);
Printf(f_cl, ";; This is an automatically generated file. Make changes in\n"
";; the definition file, not here.\n\n"
"(defpackage :swig\n"
" (:use :common-lisp :ff :excl)\n"
" (:export #:*swig-identifier-converter* #:*swig-module-name*))\n"
"(in-package :swig)\n\n"
"(eval-when (compile load eval)\n"
" (defparameter *swig-identifier-converter* '%s)\n"
" (defparameter *swig-module-name* :%s))\n\n",
identifier_converter, module);
Printf(f_cl, "(defpackage :%s\n"
" (:use :common-lisp :swig :ff :excl))\n\n",
module);
Language::top(n);
// SwigType_emit_type_table(f_cxx,f_cxx_wrapper);
// Swig_print_tree(n);
#ifdef ALLEGROCL_TYPE_DEBUG
dump_linked_types(stderr);
#endif
emit_linked_types();
Printf(f_clwrap, "\n(in-package :swig)\n");
Printf(f_clwrap, "\n(macrolet ((swig-do-export ()\n");
Printf(f_clwrap, " `(dolist (s ',*swig-export-list*)\n");
Printf(f_clwrap, " (apply #'export s))))\n");
Printf(f_clwrap, " (swig-do-export))\n");
Printf(f_clwrap, "\n(setq *swig-export-list* nil)\n");
Printf(f_cl, "%s\n", f_clhead);
Printf(f_cl, "%s\n", f_clwrap);
Printf(stderr, "All done now!\n");
Close(f_cl);
Delete(f_cl); // Delete the handle, not the file
Delete(f_clhead);
Delete(f_clwrap);
/*if (CPlusPlus)*/ Close(f_cxx);
Delete(f_cxx);
Delete(f_cxx_wrapper);
// Swig_print_tree(n);
return SWIG_OK;
}
/* very shamelessly 'borrowed' from overload.cxx, which
keeps the below Swig_overload_rank() code to itself.
We don't need a dispatch function in the C++ wrapper
code; we want it over on the lisp side. */
#define MAX_OVERLOAD 256
/* Overload "argc" and "argv" */
// String *argv_template_string;
// String *argc_template_string;
struct Overloaded {
Node *n; /* Node */
int argc; /* Argument count */
ParmList *parms; /* Parameters used for overload check */
int error; /* Ambiguity error */
};
/* -----------------------------------------------------------------------------
* Swig_overload_rank()
*
* This function takes an overloaded declaration and creates a list that ranks
* all overloaded methods in an order that can be used to generate a dispatch
* function.
* Slight difference in the way this function is used by scripting languages and
* statically typed languages. The script languages call this method via
* Swig_overload_dispatch() - where wrappers for all overloaded methods are generated,
* however sometimes the code can never be executed. The non-scripting languages
* call this method via Swig_overload_check() for each overloaded method in order
* to determine whether or not the method should be wrapped. Note the slight
* difference when overloading methods that differ by const only. The
* scripting languages will ignore the const method, whereas the non-scripting
* languages ignore the first method parsed.
* ----------------------------------------------------------------------------- */
static List *
Swig_overload_rank(Node *n, bool script_lang_wrapping) {
Overloaded nodes[MAX_OVERLOAD];
int nnodes = 0;
Node *o = Getattr(n,"sym:overloaded");
Node *c;
if (!o) return 0;
c = o;
while (c) {
if (Getattr(c,"error")) {
c = Getattr(c,"sym:nextSibling");
continue;
}
/* if (SmartPointer && Getattr(c,"cplus:staticbase")) {
c = Getattr(c,"sym:nextSibling");
continue;
} */
/* Make a list of all the declarations (methods) that are overloaded with
* this one particular method name */
if (Getattr(c,"wrap:name")) {
nodes[nnodes].n = c;
nodes[nnodes].parms = Getattr(c,"wrap:parms");
nodes[nnodes].argc = emit_num_required(nodes[nnodes].parms);
nodes[nnodes].error = 0;
nnodes++;
}
c = Getattr(c,"sym:nextSibling");
}
/* Sort the declarations by required argument count */
{
int i,j;
for (i = 0; i < nnodes; i++) {
for (j = i+1; j < nnodes; j++) {
if (nodes[i].argc > nodes[j].argc) {
Overloaded t = nodes[i];
nodes[i] = nodes[j];
nodes[j] = t;
}
}
}
}
/* Sort the declarations by argument types */
{
int i,j;
for (i = 0; i < nnodes-1; i++) {
if (nodes[i].argc == nodes[i+1].argc) {
for (j = i+1; (j < nnodes) && (nodes[j].argc == nodes[i].argc); j++) {
Parm *p1 = nodes[i].parms;
Parm *p2 = nodes[j].parms;
int differ = 0;
int num_checked = 0;
while (p1 && p2 && (num_checked < nodes[i].argc)) {
// Printf(stdout,"p1 = '%s', p2 = '%s'\n", Getattr(p1,"type"), Getattr(p2,"type"));
if (checkAttribute(p1,"tmap:in:numinputs","0")) {
p1 = Getattr(p1,"tmap:in:next");
continue;
}
if (checkAttribute(p2,"tmap:in:numinputs","0")) {
p2 = Getattr(p2,"tmap:in:next");
continue;
}
String *t1 = Getattr(p1,"tmap:typecheck:precedence");
String *t2 = Getattr(p2,"tmap:typecheck:precedence");
if ((!t1) && (!nodes[i].error)) {
Swig_warning(WARN_TYPEMAP_TYPECHECK, Getfile(nodes[i].n), Getline(nodes[i].n),
"Overloaded %s(%s) not supported (no type checking rule for '%s').\n",
Getattr(nodes[i].n,"name"),ParmList_str_defaultargs(Getattr(nodes[i].n,"parms")),
SwigType_str(Getattr(p1,"type"),0));
nodes[i].error = 1;
} else if ((!t2) && (!nodes[j].error)) {
Swig_warning(WARN_TYPEMAP_TYPECHECK, Getfile(nodes[j].n), Getline(nodes[j].n),
"Overloaded %s(%s) not supported (no type checking rule for '%s').\n",
Getattr(nodes[j].n,"name"),ParmList_str_defaultargs(Getattr(nodes[j].n,"parms")),
SwigType_str(Getattr(p2,"type"),0));
nodes[j].error = 1;
}
if (t1 && t2) {
int t1v, t2v;
t1v = atoi(Char(t1));
t2v = atoi(Char(t2));
differ = t1v-t2v;
}
else if (!t1 && t2) differ = 1;
else if (t2 && !t1) differ = -1;
else if (!t1 && !t2) differ = -1;
num_checked++;
if (differ > 0) {
Overloaded t = nodes[i];
nodes[i] = nodes[j];
nodes[j] = t;
break;
} else if ((differ == 0) && (Strcmp(t1,"0") == 0)) {
t1 = Getattr(p1,"ltype");
if (!t1) {
t1 = SwigType_ltype(Getattr(p1,"type"));
if (Getattr(p1,"tmap:typecheck:SWIGTYPE")) {
SwigType_add_pointer(t1);
}
Setattr(p1,"ltype",t1);
}
t2 = Getattr(p2,"ltype");
if (!t2) {
t2 = SwigType_ltype(Getattr(p2,"type"));
if (Getattr(p2,"tmap:typecheck:SWIGTYPE")) {
SwigType_add_pointer(t2);
}
Setattr(p2,"ltype",t2);
}
/* Need subtype check here. If t2 is a subtype of t1, then we need to change the
order */
if (SwigType_issubtype(t2,t1)) {
Overloaded t = nodes[i];
nodes[i] = nodes[j];
nodes[j] = t;
}
if (Strcmp(t1,t2) != 0) {
differ = 1;
break;
}
} else if (differ) {
break;
}
if (Getattr(p1,"tmap:in:next")) {
p1 = Getattr(p1,"tmap:in:next");
} else {
p1 = nextSibling(p1);
}
if (Getattr(p2,"tmap:in:next")) {
p2 = Getattr(p2,"tmap:in:next");
} else {
p2 = nextSibling(p2);
}
}
if (!differ) {
/* See if declarations differ by const only */
String *d1 = Getattr(nodes[i].n,"decl");
String *d2 = Getattr(nodes[j].n,"decl");
if (d1 && d2) {
String *dq1 = Copy(d1);
String *dq2 = Copy(d2);
if (SwigType_isconst(d1)) {
Delete(SwigType_pop(dq1));
}
if (SwigType_isconst(d2)) {
Delete(SwigType_pop(dq2));
}
if (Strcmp(dq1,dq2) == 0) {
if (SwigType_isconst(d1) && !SwigType_isconst(d2)) {
if (script_lang_wrapping) {
// Swap nodes so that the const method gets ignored (shadowed by the non-const method)
Overloaded t = nodes[i];
nodes[i] = nodes[j];
nodes[j] = t;
}
differ = 1;
if (!nodes[j].error) {
if (script_lang_wrapping) {
Swig_warning(WARN_LANG_OVERLOAD_CONST, Getfile(nodes[j].n), Getline(nodes[j].n),
"Overloaded %s(%s) const ignored. Non-const method at %s:%d used.\n",
Getattr(nodes[j].n,"name"), ParmList_protostr(nodes[j].parms),
Getfile(nodes[i].n), Getline(nodes[i].n));
} else {
if (!Getattr(nodes[j].n, "overload:ignore"))
Swig_warning(WARN_LANG_OVERLOAD_IGNORED, Getfile(nodes[j].n), Getline(nodes[j].n),
"Overloaded method %s(%s) ignored. Method %s(%s) const at %s:%d used.\n",
Getattr(nodes[j].n,"name"), ParmList_protostr(nodes[j].parms),
Getattr(nodes[i].n,"name"), ParmList_protostr(nodes[i].parms),
Getfile(nodes[i].n), Getline(nodes[i].n));
}
}
nodes[j].error = 1;
} else if (!SwigType_isconst(d1) && SwigType_isconst(d2)) {
differ = 1;
if (!nodes[j].error) {
if (script_lang_wrapping) {
Swig_warning(WARN_LANG_OVERLOAD_CONST, Getfile(nodes[j].n), Getline(nodes[j].n),
"Overloaded %s(%s) const ignored. Non-const method at %s:%d used.\n",
Getattr(nodes[j].n,"name"), ParmList_protostr(nodes[j].parms),
Getfile(nodes[i].n), Getline(nodes[i].n));
} else {
if (!Getattr(nodes[j].n, "overload:ignore"))
Swig_warning(WARN_LANG_OVERLOAD_IGNORED, Getfile(nodes[j].n), Getline(nodes[j].n),
"Overloaded method %s(%s) const ignored. Method %s(%s) at %s:%d used.\n",
Getattr(nodes[j].n,"name"), ParmList_protostr(nodes[j].parms),
Getattr(nodes[i].n,"name"), ParmList_protostr(nodes[i].parms),
Getfile(nodes[i].n), Getline(nodes[i].n));
}
}
nodes[j].error = 1;
}
}
Delete(dq1);
Delete(dq2);
}
}
if (!differ) {
if (!nodes[j].error) {
if (script_lang_wrapping) {
Swig_warning(WARN_LANG_OVERLOAD_SHADOW, Getfile(nodes[j].n), Getline(nodes[j].n),
"Overloaded %s(%s)%s is shadowed by %s(%s)%s at %s:%d.\n",
Getattr(nodes[j].n,"name"), ParmList_protostr(nodes[j].parms),
SwigType_isconst(Getattr(nodes[j].n,"decl")) ? " const" : "",
Getattr(nodes[i].n,"name"), ParmList_protostr(nodes[i].parms),
SwigType_isconst(Getattr(nodes[i].n,"decl")) ? " const" : "",
Getfile(nodes[i].n),Getline(nodes[i].n));
} else {
if (!Getattr(nodes[j].n, "overload:ignore"))
Swig_warning(WARN_LANG_OVERLOAD_IGNORED, Getfile(nodes[j].n), Getline(nodes[j].n),
"Overloaded method %s(%s)%s ignored. Method %s(%s)%s at %s:%d used.\n",
Getattr(nodes[j].n,"name"), ParmList_protostr(nodes[j].parms),
SwigType_isconst(Getattr(nodes[j].n,"decl")) ? " const" : "",
Getattr(nodes[i].n,"name"), ParmList_protostr(nodes[i].parms),
SwigType_isconst(Getattr(nodes[i].n,"decl")) ? " const" : "",
Getfile(nodes[i].n),Getline(nodes[i].n));
}
nodes[j].error = 1;
}
}
}
}
}
}
List *result = NewList();
{
int i;
for (i = 0; i < nnodes; i++) {
if (nodes[i].error)
Setattr(nodes[i].n, "overload:ignore", "1");
Append(result,nodes[i].n);
// Printf(stdout,"[ %d ] %s\n", i, ParmList_protostr(nodes[i].parms));
// Swig_print_node(nodes[i].n);
}
}
return result;
}
/* end shameless borrowing */
int any_varargs(ParmList *pl) {
Parm *p;
for(p=pl; p; p=nextSibling(p)) {
if (SwigType_isvarargs(Getattr(p, "type")))
return 1;
}
return 0;
}
void add_forward_referenced_type(Node *n, int overwrite = 0)
{
String *k = Getattr(n,"name");
String *name = Getattr(n, "sym:name");
String *ns = listify_namespace(current_namespace);
String *val = Getattr(defined_foreign_types, k);
if(!val || overwrite) {
#ifdef ALLEGROCL_TYPE_DEBUG
Printf(stderr,"Adding forward reference for %s (overwrite=%d)\n",
k, overwrite);
#endif
Setattr(defined_foreign_types,Copy(k),NewString("forward-reference"));
String *mangled_lname_gen =
NewStringf("#.(swig-insert-id \"%s\" %s :type :class)", name, ns);
Setattr(defined_foreign_ltypes,Copy(k),mangled_lname_gen);
// Printf(f_cl, ";; forward reference stub\n"
// "(swig-def-foreign-class \"%s\" (ff:foreign-pointer) (:class ))\n\n"
// , name);
#ifdef ALLEGROCL_CLASS_DEBUG
Printf(stderr, "Linking forward reference type = %s(%x)\n", k, n);
#endif
add_linked_type(n);
}
}
String *get_lisp_type(SwigType *ty, const String_or_char *name)
{
Hash *typemap = Swig_typemap_search("lisptype", ty, name, 0);
if (typemap) {
String *typespec = Getattr(typemap, "code");
return NewString(typespec);
}
else {
return NewString("");
}
}
Node *parent_node_skipping_extends(Node* n)
{
Node* result = n;
do {
result = parentNode(result);
}
while (Cmp("extend", nodeType(result)) == 0);
return result;
}
String *id_converter_type(SwigType const *type)
{
SwigType *t = Copy(type);
String *result = 0;
if (SwigType_ispointer(t))
{
SwigType_pop(t);
String *pointee = id_converter_type(t);
result = NewStringf("(:* %s)", pointee);
Delete(pointee);
}
else if (SwigType_ismemberpointer(t))
{
String *klass = SwigType_parm(t);
SwigType_pop(t);
String *member = id_converter_type(t);
result = NewStringf("(:member \"%s\" %s)", klass, member);
Delete(klass);
Delete(member);
}
else if (SwigType_isreference(t))
{
SwigType_pop(t);
String *referencee = id_converter_type(t);
result = NewStringf("(:& %s)", referencee);
Delete(referencee);
}
else if (SwigType_isarray(t))
{
String *size = SwigType_parm(t);
SwigType_pop(t);
String *element_type = id_converter_type(t);
result = NewStringf("(:array %s \"%s\")", element_type, size);
Delete(size);
Delete(element_type);
}
else if (SwigType_isfunction(t))
{
result = NewString("(:function (");
String *parmlist_str = SwigType_parm(t);
List *parms = SwigType_parmlist(parmlist_str);
for (Iterator i = First(parms); i.item; )
{
String *parm = id_converter_type((SwigType *)i.item);
Printf(result, "%s", parm);
i = Next(i);
if (i.item) Printf(result, " ");
Delete(parm);
}
SwigType_pop(t);
String *ret = id_converter_type(t);
Printf(result, ") %s)", ret);
Delete(parmlist_str);
Delete(parms);
Delete(ret);
}
else if (SwigType_isqualifier(t))
{
result = NewString("(:qualified (");
String *qualifiers_str = Copy(SwigType_parm(t)); // ?!
// Replaceall below SEGVs if we don't put the Copy here...
SwigType_pop(t);
String *qualifiee = id_converter_type(t);
Replaceall(qualifiers_str, " ", " :");
if (Len(qualifiers_str) > 0) Printf(result, ":");
Printf(result, "%s) %s)", qualifiers_str, qualifiee);
Delete(qualifiers_str);
Delete(qualifiee);
}
else if (SwigType_istemplate(t))
{
result = NewStringf("(:template \"%s\")", t);
}
else /* if (SwigType_issimple(t)) */
{
if (Strstr(Char(t), "::"))
{
result = listify_namespace(t);
}
else
{
result = NewStringf("\"%s\"", t);
}
}
Delete(t);
return result;
}
static ParmList *parmlist_with_names(ParmList *pl)
{
ParmList* pl2 = CopyParmList(pl);
for (Parm *p = pl, *p2 = pl2; p2;
p=nextSibling(p), p2=nextSibling(p2))
{
if (!Getattr(p2, "name"))
Setattr(p2, "name", Getattr(p2, "lname"));
Setattr(p2, "name", strip_namespaces(Getattr(p2, "name")));
Setattr(p2, "tmap:ctype", Getattr(p, "tmap:ctype"));
}
return pl2;
}
static String *parmlist_str_id_converter(ParmList *pl)
{
String *result = NewString("");
for (Parm *p = pl; p; )
{
String *lispy_type = id_converter_type(Getattr(p, "type"));
Printf(result, "(\"%s\" %s)", Getattr(p, "name"), lispy_type);
Delete(lispy_type);
if ((p=nextSibling(p))) Printf(result, " ");
}
return result;
}
String *collect_others_args(Node *overload) {
String *overloaded_from = Getattr(overload,"sym:overloaded");
String *others_args = NewString("");
int first_overload = 1;
for (Node *overload2 = overloaded_from;
overload2;
overload2 = Getattr(overload2,"sym:nextSibling"))
{
if (overload2 == overload ||
GetInt(overload2, "overload:ignore"))
continue;
ParmList *opl = parmlist_with_names(Getattr(overload2, "wrap:parms"));
String *args = parmlist_str_id_converter(opl);
if (!first_overload)
Printf(others_args, "\n ");
Printf(others_args, "(%s)", args);
Delete(args);
Delete(opl);
first_overload = 0;
}
return others_args;
}
struct IDargs {
String* name;
String* type;
String* klass;
String* arity;
IDargs() : name(0), type(0), klass(0), arity(0) {}
String* full_quoted_str() {
String *result = no_others_quoted_str();
if (arity) Printf(result, " :arity %s", arity);
return result;
}
String* no_others_quoted_str() {
String *result = NewString("");
Printf(result, "\"%s\" :type :%s", name, type);
if (klass) Printf(result, " :class \"%s\"", klass);
return result;
}
String* noname_str() {
String *result = NewString("");
Printf(result, " :type :%s", type);
if (klass) Printf(result, " :class \"%s\"", klass);
if (arity) Printf(result, " :arity %s", arity);
return result;
}
};
IDargs* id_converter_arguments(Node *n)
{
IDargs* result = (IDargs*)GetVoid(n, "allegrocl:id-converter-args");
if (!result) result = new IDargs;
// Base name
if (!result->name) {
result->name = Getattr(n, "allegrocl:old-sym:name");
if (!result->name) result->name = Getattr(n, "sym:name");
result->name = Copy(result->name);
}
// :type
if (result->type) Delete(result->type);
if (!Getattr(n, "allegrocl:kind"))
Setattr(n, "allegrocl:kind", "function");
if (Strstr(Getattr(n, "name"), "operator "))
Replaceall(Getattr(n, "allegrocl:kind"), "function", "operator");
if (Strstr(Getattr(n, "allegrocl:kind"), "variable"))
{
int name_end = Len(Getattr(n, "sym:name")) - 4;
char *str = Char(Getattr(n, "sym:name"));
String *get_set = NewString(str+name_end+1);
result->type = Copy(Getattr(n, "allegrocl:kind"));
Replaceall(result->type, "variable", "");
Printf(result->type, "%ster", get_set);
Delete(get_set);
}
else
{
result->type = Copy(Getattr(n, "allegrocl:kind"));
}
// :class
if (Strstr(result->type, "member "))
{
Replaceall(result->type, "member ", "");
if (!result->klass)
result->klass = Copy(Getattr(parent_node_skipping_extends(n),
"sym:name"));
}
// :arity
if (Getattr(n, "sym:overloaded")) {
if(result->arity) Delete(result->arity);
result->arity = NewStringf("%d",
emit_num_arguments(Getattr(n, "wrap:parms")));
}
SetVoid(n, "allegrocl:id-converter-args", result);
return result;
}
int ALLEGROCL :: emit_buffered_defuns(Node *n) {
Node *overloaded_from = Getattr(n,"sym:overloaded");
String *wrap;
if (!overloaded_from) {
wrap = Getattr(n,"allegrocl:lisp-wrap");
Printf(f_clwrap,"%s\n",wrap);
Delattr(n,"allegrocl:lisp-wrap");
Delete(wrap);
} else {
for (Node *overload = overloaded_from;
overload;
overload = Getattr(overload,"sym:nextSibling"))
{
String *others_args = collect_others_args(overload);
wrap = Getattr(overload, "allegrocl:lisp-wrap");
Replaceall(wrap, "@@OTHERS-ARGS-GO-HERE@@", others_args);
// IDargs* id_args = id_converter_arguments(overload);
// Replaceall(id_args->others_args, "@@OTHERS-ARGS-GO-HERE@@", others_args);
if (!GetInt(overload, "overload:ignore"))
Printf(f_clwrap, "%s", wrap);
Delattr(overload, "allegrocl:lisp-wrap");
Delete(wrap);
}
}
return SWIG_OK;
}
String *dispatching_type(Parm* p) {
String *result = 0;
String *parsed = Getattr(p, "type"); //Swig_cparse_type(Getattr(p,"tmap:ctype"));
String *cl_t = SwigType_typedef_resolve_all(parsed);
Hash *typemap = Swig_typemap_search("lispclass", parsed, Getattr(p, "name"), 0);
// Printf(stderr,"inspecting type '%s' for class\n", parsed);
// Printf(stderr," cfcocr = '%s' res_all = '%s'\n",
// class_from_class_or_class_ref(parsed), cl_t);
if (typemap) {
result = Copy(Getattr(typemap, "code"));
} else {
String *lookup_type = class_from_class_or_class_ref(parsed);
if(lookup_type) result = lookup_defined_foreign_ltype(lookup_type);
}
// if (!result && SwigType_ispointer(cl_t)) {
// SwigType_pop(cl_t);
// result = lookup_defined_foreign_ltype(cl_t);
// }
if (!result)
result = NewStringf("ff:foreign-pointer");
Delete(parsed);
Delete(cl_t);
return result;
}
String *defmethod_lambda_list(Node* overload) {
String *result = NewString("");
ParmList *parms = Getattr(overload, "wrap:parms");
Parm *p;
int a;
for (a=0, p=parms; p; p=nextSibling(p),++a) {
if (a!=0) Printf(result, " ");
Printf(result, "(arg%d ", a);
Printf(result, "%s", dispatching_type(p));
Printf(result, ")");
}
return result;
}
int ALLEGROCL :: emit_dispatch_defun(Node *n) {
List *overloads = Swig_overload_rank(n,true);
String *id_args = id_converter_arguments(n)->no_others_quoted_str();
Printf(f_clwrap, "(swig-dispatcher (%s :arities (", id_args);
int last_arity = -1;
for (Iterator i = First(overloads); i.item; i = Next(i)) {
int arity = emit_num_arguments(Getattr(i.item, "wrap:parms"));
if (arity == last_arity) continue;
Printf(f_clwrap, "%s%d", last_arity == -1 ? "" : " ", arity);
last_arity = arity;
}
Printf(f_clwrap, ")))\n");
Delete(id_args);
Delete(overloads);
return SWIG_OK;
}
int ALLEGROCL :: emit_defun(Node *n, File *f_cl) {
#ifdef ALLEGROCL_DEBUG
int auto_generated = Cmp(Getattr(n, "view"), "globalfunctionHandler");
Printf(stderr, "%s%sfunction %s%s%s\n",
auto_generated ? "> " : "", Getattr(n, "sym:overloaded")
? "overloaded " : "", current_namespace,
(current_namespace) > 0 ? "::" : "", Getattr(n, "sym:name"));
Printf(stderr, " (view: %s)\n", Getattr(n, "view"));
#endif
String *funcname = Getattr(n, "allegrocl:old-sym:name");
if (!funcname) funcname = Getattr(n, "sym:name");
String *mangled_name=mangle_name(n, "ACL", Getattr(n,"allegrocl:package"));
// SwigType *type=Copy(Getattr(n, "type"));
ParmList *pl = parmlist_with_names(Getattr(n, "wrap:parms"));
// attach typemap info.
Wrapper *wrap = NewWrapper();
Swig_typemap_attach_parms("lin", pl, wrap);
Swig_typemap_lookup_new("lout",n,"result",0);
// prime the pump.
Printf(wrap->code,"$body");
Parm *p;
int largnum = 0, argnum=0, first=1;
// int varargs=0;
SwigType *result_type = Swig_cparse_type(Getattr(n,"tmap:ctype"));
if (CPlusPlus)
{
String *extra_parms = id_converter_arguments(n)->noname_str();
if (Getattr(n, "sym:overloaded"))
Printf(f_cl, "(swig-defmethod (\"%s\" \"%s\"%s)\n",
funcname, mangled_name, extra_parms);
else
Printf(f_cl, "(swig-defun (\"%s\" \"%s\"%s)\n",
funcname, mangled_name, extra_parms);
Delete(extra_parms);
}
// Just C
else
{
Printf(f_cl, "(swig-defun (\"%s\")\n", funcname);
}
//////////////////////////////////////
// Lisp foreign call parameter list //
//////////////////////////////////////
Printf(f_cl, " (");
/* Special cases */
if (ParmList_len(pl) == 0) {
Printf(f_cl, ":void");
/* } else if (any_varargs(pl)) {
Printf(f_cl, "#| varargs |#");
varargs=1; */
} else {
String *largs = NewString("");
for (p=pl; p; p=nextSibling(p), argnum++, largnum++) {
SwigType *argtype=Getattr(p, "type");
if (!first) {
Printf(f_cl, "\n ");
}
if(SwigType_isvarargs(argtype)) {
Printf(stderr, "Function %s (line %d) contains varargs, which is not directly supported. Use %varargs instead.\n", Getattr(n,"name"), Getline(n));
} else {
String *argname=NewStringf("PARM%d_%s", largnum, Getattr(p, "name"));
// String *ffitype=get_ffi_type(argtype, argname);
String *ffitype=compose_foreign_type(argtype);
String *lisptype=get_lisp_type(argtype, argname);
// while we're walking the parameters, generating LIN
// wrapper code...
Setattr(p,"lname",NewStringf("SWIG_arg%d", largnum));
String *parm_code = Getattr(p,"tmap:lin");
if (parm_code) {
String *lname = Getattr(p,"lname");
Printf(largs," %s",lname);
Replaceall(parm_code,"$in", argname);
Replaceall(parm_code,"$out", lname);
Replaceall(wrap->code,"$body", parm_code);
}
String *dispatchtype=Getattr(n, "sym:overloaded") ?
dispatching_type(p) :
NewString("");
Printf(f_cl, "(%s %s %s %s)", argname, dispatchtype, ffitype, lisptype);
first=0;
Delete(ffitype);
Delete(lisptype);
}
}
Printf(wrap->locals,"%s",largs);
}
String *lout = Getattr(n,"tmap:lout");
Replaceall(wrap->code,"$body", lout);
// $lclass handling.
String *lclass = (String *)0;
SwigType *parsed = Swig_cparse_type(Getattr(n,"tmap:ctype"));
// SwigType *cl_t = SwigType_typedef_resolve_all(parsed);
SwigType *cl_t = class_from_class_or_class_ref(parsed);
Delete(parsed);
int isPtrReturn = 0;
if(cl_t) {
lclass = lookup_defined_foreign_ltype(cl_t);
isPtrReturn = 1;
}
// if (SwigType_ispointer(cl_t)) {
// isPtrReturn = 1;
// SwigType_pop(cl_t);
// lclass = lookup_defined_foreign_ltype(cl_t);
// }
int ff_foreign_ptr = 0;
if(!lclass) {
ff_foreign_ptr = 1;
lclass = NewStringf("ff:foreign-pointer");
}
#ifdef ALLEGROCL_WRAP_DEBUG
Printf(stderr,"for output wrapping %s: type=%s, ctype=%s\n",
Getattr(n,"name"), Getattr(n,"type"),
Swig_cparse_type(Getattr(n,"tmap:ctype")));
#endif
if(lclass) Replaceall(wrap->code,"$lclass", lclass);
// if(Replaceall(wrap->code,"$lclass", lclass) && !isPtrReturn) {
// Swig_warning(WARN_LANG_RETURN_TYPE,Getfile(n), Getline(n),
// "While Wrapping %s, replaced a $lclass reference when return type is non-pointer %s!\n",
// Getattr(n,"name"), cl_t);
// }
Replaceall(wrap->code,"$body", NewStringf("(swig-ff-call%s)",
wrap->locals));
String* ldestructor = Copy(lclass);
if (ff_foreign_ptr)
Replaceall(ldestructor, ldestructor, "identity");
else
Replaceall(ldestructor, ":type :class", ":type :destructor");
if (Replaceall(wrap->code,"$ldestructor", ldestructor) > 0 &&
ff_foreign_ptr) {
Swig_warning(WARN_LANG_RETURN_TYPE, Getfile(n), Getline(n),
"While wrapping %s, replaced an $ldestructor reference "
"when there was no Lisp class.\n",
Getattr(n,"name"));
}
Delete(ldestructor);
Printf(f_cl, ")\n"); /* finish arg list */
/////////////////////////////////////////////////////
// Lisp foreign call return type and optimizations //
/////////////////////////////////////////////////////
Printf(f_cl, " (:returning (%s %s)",
compose_foreign_type(result_type),
get_lisp_type(Getattr(n, "type"), "result"));
for (Iterator option = First(n); option.item; option = Next(option)) {
if (Strncmp("feature:ffargs:", option.key, 15)) continue;
String *option_val = option.item;
String *option_name = NewString(Char(option.key) + 14);
Replaceall(option_name, "_", "-");
// TODO: varargs vs call-direct ?
Printf(f_cl, "\n %s %s", option_name, option_val);
Delete(option_name);
}
Printf(f_cl,")\n %s)\n\n", wrap->code);
// Wrapper_print(wrap, stderr);
Delete(result_type);
Delete(mangled_name);
Delete(pl);
return SWIG_OK;
}
int ALLEGROCL :: functionWrapper(Node *n) {
ParmList *parms = CopyParmList(Getattr(n,"parms"));
Wrapper *wrap = NewWrapper();
String *raw_return_type = Swig_typemap_lookup_new("ctype",n,"",0);
SwigType *return_type = Swig_cparse_type(raw_return_type);
SwigType *resolved = SwigType_typedef_resolve_all(return_type);
int is_void_return = (Cmp(resolved, "void") == 0);
Delete(resolved);
if (!is_void_return)
{
String *lresult_init = NewStringf("lresult = (%s)0", raw_return_type);
Wrapper_add_localv(wrap,"lresult", raw_return_type, lresult_init, NIL);
Delete(lresult_init);
}
// Emit all of the local variables for holding arguments.
emit_args(Getattr(n, "type"), parms, wrap);
// Attach the standard typemaps
Swig_typemap_attach_parms("ctype", parms, wrap);
emit_attach_parmmaps(parms, wrap);
String *mangled = mangle_name(n);
Node *overloaded = Getattr(n,"sym:overloaded");
// Parameter overloading
Setattr(n,"wrap:parms", parms);
Setattr(n,"wrap:name", mangled);
if (overloaded) {
// emit warnings when overloading is impossible on the lisp side.
// basically Swig_overload_check(n), but with script_lang_wrapping
// set to true.
Delete(Swig_overload_rank(n, true));
if (Getattr(n, "overload:ignore")) {
// if we're the last overload, make sure to force the emit
// of the rest of the overloads before we leave.
Printf(stderr, "ignored overload %s(%x)\n", Getattr(n,"name"),
Getattr(n,"sym:nextSibling"));
if(!Getattr(n,"sym:nextSibling")) {
update_package_if_needed(n);
emit_buffered_defuns(n);
emit_dispatch_defun(n);
}
return SWIG_OK;
}
}
// Get number of required and total arguments
int num_arguments = emit_num_arguments(parms);
int gencomma = 0;
#ifdef ALLEGROCL_DEBUG
Printf(stderr,"Walking parameters for %s '%s'\n", Getattr(n,"allegrocl:kind"), Getattr(n,"name"));
#endif
// Now walk the function parameter list and generate code to get arguments
String *name_and_parms = NewStringf("%s (", mangled);
int i; Parm *p;
for (i = 0, p=parms; i < num_arguments; i++) {
while (checkAttribute(p,"tmap:in:numinputs","0")) {
p = Getattr(p,"tmap:in:next");
}
SwigType *c_parm_type = Swig_cparse_type(Getattr(p, "tmap:ctype"));
String *arg = NewStringf("l%s", Getattr(p,"lname"));
// Emit parameter declaration
if (gencomma) Printf(name_and_parms, ", ");
String *parm_decl = SwigType_str(c_parm_type, arg);
Printf(name_and_parms, "%s", parm_decl);
#ifdef ALLEGROCL_DEBUG
Printf(stderr," param: %s\n", parm_decl);
#endif
Delete(parm_decl);
gencomma = 1;
// Emit parameter conversion code
String *parm_code = Getattr(p,"tmap:in");
//if (!parm_code) {
// Swig_warning(...);
// p = nextSibling(p);
/*} else*/ {
// canThrow(n, "in", p);
Replaceall(parm_code,"$input", arg);
Setattr(p,"emit:input", arg);
Printf(wrap->code,"%s\n", parm_code);
p = Getattr(p,"tmap:in:next");
}
Delete(arg);
}
Printf(name_and_parms, ")");
// Emit the function definition
String *signature = SwigType_str(return_type, name_and_parms);
Printf(wrap->def, "EXPORT %s {", signature);
Printf(wrap->code," try {\n");
emit_action(n, wrap);
if (!is_void_return)
{
String *result_convert = Swig_typemap_lookup_new("out",n,"result",0);
Replaceall(result_convert, "$result", "lresult");
Printf(wrap->code, "%s\n", result_convert);
Printf(wrap->code, " return lresult;\n");
Delete(result_convert);
}
Printf(wrap->code," } catch (...) {\n");
if (!is_void_return)
Printf(wrap->code," return (%s)0;\n", raw_return_type);
Printf(wrap->code," }\n");
Printf(wrap->code,"}\n");
if (CPlusPlus)
Wrapper_print(wrap, f_cxx);
String *f_buffer = NewString("");
emit_defun(n,f_buffer);
Setattr(n,"allegrocl:lisp-wrap",f_buffer);
if (!overloaded || !Getattr(n, "sym:nextSibling")) {
update_package_if_needed(n);
emit_buffered_defuns(n);
// this is the last overload.
if (overloaded) {
emit_dispatch_defun(n);
}
}
return SWIG_OK;
}
int ALLEGROCL :: namespaceDeclaration(Node *n) {
// Empty namespaces are not worth DEFPACKAGEing.
if (!firstChild(n)) return SWIG_OK;
String *name=Getattr(n, "sym:name");
String *old_namespace = current_namespace;
if (Cmp(current_namespace, "") == 0)
current_namespace = NewStringf("%s", name);
else
current_namespace = NewStringf("%s::%s", current_namespace, name);
if (!GetInt(defined_namespace_packages, current_namespace))
{
SetInt(defined_namespace_packages, current_namespace, 1);
String *lispy_namespace = listify_namespace(current_namespace);
Printf(f_clhead, "(swig-defpackage %s)\n", lispy_namespace);
Delete(lispy_namespace);
}
emit_children(n);
Delete(current_namespace);
current_namespace = old_namespace;
return SWIG_OK;
}
int ALLEGROCL :: constructorHandler(Node *n)
{
#ifdef ALLEGROCL_DEBUG
Printf(stderr, "constructor %s\n", Getattr(n, "name"));
#endif
Setattr(n, "allegrocl:kind", "constructor");
Setattr(n, "allegrocl:old-sym:name", Getattr(n, "sym:name"));
// Let SWIG generate a global forwarding function.
return Language::constructorHandler(n);
}
int ALLEGROCL :: destructorHandler(Node *n)
{
#ifdef ALLEGROCL_DEBUG
Printf(stderr, "destructor %s\n", Getattr(n, "name"));
#endif
Setattr(n, "allegrocl:kind", "destructor");
Setattr(n, "allegrocl:old-sym:name", Getattr(n, "sym:name"));
// Let SWIG generate a global forwarding function.
return Language::destructorHandler(n);
}
int ALLEGROCL :: constantWrapper(Node *n) {
#ifdef ALLEGROCL_DEBUG
Printf(stderr, "constant %s\n", Getattr(n, "name"));
#endif
String *type=Getattr(n, "type");
String *converted_value=convert_literal(Getattr(n, "value"), type);
String *name=Getattr(n, "sym:name");
Setattr(n, "allegrocl:kind", "constant");
Setattr(n, "allegrocl:old-sym:name", Getattr(n, "sym:name"));
#if 0
Printf(stdout, "constant %s is of type %s. value: %s\n",
name, type, converted_value);
#endif
Printf(f_clwrap, "(swig-defconstant \"%s\" %s)\n",
name, converted_value);
Delete(converted_value);
return SWIG_OK;
}
int ALLEGROCL :: globalvariableHandler(Node *n) {
if(CPlusPlus) return Language::globalvariableHandler(n);
// String *name = Getattr(n, "name");
SwigType *type = Getattr(n,"type");
SwigType *ctype;
SwigType *rtype = SwigType_typedef_resolve_all(type);
int pointer_added = 0;
if(SwigType_isclass(rtype)) {
SwigType_add_pointer(type);
SwigType_add_pointer(rtype);
pointer_added = 1;
}
ctype = SwigType_str(type,0);
// EXPORT <SwigType_str> <mangled_name>;
// <SwigType_str> <mangled_name> = <name>;
// Printf(f_cxx, "EXPORT %s %s;\n%s %s = %s%s;\n", ctype, mangled_name,
// ctype, mangled_name, (pointer_added ? "&" : ""), name);
Printf(f_clwrap, "(swig-defvar \"%s\" \"%s\" :type %s)\n",
Getattr(n,"sym:name"), Getattr(n,"sym:name"),
((SwigType_isconst(type)) ? ":constant" : ":variable"));
return SWIG_OK;
}
int ALLEGROCL :: variableWrapper(Node *n) {
#ifdef ALLEGROCL_DEBUG
Printf(stderr, "variable %s\n", Getattr(n, "name"));
#endif
Setattr(n, "allegrocl:kind", "variable");
Setattr(n, "allegrocl:old-sym:name", Getattr(n, "sym:name"));
// Let SWIG generate a get/set function pair.
if(CPlusPlus) return Language::variableWrapper(n);
/*
String *name = Getattr(n, "name");
SwigType *type = Getattr(n,"type");
SwigType *ctype;
SwigType *rtype = SwigType_typedef_resolve_all(type);
int pointer_added = 0;
if(SwigType_isclass(rtype)) {
SwigType_add_pointer(type);
SwigType_add_pointer(rtype);
pointer_added = 1;
}
ctype = SwigType_str(type,0);
// EXPORT <SwigType_str> <mangled_name>;
// <SwigType_str> <mangled_name> = <name>;
// Printf(f_cxx, "EXPORT %s %s;\n%s %s = %s%s;\n", ctype, mangled_name,
// ctype, mangled_name, (pointer_added ? "&" : ""), name);
Printf(f_cl, "(swig-defvar \"%s\" :type %s)\n",
Getattr(n,"sym:name"),
((SwigType_isconst(type)) ? ":constant" : ":variable"));
*/
/*
Printf(f_cxx, "// swigtype: %s\n", SwigType_typedef_resolve_all(Getattr(n,"type")));
Printf(f_cxx, "// vwrap: %s\n", compose_foreign_type(SwigType_strip_qualifiers(Copy(rtype))));
*/
// Delete(mangled_name);
return SWIG_OK;
}
int ALLEGROCL :: memberfunctionHandler(Node *n) {
#ifdef ALLEGROCL_DEBUG
Printf(stderr, "member function %s::%s\n",
Getattr(parent_node_skipping_extends(n), "name"), Getattr(n, "name"));
#endif
Setattr(n, "allegrocl:kind", "member function");
Setattr(n, "allegrocl:old-sym:name", Getattr(n, "sym:name"));
// Let SWIG generate a global forwarding function.
return Language::memberfunctionHandler(n);
}
int ALLEGROCL :: membervariableHandler(Node *n) {
#ifdef ALLEGROCL_DEBUG
Printf(stderr, "member variable %s::%s\n",
Getattr(parent_node_skipping_extends(n), "name"), Getattr(n, "name"));
#endif
Setattr(n, "allegrocl:kind", "member variable");
Setattr(n, "allegrocl:old-sym:name", Getattr(n, "sym:name"));
// Let SWIG generate a get/set function pair.
return Language::membervariableHandler(n);
}
int ALLEGROCL :: typedefHandler(Node *n) {
#ifdef ALLEGROCL_TYPE_DEBUG
Printf(stderr,"In typedefHAND\n");
#endif
// has the side-effect of noting any implicit
// template instantiations in type.
Delete(compose_foreign_type(Getattr(n,"type")));
String *sym_name = Getattr(n,"sym:name");
String *name;
String *type_ref;
if(in_class) {
Setattr(n,"allegrocl:typedef:in-class",in_class);
}
if(in_class) {
String *class_name = Getattr(in_class,"name");
name = NewStringf("%s__%s",class_name,sym_name);
type_ref = NewStringf("%s::%s", class_name, sym_name);
Setattr(n,"allegrocl:in-class",in_class);
} else {
name = Copy(sym_name);
type_ref = Copy(Getattr(n,"name"));
}
Setattr(n,"allegrocl:namespace",current_namespace);
add_defined_foreign_type(n, 0, type_ref, name);
#ifdef ALLEGROCL_TYPE_DEBUG
Printf(stderr,"Out typedefHAND\n");
#endif
return SWIG_OK;
}
// forward referenced classes are added specially to defined_foreign_types
int ALLEGROCL :: classforwardDeclaration(Node *n) {
add_forward_referenced_type(n);
return SWIG_OK;
}
int ALLEGROCL :: classHandler(Node *n) {
#ifdef ALLEGROCL_DEBUG
Printf(stderr, "class %s::%s\n", current_namespace,
Getattr(n, "sym:name"));
#endif
String *name=Getattr(n, "sym:name");
String *kind = Getattr(n,"kind");
// maybe just remove this check and get rid of the else clause below.
if (Strcmp(kind, "struct") == 0 ||
Strcmp(kind, "class") == 0 ||
Strcmp(kind, "union") == 0)
{
if (CPlusPlus)
return cppClassHandler(n);
else
return cClassHandler(n);
}
// else if (Strcmp(kind, "union") == 0)
// {
// Printf(f_cl, ";; There should be a union type named \"%s\" here.\n",
// name);
// return SWIG_OK;
// }
else
{
Printf(stderr, "Don't know how to deal with %s kind of class yet.\n",
kind);
Printf(stderr, " (name: %s)\n", name);
SWIG_exit(EXIT_FAILURE);
return SWIG_OK;
}
return SWIG_OK;
}
int ALLEGROCL :: cClassHandler(Node *n) {
// String *cDeclName = Getattr(n,"classDeclaration:name");
// String *name= Getattr(n, "sym:name");
// String *kind = Getattr(n,"kind");
// Node *c;
/* Add this structure to the known lisp types */
// Printf(stderr, "Adding %s foreign type\n", name);
String *ns = listify_namespace(current_namespace);
#ifdef ALLEGROCL_TYPE_DEBUG
Printf(stderr,"In cClassHAND\n");
#endif
add_defined_foreign_type(n);
Delete(ns);
#ifdef ALLEGROCL_TYPE_DEBUG
Printf(stderr,"Out cClassHAND\n");
#endif
return SWIG_OK;
}
int ALLEGROCL :: cppClassHandler(Node *n) {
// String *name=Getattr(n, "sym:name");
// String *kind = Getattr(n,"kind");
/* Template instantiation.
Careful.
SWIG does not create instantiations of templated classes whenever
it sees a templated class reference (say, as a return type, or
in a parameter list).
The %template directive results in a templated class instantiation
that will actually be seen by <LANG> :: classHandler().
In this case, we don't want to error if the type already exists;
the point is to force the creation of wrappers for the templated
class.
*/
String *templated = Getattr(n,"template");
String *t_name;
// String *ns = listify_namespace(current_namespace);
if(templated) {
t_name = namespaced_name(n);
// t_name = Getattr(n,"name");
} else {
t_name = Getattr(n,"name");
}
Setattr(n,"allegrocl:namespace",current_namespace);
/* Add this structure to the known lisp types.
Class may contain references to the type currently being
defined */
if(!templated || !lookup_defined_foreign_type(t_name)) {
#ifdef ALLEGROCL_DEBUG
Printf(stderr, "Adding %s foreign type\n", Getattr(n,"sym:name"));
#endif
add_defined_foreign_type(n);
} else {
#ifdef ALLEGROCL_DEBUG
Printf(stderr, "cppClassHand: type %s already exists. Assuming %%template instantiation for wrapping purposes.\n", Getattr(n,"sym:name"));
#endif
add_defined_foreign_type(n,1);
}
// mjb - for real fun, generate wrappers for class slot access.
// Generate slot accessors, constructor, and destructor.
Node *prev_class = in_class;
in_class = n;
Node *c;
// walk all member variables.
for(c=firstChild(n); c; c=nextSibling(c)) {
// ping the types of all children--even protected and private
// so their types can be added to the linked_type_list.
SwigType *childType = NewStringf("%s%s", Getattr(c,"decl"),
Getattr(c,"type"));
if(!SwigType_isfunction(childType))
Delete(compose_foreign_type(childType));
}
// this will walk all necessary methods.
Language::classHandler(n);
in_class = prev_class;
return SWIG_OK;
}
int ALLEGROCL :: emit_one(Node *n)
{
// When the current package does not correspond with the current
// namespace we need to generate an IN-PACKAGE form, unless the
// current node is another namespace node.
if (Cmp(nodeType(n), "namespace") != 0 &&
Cmp(current_package, current_namespace) != 0)
{
String *lispy_namespace = listify_namespace(current_namespace);
Printf(f_clwrap, "(swig-in-package %s)\n", lispy_namespace);
Delete(lispy_namespace);
Delete(current_package);
current_package = NewStringf("%s", current_namespace);
}
Setattr(n,"allegrocl:package",current_package);
return Language::emit_one(n);
}
int ALLEGROCL :: enumDeclaration(Node *n) {
if(Getattr(n,"sym:name")) {
add_defined_foreign_type(n);
}
Node *c;
for(c = firstChild(n); c; c=nextSibling(c)) {
ALLEGROCL::enumvalueDeclaration(c);
// since we walk our own children, we need to add
// the current package ourselves.
Setattr(c,"allegrocl:package",current_package);
}
return SWIG_OK;
}
int ALLEGROCL :: enumvalueDeclaration(Node *n) {
if(CPlusPlus) {
String *mangled_name = mangle_name(n, "ACL_ENUM");
Printf(f_cxx, "EXPORT const %s %s = %s;\n", Getattr(n, "type"),
mangled_name, Getattr(n, "value"));
Delete(mangled_name);
}
return SWIG_OK;
}
int ALLEGROCL :: templateDeclaration(Node *n) {
String *type = Getattr(n,"templatetype");
// Printf(stderr, "tempDecl: %s %s\n", Getattr(n,"name"),
// type);
// Swig_print_node(n);
if(!Strcmp(type,"cdecl")) {
SwigType *ty = NewStringf("%s%s",Getattr(n,"decl"),
Getattr(n,"type"));
Delete(ty);
}
Delete(type);
return SWIG_OK;
}
Reference in a new issue View git blame Copy permalink