/* @(#)linetype.c	17.1.1.1 (ES0-DMD) 01/25/02 17:57:00 */
/*===========================================================================
  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
===========================================================================*/

/*+++++++++  Remove ESO extensions to FORTRAN 77    ++++++++++++++++++++
.COPYRIGHT   (c) 1992 European Southern Observatory
.LANGUAGE    C
.IDENT       linetype.c
.AUTHOR      Preben J. Grosbol [ESO/IPG]
.KEYWORDS    fortran, statement type
.ENVIRONMENT UNIX
.VERSION     1.0  1987-Nov-12: Creation,     PJG
.VERSION     1.1  1988-Feb-01: insert typed functions + correct IF,  PJG
.VERSION     1.2  1988-Mar-23: Redefine 'c' as int,  PJG
.VERSION     1.3  1988-Mar-24: Initiate 'action and check END,  PJG
.VERSION     1.4  1988-Sep-08: Standard error lists,  PJG
.VERSION     1.5  1990-Mar-02: Add SAVE statement to list,  PJG
.VERSION     1.6  1991-May-15: Correct for CHAR*n FUNCTION, PJG
.VERSION     1.7  1992-Aug-07: Print warning for SECTION error, PJG
------------------------------------------------------------------------*/
#include   <stdio.h>                        /* standard I/O functions   */
#include   <ctype.h>                        /* character types          */
#include   <string.h>                       /* string functions         */
#include   <f77ext.h>                       /* definition of constants  */
#include   <f77stat.h>                      /* FORTRAN statement types  */

extern    int                 section;      /* program section          */
extern    int                  x_flag;      /* extension option flag    */
extern    int                   equal;      /* level zero equal sign    */
extern    int                   comma;      /* level zero comma         */
extern    int                     lno;      /* current line number      */
extern    int                  no_lid;      /* no. of line identifiers  */
extern    char                 stmt[];      /* present statement        */
extern    char   lbuf[MXLBUF][MXLINE];      /* buffer for input lines   */
extern    LID                   lid[];      /* list of line identifiers */

static    FSTAT   sc_name[] = {             /* f77 section names        */
                  { PROG_SEC,         "PROGRAM"},
                  { IMPL_SEC,         "IMPLICIT"},
                  { DECL_SEC,         "DECLARATION"},
                  { DATA_SEC,         "DATA"},
                  { EXEC_SEC,         "EXECUTABLE"},
                  { END_SEC,          "END"},
                  { 0,                (char *) 0}};

static    FSTAT   fs_none[] = {             /* f77 stat. without , or = */
                  { IF,               "IF"},
                  { ELSEIF,           "ELSEIF"},
                  { ELSE,             "ELSE"},
                  { CALL,             "CALL"},
                  { CONTINUE,         "CONTINUE"},
                  { GOTO,             "GOTO"},
                  { CLOSE,            "CLOSE"},
                  { ENDIF,            "ENDIF"},
                  { ENDDO,            "ENDDO"},
                  { END,              "END"},
                  { WRITE,            "WRITE"},
                  { RFUNCTION,        "REALFUNCTION"},
                  { IFUNCTION,        "INTEGERFUNCTION"},
                  { DFUNCTION,        "DOUBLEPRECISIONFUNCTION"},
                  { CFUNCTION,        "CHARACTERFUNCTION"},
                  { LFUNCTION,        "LOGICALFUNCTION"},
                  { REAL,             "REAL"},
                  { INTEGER,          "INTEGER"},
                  { DOUBLEPRECISION,  "DOUBLEPRECISION"},
                  { CHARACTER,        "CHARACTER"},
                  { LOGICAL,          "LOGICAL"},
                  { RETURN,           "RETURN"},
                  { ASSIGN,           "ASSIGN"},
                  { OPEN,             "OPEN"},
                  { PARAMETER,        "PARAMETER"},
                  { INCLUDE,          "INCLUDE"},
                  { STOP,             "STOP"},
                  { SUBROUTINE,       "SUBROUTINE"},
                  { FORMAT,           "FORMAT"},
                  { FUNCTION,         "FUNCTION"},
                  { READ,             "READ"},
                  { COMMON,           "COMMON"},
                  { COMPLEX,          "COMPLEX"},
                  { DATA,             "DATA"},
                  { DIMENSION,        "DIMENSION"},
                  { EQUIVALENCE,      "EQUIVALENCE"},
                  { IMPLICITNONE,     "IMPLICITNONE"},
                  { IMPLICIT,         "IMPLICIT"},
                  { PROGRAM,          "PROGRAM"},
                  { EXTERNAL,         "EXTERNAL"},
                  { INTRINSIC,        "INTRINSIC"},
                  { REWIND,           "REWIND"},
                  { SAVE,             "SAVE"},
                  { BACKSPACE,        "BACKSPACE"},
                  { BLOCKDATA,        "BLOCKDATA"},
                  { ENDFILE,          "ENDFILE"},
                  { ENTRY,            "ENTRY"},
                  { INQUIRE,          "INQUIRE"},
                  { PAUSE,            "PAUSE"},
                  { 0,                (char *) 0}};

