/* Module arrx.c : semantic check of the access to arrays
 * including subarrays.
{*  last modification:  26.10.92  19:38   }
 * DS 10.12.90. d_seman: No control string for y_yxc$( ... )
 * DS 20.12.90. d_seman:  dotctrl->element improved by (cast)y_yxcn(...)
 * DS 10.01.91. prototypes are added for local functions
 * DS 22.01.91. arracc:  *s_ixcn(&s,i) instead of *s_inxc(s,i)
 * DS 29.01.91. arrname: static char fname[] instead of "static char *"
 * DS 29.01.91. calls seman(...,false,...) changed to seman(...,FCALL,...)
 * DS 12.02.91. d_seman produces more efficient code (see XSEMAN4.DOC)
 * uli 22.02.91: new style headers
 * DS 27.02.91. "if ( = )"  changed
 * uli 12.03.91: function "index" changed to "ar_index",
		 because index is predefined
 * uli 19.03.91: dynbound is local!
 * uli 20.03.91: dynbound: new style header
 * DS  23.05.91: arracc & ar_index: the situation a[a[1]] is corrected
 * uli 29.05.91: ar_index: inxpos initialized by statement.
 * Dima 18.06.91.: bound & ixch : made global
 * Dima 29.07.91 : arracc: Corrected access to the static array of strings
 * Dima 19.11.91 : arracc: User-cast above is no more checked
 * Dima 25.11.91 : stdtype moved to optab.c
 * Dima 04.12.91 : ar_index & d_seman: binfather(type) is eliminated.
 * uli  14.02.92 : d_seman: IDOTPRECISION CDOTPRECISION CIDOTPRECISION added.
 * Dima 26.10.92 : n_dimensions made global
 * PJ   31.03.95 : #ifdef LINT_ARGS added for iprocess.
*/

#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include           "impor.t"

#include "option.h"
#include "error.h"
#include "scan.h"
#include "symtab.h"
#include "idtab.h"
#include "optab.h"
#include "bintab.h"
#include "blktab.h"
#include "std.h"
#include "dp_main.h"
#include "seman.h"
#include           "expor.t"
#include "arrx.h"
#include           "implemen.t"


#define CHECK
#define ins_comma(p) bininsert(p,bincreate(cComma));
#define is_array(a)(binsymc(unname(a))==cDYNAMIC or \
		    binsymc(unname(a))==cARRAY   or \
		    binsymc(unname(a))==cSTRING)

#ifdef LINT_ARGS
local void addstr      ( binptr after,  char *str);
local binptr dynbound  (int i, char *bname ,binptr arr_var);
local binptr arrcall   (binptr root, int n_ind);
local char * arrname   ( char prefix, int n_dim, boolean check );
local void iprocess    ( binptr datyp, binptr inx);
local binptr ar_index  (binptr datyp, binptr inx);
#else
local void addstr     ( );
local binptr dynbound ( );
local binptr arrcall  ( );
local char * arrname  ( );
local void iprocess   ( );
local binptr ar_index ( );
#endif
/* ------------------------------------------------------------------ */
/* returns number of dimensions of the arraytype.
   returns 0, if it's not an arraytype
   Considers only the first homogeneous subtype.
     dyn. of dyn. of stat. of dyn of real : n_dim == 2
     stat. of dyn. of set of real         : n_dim == 1
*/
#ifdef LINT_ARGS
global int n_dimensions ( binptr array)
#else
global int n_dimensions( array )  /* n _ d i m e n s i o n s */
  binptr array;
#endif
{
 int n_dim = 1;
 binptr unnamed_array = unname(array);
 symctype type_of_array = binsymc(unnamed_array);/* dyn. or stat. array ? */

 IF not (type_of_array == cARRAY or type_of_array == cDYNAMIC) THEN
   return 0; /* It's not an array, therefore number of dim-s is 0 */
 FI
 array = binright(unnamed_array);
 unnamed_array = unname(array);

 WHILE binsymc(unnamed_array) == type_of_array
 DO
    array = binright(unnamed_array);
    unnamed_array = unname(array);
    n_dim++ ;
 OD
 return n_dim;
}                                /* n _ d i m e n s i o n s */


/*-------------------------------------------------------------------------*/
#ifdef LINT_ARGS
local binptr arrcall ( binptr root,int n_ind )
#else
local binptr arrcall(root, n_ind)          /* a r r c a l l */
  binptr root;
  int n_ind;
/*    root                   root
     /    \,                /    \,--------
 subtree  / \,     ---> cCall    /         \
     i1 / \ \,  i(n_ind+1)  \
          i2  ...          / \,             ....
                                 subtree  / \
                                            i1  ...

If all the indices from the right have been transferred to the left
then binright(root)==NIL.
Returns a pointer to the cCall-node.
*/
#endif
begin
    int i;
    binptr  p, call = bininsert(binleft(root), bincreate(cComma));
    binexchange(call);
    binchange(call,cCall);

    p = bininsert(binright(call), bincreate(cComma));
    binappend(p, binright(root) );
    binrlink( root,NIL );

    /* for st.arr.that would be absolutely incorrect */
    FOR i= 0; binsymc(p)== cComma and i < n_ind; ++i DO
      p = binright(p);
    OD
    IF i == n_ind and binsymc(p)== cComma and binright(p)
    THEN /* some indices are left*/
      binappend( root, binright(p) );
      binrlink(p,NIL);
      bindelete(p);
    FI

   return call;
end                                        /* a r r c a l l */


