/* @(#)prepc3.c	17.1.1.1 (ESO-DMD) 01/25/02 17:37:44 */
/*===========================================================================
  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 PREPC3  +++++++++++++++++++++
.LANGUAGE  C
.IDENTIFICATION	Module PREPC3
.AUTHOR		K. Banse                  ESO - Garching
.KEYWORDS
  MIDAS monitor
.COMMENTS
  holds Parse2, FRAMACC, PIXEL_ACCESS,
        CODE_ALLOC, CODE_FREE, INTERNAL,
        fixout, opti_code, is_label, opti_info, noprocess

.VERSION [1.00] 930126: pulled out from original PREPC.C

 020114		last modif

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

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

#include  <fcntl.h>
#include <stdlib.h>

/*

*/

int Parse2(sww,start)
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  check for ASCII outfile + get all TOKENs
.ALGORITHM
  painfully straight forward
.RETURNS
  return no. of tokens on line
---------------------------------------------------------------------*/

int   sww;	/* IN: same switch as `sw' of PARSE */
int start;	/* IN: start index of LINE.STR */

{
int   lsave, ascout;
int   n, count, nn, snr, kk;
register int  nr;

static char   blank = {' '};
register char  sngc;



/* search for  >file  or  >>file  as last token */

ascout = -1;
for (nr=LINE.LEN-1; nr>start; nr--)		/* skip trailing blanks */
   {
   if (LINE.STR[nr] != ' ') 
      {
      LINE.LEN = nr + 1;
      LINE.STR[LINE.LEN] = '\0';
      nn = nr - 2;
      goto real_check;
      }
   }
return (0);			/* nothing there... */


real_check:
for (nr=nn; nr>start; nr--)
   {
   if (LINE.STR[nr] == ' ')			/* isolate last TOKEN */
      {
      if (LINE.STR[nr+1] == '>')
         {
         if (LINE.STR[nr+2] == '>')		/* >>file  appends */
            {
            n = 2;
            sngc = CGN_UPPER(LINE.STR[nr+3]);
            }
         else					/* >file  opens new one */
            {
            n = 1;
            sngc = CGN_UPPER(LINE.STR[nr+2]);
            }
         if ((sngc >= 'A') && (sngc <= 'Z'))
            {				/* files must begin with alpha_char */
            ascout = nr + n + 1;
            snr = nr;
            }
         }
      break;
      }
   }

if ((ascout > 0) && (sww > 0))
   {
   int  outidx, size;
   register int  mr;


   if (LINE.STR[LINE.LEN-1] == '"')	/* we are enclosed by '"' ... */
      goto do_parsing;

   if (ishostcom(LINE.STR+start) == 1)	/* ignore for host commands */
      goto do_parsing;

   if (KIWORDS[OFF_OUTFLG] != 99)		/* look for back storage */
      {
      for (nr=0; nr<5; nr++)
         {
         if (REDIRECT[nr].OUTFLAG[0] == KIWORDS[OFF_OUTFLG])
            {					   /* always update `fp' */
            REDIRECT[nr].OUTFLAG[2] = KIWORDS[OFF_OUTFLG+2];
            break;
            }
         }
      }

   outidx = -1;
   for (nr=0; nr<5; nr++)
      {
      if (REDIRECT[nr].OUTFLAG[0] == 99)
         {
         outidx = nr;
         break;
         }
      }

   if (outidx == -1)
      SCTPUT("too many redirections - this one ignored...");
   
   else
      {
      KIWORDS[OFF_OUTFLG+1] = 0;
      mr = CGN_INDEXC(&LINE.STR[ascout],'+');
      if (mr > 0) 
         {
         mr += ascout + 1;
         if ((LINE.STR[mr] == 't') || (LINE.STR[mr] == 'T'))
            {
            KIWORDS[OFF_OUTFLG+1] = 1;
            LINE.STR[mr-1] = '\0';		/* ','  =>  '\0'  */
            }
         }
      else
         {
         CGN_UPCOPY(KAUX.OUT,&LINE.STR[ascout],9);
         if (strcmp(KAUX.OUT,"TERMINAL") == 0)
            {
            LINE.LEN = snr;
            LINE.STR[snr] = '\0';
            goto do_parsing;			/* no file output */
            }
         }


      /* finally check, if replacements needed:  >{..}  */

      size = CGN_COPY(KAUX.OUT,&LINE.STR[ascout]);
      if (size > 64)			/* max. 64 chars for ASCII file */
         {
         ERRORS.SYS = 38;
         PREPERR("MIDAS",LINE.STR,KAUX.OUT);
         return (-1);
         }

     sect_2100:
      kk = CGN_INDEXC(KAUX.OUT,'{');
      if (kk >= 0)               /* if { found, look for last nestings */
         {
         char  wbuf[72];
         int   stat, left, mm;

        sect_2200:
         nn = CGN_INDEXC(&KAUX.OUT[kk+1],'{');
         if (nn >= 0)
            {
            kk += (nn + 1);
            goto sect_2200;                        /* loop...  */
            }
         (void) strcpy(wbuf,&KAUX.OUT[kk+1]);
         if ((lsave = CGN_INDEXC(wbuf,'}')) < 0) goto sect_2500;

         mm = kk + lsave + 2;	/* save offset after variable */
         left = size - mm;	/* remaining chars. in AUX.OUT */
      
         stat = REPLACE(wbuf,&lsave,64);
         size = kk + lsave + left;
         if ((stat < 0) || (size > 64))
            {
            ERRORS.SYS = 38;
            PREPERR("MIDAS",LINE.STR,KAUX.OUT);
            return (-1);
            }

         (void) strcpy(&wbuf[lsave],&KAUX.OUT[mm]);
         (void) strcpy(&KAUX.OUT[kk],wbuf);
         goto sect_2100;
         }

     sect_2500:
      (void) strcpy(&KCWORDS[OFF_OUTNAM],KAUX.OUT);
      KIWORDS[OFF_OUTFLG] = MONIT.LEVEL;
      KIWORDS[OFF_OUTFLG+2] = -1;		/* file not opened yet */
      KIWORDS[OFF_OUTFLG+3] = -n;		/* so -2 for appending */

      /* save in internal structure REDIRECT */

      for (nr=0; nr<4; nr++)
         REDIRECT[outidx].OUTFLAG[nr] = KIWORDS[OFF_OUTFLG+nr];
      (void) strcpy(REDIRECT[outidx].OUTFILE,KAUX.OUT);
      }

   LINE.LEN = snr;
   LINE.STR[snr] = '\0';
   }


/*  extract all tokens + get their length */

do_parsing:
for (n=0; n<10; n++)
   {
   TOKEN[n].LEN = 
      CGN_EXTRSS(LINE.STR,LINE.LEN,blank,&start,TOKEN[n].STR,MAX_TOKEN);
   if (TOKEN[n].LEN <= 0)                       /* end of parsing reached... */
      {
      if (TOKEN[n].LEN == -2)                   /* overflow of single token */
         {
         ERRORS.SYS = 7;
         PREPERR("MIDAS",LINE.STR,TOKEN[n].STR);
         return (-1);
         }

      count = n ;
      for (nr=count; nr<10; nr++)
         {
         TOKEN[nr].STR[0] = '?';             /* init empty TOKEN + LTOKEN  */
         TOKEN[nr].STR[1] = '\0' ;
         TOKEN[nr].LEN = 1 ;
         }
      return (count);
      }
   }

count = 10;


/*  garbage collection of more tokens...  */

nn = TOKEN[9].LEN;
while ((lsave = 
        CGN_EXTRSS(LINE.STR,LINE.LEN,blank,&start,KAUX.OUT,MAX_TOKEN)) > 0)   
   {
   if (sww == -1) return (-99);		/* in diagnostic mode flag that */

   if ((lsave+nn+1) > MAX_TOKEN)
      {
      kk = MAX_TOKEN - nn;
      lsave = 0;			/* force it to break later on */
      }
   else
      {
      TOKEN[9].STR[nn++] = ' ';
      kk = lsave;
      }
   (void) strncpy(&TOKEN[9].STR[nn],KAUX.OUT,kk);
   nn += kk;

   if (lsave <= 0) break;
   }


TOKEN[9].STR[nn] = '\0' ;
TOKEN[9].LEN = nn;

return (count);
}

