make_fint.c 27.1 KB
Newer Older
1
#define _XOPEN_SOURCE 700
2
#define _GNU_SOURCE // needed for getline(3) on some systems it seems
3
4
#include <ctype.h>
#include <regex.h>
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
5
6
7
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
8
#include <sys/types.h>
Uwe Schulzweida's avatar
Uwe Schulzweida committed
9
#include <time.h>
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
10

11
12
13
#ifndef HAVE_GETLINE
#include "getline.c"
#endif
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
14

15
//#include "config.h"
16
#define VERSION "1.6.1.1"
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
17
18
typedef struct
{
19
  size_t naline;
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
20
21
22
23
24
25
  char *fname;
  char *aline[99];
  char *text;
}
Docu;

26
27
28
static Docu cdoc[9999], fdoc[9999];
static size_t ncdoc = 0, nfdoc = 0;
static int debug = 0;
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
29

Thomas Jahns's avatar
Thomas Jahns committed
30
static int doccmp(const void *s1, const void *s2)
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
31
32
33
34
35
36
37
{
  Docu *x = (Docu *) s1;
  Docu *y = (Docu *) s2;

  return (strcmp(x->fname, y->fname));
}

Thomas Jahns's avatar
Thomas Jahns committed
38
static void doctotex(FILE *fp, Docu *doc, size_t ndoc)
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
39
{
40
  size_t i, k;
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
41
42
43
44
45
46
47
48
49
50
51
52

  for ( i = 0; i < ndoc; i++ )
    {
      fprintf(fp, "\\section*{\\tt \\htmlref{%s}{%s}}\n\n", doc[i].fname, doc[i].fname);
      fprintf(fp, "\\begin{verbatim}\n");
      for ( k = 0; k < doc[i].naline; k++ )
	fprintf(fp, "    %s\n", doc[i].aline[k]);
      fprintf(fp, "\\end{verbatim}\n");
      fprintf(fp, "\n%s.\n\n\n", doc[i].text);
    }
}

Thomas Jahns's avatar
Thomas Jahns committed
53
static void doctotxt(FILE *fp, Docu *doc, size_t ndoc)
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
54
{
55
  size_t i, k;
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
56
57
58
59
60
61
62
63
64
65

  for ( i = 0; i < ndoc; i++ )
    {
      fprintf(fp, "%s\n\n", doc[i].fname);
      for ( k = 0; k < doc[i].naline; k++ )
	fprintf(fp, "    %s\n", doc[i].aline[k]);
      fprintf(fp, "\n  %s.\n\n", doc[i].text);
    }
}

66
enum cftype {ISVOID, ISCONSTSTRING, ISINT, ISREAL, ISDOUBLE, ISMPI_COMM,
67
             ISXT_IDXLIST, ISCHOICE, ISINTP, ISINTV, ISINTVV, ISREALP,
68
             ISDOUBLEP, ISCBUF, ISSTRING, ISSTRINGP,
69
70
71
72
73
74
75
76
77
78
             NUM_KNOWN_ARG_TYPES};

enum conversionType { CONV_ARG, CONV_RET };


typedef int (*cfConversionEmitter)(FILE *outfp, const char *argName,
                                   size_t argNameLen, enum conversionType part);

static int cfMPICommConvert(FILE *outfp, const char *argName,
                            size_t argNameLen, enum conversionType part);
79

80
81
82
static int cfXtIdxlistConvert(FILE *outfp, const char *argName,
                            size_t argNameLen, enum conversionType part);

83
84
85
struct symbol {
  const char *f77name, *cfint, *cname, *parseRE;
  size_t nameMatch;
86
87
88
  int needsExtraWrapper;
  cfConversionEmitter convert;
  const char *convcname;
89
90
91
92
93
94
95
96
97
98
  regex_t preg;
};

