/* @(#)prepj.c	17.1.1.2 (ESO-DMD) 02/25/02 17:53:01 */
/*===========================================================================
  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 source PREPJ  +++++++++++++++++++++++++
.LANGUAGE    C
.IDENTIFICATION  Module PREPJ
.AUTHOR  K. Banse 		ESO - Garching
.KEYWORDS
  MIDAS monitor
.COMMENTS
  holds PREPERR, TABLE_ACCESS, build_prg, KLOCK, SYNCHRO,
        CREA_COM, STORE_FR, WAIT_SECS, WRITE_QU
        (StatProc)
.ENVIRONMENT  VMS and UNIX

.VERSION  [1.00] 870723:  from FORTRAN version 2.30 as of  861105

 020222		last modif

------------------------------------------------------------------------*/
 
#include <fileexts.h>

#include <stdio.h>
#include <stdlib.h>

#include <osyparms.h>
#include <monitdef.h>
#include <midback.h>
#include <commdef.h>
#include <fsydef.h>
 
/*

*/
 
void PREPERR(source,message,err_str)
 
/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  provide controlled error handling in the monitor
.ALGORITHM
  depending upon the source display various explanatory error messages
.RETURNS
  nothing
----------------------------------------------------------------*/
 
char	*source   /* IN: FSY or OSY or MIDAS  */;
char	*message  /* IN: error message (if not '\0')
			 for display + MID$ERRMESS keyword
			 if 1. char = ' ', only into MID$ERRMESS */;
char	*err_str  /* IN: text causing the error,            \
                         if = ' ', ignore that parameter  */;
 
{
int   nn, n, usr_levl;

char  errlabel[4], prefix[8], tmp[120];
 


 
KIWORDS[OFF_PRSTAT] = ERRORS.SYS;		/* update keyword PROGSTAT */
KIWORDS[OFF_PRSTAT+1] = 10;
 
(void) SCKWRC("LASTINPUT",1,LINE.STR,1,40,&nn);	/* save 1st part of LINE */

if (KIWORDS[OFF_ERROR+3] == 0) return;		/* test error display flag */
 
 
/*  display user provided message  */
 
if ((*message != '\0') && (*message != ' '))
   {
   if (MONIT.LEVEL > 0) SCTSYS(message);

   if (*err_str != ' ')
      {
      char   workline[MAX_LINE];

      nn = CGN_INDEXS(message,err_str);		/* find `err_str' in message */
      if (nn >= 0)
         {
         if (MONIT.LEVEL < 1) nn += ERRORS.OFFSET;
         CGN_FILL(workline,' ',nn);
         workline[nn] = workline[nn+1] = workline[nn+2] = '^';
         if (err_str[1] == '\0')
            nn -= 2;
         else if (err_str[2] == '\0')
            nn --;
         workline[nn+3] = '\0';
         SCTSYS(workline);
         }
      }
   }


/*  branch according to 'source'   */
 
if ((*source == 'F') || (*source == 'O'))	/* look for FSY,OSY errors */
   {
   OSY_MESSAGE(ERRORS.SYS,tmp);
   SCTSYS(tmp);
   }
 
else						/* now the MIDAS errors ...  */
   {
   if (ERRORS.STATUS != 0)
      {
      ERRORS.STATUS = 0;

      if (ERRO_INDX >= 0)
         {
         int e1, e2;

         e1 = KIWORDS[OFF_ERROR];
         e2 = ERRO_DISP;
         ERRO_DISP = 1;			/* enable error display  */
         KIWORDS[OFF_ERROR] = 0;
         MID_DSPERR();			/* display low level error */
         KIWORDS[OFF_ERROR] = e1;
         ERRO_DISP = e2;
         return;
         }
      }

   nn = KIWORDS[OFF_OUTFLG];			/* avoid output redirection */
   KIWORDS[OFF_OUTFLG] = 99;

   if (ERRORS.SYS < 0) 
      {
      if (*message == '\0')
         (void) sprintf(tmp,"Error no. %d",ERRORS.SYS);
      else
         {
         if (*message == ' ')
            (void) strncpy(tmp,&message[1],80);	/* use provided message */
         else
            (void) strncpy(tmp,message,80);	/* use provided message */
         }
      }

   else					/* for monitor error, find the */
      {					/* corresponding text in system file */
      usr_levl = KIWORDS[OFF_ERROR+1];
      if (usr_levl >= 2)
         (void) strcpy(prefix,"EXPERT.");
      else
         (void) strcpy(prefix,"NOVICE.");
      (void) sprintf(errlabel,"%3.3d",ERRORS.SYS);

      /*  now display related section in the MIDAS error file */

      if (CGN_DISPFIL("MID_MONIT:syserr.dat",prefix,errlabel) == -1)
         {
         switch (ERRORS.SYS)
            {
           case 22:
           case 44:
           case 47:
           case 79:
            SCTPUT("problems opening error_message_file...  it looks as if");
            SCTPUT
            ("the max. no. of simultaneously opened files has been reached ");
            break;
           default:
            SCTPUT
         ("problems opening error_message_file or error_section not found...");
            }
         (void) sprintf(tmp,"problems with error no. = %d",ERRORS.SYS);
         SCTPUT(tmp);
         }
      else
         CGN_GETLIN("MID_MONIT:syserr.dat","EXPERT.",errlabel,tmp);
      }
   (void) SCKWRC("MID$ERRMESS",1,tmp,1,80,&n);

   KIWORDS[OFF_OUTFLG] = nn;
   }
}