/*

*/

#ifdef __STDC__
void FRAMACC(char actio, char *filnam, int ity, int *entrx)
#else
void FRAMACC(actio,filnam,ity,entrx)
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  open image or table and close files if necessary
.ALGORITHM
  straight forward
.RETURNS
  nothing
------------------------------------------------------------------*/

char     actio;         /* IN: 'X', close all frames in structure FRAME  
                               'C', close `filnam' + delete from FRAME  
                               'I', init structure FRAME               
                               'O', open `filnam' + add to FRAME   */
char     *filnam;       /* IN: file name */
int ity;		/* IN: file type - 1 = image, 2 = table, 0 = unknown */
int *entrx;		/* IN/OUT: MIDAS file id */
#endif

{
static int level_now = -1;              /* so `init' does not return */
int   stat, jent, k, nn, ibuf[9];
register int  nr;

char  kframe[MAX_TOKEN], temp[MAX_TOKEN];
register char  *fptr;



if (actio == 'O')               /*  here for opening image or table */
   {
   k = -123;			/* use as intermediate switch */

   if (ity == 0)
      {						/* test, if image or table */
      nn = CGN_singleframe(filnam,F_IMA_TYPE,kframe);	/* check for &a, ...*/
      if (nn == 0)				/* depending upon transl. */
         fptr = filnam;				/* fptr -> relevant name */
      else
         fptr = kframe;
      stat = SCFINF(fptr,9,ibuf);
      if (stat == ERR_NORMAL)
         {
         if (ibuf[1] == F_TBL_TYPE)
            ity = 2;
         else
            {
            k = 0;
            ity = 1;
            }
         }
      }

   if (KIWORDS[OFF_AUX+15] == 1)	/* ESO-DESC_ignore_flag set? */
      nn = 1;				/* Yes => read no ESO.xyz keywds */
   else
      nn = 0;				/* No. */
   (void) SCPSET(F_FITS_PARM,&nn);

   if (ity == 1)				/* open image */
      {
      if (k < 0)
         {
         nn = CGN_singleframe(filnam,F_IMA_TYPE,kframe); /* check for &a, ...*/
         if (nn == 0)				/* depending upon transl. */
            fptr = filnam;			/* fptr -> relevant name */
         else
            fptr = kframe;
         }
      CGN_CLEANF(fptr,F_IMA_TYPE,temp,FCT_NAME_LEN,&k,&nn);
      if (nn < 0)			/* if we have a FITS extension */
         jent = -1;			/* force fresh openeing! */
      else
         jent = MID_FINDFR(temp);

      if (jent < 0)				/* not opened yet */
         stat = SCFOPN(fptr,D_R4_FORMAT,0,F_OLD_TYPE,entrx);
      else
         stat = MID_ACCFRM(temp,0,entrx,ibuf);
      }
   else if (ity == 2)				/* open table */
      {
      nn = CGN_singleframe(filnam,F_TBL_TYPE,kframe);	/* check for &a, ...*/
      if (nn == 0)				/* depending upon transl. */
         fptr = filnam;				/* fptr -> relevant name */
      else
         fptr = kframe;
      CGN_CLEANF(fptr,F_TBL_TYPE,temp,FCT_NAME_LEN,&k,&nn);

      jent = MID_FINDFR(temp);
      if (jent < 0)				/* not opened yet */
         {
#if vms 
         stat = TCTOPN(fptr,F_IO_MODE,entrx);
         if (stat != ERR_NORMAL)
            stat = TCTOPN(fptr,F_I_MODE,entrx);

#else
        /* jent = osmopen(temp,READ_WRITE);         check, if READ+WRITE */
         jent = open(temp,O_RDWR);	 /* check, if READ+WRITE */
         if (jent == -1)			/* No. */
            stat = TCTOPN(fptr,F_I_MODE,entrx);
         else
            {
            /* osmclose(jent);*/
            close(jent); 
            stat = TCTOPN(fptr,F_IO_MODE,entrx);
            }
#endif
         }
      else		
         stat = MID_ACCFRM(temp,0,entrx,ibuf);
      }

   if (stat != ERR_NORMAL)
      {
      ERRORS.SYS = 44;
      *entrx = -1;
      return;
      }

   jent = (*entrx);

   for (nr=0; nr<MAX_FRAME; nr++)               /* check, if already there */
      {
      if (jent == FRAME[nr].ENTRY) return;
      }

                              
/* now loop through table FRAME_STRUCT + look for free entry  */

   for (nr=0; nr<MAX_FRAME; nr++)               /* search for free entry  */
      {
      if (FRAME[nr].ENTRY < 0)
         {
         k = nr;
         goto add_entry;
         }
      }


/* no free entry, so we get rid of oldest file */

   k = 0;
   nn = FRAME[0].LEVEL;
   for (nr=1; nr<MAX_FRAME; nr++)               /* search for oldest entry  */
      {
      if (FRAME[nr].LEVEL < nn)
         {
         k = nr;
         nn = FRAME[nr].LEVEL;
         }
      }

   if (FRAME[k].TYPE == 1)
      stat = SCFCLO(FRAME[k].ENTRY);
   else
      stat = TCTCLO(FRAME[k].ENTRY);
   if (stat != ERR_NORMAL)
      {
      ERRORS.SYS = 36;
      *entrx = -1;
      return;
      }

add_entry:
   FRAME[k].ENTRY = jent;
   FRAME[k].TYPE = ity;
   FRAME[k].LEVEL = level_now++;

   MONIT.FRAME_USED = 'x';
   }

else
   {
   if (level_now == 0) return;                  /* nothing to do */

   if (actio == 'X')				/* close all frames */
      {
      for (nr=0; nr<MAX_FRAME; nr++)
         {
         if (FRAME[nr].ENTRY >= 0)
            {
            if (FRAME[nr].TYPE == 1)
               stat = SCFCLO(FRAME[nr].ENTRY);
            else
               stat = TCTCLO(FRAME[nr].ENTRY);
            FRAME[nr].ENTRY = -1;
            }
         }
      }

   else if (actio == 'C')				/* close a frame */
      {
      jent =  *entrx;
      for (nr=0; nr<MAX_FRAME; nr++)
         {
         if (FRAME[nr].ENTRY == jent)
            {
            if (FRAME[nr].TYPE == 1)
               stat = SCFCLO(jent);
            else
               stat = TCTCLO(jent);
            FRAME[nr].ENTRY = -1;
            break;
            }
         }

      for (nr=0; nr<MAX_FRAME; nr++)		/* check, if any is left */
         {
         if (FRAME[nr].ENTRY >= 0) return;
         }
      }
   else						/* only INIT is left... */
      {
      for (nr=0; nr<MAX_FRAME; nr++)
         FRAME[nr].ENTRY = -1;
      }

   level_now = 0;
   MONIT.FRAME_USED = ' ';
   }

}

