/**********************************************************************/
/*                                                                    */
/*   "DP_GEN_1.C"                                                     */
/*                                                                    */
/*   Last change    == Oct-26-93 ==                                   */
/*        A.Just / R.Hammer                                           */
/*                                                                    */
/* Functions for generating the work and bin tree with the executing  */
/* orders of dotprecision calculation (Part 1).                       */
/*                                                                    */
/* Feb-01-92 Just : Macro WPRINT_ON and dependend include of          */
/*                  "DP_UTIL.INC" added.                              */
/* Feb-03-92 Just : Prototype deklarations of static functions        */
/*                  removed.                                          */
/* Feb-03-92 Just : Function 'd_generate()' deklared with 'global'.   */
/* Feb-08-92 Just : Function 'd_finddots()' removed (was looking for  */
/*                  formerly illegal type d_cdot, d_idot & d_cidot).  */
/* Feb-11-92 Just : Hopefully all changes made to this file accepting */
/*                  new types d_cdot, d_idot & d_cidot.               */
/* Mar-07-92 Just : macro 'NEW_PROTO' --> 'LINT_ARGS'                 */
/* Sep-22-92 Just : function 'd_gdotfass()' removed, because not used */
/* Oct-26-93 Just : comment added			              */
/* 06.04.95  PJ   : cast parameters in code generation of y_init and  */
/*                  y_temp to y_dscp and not to a_VOID.               */
/**********************************************************************/


/* #define TRACE_ON */
/* #define WPRINT_ON */


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

#include "impor.t"
#ifdef IBMva
#include <varargs.h>
#else
#include <stdarg.h>
#endif

#include        "error.h"
#include        "scan.h"
#include        "symtab.h"
#include        "idtab.h"
#include        "blktab.h"
#include        "optab.h"
#include        "bintab.h"
#include        "std.h"
#include        "arrx.h"

#include        "dp_nodes.h"
#include        "dp_alloc.h"
#include        "dp_error.h"
#include        "dp_check.h"
#include        "dp_genty.h"
#include        "dp_gen_2.h"
#include "expor.t"

#include        "dp_gen.h"
#include        "dp_gen_1.h"
#include "implemen.t"


#if defined(TRACE_ON) || defined(WPRINT_ON)
#include "dp_util.inc"
#endif



/**************************************************************************/



static int          nof_accus;          /* number of accus used       */
static tVARBLK      res_vblk;           /* VarInfo of result buffer   */
static binptr       bin_resvar;         /* binptr of result buffer    */
static tNODE        *work_start;        /* root of work tree          */



/*****************************************************************************/



#ifdef LINT_ARGS
static binptr d_gresalloc(symptr res_descr,tARITHTYPE basetype,
                          tSTRUCTYPE struc)
#else
static binptr d_gresalloc(res_descr,basetype,struc)
symptr         res_descr;
tARITHTYPE     basetype;
tSTRUCTYPE     struc;
#endif

/*-----------------------------------------------------------------------------
 *
 *  The function returns the statements for allocating memory of result
 *  variable. Depending on the structure of the variable the following
 *  statements are to be generated, where 'x' denotes a vector or a matrix
 *  descriptor of type real:
 *
 *  Vector:     x.fd[0].lbound = 0;
 *  -------     x.fd[0].ubound = 'd_1stdim';
 *              y_init((char *) &x,(a_byte) 1,sizeof(a_real));
 *
 *  Matrix:     x.fd[0].lbound = 0;
 *  -------     x.fd[0].ubound = 'd_1stdim';
 *              x.fd[1].lbound = 0;
 *              x.fd[1].ubound = 'd_2nddim';
 *              y_init((char *) &x,(a_byte) 2,sizeof(a_real));
 *
 *  Possible arguments for the 'sizeof(..)' call are:
 *
 *              a_real    :  basetype real
 *              a_cmpx    :  basetype complex
 *              a_intv    :  basetype interval
 *              a_cinv    :  basetype cinterval
 *
 *
 *  As an example for one of the boundary expressions we show a binary tree
 *  which corresponds to the statement 'x.fd[0].lbound = 0':
 *
 *                        cAssign
 *                       /      \
 *                    cPoint    cIcon: 0
 *                   /             \
 *               cPoint        cCsymbol: "lbound"
 *              /     \
 *       cCsymbol:
 *         "x"        /       \
 *                cCsymbol:    cIcon: 0
 *                  "fd"
 *
 *  The binary tree corresponding to the function call of 'y_init(..)', e. g.

    PJ 06.04.95  (a_VOID) changed to (y_dscp)

 *  'y_init(( y_dscp ) &x,(a_byte) 1, sizeof(a_real))' is listed below:
 *
 *
 *         cCall: "y_init"
 *                |
 *                |
 *         cComma ------------------- cComma --------------------
 *                |                      |                      |
 *                |                      |                      |
 *        cRParent                   cRParent                 cCall: "sizeof"
 *        /      \                 /          \                 |
 *   cCsymbol   cAdres                       cIcon: 1         cCsymbol: "a_real"
 *   "y_dscp"    /   \
 *                  cCsymbol:
 *                    "x"
 *
 *
 *
 *  I/O - Parameters:
 *  -----------------
 *
 *        Name       |    Type    |   I/O   |     Meaning
 *        -----------|------------|---------|------------------------------------
 *        res_descr  |   symptr   |    I    |     Descriptor of the result variable
 *        basetype   | tARITHTYPE |    I    |     Arithmetical basetype of the
 *                   |            |         |     result
 *        struc      | tTRSUCTYPE |    I    |     Structure (vector, matrix) of the
 *                   |            |         |     result
 *
 *
 *  Called Routines:
 *  ----------------
 *
 *        Name         | Short description
 *        -------------|---------------------------------------------------------
 *        bincreate    |   Create a new 'binptr' node
 *        binupvalue   | Update value of a 'binptr' node representing
 *                     | an integer node
 *        binupsym     |   Update value of the pointer to the symbol table
 *        symins       |   Insert new name into the symbol table
 *        binsycreate  |  Create a 'binptr' node with the specified symbol
 *                     | table entry
 *        binlside     |   Append node to the left
 *        binappend    |   Append node to the right
 *        binleft      |   Go left
 *        binright     |   Go right
 *        -------------|---------------------------------------------------------
 *        d_gcall      |   Generate a function call
 *        d_gassign    |   Generate an assignment statement
 *        d_stment     |   Add a statement to a sequence of already
 *                     | generated statements
 *        d_suplparam  |  Suplement another parameter to the argument
 *                     | list
 *
 *---------------------------------------------------------------------------*/

