/*
	f77290.c
		a f77 (fixed format) -> f90 (free format) converter;
		if QPRECISION is defined, also converts double prec
		to quad prec (using the conventions of qcomplex.f90)
		Sept 97, last modified 10 Jan 99 th
*/

#define QPRECISION
#define MAXLINELENGTH 82

#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include <math.h>

#define upper(a) &a[sizeof(a)/sizeof(char *)]

const char *ops[] = {
  ".eq.", "==", ".ne.", "/=",
  ".le.", "<=", ".ge.", ">=",
  ".lt.", "<",  ".gt.", ">" };

const char *types[] = {
#ifdef QPRECISION
  "type(complex32)",
#else
  "double complex",
#endif
  "double precision", 
  "integer", "real", "character", "complex", "logical" };

const char *units[] = {
  "function", "subroutine", "block data", "program" };

typedef struct sourceline {
  struct sourceline *next;
  int label, indent;
  char s[132];
} SOURCELINE;

void f90name(char *oldname)
{
  char *p;
  static char newname[50];

  if((p = strchr(oldname, '.')) && (*(p + 1) | 0x20) == 'f')
    strcpy(p, ".f90");
  else strcat(p, "90");
}

int isnumber(char c1, char c2, char c3, char c4)
{
  int i2 = isdigit(c2), i3 = isdigit(c3);

  if(i3) return i2 || ((c2 | 0x21) == 'e' && isdigit(c1)) ||
    ((c2 == '+' || c2 == '-') && (c1 | 0x21) == 'e');
  if(i2) return (c3 | 0x21) == 'e' &&
    (c4 == '+' || c4 == '-' || isdigit(c4));
  return (c2 | 0x21) == 'e' && isdigit(c1) &&
    (c3 == '+' || c3 == '-') && isdigit(c4);
}

#ifdef QPRECISION
void typereplace(char *s, char *d, char *from, char *to)
{
  int i;
  char *p, s2[200];

  if(p = strstr(s, from)) {
    i = strlen(from);
    strcpy(s2, p + i);
    strcpy(p, to);
    strcat(p, s2);
    p = d + (int)(p - s);
    strcpy(s2, p + i);
    strcpy(p, to);
    strcat(p, s2);
  }
}
#endif