/*

*/

int PIXEL_ACCESS(flag,string,value)
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  return value of image frame at given coordinates
.ALGORITHM
  open frame + get to pixel in a subroutine
.RETURNS
  status: MIDAS error codes
------------------------------------------------------------------*/

int   flag;		/* IN: = 0, read pixel value     
			       = 1, write pixel value   */
char  *string;		/* IN: string with frame[x,y,z] */
float *value;		/* IN/OUT: pixel value at frame[x,y,z]  */

{
int   stat, n, nco, entrx, npix[3], unit, iav;
int   ioffz, ioffy, sublo[3], subhi[3];



for (n=0; n<3; n++)
   {
   sublo[n] = 0;
   npix[n] = 1;
   }

nco = CGN_INDEXC(string,'[');		/* split frame and coords string  */
string[nco] = '\0';
iav = CGN_singleframe(string,F_IMA_TYPE,KAUX.OUT);	
if (iav == 0) (void) strcpy(KAUX.OUT,string);	/* always fill output name */
string[nco] = '[';			/* reset string */

FRAMACC('O',KAUX.OUT,1,&entrx);		/*  open the image + get NPIX */
if (entrx < 0) goto sect_9000;

stat = SCDRDI(entrx,"NPIX",1,3,&iav,npix,&unit,&n);
if (stat != ERR_NORMAL) goto sect_9000;
 
stat = Convcoo(0,entrx,&string[nco],3,&iav,sublo,subhi);
if (stat != ERR_NORMAL) 
   {
   ERRORS.SYS = 45;
   FRAMACC('C',KAUX.OUT,1,&entrx);                    /* close file */
   return (-1);
   }

if (sublo[2] > 0)
   ioffz = npix[0] * npix[1] * sublo[2];
else
   ioffz = 0;
ioffy = npix[0] * sublo[1];
nco = ioffz + ioffy + sublo[0] + 1;

if (flag == 0)					/*  read or write value  */
   n = SCFGET(entrx,nco,1,&iav,(char *)value);
else
   n = SCFPUT(entrx,nco,1,(char *)value);
if (n == ERR_NORMAL) return (0);


sect_9000:					/*  problems, problems...   */
ERRORS.SYS = 100;
return (-1);
}

