Source/Modules/clisp.cxx

   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  * clisp.cxx
   6  *
   7  * clisp language module for SWIG.
   8  * ----------------------------------------------------------------------------- */
   9
  10 char cvsroot_clisp_cxx[] = "$Id: clisp.cxx 11380 2009-07-08 12:17:45Z wsfulton $";
  11
  12 #include "swigmod.h"
  13
  14 class CLISP:public Language {
  15 public:
  16   File *f_cl;
  17   String *module;
  18   virtual void main(int argc, char *argv[]);
  19   virtual int top(Node *n);
  20   virtual int functionWrapper(Node *n);
  21   virtual int variableWrapper(Node *n);
  22   virtual int constantWrapper(Node *n);
  23   virtual int classDeclaration(Node *n);
  24   virtual int enumDeclaration(Node *n);
  25   virtual int typedefHandler(Node *n);
  26   List *entries;
  27 private:
  28   String *get_ffi_type(Node *n, SwigType *ty);
  29   String *convert_literal(String *num_param, String *type);
  30   String *strip_parens(String *string);
  31   int extern_all_flag;
  32   int generate_typedef_flag;
  33   int is_function;
  34 };
  35
  36 void CLISP::main(int argc, char *argv[]) {
  37   int i;
  38
  39   Preprocessor_define("SWIGCLISP 1", 0);
  40   SWIG_library_directory("clisp");
  41   SWIG_config_file("clisp.swg");
  42   generate_typedef_flag = 0;
  43   extern_all_flag = 0;
  44
  45   for (i = 1; i < argc; i++) {
  46     if (!strcmp(argv[i], "-help")) {
  47       Printf(stdout, "clisp Options (available with -clisp)\n");
  48       Printf(stdout,
  49              " -extern-all\n"
  50              "\t If this option is given then clisp definitions for all the functions\n"
  51              "and global variables will be created otherwise only definitions for \n"
  52              "externed functions and variables are created.\n"
  53              " -generate-typedef\n"
  54              "\t If this option is given then def-c-type will be used to generate shortcuts\n"
  55              "according to the typedefs in the input.\n");
  56     } else if ((Strcmp(argv[i], "-extern-all") == 0)) {
  57       extern_all_flag = 1;
  58       Swig_mark_arg(i);
  59     } else if ((Strcmp(argv[i], "-generate-typedef") == 0)) {
  60       generate_typedef_flag = 1;
  61       Swig_mark_arg(i);
  62     }
  63   }
  64 }
  65
  66 int CLISP::top(Node *n) {
  67
  68   File *f_null = NewString("");
  69   module = Getattr(n, "name");
  70   String *output_filename;
  71   entries = NewList();
  72
  73   /* Get the output file name */
  74   String *outfile = Getattr(n, "outfile");
  75
  76   if (!outfile)
  77     output_filename = outfile;
  78   else {
  79     output_filename = NewString("");
  80     Printf(output_filename, "%s%s.lisp", SWIG_output_directory(), module);
  81   }
  82
  83   f_cl = NewFile(output_filename, "w+", SWIG_output_files());
  84   if (!f_cl) {
  85     FileErrorDisplay(output_filename);
  86     SWIG_exit(EXIT_FAILURE);
  87   }
  88
  89   Swig_register_filebyname("header", f_null);
  90   Swig_register_filebyname("begin", f_null);
  91   Swig_register_filebyname("runtime", f_null);
  92   Swig_register_filebyname("wrapper", f_null);
  93
  94   String *header = NewString("");
  95
  96   Swig_banner_target_lang(header, ";;");
  97
  98   Printf(header, "\n(defpackage :%s\n  (:use :common-lisp :ffi)", module);
  99
 100   Language::top(n);
 101
 102   Iterator i;
 103
 104   long len = Len(entries);
 105   if (len > 0) {
 106     Printf(header, "\n  (:export");
 107   }
 108   //else nothing to export
 109
 110   for (i = First(entries); i.item; i = Next(i)) {
 111     Printf(header, "\n\t:%s", i.item);
 112   }
 113
 114   if (len > 0) {
 115     Printf(header, ")");
 116   }
 117
 118   Printf(header, ")\n");
 119   Printf(header, "\n(in-package :%s)\n", module);
 120   Printf(header, "\n(default-foreign-language :stdc)\n");
 121
 122   len = Tell(f_cl);
 123
 124   Printf(f_cl, "%s", header);
 125
 126   long end = Tell(f_cl);
 127
 128   for (len--; len >= 0; len--) {
 129     end--;
 130     Seek(f_cl, len, SEEK_SET);
 131     int ch = Getc(f_cl);
 132     Seek(f_cl, end, SEEK_SET);
 133     Putc(ch, f_cl);
 134   }
 135
 136   Seek(f_cl, 0, SEEK_SET);
 137   Write(f_cl, Char(header), Len(header));
 138
 139   Close(f_cl);
 140   Delete(f_cl);                 // Deletes the handle, not the file
 141
 142   return SWIG_OK;
 143 }
 144
 145
 146 int CLISP::functionWrapper(Node *n) {
 147   is_function = 1;
 148   String *storage = Getattr(n, "storage");
 149   if (!extern_all_flag && (!storage || (Strcmp(storage, "extern") && Strcmp(storage, "externc"))))
 150     return SWIG_OK;
 151
 152   String *func_name = Getattr(n, "sym:name");
 153
 154   ParmList *pl = Getattr(n, "parms");
 155
 156   int argnum = 0, first = 1;
 157
 158   Printf(f_cl, "\n(ffi:def-call-out %s\n\t(:name \"%s\")\n", func_name, func_name);
 159
 160   Append(entries, func_name);
 161
 162   if (ParmList_len(pl) != 0) {
 163     Printf(f_cl, "\t(:arguments ");
 164   }
 165   for (Parm *p = pl; p; p = nextSibling(p), argnum++) {
 166
 167     String *argname = Getattr(p, "name");
 168     //    SwigType *argtype;
 169
 170     String *ffitype = get_ffi_type(n, Getattr(p, "type"));
 171
 172     int tempargname = 0;
 173
 174     if (!argname) {
 175       argname = NewStringf("arg%d", argnum);
 176       tempargname = 1;
 177     }
 178
 179     if (!first) {
 180       Printf(f_cl, "\n\t\t");
 181     }
 182     Printf(f_cl, "(%s %s)", argname, ffitype);
 183     first = 0;
 184
 185     Delete(ffitype);
 186
 187     if (tempargname)
 188       Delete(argname);
 189   }
 190   if (ParmList_len(pl) != 0) {
 191     Printf(f_cl, ")\n");        /* finish arg list */
 192   }
 193   String *ffitype = get_ffi_type(n, Getattr(n, "type"));
 194   if (Strcmp(ffitype, "NIL")) { //when return type is not nil
 195     Printf(f_cl, "\t(:return-type %s)\n", ffitype);
 196   }
 197   Printf(f_cl, "\t(:library +library-name+))\n");
 198
 199   return SWIG_OK;
 200 }
 201
 202
 203 int CLISP::constantWrapper(Node *n) {
 204   is_function = 0;
 205   String *type = Getattr(n, "type");
 206   String *converted_value = convert_literal(Getattr(n, "value"), type);
 207   String *name = Getattr(n, "sym:name");
 208
 209   Printf(f_cl, "\n(defconstant %s %s)\n", name, converted_value);
 210   Append(entries, name);
 211   Delete(converted_value);
 212
 213   return SWIG_OK;
 214 }
 215
 216 int CLISP::variableWrapper(Node *n) {
 217   is_function = 0;
 218   //  SwigType *type=;
 219   String *storage = Getattr(n, "storage");
 220
 221   if (!extern_all_flag && (!storage || (Strcmp(storage, "extern") && Strcmp(storage, "externc"))))
 222     return SWIG_OK;
 223
 224   String *var_name = Getattr(n, "sym:name");
 225   String *lisp_type = get_ffi_type(n, Getattr(n, "type"));
 226   Printf(f_cl, "\n(ffi:def-c-var %s\n (:name \"%s\")\n (:type %s)\n", var_name, var_name, lisp_type);
 227   Printf(f_cl, "\t(:library +library-name+))\n");
 228   Append(entries, var_name);
 229
 230   Delete(lisp_type);
 231   return SWIG_OK;
 232 }
 233
 234 int CLISP::typedefHandler(Node *n) {
 235   if (generate_typedef_flag) {
 236     is_function = 0;
 237     Printf(f_cl, "\n(ffi:def-c-type %s %s)\n", Getattr(n, "name"), get_ffi_type(n, Getattr(n, "type")));
 238   }
 239
 240   return Language::typedefHandler(n);
 241 }
 242
 243 int CLISP::enumDeclaration(Node *n) {
 244   is_function = 0;
 245   String *name = Getattr(n, "sym:name");
 246
 247   Printf(f_cl, "\n(ffi:def-c-enum %s ", name);
 248
 249   for (Node *c = firstChild(n); c; c = nextSibling(c)) {
 250
 251     String *slot_name = Getattr(c, "name");
 252     String *value = Getattr(c, "enumvalue");
 253
 254     Printf(f_cl, "(%s %s)", slot_name, value);
 255
 256     Append(entries, slot_name);
 257
 258     Delete(value);
 259   }
 260
 261   Printf(f_cl, ")\n");
 262   return SWIG_OK;
 263 }
 264
 265
 266 // Includes structs
 267 int CLISP::classDeclaration(Node *n) {
 268   is_function = 0;
 269   String *name = Getattr(n, "sym:name");
 270   String *kind = Getattr(n, "kind");
 271
 272   if (Strcmp(kind, "struct")) {
 273     Printf(stderr, "Don't know how to deal with %s kind of class yet.\n", kind);
 274     Printf(stderr, " (name: %s)\n", name);
 275     SWIG_exit(EXIT_FAILURE);
 276   }
 277
 278
 279   Printf(f_cl, "\n(ffi:def-c-struct %s", name);
 280
 281   Append(entries, NewStringf("make-%s", name));
 282
 283   for (Node *c = firstChild(n); c; c = nextSibling(c)) {
 284
 285     if (Strcmp(nodeType(c), "cdecl")) {
 286       Printf(stderr, "Structure %s has a slot that we can't deal with.\n", name);
 287       Printf(stderr, "nodeType: %s, name: %s, type: %s\n", nodeType(c), Getattr(c, "name"), Getattr(c, "type"));
 288       SWIG_exit(EXIT_FAILURE);
 289     }
 290
 291     String *temp = Copy(Getattr(c, "decl"));
 292     Append(temp, Getattr(c, "type"));   //appending type to the end, otherwise wrong type
 293     String *lisp_type = get_ffi_type(n, temp);
 294     Delete(temp);
 295
 296     String *slot_name = Getattr(c, "sym:name");
 297     Printf(f_cl, "\n\t(%s %s)", slot_name, lisp_type);
 298
 299     Append(entries, NewStringf("%s-%s", name, slot_name));
 300
 301     Delete(lisp_type);
 302   }
 303
 304   Printf(f_cl, ")\n");
 305
 306   /* Add this structure to the known lisp types */
 307   //Printf(stdout, "Adding %s foreign type\n", name);
 308   //  add_defined_foreign_type(name);
 309
 310   return SWIG_OK;
 311 }
 312
 313 /* utilities */
 314 /* returns new string w/ parens stripped */
 315 String *CLISP::strip_parens(String *string) {
 316   char *s = Char(string), *p;
 317   int len = Len(string);
 318   String *res;
 319
 320   if (len == 0 || s[0] != '(' || s[len - 1] != ')') {
 321     return NewString(string);
 322   }
 323
 324   p = (char *) malloc(len - 2 + 1);
 325   if (!p) {
 326     Printf(stderr, "Malloc failed\n");
 327     SWIG_exit(EXIT_FAILURE);
 328   }
 329
 330   strncpy(p, s + 1, len - 1);
 331   p[len - 2] = 0;               /* null terminate */
 332
 333   res = NewString(p);
 334   free(p);
 335
 336   return res;
 337 }
 338
 339 String *CLISP::convert_literal(String *num_param, String *type) {
 340   String *num = strip_parens(num_param), *res;
 341   char *s = Char(num);
 342
 343   /* Make sure doubles use 'd' instead of 'e' */
 344   if (!Strcmp(type, "double")) {
 345     String *updated = Copy(num);
 346     if (Replace(updated, "e", "d", DOH_REPLACE_ANY) > 1) {
 347       Printf(stderr, "Weird!! number %s looks invalid.\n", num);
 348       SWIG_exit(EXIT_FAILURE);
 349     }
 350     Delete(num);
 351     return updated;
 352   }
 353
 354   if (SwigType_type(type) == T_CHAR) {
 355     /* Use CL syntax for character literals */
 356     return NewStringf("#\\%s", num_param);
 357   } else if (SwigType_type(type) == T_STRING) {
 358     /* Use CL syntax for string literals */
 359     return NewStringf("\"%s\"", num_param);
 360   }
 361
 362   if (Len(num) < 2 || s[0] != '0') {
 363     return num;
 364   }
 365
 366   /* octal or hex */
 367
 368   res = NewStringf("#%c%s", s[1] == 'x' ? 'x' : 'o', s + 2);
 369   Delete(num);
 370
 371   return res;
 372 }
 373
 374 String *CLISP::get_ffi_type(Node *n, SwigType *ty) {
 375   Node *node = NewHash();
 376   Setattr(node, "type", ty);
 377   Setfile(node, Getfile(n));
 378   Setline(node, Getline(n));
 379   const String *tm = Swig_typemap_lookup("in", node, "", 0);
 380   Delete(node);
 381
 382   if (tm) {
 383     return NewString(tm);
 384   } else if (SwigType_ispointer(ty)) {
 385     SwigType *cp = Copy(ty);
 386     SwigType_del_pointer(cp);
 387     String *inner_type = get_ffi_type(n, cp);
 388
 389     if (SwigType_isfunction(cp)) {
 390       return inner_type;
 391     }
 392
 393     SwigType *base = SwigType_base(ty);
 394     String *base_name = SwigType_str(base, 0);
 395
 396     String *str;
 397     if (!Strcmp(base_name, "int") || !Strcmp(base_name, "float") || !Strcmp(base_name, "short")
 398         || !Strcmp(base_name, "double") || !Strcmp(base_name, "long") || !Strcmp(base_name, "char")) {
 399
 400       str = NewStringf("(ffi:c-ptr %s)", inner_type);
 401     } else {
 402       str = NewStringf("(ffi:c-pointer %s)", inner_type);
 403     }
 404     Delete(base_name);
 405     Delete(base);
 406     Delete(cp);
 407     Delete(inner_type);
 408     return str;
 409   } else if (SwigType_isarray(ty)) {
 410     SwigType *cp = Copy(ty);
 411     String *array_dim = SwigType_array_getdim(ty, 0);
 412
 413     if (!Strcmp(array_dim, "")) {       //dimension less array convert to pointer
 414       Delete(array_dim);
 415       SwigType_del_array(cp);
 416       SwigType_add_pointer(cp);
 417       String *str = get_ffi_type(n, cp);
 418       Delete(cp);
 419       return str;
 420     } else {
 421       SwigType_pop_arrays(cp);
 422       String *inner_type = get_ffi_type(n, cp);
 423       Delete(cp);
 424
 425       int ndim = SwigType_array_ndim(ty);
 426       String *dimension;
 427       if (ndim == 1) {
 428         dimension = array_dim;
 429       } else {
 430         dimension = array_dim;
 431         for (int i = 1; i < ndim; i++) {
 432           array_dim = SwigType_array_getdim(ty, i);
 433           Append(dimension, " ");
 434           Append(dimension, array_dim);
 435           Delete(array_dim);
 436         }
 437         String *temp = dimension;
 438         dimension = NewStringf("(%s)", dimension);
 439         Delete(temp);
 440       }
 441       String *str;
 442       if (is_function)
 443         str = NewStringf("(ffi:c-ptr (ffi:c-array %s %s))", inner_type, dimension);
 444       else
 445         str = NewStringf("(ffi:c-array %s %s)", inner_type, dimension);
 446
 447       Delete(inner_type);
 448       Delete(dimension);
 449       return str;
 450     }
 451   } else if (SwigType_isfunction(ty)) {
 452     SwigType *cp = Copy(ty);
 453     SwigType *fn = SwigType_pop_function(cp);
 454     String *args = NewString("");
 455     ParmList *pl = SwigType_function_parms(fn);
 456     if (ParmList_len(pl) != 0) {
 457       Printf(args, "(:arguments ");
 458     }
 459     int argnum = 0, first = 1;
 460     for (Parm *p = pl; p; p = nextSibling(p), argnum++) {
 461       String *argname = Getattr(p, "name");
 462       SwigType *argtype = Getattr(p, "type");
 463       String *ffitype = get_ffi_type(n, argtype);
 464
 465       int tempargname = 0;
 466
 467       if (!argname) {
 468         argname = NewStringf("arg%d", argnum);
 469         tempargname = 1;
 470       }
 471       if (!first) {
 472         Printf(args, "\n\t\t");
 473       }
 474       Printf(args, "(%s %s)", argname, ffitype);
 475       first = 0;
 476       Delete(ffitype);
 477       if (tempargname)
 478         Delete(argname);
 479     }
 480     if (ParmList_len(pl) != 0) {
 481       Printf(args, ")\n");      /* finish arg list */
 482     }
 483     String *ffitype = get_ffi_type(n, cp);
 484     String *str = NewStringf("(ffi:c-function %s \t\t\t\t(:return-type %s))", args, ffitype);
 485     Delete(fn);
 486     Delete(args);
 487     Delete(cp);
 488     Delete(ffitype);
 489     return str;
 490   }
 491   String *str = SwigType_str(ty, 0);
 492   if (str) {
 493     char *st = Strstr(str, "struct");
 494     if (st) {
 495       st += 7;
 496       return NewString(st);
 497     }
 498     char *cl = Strstr(str, "class");
 499     if (cl) {
 500       cl += 6;
 501       return NewString(cl);
 502     }
 503   }
 504   return str;
 505 }
 506
 507 extern "C" Language *swig_clisp(void) {
 508   return new CLISP();
 509 }