{
     binptr    stm_list,           /* List of statements to be returned    */
               ass, lass, rass,    /* Help variables for assignments       */
               head,               /* Head of a function call              */
               p, q;               /* Help variables                       */


     /* func d_gresalloc */
     /*------------------*/

#ifdef TRACE_ON
     d_trace("'d_gresalloc()'");
#endif

     stm_list = NIL;

     /*-------------------------------*/
     /* Generate:  x.fd[0].lbound = 0 */
     /*-------------------------------*/

     rass = bincreate(cIcon); binupvalue(rass,0L);          /* right side of */
                                                            /* assignment    */
     lass = bincreate(cPoint);
     p = bincreate(cCsymbol); binupsym(p,symins("lbound")); /* left side of */
                                                            /* assignment   */
     (void) binappend(lass,p);
     p = binlside(lass,bincreate(cPoint));
     (void) binlside(p,binsycreate(res_descr));
     p = binappend(p,bincreate(cArrVar));
     q = bincreate(cCsymbol); binupsym(q,symins("fd"));
     (void) binlside(p,q);
     q = bincreate(cIcon); binupvalue(q,0L);
     (void) binappend(p,q);

     ass = d_gassign(lass,rass);                  /* complete assignment */

     d_gstment(&stm_list,ass);


     /*------------------------------------------*/
     /* Generate: x.fd[0].ubound = 'd_1stdim'    */
     /*------------------------------------------*/

     /* Copy the tree of the last assignment */
     /*--------------------------------------*/

     ass = bincopy(ass);

     /* Updating:   "lbound"   ==>  "ubound" */
     /*--------------------------------------*/

     p = binright(binleft(ass));
     binupsym(p,symins("ubound"));

     /* Updating: right side */
     /*----------------------*/

     binrlink(ass,NIL);                            /* unlink right child */
     (void) binappend(ass,bincopy(d_1stdim));

     /* Append statement to statement list */
     /*------------------------------------*/

     d_gstment(&stm_list,ass);


     if (struc == d_matrix){
          /*---------------------------------*/
          /* Generate:    x.fd[1].lbound = 0 */
          /*---------------------------------*/

          /* Copy the tree of the last assignment */
          /*--------------------------------------*/

          ass = bincopy(ass);

          /* Updating:    "ubound"  ==>  "lbound" */
          /*--------------------------------------*/

          p = binright(binleft(ass));
          binupsym(p,symins("lbound"));

          /* Updating:    "fd[0]"   ==>  "fd[1]"   */
          /*---------------------------------------*/

          p = binleft(binleft(ass));
          p = binright(binright(p));
          binupvalue(p,1L);

          /* Updating: right side */
          /*----------------------*/

          p = bincreate(cIcon);
          binupvalue(p,0L);

          binrlink(ass,NIL);                      /* unlink right child */
          (void) binappend(ass,p);

          /* Append statement to statement list */
          /*------------------------------------*/

          d_gstment(&stm_list,ass);


          /*------------------------------------------*/
          /* Generate:  x.fd[1].ubound = 'd_2nddim'   */
          /*------------------------------------------*/

          /* Copy the tree of the last assignment */
          /*--------------------------------------*/

          ass = bincopy(ass);

          /* Updating:   "lbound"   ==>  "ubound" */
          /*--------------------------------------*/

          p = binright(binleft(ass));
          binupsym(p,symins("ubound"));

          /* Updating: right side */
          /*----------------------*/

          binrlink(ass,NIL);                      /* unlink right child */
          (void) binappend(ass,bincopy(d_2nddim));

          /* Append statement to statement list */
          /*------------------------------------*/

          d_gstment(&stm_list,ass);} /* if(struc==d_matrix) */

     /* PJ  06.04.95  (a_VOID) changed to (y_dscp) */

     /*---------------------------------------------------*/
     /* Generate:     y_init(( y_dscp ) &x,...,sizeof(...)) */
     /*---------------------------------------------------*/

     head = d_gcall("y_init");


     /* 1st Argument: Descriptor as reference parameter */
     /*-------------------------------------------------*/

     p = bincreate(cRParent);           /* insert cast Operator: (y_dscp) */
     q = bincreate(cCsymbol);           /*--------------------------------*/
     binupsym(q,symins("y_dscp"));
     (void) binlside(p,q);

     q = binappend(p,bincreate(cAdres));          /* create call by adress */
     (void) binappend(q,binsycreate(res_descr));  /*-----------------------*/

     d_suplparam(head,p,false);


     /* 2nd Argument: 1 for vectors, 2 for matrices */
     /*---------------------------------------------*/

     p = bincreate(cRParent);      /* insert cast Operator: (a_byte) */
     q = bincreate(cCsymbol);      /*------------------------------*/
     binupsym(q,symins("a_byte"));
     (void) binlside(p,q);

     q = bincreate(cIcon);         /* create integer Constant */
     if (struc == d_vector)        /*-------------------------*/
          binupvalue(q,1L);
     else
          binupvalue(q,2L);
     (void) binappend(p,q);

     d_suplparam(head,p,false);


     /* 3rd Argument: Call of 'sizeof(...)' with a descriptor for */
     /*               the basetype at runtime                     */
     /*-----------------------------------------------------------*/

     p = d_gcall("sizeof");

     q = bincreate(cCsymbol);      /* generate argument of 'sizeof(..)' */
     switch (basetype){            /*-----------------------------------*/
          case d_real      : binupsym(q,symins("a_real"));  break;
          case d_interval  : binupsym(q,symins("a_intv"));  break;
          case d_complex   : binupsym(q,symins("a_cmpx"));  break;
          case d_cinterval : binupsym(q,symins("a_cinv"));  break;
          default          :
#ifdef CHECK
                             d_checkerr(cILEBASE,work_start->pos,NULL);
#endif
                             return(bincreate(cSemicolon));} /* switch(...) */

     d_suplparam(p,q,false);
     d_suplparam(head,p,false);

     /* Append statement to statement list */
     /*------------------------------------*/

     d_gstment(&stm_list,head);

     return(stm_list);

} /* d_gresalloc() */