/*

*/
 
void TABLE_ACCESS(flag,string,ival,rval,cval,dval,type,size)
 
/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  replace string TABLE,COLUMN,ROW with the contents of the element in 
  column COLUMN and row ROW of table TABLE
.ALGORITHM
  use TCE_ACCESS
.RETURNS
  nothing
----------------------------------------------------------------------*/
 
int   flag    /* IN: = 0, read table element    
		          = 1, write table element  
		          = 2, get necessary table info        */;
char	*string    /* IN: table,col,row terminated by \0 */;
int   *ival   /* IO: integer value to be read or written  */;
float	*rval	   /* IN/OUT: real value to be read or written  */;
char	*cval	   /* IO: character value to be read or written  
			  or keyword name if flag=1 and nonchar. data */;
double	*dval	   /* IO: double prec. value to be read or written  */;
char	*type	   /* OUT: type of element: I,R,CHAR*..,D   
		           = ' ', if something wrong     */;
int   *size   /* OUT: length of value returned (for 'flag' = 0)  */;
	
{
int  tid, column, irow, nlo, nlon, inull, idum, iav, nullo;
int  dtyp, nw, *tip;
int  unit, stat, n, nn, flagsel;
short int *tjp;

float     *trp, rnull, rdum;

double    *tdp, ddum;

char      *addr, ck;
char  frame[80], cbuf[20];
	


/*  split table, column, row    */

*type = ' ';
n = 0;
nn = (int)strlen(string);
stat = CGN_EXTRSS(string,nn,',',&n,frame,80);
stat = CGN_EXTRSS(string,nn,',',&n,cbuf,20);
if (string[n] == '@') n++;			/* take care of @row ...  */
stat = CGN_CNVT(&string[n],1,1,&irow,&rdum,&ddum);
if (stat < 1) 
   {
   ERRORS.SYS = 86;
   return;
   }

(void) FRAMACC('O',frame,2,&tid);		/* open table */
if (tid < 0) 
   {
   ERRORS.SYS = 47;
   return;
   }

if (stuindex(cbuf,"sel") == 0)
   flagsel = 1;
else 
   {
   flagsel = 0;
   stat = TCCSER(tid,cbuf,&column);
   if ((stat != ERR_NORMAL) || (column < 0))
    {
    if ((cbuf[0] >= '0') && (cbuf[0] <= '9'))
       {				/* insert the # sign for columns */
       frame[0] = '#';			/* and try once more ...  */
       (void) strcpy(&frame[1],cbuf);
       stat = TCCSER(tid,frame,&column);
       if ((stat == ERR_NORMAL) && (column >= 0)) goto tblget;	/* continue */
       }
    ERRORS.SYS = 48;
    goto table_error;
    }

tblget:
stat = TCBGET(tid,column,&dtyp,&nlo,&nlon);
if (stat != ERR_NORMAL)
   {
   ERRORS.SYS = 48;
   goto table_error;
   }
 }
(void) TCIGET(tid,&iav,&nlo,&iav,&iav,&iav);	/* may return irow < 0 */

if (flagsel == 0)
   {
   stat = TCEMAP(tid,irow,column,&addr,&inull);
   if (stat != ERR_NORMAL)
      {
      ERRORS.SYS = 49;
      goto table_error;
      }
   }
 
/* read table element */

if (flagsel == 1)
   {
   *type = 'I';
   (void) TCSGET(tid,irow,ival);
   } 

else if (flag == 0) 
   {
   if (inull == 1) 			/* we cannot read "NULL" */
      {
      SCTPUT("Accessing table NULL value - replaced by keyword NULL!!");
      stat = SCKRDR("NULL",2,1,&iav,&rnull,&unit,&nullo);

      switch (dtyp)
         {
         case D_I1_FORMAT:
         case D_I2_FORMAT:
         case D_I4_FORMAT:
            *type = 'I';
            *ival = (int) rnull;
            break;
         case D_R4_FORMAT:
            *type = 'R';
            *rval = rnull;
            break;
         case D_R8_FORMAT:
            *type = 'D';
            *dval = (double ) rnull;
            break;
         default:
            *type = 'C';
            *size = 1;
            cval[0] = ' ';
            cval[1] = '\0';
         }
      }

   else
      {
      switch (dtyp)
         {
         case D_I1_FORMAT:
            *type = 'I';
            ck = *addr;		
            *ival = (int) ck;
            break;
         case D_I2_FORMAT:
            *type = 'I';
            tjp = (short int *) addr;
            *ival = (int) *tjp;
            break;
         case D_I4_FORMAT:
            *type = 'I';
            tip = (int *) addr;
            *ival = *tip;
            break;
         case D_R4_FORMAT:
            *type = 'R';
            trp = (float *) addr;
            *rval = *trp;
            break;
         case D_R8_FORMAT:
            *type = 'D';
            tdp = (double *) addr;
            *dval = *tdp;
            break;
         default:
            *type = 'C';
            nw = nlon;
            strncpy(cval,addr,nw);
            for (n=0; n<nw; n++)
               {
               if (cval[n] == '\0')
                  {
                  nw = n;
                  break;
                  }
               }
            *size = nw;
            cval[nw] = '\0';
         }
      }
   }

else if (flag == 2)
   {                      
   switch (dtyp)
      {
      case D_I1_FORMAT:
      case D_I2_FORMAT:
      case D_I4_FORMAT:
        *type = 'I';
        break;
      case D_R4_FORMAT:
        *type = 'R';
        break;
      case D_R8_FORMAT:
        *type = 'D';
        break;
      default: 
        *type = 'C';
      }
   }


/*  write table element */

else  
   {                      
   stat = TCMNUL(&idum,&rdum,&ddum);		/* read already null vals */
   if (stat != ERR_NORMAL)
      {
      ERRORS.SYS = 86;
      goto table_error;
      }

   switch (dtyp)
      {
      case D_I1_FORMAT:
      case D_I2_FORMAT:
      case D_I4_FORMAT:
         if (cval[0] != 'N') 
            (void) SCKRDI(cval,1,1,&iav,&idum,&unit,&nullo);

         if (dtyp == D_I1_FORMAT)
            *addr = (char) idum;
         else if (dtyp == D_I2_FORMAT)
            {
            tjp = (short int *) addr;
            *tjp = (short int) idum;
            }
         else
            {
            tip = (int *) addr;
            *tip = idum;
            }
         *type = 'I';
         break;

      case D_R4_FORMAT:
         if (cval[0] != 'N') 
            (void) SCKRDR(cval,1,1,&iav,&rdum,&unit,&nullo);

         trp = (float *) addr;
         *trp = rdum;
         *type = 'R';
         break;

      case D_R8_FORMAT:
         if (cval[0] != 'N') 
            (void) SCKRDD(cval,1,1,&iav,&ddum,&unit,&nullo);

         tdp = (double *) addr;
         *tdp = ddum;
         *type = 'D';
         break;

      default: 
         nn = (int)strlen(cval) - 1;
         if ((cval[0] == '"') && (cval[nn] == '"'))
            {
            nw = nn - 1;
            nn = 1;
            }
         else
            {
            nw = nn + 1;
            nn = 0;
            }

         strncpy(addr,&cval[nn],nw);
         *type = 'C';
      }
   }


(void) TCEUNM(tid,addr);
return;

table_error:
(void) FRAMACC('C',KAUX.OUT,0,&tid);
}