/*

*/

int CODE_ALLOC(size)

/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  allocate `size' bytes memory for CODE
.ALGORITHM
  use malloc + free
.RETURNS
  return status = 0, if all o.k., = 1, if problems in allocating memory
----------------------------------------------------------------------*/

int   size;   /* IN: no. of bytes for allocation */

{
int   n, levl;


if (size <= 0)
   size = CODE_BLOCKS * BLOCK_SIZE;		/* default size */

levl = MONIT.LEVEL - 1;
n = TRANSLATE[levl].LEN[0];

if (n == 0) 
   {
   CODE.CODE = malloc((unsigned int) size);
   n = CODE_START;
   memset((void *)CODE.CODE,0,(size_t)n);	/* clear header section */
   }

else
   {
   if (n < size)			/* we need large space now */
      {
      free(TRANSLATE[levl].PNTR[0]);
      CODE.CODE = malloc((unsigned int) size);
      n = CODE_START;
      memset((void *)CODE.CODE,0,(size_t)n);	/* clear header section */
      }
   else					/* use allocated space again */
      {
      CODE.LEN = TRANSLATE[levl].LEN[0];
      CODE.CODE = TRANSLATE[levl].PNTR[0];
      KIWORDS[OFF_MONPAR+7] = size;          /* save also in key MONITPAR(8) */
      return (0);
      }
   }

if (CODE.CODE == NULL) 			/* problems with memory allocation */
   {
   TRANSLATE[levl].LEN[0] = 0;
   return (1);
   }
else
   {
   CODE.LEN = size;
   TRANSLATE[levl].PNTR[0] = CODE.CODE;
   TRANSLATE[levl].LEN[0] = CODE.LEN;
   KIWORDS[OFF_MONPAR+7] = size;           /* save also in key MONITPAR(8) */
   return (0);
   }
}

/*

*/

void CODE_FREE(levl,indx)

/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  clear memory which was allocated for CODE
.ALGORITHM
  use free
.RETURNS
  nothing
----------------------------------------------------------------------*/

int   levl;   /* IN: MONIT level we work on */
int   indx;   /* IN: index for TRANSLATE array,               \
			  = 0 for normal CODE, = 1 for PAUSE code */

{
register int  nr;


if (indx != 0) indx = 1;

for (nr=levl; nr<MAX_LEVEL; nr++)
   {
   if (TRANSLATE[nr].LEN[indx] != 0)
      {
      free(TRANSLATE[nr].PNTR[indx]);
      TRANSLATE[nr].LEN[indx] = 0;
      }
   }

}

/*

*/
 
int INTERNAL(action,name,nobytes)
	
/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  provide the interface to the file MID_PROC:internal.cod,
  which holds all "compiled" MIDAS (system) procedures
.ALGORITHM
  The file MID_PROC:internal.cod is organized as follows:
  first 4 records (of 512 bytes) hold the procedure names of max. 12 chars
  (without the terminating '\0'),
  the end of this area is indicated via '&&' .
  Records 5+6 hold the array of start blocks and no. of bytes for each 
  compiled procedure stored as two unsigned short int numbers,
  the end of this area is indicated via a start block of 0.
  The following records hold the translated code for each procedure, each
  beginning at a record.
  The end of the written records is indicated by a record beginning
  with 20 blanks.
.RETURNS
  return status			0 = o.k., else not...!
--------------------------------------------------------------------*/
 
char  *action;	/* IN: action flag,                                    
 		       = OPEN for opening the file internal.cod, .kod  
		       = CLOSE for closing the file                   
		       = ADD for adding another entry +  code        
		       = FIND for finding an entry + reading the code */
 
char  *name;	/* IN: name of procedure, for A or F      
		       max. 12 chars. and terminator;
                       = KOD or COD for action = OPEN */
int   *nobytes;	/* IO: length of procedure, input for A, output for F */
 
{
#define BIT_0    0x1
#define head_len 3072
#define PROC_MXLEN   12
 
int     mm, n, noblocks, flen, stat;
register int nr;
static unsigned short int   *rec_nos;
static int   NoProcs;
static int   iochan = -1;

char  *cpntr;
char  fulname[PROC_MXLEN];
static char  *headrec;			/* point to header record  */
 
void opti_code();
	


 
/*  open file MID_PROC:internal.cod or .kod   */
	
if (*action == 'O')
   {
   char	file[200];

   headrec = (char *) CODE.WORK;		/* CODE.WORK is double */
   rec_nos = (unsigned short int *) &headrec[2048];
   NoProcs = 2048 / PROC_MXLEN;

   (void) OSY_TRNLOG("MID_PROC",file,200,&mm);
#if vms
   if (file[mm-1] != FSY_DISKEND)
      {
      if (file[mm-1] != FSY_DIREND) file[mm++] = FSY_DIREND;
      }
#else
   if (file[mm-1] != FSY_DIREND) file[mm++] = FSY_DIREND;
#endif
   (void)strcpy(&file[mm],"internal.cod");

   mm = (int)strlen(file);
   if (*name == 'K') file[mm-3] = 'k';		/* .kod instead of .cod */
 
   FSY_OPNFIL(file,mm,&iochan,&stat);
   if (stat & BIT_0 )
      return (0);					/*  successful  */
   else
      {
      iochan = -1;
      return (2);				/*  no. some problems...  */
      }
   }
 
	
/*  or close file   */
 
else if (*action == 'C')
   {
   stat = OSY_DASSGN(-1,iochan);
   iochan = -1;
   return (0);
   }
 
	
/*  find a procedure + translated code   */

if (iochan == -1) return(2);			/* no `internal.cod' there */