/* C symbol names */
#define SYMRE "([A-Za-z_][A-Za-z_0-9]*)"
/* white-space */
#define WS "[[:blank:]\n]"
#define NWS "[^[:blank:]\n]"
static struct symbol funArgSym[]
  = { { "",                "",        "void",
99
        "^"WS"*void"WS"*)", 0, 0 },
100
      { "CHARACTER(80)",    "STRING",  "char *",
101
        "^"WS"*const"WS"+char"WS"+\\*"SYMRE WS"*\\(", 1, 0 },
102
      { "INTEGER",         "INT",     "int",
103
        "^"WS"*(const"WS"+)?int("WS"+"SYMRE")?"WS"*[,\\)]", 3, 0 },
104
      { "REAL",            "FLOAT",   "float",
105
        "^"WS"*(const"WS"+)?float"WS"+"SYMRE"?"WS"*[,\\)]", 2, 0 },
106
      { "DOUBLEPRECISION", "DOUBLE",  "double",
107
108
109
110
        "^"WS"*(const"WS"+)?double"WS"+"SYMRE"?"WS"*[,\\)]", 2, 0 },
      { "INTEGER",         "INT", "MPI_Comm",
        "^"WS"*MPI_Comm"WS"+"SYMRE"?"WS"*[,\\)]", 1, 1,
        cfMPICommConvert, "int" },
111
112
113
114
115
      { "TYPE(XT_IDXLIST)", "PVOID", "Xt_idxlist",
        "^"WS"*Xt_idxlist"WS"+"SYMRE"?"WS"*[,\\)]", 1, 1,
        cfXtIdxlistConvert, "void *" },
      { "CHOICE", "PVOID", "const void *",
        "^"WS"*const"WS"+void"WS"*\\*"WS"*"SYMRE"?"WS"*[,\\)]", 1, 0 },
116
      { "INTEGER",         "PINT",    "int *",
117
        "^"WS"*(const"WS"+)?int"WS"+\\*"SYMRE"?"WS"*[,\\)]", 2, 0 },
118
      { "INTEGER",         "INTV",    "int[]",
119
120
        "^"WS"*(const"WS"+)?int("WS"+"SYMRE")?"WS"*\\[[^]]*\\]"
        WS"*[,\\)]", 3, 0 },
121
122
      { "INTEGER",         "INTVV",    "int[][]",
        "^"WS"*(const"WS"+)?int("WS"+"SYMRE")?"WS"*\\[[^]]*\\]"
123
        WS"*\\[[^]]*\\]"WS"*[,\\)]", 3, 0 },
124
      { "REAL",            "PFLOAT",  "float *",
125
        "^"WS"*(const"WS"+)?float"WS"+\\*"SYMRE"?"WS"*[,\\)]", 2, 0 },
126
      { "DOUBLEPRECISION", "PDOUBLE", "double *",
127
        "^"WS"*(const"WS"+)?double"WS"+\\*"SYMRE"?"WS"*[,\\)]", 2, 0 },
128
129
      { "CHARACTER*(*)",   "CBUF",    "char *",
        "^"WS"*(const"WS"+)?char"WS"+\\*""([A-Za-z_][A-Za-z_0-9]*_cbuf)"WS"*[,\\)]", 2 },
130
      { "CHARACTER*(*)",   "STRING",  "char *",
131
        "^"WS"*const"WS"+char"WS"+\\*"WS"*"SYMRE"?"WS"*[,\\)]", 1, 0 },
132
      { "CHARACTER*(*)",   "PSTRING", "char *",
133
        "^"WS"*char"WS"+\\*"SYMRE"?"WS"*[,\\)]", 1, 0 },
134
135
136
137
};

static struct symbol funRet[] = {
  { "",                "",        "void",
138
    "void"WS"+"SYMRE WS"*\\(", 1, 0 },
139
  { "CHARACTER",       "STRING",  "(const) char *",
140
    "(const"WS"+)?char"WS"+\\*"WS"*"SYMRE WS"*\\(", 2, 0 },
141
  { "INTEGER",         "INT",     "int",
142
    "(const"WS"+)?int"WS"+"SYMRE WS"*\\(", 2, 0 },
143
  { "REAL",            "FLOAT",   "float",
144
    "(const"WS"+)?float"WS"+"SYMRE WS"*\\(", 2, 0 },
145
  { "DOUBLEPRECISION", "DOUBLE",  "double",
146
147
148
    "(const"WS"+)?double"WS"+"SYMRE WS"*\\(", 2, 0 },
  { "INTEGER",         "INT",     "MPI_Comm",
    "MPI_Comm"WS"+"SYMRE WS"*\\(", 1, 0, cfMPICommConvert, "int" },
149
150
151
152
153
154
155
};

enum { NUM_RET_TYPES = sizeof (funRet) / sizeof (funRet[0]) };
enum decl { UNKNOWN_DECL, FUNC_DECL, PARAM_DECL };

enum {
  MAX_FUNC_ARGS = 200,
156
  MAX_FUNC_NAME_LEN = 127,
157
158
159
160
161
};

static inline size_t
compress_whitespace(size_t len, char str[]);

162
163
164
static int
reCompile(regex_t *restrict RE, const char *restrict REstring,
          char * restrict *restrict lineBuf, size_t * restrict lineBufSize);
Thomas Jahns's avatar
Thomas Jahns committed
165
166
167
168
169
static size_t
symRegexCompile(size_t numSyms, struct symbol symList[],
                char **line, size_t *lineBufSize);


