/* @(#)prepi.c	17.1.1.1 (ESO-DMD) 01/25/02 17:37:41 */
/*===========================================================================
  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 Massachusetts Ave, Cambridge, 
  MA 02139, USA.
 
  Correspondence 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
===========================================================================*/

/*+++++++++++++++++++  MIDAS monitor routines PREPI  +++++++++++++++++++++++++
.LANGUAGE    C
.IDENTIFICATION  Module PREPI
.AUTHOR  K. Banse                  ESO - Garching
.ENVIRONMENT VMS and UNIX
.KEYWORDS
  MIDAS monitor
.COMMENTS
holds KEYCOMP, TOKBLD, COMPU, KEY_PARSE, PARSE_ELEM, DSCR_PARSE
      ascfiles

.VERSION  [1.00] 870908: built from FORTRAN version 3.10 of 860220

 010608		last modif

-------------------------------------------------------------------------*/

#include <fileexts.h>
#include <osyparms.h>
#include <monitdef.h>
#include <midback.h>

#include <stdlib.h>
#include <math.h>


#define   MAXATOM  16
#define   MAXAT2   32
#define   MAXASCID 10

#define   EPSILON   10.e-36

static char  tokn2[2*MAX_TOKEN], tokop, tokn4[2*MAX_TOKEN];
static int   ltokn2, ltokn4;


/*

*/

int KEYCOMP(optio,nt,rettype)
 
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  handle  "res_key = expression (with possible blanks)"
.ALGORITHM
  cumbersome, but straight forward (same way as COMPUTE/IMAGE)
.RETURNS
  status, if not 0 - something wrong
----------------------------------------------------------------------*/

int  optio;	/* IN: = 1, expression only in TOKEN[nt],
		       = 0, expression from TOKEN[nt] on till end */
int  nt;	/* IN: index of first token in expression  */
char *rettype;	/* OUT: type of result keyword (only used for optio=1),
		        = 'I', 'R', 'D', 'C' or ' ' if it failed */