main(int argc, char **argv)
{
  FILE *f;
  char s[200], s2[200], *p, *d, *d2, suffix;
  char fnstack[500], *funcname[10], **fnp = funcname;
  char functype[50], ch;
  const char **pp;
  int lnr = 0, maxllen = MAXLINELENGTH, cont, space, i, throwout = 0;
  int indent = 0, defertype = 0, justif = 0, param = 0;
  SOURCELINE *start = NULL, *current = NULL, *new, *last = NULL;
  SOURCELINE *xref[300], **xrp = xref, **xxp;
  int gotos[150], *gp = gotos, donum[150], *dgp = donum, *ip;
  char *dos[150], **dp = dos, **cp;
#ifdef QPRECISION
  int usemodule = 0;
#endif

  if(argc < 2) {
    fprintf(stderr, "usage: %s file.f [file.f90]\n"
      "  translates fixed-style f77 source code file.f to "
      "free-style f90 source code.\n"
      "  if the file is -, stdin/stdout is used.\n",
      argv[0]);
    exit(1);
  }
  if(strcmp(argv[1], "-") == 0) f = stdin;
  else if((f = fopen(argv[1],"r")) == NULL) {
    fprintf(stderr, "%s not found\n", argv[1]);
    exit(2);
  }
  if(p = getenv("MAXLINELENGTH")) maxllen = atoi(p);

  *funcname = fnstack;
  while(!feof(f)) {
    *s = 0;
    ++lnr;
    fgets(s, sizeof(s), f);
    *(s + strlen(s) - 1) = 0;
    if(*s == 0) continue;
    p = s;
    cont = 0;
    if(strncmp(s, "     ", 5) == 0 && s[5] > ' ') {
      if(throwout) continue;
      p += 6;
      if(last) {
        d = last->s + (i = strlen(last->s));
        d2 = p + strspn(p, " \t");
        space = strchr(",()=/", *(d - 1)) || strchr(",()=/", *d2) ||
          (*(d - 1) >= 'A' && *(d - 1) <= 'z' && *d2 >= 'A' && *d2 <= 'z');
        if(space) *d++ = ' ';
        cont = 1 + (i + strlen(p) < maxllen && last == current);
        if(cont == 1) *d++ = '&';
        *d = 0;
      }
    }
    else if(strncasecmp(p + strspn(p, " \t"), "intrinsic", 9) == 0) {
      throwout = 1;
      continue;
    }
    throwout = 0;
    if(cont < 2) {
      new = malloc(sizeof(SOURCELINE));
      if(!start) start = current = new;
      else {
        current->next = new;
        current = new;
      }
      current->indent = indent;
      d = current->s;
      if(*s == '\t' || cont == 1) current->label = 0;
      else {
        current->label = strtol(s, &d2, 10);
        if(d2 != s) p = d2, *xrp++ = current;
      }
      if(cont == 1) {
        current->indent += 2;
        if(!space) *d++ = '&';
      }
    }
    p = memccpy(d, p + strspn(p, " \t"), 0, 132) - 2;
    while(p > s && (*p == ' ' || *p == '\t')) --p;
    *++p = 0;
    if(*s == '*' || (*s | 0x20) == 'c') {
      *d = '!';
			/* this is a dirty hack to cure some problems
			   the DEC f90 compiler has with FF */
      if(strstr(s, "#] declarations")) strcpy(p, "\ncontinue");
      continue;
    }
    for(p = s, d2 = d; *d2; ) *p++ = tolower(*d2++);
    *p = 0;
    if(strncmp(s, "include", 7) == 0 || strncmp(s, "#include", 8) == 0) {
      if((p = strpbrk(d + 7, "'\"<")) && (d2 = strpbrk(++p, "'\">"))) {
        ch = *d2;
        *d2 = 0;
        f90name(p);
        *(p += strlen(p)) = ch;
        *(p + 1) = 0;
      }
    }
#ifdef QPRECISION
    if(usemodule && !cont) {
      new = malloc(sizeof(SOURCELINE));
      memcpy(new, current, sizeof(SOURCELINE));
      current->next = new;
      current->label = 0;
      strcpy(current->s, "use qcomplex");
      current = new;
      d = current->s;
      usemodule = 0;
    }
#endif
    if(defertype && !cont && strncmp(s, "implicit", 8)) {
      new = malloc(sizeof(SOURCELINE));
      memcpy(new, current, sizeof(SOURCELINE));
      current->next = new;
      current->label = 0;
      strcpy(current->s, functype);
      strcat(current->s, *(fnp - 1) + 9);
      current = new;
      d = current->s;
      param = justif = defertype = 0;
    }
#ifdef QPRECISION
    typereplace(s, d, "double complex", "type(complex32)");
    typereplace(s, d, "complex*16", "type(complex32)");
    typereplace(s, d, "double precision", "real*16");
    typereplace(s, d, "real*8", "real*16");
    typereplace(s, d, "real*4", "real*16");
#endif
    if(*s == '#') continue;
    if(!cont) param = justif = 0;
    last = current;
    for(pp = ops; pp < upper(ops); pp += 2)
      while(p = strstr(s, *pp)) {
        strcpy(memccpy(d + (int)(p - s), *(pp + 1), 0, 10) - 1,
          d + (int)(p - s + 4));
        strcpy(memccpy(p, *(pp + 1), 0, 10) - 1, p + 4);
      }
    for(pp = units; pp < upper(units); ++pp)
      if(strncmp(s, *pp, strlen(*pp)) == 0) {
copyfname:
#ifdef QPRECISION
        if(fnp == funcname) usemodule = 1;
#endif
        for(d2 = *fnp, p = d; *p && *p != '('; ) *d2++ = *p++;
        *d2++ = 0;
        *++fnp = d2;
        gp = gotos;
        dp = dos;
        dgp = donum;
        xrp = xref;
        goto lineok;
      }
    for(pp = types; pp < upper(types); ++pp)
      if(strncmp(s, *pp, i = strlen(*pp)) == 0) {
        p = d + (i += strspn(d + i, "*0123456789() \t"));
        if(strncmp(s + i, "function", 8) == 0) {
          memcpy(functype, d, i);
          strcpy(functype + i, ":: ");
          strcpy(d, p);
          defertype = 1;
          goto copyfname;
        }
        strcpy(s2, p);
        strcpy(p, ":: ");
        strcpy(p + 3, s2);
        break;
      }
    if(strcmp(s, "end") == 0 || strncmp(s, "end function", 12) == 0 ||
      strncmp(s, "end subroutine", 14) == 0) {
      if(fnp == funcname) {
        *d = 0;
        fprintf(stderr,
          "warning: superfluous END statement in line %d\n", lnr);
      }
      else {
        for(xxp = xref; xxp < xrp; ++xxp) {
          i = (*xxp)->label;
          for(ip = gotos; ip < gp; ++ip)
            if(*ip == i) goto keep;
          for(cp = dos, ip = donum; cp < dp; ++cp, ++ip)
            if(*ip == i) {
              strcpy(*cp, *cp + strspn(*cp, "0123456789 \t"));
              new = malloc(sizeof(SOURCELINE));
              new->next = (*xxp)->next;
              new->indent = (*xxp)->indent;
              (*xxp)->label = new->label = 0;
              strcpy(new->s, "enddo");
              (*xxp)->next = new;
            }
keep: ;
        }
        *(d + 3) = ' ';
        strcpy(d + 4, *--fnp);
        strcat(d + 4, "\n");
      }
      current->indent = indent = 0;
      gp = gotos;
      dgp = donum;
      dp = dos;
      xrp = xref;
    }
    else if(justif || (strncmp(s, "if", 2) == 0 && !isalnum(s[2]))) {
      if(strstr(s, "then")) justif = 0, indent += 2;
      else justif = 1;
    }
    else if(strncmp(s, "else", 4) == 0)
      current->indent -= 2;
    else if(strcmp(s, "endif") == 0 || strcmp(s, "end if") == 0)
      indent -= 2, current->indent -= 2;
    else if(strncmp(s, "do ", 3) == 0) {
      if(i = strtol(d + 3, &p, 10)) *dgp++ = i, *dp++ = d + 3;
    }
    if((p = strstr(s, "goto")) || (p = strstr(s, "go to")))
      if(i = strtol(p + 5, &d2, 10)) *gp++ = i;
#ifdef QPRECISION
    if(strncmp(s, "parameter", 9) == 0) param = 1;
    if(param) {
      p = d;
      while(p = strchr(p, '='))
        if(*(p += 1 + strspn(p + 1, " \t")) == '(') {
          strcpy(s2, p);
          strcpy(p, "complex32");
          strcpy(p += 9, s2);
        }
      p = s;
      i = 0;
      while(p = strstr(p, "dcmplx")) {
        strcpy(s2, d2 = d + (int)((p += 6) - s + i));
        strcpy(d2 - 6, "complex32");
        strcpy(d2 + 3, s2);
        i += 3;
      }
    }
			/* statement functions _are_ a problem if they
			   contain type(complex32) functions :-(,
			   therefore:  */
    else if(!cont && (strncmp(s, "absc(", 5) == 0 ||
      strncmp(s, "absr(", 5) == 0 || strncmp(s, "norm(", 5) == 0)) {
      while(p = strstr(s + 5, "dble(")) {
        strcpy(p, p + 3);
        p = d + (int)(p - s);
        memcpy(p, p + 5, i = strcspn(p + 5, ")"));
        strcpy(p += i, "%re");
        strcpy(p + 3,p + 6);
      }
      while(p = strstr(s + 5, "dimag(")) {
        strcpy(p, p + 4);
        p = d + (int)(p - s);
        memcpy(p, p + 6, i = strcspn(p + 6, ")"));
        strcpy(p += i, "%im");
        strcpy(p + 3, p + 7);
      }
    }
#endif
lineok: ;
  }
  fclose(f);
  current->next = NULL;

  if(argc > 2) {
    if(strcmp(p = argv[2], "-") == 0) f = stdout;
  }
  else {
    if(f == stdin) f = stdout;
    else {
      strcpy(s, argv[1]);
      f90name(p = s);
    }
  }
  if(f != stdout && (f = fopen(p,"w")) == NULL) {
    fprintf(stderr, "cannot create %s\n", p);
    exit(2);
  }

  indent = 0;
  for(new = start; new; new = new->next) {
    if(*new->s == '#' || *new->s == '!') {
      fprintf(f, "%s\n", new->s);
      continue;
    }
    if(strcasecmp(new->s, "enddo") == 0 ||
       strcasecmp(new->s, "end do") == 0) indent -= 2;
    new->indent += indent;
    if(new->label) {
      for(i = new->label; i; i /= 10) --new->indent;
      if(--new->indent <= 0) *s = 0;
      else {
        memset(s, ' ', new->indent);
        *(s + new->indent) = 0;
      }
      fprintf(f, "%d %s%s\n", new->label, s, new->s);
    }
    else if(strcasecmp(new->s, "continue")) {
      if(new->indent <= 0) *s = 0;
      else {
        memset(s, ' ', new->indent);
        *(s + new->indent) = 0;
      }
      fprintf(f, "%s%s\n", s, new->s);
    }
    if(strncasecmp(new->s, "do ", 3) == 0 && !isdigit(new->s[3]))
      indent += 2;
  }
  fclose(f);
}