Thomas Jahns's avatar
Thomas Jahns committed
170
static void fortran_interface(char *fname, char *fnameinc, char *fnameint)
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
171
172
173
{
  FILE *fpin, *fpinc, *fpint;
  FILE *fp;
174
175
176
  char *line = NULL, *pline;
  size_t lineBufSize = 0;
  char sname[128], *parname;
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
177
  char xname[128], xdes[128];
178
  xname[0] = 0;
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
179
  int parvalue;
180
  enum cftype functype;
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
181
  int lineno = 0;
182
183
  size_t len;

184
  char funcname[MAX_FUNC_NAME_LEN];
185
186
187
188
  regmatch_t funcargfull[MAX_FUNC_ARGS];
  regmatch_t funcargname[MAX_FUNC_ARGS];
  int  funcargtype[MAX_FUNC_ARGS];
  /* char *strsort[99999]; */
Uwe Schulzweida's avatar
Uwe Schulzweida committed
189
190
191
  char timestr[30];
  time_t date_and_time_in_sec;
  struct tm *date_and_time;
192
193
  regmatch_t *reMatch = NULL;
  size_t maxMatch = 0;
Uwe Schulzweida's avatar
Uwe Schulzweida committed
194
195
196
197
198
199
200
201
202

  date_and_time_in_sec = time(NULL);
  timestr[0] = 0;

  if ( date_and_time_in_sec != -1 )
    {
      date_and_time = localtime(&date_and_time_in_sec);
      (void) strftime(timestr, sizeof(timestr), "%B %Y", date_and_time);
    }
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
203
204
205
206
207
208
209
210
211
212

  fpin = fopen(fname, "r");
  if ( fpin == NULL ) { perror(fname); return; }

  fpinc = fopen(fnameinc, "w");
  if ( fpinc == NULL ) { perror(fnameinc); return; }

  fpint = fopen(fnameint, "w");
  if ( fpint == NULL ) { perror(fnameint); return; }

213
  /* complete symbol table data */
Thomas Jahns's avatar
Thomas Jahns committed
214
215
216
217
218
219
220
221
  {
    maxMatch = symRegexCompile(NUM_KNOWN_ARG_TYPES, funArgSym,
                             &line, &lineBufSize);
    size_t maxFunMatch = symRegexCompile(NUM_RET_TYPES, funRet,
                                         &line, &lineBufSize);
    if (maxFunMatch > maxMatch)
      maxMatch = maxFunMatch;
  }
222
223
224
225
226
  ++maxMatch;
  reMatch = malloc((size_t)maxMatch * sizeof (reMatch[0]));
  /* compile comment regular expression */
  regex_t commentRE;
  {
227
228
229
    static const char commentREString[] = "^"WS"*/\\*"WS"*(.*"NWS")"WS"*\\*/";
    if (reCompile(&commentRE, commentREString, &line, &lineBufSize))
      exit(EXIT_FAILURE);
230
231
232
233
  }
  /* compile documentation comment regular expression */
  regex_t docCommentRE;
  {
234
    static const char docCommentREString[] = "^"WS"*/\\*"WS"*"SYMRE":"
235
      WS"*("NWS".*"NWS")"WS"*\\*/";
236
237
    if (reCompile(&docCommentRE, docCommentREString, &line, &lineBufSize))
      exit(EXIT_FAILURE);
238
  }
239
240
241
242
243
244
245
246
247
248
  /* compile keep-conditional regular expression */
  /* if(n)def and endif preprocessor conditionals followed by
     make_fint keep are copied to the Fortran interface file */
  regex_t cppCondRE;
  {
    static const char cppCondREString[]
      = "^"WS"*#"WS"*(ifn?def"WS"+"SYMRE"|endif)"WS"+/\\*"WS"*make_fint keep"WS"*\\*/";
    if (reCompile(&cppCondRE, cppCondREString, &line, &lineBufSize))
      exit(EXIT_FAILURE);
  }
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
249
250
  /* fortran include */

251
  fprintf(fpinc, "! This file was automatically generated, don't edit!\n");
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
252
  fprintf(fpinc, "!\n");
253
  fprintf(fpinc, "! Fortran interface for CDI library version %s\n", VERSION);
Uwe Schulzweida's avatar
Uwe Schulzweida committed
254
255
256
257
  fprintf(fpinc, "!\n");
  fprintf(fpinc, "! Author:\n");
  fprintf(fpinc, "! -------\n");
  fprintf(fpinc, "! Uwe Schulzweida, MPI-MET, Hamburg,   %s\n", timestr);
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
258
259
260
261
  fprintf(fpinc, "!\n\n");

  /* fortran interface */

262
  fprintf(fpint, "/* Automatically generated by make_fint.c, don't edit! */\n");
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
263
264
265
266
267
  fprintf(fpint, "\n");
  fprintf(fpint, "#if defined (HAVE_CONFIG_H)\n");
  fprintf(fpint, "#  include \"config.h\"\n");
  fprintf(fpint, "#endif\n");
  fprintf(fpint, "\n");
268
269
  fputs("#if USE_MPI\n"
        "#  include <mpi.h>\n"
270
        "#  include <yaxt.h>\n"
271
272
273
274
275
276
277
278
279
280
        "#else\n"
        "#define MPI_Comm int\n"
        "#define MPI_Comm_f2c(c) (c)\n"
        "#define MPI_Comm_c2f(c) (c)\n"
        "#endif\n"
        "\n"
        "#if ! defined (_CDI_H)\n"
        "#  include \"cdi.h\"\n"
        "#endif\n"
        "\n", fpint);
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
281
282
283
284
285
286
  fprintf(fpint, "#if defined (HAVE_CF_INTERFACE)\n");
  fprintf(fpint, "\n");
  fprintf(fpint, "#if ! defined (__CFORTRAN_LOADED)\n");
  fprintf(fpint, "#  include \"cfortran.h\"\n");
  fprintf(fpint, "#endif\n");
  fprintf(fpint, "\n");
287
288
289
290
  fprintf(fpint, "#if ! defined (_CDIFORTRAN_H)\n");
  fprintf(fpint, "#  include \"cdiFortran.h\"\n");
  fprintf(fpint, "#endif\n");
  fprintf(fpint, "\n");
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
291

292
293
  ssize_t lineLen;
  while ((lineLen = getline(&line, &lineBufSize, fpin)) >= 0)
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
294
295
296
    {
      lineno++;
      functype = ISVOID;
297
298
      size_t funcargc = 0;
      pline = line;
299
      int needsExtraWrapper = 0;
300
301
302
303
304
305
306
      enum decl declType = UNKNOWN_DECL;
      do {
        for (int retType = 0; retType < NUM_RET_TYPES; ++retType)
          if (!regexec(&funRet[retType].preg, pline, maxMatch, reMatch, 0))
            {
              functype = retType;
              declType = FUNC_DECL;
307
308
              needsExtraWrapper
                = needsExtraWrapper || funRet[retType].needsExtraWrapper;
309
310
311
312
313
              break;
            }
        if (declType == UNKNOWN_DECL)
          break;
        regmatch_t *nameMatch = reMatch + funRet[functype].nameMatch;
314
315
        if (debug)
          printf("Found: %.*s\n",
316
                 (int) (nameMatch->rm_eo - nameMatch->rm_so),
317
                 pline + nameMatch->rm_so);
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
        ssize_t funNameLast = reMatch[0].rm_eo - 1;
        ssize_t nameLen = nameMatch->rm_eo - nameMatch->rm_so;
        if ( pline[funNameLast] != '(' )
          {
            printf("%s\n>(< not found!", line);
            return;
          }
        memcpy(funcname, pline + nameMatch->rm_so, (size_t)nameLen);
        funcname[nameLen] = 0;
        pline += reMatch[0].rm_eo;
      } while (0);
      if (declType == FUNC_DECL)
        {
	  funcargname[funcargc].rm_so = (regoff_t)(pline - line);
          {
            ssize_t i = 0;
            do {
              ssize_t restLen = lineLen - (ssize_t)(pline - line);
              for (; i < restLen; i++ )
                {
                  if ( pline[i] == ',' )
                    {
                      funcargc++;
                      funcargname[funcargc].rm_so
                        = (regoff_t)(pline - line + i + 1);
                    }
                  if ( pline[i] == ')' )
                    {
                      funcargc++;
                      funcargname[funcargc].rm_so
                        = (regoff_t)(pline - line + i + 1);
                      break;
                    }
                }
              if (i < restLen)
                break;
              char *lineExtension = NULL;
              size_t extSize = 0, plineOff = (size_t)(pline - line);
              ssize_t extLen;
              if ((extLen = getline(&lineExtension, &extSize, fpin)) <= 0)
                break;
              if ((size_t)(lineLen + extLen) >= lineBufSize)
                if (!(line = realloc(line, (size_t)(lineLen + extLen + 1))))
                  exit(EXIT_FAILURE);
              memcpy(line + lineLen, lineExtension, (size_t)extLen + 1);
              lineLen += extLen;
              pline = line + plineOff;
            } while (1);
          }
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
367
368

	  /*  printf("funcargc = %d\n", funcargc);*/
369
370
          {
            size_t i;
371
            for (i = 0; i < funcargc; ++i )
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
              {
                pline = line + funcargname[i].rm_so;
                int argtype;
                regoff_t argStart = (regoff_t)(pline - line);
                for (argtype = ISVOID;
                     argtype < NUM_KNOWN_ARG_TYPES;
                     ++argtype)
                  if (!regexec(&funArgSym[argtype].preg, pline, maxMatch,
                               reMatch, 0))
                    {
                      funcargtype[i] = argtype;
                      funcargfull[i].rm_so = reMatch[0].rm_so + argStart;
                      funcargfull[i].rm_eo = reMatch[0].rm_eo + argStart;
                      regmatch_t *nameMatch = reMatch + funArgSym[argtype].nameMatch;
                      funcargname[i].rm_so = nameMatch->rm_so + argStart;
                      funcargname[i].rm_eo = nameMatch->rm_eo + argStart;
388
389
                      needsExtraWrapper
                        = needsExtraWrapper || funArgSym[argtype].needsExtraWrapper;
390
391
392
393
394
395
396
397
398
399
400
401
402
403
                      break;
                    }
                if (argtype == NUM_KNOWN_ARG_TYPES)
                  {
                    printf("%s not implemented\n", line + funcargname[i].rm_so);
                    break;
                  }
              }
            if ( i != funcargc )
              {
                printf("problem parsing line: %s\n", line);
                continue;
              }
          }
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
404
405
406

	  strcpy(sname, funcname);
	  len = strlen(sname);
407

Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
408
409
410
411
412
	  /* fortran include */

	  if ( functype == ISVOID )
	    fprintf(fpinc, "!     %-16s", "");
	  else
413
	    fprintf(fpinc, "      %-16s", funArgSym[functype].f77name);
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
414
415
416
417

          fprintf(fpinc, "%s", sname);
	  fprintf(fpinc, "\n");
	  if ( (funcargc == 1 && funcargtype[0] == ISVOID) ) funcargc = 0;
418
	  for (size_t i = 0; i < funcargc; i++ )
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
419
420
421
422
423
	    {
	      if ( i == 0 )
		fprintf(fpinc, "!%36s(", "");
	      else
		fprintf(fpinc, ",\n!%36s ", "");
424
425
426
	      fprintf(fpinc, "%-16s%.*s", funArgSym[funcargtype[i]].f77name,
                      (int)(funcargname[i].rm_eo - funcargname[i].rm_so),
                      line + funcargname[i].rm_so);
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
427
428
429
430
431
432
	    }
	  if ( funcargc )
	    fprintf(fpinc, ")\n");
	  fprintf(fpinc, "      %-16s%s\n\n", "EXTERNAL", sname);

	  /* fortran interface */
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
          const char *delegateName;
          char delegateNameBuf[MAX_FUNC_NAME_LEN + 7];
          /* emit wrapper for type conversions if needed */
          if (needsExtraWrapper)
            {
              strcpy(delegateNameBuf, funcname);
              strcat(delegateNameBuf, "_fwrap");
              delegateName = delegateNameBuf;
              fprintf(fpint, "static %s %s(",
                      (funRet[functype].convert
                       ?funRet[functype].convcname:funRet[functype].cname),
                      delegateName);
              for (size_t i = 0; i < funcargc; i++ )
                {
                  fprintf(fpint, "%s%s %.*s", (i > 0?", ":""),
                          (funArgSym[funcargtype[i]].convert
                           ?funArgSym[funcargtype[i]].convcname
                           :funArgSym[funcargtype[i]].cname),
                          (int)(funcargname[i].rm_eo - funcargname[i].rm_so),
                          line + funcargname[i].rm_so);
                }
              fputs(")\n{\n", fpint);
              if (functype != ISVOID)
                fprintf(fpint, "  %s v;\n"
                        "  v = %s(", funRet[functype].cname,
                        funcname);
              else
                fprintf(fpint, "  %s(", funcname);
              for (size_t i = 0; i < funcargc; i++ )
                {
                  if (funArgSym[funcargtype[i]].convert)
                    {
                      if (i > 0)
                        fputs(", ", fpint);
                      funArgSym[funcargtype[i]]
                        .convert(fpint,
                                 line + funcargname[i].rm_so,
                                 (size_t)(funcargname[i].rm_eo
                                          - funcargname[i].rm_so), CONV_ARG);
                    }
                  else
                    fprintf(fpint, "%s %.*s", (i > 0?", ":""),
                            (int)(funcargname[i].rm_eo - funcargname[i].rm_so),
                            line + funcargname[i].rm_so);
                }
              fputs(");\n", fpint);
              if (functype != ISVOID)
                {
                  fputs("  return ", fpint);
                  if (funRet[functype].convert)
                    funRet[functype].convert(fpint, "v", 1, CONV_RET);
                  else
                    fputc('v', fpint);
                  fputs(";\n", fpint);
                }
              fputs("}\n", fpint);
            }
          else
            delegateName = funcname;
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
492
493
494
495
	  if ( functype == ISVOID )
	    fprintf(fpint, "FCALLSCSUB");
	  else
	    fprintf(fpint, "FCALLSCFUN");
496
	  fprintf(fpint, "%zd ", funcargc);
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
497
498
	  fprintf(fpint, "(");
	  if ( functype != ISVOID )
499
500
	    fprintf(fpint, "%s, ", funRet[functype].cfint);
	  fprintf(fpint, "%s, ", delegateName);
501
	  for (size_t i = 0; i < len; i++ ) sname[i] = (char)toupper((int) sname[i]);
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
502
	  fprintf(fpint, "%s, ", sname);
503
	  for (size_t i = 0; i < len; i++ ) sname[i] = (char)tolower((int) sname[i]);
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
504
	  fprintf(fpint, "%s", sname);
505
	  for (size_t i = 0; i < funcargc; i++ )
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
506
	    {
507
508
	      fprintf(fpint, ", %s", funArgSym[funcargtype[i]].cfint);
	    }
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
509
510
511
	  fprintf(fpint, ")\n");


512
	  if ( strcmp(funcname, xname) == 0 )
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
513
514
	    {
	      char xline[128];
515
516
	      int nch;

Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
517
518
519
520
521
522
	      /* C Quick Guide */

	      cdoc[ncdoc].naline = 0;
	      cdoc[ncdoc].text   = NULL;
	      cdoc[ncdoc].fname  = strdup(funcname);

523
	      nch = sprintf(xline, "%s %s (", funArgSym[functype].cname, xname);
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
524
525
526

	      if ( (funcargc == 1 && funcargtype[0] == ISVOID) ) funcargc = 0;

527
	      for (size_t i = 0; i < funcargc; i++ )
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
528
529
530
		{
		  if ( i ) strcat(xline, ", ");

531
532
533
534
535
536
537
538
539
540
541
542
                  /* extract full argument text from match */
                  char farg[128];
                  /* - 1 to omit closing paren ) or comma , */
                  int nchn = snprintf(farg, sizeof (farg), "%.*s",
                                      (int)(funcargfull[i].rm_eo
                                            - funcargfull[i].rm_so - 1),
                                      line + funcargfull[i].rm_so);
                  if (nchn < 0)
                    abort();
                  /* compress white-space */
                  nchn = (int)compress_whitespace((size_t)nchn, farg);
		  if ( (strlen(xline)+(size_t)nchn) > (size_t)80 )
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
543
		    {
544
                      if (i) xline[strlen(xline) - 1] = 0;
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
		      cdoc[ncdoc].aline[cdoc[ncdoc].naline++] = strdup(xline);
		      sprintf(xline, "%*s", nch, "");
		    }
		  strcat(xline, farg);
		}
	      if ( funcargc ) strcat(xline, ");");
	      cdoc[ncdoc].aline[cdoc[ncdoc].naline++] = strdup(xline);
	      cdoc[ncdoc].text  = strdup(xdes);

	      ncdoc++;

	      /* Fortran Quick Guide */

	      fdoc[nfdoc].naline = 0;
	      fdoc[nfdoc].text   = NULL;
	      fdoc[nfdoc].fname  = strdup(funcname);

	      if ( functype == ISVOID )
		nch = sprintf(xline, "SUBROUTINE %s (", xname);
	      else
565
		nch = sprintf(xline, "%s FUNCTION %s (", funArgSym[functype].f77name, xname);
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
566
567
568

	      if ( (funcargc == 1 && funcargtype[0] == ISVOID) ) funcargc = 0;

569
	      for (size_t i = 0; i < funcargc; i++ )
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
570
571
572
		{
		  if ( i ) strcat(xline, ", ");

573
574
575
576
577
578
579
580
581
582
583
                  char farg[128];
                  /* FIXME: optional empty argument name unhandled */
		  int nchn
                    = snprintf(farg, sizeof (farg), "%s %.*s",
                               funArgSym[funcargtype[i]].f77name,
                               (int)(funcargname[i].rm_eo
                                     - funcargname[i].rm_so),
                               line + funcargname[i].rm_so);
                  if (nchn < 0)
                    abort();
		  if ( (strlen(xline)+(size_t)nchn) > 80 )
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
584
585
586
587
588
589
590
591
592
593
594
595
596
		    {
		      fdoc[nfdoc].aline[fdoc[nfdoc].naline++] = strdup(xline);
		      sprintf(xline, "%*s", nch, "");
		    }
		  strcat(xline, farg);
		}
	      if ( funcargc ) strcat(xline, ")");
	      fdoc[nfdoc].aline[fdoc[nfdoc].naline++] = strdup(xline);
	      fdoc[nfdoc].text  = strdup(xdes);

	      nfdoc++;
	    }
	}
597
      else if ( memcmp(line, "#define", 7) == 0 )
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
598
599
600
601
602
603
	{
	  pline = line;
	  pline += 7;
	  while ( isspace((int) *pline) ) pline++;
	  parname = pline;
	  len = strlen(pline);
604
605
          size_t i = 0;
	  for (; i < len; i++ )
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
606
607
608
609
610
611
612
613
614
615
616
	    {
	      if ( isspace((int) pline[i]) ) break;
	    }
	  if ( i == len ) continue;
	  parname[i] = 0;
	  pline += i+1;
	  while ( isspace((int) *pline) ) pline++;
	  if ( ! (isdigit((int) *pline) || *pline == '-') ) continue;
	  parvalue = atoi(pline);

	  /* fortran include */
617
618
619
	  fprintf(fpinc, "      INTEGER    %-22s\n"
                  "      PARAMETER (%-22s = %2d)\n", parname, parname,
                  parvalue);
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
620
	}
621
622
623
624
625
      else if (!regexec(&cppCondRE, line, maxMatch, reMatch, 0))
	{
          /* fortran include */
	  fputs(line, fpint);
	}
626
627
628
629
630
631
632
633
634
635
636
637
638
      else if (!regexec(&docCommentRE, line, maxMatch, reMatch, 0))
        {
          /* found documentation comment */
          size_t nameMatchLen = (size_t)(reMatch[1].rm_eo - reMatch[1].rm_so),
            docMatchLen = (size_t)(reMatch[2].rm_eo - reMatch[2].rm_so);
          memcpy(xname, line + reMatch[1].rm_so, nameMatchLen);
          xname[nameMatchLen] = 0;
          memcpy(xdes, line + reMatch[2].rm_so, docMatchLen);
          xdes[docMatchLen] = 0;
          printf("Found documentation for \"%s\": \"%s\"\n", xname,
                 xdes);
        }
      else if (!regexec(&commentRE, line, maxMatch, reMatch, 0))
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
639
	{
640
641
642
643
          size_t commentLen = (size_t)(reMatch[1].rm_eo - reMatch[1].rm_so);
          const char *comment = line + reMatch[1].rm_so;
          /* fortran include */
          fprintf(fpinc, "!\n!  %.*s\n!\n", (int)commentLen, comment);
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
644

645
646
          /* fortran interface */
          fprintf(fpint, "\n/*  %.*s  */\n\n", (int)commentLen, comment);
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
647
648
649
	}
      else
	{
650
651
652
	  if ( lineLen > 1 )
	    printf("skip: line %3d  size %3zd  %s%s", lineno, lineLen, line,
                   line[lineLen-1]=='\n'?"":"missing new-line\n");
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
	}
    }

  fprintf(fpint, "\n");
  fprintf(fpint, "#endif\n");

  fclose(fpin);
  fclose(fpinc);
  fclose(fpint);

  qsort(cdoc, ncdoc, sizeof(Docu), doccmp);
  qsort(fdoc, nfdoc, sizeof(Docu), doccmp);

  fp = fopen("../doc/c_quick_ref.txt", "w");
  if ( fp )
    {
      fprintf(fp, "C Quick Reference\n");
      fprintf(fp, "-----------------\n\n");

      doctotxt(fp, cdoc, ncdoc);
      fclose(fp);
    }

  fp = fopen("../doc/f_quick_ref.txt", "w");
  if ( fp )
    {
      fprintf(fp, "Fortran Quick Reference\n");
      fprintf(fp, "-----------------------\n\n");

      doctotxt(fp, fdoc, nfdoc);
      fclose(fp);
    }

  fp = fopen("../doc/tex/c_quick_ref.tex", "w");
  if ( fp )
    {
      fprintf(fp, "\\chapter*{Quick Reference}\n");
      fprintf(fp, "\\addcontentsline{toc}{chapter}{Quick Reference}\n");
      fprintf(fp, "\n");
      fprintf(fp, "This appendix provide a brief listing of the C language bindings of the\n");
      fprintf(fp, "CDI library routines:\n");
      fprintf(fp, "\n");

      doctotex(fp, cdoc, ncdoc);
      fclose(fp);
    }

  fp = fopen("../doc/tex/f_quick_ref.tex", "w");
  if ( fp )
    {
      fprintf(fp, "\\chapter*{Quick Reference}\n");
      fprintf(fp, "\\addcontentsline{toc}{chapter}{Quick Reference}\n");
      fprintf(fp, "\n");
      fprintf(fp, "This appendix provide a brief listing of the Fortran language bindings of the\n");
      fprintf(fp, "CDI library routines:\n");
      fprintf(fp, "\n");

      doctotex(fp, fdoc, nfdoc);
      fclose(fp);
    }
}