flen = (int)strlen(name);
if (flen > PROC_MXLEN) return(3);
CGN_FILL(fulname,' ',PROC_MXLEN);
(void) strncpy(fulname,name,flen);
	
if (*action == 'F')
   {
   if (OSY_RVB(iochan,headrec,head_len,1) != 0) return (1);
	
   cpntr = headrec;
   mm = 0;
   for (nr=0; nr<NoProcs; nr++)
      {						/* locate procedure name  */
      if (strncmp(cpntr,fulname,PROC_MXLEN) == 0) goto get_recno;
          
      mm += 2;
      cpntr += PROC_MXLEN;
      }
   return (1);					/* not found! */
 
	
   /*  now get the start block and length   */
 
get_recno:
   *nobytes = rec_nos[mm+1];
   stat = OSY_RVB(iochan,CODE.CODE,*nobytes,rec_nos[mm]);
   if (stat != 0)
      return (1);
   else
      {
      CODE.CODE[(*nobytes)] = '\0';
      return (0);
      }
   }
 
	
/*  add a procedure + translated code   */
	
else
   {
   stat = OSY_RVB(iochan,headrec,head_len,1);
   if (stat != 0) return (1);
	
   cpntr = headrec;
   mm = 0;
   n = 0;					/* found_switch */
   for (nr=0; nr<NoProcs; nr++)
      {                                         /* locate procedure name  */
      if (strncmp(cpntr,fulname,PROC_MXLEN) == 0)
         {
         n = 1;
         break;
         }
      else if ((*cpntr == '&') && (*(cpntr+1) == '&')) break;

      mm += 2;
      cpntr += PROC_MXLEN;
      }
	
   if (n < 1) 					/*  if not found ...    */
      {
      if ((*cpntr == '&') && (*(cpntr+1) == '&')) 
         {
         (void)strncpy(cpntr,fulname,PROC_MXLEN);
         cpntr += PROC_MXLEN;
         *cpntr++ = '&';		/* insert new end marker */
         *cpntr = '&';
         }
      else
         {
         (void) printf
         ("Overflow in internal.cod, more than 100 procedures...\n");
         return (1);
         }
      }
   }
	
/*  now rewrite header records (1-6) and code record(s)  */
 
n = KIWORDS[OFF_MONPAR+10];		/* MONITPAR(11) = debug flag */
opti_code(nobytes,0,n);			/* optimize code for system proc. */

if (*nobytes > 65000)
   {
   (void) printf
   ("Overflow in code size, more than 65000 chars. in procedure\n");
   return (1);
   }

noblocks = ( (*nobytes - 1) / BLOCK_SIZE ) + 1 ;
rec_nos[mm+1] = (unsigned short int) *nobytes;
rec_nos[mm+2] = rec_nos[mm] + (unsigned short int) noblocks;
stat = OSY_WVB(iochan,headrec,head_len,1);
stat = OSY_WVB(iochan,CODE.CODE,*nobytes,rec_nos[mm]);
if (stat != 0)
   return (1);
else
   return (0);
}

/*

*/

void fixout(run,curlevl)
int  run;		/* IN: = 0. end of procedure - go back up a level
			         1, start a program */
int  curlevl;		/* IN: current procedure level (MONIT.LEVEL) */

{
int    savnr, newlevl, iolevl, fp;
register int   nr;



if ((run == 0) && (curlevl == 0))	/* we're at interactive level */
					/* so clean up everything */
   {
   for (nr=0; nr<5; nr++)
      {
      if (REDIRECT[nr].OUTFLAG[0] != 99)
         {
         fp = REDIRECT[nr].OUTFLAG[2];
         if ((fp > 0) && (fp < 999)) (void) osaclose(fp);
         REDIRECT[nr].OUTFLAG[0] = 99;
         }
      }

   fp = KIWORDS[OFF_OUTFLG+2];			  /* only this one set, if */
   if ((fp > 0) && (fp < 999)) (void) osaclose(fp);	/* done in monitor */

   KIWORDS[OFF_OUTFLG] = 99;
   return;
   }


if (KIWORDS[OFF_OUTFLG] == 99) return;			/* nothing to do */


if (run == 0)			/* go up a level */
   {
   if (KIWORDS[OFF_OUTFLG] >= curlevl)
      {
      for (nr=0; nr<5; nr++)
         {
         iolevl = REDIRECT[nr].OUTFLAG[0];
         if ((iolevl != 99) && (iolevl >= curlevl))
            {
            fp = REDIRECT[nr].OUTFLAG[2];
            if ((fp > 0) && (fp < 999)) (void) osaclose(fp);
            REDIRECT[nr].OUTFLAG[0] = 99;
            break;
            }
         }

      fp = KIWORDS[OFF_OUTFLG+2];		  /* only this one set, if */
      if ((fp > 0) && (fp < 999)) (void) osaclose(fp);	/* done in monitor */


      newlevl = -1;			/* look for iochanges before */
      for (nr=0; nr<5; nr++)		/* but take the last one */
         {
         iolevl = REDIRECT[nr].OUTFLAG[0];
         if ((iolevl != 99) && (newlevl < iolevl))
            {
            savnr = nr;
            newlevl = iolevl;
            }
         }

      if (newlevl != -1)
         {				/* copy flags + file name */
         for (nr=0; nr<4; nr++)
             KIWORDS[OFF_OUTFLG+nr] = REDIRECT[savnr].OUTFLAG[nr];
         (void) strcpy(&KCWORDS[OFF_OUTNAM],REDIRECT[savnr].OUTFILE);
         KIWORDS[OFF_OUTFLG+3] = -2;	/* so we can append */
         }
      else
         KIWORDS[OFF_OUTFLG] = 99;
      }

   else
      {
      fp = KIWORDS[OFF_OUTFLG+2];
      if ((fp > 0) && (fp < 999))	/* output file already open */
         KIWORDS[OFF_OUTFLG+3] = -2;	/* so we can append */
      }
   }


else				/* or prepare for application */
   {
   fp = KIWORDS[OFF_OUTFLG+2];
   if ((fp > 0) && (fp < 999))
      {					/* file already used in monitor */
      (void) osaclose(fp);
      KIWORDS[OFF_OUTFLG+2] = -1;
      KIWORDS[OFF_OUTFLG+3] = -2;	/* so we can append */
      }
   }
}