/*****************************************************************************/



#ifdef LINT_ARGS
static binptr d_gresfree (symptr res_descr)
#else
static binptr d_gresfree (res_descr)
symptr         res_descr;
#endif

/*-----------------------------------------------------------------------------
 *
 *  The function returns the statement to mark the result variable as
 *  temporary. It is only used in case of vector or matrix dotexpressions.
 *  I. e. the variable will be marked by an 'y_temp(..)' call, so the memory
 *  used by it will be freed if it is used afterwards in an assignment.
 *

    PJ 06.04.95  (a_VOID) changed to (y_dscp)

 *  The binary tree corresponding to the function call of 'y_temp(..)',
 *  e. g. 'y_temp((y_dscp) &x) is listed below:
 *
 *
 *         cCall: "y_temp"
 *               |
 *               |
 *               cRParent
 *               /       \
 *         cCsymbol   cAdres
 *         "y_dscp" /   \
 *                     cCsymbol:
 *                       "x"
 *
 *
 *
 *  I/O - Parameters:
 *  -----------------
 *
 *        Name       |    Type    |   I/O   |     Meaning
 *        -----------|------------|---------|------------------------------------
 *        res_descr  |   symptr   |    I    |     Descriptor of the result variable
 *
 *
 *  Called Routines:
 *  ----------------
 *
 *        Name         | Short description
 *        -------------|---------------------------------------------------------
 *        bincreate    |   Create a new 'binptr' node
 *        binupsym     |   Update value of the pointer to the symbol table
 *        symins       |   Insert new name into the symbol table
 *        binsycreate  |  Create a 'binptr' node with the specified symbol
 *                     | table entry
 *        binlside     |   Append node to the left
 *        binappend    |   Append node to the right
 *        -------------|---------------------------------------------------------
 *        d_gcall      |   Generate a function call
 *        d_suplparam  |  Suplement another parameter to the argument
 *                     | list
 *
 *---------------------------------------------------------------------------*/

{
     binptr    stm_list,           /* List of statements to be returned    */
               p, q;               /* Help variables                       */


     /* func d_gresfree */
     /*-----------------*/

#ifdef TRACE_ON
     d_trace("'d_gresfree()'");
#endif

     stm_list = NIL;

     /* PJ 06.04.95  Change (a_VOID) to (y_dscp) */

     /*----------------------------------------*/
     /* Generate:    y_temp((y_dscp) &x)       */
     /*----------------------------------------*/

     stm_list = d_gcall("y_temp");


     /* Argument: Descriptor as reference parameter */
     /*---------------------------------------------*/

     p = bincreate(cRParent);           /* insert cast Operator: (y_dscp) */
     q = bincreate(cCsymbol);           /*--------------------------------*/
     binupsym(q,symins("y_dscp"));
     (void) binlside(p,q);

     q = binappend(p,bincreate(cAdres));          /* create call by adress */
     (void) binappend(q,binsycreate(res_descr));  /*-----------------------*/

     d_suplparam(stm_list,p,false);

     return(stm_list);

} /* d_gresfree() */



/**************************************************************************/



#ifdef LINT_ARGS
static binptr d_tmptype(tSTRUCTYPE struc,tARITHTYPE base,binptr row_width,
                        binptr col_width)
#else
static binptr d_tmptype(struc,base,row_width,col_width)
tSTRUCTYPE     struc;
tARITHTYPE     base;
binptr         row_width,col_width;
#endif

/*--------------------------------------------------------------------*/
/* This function creates a bintree representing the datyp for use in  */
/* function 'tempdecl()'. It will only work on vector and matrix      */
/* types.                                                             */
/* It might be nessecary to delete the created tree after usage.      */
/*--------------------------------------------------------------------*/
/* struc, base          = arithmetical structure and basetype         */
/* row_width, col_width = number rows and columns of the variable     */
/*--------------------------------------------------------------------*/

{
     binptr    result,h1,h2;



#ifdef TRACE_ON
     d_trace("'d_tmptype()'");
#endif

#ifdef CHECK
     switch(struc){
          case d_matrix :
               if( col_width == NIL ){
                    d_checkerr(cISNIL,pos,"col_width");
                    return(bincopy(integertype));}
          case d_vector :
               if( row_width == NIL ){
                    d_checkerr(cISNIL,pos,"row_width");
                    return(bincopy(integertype));}
          case d_scalar :
               break;
          default :
               d_checkerr(cISTRUC,pos,NULL);
               return(bincopy(integertype));}
#endif



     switch(struc){
          case d_scalar :
#ifdef CHECK
               d_checkerr(cBADCALL,pos,"d_tmptype()");
#endif
               switch(base){
                    case d_integer   :
                    case d_real      :result=bincreate(cREAL);          break;
                    case d_rdot      :result=bincreate(cDOTPRECISION);  break;
                    case d_complex   :result=bincreate(cCOMPLEX);       break;
                    case d_cdot      :result=bincreate(cCDOTPRECISION); break;  /*new_dot*/
                    case d_interval  :result=bincreate(cINTERVAL);      break;
                    case d_idot      :result=bincreate(cIDOTPRECISION); break;  /*new_dot*/
                    case d_cinterval :result=bincreate(cCINTERVAL);     break;
                    case d_cidot     :result=bincreate(cCIDOTPRECISION);break;  /*new_dot*/}
               break;
          case d_vector :
               switch(base){
                    case d_integer   :
                    case d_real      :
                         result = bincopy(rvectortype);     break;
                    case d_complex   :
                         result = bincopy(cvectortype);     break;
                    case d_interval  :
                         result = bincopy(ivectortype);     break;
                    case d_cinterval :
                         result = bincopy(civectortype);    break;}
               h2    = bincreate(cTill);
               (void) binappend(result,h2);
               h1    = bincreate(cIcon);
               binupvalue(h1,(longint)0);
               (void) binlside(h2,h1);
               (void) binappend(h2,row_width);
               break;
          case d_matrix :
               switch(base){
                    case d_integer   :
                    case d_real      :
                         result = bincopy(rmatrixtype);     break;
                    case d_complex   :
                         result = bincopy(cmatrixtype);     break;
                    case d_interval  :
                         result = bincopy(imatrixtype);     break;
                    case d_cinterval :
                         result = bincopy(cimatrixtype);    break;}
               h1    = bincreate(cComma);
               (void) binappend(result,h1);
               h2    = bincreate(cTill);
               (void) binlside(h1,h2);
               h1    = bincreate(cIcon);
               binupvalue(h1,(longint)0);
               (void) binlside(h2,h1);
               (void) binappend(h2,row_width);
               h1    = binfather(h2);
               h2    = bincreate(cTill);
               (void) binappend(h1,h2);
               h1    = bincreate(cIcon);
               binupvalue(h1,(longint)0);
               (void) binlside(h2,h1);
               (void) binappend(h2,col_width);
               break;} /* switch(struc) */



#ifdef CHECK
     if( result == NIL )
          {d_checkerr(cISNIL,pos,"result");return(bincopy(integertype));}
#endif

     return(result);

} /* d_tmptype() */