/*------------------------------------------------------------------------*/
/* Creates runtime function name for arracc and d_seman */
#ifdef LINT_ARGS
local char * arrname  ( char prefix,int n_dim,boolean check)
#else
local char * arrname ( prefix, n_dim, check )     /* a r r n a m e */
 char prefix;        /*prefix 'i' or 'y'*/
 int n_dim;
 boolean check;
#endif
begin
  static char fname[] = "y_*$$#";
  char *s = fname + 3;
  fname[2] = prefix;
  /*create runtime name*/
    IF check THEN
      *s++ = 'x'; *s++ = 'c';
    ELSE
      *s++ = 'n'; *s++ = 'x';
    FI
    IF n_dim < MACRO_LIMIT+1 THEN
      sprintf( s, "%d", n_dim );
    ELSE
      *s = 'n';
    FI
  return fname;
end                                          /* a r r n a m e */


/* ------------------------------------------------------------------ */
#ifdef LINT_ARGS
global binptr bound  (  binptr p ,int specif)
#else
global binptr bound (p,specif)                        /*  b o u n d */
  /* returns  the upper or lower bound value of a subrange  */
  /* returns  NIL, if (lower bound  is zero and specif==LBOUND)
		      or (something is not correct)
  */
  binptr p ;
  int specif;
#endif
BEGIN(bound)
  symctype symc ;  /* symbol code of bound value */
  boolean minus;
  binptr   res = NIL ;

  p = unname (p) ;
  IF specif == UBOUND or specif == ZLBOUND THEN
    IF binsymc(p) == cCHAR THEN
      res = bincreate(cIcon);
      binupvalue( res,(specif == UBOUND)? (long int)255:(long int)0 );
      return res;
    ELIF binsymc(p) == cBOOLEAN  THEN
      res = bincreate(cIcon);
      binupvalue( res,(specif == UBOUND)? (long int)1:(long int)0 );
      return res;
    ELIF binsymc(p) == cLParent  THEN /* enumeration LB==0 */
      res = bincreate(cIcon);
      IF specif == UBOUND THEN
	long int ubound = -1;
	FOR p = binright(p); p; p= binright(p) DO
	  ++ubound ;
	OD
	binupvalue( res, ubound );
      ELSE
	binupvalue( res, (long int)0 );
      FI
      return res;
    FI
  FI /*  */

  if  (binsymc (p) == cTill)  then              /* subrange */
   begin
     p = (specif == LBOUND or specif == ZLBOUND)? binleft (p)
						: binright(p) ; /* bound */
     minus = (binsymc (p) == cMMinus) ;
     if  (minus)  then   p = binright (p) ;             /* skip "-" */

     if (on_rename)
       p = unname (p);

     if  (sym_is [symc = binsymc(p)] .identifier)  then
       if  (binvalue (p) )  then                /* named bound */
	 begin
	   if  (minus)  then
	    begin
	      res = bincreate (cMMinus) ;       /* create "-" bound */
			binappend (res,  binidcreate (symc, binid (p)) ) ;
	    end
		else   res =  binidcreate (symc, binid (p)) ;
						      /* create bound */
	 end
	else /* res = NIL */ ;
    else   /* unnamed constant */
     begin
#ifdef CHECK
       if  (not sym_is [symc] .value)  then
	   begin
	     errput (1501, binpos(p), NULL) ;
			/* Bound is not integer. */
	   end
	  else
#endif
       IF not (specif== LBOUND and not binvalue (p)) THEN
	  res = bincreate (symc) ;                      /* copy value */
	  if  (minus)  binupvalue (res,-binvalue (p)) ;
	  else         binupvalue (res, binvalue (p)) ;
       FI
     end /* bound is not id */
   end /* subrange */ ;
   /* else return  NIL */
  RETURN (res) ;
END /* bound */


/* ------------------------------------------------------------------ */
/* Inserts index range check for arrays.
   index -> a_ixch(index,lb,ub)
*/
#ifdef LINT_ARGS
global binptr ixch  ( binptr inx, binptr subrange)
#else
global binptr ixch (inx, subrange )             /* i x c h  */
  binptr inx, subrange;
#endif
begin
  binptr  u, f = bincreate( cComma);
  binexchange(bininsert(inx, f));
  binchange(f,cCall);
  binupsym( f, symins("a_ixch"));
  u = bininsert(binright(f),bincreate(cComma));
  u = binappend(u,bound(subrange,ZLBOUND));
  u = bininsert(u,bincreate(cComma));
  binappend(u,bound(subrange,UBOUND));
  return f;
end                                          /* i x c h  */


/* ------------------------------------------------------------------ */
/* Adds control string to argument list */
#ifdef LINT_ARGS
local void addstr  (binptr after, char *str)         /*  a d d s t r  */
#else
local void addstr (  after,  str)
  binptr after;
  char *str;
#endif
begin
  binptr p;
  p= bininsert (after, bincreate (cComma)) ;
  p= binappend (p, bincreate (cScon)) ;
  binupcharp (p, (char*) malloc (strlen (str) + 1) ) ;
  if( bincharp(p) == 0)  memerror (pos) ;
  strcpy (bincharp (p), str) ;
  binexchange (binfather (p)) ;
end                                         /* a d d s t r */


/* ------------------------------------------------------------------ */
/* Generates function call for the transformation  of static array to
   dynamic one.
   y_stat( &dy_???, array, elsize, n_dim, lb1,ub1, ... );
*/
#ifdef LINT_ARGS
global void stattodyn  ( binptr arrid ,binptr restyp ,binptr type )
#else
global void stattodyn ( arrid, restyp,type ) /* s t a t t o d y n */
  binptr arrid ;  /* array identifier */
  binptr restyp ; /*   */
  binptr type ;