/*

*/

int build_prg(flag,spec_flg)

/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  build a procedure from the rows of table stored in TOKEN[1].STR
  use columns #1 - #10  if not given in TOKEN[2].STR
.ALGORITHM
  use table interfaces
.RETURNS
  = 0, if all o.k.
----------------------------------------------------------------------*/

int   flag;    /* IN = 1 for building procedure from table 
		     = 2 for building procedure from ASCII file 
		     = 3 for building procedure for: inmidas -j "..." */
int   spec_flg;  /* IN = 0 for building a procedure
		       = 1 for building single command line */

{
int  fid, tid, icol, irow, findx;
int  stat, iav, m, n, nn, quote_flag;
static int first=0, indxadd=2;			/* index for addchar below */

char  *poff;
char  frame[100], mybuff[164], cbuf[24];
static char  *prline, *buff;
static char  addchar[4] = " ab";		/* for switching 'a' <-> 'b' */



if (first == 0)
   {
   first = 1;
   n = 2*MAX_LINE;		/* twice the max. size of command line */
   prline = (char *) malloc((unsigned int)n);
   buff = (char *) malloc((unsigned int)n);
   if ((prline == (char *)NULL) || (buff == (char *)NULL))
      {
      (void) printf("build_prg: could not allocate %d bytes...\n",n);
      return 80;
      }
   }


if (flag == 3)			/* here we handle the inmidas -j "..."  stuff */
   {
   (void) strcpy(frame,"MID_WORK:midjob  .prg");	/* new `midjobXY.prg */
   frame[15] = FRONT.DAZUNIT[0];
   frame[16] = FRONT.DAZUNIT[1];

   fid = CGN_OPEN(frame,1);
   if (fid < 0) return(81);

   (void) osawrite(fid,KAUX.STR,(int)strlen(KAUX.STR));
   (void) osaclose(fid);
   return 0;
   }


 
poff = prline;
if (flag == 1)
   (void) strcpy(frame,"MID_WORK:midtab   .prg");	/* new `midtabXYa.prg */
else 
   (void) strcpy(frame,"MID_WORK:midlis   .prg");	/* new `midlisXYa.prg */
 
m = 3 - indxadd; indxadd = m;
frame[17] = addchar[m];				/* toggle 'a' <-> 'b' */
frame[15] = FRONT.DAZUNIT[0];
frame[16] = FRONT.DAZUNIT[1];

fid = CGN_OPEN(frame,1);
if (fid < 0) return(81);


/*  here we handle the ASCII file stuff */

if (flag == 2)
   {
   quote_flag = 0;
   findx = MONIT.COUNT - 1;

   if (strcmp(TOKEN[0].STR,"WRITE/KEYW") == 0)	/* look for WRITE/KEYW */
      {
      long int since = 0;			/* earliest time */

      n = CGN_INDEXC(TOKEN[1].STR,'/');		/* test, if char key */
      if (n > 0)
         {
         (void) memcpy(cbuf,TOKEN[1].STR,(size_t)n);
         cbuf[n] = '\0';
         n = MID_FNDKEY(cbuf,mybuff,&nn,&m,&since,&stat);
         }
      else
         n = MID_FNDKEY(TOKEN[1].STR,mybuff,&nn,&m,&since,&stat);

      if ((n >= 0) && (mybuff[0] == 'C')) quote_flag = 1;
      }

   for (m=0; m<findx; m++)
      {
      nn = CGN_COPY(poff,TOKEN[m].STR);
      poff += nn;
      *poff++ = ' ';
      }
   (void) strcpy(mybuff,&TOKEN[findx].STR[1]);
 
   tid = osaopen(mybuff,0);		/* open for reading */
   if (tid <= 0) 
      {
      nn = 22;
      goto closing;
      }
   icol = 0;				/* serves as line counter */

   if (quote_flag == 1) 
      mybuff[0] = '"';
   else
      mybuff[0] = ' ';

rd_loop:
   nn = osaread(tid,&mybuff[1],160);                /* get a file record */

   if (nn == 0)
      goto rd_loop;
   else if (nn < 0)
      goto eof_found;                              /*  EOF encountered  */

   icol++;
   if (quote_flag == 1)
      {
      nn++;					/* add '"' in the end */
      mybuff[nn++] = '"';
      mybuff[nn] = '\0';
      }
   nn = CGN_COPY(poff,mybuff);
   (void) osawrite(fid,prline,(int)strlen(prline));
   goto rd_loop;


eof_found:
   (void) osaclose(tid);
   if (icol == 0) 				/* empty file */
      {
      nn = 39;
      goto closing;
      }

   /* finally build up the command line */

   if ((spec_flg == 1) && (icol == 1)) 			/* single line */
      LINE.LEN = CGN_COPY(LINE.STR,prline);
   else
      {
      (void) strcpy(LINE.STR,"@@ ");
      (void) strcpy(&LINE.STR[3],&frame[9]);
      LINE.LEN = (int) strlen(LINE.STR);
      }
   }


/*  here we handle the table stuff */

else 
   {
   (void) strcpy(mybuff,TOKEN[1].STR);		/* save table name */
   stat = TCTOPN(mybuff,F_I_MODE,&tid);
   if (stat != ERR_NORMAL) goto err_open;
   stat = TCIGET(tid,&icol,&irow,&iav,&iav,&iav);  /* no. of columns +  rows */
   TCTCLO(tid);
   if (stat != ERR_NORMAL) goto err_tab;

   (void) sprintf(prline,"define/local loop/i/1/2 0,%d",irow);
   (void) osawrite(fid,prline,(int)strlen(prline));
   (void) strcpy(prline,"do loop = 1 loop(2)");
   (void) osawrite(fid,prline,(int)strlen(prline));


   /* now massage the command line */

   LINE.LEN = TOKBLD(2,LINE.STR,MAX_LINE,1,MONIT.COUNT);

   iav = CGN_INDEXS(LINE.STR,"[:");		/* look for first [:xyz] */
   if (iav < 0) goto bad_syntax;

   if (iav == 0)
      prline[0] = '\0';
   else
      {
      (void) memcpy(prline,LINE.STR,(size_t)iav);
      prline[iav] = '\0';
      }
  
   nn = iav;
   (void) memcpy(cbuf,&LINE.STR[iav+2],(size_t)20);
   cbuf[20] = '\0';
   iav = CGN_INDEXC(cbuf,']');		/* look for closing ']' */
   if (iav < 0) goto bad_syntax;
   cbuf[iav] = '\0';
   nn += (iav + 3);			/* skip the 3 ':' */

   (void) sprintf(buff,"{%s,:%s,@{loop}}",mybuff,cbuf);
   (void) strcat(prline,buff);
   (void) strcat(prline,&LINE.STR[nn]);
   (void) strcpy(LINE.STR,prline);		/* copy back to LINE.STR */

loop_again:
   iav = CGN_INDEXS(LINE.STR,"[:");		/* look for more [:xyz] */
   if (iav >= 0)
      {
      (void) memcpy(prline,LINE.STR,(size_t)iav);
      prline[iav] = '\0';
      nn = iav;
      (void) memcpy(cbuf,&LINE.STR[iav+2],(size_t)20);
      cbuf[20] = '\0';
      iav = CGN_INDEXC(cbuf,']');		/* look for closing ']' */
      if (iav < 0) goto bad_syntax;
      cbuf[iav] = '\0';
      nn += (iav + 3);			/* skip the 3 ':' */

      (void) sprintf(buff,"{%s,:%s,@{loop}}",mybuff,cbuf);
      (void) strcat(prline,buff);
      (void) strcat(prline,&LINE.STR[nn]);
      (void) strcpy(LINE.STR,prline);		/* copy back to LINE.STR */
      goto loop_again;
      }
   (void) osawrite(fid,prline,(int)strlen(prline));
 
   (void) strcpy(prline,"enddo");
   (void) osawrite(fid,prline,(int)strlen(prline));

   /* finally build up the command line */

   (void) strcpy(LINE.STR,"@@ ");
   (void) strcpy(&LINE.STR[3],&frame[9]);
   LINE.LEN = (int) strlen(LINE.STR);
   }


(void) osaclose(fid);				/* close file */
return (0);


bad_syntax:
nn = 5;
goto closing;

err_open:
nn = 47;
goto closing;

err_tab:
nn = 48;

closing:
(void) osaclose(fid);
return (nn);
}