/*

*/

void opti_code(nb,option,dflag)
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  optimize the code of a compiled procedure
.ALGORITHM
.RETURNS
---------------------------------------------------------------------*/
int  *nb;               /* IN/OUT: no. of bytes of code */
int  option;		/* IN: = 0, optimize for TRANSL/ADD
			       = 1, optimize for TRANSL/PROC */
int  dflag;		/* IN: = 1, save input, output code on file,
			       = 0, no save (for debugging )	   */

{
int   jj, kk, dd, m, mm, nc, label_used;
int   lenA, lenB, offset, double_lab, offmin;

char  *cpntr, *xpntr, *opntr, *tpntr, *dpntr, *savpntr;
char  labelA[24], labelB[24], labelUp[24];
static char *fmts[6] = {"%03.3d", "%04.4d", "%05.5d", "%06.6d",
                        "%07.7d", "%08.8d"};

void opti_info();




nc = (*nb - CODE_START);			/* current size of code */
offmin = 3;
if (nc > 999)
   {					/* get no. of digits needed */
   if (nc > 9999)			/* for offsets */
      {
      if (nc > 99999) 
         offmin = 6;
      else
         offmin = 5;
      }
   else
      offmin = 4;
   }


m = nc + 4;			
cpntr = malloc((unsigned int) m);		/* for security */
(void) memcpy(cpntr,&CODE.CODE[CODE_START],(size_t)nc);
*(cpntr+nc) = '\r';
*(cpntr+nc+1) = '\0';
savpntr = cpntr;

if (dflag == 1) opti_info(cpntr,1);


/* -------------------------- first step ------------------------- */
/* check if last command is a label                                */

start_job:
tpntr = cpntr;					/* point to start of code */
double_lab = 0;		/* if set, we have a double label in the end */
dpntr = xpntr = tpntr;

read_1:				/* get a line from orig code */
m = CGN_INDEXC(tpntr,'\r');
if (m == 0) 
   {					/* end of code reached */
   dd = is_label(dpntr,xpntr);
   if ((dd == 1) && (kk > 4))			/* we got a label */
      {
      lenA = kk - 1;
      (void) strncpy(labelA,dpntr,lenA);	/* omit trailing ':' */
      labelA[lenA] = '\0';
      jj = noprocess(labelA,cpntr);
      if (jj == 1) goto next_job;

      (void) strcpy(labelB,"*RE");
      lenB = 3;
      *dpntr++ = '\r';			/* indicate new end */
      *dpntr++ = '\r';
      *dpntr = '\0';
      if (dflag > 0)
         (void) printf("removing last label `%s'\n",labelA);
      }
   else
      goto next_job;			/* No, do next job */
   }
else				/* process line */
   {
   dpntr = tpntr;			/* keep last offset */
   xpntr = tpntr + m - 1; 		/* point to last char of that line */
   tpntr += (m+1);
   kk = m;				/* save length of line */
   goto read_1;
   }


/* we get here only if last command is a label 
   so, replace all references to that label with '*RE'  */

tpntr = cpntr;				/* reset to start of code */

read_10:	
m = CGN_INDEXC(tpntr,'\r');
if (m > 0) 
   {
   if (*tpntr == '*')			/* look for *IF, *GO only */
      {
      opntr = tpntr + 1;
      if ((strncmp(opntr,"IF",2) == 0) || (strncmp(opntr,"GO",2) == 0))
         {
         *(tpntr + m) = '\0';		/* replace \r by \0 for the moment */
         jj = CGN_JNDEXC(tpntr,' ');	/* search from the end */
         if (jj < 3) goto errors;

         xpntr = opntr + jj;		/* get to label itself */
         if (strcmp(xpntr,labelA) == 0)
            {
            double_lab = 1;
            if (*opntr == 'G')
               xpntr = tpntr;		/*  *GO label  =>  *RE  */
            (void) strcpy(xpntr,labelB);
            dpntr = xpntr + lenB;
            *dpntr++ = '\r';            /* overwrite '\0' with '\r' */
            if (lenA > lenB)
               (void) strcpy(dpntr,tpntr+m+1);
            tpntr = dpntr;
            goto read_10;
            }
         *(tpntr + m) = '\r';		/* reset */
         }
      }
   tpntr += (m+1);				/* move on */
   goto read_10;
   }
else
   {
   if (double_lab == 0) 
      (void) printf("last label `%s' not used...\n",labelA);
   else
      goto start_job;		/* do it again */
   }


/* ------------------------- second step ------------------------- */
/* remove double labels                                            */

double_lab = 0;		/* if set, we had a double label */


next_job:
tpntr = cpntr;
mm = 0;			/* serves as previous label flag */

read_2:
m = CGN_INDEXC(tpntr,'\r');
if (m == 0) 
   {
   if (double_lab == 1)		/* once more, to also get triple labels */
      {
      double_lab = 0;
      goto next_job;
      }
   else
      {
      savpntr = cpntr;
      goto next_next_job;		/* no more double labels found */
      }
   }

xpntr = tpntr + m - 1; 		/* point to last char of that line */
dpntr = tpntr;
dd = is_label(dpntr,xpntr);
if (dd == 1)				/* we got a label */
   {
   if (mm == 1)
      {					/* second label found */
      int  n;
      char temp[24];

      lenB = m - 1;			/* size of labelB (without `:') */
      (void) strncpy(labelB,dpntr,lenB);
      labelB[lenB] = '\0';
      if (lenA < lenB)
         {				/* use shorter label as labelB */
         (void) strcpy(temp,labelB);
         (void) strcpy(labelB,labelA);
         (void) strcpy(labelA,temp);
         n = lenB;
         lenB = lenA;
         lenA = n;
         }
      CGN_UPSTR(labelA);
      CGN_UPSTR(labelB);

      /* but first we have to check, that the label is not used
         by a BRANCH (*BR) command ...                          */
      
      n = noprocess(labelA,cpntr); 
      if (n == 1)			/* Yes, so skip this one */
         dd = 0;
      else
         {
         double_lab = 1;
         (void) strcpy(opntr,labelB);	/* labelA overwritten with labelB */
         opntr += lenB;
         *opntr++ = ':';
         *opntr++ = '\r';
         (void) strcpy(opntr,tpntr+m+1);	/* overwrite second label */
         if (dflag > 0)
            (void) printf("working on double labels `%s' + `%s'\n",
                          labelA,labelB);
         goto duplicate_labels;
         }
      }
   else
      {
      lenA = m - 1;				/* size of labelA */
      (void) strncpy(labelA,dpntr,lenA);	/* omit trailing ':' */
      labelA[lenA] = '\0';
      opntr = dpntr;			/* save offset */
      }
   }
mm = dd;			/* save it */

tpntr += (m+1);			/* move to next line */
goto read_2;


duplicate_labels:
label_used = 0;
tpntr = cpntr;

read_20:
m = CGN_INDEXC(tpntr,'\r');
if (m != 0)
   {
   if (*tpntr == '*')              /* look for *IF, *GO, *INC */
      {
      opntr = tpntr + 1;
      if ((strncmp(opntr,"IF",2) == 0) ||
          (strncmp(opntr,"GO",2) == 0) ||
          (strncmp(opntr,"INC",3) == 0))
         {
         *(tpntr + m) = '\0';		/* replace \r by \0 for the moment */
         jj = CGN_JNDEXC(tpntr,' ');
         if (jj < 3) goto errors;

         xpntr = opntr + jj;		/* get to label itself */
         CGN_UPCOPY(labelUp,xpntr,24);	/* copy to uppercase */
         if (strcmp(labelUp,labelA) == 0)
            {
            label_used ++;
            (void) strcpy(xpntr,labelB);	
            dpntr = xpntr + lenB;
            *dpntr++ = '\r';		/* overwrite '\0' with '\r' */ 
            if (lenA > lenB) 
               (void) strcpy(dpntr,tpntr+m+1); 
            tpntr = dpntr;
            goto read_20;
            }
         *(tpntr + m) = '\r';			/* reset */
         }
      }
   tpntr += (m+1);
   goto read_20;
   }

if (label_used == 0)
   (void) printf(">>>>> double label `%s' not used...\n",labelA);
goto next_job;


/* ----------------------------- third step ---------------------------- */
/* translate all labels (with size > offmin (up to 8) chars) to offsets  */

next_next_job:
tpntr = savpntr;

read_3:
label_used = 0;
m = CGN_INDEXC(tpntr,'\r');
if (m == 0) goto end_of_it;		/* no more labels found, we're done */

if ((m > offmin) && (m < 9))		/* supported length of label */
   {
   xpntr = tpntr + m - 1; 		/* point to last char of that line */
   dpntr = tpntr;
   dd = is_label(dpntr,xpntr);
   if (dd == 1)				/* we got a label */
      {
      lenA = m - 1;
      (void) strncpy(labelA,dpntr,lenA);	/* omit trailing ':' */
      labelA[lenA] = '\0';
      CGN_UPSTR(labelA);

      kk = noprocess(labelA,cpntr);	/* check that it's not from a *BR */
      if (kk == 0)			/* No, so get it's offset */
         {
         if (dflag > 0)
            (void) printf("processing label `%s'\n",labelA);
         savpntr = tpntr;			/* save position */
         offset = tpntr - cpntr + CODE_START;	/* offset of this line */
         (void) strcpy(tpntr,tpntr+m+1);

         jj = m - 4;				/* get format for offset */
         sprintf(labelB,fmts[jj],offset);	/* 1234: => fmts[1]: %04.4d */
         lenB = (int)strlen(labelB);
         goto replace_labels;
         }
      }
   }

tpntr += (m+1);			/* move to next line */
goto read_3;


replace_labels:
tpntr = cpntr;

read_30:
m = CGN_INDEXC(tpntr,'\r');
if (m != 0)
   {
   if (*tpntr == '*')			/* look for *IF, *GO, *INC */
      {
      opntr = tpntr + 1;
      if ((strncmp(opntr,"IF",2) == 0) ||
          (strncmp(opntr,"GO",2) == 0) ||
          (strncmp(opntr,"INC",3) == 0))
         {
         *(tpntr + m) = '\0';			/* move \r to \0 for now */
         jj = CGN_JNDEXC(tpntr,' ');
         if (jj < 3) goto errors;

         xpntr = opntr + jj;		/* get to label itself */
         CGN_UPCOPY(labelUp,xpntr,24);
         if (strcmp(labelUp,labelA) == 0)
            {
            label_used ++;
            *opntr = 'J';		/* *GO/ *IF/ *INC  =>  *JO/ *JF/ *JNC */
            (void) strcpy(xpntr,labelB);
            dpntr = xpntr + lenB;
            }
         *(tpntr + m) = '\r';			/* reset */
         }
      }
   tpntr += (m+1);
   goto read_30;
   }

if (label_used == 0)
   (void) printf(">>>>> label `%s' not used...\n",labelA);
goto next_next_job;				/* look for next label */


/* ------------------------- fourth step ------------------------- */

end_of_it:		
*(tpntr+1) = '\0';
mm = nc;
nc = (int) strlen(cpntr);			/* new size of code */

if (option == 1)			/* TRANSLATE/PROC procedure */
   {
   opti_info(cpntr,0);			/* set counter to 0 -> unique name */
   dflag = 1;
   }

if (dflag == 1)
   opti_info(cpntr,2);

*nb = CODE_START + nc;				/* update length */
(void) strcpy(&CODE.CODE[CODE_START],cpntr);
goto free_them;


errors:
SCTPUT("parsing problems in *IF/*GO line");


free_them:
free(cpntr);
return;
} 