#endif
begin
  binptr p,call ;
  binptr  comma ;
  long n_dim  ;

  /*insert cCall: y_stat */
  call = ins_comma(arrid);
  binexchange( call);
  binchange(call,cCall);
  binupsym(call, symins("y_stat"));

  comma = binright(call);

  /* insert low and upper bounds for all the dimensions*/
  FOR type = unname(type),n_dim = 0;
     binsymc(type)== cARRAY;
     ++n_dim, type = binright(type)
  DO
    comma = ins_comma(comma);
    comma = binappend(comma,bound( binleft(type), ZLBOUND ));
    comma = ins_comma(comma);
    comma = binappend(comma,bound( binleft(type), UBOUND ));

    /*size *= binvalue (ub) - binvalue (lb) + 1;*/
  OD

  /*add &tempvar to argument list*/
    tempvar = tempdecl ("dy", restyp) ;/* subarray result variable*/
    comma = ins_comma (binright(call)) ;
    binappend (comma, binsycreate (binsym (tempvar))) ;
    binexchange (comma) ;
    varparam( binleft(comma), false);

  comma =  binright(binright(comma)); /* skip arrid */

  /* add sizeof(eltype) or s_SIZE */
    comma = ins_comma(comma);
    IF binsymc(unname(type)) == cSET THEN
	       binappend (comma, binsycreate (symins ("s_SIZE"))) ; /* set size */
    ELSE
      p = binappend (comma, binsycreate (symins ("sizeof"))) ;
      binchange (p, cCall) ;
      binrlink (p, type) ;
    FI
  binexchange (comma) ;

  /* add numdim */
    comma= ins_comma(binright(comma));
    binappend(comma, bincreate(cIcon) );
    binexchange (comma) ;
    binupvalue( binleft(comma), n_dim);

  /* Dereference the function */
    /*voidptr(call,restyp);*/
end                                         /* s t a t t o d y n */


/*----------------------------------------------------------------*/
/* Perform either insertion of index range check or
  subtraction of  the low bound from the index
*/

/* PJ 31.03.95  #ifdef LINT_ARGS added */

#ifdef LINT_ARGS
local void iprocess( binptr datyp, binptr inx )
#else
 local void iprocess( datyp, inx)             /* i p r o c e s s */
  binptr datyp, inx;
#endif
begin
  binptr lb ;

  IF on_index THEN
    ixch(inx,binleft(datyp));
  ELIF lb = bound(binleft(datyp),LBOUND) THEN /* subtract low bound */
    binappend( bininsert (inx, bincreate (cMinus)) ,lb) ;
  FI
end                                           /* i p r o c e s s */


/*-------------------------------------------------------------------------*/
#ifdef LINT_ARGS
local binptr ar_index (binptr datyp, binptr inx )
#else
local binptr ar_index (datyp, inx)              /* a r _ i n d e x  */
  /* checks the actual data type of the index inx */
  /* against the index type of the formal data type datyp */
  /* and returns the component type of datyp */
  binptr datyp, inx ;
#endif
BEGIN(ar_index)
  binptr ityp ;  /* data type of inx */
  binptr   lb ;  /* low bound to be subtracted from index */
  /* symc & pos of "inx" must be saved since "inx" since it can be
     deleted by arracc in seman if index is access to an array: a[a[1]]
  */
  symctype inxsymc= binsymc(inx);
  postype  inxpos ;
  static sc_type  sc ;  /* storage class */
  inxpos = binpos(inx) ;
  datyp = unname (datyp) ;

  IF inxsymc==cIrange or
     inxsymc==cTill
  THEN
    ityp = integertype;
  ELSE
    ityp = unname (subtype (seman (inx, FCALL, &sc))) ;
  FI
  if  (binsymc (datyp) == cDYNAMIC)  then
     if( ityp != integertype) then
      begin
       errput (1502, inxpos, NULL) ;
		  /* The index must be integer */
     end
    else ;
  else
  IF  binsymc (datyp) == cARRAY THEN         /* static array */
    IF not(inxsymc==cIrange or inxsymc==cTill) and
       ityp != unname (subtype (binleft (datyp)))
    THEN
      errput (1503, inxpos, NULL) ;
		   /* Index  type mismatch. */
    FI
  ELSE
    errput (1504, inxpos, NULL) ;
		    /* Too many indices. */
    /*datyp = binfather (datyp) ;*/
    return datyp  ;     /* 04.12.91 */
  FI
  RETURN (binright (datyp)) ;
END                                        /* i n d e x */
/*-------------------------------------------------------------------------*/

#ifdef LINT_ARGS
global  binptr arracc  ( binptr chktyp ,binptr root )
#else
global  binptr arracc ( chktyp,root)                  /*  a r r a c c */
  binptr chktyp ;
  binptr root ;
/* Performs the semantic analysis of the
   Pascal-SC array acces for the arbitrary combination of component types,
   (dyn. of stat., stat. of dyn., etc)
   and
   Static and Dynamic subarrays
   with the exeption of subarrays of static arrays which
   component type is dynamic array.
   Ranges as indices are already implemented .
*/
#endif
BEGIN(arracc)
  binptr p,t            ; /* walks through element list */
  int i = 0;
  binptr  call, inx ;
  binptr  lb,ub ;