/*****************************************************************************/



#ifdef LINT_ARGS
static binptr d_gstart(binptr *r_side)
#else
static binptr d_gstart(r_side)
binptr    *r_side;
#endif

/*--------------------------------------------------------------------*/
/* This function creates the starting sequence for the dot expression */
/* like allocating the accus and the main loop(s) for vector (matrix) */
/* results.                                                           */
/*--------------------------------------------------------------------*/
/* rside = returns address of node to add statements at               */
/*--------------------------------------------------------------------*/

{
     binptr    stm_list,loop,h,h1,h2,res_type,loop_start;



#ifdef TRACE_ON
     d_trace("'d_gstart()'");
#endif



     /*---------------------------------------------------------------*/
     /* initialise variables                                          */
     /*---------------------------------------------------------------*/

     stm_list = (binptr)0;
     accu1 = accu2 = accu3 = accu4 = NIL;
     row_var = col_var = NIL;
     nof_accus = 0;



     /*---------------------------------------------------------------*/
     /* generate the allocation of the accus                          */
     /*---------------------------------------------------------------*/

     switch( base_res ){
          case d_cidot     : /*new_dot*/
          case d_cinterval : accu4 = tempdecl("a4",dotprecisiontype);
                             d_gstment(&stm_list,d_gfp("d_clr",1,ACCU4,-1));
                             accu3 = tempdecl("a3",dotprecisiontype);
                             d_gstment(&stm_list,d_gfp("d_clr",1,ACCU3,-1));
                             nof_accus = 4;
          case d_cdot      : /*new_dot*/
          case d_idot      : /*new_dot*/
          case d_complex   :
          case d_interval  : accu2 = tempdecl("a2",dotprecisiontype);
                             d_gstment(&stm_list,d_gfp("d_clr",1,ACCU2,-1));
                             if(nof_accus==0)nof_accus = 2;
          case d_integer   :
          case d_rdot      :
          case d_real      : accu1 = tempdecl("a1",dotprecisiontype);
                             d_gstment(&stm_list,d_gfp("d_clr",1,ACCU1,-1));
                             if(nof_accus==0)nof_accus = 1;
                             break;
          default :
#ifdef CHECK
                    d_checkerr(cILEBASE,work_start->right->pos,NULL);
#endif
                    *r_side=NIL;return(bincreate(cSemicolon));
          } /* switch() */



     /*---------------------------------------------------------------*/
     /* generate the allocation of the variable to store the final    */
     /* results in.                                                   */
     /*---------------------------------------------------------------*/

     switch( struc_res ){
          /*----------------------------------------------------------*/
          case d_matrix  :
               res_type = d_tmptype(struc_res,work_start->basetype,
                                    d_1stdim,d_2nddim);
               switch( work_start->basetype ){
                    case d_integer   :
                    case d_real      :
                         res_vblk.eltype = idREAL;
                         bin_resvar = tempdecl("Rm",res_type);
                         break;
                    case d_complex   :
                         res_vblk.eltype = idCOMPLEX;
                         bin_resvar = tempdecl("Cm",res_type);
                         break;
                    case d_interval  :
                         res_vblk.eltype = idINTERVAL;
                         bin_resvar = tempdecl("Im",res_type);
                         break;
                    case d_cinterval :
                         res_vblk.eltype = idCINTERVAL;
                         bin_resvar = tempdecl("Zm",res_type);
                         break;} /* switch( work_start->basetype ) */
               res_vblk.original   = true;
               res_vblk.numdim     = 2;
               res_vblk.rowptr     = bincreate(cCsymbol);
               res_vblk.colptr     = bincreate(cCsymbol);
               res_vblk.rowub      = d_1stdim;
               res_vblk.colub      = d_2nddim;
               binupvalue(res_vblk.rowlb=bincreate(cIcon),(longint)0);
               binupvalue(res_vblk.collb=bincreate(cIcon),(longint)0);
               res_vblk.element    = d_gfp("y_ynx2",3,
                                             d_varcopy(bin_resvar),0,
                                             res_vblk.rowptr,0,
                                             res_vblk.colptr,0);

               h = d_gresalloc(binsym(bin_resvar),
                               work_start->basetype,
                               work_start->structure);
               d_gstment(&stm_list,h);
               break;
          /*----------------------------------------------------------*/
          case d_vector  :
               res_type = d_tmptype(struc_res,work_start->basetype,
                                    d_1stdim,NIL);
               switch( work_start->basetype ){
                    case d_integer   :
                    case d_real      :
                         res_vblk.eltype = idREAL;
                         bin_resvar = tempdecl("Rv",res_type);
                         break;
                    case d_complex   :
                         res_vblk.eltype = idCOMPLEX;
                         bin_resvar = tempdecl("Cv",res_type);
                         break;
                    case d_interval  :
                         res_vblk.eltype = idINTERVAL;
                         bin_resvar = tempdecl("Iv",res_type);
                         break;
                    case d_cinterval :
                         res_vblk.eltype = idCINTERVAL;
                         bin_resvar = tempdecl("Zv",res_type);
                         break;} /* switch( work_start->basetype ) */
               /* bintdelete(&res_type); */
               res_vblk.original   = true;
               res_vblk.numdim     = 1;
               res_vblk.rowptr     = bincreate(cCsymbol);
               res_vblk.colptr     = NIL;
               res_vblk.rowub      = d_1stdim;
               res_vblk.colub      = NIL;
               binupvalue(res_vblk.rowlb=bincreate(cIcon),(longint)0);
               res_vblk.collb      = NIL;
               res_vblk.element    = d_gfp("y_ynx1",2,
                                             d_varcopy(bin_resvar),0,
                                             res_vblk.rowptr,0);
               h = d_gresalloc(binsym(bin_resvar),
                               work_start->basetype,
                               work_start->structure);
               d_gstment(&stm_list,h);
               break;
          /*----------------------------------------------------------*/
          case d_scalar  :
               switch( work_start->basetype ){
                    case d_rdot      :
                         res_vblk.eltype = idDOTPRECISION;
                         bin_resvar      = bincopy(accu1);
                         break;
                    case d_cdot      : /*new_dot*/
                         res_vblk.eltype = idCDOTPRECISION;
                         bin_resvar      = tempdecl("Dc",cdotprecisiontype);
                         break;
                    case d_idot      : /*new_dot*/
                         res_vblk.eltype = idIDOTPRECISION;
                         bin_resvar      = tempdecl("Di",idotprecisiontype);
                         break;
                    case d_cidot     : /*new_dot*/
                         res_vblk.eltype = idCIDOTPRECISION;
                         bin_resvar      = tempdecl("Dz",cidotprecisiontype);
                         break;
                    case d_integer   :
                    case d_real      :
                         res_vblk.eltype = idREAL;
                         bin_resvar = tempdecl("Rs",realtype);
                         break;
                    case d_complex   :
                         res_vblk.eltype = idCOMPLEX;
                         bin_resvar = tempdecl("Cs",complextype);
                         break;
                    case d_interval  :
                         res_vblk.eltype = idINTERVAL;
                         bin_resvar = tempdecl("Is",intervaltype);
                         break;
                    case d_cinterval :
                         res_vblk.eltype = idCINTERVAL;
                         bin_resvar = tempdecl("Zs",cintervaltype);
                         break;} /* switch( work_start->basetype ) */
               res_vblk.original   = false;
               res_vblk.numdim     = 0;
               res_vblk.rowptr     = NIL;
               res_vblk.colptr     = NIL;
               res_vblk.rowub      = NIL;
               res_vblk.colub      = NIL;
               res_vblk.rowlb      = NIL;
               res_vblk.collb      = NIL;
               res_vblk.element    = bin_resvar;
               break;
          /*----------------------------------------------------------*/
          default :
#ifdef CHECK
                    d_checkerr(cILESTRUC,work_start->right->pos,NULL);
#endif
                    *r_side=NIL;return(bincreate(cSemicolon));
          } /* switch( struc_res ) */



     /*---------------------------------------------------------------*/
     /* generate the allocation of the count variable(s) for the main */
     /* loop(s)                                                       */
     /*---------------------------------------------------------------*/

     switch( struc_res ){
          case d_matrix  : col_var = tempdecl("Nc",integertype);
          case d_vector  : row_var = tempdecl("Nr",integertype);
          } /* switch() */



     /*---------------------------------------------------------------*/
     /* generate the main loop(s)                                     */
     /*---------------------------------------------------------------*/

     loop = h1 = h2 = NIL;
     binupvalue(loop_start=bincreate(cIcon),(longint)0);

     switch( struc_res ){
          case d_matrix : loop = d_gloop(d_varcopy(col_var),
                                         bincopy(loop_start),
                                         bincopy(d_2nddim),&h1,cTO);
          case d_vector : if( h1 == NIL )
                               loop = d_gloop(d_varcopy(row_var),loop_start,
                                              bincopy(d_1stdim),&h2,cTO);
                          else
                               (void) binappend(h1,d_gloop(
                                                      d_varcopy(row_var),
                                                      loop_start,
                                                      bincopy(d_1stdim),
                                                      &h2,cTO));
          } /* switch() */

     if( loop != NIL ) d_gstment(&stm_list,loop);



#ifdef CHECK
     if( stm_list == NIL ){
          d_checkerr(cISNIL,work_start->right->pos,"stm_list");
          *r_side=NIL;return(bincreate(cSemicolon));}
#endif



     /*---------------------------------------------------------------*/
     /* set result value and return pointer to created tree           */
     /*---------------------------------------------------------------*/

     *r_side = h2;
     return(stm_list);

} /* d_gstart() */