{ 
int   ii, bytelem, elem, first, iav, nulo;
int   cclen, iopnd, p1, p2, p3, pp;
int   n, j, m, stat, k, last, nbra, nval, opnd_count;
int   latom[MAXATOM], atom_indx[MAXAT2];
int   unit, sfirst;
register int  nr, mr;
static int  work_size = 0;
	
char	*line, *work1, *work2, *tpr;
char	operation[5], *cc, *cc_work, reskey[18];
char	k_type[12], restype[20], cchar;
register char  cr;
static char  *work_str, *atom[MAXATOM];
	
float	rr;

double	dd;


	
	
/* equivalence the pointers to work_space  */

if (work_size == 0)
   {
   work_size = 1700;
   work_str = malloc((unsigned int)work_size);

   atom[0] = (char *) &CODE.WORK[150];	/* use workbuffer [1200 - 3632] */
   for (nr=1; nr<MAXATOM; nr++)
      atom[nr] = atom[nr-1] + MAX_TOKEN + 2;
   }

line = work_str;			/* = 300 bytes */
work1 = line + 300;                     /* = 300 bytes */
work2 = line + 600;                     /* = 300 bytes */
cc = line + 900;                        /* = 400 bytes */
cc_work = line + 1300;                  /* = 400 bytes */
	

/*   build expression from tokens without separating blanks */

if (optio == 0)
   {
   if (MONIT.COUNT == 10)		/* TOKEN[9].STR may contain blanks! */
      {
      (void) strcpy(work1,TOKEN[9].STR);
      mr = 0;
      for (nr=0; nr<=TOKEN[9].LEN; nr++)      /* so also the '\0' is copied */
         {
         cr = *work1++;
         if (cr != ' ')
            TOKEN[9].STR[mr++] = cr;
         }
      }

   if (TOKBLD(nt,line,299,0,MONIT.COUNT) < 0) 
      {
      ERRORS.INDEX = nt;
      return (14);				/*  something wrong ...    */
      }

   KEY_PARSE(TOKEN[nt-2].STR,reskey,restype,&bytelem,&elem,&first,&last);
   if (restype[0] == ' ')
      {
      ERRORS.INDEX = nt - 2;
      return (51);                      /* result key must exist */
      }
   }
else
   {
   (void) strcpy(line,TOKEN[nt].STR);
   restype[0] = ' ';
   }


sect_200:		/*  look for ()  */
j = CGN_INDEXS(line,"()");
if ((j > 0) && (line[0] != '"')) 			/* () -> (0)   */
   {
   j++;
   (void) strncpy(work1,line,j);
   *(work1+j) = '0';
   (void) strcpy(work1+j+1,line+j);
   (void) strcpy(line,work1);
   goto sect_200;				/* look for more...  */
   }
	
clean_line:
opnd_count = KEXP_CLEAN(line,work2,MAXATOM,atom,latom);


/* charkey(x)(a:b) is first replaced, then we continue as usual  
   only   charkey(x)(a:b)   or   charkey(x)(a:b)//"abc"
     or   "abc"//charkey(x)(a:b)     is currently supported     */

k = CGN_INDEXS(work2,"A(S)(S)");
if (k > -1)
   {
   int  saveflag = 0;
   char   savera[80], saverb[80];

   if (k == 0)				/* at begin */
      {
      nr = CGN_INDEXS(line,")//");
      if (nr > 0)
         {
         (void) strcpy(savera,&line[nr+1]);
         line[nr+1] = '\0';
         saveflag = 1;
         }
      }
   else
      {
      saverb[0] = '\0';
      k = CGN_INDEXS(line,")(");		/* look for abc(x)(y:z) */
      if (k < 1) return (14);
      for (nr=k; nr>0; nr--)			/* and the `//' before it */
         {
         if (line[nr] == '/')
            {
            if (line[nr-1] == '/')
               {
               nr = nr - 1;
               goto fill_savera;
               }
            }
         }
      return (14);
  
     fill_savera:
      (void) strncpy(savera,line,nr+2);
      savera[nr+2] = '\0';
      saveflag = -1;
      (void) strcpy(line,&line[nr+2]);
      nr = CGN_INDEXS(line,"//");
      if (nr > 0)
         {
         (void) strcpy(saverb,&line[nr]);
         line[nr] = '\0';
         }
      }

   stat = KEY_ACCESS(line,&ii,&rr,work1,&dd,k_type,300);
   if ((stat != 0) || (k_type[0] != 'C')) return(14);

   if (saveflag == -1)
      {
      (void) strcpy(line,savera);
      k = (int) strlen(line);
      line[k++] = '"';
      (void) strcpy(&line[k],work1);
      (void) strcat(line,"\"");
      if (saverb[0] != '\0')
         (void) strcat(line,saverb);
      }
   else
      {
      line[0] = '"';
      (void) strcpy(&line[1],work1);
      k = (int) strlen(line);
      line[k++] = '"';
      if (saveflag == 1)
         (void) strcpy(&line[k],savera);
      else
         line[k] = '\0';
      }
   goto clean_line;
   }

stat = KEXP_POLISH(work2,work1);	/*  transform to polish reverse form */

if ( (opnd_count <= 0) || (stat != 0) )
   {
   ERRORS.INDEX = nt;
   return (14);				/* really weird command string ... */
   }
 

/*  init pointers to operands  */

k = 0;
for (nr=0; nr<MAXAT2; nr++)
   {
   atom_indx[nr] = -1;
   cchar = *(work1 + nr);
   if ( ( cchar == 'S') || ( cchar == 'A') ||
        ( cchar == 'P') || ( cchar == 'Q') || ( cchar == 'R') )
      atom_indx[nr] = k++;
   else if (cchar == '\0')
      {
      for (j=nr+1; j<MAXAT2; j++)
         atom_indx[j] = -1;
      break;
      }
   }


/*  handle key = operand  */

k_type[0] = restype[0];
if (opnd_count == 1)
   {
   (void) strcpy(tokn2,atom[0]);
   ltokn2 = latom[0];
   cclen = 400;
   stat = COMPU(1,k_type,&ii,&rr,cc,&cclen,&dd);
   if (stat != 0)
      {
      ERRORS.INDEX = nt;
      if (stat == -12)
         return (60);                         /* something wrong again */
      else
         return (14);                         /* something wrong again */
      }
   else
      goto sect_2000;
   }


/*  here the main loop, where we extract the basic operations  */

main_loop:
pp = KEXP_REDUCE(work1,work2,operation);
	

/*  now we have the operands to work on  */

p1 = atom_indx[pp];
p2 = atom_indx[pp+1];
if ( (p1 < 0) || (p2 < 0) || (operation[1] != 'S') )
   {
   ERRORS.INDEX = nt;
   return (14);                         /* something wrong again */
   }


(void) strcpy(tokn2,atom[p1]);
if (operation[0] == 'S')
   {
   ltokn2 = latom[p1];
   tokop = operation[2];
   (void) strcpy(tokn4,atom[p2]);
   ltokn4 = latom[p2];
   iopnd = 2;
   }
else
   {
   iopnd = 1;
   tokop = '=';
   n = latom[p1];
   tokn2[n++] = '(';
   (void) strcpy(&tokn2[n],atom[p2]);
   n += latom[p2];

   if ( (operation[0] == 'A') || (operation[0] == 'P') )
      {
      tokn2[n++] = ')';		/* build complete function  */
      tokn2[n] = '\0';	
      ltokn2 = n;
      }
   else if (operation[0] == 'Q')
      {
      tokn2[n++] = ',';
      p3 = atom_indx[pp+2];
      (void) strcpy(&tokn2[n],atom[p3]);
      n += latom[p3];
      tokn2[n++] = ')';
      tokn2[n] = '\0';
      ltokn2 = n;
      }
   else if (operation[0] == 'R')
      {
      tokn2[n++] = ',';
      p3 = atom_indx[pp+2];
      (void) strcpy(&tokn2[n],atom[p3]);
      n += latom[p3];
      tokn2[n++] = ',';
      p3 = atom_indx[pp+3];
      (void) strcpy(&tokn2[n],atom[p3]);
      n += latom[p3];
      tokn2[n++] = ')';
      tokn2[n] = '\0';
      ltokn2 = n;
      }
   }

	
/*   now we have the input ready for COMPU  */

cclen = 400;					/* length for cc */
stat = COMPU(iopnd,k_type,&ii,&rr,cc,&cclen,&dd);
if (stat != 0) 
   {
   ERRORS.INDEX = nt;
   if (stat == -12)
      return (60);                         /* something wrong again */
   else
      return (14);                         /* something wrong again */
   }

	
/*  test for end  */

if ( *(work2 + 1) != '\0')
   {			/*  not finished yet, so replace atom with result  */
   if (k_type[0] == 'I')
      {
      (void) sprintf(atom[p1],"%-20d ",ii);
      latom[p1] = (int) strlen(atom[p1]);
      }

   else if (k_type[0] == 'C')  		
      {
      *atom[p1] = '"';			/* begin with " */
      (void) strcpy(atom[p1]+1,cc);		/* copy intermediate result  */
      m = (int) strlen(atom[p1]);		/* find end of string  */
      *(atom[p1]+m) = '"';		/* append closing " */
      *(atom[p1]+m+1) = '\0';		/* and add \0 */
      latom[p1] = m + 1;
      }

   else
      {					/* must be 'D' */
      (void) sprintf(atom[p1],"%-28.18g ",dd);
      latom[p1] = (int) strlen(atom[p1]);

      tpr = atom[p1];
      if (*tpr == '-') tpr++;
      for (nr=0; nr<latom[p1]; nr++)		/* ensure a real no. */
         {
         cr = *tpr++;
         if ((cr >= '0') && (cr <= '9'))
            continue;
         else if (cr == ' ')
            {
            *(--tpr) = '.';
            break;
            }
         else
            break;			/* that must be '.' or 'e', 'd', ... */
         }
      }


   /*  we have to shift the pointers as well  */

   if (operation[0] == 'R')
      nbra = 4;
   else if (operation[0] == 'Q')
      nbra = 3;
   else
      nbra = 2;

   for (nr=pp+1; nr<MAXAT2; nr++)
      {
      mr = nr + nbra;
      if (mr < MAXAT2) 			/* make sure we stay inside range */
         atom_indx[nr] = atom_indx[mr];
      else
         atom_indx[nr] = -1;
      }

   (void) strncpy(work1,work2,MAX_TOKEN);		/* switch buffers  */
   goto main_loop;
   }
	

/*  get type + element no. of result key  */

sect_2000:
if (optio != 0)
   {
   if (k_type[0] == 'I')		/* write to internal keywords */
      KAUX.IVAL = ii;
   else if (k_type[0] == 'D')
      KAUX.DVAL = dd;
   else return(99);			/* type 'C' not supported! */

   *rettype = k_type[0];
   return (0);				/* if we made it to here, return 0 */
   }


/*  now write into keyword  */

if (restype[0] == 'I')			/* integer result key  */
   {
   if (k_type[0] == 'D')
      ii = (int) dd;
   else if (k_type[0] == 'C')
      goto badtype;

   stat = SCKWRI(reskey,&ii,elem,1,&unit);
   }

else if (restype[0] == 'R')             /* real result key  */
   {
   if (k_type[0] == 'I')
      rr = (float) ii;
   else if (k_type[0] == 'C')
      goto badtype;
   else 
      rr = (float) dd;

   stat = SCKWRR(reskey,&rr,elem,1,&unit);
   }

else if (restype[0] == 'D')             /* double precision key  */
   {
   if (k_type[0] == 'I')
      dd = (double) ii;
   else if (k_type[0] == 'C')
      goto badtype;

   stat = SCKWRD(reskey,&dd,elem,1,&unit);
   }

else			/*  character keys are the hardest  */
   {
   if (k_type[0] != 'C') goto badtype;

   sfirst = first-1;
   if (last < 0) 
      nval = -last;		/* size of keyword or of 1 element */
   else
      nval = last;
   nval -= sfirst;

   if (bytelem > 1)
      k = bytelem;
   else
      k = nval;
   if (k > 400)			/* max 400 chars */
      {
      ERRORS.INDEX = nt;
      return (57);
      }

   if (bytelem > 1)
      {
      if ((nval+sfirst) > bytelem) nval = bytelem - sfirst;

      stat = SCKRDC(reskey,bytelem,elem,1,&iav,cc_work,&unit,&nulo);
      if (stat == ERR_NORMAL)
         {
         if (nval > cclen)
            {
            (void) strncpy(cc_work+sfirst,cc,cclen);
            CGN_FILL(cc_work+sfirst+cclen,' ',(nval-cclen));
            }
         else
            (void) strncpy(cc_work+sfirst,cc,nval);

         stat = SCKWRC(reskey,bytelem,cc_work,elem,1,&unit);  
         }
      }
   else
      {
      if (nval > cclen)
         {
         (void) strncpy(cc_work,cc,cclen);
         CGN_FILL(cc_work+cclen,' ',(nval-cclen));
         stat = SCKWRC(reskey,1,cc_work,first,nval,&unit);
         }
      else
         stat = SCKWRC(reskey,1,cc,first,nval,&unit);
      }
   }

if (stat == 0)
   return (0);			/* we've done it...  */
else
   {
   ERRORS.INDEX = nt - 2;
   if (stat == ERR_BADLCK)
      return (54);
   else
      return (14);			/* could not write into result key */
   }
 
badtype:
ERRORS.INDEX = nt - 2;
return (50);                         /* could not write into result key */
}
 