/*

*/

int K_LOCK(flag)

/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  handle the LOCK, UNLOCK/KEYWORD commands

 LOCK/KEYWORD  keyword_list  lock no.         
 UNLOCK/KEYWORD  keyword_list  lock no.         

----------------------------------------------------------------------*/
int  flag;		/* IN: 0 for UNLOCK/KEY,
			       1 for LOCK/KEY    */

{
int   reto, iwa, iav;

float  rwa;

double dwa;


iav = CGN_CNVT(TOKEN[2].STR,1,1,&iwa,&rwa,&dwa);
if (iav < 1) 
   reto = 1;

else
   {
   reto = 0;
   if (flag == 0) iwa = -iwa;		/* that indicates unlocking */

   if (MID_KLOCK(TOKEN[1].STR,iwa) != ERR_NORMAL) reto = 100;
   }

return (reto);
}

/*

*/

int SYNCHRO(qualf)

/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  handle the SYNCHRONIZE commands

 SYNCHRONIZE/MIDAS 
 SYNCHRONIZE/TIME 

----------------------------------------------------------------------*/
char *qualf;           /* IN: the qualifier string of SYNCHRONIZE/ */

{
char  str[200];

int  mm;



if (*qualf == 'M')			/* SYNC/MIDAS */
   {
   (void) MID_MOVKEY("O",str);             /* close keyfile */
   mm = CGN_COPY(str,FRONT.STARTUP);
   (void) strcpy(&str[mm],"FORGR  .KEY");
   str[mm+5] = FRONT.DAZUNIT[0];
   str[mm+6] = FRONT.DAZUNIT[1];
   (void) MID_MOVKEY("IM",str);             /* open keyfile again*/
   }

else					/* SYNC/TIME */
   {
   mm = MONIT.MXT[MONIT.LEVEL];     /* so get current timeout */
   if (mm > 0)
      {
      mm = (int) (MONIT.ENDT[MONIT.LEVEL] - oshtime());
      if (mm < 1)
         {
         (void)
         sprintf(str,"(ERR) Midas procedure %s timed out (%d seconds)",
                 PROC.FNAME,MONIT.MAXTIME);
         SCTPUT(str);
         KIWORDS[OFF_PRSTAT] = 998;
         KIWORDS[OFF_PRSTAT+1] = 10;
         return (1);
         }
      }
   }

return (0);
}