int main(int argc, char *argv[])
{
  char *fname;
  char *cp;
  char fnameinc[128], fnameint[128];
  size_t len;

  if ( argc != 2 )
    {
      printf("Usage:  %s  includefile\n", argv[0]);
      return (1);
    }

  fname = argv[1];

  cp = strrchr(fname, '.');
  if ( cp == NULL ) len = strlen(fname);
732
  else              len = (size_t)(cp - fname);
733

734
735
  memcpy(fnameinc, fname, len);
  memcpy(fnameint, fname, len);
Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
736
737
738

  strcpy(fnameinc+len, ".inc");
  strcpy(fnameint+len, "Fortran.c");
739

Uwe Schulzweida's avatar
Cleanup  
Uwe Schulzweida committed
740
741
742
743
  fortran_interface(fname, fnameinc, fnameint);

  return (0);
}
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772

static inline size_t
compress_whitespace(size_t len, char str[])
{
  size_t wpos = 0;
  size_t i = 0;
  /* skip leading white-space */
  while (i < len && (isblank(str[i]) || str[i] == '\n'))
    ++i;
  /* after the leading white-space the following is
   * an alternation of white- and non-white-space
   * characters, where sequences of the latter will
   * be compressed to a single space */
  while (i < len)
    {
      /* handle white-space */
      while (i < len && !(isblank(str[i]) || str[i] == '\n'))
        str[wpos++] = str[i++];
      /* skip non-white-space */
      size_t wscount = 0;
      while (i < len && (isblank(str[i]) || str[i] == '\n'))
        ++i, ++wscount;
      if (wscount)
        str[wpos++] = ' ';
    }
  str[wpos] = '\0';
  return wpos;
}