/**************************************************************************/



#ifdef LINT_ARGS
static binptr d_gfinassign(void)
#else
static binptr d_gfinassign()
#endif

{
     binptr    stm_list,res_comp;
     char      *funcname;
     tVARINFO  info;



#ifdef TRACE_ON
     d_trace("'d_gfinassign()'");
#endif



     stm_list = NIL;



     /*---------------------------------------------------------------*/
     /* create the bintree representing the component of the result   */
     /* buffer array (i.e. a single "cIdent" in scalar case).         */
     /*---------------------------------------------------------------*/

     info.struc      = struc_res;
     info.base       = d_anyarith;
     info.ptr.varptr = &res_vblk;
     info.row        = row_var;
     info.col        = col_var;
     info.c_symptr   = info.i_symptr = symNIL;
     res_comp        = d_gvarelem(&info);



     /*---------------------------------------------------------------*/
     /* compute the name of the rounding routine and the parameters   */
     /* needed                                                        */
     /*---------------------------------------------------------------*/

     switch( work_start->name.direct ){
          /*----------------------------------------------------------*/
          case d_sharp : /*new_dot*/
#ifdef CHECK
               if( struc_res != d_scalar ){
                    d_checkerr(cILRRES,work_start->pos,"#");
                    return(bincreate(cSemicolon));}
#endif
               switch( base_res ){
                    case d_integer   :
                    case d_real      :
                    case d_rdot      : funcname = NULL;     break;
                    case d_complex   :
                    case d_cdot      : funcname = "c_dsta"; break;
                    case d_interval  :
                    case d_idot      : funcname = "i_dsta"; break;
                    case d_cinterval :
                    case d_cidot     : funcname = "z_dsta"; break;
                    default :
#ifdef CHECK
                         d_checkerr(cILRRES,work_start->pos,"#");
#endif
                         return(bincreate(cSemicolon));}
               break;
          /*----------------------------------------------------------*/
          case d_sharpnext :
               switch( base_res ){
                    case d_rdot      :
                    case d_real      :
                    case d_integer   :
                         funcname = "d_stan";
                         break;
                    case d_cdot      :  /*new_dot*/
                    case d_complex   :
                         funcname = "c_stan";
                         break;
                    default :
#ifdef CHECK
                              d_checkerr(cILRRES,work_start->pos,"#*");
#endif
                              return(bincreate(cSemicolon));
                    } /* switch(base_res) */
               break;
          /*----------------------------------------------------------*/
          case d_sharpup :
               switch( base_res ){
                    case d_rdot      :
                    case d_real      :
                    case d_integer   :
                         funcname = "d_stau";
                         break;
                    case d_cdot      :  /*new_dot*/
                    case d_complex   :
                         funcname = "c_stau";
                         break;
                    default :
#ifdef CHECK
                              d_checkerr(cILRRES,work_start->pos,"#>");
#endif
                              return(bincreate(cSemicolon));
                    } /* switch(base_res) */
               break;
          /*----------------------------------------------------------*/
          case d_sharpdown :
               switch( base_res ){
                    case d_rdot      :
                    case d_real      :
                    case d_integer   :
                         funcname = "d_stad";
                         break;
                    case d_cdot      :  /*new_dot*/
                    case d_complex   :
                         funcname = "c_stad";
                         break;
                    default :
#ifdef CHECK
                              d_checkerr(cILRRES,work_start->pos,"#<");
#endif
                              return(bincreate(cSemicolon));
                    } /* switch(base_res) */
               break;
          /*----------------------------------------------------------*/
          case d_sharpintval :
               switch( base_res ){
                    case d_rdot      :
                    case d_real      :
                    case d_integer   :
                         nof_accus = 2;
                         accu2 = accu1;
                         funcname = "i_ista";
                         break;
                    case d_cdot      :  /*new_dot*/
                    case d_complex   :
                         nof_accus = 4;
                         accu3 = accu1;
                         accu4 = accu2;
                         funcname = "z_zsta";
                         break;
                    case d_idot      :  /*new_dot*/
                    case d_interval  :
                         funcname = "i_ista";
                         break;
                    case d_cidot     :  /*new_dot*/
                    case d_cinterval :
                         funcname = "z_zsta";
                         break;
                    default :
#ifdef CHECK
                              d_checkerr(cILRRES,work_start->pos,"##");
#endif
                              return(bincreate(cSemicolon));
                    } /* switch(base_res) */
               break;
          /*----------------------------------------------------------*/
          default :
#ifdef CHECK
                    d_checkerr(cILRSYM,work_start->pos,NULL);
#endif
                    return(bincreate(cSemicolon));
          } /* switch(work_start->name.direct) */




     /*---------------------------------------------------------------*/
     /* generate the assignment from accus to result variable         */
     /*---------------------------------------------------------------*/


     if( funcname != NULL )
          d_gstment(&stm_list,
                    d_gassign(res_comp,
                              d_gfp(funcname,nof_accus,ACCU1,0,ACCU2,0,
                                                       ACCU3,0,ACCU4,0)));



#ifdef CHECK
     if (work_start->name.direct != d_sharp)
          if( stm_list == NIL ){
               d_checkerr(cISNIL,work_start->pos,"stm_list");
               return(bincreate(cSemicolon));}
#endif



     return(stm_list);

} /* d_gfinassign() */