#define maxdim 32    /* maximal dimensions number, ".." and "*" count 1 */
  char   ctrlstring [maxdim] ;
  char * chp = ctrlstring;
  boolean was_asterisk = false;
  boolean on_suba = false;
  boolean st_suba = false;
  boolean s_slice = false;
  boolean dyn_arr= false ;
  boolean dyn_stat= false ;
  int n_dim, n_ind, end_i ;
  binptr restyp ,loctyp , endres , endloc, ast_beg, end_type ;

  postype arr_pos;

  restyp =loctyp = endres = endloc = NIL;
  n_dim = n_ind = end_i = 0;

  arr_pos = binpos(root); /* The name of the array */

  /*Create cArrvar node to the left of the root, if necessary*/
  IF binsymc(root) == cArry THEN
    p = binidcreate(binsymc(root),binid(root) );
    binchange( root, cArrVar) ;
    binchange(p, cIdent) ;
    binllink(root,NIL);
    binlside(root,p);
  FI

  IF not (binright (root)) THEN   /*  empty array access */
    errput(1505, arr_pos, NULL);
			/* Must be at least one index. */
    return chktyp;
  FI


  /* Arraytype consist of several homogenous subtypes which are
     either dynamic or static array.
     dyn. of dyn.| of stat.| of dyn.| of real
     The beginning this loop ALWAYS coincide with the beginning
     of a subtype.
  */
  WHILE binsymc(root)==cArrVar DO
     binptr orig_typ = chktyp; /*named type of the subtype*/
     loctyp = endloc = NIL;
     on_suba = false;

     ast_beg = NIL;
     orig_typ = chktyp;

     /* Treats the case of string access */
     IF binsymc(unname(chktyp))==cSTRING THEN
	sc_type  sc ;  /* dummy storage class  */

	/* check the type of the first index */
	  inx = binright(root);
	  IF  binsymc(inx) == cComma THEN
	    inx = binleft(inx);
	  FI
	  IF unname (subtype (seman ( inx, FCALL, &sc))) != integertype THEN
	    errput (1502, binpos(inx), NULL) ; /* The index must be integer */
	  FI

	/*Insert function call to the left of the root:  */
	 call = arrcall(root, 1);
	 IF on_index THEN
	   binupsym(  call ,symins( "*s_ixcn" ) );
	   varparam( binleft(binright(call)), false); /* *s_ixcn(&string,i)*/
	 ELSE
	   binupsym(  call ,symins(  "s_inxn" ));     /*  s_inxn( string,i)*/
	 FI
	 p = binright(root) ;
	 IF  p  THEN
	   errput(1504,binpos(p), NULL);/*Too many indices*/
	   /* Other than the first one, indices are ignored */
	   bintdelete(&p);
	   binrlink(root,NIL);
	 FI

	 bindelete(root);
	 root = NIL;

	return chartype;
     FI

     /*Can be changed in the next loop*/
       dyn_arr = binsymc(unname(chktyp)) == cDYNAMIC; /* subtype's type*/

     /*
       This loop determines the type of accsess:
       stat.subarray or dyn.subarray  or accsess to an element

       It processes the list of indices,
       but no more indices than the dimension of the subtype.
       In the case of subarray of dynamic array
       which component type is static array.
       Both subtypes are treated as one subtype and the corresponding
       call of "y_suba" needs to be generated.
     */


    FOR i=0, /*The number of processed indices - 1 */

       /*Can be changed at the and of the following loop*/
	n_dim = n_dimensions(chktyp),     /* numdim in the  subtype */

	/* Need not to be initialised, if we process the static array
	   which is the component type of a dynamic array.
	*/
	 n_ind = 0,/*Number of indices that need to be kept in the list*/

	p= binright (root);  /*The first index*/

	/*While */
	p and     /*There are indices and */
	i < n_dim;/*Their number don't exceed the dimension of the subtype*/

	++i /*Next index*/
    DO
      boolean irange= false, till= false;
      binptr  left= NIL, right= NIL ;

      inx = (binsymc (p) == cComma)? binleft(p): p ;

      /* Determine the next index-node */
      p = (binsymc(p)==cComma)?binright(p):NIL;

      /*  index process */ ;
      irange= (binsymc(inx) == cIrange) ;
      till=   (binsymc(inx) == cTill);
      IF irange or till THEN
	IF till THEN
	  left = binleft(inx);
	  right= binright(inx);
	FI
	was_asterisk = true;
	IF left or right or /* non-empty ".." */
	   ( (irange or till) and dyn_arr )
	THEN
	  on_suba = true;
	FI
	IF (left or right) and /* non-empty ".." */
	  (not dyn_arr) and (not dyn_stat) THEN
	  st_suba = true;
	FI
       /* non-empty ".." is always a symptom of subarray.
	  "*" and  empty "..",
	  if they are not trailing in a static arrary. st[ 1, .., * ]
	  subarray's type is always dynamic.
       */
	IF loctyp THEN
	  endloc= binappend(endloc,bincreate(cDYNAMIC));
	ELSE
	  loctyp = endloc = bincreate(cDYNAMIC);
	FI

	/* if "*" or empty ".." is the first in the trail*/
	IF not (ast_beg or left or right) THEN
	  ast_beg = endloc;    /* Beg. of the list of "*"s */
	  end_type = chktyp;   /* current type*/
	  end_i = i;           /* current number of indices*/
	FI
	binrlink(endloc,NIL);
      FI

IF irange or till THEN  /* Check only */
	IF not(left or right) THEN /* "*" or empty ".." */
	  chktyp= ar_index ( chktyp, inx) ;
	  *chp++ = (dyn_arr)?'0':'5' ;

	ELIF left and  right  THEN /* [ i..j ]*/
	 /* check the range bounds */
	   ar_index (  chktyp,left ) ;
	   chktyp= ar_index (  chktyp,right ) ;

	   n_ind += 2;/*number of indices that need to be kept in the list*/

	   *chp++ = '2' ;

	ELIF left THEN    /* [ i.. ]*/
	  chktyp= ar_index (  chktyp,left ) ;
	  ++n_ind;  /*number of indices that need to be kept in the list*/
	  *chp++ = '3' ;

	ELIF right THEN    /* [ ..j ]*/
	  chktyp= ar_index (  chktyp, right) ;
	  ++n_ind;  /*number of indices that need to be kept in the list*/
	  *chp++ = '4' ;

	FI