/*

*/

int is_label(pntra,pntrb)
char   *pntra, *pntrb;

{
int  jj;

register char  cc;


cc = *pntrb;
if (cc != ':') return (0);

*pntrb = '\0';
jj = CGN_INDEXC(pntra,' ');
*pntrb = cc;

if (jj < 1)
   return (1);
else
   return (0);
}
/*

*/

void opti_info(kpntr,flag)
char  *kpntr;
int  flag;

{
int  fid, m;
static int deb_count = 0;

char  *pntr, temp[20];



pntr = kpntr;			/* leave kpntr unchanged */

if (flag == 0)
   {
   deb_count = 0;		/* so we have a fixed output name... */
   return;
   }

if (flag == 1)
   (void) sprintf(temp,"input%d.cprg",deb_count);
else
   (void) sprintf(temp,"output%d.cprg",deb_count++);

fid = osaopen(temp,1);               /* open for writing */
if (fid < 0)
   printf("Could not open ASCII file `input.cprg' ...\n");
    
else
   {
  debug_read:
   m = CGN_INDEXC(pntr,'\r');
   if (m == 0)
      {
      osaclose(fid);
      return;
      }
   else if (m < 0)
      {
      osaclose(fid);
      (void) printf("opti_info: flag = %d, m = -1 ...!\n",flag);
      return;
      }
   else
      {
      *(pntr+m) = '\0';
      (void) osawrite(fid,pntr,(int)strlen(pntr));
       *(pntr+m) = '\r';
      pntr += (m+1);
      goto debug_read;
      }
   }
}