/*

*/

int TOKBLD(indx,buff,lbuff,skip,lindx)

/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  rebuild command string from single tokens
.ALGORITHM
  straight forward 
.RETURNS
int 'end' 		length of string built up,
                        = 0 if something wrong
-----------------------------------------------------------*/
	
int   indx;	/* IN: index of first token in expression  */
char  *buff;	/* IN: buffer  */
int   lbuff;	/* IN: length of above  */
int   skip;	/* IN: no. of chars. to skip  */
int   lindx;	/* IN: index of last token in expression  */

{
int   kk;
register int  nr, kstrn;

kk = 0;
CGN_FILL(buff,' ',lbuff);

for (nr=indx; nr<lindx; nr++)
   {
   kstrn = TOKEN[nr].LEN;
   (void) strncpy(&buff[kk],TOKEN[nr].STR,kstrn);
   kk += (kstrn+skip);
   if (kk > lbuff) return (-1);
   }

nr = kk - skip;
buff[nr] = '\0';

return (nr);
}
 
/*

*/

int COMPU(noop,rtype,ii,rr,cop1,cclen,dd)

/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  compute an arithmetic axpression of the form "  OPA op OPB  " or "  OPA  "
  or " M$FUNC(OPA,OPB,...)  ", with FUNC a defined function
  stored in global char variables tokn2, tokop, tokn4 or only tokn2
  with OPA + OPB a keyname or constant and op = +,-,* or /
  for character keys op = // only