static    FSTAT   fs_c[] = {                /* f77 stat. with , only    */
                  { IF,               "IF"},
                  { WRITE,            "WRITE"},
                  { REAL,             "REAL"},
                  { INTEGER,          "INTEGER"},
                  { DOUBLEPRECISION,  "DOUBLEPRECISION"},
                  { CHARACTER,        "CHARACTER"},
                  { LOGICAL,          "LOGICAL"},
                  { COMMON,           "COMMON"},
                  { COMPLEX,          "COMPLEX"},
                  { DATA,             "DATA"},
                  { DIMENSION,        "DIMENSION"},
                  { EQUIVALENCE,      "EQUIVALENCE"},
                  { EXTERNAL,         "EXTERNAL"},
                  { IMPLICIT,         "IMPLICIT"},
                  { INTRINSIC,        "INTRINSIC"},
                  { READ,             "READ"},
                  { SUBROUTINE,       "SUBROUTINE"},
                  { FUNCTION,         "FUNCTION"},
                  { RFUNCTION,        "REALFUNCTION"},
                  { IFUNCTION,        "INTEGERFUNCTION"},
                  { DFUNCTION,        "DOUBLEPRECISIONFUNCTION"},
                  { CFUNCTION,        "CHARACTERFUNCTION"},
                  { LFUNCTION,        "LOGICALFUNCTION"},
                  { SAVE,             "SAVE"},
                  { 0,                (char *) 0}};

static    FSTAT   fs_e[] = {                /* f77 stat. with = only    */
                  { IF,               "IF"},
                  { 0,                (char *) 0}};

static    FSTAT   fs_ce[] = {               /* f77 stat. with , and =   */
                  { DO,               "DO"},
                  { 0,                (char *) 0}};

static    FSTAT   fs_if[] = {               /* f77 stat. in IF stat.    */
                  { READ,             "READ"},
                  { IF,               "IF"},
                  { CALL,             "CALL"},
                  { CONTINUE,         "CONTINUE"},
                  { GOTO,             "GOTO"},
                  { CLOSE,            "CLOSE"},
                  { RETURN,           "RETURN"},
                  { ASSIGN,           "ASSIGN"},
                  { OPEN,             "OPEN"},
                  { STOP,             "STOP"},
                  { READ,             "READ"},
                  { WRITE,            "WRITE"},
                  { REWIND,           "REWIND"},
                  { BACKSPACE,        "BACKSPACE"},
                  { ENDFILE,          "ENDFILE"},
                  { INQUIRE,          "INQUIRE"},
                  { PAUSE,            "PAUSE"},
                  { 0,                (char *) 0}};