/*

*/

int CREA_COM(qualf)

/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  handle the CREATE/COMMAND, CREATE/D_COMMAND commands

 CREATE/COMMAND [D_COMMAND)  user_command command LINE.STR ... 

----------------------------------------------------------------------*/
char *qualf;           /* IN: the qualifier string of CREATE/ */

{
int  stat, iwa, jj, mm;
register int nr, mr;

char  save[20], command[8], qualif[4];
register char  cc;




if ( (MONIT.COUNT < 3) ||  		/* not enough parameters */
     (TOKEN[1].STR[1] == ',') )		/* no 'x,' in the beginning */
   return (5);


EXTRACOM(TOKEN[1].STR,command,qualif);	/* extract command + qualifier
					   and convert to upper case  */


/*  check new command name against
                       a) commands of MIDAS programming language
                       b) special commands                             */

cc = command[0];
if ((cc < 'A') || (cc > 'Z')) return (11);	/* must begin with alpha */

save[0] = cc;
jj = 6;
for (nr=1; nr<6; nr++)
   {
   cc = command[nr];
   if (cc == ' ')
      {
      jj = nr;
      break;
      }
   save[nr] = cc;
   }
save[jj] = '\0';

for (nr=0; nr<MAX_BATCH; nr++)
   {
   if (strcmp(save,BATCH[nr].CMND) == 0) return (11);
   }


/*  isolate actual commline */

for (nr=jj; ;nr++)			/* we can start here in LINE.STR */
   {
   if (LINE.STR[nr] == ' ')
      {
      jj += (nr+1);
      for (mr=jj; ;mr++)
         {
         if (LINE.STR[mr] == ' ') 
            {
            mm = mr + 1;
            while(LINE.STR[mm] == ' ') mm++;
            goto after_TOK1;
            }
         }
      }
   }


/*  all o.k.  -   add the command dynamically   */

after_TOK1:
jj = 0;                          /* default: commands added out of a context */
if (CONTXT.STACK > 0)
   {
   for (nr=0; nr<MAX_CONTXT; nr++)           /* search for base context */
      {
      if (CONTXT.QUEUE[nr] == CONTXT.BASE)
         {
         jj = CONTXT.QUEUE[nr+CONTXT.STACK-1];       /* get current one */
         break;
         }
      }
   }


if ((LINE.STR[mm] == '"') &&
    (LINE.STR[LINE.LEN-1] == '"'))           /* remove surrounding '"' */
   {
   mm ++;
   LINE.LEN -- ;
   LINE.STR[LINE.LEN] = '\0';
   }

if (*qualf == 'D')			/* check D_commands */
   {
   iwa = LINE.LEN - 1;				/* point to last char. */
   if (LINE.STR[iwa] != FSY_DIREND)
      {
      LINE.STR[++iwa] = FSY_DIREND;
      LINE.STR[++iwa] = '\0';
      LINE.LEN ++;
      }
   iwa = 0;
   }
else
   iwa = 1;

return(ADDCOM(command,qualif,jj,iwa,&LINE.STR[mm]));
}