/**************************************************************************/



#ifdef LINT_ARGS
static binptr d_gend(void)
#else
static binptr d_gend()
#endif

/*--------------------------------------------------------------------*/
/* This function creates the final statements to claer up             */
/*--------------------------------------------------------------------*/

{
     binptr    stm_list;



#ifdef TRACE_ON
     d_trace("'d_gend()'");
#endif


     stm_list = NIL;


     /*--------------------------*/
     /* undeclare temp variables */
     /*--------------------------*/

     d_undecl(accu1);
     d_undecl(accu2);
     d_undecl(accu3);
     d_undecl(accu4);
     d_undecl(row_var);
     d_undecl(col_var);

     d_undecl(d_1stdim);
     d_undecl(d_2nddim);

     tempvar = bin_resvar;    /* will be freed later by d_seman() */


     /*---------------------------------------------------------*/
     /* If the expression is of type vector or matrix then the   */
     /* result variable ist to be markt as temporary at runtime */
     /*---------------------------------------------------------*/

     if ( (struc_res == d_vector) || (struc_res == d_matrix) )
       d_gstment(&stm_list,d_gresfree(binsym(bin_resvar)));


#ifdef CHECK
     if( (stm_list == NIL) && (struc_res != d_scalar) ){
          d_checkerr(cISNIL,work_start->right->pos,"stm_list");
          return(bincreate(cSemicolon));}
#endif


     return(stm_list);

} /* d_gend() */



/**************************************************************************/



#ifdef LINT_ARGS
static binptr d_gclraccus(void)
#else
static binptr d_gclraccus()
#endif