int line_type(ptype)                         /* find statement type      */
int      *ptype;
{
  int    no, action, n, err, f77_sect();
  char   *pc, type, group, *find_f77();
  ID     *pid, *add_id();
  LID    *plid;

  action = NO_ACTION;                        /* initiate action to none  */

  if (!comma && !equal) pc = find_f77(fs_none,stmt,&no,ptype);
  if (comma && !equal) pc = find_f77(fs_c,stmt,&no,ptype);
  if (!comma && equal) pc = find_f77(fs_e,stmt,&no,ptype);
  if (comma && equal) pc = find_f77(fs_ce,stmt,&no,ptype);

  section = f77_sect(ptype,section,&err);    /* update and check section */

  if (err) {
     for (n=0; section!=sc_name[n].type && sc_name[n].id; n++);
     fprintf(stderr,"Warning: line %d: ",lno);
     fprintf(stderr,"Statement >%-16.16s< in wrong section (%s)\n",
	     stmt,sc_name[n].id);
  }

  plid = lid; n = 0;
  if (*ptype != EXEC_STAT) {                /* modify identifier        */
    plid->sid = pc; plid->size -= no;
    if (*ptype == CFUNCTION && *pc == '*') {
      plid++;
      plid->sid += 8; plid->size -= 8;
    }
  }

  if (*ptype == IF || *ptype == ELSEIF) {    /* check conditioned stat. */
    plid++; n++;
    while (plid->level && n<no_lid) { plid++; n++; }
    if (n<no_lid) {                          /* if more ident. on line  */
       if (!strncmp(plid->sid,"THEN",4)) plid->size = 0;
        else {
          pc = find_f77(fs_if,plid->sid,&no,ptype);
          if (*ptype != EXEC_STAT) {
             plid->sid = pc; plid->size -=no;
          }
       }
    }
    chk_exp(lid);
  }

  plid = lid;
  switch (*ptype) {                        /* special things            */
    case EXEC_STAT    : chk_exp(lid); break;
    case FORMAT       : if (!equal) { no_lid = 0; return NO_ACTION; } 
                        break;
    case ENDDO        : no_lid = 0; return DO_ACTION;
    case DO           : if (isdigit((int)*pc)) { /* f77 DO statement    */
                          no = 1;
                          while (isdigit((int)*(++pc))) no++;
                          if (isalpha((int)*pc)) {
                            plid->sid = pc; plid->size -= no; }
                          else plid->size = 0;
                          action = NO_ACTION;
                        }
                        else action = DO_ACTION;
                        break;
    case GOTO         : if (isdigit((int)*plid->sid)) {
			  plid->size = 0; action = NO_ACTION;
                        }
                        break;
    case IMPLICIT     : no_lid = 0; return NO_ACTION;
    case IMPLICITNONE : no_lid = 0; return RM_ACTION;
    case INCLUDE      : no_lid = 0; return IN_ACTION;
    case STOP         : no_lid = 0; return NO_ACTION;
    case END          : no_lid = 0; return NO_ACTION;
    case PAUSE        : no_lid = 0; return NO_ACTION;
    case ASSIGN       : no = 0; pc = plid->sid;
                        while (isdigit((int)*(plid->sid++))) no++;
                        plid->sid += 2; plid->size -= no + 2;
                        break;
    case READ         :
    case WRITE        :
    case PRINT        :
    case OPEN         :
    case CLOSE        :
    case ENDFILE      :
    case REWIND       :
    case BACKSPACE    :
    case INQUIRE      : chk_io(lid); break;
  }

  type = '?'; group = 'V';
  if (*ptype == CALL) { type = 'X'; group = 'S'; }
  if (*ptype & PROG_STAT)                   /* check program block      */
    switch (*ptype) {
	   case SUBROUTINE : group = 'S'; break;
	   case FUNCTION   : group = 'F'; break;
	   case IFUNCTION  : type = 'I'; group = 'F'; break;
	   case RFUNCTION  : type = 'R'; group = 'F'; break;
	   case DFUNCTION  : type = 'D'; group = 'F'; break;
	   case LFUNCTION  : type = 'L'; group = 'F'; break;
	   case CFUNCTION  : type = 'C'; group = 'F'; break;
	   case PROGRAM    : group = 'P'; break;
	   case BLOCKDATA  : group = 'D'; break;
    }

  if (*ptype & DECL_STAT)                   /* check type decleration   */
    switch (*ptype) {
      case REAL            : type = 'R'; break;
      case INTEGER         : type = 'I'; break;
      case DOUBLEPRECISION : type = 'D'; break;
      case CHARACTER       : type = 'S'; break;
      case LOGICAL         : type = 'L'; break;
      case EXTERNAL        : group = 'F'; break;
      case INTRINSIC       : group = 'F'; break;
      case PARAMETER       : type = 'P'; group = 'P'; break;
      case COMMON          : group = 'C'; break;
    }

  plid = lid;
  for (n=0; n<no_lid; n++, plid++) {        /* go through identifiers   */
    if (!plid->size) continue;
    pid = add_id(plid->sid,plid->size,type,group,&err);
    if (err) {
       fprintf(stderr,"Error: line %5d: ",lno);
       fprintf(stderr,"Identifier >%-20.20s<, error %d\n",plid->sid,err);
       plid->size = 0;
    }
    plid->id = pid;
    if (x_flag & LN_FLAG)
      new_id(pid->lname,plid->size,pid->sname);
     else *(pid->sname) = '\0';
  }

  return action;
}