ELSE  /* single index */
	++n_ind;  /*number of indices which need to be kept in the list*/
	chktyp = ar_index (  chktyp, inx) ;
	ast_beg = NIL; /* There are no trailing "*" and empty ".." .*/
	IF was_asterisk THEN
	  on_suba = true;
	  IF (not dyn_arr) and (not dyn_stat) THEN
	    st_suba = true;
	  FI
	FI
	*chp++ = (dyn_arr)?'1':'6' ;
FI  /*  index process */ ;

    /*Is it a subarray of dynamic array and component type is stat. array ? */
       IF /*The number of indices is equal to the dimension of subtype*/
	  i==(n_dim-1) and
	  dyn_arr and on_suba and
	  p and    /* Are there indices still ??? */
	  binsymc(unname(chktyp))==cARRAY /*Components type is st. arr.*/
       THEN
	 dyn_stat = true;
	 dyn_arr = false; /*There will be a static array*/
	 /*Both sybtypes will be treated as a one subtype*/
	  n_dim += n_dimensions(chktyp);
       FI
    OD   /*  indices processing */ ;

    /* dyn_dyn_dyn:   d[1]  */
    IF dyn_arr and (i < n_dim) THEN
      on_suba = true;
    FI


   /* Exeption:  subarray of static array which
      component type is dynamic array.
   */
     IF  st_suba and
	 p and   /* there are indices still */
	 binsymc(unname(chktyp))==cDYNAMIC
     THEN
	 errput(1506, arr_pos, NULL);
	 /* That type of subarrays has not been implemented yet */
	 return anytype;
     FI

    /*delete dyn.arr. created for trailing "*"s and
      assign to "chktyp" named type before the first trailing "*" and
      to "i" the number of processed indices ;
    */
    IF  ast_beg and
	/* For subarray of stat.array we need to create a dynamic type
	   in any case, so the dyn.arr created for trailing "*"s can be
	   used
	*/
	not(st_suba) /* stat subarray */
    THEN
      chktyp = end_type ;
      i = end_i;
      IF ast_beg == loctyp THEN
	loctyp = endloc = NIL ;
      ELSE
	endloc = binfather(ast_beg);
	binrlink(endloc, NIL);
      FI
      bintdelete(&ast_beg);
      ast_beg = NIL;
    FI

    IF not dyn_arr and not on_suba THEN /* access to the stat. arr*/
      loctyp = chktyp;
    ELIF st_suba THEN /* static subarray*/
       /* dynamic dimensions for the absent trailing "*"s
	  a is  st_st_st :
	  restyp for a[*,1]   is dyn_dyn.
	  loctyp == dyn.  before this loop
       */
       WHILE i++ < n_dim  and chktyp DO
	IF loctyp THEN
	  endloc = binappend(endloc,bincreate(cDYNAMIC));
	ELSE
	  loctyp = endloc = bincreate(cDYNAMIC);
	FI
	binrlink(endloc,NIL);
	chktyp= binright(unname(chktyp));
      OD
      binrlink(endloc,chktyp);
    ELSE
      /* append the rest of the type (NAMED !!!)*/
      /*
	  d is  dyn_dyn_NT :
	  restyp for d[*,1]   is dyn_NT.
	  loctyp == dyn.  before this loop
      */
	/*14.11.90.*/
	IF loctyp THEN
	  binrlink(endloc,chktyp);
	ELSE
	  loctyp = chktyp;
	FI

      /*
      WHILE i++ < n_dim  and chktyp DO
	IF loctyp THEN
	  endloc = binappend(endloc,bincopy(chktyp));
	ELSE
	  loctyp = endloc = bincopy(chktyp);
	FI
	binrlink(endloc,NIL);
	chktyp= binright(chktyp);
      OD
      */
    FI

    *chp = '\0' ;

    /*The second pass: Semantic transformation of the tree*/
    FOR i=0, p= binright (root), /*The first index*/
	t = unname(orig_typ);   /* restore the original type */
	p and i < n_dim;
	++i, t = unname(binright(t))
    DO
      boolean irange= false, till= false;
      binptr  left= NIL, right= NIL ;

      inx = (binsymc (p) == cComma)? binleft(p): p ;

      /* Determine the next index-node */
      p = (binsymc(p)==cComma)?binright(p):NIL;

      irange= (binsymc(inx) == cIrange);
      till=  (binsymc(inx) == cTill) ;
      IF till THEN
	left = binleft(inx);
	right= binright(inx);
      FI

      IF irange or till THEN
	IF not(left or right) THEN /* "*" or empty ".." */
	  IF binfather(inx) != root THEN
	    binptr fat = binfather(inx) ;
	    bindelete(inx);
	    bindelete (fat);
	  ELSE
	    bindelete(inx);
	  FI

	ELIF left and  right  THEN /* [ i..j ]*/
	   IF p THEN /*That is NOT the last index*/
	     binlift (inx) ; /* lift ".." to comma level */
	   FI
	   binchange (inx, cComma) ;

	ELSE  /*left or right */   /* [ ..j ] or [ i.. ]*/
	  bindelete(inx);
	FI

      ELSE  /* single index */
	IF not (dyn_arr or on_suba or dyn_stat) THEN
	  /*static array. not a subarray*/
	  iprocess (t,inx); /* subtract low bound */
	FI
      FI  /*  index process */ ;

    OD

    /*Treats superfluouses indices */
    IF (i == n_dim) and  /*The whole subtype was processed*/
       p              and  /* There are indices still */
       not is_array (t)     /* The end of array-type*/
    THEN
      errput(1504,binpos(p), NULL);/*Too many indices*/
      bintdelete(&p);
      binrlink(root,NIL);
      bindelete(root);
      return chktyp;
    FI
    IF (i == n_dim) and  /*The whole subtype was processed*/
       p              and  /* There are indices still */
       (binsymc(unname(t)) == cSTRING)
    THEN
      s_slice = true ;
    ELSE
      s_slice = false;
    FI
    /* IF all indices were "*" or ".." and were deleted */
    /* THEN instead of array access there will be array identifier*/
     IF  binright(root)==NIL THEN
	bindelete(root);
	IF restyp THEN
	  binappend( endres, orig_typ);
	ELSE
	  restyp = orig_typ;
	FI
	return restyp;
     FI


     IF (not dyn_arr) and (not dyn_stat)  THEN  /* static array */
       /* IF it is not a static subarray or
	  access to an array of string
       */
       IF not st_suba  THEN
	 IF s_slice THEN
	   binptr r;
	   r = bininsert(root, bincreate(binsymc(root)));
	   binuppos (r, binpos (root)) ;
	   p = binright(root) ;
	   /* There must be at least two indices */
	   FOR i= 1; binsymc(p)== cComma and i < n_ind; ++i DO
	     p = binright(p);
	   OD
	   IF i == n_ind and binsymc(p)== cComma and binright(p)
	   THEN /* some indices are left*/
	     binappend( r, binright(p) );
	     binrlink(p,NIL);
	     bindelete(p);
	   FI
	   root = r;
	   continue;
	 ELSE
	   restyp = (loctyp)? loctyp: chktyp  ;
	   if(on_dump)
	     dump(restyp);
	   return restyp;
	 FI
       ELSE   /*static sub. array*/
	 p = loctyp;
	 loctyp = stdtyp(loctyp); /* Try to transform to a standard VM-type*/
	 IF on_warning and (p != loctyp)  THEN
	   /* Warn. type LOCTYP was assigned to the subarray*/
	   errput(120, arr_pos, namestring(loctyp) );
	 FI
	 stattodyn ( binleft(root),loctyp,orig_typ );
	 voidptr( binleft(root),loctyp);
	/* correct the Control String for y_suba */
	 FOR chp = ctrlstring; *chp; chp++ DO
	   IF   *chp == '5' THEN *chp = '0' ;
	   ELIF *chp == '6' THEN *chp = '1' ;
	   FI
	 OD
	 /*
	  n_dim of cARRAY -> cDYNAMIC ;  arrID  -> y_stat(...);
	 */
       FI
     FI /* static array */


   /* call(arr_var,i1,i2,...)[i3,i4,...]  */
   /*insert function call to the left of the root */
    call = arrcall( root, n_ind);

   /*If no indices more, then delete the root */
    IF not binright(root) THEN
      bindelete(root);
      root = NIL;
    FI

      IF on_suba THEN
	 /* now construct call of runtime procedure */
	 binupsym(call ,symins( "y_suba" ));

	/* array desc. is var.param for dyn. arr.*/
	   varparam( binleft(binright(call)), false);

	/* Delete trailing '5's and '0's from Control String*/
	  for( --chp ; *chp == '5'or *chp == '0'; --chp );
	  *(++chp) = '\0';
	/*find for static part (the beg. of CStr and 1st index)  */
	  FOR chp = ctrlstring , p = binright(call); /* descriptor*/
	      *chp == '1' or *chp == '0';
	      ++chp
	  DO if(*chp == '1' ) p = binright(p); OD
	IF *chp  THEN     /*there are some more indices*/
	  p = binright(p);
	FI
	/*add lbound and ubound for each dimension*/
	 FOR t = unname(orig_typ );
	     *chp;
	     t = unname(binright(t)),
	     ++chp
	 DO
	   lb = bound( binleft(t), ZLBOUND );
	   ub = bound( binleft(t), UBOUND );
	   IF   *chp == '5' THEN
	       p = ins_comma(p);  /* before p */
	       binappend(p,lb);
	       binexchange(p);
	       p = ins_comma(binright(p));
	       binappend(p,ub);
	       binexchange(p);
	   ELIF *chp == '6' THEN /* after p */
	     IF binsymc(p)==cComma and binright(p) THEN
	       p = ins_comma(binright(p));
	       binappend(p,lb);
	       binexchange(p);
	       p = ins_comma(binright(p));
	       binappend(p,ub);
	       binexchange(p);
	     ELSE
	       p = ins_comma(p);
	       p = binappend(p,lb);
	       p = ins_comma(p);
	       p = binappend(p,ub);
	     FI
	   FI
	   p = binright(p);
	 OD

	 p = loctyp;
	 /* Try to transform to a standard VM-type*/
	 loctyp = stdtyp(loctyp);

	 IF on_warning and (p != loctyp)  THEN
	   /* Warn. type LOCTYP was assigned to the subarray*/
	   errput(120,arr_pos, namestring(loctyp) );
	 FI

	  /* create "*(loctyp *)y_suba(...)" or "*y_suba(...)"*/
	  voidptr ( call, loctyp);
	  /* IF loctyp was not named and
	      "*" will not be deleted by y_assign
	     THEN
		C compiler will curse;
		 temporal types are necessary;
	      FI
	  */
	  /*add &tempvar to argument list*/
	   tempvar = tempdecl ("sa", loctyp) ;/* subarray result variable */
	   p= ins_comma(binright(binright(call))) ;
	   binappend (p, binsycreate (binsym (tempvar))) ;
	   binexchange (p) ;
	   varparam( binleft(p), false);

	  /* add control string to argument list */
	    addstr (binright (p), ctrlstring) ;

	if(on_dump)
	    dump(loctyp);
	return loctyp;

      ELIF dyn_arr THEN /* dynamic array access ,not subarray*/
	*(chp -= n_dim) = '\0';
	binupsym(call,symins(arrname('i', n_dim,on_index) ));

	 /* if it is a function call istead of macro*/
	 IF n_dim > MACRO_LIMIT THEN
	   /* "call(x,...)" -> "call(&x,..)*/
	   varparam( binleft(binright(call)), false);
	   /* "call(...)" -> "*(chktyp *)call(...) */
	   voidptr( call, chktyp);
	 FI
      FI /* end on_suba */
  OD  /* binsymc(root)==cArrVar */
  restyp = (loctyp)?loctyp:chktyp;
  if(on_dump)
    dump(restyp);
  return restyp;