{
     binptr    stm_list;



     stm_list = NIL;




     switch(base_res){
          case d_cidot     : /*new_dot*/
          case d_cinterval : d_gstment(&stm_list,d_gfp("d_clr",1,ACCU4,-1));
                             d_gstment(&stm_list,d_gfp("d_clr",1,ACCU3,-1));
          case d_idot      : /*new_dot*/
          case d_interval  :
          case d_cdot      : /*new_dot*/
          case d_complex   : d_gstment(&stm_list,d_gfp("d_clr",1,ACCU2,-1));
          case d_real      :
          case d_integer   :
          case d_rdot      : d_gstment(&stm_list,d_gfp("d_clr",1,ACCU1,-1));
                             break;
          default :
#ifdef CHECK
                    d_checkerr(cILEBASE,work_start->right->pos,NULL);
#endif
                    return(bincreate(cSemicolon));} /* switch(base_res) */



#ifdef CHECK
     if( stm_list == NIL ){
          d_checkerr(cISNIL,work_start->right->pos,"stm_list");
          return(bincreate(cSemicolon));}
#endif



     return(stm_list);

} /* d_gclraccus() */



/**************************************************************************/



#ifdef LINT_ARGS
binptr d_gexpr(tNODE *work)
#else
binptr d_gexpr(work)
tNODE     *work;
#endif

/*--------------------------------------------------------------------*/
/* This function generates a list of statement replacing the expres-  */
/* sion defined by the input worktree.                                */
/* It returns a pointer to the created bintree.                       */
/*--------------------------------------------------------------------*/
/* work = pointer to work (sub)tree                                   */
/*--------------------------------------------------------------------*/

{
     binptr    stm_list;
     postype   save_pos;



#ifdef TRACE_ON
     d_trace("'d_gexpr()'");
#endif

#ifdef CHECK
     if( work == NULL ){
          d_checkerr(cISNULL,pos,"work");
          return(bincreate(cSemicolon));}
     if( (work->namekind==d_direct) && (work->name.direct==d_plus) ){
          if( work->right == NULL ){
               d_checkerr(cISNULL,work->pos,"work->right");
               return(bincreate(cSemicolon));}
          if( work->left == NULL ){
               d_checkerr(cISNULL,work->pos,"work->left");
               return(bincreate(cSemicolon));}}
#endif



     save_pos = pos;
     pos = work->pos;

     stm_list = (binptr)0;



     /*---------------------------------------------------------------*/
     /* Add addition statements as long as node is a 'd_plus'         */
     /*---------------------------------------------------------------*/

     while( (work->namekind==d_direct) && (work->name.direct==d_plus) ){
          d_gstment(&stm_list,d_gadlist(work->right) );
          work = work->left;}



     /*---------------------------------------------------------------*/
     /* Add last element in tree                                      */
     /*---------------------------------------------------------------*/

     d_gstment( &stm_list, d_gadlist(work) );



     /*---------------------------------------------------------------*/
     /* return a pointer to the generated statement list              */
     /*---------------------------------------------------------------*/

#ifdef CHECK
     if( stm_list == NIL ){
          d_checkerr(cISNIL,work->pos,"stm_list");
          pos = save_pos;
          return(bincreate(cSemicolon));}
#endif

     pos = save_pos;
     return(stm_list);

} /* d_gexpr() */



/**************************************************************************/



#ifdef LINT_ARGS
binptr d_gloop(binptr run_var,binptr start_expr,binptr end_expr,
                          binptr *r_side,symctype direc)
#else
binptr d_gloop(run_var,start_expr,end_expr,r_side,direc)
binptr    run_var,start_expr,end_expr,*r_side;
symctype  direc;
#endif

/*--------------------------------------------------------------------*/
/* This function generates a loop                                     */
/* It returns a pointer to the created bintree                        */
/*--------------------------------------------------------------------*/
/* run_var              = pointer to copy of the count variable       */
/* start_expr, end_expr = bintrees, describing the loop width         */
/* r_side               = returns address of node to add statements   */
/* direc                = MUST contain values 'cTO' or 'cDOWNTO'      */
/*--------------------------------------------------------------------*/

{
     binptr result,help;



#ifdef TRACE_ON
     d_trace("'d_gloop()'");
#endif

#ifdef CHECK
     if( run_var == NIL ){
          d_checkerr(cISNIL,pos,"run_var");
          *r_side = NIL;return(bincreate(cSemicolon));}
     if( start_expr == NIL ){
          d_checkerr(cISNIL,pos,"start_expr");
          *r_side = NIL;return(bincreate(cSemicolon));}
     if( end_expr == NIL ){
          d_checkerr(cISNIL,pos,"end_expr");
          *r_side = NIL;return(bincreate(cSemicolon));}
#endif



     /*---------------------------------------------------------------*/
     /* create cFOR node                                              */
     /*---------------------------------------------------------------*/

     result = bincreate(cFOR);



     /*---------------------------------------------------------------*/
     /* create "run_var:=start_expr" and append as left child         */
     /*---------------------------------------------------------------*/

     (void) binlside( result, d_gassign(run_var,start_expr) );



     /*---------------------------------------------------------------*/
     /* append cTO node as right child. (help points to the cTO node) */
     /*---------------------------------------------------------------*/

     help = binappend(result,bincreate(direc));
     *r_side = help;



     /*---------------------------------------------------------------*/
     /* append 'end_expr' as left child to cTO node                   */
     /*---------------------------------------------------------------*/

     (void) binlside(help,end_expr);



     /*---------------------------------------------------------------*/
     /* return pointer to cFOR node                                   */
     /*---------------------------------------------------------------*/

#ifdef CHECK
     if( result == NIL ){
          d_checkerr(cISNIL,pos,"result");
          *r_side = NIL;return(bincreate(cSemicolon));}
#endif

     return(result);

} /* d_gloop() */



/**************************************************************************/



#ifdef IBMva

global binptr d_gfp(func_name, nof_params, va_alist)
char *func_name;
int  nof_params;
va_dcl

#else

global binptr d_gfp(char *func_name, int nof_params, ... )

#endif