.ALGORITHM
  cumbersome, but straight forward
.RETURNS
  status, = 0: o.k., < 0: error
--------------------------------------------------------------------*/

int    noop;	/* IN: number of operands  */
char   *rtype;	/* IN/OUT: type of result of computation:   
			   I, C or D */
int    *ii;	/* OUT: result, if integer   */
float  *rr;	/* OUT:	result, if real  */
char   *cop1;	/* OUT:	result, if character string  */
int    *cclen;	/* IN/OUT: max. length of character result on input,  
                       real length on output    */
double *dd;	/* OUT: result, if double precision  */
	

{
int   iop1, iop2, ibuf1, ibuf2=0;
int   n, m, lcop1, n1, noff;
register int nr;
	
char  work[MAX_TOKEN], type[10], typ1, typ2;
static char   opcode[5] = {'+','-','*','/','`'};
	
float	rbuf1, rbuf2=0.;
	
double	dop1, dop2, dbuf1, dbuf2=0.;

	

/*  handle 1. operand  (test for MIDAS function...)  */

if ( (tokn2[1] == '$') && (tokn2[0] == 'M') )
   {
   n = ltokn2 - 2;
   KEYFUNC(&tokn2[2],n,ii,rr,cop1,dd,cclen,rtype); 	/* yes. */

   if (*rtype == 'R')
      {
      *rtype = 'D';
      *dd = (double) *rr;
      }
   else if (*rtype == ' ') 
      return (-11);

   return (0);				/* work done already ...   */
   }

else
   {
   lcop1 = *cclen;
   GETOP(tokn2,ltokn2,&ibuf1,&rbuf1,cop1,&dbuf1,type,lcop1);
   if (*type == ' ') return (-11);

   typ1 = *type;
   }
	

/*  handle 2. operand if it exists  */

if (noop == 1)  			/* if only one operand  */
   typ2 = typ1;

else
   {
   GETOP(tokn4,ltokn4,&ibuf2,&rbuf2,work,&dbuf2,type,MAX_TOKEN);
   if (*type == ' ') return (-11);
    
   typ2 = *type;
   }

	
/*  for character type only "//" is allowed and used...!   */

if ( (typ1 == 'C') || (typ2 == 'C') )
   {
   if (typ1 != typ2) return (-11);	/* both opers have to be char. stuff */

   n1 = (int) strlen(cop1);

   if (noop == 2)
      {
      char  *ck;

      m = n1;
      ck = cop1 + m - 1;			/* point to last elem. */
      n1 = 0;

      for (nr=m; nr>0; nr--)			/* cut off trailing blanks */
         {
         if (*ck-- != ' ')
            {
            n1 = nr;
            break;
            }
         }

      m = n1;				/* save length of first operand  */
      n1 += (int) strlen(work);
      if (n1 > lcop1) return (-11);	/* output charbuf not big enough */
   
      (void) strcpy(cop1+m,work);
      }

   *cclen = n1;
   *rtype = type[0];
   return (0);				/* and leave this place  */
   }

	
/*  maximize type, update `rtype' + adjust operands to chosen type  */


if (typ1 == 'I')
   {
   if ( (typ2 == 'I') && 		/*  only integer arithmetic */
        ((*rtype == ' ') || (*rtype == 'I')) )
      {
      iop1 = ibuf1;
      iop2 = ibuf2;
      *rtype = 'I';
      }
   else
      {
      dop1 = (double) ibuf1;
      if (typ2 == 'I')
         dop2 = (double) ibuf2;
      else if (typ2 == 'R')
         dop2 = (double) rbuf2;
      else 
         dop2 = dbuf2;
      *rtype = 'D';	
      }
   }

else
   {
   *rtype = 'D';			/* default to double result */

   if (typ1 == 'R')				/* 1. operand is real */
      dop1 = (double) rbuf1;
   else						/* or double */
      dop1 = dbuf1;

   if (typ2 == 'I')
      dop2 = (double) ibuf2;
   else if (typ2 == 'R')
      dop2 = (double) rbuf2;
   else
      dop2 = dbuf2;
   }

	
/*  now do the actual operation  */

if (noop == 1) 			/*    handle single_op      */
   {
   if (*rtype == 'I')
      *ii = iop1;
   else
      *dd = dop1;
   return (0);
   }

for (nr=0; nr<5; nr++)
   {
   if (tokop == opcode[nr])
      {
      noff = nr;
      goto go_on;
      }
   }
return (-11);					/*  wrong opcode  */


/*  branch according to operation   */

go_on:
switch (noff)
   {
  case 0:			/*    handle +      */
   if (*rtype == 'I')
      *ii = iop1 + iop2;
   else
      *dd = dop1 + dop2;
   break;

  case 1:			/*    handle -      */
   if (*rtype == 'I')
      *ii = iop1 - iop2;
   else
      *dd = dop1 - dop2;
   break;

  case 2:			/*    handle *       */
   if (*rtype == 'I')
      *ii = iop1 * iop2;
   else
      *dd = dop1 * dop2;
   break;

  case 3:			/*    handle /       */
   if (*rtype == 'I')
      {
      if (iop2 == 0) return (-12);
       
      *ii = iop1 / iop2;
      }
   else
      {
      if ((dop2 < EPSILON) && (dop2 > - EPSILON)) return (-12);
       
      *dd = dop1 / dop2;
      }
   break;
   
  case 4:                      /*    handle **       */
   if (*rtype == 'I')
      {
      dop1 = (double) iop1;
      dop2 = (double) iop2;
      dbuf1 = pow(dop1,dop2);
      *ii = (int) dbuf1;
      }
   else
      *dd = pow(dop1,dop2);
   break;

  default:
   return (-12);
   }

return (0);
}	
 