int noprocess(label,kpntr)
/* ++++++++++++++++++++++++++++++++++++++++++++++++++++

if a label is used in a BRANCH (*BR) or STORE/FRAME command
it cannot be removed

++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
char   *label, *kpntr;

{
char  *tpntr, *xpntr;
char  cbuf[24];

int  m, jj, start, ln;



tpntr = kpntr;

read:
m = CGN_INDEXC(tpntr,'\r');
if (m != 0)
   {
   if (*tpntr == '*')			/* look for *BR test_str label_str */
      {
      *(tpntr + m) = '\0';		/* replace \r by \0 for the moment */
      if ((*(tpntr+1) == 'B') && (*(tpntr+2) == 'R'))
         {
         jj = CGN_JNDEXC(tpntr,' ');	/* go backwards */
         xpntr = tpntr + jj + 1;	/* get to label string */
         ln = (int) strlen(xpntr);
         start = 0;			/* extract each label */
         while (CGN_EXTRSS(xpntr,ln,',',&start,cbuf,24) > 0)
            {
            CGN_UPSTR(cbuf);		/* label is UpperCase! */
            if (strcmp(label,cbuf) == 0) 
               {
               (void) 
               printf("label `%s' used in BRANCH -> not processed\n",label);
               *(tpntr + m) = '\r';	/* reset */
               return 1;		/* Yes, label is used in *BR command */
               }
            }
         }
      *(tpntr + m) = '\r';                 /* reset */
      }

   else if (strncmp(tpntr,"STOR",4) == 0)
      {					/* look for STORE/FRAME . . . label */
      *(tpntr + m) = '\0';              /* replace \r by \0 for the moment */
      ln = CGN_INDEXC(tpntr,'/');
      if ((ln > 0) && (*(tpntr+ln+1) == 'F'))
         {
         jj = CGN_JNDEXC(tpntr,' ');	/* go backwards */
         xpntr = tpntr + jj + 1;		/* get to label string */
         ln = (int) strlen(xpntr);
         CGN_UPCOPY(cbuf,xpntr,ln+1);
         if (strcmp(label,cbuf) == 0) 
            {
            (void)
            printf("label `%s' used in STORE/FRAME -> not processed\n",label);
            *(tpntr + m) = '\r';	/* reset */
            return 1;		/* Yes, label is used in *BR command */
            }
         }
      *(tpntr + m) = '\r';                 /* reset */
      }

   tpntr += (m+1);
   goto read;
   }

return 0;
}