Thomas Jahns's avatar
Thomas Jahns committed
773
774
775
776
777
778
779
780
781
782
783
784
enum {
  REGEX_MAX_ERRSTRLEN = 1024,
};


static size_t
symRegexCompile(size_t numSyms, struct symbol symList[],
                char **line, size_t *lineBufSize)
{
  size_t maxMatch = 0;
  for (size_t sym = 0; sym < numSyms; ++sym)
    {
785
786
787
      if (reCompile(&symList[sym].preg, symList[sym].parseRE,
                    line, lineBufSize))
        exit(EXIT_FAILURE);
Thomas Jahns's avatar
Thomas Jahns committed
788
789
790
791
792
793
      if (symList[sym].nameMatch > maxMatch)
        maxMatch = symList[sym].nameMatch;
    }
  return maxMatch;
}

794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
static int
reCompile(regex_t *restrict RE, const char *restrict REstring,
          char * restrict *restrict lineBuf, size_t * restrict lineBufSize)
{
  int errcode;
  if ((errcode = regcomp(RE, REstring, REG_EXTENDED)))
    {
      char *restrict line;
      size_t resize;
      if (*lineBufSize < REGEX_MAX_ERRSTRLEN
          && (line = realloc(*lineBuf, resize = REGEX_MAX_ERRSTRLEN)))
        {
          *lineBuf = line;
          *lineBufSize = resize;
          regerror(errcode, RE, line, *lineBufSize);
          fprintf(stderr, "Error compiling regular expression: %s: %s\n",
                  REstring, *lineBuf);
        }
    }
  return errcode;
}

