/* @(#)esoext.c	13.1.1.1 (ES0-DMD) 06/02/98 18:50:22 */
/*===========================================================================
  Copyright (C) 1995 European Southern Observatory (ESO)
 
  This program is free software; you can redistribute it and/or 
  modify it under the terms of the GNU General Public License as 
  published by the Free Software Foundation; either version 2 of 
  the License, or (at your option) any later version.
 
  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.
 
  You should have received a copy of the GNU General Public 
  License along with this program; if not, write to the Free 
  Software Foundation, Inc., 675 Massachusetss Ave, Cambridge, 
  MA 02139, USA.
 
  Corresponding concerning ESO-MIDAS should be addressed as follows:
	Internet e-mail: midas@eso.org
	Postal address: European Southern Observatory
			Data Management Division 
			Karl-Schwarzschild-Strasse 2
			D 85748 Garching bei Muenchen 
			GERMANY
===========================================================================*/

/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.COPYRIGHT   (c) 1994 European Southern Observatory
.LANGUAGE    C
.IDENT       esoext.c
.AUTHOR      Preben J. Grosbol [ESO/IPG]
.PURPOSE     Remove ESO extensions to FORTRAN-77
.KEYWORDS    fortran extensions, ESO fortran
.ENVIRON     UNIX
.VERSION     1.0   1987-Nov-12: Creation,     PJG
.VERSION     1.1   1988-Jan-15: Correct include file, PJG
.VERSION     1.2   1988-Feb-15: Remove '\f', PJG
.VERSION     1.3   1988-Mar-10: Remove file name print, PJG
.VERSION     1.4   1988-Mar-23: Redefine 'c' as int, PJG
.VERSION     1.5   1988-Apr-22: Insert exit in end, PJG
.VERSION     1.6   1988-Sep-08: Change default prints, PJG
.VERSION     1.7   1988-Dec-06: Include '*' comments, PJG
.VERSION     1.8   1990-Dec-05: Multi-file in include search path, PJG
.VERSION     1.9   1991-Apr-17: Correct dim. of hstat[], PJG
.VERSION     2.0   1992-Jun-24: Add 'UPPER-Case' flag to default, PJG
.VERSION     2.1   1992-Aug-07: Upgrade error messages, PJG
.VERSION     2.2   1992-Aug-21: Check for label on continue card, PJG
.VERSION     2.3   1994-Apr-27: Error on amb.ID + warning on 73++ char, PJG
.VERSION     2.4   1999-Apr-20: add flag -Z  for 64 bit architecture,  KB
------------------------------------------------------------------------*/
#include   <stdio.h>                        /* standard I/O functions   */
#include   <ctype.h>                        /* C type definitions       */
#include   <f77ext.h>                       /* definition of constants  */
#include   <f77stat.h>                      /* FORTRAN statement types  */

int                    section;             /* program section          */
int                      equal;             /* level zero equal sign    */
int                      comma;             /* level zero comma         */
int                        lno;             /* current line number      */
int                        sno;             /* no. of statement labels  */
int                        nlb;             /* present index in 'lbuf'  */
int                      nstat;             /* char. index in 'stat'    */
int                      bit64;             /* flag for 64bit CPU (=1)  */
int                     x_flag;             /* extension flags          */
int                     f_flag;             /* file name flag           */
int                      no_id;             /* no. of identifiers       */
int                     no_lid;             /* no. of line identifiers  */
int                    id_size;             /* length of identifier     */
int                   do_level;             /* DO stack pointer         */
int                   do_label;             /* DO label                 */
ID                 idtbl[MXID];             /* list of identifiers      */
LID                 lid[MXLID];             /* list of line identifiers */
int              statno[MXSNO];             /* statement numbers        */
char              stmt[MXSTAT];             /* present statement        */
char      lbuf[MXLBUF][MXLINE];             /* buffer for input lines   */
char                  u_text[] =            /* usage text               */
         "usage: esoext [-csdnilxuv] [-f file] [-t table] [-I path]\n";

