← Back to branch summary

~ubuntu-branches/ubuntu/edgy/swig1.3/edgy

« back to all changes in this revision

Viewing changes to Source/Modules/allegrocl.cxx

  • Committer: Bazaar Package Importer
  • Author(s): Matthias Klose
  • Date: 2005-01-10 09:48:52 UTC
  • mfrom: (1.1.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20050110094852-axi555axhj1brbwq
Tags: 1.3.22-5ubuntu2
http://bugs.debian.org/4146
Build using python2.4 and pike7.6. Closes: #4146.

Show diffs side-by-side

added added

removed removed

Lines of Context:
Source/Modules/allegrocl.cxx
 
1
char cvsroot_allegrocl_cxx[] = "$Header: /cvsroot/swig/SWIG/Source/Modules/allegrocl.cxx,v 1.9 2004/08/25 20:45:23 wsfulton Exp $";
 
2
 
 
3
#include "swigmod.h"
 
4
 
 
5
class ALLEGROCL : public Language {
 
6
public:
 
7
 
 
8
  virtual void main(int argc, char *argv[]);
 
9
  virtual int top(Node *n);
 
10
  virtual int functionWrapper(Node *n); 
 
11
  virtual int constantWrapper(Node *n);
 
12
  virtual int classDeclaration(Node *n);
 
13
 
 
14
};
 
15
 
 
16
static File *f_cl=0;
 
17
static File *f_null=0;
 
18
 
 
19
const char *identifier_converter="identifier-convert-null";
 
20
 
 
21
int any_varargs(ParmList *pl) {
 
22
  Parm *p;
 
23
  
 
24
  for(p=pl; p; p=nextSibling(p)) {
 
25
    if (SwigType_isvarargs(Getattr(p, "type")))
 
26
      return 1;
 
27
  }
 
28
 
 
29
  return 0;
 
30
}
 
31
 
 
32
  
 
33
/* utilities */
 
34
/* returns new string w/ parens stripped */
 
35
String *strip_parens(String *string) {
 
36
        char *s=Char(string), *p;
 
37
        int len=Len(string);
 
38
        String *res;
 
39
        
 
40
        if (len==0 || s[0] != '(' || s[len-1] != ')') {
 
41
                return NewString(string);
 
42
        }
 
43
        
 
44
        p=(char *)malloc(len-2+1);
 
45
        if (!p) {
 
46
                Printf(stderr, "Malloc failed\n");
 
47
                SWIG_exit(EXIT_FAILURE);
 
48
        }
 
49
        
 
50
        strncpy(p, s+1, len-1);
 
51
        p[len-2]=0; /* null terminate */
 
52
        
 
53
        res=NewString(p);
 
54
        free(p);
 
55
        
 
56
        return res;
 
57
}
 
58
 
 
59
 
 
60
String *convert_literal(String *num_param, String *type) {
 
61
        String *num=strip_parens(num_param), *res;
 
62
        char *s=Char(num);
 
63
        
 
64
        /* Make sure doubles use 'd' instead of 'e' */
 
65
        if (!Strcmp(type, "double")) {
 
66
                String *updated=Copy(num);
 
67
                if (Replace(updated, "e", "d", DOH_REPLACE_ANY) > 1) {
 
68
                        Printf(stderr, "Weird!! number %s looks invalid.\n", num);
 
69
                        SWIG_exit(EXIT_FAILURE);
 
70
                }
 
71
                Delete(num);
 
72
                return updated;
 
73
        }
 
74
 
 
75
        if (SwigType_type(type) == T_CHAR) {
 
76
                /* Use CL syntax for character literals */
 
77
                return NewStringf("#\\%s", num_param);
 
78
        }
 
79
        else if (SwigType_type(type) == T_STRING) {
 
80
                /* Use CL syntax for string literals */
 
81
                return NewStringf("\"%s\"", num_param);
 
82
        }
 
83
        
 
84
        if (Len(num) < 2 || s[0] != '0') {
 
85
                return num;
 
86
        }
 
87
        
 
88
        /* octal or hex */
 
89
        
 
90
        res=NewStringf("#%c%s", 
 
91
                       s[1] == 'x' ? 'x' : 'o', 
 
92
                       s+2);
 
93
        Delete(num);
 
94
 
 
95
        return res;
 
96
}
 
97
 
 
98
struct {
 
99
  int count;
 
100
  String **entries;
 
101
} defined_foreign_types;
 
102
 
 
103
void add_defined_foreign_type(String *type) {
 
104
  if (!defined_foreign_types.count) {
 
105
    /* Make fresh */
 
106
    defined_foreign_types.count=1;
 
107
    defined_foreign_types.entries=(String **)malloc(sizeof(String *));
 
108
  } else {
 
109
    /* make room */
 
110
    defined_foreign_types.count++;
 
111
    defined_foreign_types.entries=(String **)
 
112
      realloc(defined_foreign_types.entries,
 
113
              defined_foreign_types.count*sizeof(String *));
 
114
  }
 
115
 
 
116
  if (!defined_foreign_types.entries) {
 
117
    Printf(stderr, "Out of memory\n");
 
118
    SWIG_exit(EXIT_FAILURE);
 
119
  }
 
120
 
 
121
  /* Fill in the new data */
 
122
  defined_foreign_types.entries[defined_foreign_types.count-1]=
 
123
    Copy(type);
 
124
  
 
125
}
 
126
 
 
127
 
 
128
String *get_ffi_type(SwigType *ty, const String_or_char *name) {
 
129
  Hash *typemap = Swig_typemap_search("ffitype", ty, name, 0);
 
130
  if (typemap) {
 
131
          String *typespec = Getattr(typemap, "code");
 
132
          return NewString(typespec);
 
133
  }
 
134
  else {
 
135
          SwigType *tr=SwigType_typedef_resolve_all(ty);
 
136
          char *type_reduced=Char(tr);
 
137
          int i;
 
138
 
 
139
          //Printf(stdout,"convert_type %s\n", ty);
 
140
          if (SwigType_isconst(tr)) {
 
141
                  SwigType_pop(tr);
 
142
                  type_reduced=Char(tr);
 
143
          }
 
144
 
 
145
          if (SwigType_ispointer(type_reduced) || SwigType_isarray(ty) ||
 
146
              !strncmp(type_reduced, "p.f", 3)) {
 
147
#if 1
 
148
                  return NewString("(* :void)");
 
149
#else
 
150
                  return NewString(":foreign-address");
 
151
#endif
 
152
          }
 
153
  
 
154
          for(i=0; i<defined_foreign_types.count; i++) {
 
155
                  if (!Strcmp(ty, defined_foreign_types.entries[i])) {
 
156
                          return NewStringf("#.(%s \"%s\" :type :type)",
 
157
                                            identifier_converter, 
 
158
                                            ty);
 
159
                  }
 
160
          }
 
161
  
 
162
          if (!Strncmp(type_reduced, "enum ", 5)) {
 
163
                  return NewString(":int");
 
164
          }
 
165
 
 
166
          Printf(stderr, "Unsupported data type: %s (was: %s)\n", type_reduced, ty);
 
167
          SWIG_exit(EXIT_FAILURE);
 
168
  }
 
169
  return 0;
 
170
}
 
171
 
 
172
String *get_lisp_type(SwigType *ty, const String_or_char *name)
 
173
{
 
174
  Hash *typemap = Swig_typemap_search("lisptype", ty, name, 0);
 
175
  if (typemap) {
 
176
    String *typespec = Getattr(typemap, "code");
 
177
    return NewString(typespec);
 
178
  }
 
179
  else {
 
180
    return NewString("");
 
181
  }
 
182
}
 
183
 
 
184
void ALLEGROCL :: main(int argc, char *argv[]) {
 
185
  int i;
 
186
 
 
187
  SWIG_library_directory("allegrocl"); 
 
188
  SWIG_config_file("allegrocl.swg");
 
189
 
 
190
 
 
191
  for(i=1; i<argc; i++) {
 
192
    if (!strcmp(argv[i], "-identifier-converter")) {
 
193
      char *conv=argv[i+1];
 
194
      
 
195
      if (!conv)
 
196
        Swig_arg_error();
 
197
 
 
198
      Swig_mark_arg(i);
 
199
      Swig_mark_arg(i+1);
 
200
      i++;
 
201
 
 
202
      /* check for built-ins */
 
203
      if (!strcmp(conv, "lispify")) {
 
204
        identifier_converter="identifier-convert-lispify";
 
205
      } else if (!strcmp(conv, "null")) {
 
206
        identifier_converter="identifier-convert-null";
 
207
      } else {
 
208
        /* Must be user defined */
 
209
        char *idconv = new char[strlen(conv)+1];
 
210
        strcpy(idconv, conv);
 
211
        identifier_converter=idconv;
 
212
      }
 
213
    }
 
214
 
 
215
    if (!strcmp(argv[i], "-help")) {
 
216
      fprintf(stderr, "Allegro CL Options:\n");
 
217
      fprintf(stderr, 
 
218
              "    -identifier-converter <type or funcname>\n"
 
219
              "\tSpecifies the type of conversion to do on C identifiers to convert\n"
 
220
              "\tthem to symbols.  There are two built-in converters:  'null' and\n"
 
221
              "\t 'lispify'.  The default is 'null'.  If you supply a name other\n"
 
222
              "\tthan one of the built-ins, then a function by that name will be\n"
 
223
              "\tcalled to convert identifiers to symbols.\n");
 
224
 
 
225
    }
 
226
      
 
227
  }
 
228
      
 
229
  
 
230
}
 
231
 
 
232
int ALLEGROCL :: top(Node *n) {
 
233
  String *module=Getattr(n, "name");
 
234
  String *output_filename=NewString("");
 
235
  String *devnull=NewString("/dev/null");
 
236
 
 
237
  f_null=NewFile(devnull, "w+");
 
238
  if (!f_null) {
 
239
          perror("Failed to open /dev/null");
 
240
          SWIG_exit(EXIT_FAILURE);
 
241
  }
 
242
  Delete(devnull);
 
243
 
 
244
 
 
245
  Printf(output_filename, "%s%s.cl", SWIG_output_directory(), module);
 
246
 
 
247
 
 
248
  f_cl=NewFile(output_filename, "w");
 
249
  if (!f_cl) {
 
250
    Printf(stderr, "Unable to open %s for writing\n", output_filename);
 
251
    SWIG_exit(EXIT_FAILURE);
 
252
  }
 
253
 
 
254
  Swig_register_filebyname("header",f_null);
 
255
  Swig_register_filebyname("wrapper", f_cl);
 
256
 
 
257
  Printf(f_cl, ";; This is an automatically generated file.  Make changes in\n;; the definition file, not here.\n\n(defpackage :%s\n  (:use :common-lisp :ff :excl))\n\n(in-package :%s)\n", module, module);
 
258
  Printf(f_cl, "(eval-when (compile load eval)\n  (defparameter *swig-identifier-converter* '%s))\n", identifier_converter);
 
259
  
 
260
  Language::top(n);
 
261
 
 
262
  Close(f_cl);
 
263
  Delete(f_cl); // Delete the handle, not the file
 
264
  Close(f_null);
 
265
  Delete(f_null);
 
266
  
 
267
  return SWIG_OK;
 
268
}
 
269
 
 
270
int ALLEGROCL :: functionWrapper(Node *n) {
 
271
  String *funcname=Getattr(n, "sym:name");
 
272
  ParmList *pl=Getattr(n, "parms");
 
273
  Parm *p;
 
274
  int argnum=0, first=1, varargs=0;
 
275
  
 
276
  //Language::functionWrapper(n);
 
277
 
 
278
  Printf(f_cl, "(swig-defun \"%s\"\n", funcname);
 
279
  Printf(f_cl, "  (");
 
280
 
 
281
  /* Special cases */
 
282
  
 
283
  if (ParmList_len(pl) == 0) {
 
284
    Printf(f_cl, ":void");
 
285
  } else if (any_varargs(pl)) {
 
286
    Printf(f_cl, "#| varargs |#");
 
287
    varargs=1;
 
288
  } else {
 
289
    for (p=pl; p; p=nextSibling(p), argnum++) {
 
290
      String *argname=Getattr(p, "name");
 
291
      SwigType *argtype=Getattr(p, "type");
 
292
      String *ffitype=get_ffi_type(argtype, argname);
 
293
      String *lisptype=get_lisp_type(argtype, argname);
 
294
      int tempargname=0;
 
295
      
 
296
      if (!argname) {
 
297
        argname=NewStringf("arg%d", argnum);
 
298
        tempargname=1;
 
299
      }
 
300
      
 
301
      if (!first) {
 
302
        Printf(f_cl, "\n   ");
 
303
      }
 
304
      Printf(f_cl, "(%s %s %s)", argname, ffitype, lisptype);
 
305
      first=0;
 
306
      
 
307
      Delete(ffitype);
 
308
      Delete(lisptype);
 
309
      if (tempargname) 
 
310
        Delete(argname);
 
311
      
 
312
    }
 
313
  }
 
314
  Printf(f_cl, ")\n"); /* finish arg list */
 
315
  Printf(f_cl, "  :returning (%s %s)\n  :strings-convert t\n  :call-direct %s\n  :optimize-for-space t)\n", 
 
316
         get_ffi_type(Getattr(n, "type"), "result"),
 
317
         get_lisp_type(Getattr(n, "type"), "result"),
 
318
         varargs ? "nil"  : "t");
 
319
 
 
320
  
 
321
  return SWIG_OK;
 
322
}
 
323
 
 
324
int ALLEGROCL :: constantWrapper(Node *n) {
 
325
  String *type=Getattr(n, "type");
 
326
  String *converted_value=convert_literal(Getattr(n, "value"), type);
 
327
  String *name=Getattr(n, "sym:name");
 
328
 
 
329
#if 0
 
330
  Printf(stdout, "constant %s is of type %s. value: %s\n",
 
331
         name, type, converted_value);
 
332
#endif
 
333
 
 
334
  Printf(f_cl, "(swig-defconstant \"%s\" %s)\n",
 
335
         name, converted_value);
 
336
 
 
337
  Delete(converted_value);
 
338
 
 
339
  return SWIG_OK;
 
340
}
 
341
 
 
342
// Includes structs
 
343
int ALLEGROCL :: classDeclaration(Node *n) {
 
344
  String *name=Getattr(n, "sym:name");
 
345
  String *kind = Getattr(n,"kind");
 
346
  Node *c;
 
347
  
 
348
  if (Strcmp(kind, "struct")) {
 
349
    Printf(stderr, "Don't know how to deal with %s kind of class yet.\n",
 
350
           kind);
 
351
    Printf(stderr, " (name: %s)\n", name);
 
352
    SWIG_exit(EXIT_FAILURE);
 
353
  }
 
354
 
 
355
  Printf(f_cl, 
 
356
         "(swig-def-foreign-type \"%s\"\n (:struct\n", 
 
357
         name);
 
358
  
 
359
  for (c=firstChild(n); c; c=nextSibling(c)) {
 
360
    SwigType *type=Getattr(c, "type");
 
361
    String *lisp_type;
 
362
 
 
363
    if (Strcmp(nodeType(c), "cdecl")) {
 
364
      Printf(stderr, "Structure %s has a slot that we can't deal with.\n",
 
365
             name);
 
366
      Printf(stderr, "nodeType: %s, name: %s, type: %s\n", 
 
367
             nodeType(c),
 
368
             Getattr(c, "name"),
 
369
             Getattr(c, "type"));
 
370
      SWIG_exit(EXIT_FAILURE);
 
371
    }
 
372
 
 
373
    
 
374
    /* Printf(stdout, "Converting %s in %s\n", type, name); */
 
375
    lisp_type=get_ffi_type(type, Getattr(c, "sym:name"));
 
376
 
 
377
    Printf(f_cl, 
 
378
           "  (#.(%s \"%s\" :type :slot) %s)\n", 
 
379
           identifier_converter,
 
380
           Getattr(c, "sym:name"), 
 
381
           lisp_type);
 
382
 
 
383
    Delete(lisp_type);
 
384
  }
 
385
  
 
386
  Printf(f_cl, " ))\n");
 
387
 
 
388
  /* Add this structure to the known lisp types */
 
389
  //Printf(stdout, "Adding %s foreign type\n", name);
 
390
  add_defined_foreign_type(name);
 
391
  
 
392
  return SWIG_OK;
 
393
}
 
394
 
 
395
extern "C" Language *swig_allegrocl(void) {
 
396
  return new ALLEGROCL();
 
397
}
 
398
 
 
399
 
 
400
 
 
401