816
817
/* emit conversion code for MPI_Comm argument */
static int cfMPICommConvert(FILE *outfp, const char *argName,
818
                            size_t argNameLen, enum conversionType part)
819
820
821
822
823
824
825
826
827
828
829
830
831
832
{
  int retval = 0;
  switch (part)
    {
    case CONV_ARG:
      retval
        = fprintf(outfp, "MPI_Comm_f2c(%.*s)", (int)argNameLen, argName);
      break;
    case CONV_RET:
      retval = fprintf(outfp, "MPI_Comm_c2f(%.*s)", (int)argNameLen, argName);
      break;
    }
  return retval;
}
833

834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
/* emit conversion code for Xt_idxlist argument */
static int cfXtIdxlistConvert(FILE *outfp, const char *argName,
                              size_t argNameLen, enum conversionType part)
{
  int retval = 0;
  switch (part)
    {
    case CONV_ARG:
      retval
        = fprintf(outfp, "(*(Xt_idxlist *)%.*s)", (int)argNameLen, argName);
      break;
    case CONV_RET:
      abort();
      break;
    }
  return retval;
}

852
853
854
855
856
857
858
859
860
/*
 * Local Variables:
 * c-file-style: "Java"
 * c-basic-offset: 2
 * indent-tabs-mode: nil
 * show-trailing-whitespace: t
 * require-trailing-newline: t
 * End:
 */
861