main(argc, argv)
int        argc;
char    *argv[];
{
  int     c, ns, n, i, stype, action, nip, line_type();
  int     hstat[MXFSTAT], put_line(), labno,chk_id();
  char    *f_name, *o_name, *table, *new_ext();
  char    *incl_path[MXINCP], *incl_name, *incl_file();
  char    *p,cont, *plab, label[6], get_line();
  char    *push_lab(), *pop_lab(), *new_file();
  FILE    *fp, *ofp, *push_fp(), *pop_fp();

  no_id = 0; nip = 0; bit64 = 0;
  idtbl[0].lname[0] = '\0';
  for (n=0; n<MXFSTAT; n++) hstat[n] = 0;
  for (n=0; n<MXINCP; n++) incl_path[n] = (char *) 0;

  f_flag = 0; x_flag = 0; fp = (FILE *) 0;
  f_name = (char *) 0; table = (char *) 0;

  argv++;
  if (--argc != 0)                         /* decode parameters         */
    while (argc--) {
       p = *argv++;
       if (*p++ == '-')
         switch (*p) {
                case 'Z' : bit64 = 1; break;	  /* it's a 64bit CPU  */
                case 'c' :                        /* remove comments   */
                case 's' :                        /* remove spaces     */
                case 'd' :                        /* ENDDO extension   */
                case 'n' :                        /* IMPLICIT NONE     */
                case 'i' :                        /* INCLUDE extension */
                case 'l' :                        /* long names        */
                case 'x' :                        /* exclamation mark  */
                case 'u' :                        /* UPPER case        */
                case 'L' :                        /* include to LOWER  */
                case 'v' :                        /* verbose option    */
                           while (*p)
                             switch (*p++) {
                                  case 'c' : x_flag |= COM_FLAG; break;
                                  case 's' : x_flag |= SPC_FLAG; break;
                                  case 'd' : x_flag |= DO_FLAG; break;
                                  case 'n' : x_flag |= IMP_FLAG; break;
                                  case 'i' : x_flag |= INC_FLAG; break;
                                  case 'l' : x_flag |= LN_FLAG; break;
                                  case 'x' : x_flag |= EXC_FLAG; break;
                                  case 'u' : x_flag |= UPC_FLAG; break;
                                  case 'L' : x_flag |= LCI_FLAG; break;
                                  case 'v' : x_flag |= VER_FLAG; break;
                                  default  :
                                             printf("%s",u_text);
                                             exit(1);
                             }
                           break;
                case 'f' :                /* name of file to convert */
                           if (!(*(++p))) {
			     if (!argc--) { printf("%s",u_text); exit(1); }
			     p = *argv++;
			   }
			   f_name = p; f_flag = 1;
                           break;
                case 't' :                /* table of long names     */
                           if (!(*(++p))) {
			     if (!argc--) { printf("%s",u_text); exit(1); }
			     p = *argv++;
			   }
			   table = p;
                           break;
                case 'I' :                /* path name of includes   */
                           if (!(*(++p))) {
			     if (!argc--) { printf("%s",u_text); exit(1); }
			     p = *argv++;
			   }
			   if (MXINCP<nip+2) {
			     fprintf(stderr,"Error: max. include directories\
 reached - %d\n",nip);
			     exit(1);
			   }
			   incl_path[nip++] = p;
                           break;
                default  :
                           printf("%s",u_text);
                           exit(1);
         }
    }
  if (!x_flag || x_flag==VER_FLAG)               /* define default flags  */
    x_flag = IMP_FLAG | DO_FLAG | LN_FLAG | EXC_FLAG | UPC_FLAG |
             INC_FLAG | LCI_FLAG | COM_FLAG | x_flag;

  if (x_flag & VER_FLAG) printf("Option flag: %x\n",x_flag);

  if (table) fopen(table,"r");
  if (!f_flag) f_name = new_file();

  do {                                    /* loop through one file       */
    if (!fp) fp = fopen(f_name,"r");      /* open input file to process  */
    if (!fp) { 
      fprintf(stderr,"Error: Opening input file >%s<\n",f_name);
      exit(1);
    }
    o_name = new_ext(f_name,"f");
    ofp = fopen(o_name,"w");
    if (!ofp) { 
      fprintf(stderr,"Error: Opening output file >%s<\n",o_name);
      exit(1);
    }
    if (x_flag & VER_FLAG)
        printf("File name >%s<, Output >%s<\n",f_name,o_name);

    nstat = 0; nlb = 0; c = ' ';
    equal = 0; comma = 0; section = PROG_SEC;
    lno = 0; labno = 0; plab = (char *) 0;
    no_id = 0; no_lid = 0; id_size = 0;
    sno = 0; do_level = 0; do_label = DO_LABEL;

    while (1) {                           /* loop through each line      */
      if (c==EOF) {
         cont = '\0';                     /* no cont. line across files  */
         if (!(fp=pop_fp(fp))) break;     /* if no include file          */
         plab = pop_lab();                /* get old label if include    */
      }
      lno++;
                                          /* check for comment or '\f'   */
      if (!plab && ((c=getc(fp))=='C' || c=='*' ||
           c=='c' || c=='\f')) {
        if (x_flag & COM_FLAG)
          while ((c=getc(fp)) != '\n' && c != EOF);
        else {
          putc('C',ofp);
	  n = 0;
          while ((c=getc(fp)) != '\n' && c != EOF)
	    if (++n < MXLINE) putc(c,ofp);
          if (c == '\n') putc('\n',ofp);
        }
        continue;
      }

      if (section == PROG_SEC) {
        for (n=0; n<sno; n++) {          /* check duplicate labels      */
          if (0<statno[n]) continue;
          ns = -statno[n];
          for (i=0; i<sno; i++)
	    if (ns==statno[i]) {
	       fprintf(stderr,"Error: line %d: Duplicate label %5d\n",lno,ns);
	       exit(1);
	     }
        }
        if (x_flag & VER_FLAG)
          for (n=0; n<sno; n++) printf("Label : %5d\n",statno[n]);
	sno = 0; do_level = 0; do_label = DO_LABEL;
      }
      if (!plab) {                   /* find new label if none on stack */
         if (c=='\t') {                /* check VAX tab extension       */
           fprintf(stderr,"Warning: line %d: TAB detected\n",lno);
           c = getc(fp);
           if (isalpha(c)) { ungetc(c,fp); c = ' '; }
         }
         else {                        /* check for statement label     */
           for (n=0; n<5 && c!='\t' && c!='\n' && c!=EOF; c = getc(fp)) { 
             if (!plab && c!=' ') plab = label;
             label[n++] = c;
           }
           label[n] = '\0';
           if (c=='\t') c = ' ';
         }
         if (c == '\n' || c == EOF) continue;
         cont = (c != ' ') ? c : '\0';   /* check if continuation line  */
	 if (cont && plab) {
	    fprintf(stderr,"Error: line %d: label on continue card\n",lno);
	    exit(1);
	  }
      }

      if (cont) {                      /* add continuation line         */
        nlb++;
        c = get_line(fp);
      }
      else {                           /* analyze statement             */
        if (nstat) {
          stmt[nstat] = '\0';
          action = line_type(&stype);
          if (stype == INCLUDE && (x_flag & INC_FLAG)) {
            incl_name = incl_file(stmt);
            if (x_flag & VER_FLAG)
	      printf("Include file name >%s<\n",incl_name);
	    fp = push_fp(fp,incl_path,incl_name);
            plab = push_lab(plab);
            hstat[stype & 0xFF] += 1;
            nstat = 0; nlb = 0; equal = 0; comma = 0; no_lid = 0;
            labno = 0;
            continue;
          }
          else {
            put_line(ofp,action,stype,labno);
            hstat[stype & 0xFF] += 1;
            nstat = 0; nlb = 0; equal = 0; comma = 0; no_lid = 0;
            labno = 0;
          }
        }
        if (plab) {                    /* read statement no. if present */
          if (MXSNO<=sno) { 
            fprintf(stderr,"Error: line %d: Max. no. of label reached %d\n",
		    lno,sno);
              exit(1);
          }
	  if (*plab) {                 /* there is a statement label   */
             labno = atoi(plab);
             if (labno) statno[sno++] = labno;
          }
           else labno = 0;
          plab = (char *) 0;
        }
      c = get_line(fp);
      }
    }
    if (nstat) {
      stmt[nstat] = '\0';
      action = line_type(&stype);
      put_line(ofp,action,stype,labno);
      hstat[stype & 0xFF] += 1;
      nstat = 0; nlb = 0; equal = 0; comma = 0; no_lid = 0;
    }

    if (chk_id()) exit(1);             /* check duplicate idntifiers  */
    for (n=0; n<sno; n++) {            /* check duplicate labels      */
	if (0<statno[n]) continue;
        ns = -statno[n];
        for (i=0; i<sno; i++)
        if (ns==statno[i]) {
           fprintf(stderr,"Error: Duplicate label %5d\n",ns);
	   exit(1);
	 }
    }
    if (x_flag & VER_FLAG) {
      for (n=0; n<sno; n++) printf("Label : %5d\n",statno[n]);
      printf("Source file had %d lines, %d identifiers.\n",
             lno,no_id);
      for (n=0; n<MXFSTAT; n++) 
        if (hstat[n]) printf("Statement #%2x: %4d\n",n,hstat[n]);
      for (n=0; n<no_id; n++) printf("ID >%s< %2d %c %c >%s<\n",
        idtbl[n].lname,idtbl[n].size,idtbl[n].type,
        idtbl[n].group,idtbl[n].sname);
    }

    f_name = (f_flag) ? (char *) 0 : new_file();
  } while (f_name);                                     /* next file  */
  exit(0);
}