/*

*/

int STORE_FR(wk_flag)

/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  handle the STORE/FRAME command

 STORE/FRAME key input element_no exit_label     

----------------------------------------------------------------------*/
int  *wk_flag;		/* OUT: 1 if simple write/keyword,
			        0 if not                      */

{
int  stat, catalkey[8], lcatal, unit, nullo, iwa, iav, nb, m, felm;

char  *cpntr, save[120];




*wk_flag = 0;

stat = SCKRDI("CATAL",1,8,&iav,catalkey,&unit,&nullo);  /* read 8 values */
if (stat != ERR_NORMAL)
   {
   SCTSYS("problems with keyword CATAL ");
   goto catal_out;
   }

if (TOKEN[3].STR[0] == '?')		/* get index into key CATAL   */
   felm = 0;				/* default is 1. element  */

else
   {
   float  rwa;
   double dwa;

   stat = CGN_CNVT(TOKEN[3].STR,1,1,&iwa,&rwa,&dwa);
   if ( (stat < 1) || (iwa < 1) || (iwa > iav) ) return (5);
          
   felm = iwa - 1;			/* move `felm' to C indexing */
   }

lcatal = catalkey[felm];
cpntr = FSY_DEFPNTR[6];
nb = CGN_INDEXS(TOKEN[2].STR,cpntr);
if (nb <= 0)
   {
   cpntr = FSY_DEFPNTR[15];                  /* look also for upper case */
   nb = CGN_INDEXS(TOKEN[2].STR,cpntr);
   if (nb <= 0)                              /* it's a simple WRITE/KEY  */
      {
      if (lcatal < 0)
         {
         for (m=0; m<iav; m++)     /* go on if other catalog still there */
            {
            if (catalkey[m] > 0) 
               {			/* continue like WRITE/KEY */
               *wk_flag = 1;
               return (0);
               }
            }
         goto catal_out;             /* No. This is really the end  */
         }

      catalkey[felm] = -1;
      (void) SCKWRI("CATAL",catalkey,1,iav,&unit);
      *wk_flag = 1;
      return (0);
      }
   }
       
/*  now handle the catalog stuff  */

if (lcatal < 0)
   {
   (void) sprintf(save,"catalog: %s already processed...",TOKEN[2].STR);
   SCTSYS(save);
   TOKEN[2].LEN = CGN_COPY(TOKEN[2].STR,"   ");
   goto catal_out;
   }


/*  get catalog info  */

(void) strcpy(TOKEN[9].STR,TOKEN[2].STR);
stat = SCCGET(TOKEN[9].STR,0,TOKEN[2].STR,save,&lcatal);
       
if (stat != ERR_NORMAL)                      /* check return from SCCGET  */
   {
   (void) sprintf(save,"problems with catalog %s",TOKEN[2].STR);
   SCTSYS(save);
   goto catal_out;
   }

catalkey[felm] = lcatal;
(void) SCKWRI("CATAL",catalkey,1,iav,&unit);  /* save current entry no.   */

TOKEN[2].LEN = (int) strlen(TOKEN[2].STR);     /* size of name in catalog */
if (TOKEN[2].STR[0] != ' ')
   {						/* continue like WRITE/KEY */
   *wk_flag = 1;
   return (0);
   }
       

/* get out of loop  */

catal_out:
(void) MID_CKLO(TOKEN[9].STR);

TOKEN[0].STR[0] = '*';		/* prepare command string for MYBATCH  */
TOKEN[0].STR[3] = '\0';
TOKEN[0].LEN = 3;
if (TOKEN[4].STR[0] == '?')
   {
   TOKEN[0].STR[1] = 'R';		/* RETURN statement  */
   TOKEN[0].STR[2] = 'E';
   }
else
   {
   TOKEN[0].STR[1] = 'G';		/* GOTO statement    */
   TOKEN[0].STR[2] = 'O';
   (void) strcpy(TOKEN[1].STR,TOKEN[4].STR);
   TOKEN[1].LEN = TOKEN[4].LEN;
   }

return (0);
}