END                                                 /*  a r r a c c  */
/*----------------------------------------------------------------------*/


/* Create expression  x.fd[i].bname, x correspond to arr_var */
#ifdef LINT_ARGS
local binptr dynbound  (int i, char* bname, binptr arr_var)
#else
local binptr dynbound (i, bname ,arr_var)            /* d y n b o u n d  */
  int i;
  char *bname;
  binptr arr_var;
#endif
begin
   binptr p, root =   bincreate(cPoint);

   binlside(root,binidcreate(binsymc(arr_var),binid(arr_var) ) );
   binappend(root,bincreate(cCsymbol));
   binupsym(binright(root) ,symins(bname) ); /* x.bound*/
   p = bininsert(binleft(root),bincreate(cPoint));
   p = binappend(p,bincreate(cArrVar) );
   binlside(p,bincreate(cCsymbol));
   binupsym(binleft(p) ,symins("fd") ); /* x.fd[].bound*/
   p = binappend(p, bincreate(cIcon));
   binupvalue (p,(long)i);              /* x.fd[i].bound*/
   return root;
end                                     /* d y n b o u n d  */


/*-----------------------------------------------------------------------*/
/* Special semantic checker for dot-presicion expressions */
#ifdef LINT_ARGS
global tVARBLK *d_seman ( binptr root)
#else
global tVARBLK *d_seman( root )         /* d _ s e m a n */
  binptr root;