/*--------------------------------------------------------------------*/
/* "Generate Functioncall with Parameters"                            */
/*                                                                    */
/* This function generates a full call to the runtime function        */
/* 'func_name'. 'nof_params' contains the number of the parameters    */
/* of the call to generate. The parameters to be added to the func-   */
/* tion list are passed by 'binptr' variables.                        */
/* Each parameter is followed by an integer describing whether the    */
/* parameter to be generated will be a VAR parameter ( -1 ) or        */
/* not ( 0 ).                                                         */
/* If a parameter is passed with 'NIL', it will be skipped.           */
/*                                                                    */
/* This function is implemented as 'variable-length argument list'.   */
/*                                                                    */
/* For example:                                                       */
/*             'd_gfp("func",2,param1,-1,param2,0)'                   */
/* will generate the function call:                                   */
/*             'func(&param1,param2)'                                 */
/*                                                                    */
/*--------------------------------------------------------------------*/
/* func_name  = pointer to name of function                           */
/* nof_params = number of parameters the created function will have   */
/*--------------------------------------------------------------------*/

{
     binptr    result,param;
     int       varp,cnt;
     va_list   arg_ptr;
     boolean   flag;



     result = d_gcall(func_name);
#ifdef IBMva
     va_start(arg_ptr);
#else
     va_start(arg_ptr,nof_params);
#endif

     for(cnt=0;cnt<nof_params;cnt++){
          param = va_arg(arg_ptr,binptr);
          varp  = va_arg(arg_ptr,int);
          if(param!=NIL){
               flag = (varp!=0) ? true : false;
               d_suplparam(result,param,flag);}}

     va_end(arg_ptr);
     return(result);

} /* d_gfp() */



/**************************************************************************/



#ifdef LINT_ARGS
binptr d_varcopy(binptr var_ptr)
#else
binptr d_varcopy(var_ptr)
binptr var_ptr;
#endif

/*--------------------------------------------------------------------*/
/* This function creates a copy of a variable for the use in expres-  */
/* sions. If the variable was created by 'tempdecl' (i.e. the first   */
/* node is 'cCsymbol') a the routine will not copy the right child of */
/* the variable tree.                                                 */
/*--------------------------------------------------------------------*/
/* var_ptr = pointer to the binptr tree                               */
/*--------------------------------------------------------------------*/

{
     binptr    result;



#ifdef TRACE_ON
     d_trace("'d_varcopy()'");
#endif



     if(var_ptr==NIL)return(NIL);

     if( binsymc(var_ptr) != cCsymbol )return(bincopy(var_ptr));

     result = bincreate(cCsymbol);
     binupsym(result,binsym(var_ptr));
     return(result);

} /* d_varcopy() */



/**************************************************************************/



#ifdef LINT_ARGS
void d_undecl(binptr var_ptr)
#else
void d_undecl(var_ptr)
binptr    var_ptr;
#endif

/*--------------------------------------------------------------------*/
/* mark temp variable as not needed anymore.                          */
/*--------------------------------------------------------------------*/
/* var_ptr = pointer to the binptr tree                               */
/*--------------------------------------------------------------------*/

{
#ifdef TRACE_ON
     d_trace("'d_undecl()'");
#endif



     if(var_ptr!=NIL)binchange(var_ptr,cTempvar);

} /* d_undecl() */



/**************************************************************************/



#ifdef LINT_ARGS
global void d_generate(tNODE *source,binptr *res_bin,binptr *res_var)
#else
global void d_generate(source,res_bin,res_var)
tNODE     *source;
binptr    *res_bin,*res_var;
#endif

/*--------------------------------------------------------------------*/
/* This function executes the generation of the bintree.              */
/* It returns a pointer to the temp variable containing the result.   */
/*--------------------------------------------------------------------*/
/* source  = pointer to the source subtree                            */
/* res_bin = address of pointer to the root                           */
/* res_var = address of pointer to the result variable                */
/*--------------------------------------------------------------------*/

{
     binptr    root,stm_list,add_here;
     postype   save_pos;



#ifdef TRACE_ON
     d_trace("'d_generate()'");
#endif

#ifdef CHECK
     if( source == NULL ){
          d_checkerr(cISNULL,pos,"source");
          *res_bin=NIL;*res_var=NIL;return;}
     if( source->right == NULL ){
          d_checkerr(cISNULL,source->pos,"source->right");
          *res_bin=NIL;*res_var=NIL;return;}
#endif



     save_pos = pos;
     pos = source->pos;



     /*---------------------------------------------------------------*/
     /* initialise global values describing the source tree           */
     /*---------------------------------------------------------------*/

     work_start = source;
     struc_res  = source->right->structure;
     base_res   = source->right->basetype;



     /*---------------------------------------------------------------*/
     /* generate the start sequences                                  */
     /*---------------------------------------------------------------*/

     root      = d_gstart(&add_here);
     plus_mode = true;
     if (struc_res != d_scalar)         /* Clearing accus only within      */
          stm_list  = d_gclraccus();    /* a loop for computing vector     */
     else                               /* or matrix components required   */
          stm_list  = (binptr)0;

     /*---------------------------------------------------------------*/
     /* generate expression tree                                      */
     /*---------------------------------------------------------------*/
     d_gstment(&stm_list,d_gexpr(source->right));


     /*---------------------------------------------------------------*/
     /* generate the final assignment and finish the main loop(s)     */
     /*---------------------------------------------------------------*/

     d_gstment( &stm_list, d_gfinassign() );



     /*---------------------------------------------------------------*/
     /* append statement list to the loops as possible                */
     /*---------------------------------------------------------------*/

#ifdef CHECK
     if( stm_list == NIL ){
          d_checkerr(cISNIL,source->pos,"stm_list");
          pos = save_pos;*res_bin=NIL;*res_var=NIL;return;}
#endif

     if( root != NIL )
          if( add_here != NIL )
               (void) binappend(add_here,stm_list);
          else
               d_gstment(&root,stm_list);
     else
          root = stm_list;



     /*---------------------------------------------------------------*/
     /* Add clearup statements to the root expression                 */
     /*---------------------------------------------------------------*/

     d_gstment(&root,d_gend());



     /*---------------------------------------------------------------*/
     /* set return values and delete local tree(s)                    */
     /*---------------------------------------------------------------*/

     *res_bin = root;
     *res_var = bin_resvar;

     pos = save_pos;

} /* d_generate() */



/**************************************************************************/