/*

*/

int WAIT_SECS(string)

/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  handle the WAIT/SECS commands

 WAIT/SECS    no_of_secs 

----------------------------------------------------------------------*/
char *string;		/* IN: the no. of seconds to wait */

{
int   iwa, iav;
unsigned int milsecs;

float  rwa;

double dwa;



if (MONIT.COUNT < 2)
   rwa = 1.0;				/* default to 1 sec */
else
   {
   iav = CGN_CNVT(string,2,1,&iwa,&rwa,&dwa);
   if (iav < 1) return (100);
   }

if (rwa > 0.001)			/* WAIT 0 is a NOOP */
   {
   milsecs = (unsigned int) (rwa*1000.0);	/* units are millisecs */

   iav = MONIT.MXT[MONIT.LEVEL];	/* current timeout */
   if (iav > 0)
      {
      if (MONIT.LEVEL > 0)
         {
         iav = (int) (MONIT.ENDT[MONIT.LEVEL] - oshtime());
         if (iav < 1) return (0);		/* already timed out... */
         }
      iav *= 1000;                              /* `iav' was in seconds */
      if (milsecs > iav) milsecs = iav;         /* minimize with time left */
      }

   OSY_SLEEP(milsecs,1);
   }

return (0);
}

/*

*/

void WRITE_QU(qualif,retval)

/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  handle the WRITE commands

 WRITE/OUT  text  or  file.txt section label    
 WRITE/_OUT  file section label   (no special file type required)

 WRITE/ERROR      error no.  [text ... ]   

----------------------------------------------------------------------*/
char *qualif;		/* IN: the qualifier string of WRITE */
int  *retval;		/* OUT: for WRITE/ERROR we return the error_source
				value (10 = Monitor, 100 = Application */
{
int   n, iwa, iav, from, kk, stat; 
register int nr;

char  *cpntr, save[120];
register char  cc;




if (*qualif == 'E')			/* WRITE/ERROR part */
   {
   int  no_display_flag=0;
   float  rwa;
   double dwa;


   *retval = 10;			/* default to Monitor error */

   n = CGN_INDEXC(TOKEN[1].STR,',');
   if (n > 0)
      {
      TOKEN[1].STR[n++] = '\0';
      cc = TOKEN[1].STR[n];
      if ((cc == 'A') || (cc == 'a'))
         {
         char cb[40];

         *retval = 100;			/* application error */
         (void) strcpy(cb,&TOKEN[1].STR[n]);
         n = CGN_INDEXC(cb,',') + 1;
         if (n > 0) 
            {
            cc = cb[n];
            if ((cc == 'N') || (cc == 'n'))
               no_display_flag = 1;	/* no display, just -> MID$ERRMESS */
            }
         }
      }

   iav = CGN_CNVT(TOKEN[1].STR,1,1,&iwa,&rwa,&dwa);
   if (iav <= 0)
      {
      ERRORS.SYS = 5;		/* set ERRORS.SYS to "wrong syntax..." */
      *retval = 10;			/* and force to monitor error */
      }
   else
      ERRORS.SYS = iwa;

   iav = 0;
   if (no_display_flag == 1) KAUX.OUT[iav++] = ' ';

   if (MONIT.COUNT > 2)			/* construct special message */
      {
      for (n=2; n<MONIT.COUNT; n++)
         {
         if (TOKEN[n].STR[0] == '"')
            kk = 1;
         else
            kk = 0;
         (void) strcpy(&KAUX.OUT[iav],&TOKEN[n].STR[kk]);
         iav += (TOKEN[n].LEN - kk - kk);
         KAUX.OUT[iav++] = ' ';
         }
      KAUX.OUT[iav] = '\0';
      }
   else
      {
      if (*retval == 100)
         (void) sprintf(&KAUX.OUT[iav],"Error no. %d",ERRORS.SYS);
      else
         KAUX.OUT[0] = '\0';
      }

   LINE.STR[0] = '\0';			/* invalidate command line itself */
   return;
   }


/* from here on WRITE/OUT stuff */

if (*qualif == '_') goto file_section;     /* display a file (section) */

iwa = MONIT.COUNT - 1;
if ((TOKEN[iwa].STR[0] == '\\') && (TOKEN[iwa].STR[1] == '<'))
   {
   (void) strcpy(TOKEN[iwa].STR,&TOKEN[iwa].STR[1]);
   TOKEN[1].LEN --;
   }

iav = TOKEN[1].LEN;
if (iav < 5) goto single_line;

iav -= 4;
CGN_LOWCOPY(save,&TOKEN[1].STR[iav],5);
if (strcmp(save,".txt") != 0) goto single_line;


                        /*  o.k. we want to display a file (no processing) */
file_section:
if (TOKEN[2].STR[0] == '?') TOKEN[2].STR[0] = '\0';
stat = CGN_DISPFIL(TOKEN[1].STR,TOKEN[2].STR,TOKEN[3].STR);
if (stat != 0)
   {
   (void) sprintf(save,"file %s or given section not found",TOKEN[1].STR);
   SCTSYS(save);
   }
return;


/*  clean + write the LINE.STR to the terminal  */

single_line:
if (MONIT.COUNT >= 2)
   {
   cpntr = LINE.STR;
   for (n=1; n<MONIT.COUNT; n++)
      {
      from = 0;
      iav = TOKEN[n].LEN;
      if (TOKEN[n].STR[0] == '"')
         {
         if ((iav > 2) && (TOKEN[n].STR[iav-1] == '"'))
            {
            from = 1;
            iav -= 2;
            }
         }
      kk = 0;
      for (nr=from; nr<=iav; nr++)	/*  \{ and \}  ->  { and }  */
         {
         cc = TOKEN[n].STR[nr];
         KAUX.OUT[kk++] = cc;
         if (cc == '\\')
            {
            cc = TOKEN[n].STR[nr+1];
            if ((cc == '{') || (cc == '}')) kk --;
            }
         }
      KAUX.OUT[kk] = '\0';
      iav = CGN_COPY(cpntr,KAUX.OUT);
      cpntr += iav;
      *cpntr++ = ' ';			/* overwrite \0 with ' '  */
      }
   *(cpntr-1) = '\0';			/* avoid last added blank */
   }
else
   (void) strcpy(LINE.STR,"   ");

SCTPUT(LINE.STR);
}