/*

*/

void KEY_PARSE(parm,key,type,bytelm,elem,first,last)

/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  extract from the string keyword(...) the keyword and get its type
  and evaluate (...) to return the element and for character keys
  return first and last char. in that element
.ALGORITHM
  cumbersome, but straight forward
.NOTES
  The parameter 'elem' is set to 0, if flat character string 
.RETURNS
  nothing
---------------------------------------------------------------*/
	
char	*parm	/* IN: string of the form keyword(...) or keyword  */;
char	*key	/* OUT: name keyword (parentheses are stripped off) 
                        terminated by \0  */;
char	*type	/* OUT: type of keyword  */;
int  *bytelm	/* OUT: no. of bytes per element  */;
int  *elem	/* OUT: the element indicated by (...)  */;
int   *first	/* OUT: first character or start of interval */;
int   *last	/* OUT: last character or end of interval     
			if = -1, last character is determined 
                        after trailing blanks are cut off  */;

{
int  unit, m1, m2, noel;
long int  mytime;
	

*type = ' ';	

m1 = CGN_INDEXC(parm,'(');	/*  strip off (first) parentheses  */
if (m1 <= 0)
   {
   (void) strcpy(key,parm);
   m2 = m1;
   }
else
   {
   m2 = CGN_INDEXC(parm,')');
   if (m2 < m1) return;			/* missing closing parenthesis...  */

   (void) strncpy(key,parm,m1);
   *(key+m1) = '\0';
   }
	

/*  get keyword info   */

unit = 0;
if (MID_FNDKEY(key,type,bytelm,&noel,&mytime,&unit) >= 0)
   {						/* we found the keyword */
   (void) PARSE_ELEM(parm,m1,m2,type,*bytelm,elem,first,last);
   if (*type == 'C')
      {
      if (*last == -1)
         {
         if (*bytelm > 1)		/* return: -no_bytes_per_elem */
            *last = -(*bytelm);
         else                           /* return: -no_elem */
            *last = -noel;
         }
      }

   else if (*elem > noel) *type = ' ';	/* index too large */
   }	
}
 