#endif
begin
  int n_dim = 0;
  int i;
  idptr idp;
  binptr call, arr_var, p, inx;
  binptr chktyp, fat_chk ;
  binptr restyp ;
  boolean dyn_arr;
  boolean check = false;
  binptr subrange;
  binptr *ptr ,*lb ,*ub;
  boolean use_y_y = false;
  int i_cnt, ast_cnt ;
  sc_type sc;  /* dummy */

  tVARBLK *dotctrl = (tVARBLK *)calloc( 1, sizeof(tVARBLK));
  if( dotctrl == 0)
    memerror (pos) ;

  /*Create cArrvar node to the left of the root, if necessary*/
  IF binsymc(root) == cArry THEN
    arr_var = binidcreate(binsymc(root),binid(root) );
    binchange( root, cArrVar) ;
    binchange(arr_var, cIdent) ;
    binllink(root,NIL);
    binlside(root,arr_var);
  ELIF binsymc(root) == cArrVar THEN /* ??? */
    arr_var = binleft(root);
  FI

  p = (binsymc(root) == cArrVar )? binleft(root) :root;
  restyp = seman( p, FCALL, &sc);

  IF binsymc(root)!= cArrVar and is_array(restyp) THEN
    IF root THEN
      root = bininsert(root,bincreate(cArrVar));
    ELSE
      p = bincreate(cArrVar);
      binlside(p,root);
      root = p;
    FI
    arr_var  = binleft(root);
    dotctrl->element =  root ;
  FI
  dotctrl->element =  root ;


  IF binsymc(root) == cArrVar THEN
  /* determine the "originality" of the result type */
  /*go till "*" or ".." in index list */
    p = binright(root), chktyp = restyp;
    WHILE  p  DO
      inx = (binsymc (p) == cComma)? binleft(p): p ;
      IF binsymc(inx) == cIrange or binsymc(inx) == cTill THEN
	break;
      FI
      chktyp = binright(unname(chktyp)) ;
      p = (binsymc (p) == cComma)? binright(p): NIL;
    OD
   /* skip all the "*"s and empty ".." */
   WHILE p  DO
     inx = (binsymc (p) == cComma)? binleft(p): p ;
     IF binsymc(inx) != cIrange and binsymc(inx) != cTill or
       (binsymc(inx) == cTill  and (binleft(inx) or binright(inx) ))
     THEN break;
     FI
     p = (binsymc (p) == cComma)? binright(p): NIL;
   OD
   IF not p THEN
     dotctrl->original =
    (binsymc(chktyp) >= cRVECTOR and binsymc(chktyp) <= cCIMATRIX)
      ?true
      :false;
   ELSE
     dotctrl->original = false;
   FI
  ELSE
     dotctrl->original = false;
  FI
   /*determine the element's type*/
     IF not is_array(restyp) THEN
       idp = binid(restyp);
       IF idp == idDOTPRECISION or
	  idp == idIDOTPRECISION or
	  idp == idCDOTPRECISION or
	  idp == idCIDOTPRECISION or
	  idp ==idINTEGER      or
	  idp ==idREAL         or
	  idp ==idINTERVAL     or
	  idp ==idCOMPLEX      or
	  idp ==idCINTERVAL
	THEN
	  dotctrl->eltype = idp;
	ELSE
	  dotctrl->eltype = idBAD_ID;
	FI
       return dotctrl;
     ELSE
       FOR chktyp = restyp; binright(unname(chktyp));  DO
	 chktyp = binright(unname(chktyp));
       OD
       idp = binid(chktyp);
       IF idp ==idDOTPRECISION or
	  idp ==idIDOTPRECISION or
	  idp ==idCDOTPRECISION or
	  idp ==idCIDOTPRECISION or
	  idp ==idINTEGER      or
	  idp ==idREAL         or
	  idp ==idINTERVAL     or
	  idp ==idCOMPLEX      or
	  idp ==idCINTERVAL
	THEN
	  dotctrl->eltype = idp;
	ELSE
	  dotctrl->eltype = idBAD_ID;
	FI
     FI

  /* The number of indicis is to be equal to the number of ALL
     the dimensions( not only the main array;
  */
  /* Arraytype consist of several homogeneous subtypes which are
     either dynamic or static array.
     dyn. of dyn.| of stat.| of dyn.| of real
     The beginning of this loop ALWAYS coincide with the beginning
     of a subtype.
  */