/*

*/

/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  do statistics on Midas procedures

to switch on change the two \\s to `star' and /`star' respectively

the same has to be done also in `prepx' with the line
ProcStat()

to print the statistics you must create a procedure named StatProc.prg
with any valid Midas command in it, e.g.:
WRITE/OUT This is StatProc...
and do @@ StatProc

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



void StatProc()

{
int  k, m;
int  *ipntr, lowlim;
register int  nr;
static int  *procstat, procinit = 0, procno = 0, omit = 0;

char  *cpntr, *kpntr;
static char  *procpntr, *compntr;

#define  PROCMAX   200


if (procinit == 0)
   {
   procinit = 1;
   m = 24 * PROCMAX;
   procpntr = malloc((unsigned int)m);
   m = 4 * PROCMAX;
   compntr = malloc((unsigned int)m);
   m = sizeof(int) * PROCMAX;
   procstat = (int *) malloc((unsigned int)m);
   }

if (strcmp(TOKEN[1].STR,"StatProc") == 0)
   {
   char  output[80];

   if (MONIT.COUNT > 2)
      lowlim = atoi(TOKEN[2].STR);
   else
      lowlim = 0;			/* all entries */
   cpntr = procpntr;
   kpntr = compntr;
   ipntr = procstat;
   for (nr=0; nr<procno; nr++)
      {
      m = *ipntr++;
      if (m > lowlim)
         {
         (void) sprintf(output,"(%s) %s: %d",kpntr,cpntr,m);
         SCTPUT(output);
         }
      cpntr += 24;
      kpntr += 4;
      }
   SCTPUT("   ");
   (void) sprintf(output,"lowlim used = %d",lowlim);
   SCTPUT(output);
   if (omit > 0)
      {
      (void) sprintf(output,"%d procedures omitted...",omit);
      SCTPUT(output);
      }
   return;
   }


cpntr = procpntr;
for (nr=0; nr<procno; nr++)
   {
   k = strcmp(TOKEN[1].STR,cpntr);
   if (k == 0)
      {
      ipntr = procstat + nr;
      *ipntr += 1;
      return;
      }
   cpntr += 24;
   }

if (procno < PROCMAX)
   {
   kpntr = compntr + (procno*4);
   cpntr = procpntr + (procno*24);
   if (TOKEN[1].LEN > 23)
      {
      (void) memcpy(cpntr,TOKEN[1].STR,(size_t)23);
      *(cpntr+23) = '\0';
      }
   else
      (void) memcpy(cpntr,TOKEN[1].STR,(size_t)(TOKEN[1].LEN+1));
   (void) strcpy(kpntr,TOKEN[0].STR);
   ipntr = procstat + procno;
   *ipntr = 1;
   procno ++;
   }
else
   {
   if (omit == 0) (void) printf
      ("StatProc: max. no. of procedures (%d) reached...\n",PROCMAX);
   omit ++;
   }
}