/*

*/

void PARSE_ELEM(string,fp,lp,type,bytelem,elem,first,last)

/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  extract from a string keyword(...) the keyword and get its type
  and evaluate (...) to return the element and for character keys
  return first and last char. in that element
.ALGORITHM
  cumbersome, but straight forward
.RETURNS
  nothing
-----------------------------------------------------------------*/

char  *string;	/* IN: string of the form variable(...) or variable  */
int   fp;	/* IN: position of 1. opening parenthesis  */
int   lp;	/* IN: position of 1. closing parenthesis  */
char  *type;	/* IO: type of element  */
int   bytelem;	/* IN: no. of bytes per element  */
int   *elem;	/* IO: the element indicated by (...)  
		       set to 0, if flat character string  */
int   *first;  /* OUT: first character, or first element */
int   *last;   /* OUT: last character or last element    
		      - 1, for character data means: truncate at first blank */


{
int   j, p01, p1, sl, iwa, cx;

float  rwa;
double  dwa;

char	*pntr;


	
pntr = (char *) &CODE.WORK[100];	/* use work buffer [800 - 1000] */

*elem = 0;			/* so it is set */


/*  for character arrays we have to modify 'type'  */

cx = 0;
if (*type == 'C')
   {
   *first = 1;			/* remember, we count in "human" terminoloy  */
   *last = -1;

   if (bytelem > 1)  			/* yes. it's an array  */
      {
      (void) sprintf(type,"CHAR*%5.5d",bytelem);
      cx = bytelem;
      }
   else
      {			/*  it's a flat string, check if (..:..) is present  */
      *elem = 0;			/* no. use element 0  */
      if (fp <= 0)
         return;
      else
         goto go_on;				/* go + handle (..:..)  */
      }
   }

	
/*  take care of parentheses  */

if (fp <= 0)
   *elem = 1;				      /* if none, use element 1  */

else
   {
   if ((*(string+lp+1) != '\0') && (cx == 0))
      goto errors;			/* there is stuff after the index */

   j = lp - fp - 1;
   (void) strncpy(pntr,string+fp+1,j);
   *(pntr+j) = '\0';
   j = CGN_CNVT(pntr,1,1,&iwa,&rwa,&dwa);
   if ((j < 1) || (iwa < 1)) goto errors;	/* negative index is bad */

   *elem = iwa;
   }

	
/*  only for char. keywords we still have to work  */

if (*type != 'C') return;		/* for I, R, D keys, we're done...  */


fp = CGN_INDEXS(string,")(");		/* look for (x)(y:z)  */
if (fp < 1) return;

fp ++;

	
/*  treat (yyy:zzz) - 'fp' points to opening parenthesis  */
	
go_on:
p1 = CGN_INDEXC(string+fp,')');
p01 = CGN_INDEXC(string+fp,':');

if ((p01 <= 0) || (p01 >= p1))  	/* correct order is (:)...    */
   goto errors;			/* if syntax error, return TYPE = ' ' */
	

sl = p01 - 1;				/* extract starting character */
if (sl > 0)
   {
   (void) strncpy(pntr,string+fp+1,sl);
   *(pntr+sl) = '\0';
   j = CGN_CNVT(pntr,1,1,&iwa,&rwa,&dwa);
   if (j < 1) goto errors;
 
   *first = iwa;
   }

sl = p1 - p01 - 1;			/* extract terminating character */
if (sl > 0)
   {
   p01 = fp + p01 + 1;
   if (*(string+p01) == '>')  	/* there might be still (...:>) out there */
      *last = -1;			/* indicate that no definite end */
   else
      {
      (void) strncpy(pntr,string+p01,sl);
      *(pntr+sl) = '\0';
      j = CGN_CNVT(pntr,1,1,&iwa,&rwa,&dwa);
      if (j < 1) goto errors;

      *last = iwa;
      }
   }
return;

	
/*  here for wrong syntax...  */

errors:
*type = ' ';
}
 
/*

*/

void DSCR_PARSE(imno,parm,descr,type,bytelm,elem,first,last)