chktyp = restyp;

WHILE binsymc(root)==cArrVar DO
   n_dim = n_dimensions(chktyp);  /* numdim in the subtype */
   /* If the list of indices is empty AND current type isn't an arraytype
      then delete the root-node and finish the function
   */
   IF (not binright(root)) and (not n_dim) THEN
     /* 13.12.90.
	To the left of the root hangs function call and m.b.
	a cast-Operator.
     */
     IF binfather(root)  THEN
       dotctrl->element = binleft(root);
       bindelete(root);
       root = NIL;
     ELSE
       dotctrl->element = bincopy(binleft(root)); /* very ineffective */;
       bintdelete( &root);
       root = NIL;
      FI
      return dotctrl;
    FI

    dyn_arr = binsymc(unname(chktyp)) == cDYNAMIC;

     /*This loop processes exactly n_dim indices.
       Instead of missing indices "*"s will be appended.
     */
     FOR i=0, i_cnt= 0, ast_cnt= 0, p= root; i < n_dim; ++i DO
	IF not binright(p) THEN
	  /*  add the star */
	  binappend(p,bincreate(cIrange));
	FI
	p = binright (p) ;
	IF binsymc(p) != cComma and i < n_dim-1 THEN
	 p = bininsert(p,bincreate(cComma) );
	FI
	inx = (binsymc (p) == cComma)? binleft(p): p ;
	IF binsymc(inx) == cIrange THEN
	  ++ast_cnt;
	ELSE
	  ++i_cnt;
	FI
     OD

     use_y_y = (i_cnt <= ast_cnt); /* What kind of function to use */

     /*This loop processes exactly n_dim indices.
       Instead of missing indices "*"s  have been already appended.
     */
     p = root;
     FOR i=0 ; i < n_dim; ++i  DO
	boolean l_son = false;
	binptr inx_fat;
	p= binright(p); /* can be deleted in ar_index if p==inx */
	l_son = (binsymc (p) == cComma)? true: false;
	inx = (l_son)? binleft(p): p ;
	inx_fat = binfather(inx);
	subrange = binleft(unname(chktyp)) ;

	fat_chk = unname(chktyp);
	chktyp= ar_index (chktyp, inx);
	/*  27.05.91
	    Pointer to "inx" can be deleted
	    by arracc if "inx" is array access : a[a[1]]
	*/
	inx = (l_son)? binleft(inx_fat):binright(inx_fat); /* Restore it*/


	/* index processing*/
	IF binsymc(inx) == cIrange THEN
	  binchange(inx,cCsymbol);

	  IF not dotctrl->rowptr THEN
	     ptr = &(dotctrl->rowptr);
	     lb =  &(dotctrl->rowlb);
	     ub =  &(dotctrl->rowub);
	  ELIF not dotctrl->colptr THEN
	     ptr = &(dotctrl->colptr);
	     lb =  &(dotctrl->collb);
	     ub =  &(dotctrl->colub);
	  ELSE
	   errput(1507, binpos(inx), NULL);
	   /* No more than 2-D arrays are allowed in #-expressions. */
	  FI

	   *ptr = inx;
	   IF dyn_arr THEN
	      *lb = dynbound ( i, "lbound",arr_var );
	      *ub = dynbound ( i, "ubound",arr_var );
	      IF not use_y_y THEN
		binappend( bininsert (inx, bincreate (cPlus) ), *lb );
	      FI
	   ELSE
	     *lb = bound(subrange,ZLBOUND);
	     *ub = bound( subrange, UBOUND);
	   FI

	  ++(dotctrl->numdim) ;
	ELSE  /* single index */
	  IF dyn_arr THEN
	    IF use_y_y THEN
	      binappend( bininsert (inx, bincreate (cMinus) ),
			 dynbound( i, "lbound",arr_var )  );
	    FI
	  ELSE
	    iprocess(fat_chk,inx );
	  FI
	  restyp= binright(unname(restyp));
	  IF on_index THEN
	    check = true;
	  FI
	FI /* index processing*/

     OD  /* index list processing*/

     IF not dyn_arr  THEN /*static array*/
       return dotctrl;   /* EXIT */
     FI

     /*insert function call to the left of the root */
       call = arrcall( root, n_dim);
       binupsym(call,symins(arrname( (use_y_y)?'y':'i' ,n_dim, check) ));

       IF n_dim > MACRO_LIMIT THEN
	  varparam( binleft(binright(call)), false);
	  voidptr( call, idbin(dotctrl->eltype) );
       FI
  OD   /* binsymc(root)==cArrVar */
  return dotctrl;

end             /* d _ s e m a n */