/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  extract from a string descriptor(...) the descriptor and get its type
  and evaluate (...) to return no. of element and length (only for character de
.ALGORITHM
  the usual stuff
.RETURNS nothing
---------------------------------------------------------------------*/

int   imno /* IN: file no.  */;
char	*parm	/* IN: string of the form descr(...) or descr  */;
char	*descr	/* OUT:name of descriptor (parentheses are stripped off)  */;
char *type        /* OUT: type of descr  */;
int  *bytelm /* OUT: no. of bytes per element  */;
int  *elem   /* OUT: the element indicated by (...) */;
int  *first  /* OUT: first character  */;
int  *last   /* OUT: last character (may be = -1)  */;

{
int  unit, stat, n, m, noel, m1, m2, dsclen;

char  htext[72], realdescr[52];

struct FCB_STRUCT  *fcbp;

struct FCT_STRUCT  *fctpntr;




/*  strip off first parentheses  */

unit = 0;
*type = ' ';				/* that indicates failure...  */
m1 = CGN_INDEXC(parm,'(');

if (m1 <= 0)
   {
   (void) strcpy(descr,parm);
   m2 = 0;
   }

else
   {
   m2 = CGN_INDEXC(parm,')');
   if (m2 < m1) return;			/*   missing closing parenthesis...  */
    
   (void) strncpy(descr,parm,m1);
   descr[m1] = '\0';
   }

	
/*  get descr info  */

*type = ' ';
fctpntr = FCT.ENTRIES + imno;
fcbp = fctpntr->FZP;
dsclen = CGN_UPCOPY(realdescr,descr,49);        /* build uppercase name */

if (fcbp->DSCFLAG == 'Y')
   stat = MID_YDSCDIR(imno,'F',realdescr,type,bytelm,&noel,&unit,&n,&m,htext);
else if (fcbp->DSCFLAG == 'Z')
   stat = MID_ZDSCDIR(imno,'F',realdescr,dsclen,type,bytelm,&noel,&unit,&n,&m);
else
   stat = MID_DSCDIR(imno,'F',descr,type,bytelm,&noel,&unit,&n,&m);

if (stat != ERR_NORMAL) 
   KIWORDS[OFF_PRSTAT] = 0;
else
   {
   PARSE_ELEM(parm,m1,m2,type,*bytelm,elem,first,last);
   if (*type == 'C')
      {
      if (*last == -1) 
         {
         if (*bytelm > 1)                  /* return: -no_bytes_per_elem */
            *last = -(*bytelm);
         else                              /* return: -no_elem */
            *last = -noel;
         }
      }
   }
}
 
/*

*/

int ascfiles(flag,bad)
int flag;			/* IN: action flag
				       = 0, open file
				       = 1,  close file
				       = 2
				       = 3 */
int *bad;			/* OUT: if it failed... */

{
int    m, j, n, stat, mk, idx;
int    iwa, fid, fidcount, kbuf[2];
int    unit=0;
int    klaus=600;
register int  nr;
static int   ascbegin = -1;
static int   ascid[MAXASCID];

float  rwa;
double  dwa;

char  *wpntr, type[12];
static char  *myline;
static char  ascstat[MAXASCID*(KEY_NAMELEN+1)];



if (ascbegin == -1)			/* initialize the file id's */
   {
   ascbegin = 0;
   for (nr=0; nr<MAXASCID; nr++) ascid[nr] = -9;
   myline = malloc(klaus);			/* max length of record */
   }

*bad = -1;
idx = -1;

if (flag == 0)		 /* OPEN/FILE file_name read/write file_control_key  */
   {		
   if (MONIT.COUNT < 4) return (100);

   for (nr=0; nr<MAXASCID; nr++)
      {
      if (ascid[nr] < 0)
         {
         idx = nr;
         break;
         }
      }
   if (idx < 0) return (101);		/* overflow */

   wpntr = TOKEN[1].STR;
   fidcount = 0;
   if ((TOKEN[2].STR[0] == 'W') || (TOKEN[2].STR[0] == 'w'))
      mk =  WRITE;
   else if ((TOKEN[2].STR[0] == 'A') || (TOKEN[2].STR[0] == 'a'))
      mk =  APPEND;
   else
      mk =  READ;

open_file:
   fid = CGN_OPEN(wpntr,mk);
   if (fid < 0)
      {
      if (fidcount < 4)
         {
         n = fidcount*80;
         (void) strncpy(myline,&KCWORDS[OFF_DPATH+n],80);
         if (myline[0] != '^')
            {
            myline[80] = ' ';
            n = CGN_INDEXC(myline,' ');
            (void) strcpy(&myline[n],TOKEN[1].STR);          /* use new path */
            wpntr = myline;
            fidcount ++;
            goto open_file;
            }
         }
      }

   ascid[idx] = fid;
   kbuf[0] = ascid[idx];
   kbuf[1] = 0;

   idx *= (KEY_NAMELEN+1);		/* point to relevant keyname entry */
   (void) strncpy(&ascstat[idx],TOKEN[3].STR,KEY_NAMELEN);
   ascstat[idx+KEY_NAMELEN] = '\0';	/* ensure a '\0' in the end */
   }

else
   {
   m = CGN_CNVT(TOKEN[1].STR,1,1,&iwa,&rwa,&dwa);
   j = iwa;

   if (flag == 4) 				/* process INFO/FILE */
      {
      int  recmax, recount;


      if (m < 1)				/* should be name of file */
         {
         wpntr = TOKEN[1].STR;
         fidcount = 0;

        opening:
         fid = CGN_OPEN(wpntr,READ);
         if ((fid < 0) && (fidcount < 4))
            {
            n = fidcount*80;
            (void) strncpy(myline,&KCWORDS[OFF_DPATH+n],80);
            if (myline[0] != '^')
               {
               myline[80] = ' ';
               n = CGN_INDEXC(myline,' ');
               (void) strcpy(&myline[n],TOKEN[1].STR);   /* use new path */
               wpntr = myline;
               fidcount ++;
               goto opening;
               }
            }
         if (fid < 0) return 100;
         }
      else
         {
         for (nr=0; nr<MAXASCID; nr++)		/* search for file_id */
            {
            if (ascid[nr] == j)
               {
               idx = nr;
               fid = j;
               break;
               }
            }
         if (idx < 0)  return (100);		/* not found in table */

         osaseek(fid,0L,FILE_START);		/* move to start of file */
         }


      recmax = recount = 0;

     reading: 
      nr = osaread(fid,myline,klaus-1);		/* read a line */
      if (nr > -1)
         {
         if (nr > recmax) recmax = nr;		/* and get max length */
         recount ++;
         goto reading;
         }
      if (idx < 0) 
         osaclose(fid);		/* we had opened the file */
      else
         osaseek(fid,0L,FILE_START);		/* rewind file */


      KIWORDS[OFF_INFO] = recount;
      KIWORDS[OFF_INFO+1] = recmax;

      return 0;
      }

   if (m != 1)
      {
      if ((flag == 1) &&			/* is it CLOSE/FILE *  ? */
          (TOKEN[1].STR[0] == '*'))
         {
         for (nr=0; nr<MAXASCID; nr++)
            {
            if (ascid[nr] >= 0)
               {
               j =  ascid[nr];
               osaclose(j);
               ascid[nr] = -9;
               }
            }
         return (0);
         }
      else
         return (5);
      }
       
   for (nr=0; nr<MAXASCID; nr++)		/* search for file_id */
      {
      if (ascid[nr] == j)
         {
         idx = nr;
         break;
         }
      }

   if (idx < 0)  return (100);		/* not found in table */

   if (flag == 1) 		/* CLOSE/FILE file_id  */
      {
      (void) osaclose(j);
      ascid[idx] = -9;		/* clear entry */
      }

   else 
      {
      if (MONIT.COUNT < 3) return (100);

      if (flag == 2)		/*  WRITE/FILE */
         {
         m = CGN_INDEXC(TOKEN[1].STR,',');
         if (m > 0)
            {		/* check, if  WRITE/FILE file_id,key  char.key  */
            m ++;
            if ((TOKEN[1].STR[m] == 'K') || (TOKEN[1].STR[m] == 'k'))
               {
               GETOP(TOKEN[2].STR,TOKEN[2].LEN,&iwa,&rwa,myline,&dwa,
                     type,klaus);
               if (*type != 'C') return (100);

               n = osawrite(j,myline,(int)strlen(myline));
               goto end_file;
               }
            }
         m = CGN_INDEXS(LINE.STR,TOKEN[1].STR);		/* WR file_id c_buff */
         m += (TOKEN[1].LEN + 1);		    /* move to after file_id */
         mk = CGN_COPY(LINE.STR,&LINE.STR[m]) - 1;

         if ((KIWORDS[OFF_AUX+4] == 0) &&       /* double quote flag */
             (LINE.STR[0] == '"') &&
             (LINE.STR[mk] == '"'))
            {
            LINE.STR[mk] = '\0';
            mk --;                             /* new length */
            n = osawrite(j,&LINE.STR[1],mk);
            }
         else
            {
            mk ++;				/* reset to original value */
            n = osawrite(j,LINE.STR,mk);
            }
         }

      else if (flag == 3)	/* READ/FILE file_id char.buff_key [max_rd] */
         {
         int     bytelem, noelem;
         long int since;
 
         stat = MID_FNDKEY(TOKEN[2].STR,type,&bytelem,&noelem,&since,&unit);
         if ((stat < 0) || (type[0] != 'C'))
            {
            *bad = 2;
            return (100);
            }

         if (MONIT.COUNT < 4) 
            m = noelem;			/* default to size of keyword */
         else
            {
            n = CGN_CNVT(TOKEN[3].STR,1,1,&m,&rwa,&dwa);
            if ((n != 1) || (m < 1))	/* problems converting max_read */
               {
               *bad = 3;
               return (5);
               }
            }

         if (m > klaus) m = klaus;    /* that's the size of `myline' */
 
         CGN_FILL(myline,' ',m);	/* pad with blanks till `m' */
         n = osaread(j,myline,m);	/* now read from ASCII file */

         if (n > 0)
            {
            stat = SCKWRC(TOKEN[2].STR,1,myline,1,m,&unit);
            if (stat != ERR_NORMAL)
               {
               *bad = 2;
               return (100);
               }
            }
         }
   
      else
         return (16);
      } 

  end_file:
   kbuf[0] = j;				/* file id */
   kbuf[1] = n;				/* no. of chars. written/read  */
   idx *= (KEY_NAMELEN+1);		/* point to keyname entry */
   }


/*  fill file_control_key with file id + no. of chars. written/read  */

stat = SCKWRI(&ascstat[idx],kbuf,1,2,&unit);
if (stat != ERR_NORMAL)
   return (100);
else
   return (0);
}