/**********************************************************************/
/*                                                                    */
/*   "DP_GEN_2.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 2).                       */
/*                                                                    */
/* Feb-01-92 Just : Macro WPRINT_ON and dependend include of          */
/*                  "DP_UTIL.INC" added.                              */
/* Feb-02-92 Just : Function 'd_mmintoop()' added; is called in       */
/*                  'd_gfuncelem()' after 'd_idoptim()'.              */
/* Feb-03-92 Just : Prototype deklarations of static functions        */
/*                  removed.                                          */
/* Feb-08-92 Just : Function 'd_mmintoop()' corrected.                */
/* Feb-11-92 Just : Hopefully all changes made to this file accepting */
/*                  new types d_cdot, d_idot & d_cidot.               */
/* Mar-04-92 Just : Types d_cdot, d_idot & d_cidot added as legal     */
/*                  dotexpression result types for product additions  */
/*                  in function 'd_gaddition()'                       */
/* Mar-07-92 Just : macro 'NEW_PROTO' --> 'LINT_ARGS'                 */
/*                                                                    */
/* Apr-01-92 Just : d_mintoop 'oppsym' changed to 'opcsym'            */
/* Apr-23-92 Just : generation of named constants changed.            */
/* Apr-26-92 Just : Generation of constants is now done by function   */
/*                  'd_gconstant()' and function 'd_gnrconst()'       */
/*                  called by 'd_gconstant()'.                        */
/*                  Due to these changes, function 'd_contoreal()' is */
/*                  removed.                                          */
/* Sep-22-92 Just : functions 'd_gdaelem()' and 'd_gdotadd()' removed */
/* Oct-26-93 Just : Error removed                                     */
/*                  - 'info->mat_transp' is set in function           */
/*                    'd_gfuncarg()'                                  */
/*                  - 'info->mat_transp' is used in function          */
/*                    'd_gaddmul()' to create addition range          */
/*                                                                    */
/**********************************************************************/



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



#include <stdlib.h>
#include <string.h>
#include <stdio.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        "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_1.h"
#include "expor.t"

#include        "dp_gen_2.h"
#include "implemen.t"


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



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



#ifdef LINT_ARGS
static binptr d_gaddition(tNODE *work,binptr l_opnd,binptr r_opnd,tOPTBLK *optblk)
#else
static binptr d_gaddition(work,l_opnd,r_opnd,optblk)
tNODE   *work;
binptr  l_opnd,r_opnd;
tOPTBLK *optblk;
#endif

/*--------------------------------------------------------------------*/
/* This function generates an addition/product-addition of one/two    */
/* argument(s).                                                       */
/*--------------------------------------------------------------------*/
/* work           = pointer to product expression                     */
/* l_opnd, r_opnd = left and right argument of product                */
/* optblk         = pointer to optimization block                     */
/*--------------------------------------------------------------------*/

{
  char         *fname;
  binptr       help,result,fcall;
  binptr       locac1,locac2,locac3,locac4;
  tARITHTYPE   l_base,r_base;
  binptr       opnd1,opnd2;
  boolean      two_calls;
  postype      save_pos;



  save_pos  = pos;
  pos       = work->pos;



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

#ifdef CHECK
  if( work == NULL ){
    d_checkerr(cISNULL,pos,"work");
    pos = save_pos;return(bincreate(cSemicolon));}
#endif



  locac1 = locac2 = locac3 = locac4 = NIL;
  opnd1 = opnd2 = NIL;



  if( (work->namekind!=d_direct) || (work->name.direct!=d_mult) ){

    /*-------------------------------------------------*/
    /* compute function name and parameters for simple */
    /* additions                                       */
    /*-------------------------------------------------*/
    opnd1 = l_opnd;

    switch(base_res){
      /*-----------------------------------------------------*/
      case d_real    :
      case d_integer :
      case d_rdot    :
        switch(work->basetype){
          case d_integer :
          case d_real    :
            fname     = plus_mode ? "d_radd" : "d_rsub";
            locac1    = ACCU1;
            two_calls = false;
            break;
          case d_rdot :
            fname     = plus_mode ? "d_dadd" : "d_dsub";
            locac1    = ACCU1;
            two_calls = false;
            break;
          default : 
#ifdef CHECK
            d_checkerr(cILBASE,pos,NULL);
#endif
            pos = save_pos;
            return(bincreate(cSemicolon));} /* switch(work->basetype) */
        break;
      /*-----------------------------------------------------*/
      case d_complex :
      case d_cdot    : /*new_dot*/
        switch(work->basetype){
          case d_integer :
          case d_real    :
            fname     = plus_mode ? "d_radd" : "d_rsub";
            locac1    = ACCU1;
            two_calls = false;
            break;
          case d_rdot :
            fname     = plus_mode ? "d_dadd" : "d_dsub";
            locac1    = ACCU1;
            two_calls = false;
            break;
          case d_complex :
            fname     = plus_mode ? "c_cadd" : "c_csub";
            locac1    = ACCU1;
            locac2    = ACCU2;
            two_calls = false;
            break;
          case d_cdot : /*new_dot*/
            fname     = plus_mode ? "c_dadd" : "c_dsub";
            locac1    = ACCU1;
            locac2    = ACCU2;
            two_calls = false;
            break;
          default :
#ifdef CHECK
            d_checkerr(cILBASE,pos,NULL);
#endif
            pos = save_pos;
            return(bincreate(cSemicolon));} /* switch(work->basetype) */
        break;
      /*-----------------------------------------------------*/
      case d_interval :
      case d_idot     : /*new_dot*/
        switch(work->basetype){
          case d_integer :
          case d_real    :
            fname     = plus_mode ? "d_radd" : "d_rsub";
            locac1    = ACCU1;
            locac3    = ACCU2;
            two_calls = true;
            break;
          case d_rdot :
            fname     = plus_mode ? "d_dadd" : "d_dsub";
            locac1    = ACCU1;
            locac3    = ACCU2;
            two_calls = true;
            break;
          case d_interval :
            fname     = plus_mode ? "i_iadd" : "i_isub";
            locac1    = ACCU1;
            locac2    = ACCU2;
            two_calls = false;
            break;
          case d_idot : /*new_dot*/
            fname     = plus_mode ? "i_dadd" : "i_dsub";
            locac1    = ACCU1;
            locac2    = ACCU2;
            two_calls = false;
            break;
          default :
#ifdef CHECK
            d_checkerr(cILBASE,pos,NULL);
#endif
            pos = save_pos;
            return(bincreate(cSemicolon));} /* switch(work->basetype) */
        break;
      /*-----------------------------------------------------*/
      case d_cinterval :
      case d_cidot     : /*new_dot*/
        switch(work->basetype){
          case d_integer :
          case d_real    :
            fname     = plus_mode ? "d_radd" : "d_rsub";
            locac1    = ACCU1;
            locac3    = ACCU3;
            two_calls = true;
            break;
          case d_rdot :
            fname     = plus_mode ? "d_dadd" : "d_dsub";
            locac1    = ACCU1;
            locac3    = ACCU3;
            two_calls = true;
            break;
          case d_complex :
            fname     = plus_mode ? "c_cadd" : "c_csub";
            locac1    = ACCU1;
            locac2    = ACCU2;
            locac3    = ACCU3;
            locac4    = ACCU4;
            two_calls = true;
            break;
          case d_cdot : /*new_dot*/
            fname     = plus_mode ? "c_dadd" : "c_dsub";
            locac1    = ACCU1;
            locac2    = ACCU2;
            locac3    = ACCU3;
            locac4    = ACCU4;
            two_calls = true;
            break;
          case d_interval :
            fname     = plus_mode ? "i_iadd" : "i_isub";
            locac1    = ACCU1;
            locac2    = ACCU3;
            two_calls = false;
            break;
          case d_idot : /*new_dot*/
            fname     = plus_mode ? "i_dadd" : "i_dsub";
            locac1    = ACCU1;
            locac2    = ACCU3;
            two_calls = false;
            break;
          case d_cinterval :
            fname     = plus_mode ? "z_zadd" : "z_zsub";
            locac1    = ACCU1;
            locac2    = ACCU2;
            locac3    = ACCU3;
            locac4    = ACCU4;
            two_calls = false;
            break;
          case d_cidot : /*new_dot*/
            fname     = plus_mode ? "z_dadd" : "z_dsub";
            locac1    = ACCU1;
            locac2    = ACCU2;
            locac3    = ACCU3;
            locac4    = ACCU4;
            two_calls = false;
            break;
          default :
#ifdef CHECK
            d_checkerr(cILBASE,pos,NULL);
#endif
            pos = save_pos;
            return(bincreate(cSemicolon));} /* switch(work->basetype) */
        break;
      /*-----------------------------------------------------*/
      default : 
#ifdef CHECK
        d_checkerr(cILEBASE,pos,NULL);
#endif
        pos = save_pos;
        return(bincreate(cSemicolon));
      /*-----------------------------------------------------*/
      } /* switch(base_res) */} /* if()...then... */

  else{

    /*------------------------------------------------------*/
    /* compute function name and parameters for product     */
    /* additions                                            */
    /*------------------------------------------------------*/

#ifdef CHECK
    if( work->left == NULL ){
      d_checkerr(cISNULL,work->pos,"work->left");
      pos = save_pos;return(bincreate(cSemicolon));}
    if( work->right == NULL ){
      d_checkerr(cISNULL,work->pos,"work->right");
      pos = save_pos;return(bincreate(cSemicolon));}
#endif

    l_base = work->left->basetype;
    r_base = work->right->basetype;

#ifdef CHECK
    switch(l_base){
      case d_rdot: case d_cdot: case d_idot: case d_cidot :
        d_checkerr(cMULDOT,work->left->pos,NULL);
        pos = save_pos;return(bincreate(cSemicolon));
      default : break;}
    switch(r_base){
      case d_rdot: case d_cdot: case d_idot: case d_cidot :
        d_checkerr(cMULDOT,work->right->pos,NULL);
        pos = save_pos;return(bincreate(cSemicolon));
      default : break;}
#endif

    switch(base_res){
      /*-----------------------------------------------------*/
      case d_integer :
      case d_real    :
      case d_rdot    :
        switch(l_base){
          /* - - - - - - - - - - - - - - - - - - - - - - - - */
          case d_integer :
          case d_real    :
            switch(r_base){
                case d_integer :
                case d_real    :
                fname     = plus_mode ? "d_padd" : "d_psub";
                locac1    = ACCU1;
                two_calls = false;
                opnd1     = l_opnd;
                opnd2     = r_opnd;
                break;
                default :
#ifdef CHECK 
                d_checkerr(cILBASE,work->right->pos,NULL);
#endif
                pos = save_pos;
                return(bincreate(cSemicolon));} /* switch(r_base) */
            break;
          /* - - - - - - - - - - - - - - - - - - - - - - - - */
          default :
#ifdef CHECK 
            d_checkerr(cILBASE,work->left->pos,NULL);
#endif
            pos = save_pos;return(bincreate(cSemicolon));
          /* - - - - - - - - - - - - - - - - - - - - - - - - */
          } /* switch(l_base) */
        break;
      /*-----------------------------------------------------*/
      case d_complex :
      case d_cdot    : /* new_dot */
        switch(l_base){
          /* - - - - - - - - - - - - - - - - - - - - - - - - */
          case d_integer :
          case d_real    :
            switch(r_base){
                case d_integer :
                case d_real    :
                fname     = plus_mode ? "d_padd" : "d_psub";
                locac1    = ACCU1;
                two_calls = false;
                opnd1     = l_opnd;
                opnd2     = r_opnd;
                break;
                case d_complex :
                fname     = plus_mode ? "c_rcad" : "c_rcsb";
                locac1    = ACCU1;
                locac2    = ACCU2;
                two_calls = false;
                opnd1     = l_opnd;
                opnd2     = r_opnd;
                break;
                default :
#ifdef CHECK
                d_checkerr(cILBASE,work->right->pos,NULL);
#endif
                pos = save_pos;
                return(bincreate(cSemicolon));} /* switch(r_base) */
            break;
          /* - - - - - - - - - - - - - - - - - - - - - - - - */
          case d_complex :
            switch(r_base){
                case d_integer :
                case d_real    :
                fname     = plus_mode ? "c_rcad" : "c_rcsb";
                locac1    = ACCU1;
                locac2    = ACCU2;
                two_calls = false;
                opnd1     = r_opnd;
                opnd2     = l_opnd;
                break;
                case d_complex :
                fname     = plus_mode ? "c_padd" : "c_psub";
                locac1    = ACCU1;
                locac2    = ACCU2;
                two_calls = false;
                opnd1     = l_opnd;
                opnd2     = r_opnd;
                break;
                default :
#ifdef CHECK
                d_checkerr(cILBASE,work->right->pos,NULL);
#endif
                pos = save_pos;
                return(bincreate(cSemicolon));} /* switch(r_base) */
            break;
          /* - - - - - - - - - - - - - - - - - - - - - - - - */
          default :
#ifdef CHECK
            d_checkerr(cILBASE,work->left->pos,NULL);
#endif
            pos = save_pos;return(bincreate(cSemicolon));
          /* - - - - - - - - - - - - - - - - - - - - - - - - */
          } /* switch(l_base) */
        break;
      /*-----------------------------------------------------*/
      case d_interval :
      case d_idot     : /* new_dot */
        switch(l_base){
          /* - - - - - - - - - - - - - - - - - - - - - - - - */
          case d_integer :
          case d_real    :
            switch(r_base){
                case d_integer :
                case d_real    :
                fname     = plus_mode ? "d_padd" : "d_psub";
                locac1    = ACCU1;
                locac3    = ACCU2;
                two_calls = true;
                opnd1     = l_opnd;
                opnd2     = r_opnd;
                break;
                case d_interval :
                fname     = plus_mode ? "i_riad" : "i_risb";
                locac1    = ACCU1;
                locac2    = ACCU2;
                two_calls = false;
                opnd1     = l_opnd;
                opnd2     = r_opnd;
                break;
                default :
#ifdef CHECK
                d_checkerr(cILBASE,work->right->pos,NULL);
#endif
                pos = save_pos;
                return(bincreate(cSemicolon));} /* switch(r_base) */
            break;
          /* - - - - - - - - - - - - - - - - - - - - - - - - */
          case d_interval :
            switch(r_base){
                case d_integer :
                case d_real    :
                fname     = plus_mode ? "i_riad" : "i_risb";
                locac1    = ACCU1;
                locac2    = ACCU2;
                two_calls = false;
                opnd1     = r_opnd;
                opnd2     = l_opnd;
                break;
                case d_interval :
                fname     = plus_mode ? "i_padd" : "i_psub";
                locac1    = ACCU1;
                locac2    = ACCU2;
                two_calls = false;
                opnd1     = l_opnd;
                opnd2     = r_opnd;
                break;
                default :
#ifdef CHECK
                d_checkerr(cILBASE,work->right->pos,NULL);
#endif
                pos = save_pos;
                return(bincreate(cSemicolon));} /* switch(r_base) */
            break;
          /* - - - - - - - - - - - - - - - - - - - - - - - - */
          default :
#ifdef CHECK
            d_checkerr(cILBASE,work->left->pos,NULL);
#endif
            pos = save_pos;return(bincreate(cSemicolon));
          /* - - - - - - - - - - - - - - - - - - - - - - - - */
          } /* switch(l_base) */
        break;
      /*-----------------------------------------------------*/
      case d_cinterval :
      case d_cidot     : /* new_dot */
        switch(l_base){
          /* - - - - - - - - - - - - - - - - - - - - - - - - */
          case d_integer :
          case d_real    :
            switch(r_base){
                case d_integer :
                case d_real    :
                fname     = plus_mode ? "d_padd" : "d_psub";
                locac1    = ACCU1;
                locac3    = ACCU3;
                two_calls = true;
                opnd1     = l_opnd;
                opnd2     = r_opnd;
                break;
                case d_complex :
                fname     = plus_mode ? "c_rcad" : "c_rcsb";
                locac1    = ACCU1;
                locac2    = ACCU2;
                locac3    = ACCU3;
                locac4    = ACCU4;
                two_calls = true;
                opnd1     = l_opnd;
                opnd2     = r_opnd;
                break;
                case d_interval :
                fname     = plus_mode ? "i_riad" : "i_risb";
                locac1    = ACCU1;
                locac2    = ACCU3;
                two_calls = false;
                opnd1     = l_opnd;
                opnd2     = r_opnd;
                break;
                case d_cinterval :
                fname     = plus_mode ? "z_rzad" : "z_rzsb";
                locac1    = ACCU1;
                locac2    = ACCU2;
                locac3    = ACCU3;
                locac4    = ACCU4;
                two_calls = false;
                opnd1     = l_opnd;
                opnd2     = r_opnd;
                break;
                default :
#ifdef CHECK
                d_checkerr(cILBASE,work->right->pos,NULL);
#endif
                pos = save_pos;
                return(bincreate(cSemicolon));} /* switch(r_base) */
            break;
          /* - - - - - - - - - - - - - - - - - - - - - - - - */
          case d_complex :
            switch(r_base){
                case d_integer :
                case d_real    :
                fname     = plus_mode ? "c_rcad" : "c_rcsb";
                locac1    = ACCU1;
                locac2    = ACCU2;
                locac3    = ACCU3;
                locac4    = ACCU4;
                two_calls = true;
                opnd1     = r_opnd;
                opnd2     = l_opnd;
                break;
                case d_complex :
                fname     = plus_mode ? "c_padd" : "c_psub";
                locac1    = ACCU1;
                locac2    = ACCU2;
                locac3    = ACCU3;
                locac4    = ACCU4;
                two_calls = true;
                opnd1     = l_opnd;
                opnd2     = r_opnd;
                break;
                case d_interval :
                fname     = plus_mode ? "z_ciad" : "z_cisb";
                locac1    = ACCU1;
                locac2    = ACCU2;
                locac3    = ACCU3;
                locac4    = ACCU4;
                two_calls = false;
                opnd1     = l_opnd;
                opnd2     = r_opnd;
                break;
                case d_cinterval :
                fname     = plus_mode ? "z_czad" : "z_czsb";
                locac1    = ACCU1;
                locac2    = ACCU2;
                locac3    = ACCU3;
                locac4    = ACCU4;
                two_calls = false;
                opnd1     = l_opnd;
                opnd2     = r_opnd;
                break;
                default :
#ifdef CHECK
                d_checkerr(cILBASE,work->right->pos,NULL);
#endif
                pos = save_pos;
                return(bincreate(cSemicolon));} /* switch(r_base) */
            break;
          /* - - - - - - - - - - - - - - - - - - - - - - - - */
          case d_interval :
            switch(r_base){
                case d_integer :
                case d_real    :
                fname     = plus_mode ? "i_riad" : "i_risb";
                locac1    = ACCU1;
                locac2    = ACCU3;
                two_calls = false;
                opnd1     = r_opnd;
                opnd2     = l_opnd;
                break;
                case d_complex :
                fname     = plus_mode ? "z_ciad" : "z_cisb";
                locac1    = ACCU1;
                locac2    = ACCU2;
                locac3    = ACCU3;
                locac4    = ACCU4;
                two_calls = false;
                opnd1     = r_opnd;
                opnd2     = l_opnd;
                break;
                case d_interval :
                fname     = plus_mode ? "i_padd" : "i_psub";
                locac1    = ACCU1;
                locac2    = ACCU3;
                two_calls = false;
                opnd1     = l_opnd;
                opnd2     = r_opnd;
                break;
                case d_cinterval :
                fname     = plus_mode ? "z_izad" : "z_izsb";
                locac1    = ACCU1;
                locac2    = ACCU2;
                locac3    = ACCU3;
                locac4    = ACCU4;
                two_calls = false;
                opnd1     = l_opnd;
                opnd2     = r_opnd;
                break;
                default :
#ifdef CHECK
                d_checkerr(cILBASE,work->right->pos,NULL);
#endif
                pos = save_pos;
                return(bincreate(cSemicolon));} /* switch(r_base) */
            break;
          /* - - - - - - - - - - - - - - - - - - - - - - - - */
          case d_cinterval :
            switch(r_base){
                case d_integer :
                case d_real    :
                fname     = plus_mode ? "z_rzad" : "z_rzsb";
                locac1    = ACCU1;
                locac2    = ACCU2;
                locac3    = ACCU3;
                locac4    = ACCU4;
                two_calls = false;
                opnd1     = r_opnd;
                opnd2     = l_opnd;
                break;
                case d_complex :
                fname     = plus_mode ? "z_czad" : "z_czsb";
                locac1    = ACCU1;
                locac2    = ACCU2;
                locac3    = ACCU3;
                locac4    = ACCU4;
                two_calls = false;
                opnd1     = r_opnd;
                opnd2     = l_opnd;
                break;
                case d_interval :
                fname     = plus_mode ? "z_izad" : "z_izsb";
                locac1    = ACCU1;
                locac2    = ACCU2;
                locac3    = ACCU3;
                locac4    = ACCU4;
                two_calls = false;
                opnd1     = r_opnd;
                opnd2     = l_opnd;
                break;
                case d_cinterval :
                fname     = plus_mode ? "z_padd" : "z_psub";
                locac1    = ACCU1;
                locac2    = ACCU2;
                locac3    = ACCU3;
                locac4    = ACCU4;
                two_calls = false;
                opnd1     = l_opnd;
                opnd2     = r_opnd;
                break;
                default :
#ifdef CHECK
                d_checkerr(cILBASE,work->right->pos,NULL);
#endif
                pos = save_pos;
                return(bincreate(cSemicolon));} /* switch(r_base) */
            break;
          /* - - - - - - - - - - - - - - - - - - - - - - - - */
          default :
#ifdef CHECK
            d_checkerr(cILBASE,work->left->pos,NULL);
#endif
            pos = save_pos;return(bincreate(cSemicolon));
          /* - - - - - - - - - - - - - - - - - - - - - - - - */
          } /* switch(l_base) */
        break;
      /*-----------------------------------------------------*/
      default :
#ifdef CHECK
        d_checkerr(cILEBASE,work->pos,NULL);
#endif
        pos = save_pos;return(bincreate(cSemicolon));
      /*-----------------------------------------------------*/
      } /* switch(base_res) */} /* if()...else... */



     /*---------------------------------------------------------------*/
     /* generate function call(s).                                    */
     /*---------------------------------------------------------------*/

     if(two_calls){
          fcall = bincreate(cSemicolon);
          help  = d_gfp(fname,4,locac1,-1,locac2,-1,opnd1,0,opnd2,0);
          (void)binlside(fcall,help);
          help  = d_gfp(fname,4,locac3,-1,locac4,-1,opnd1,0,opnd2,0);
          (void)binappend(fcall,help);}
     else
          fcall = d_gfp(fname,6,locac1,-1,locac2,-1,locac3,-1,locac4,-1,
                            opnd1,0,opnd2,0);

     if( optblk->l_opt || optblk->r_opt ){
          result = bincreate(cIF);
          (void)binlside(result,help=bincreate(cEQ));
          (void)binlside(help,d_varcopy(optblk->row));
          (void)binappend(help,d_varcopy(optblk->col));
          (void)binappend(result,fcall);}
     else
          result = fcall;



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

  pos = save_pos;
  return(result);

} /* d_gaddition() */



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



#ifdef LINT_ARGS
binptr d_gvarelem(tVARINFO *info)
#else
binptr d_gvarelem(info)
tVARINFO  *info;
#endif

/*--------------------------------------------------------------------*/
/* This function creates a bintree which contains a description of    */
/* an element of the input binptr, for example: "a[row,col].sup.re".  */
/* The input bintrees will be copied.                                 */
/* To get access to whole complex, interval or cinterval record,      */
/* call the function with 'base' = 'd_anyarith'.                      */
/*--------------------------------------------------------------------*/
/* info = pointer to VarInfo-Block                                    */
/*--------------------------------------------------------------------*/

{
     binptr    result,help,rec_comp,arr_comp;



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

#ifdef CHECK
     if( info == NULL ){
          d_checkerr(cISNULL,pos,"info");
          return(bincreate(cSemicolon));}
     if( info->ptr.varptr->element == NIL ){
          d_checkerr(cVARNIL,pos,NULL);
          return(bincreate(cSemicolon));}
#endif



     /*---------------------------------------------------------------*/
     /* create the "array" component (an cIdent in scalar case)       */
     /*---------------------------------------------------------------*/

     switch(info->struc){
          /*----------------------------------------------------------*/
          case d_scalar :
               arr_comp = bincopy(info->ptr.varptr->element);
               break;
          /*----------------------------------------------------------*/
          case d_vector :
               binupsym(info->ptr.varptr->rowptr,binsym(info->row));
               arr_comp = bincopy(info->ptr.varptr->element);
               break;
          /*----------------------------------------------------------*/
          case d_matrix :
               binupsym(info->ptr.varptr->rowptr,binsym(info->row));
               binupsym(info->ptr.varptr->colptr,binsym(info->col));
               arr_comp = bincopy(info->ptr.varptr->element);
               break;
          /*----------------------------------------------------------*/
          default :
#ifdef CHECK
                    d_checkerr(cISTRUC,pos,NULL);
#endif
                    return(bincreate(cSemicolon));
          /*----------------------------------------------------------*/
          } /* switch(info->struc) */



     /*---------------------------------------------------------------*/
     /* create the record components for interval and complex         */
     /*---------------------------------------------------------------*/

     switch(info->base){
          /*----------------------------------------------------------*/
          case d_anyarith  :
          case d_real          :
          case d_rdot          :
               result = arr_comp;
               break;
          /*----------------------------------------------------------*/
          case d_integer   :
               /*--------------------------------------*/
               /* is to be converted to real by a call */
               /* of the runtime routine "r_flot()"    */
               /*--------------------------------------*/
               result = d_gcall("r_flot");
               d_suplparam(result,arr_comp,false);
               break;
          /*----------------------------------------------------------*/
          case d_complex   :
          case d_cdot      : /*new_dot*/
#ifdef CHECK
               if( (info->c_symptr!=sIM) && (info->c_symptr!=sRE) ){
                    d_checkerr(cILVALUE,pos,"info->c_symptr");
                    return(bincreate(cSemicolon));}
#endif
               result = bincreate(cPoint);
               (void) binappend(result,rec_comp=bincreate(cCsymbol));
               binupsym(rec_comp,info->c_symptr);
               (void) binlside(result,arr_comp);
               break;
          /*----------------------------------------------------------*/
          case d_interval  :
          case d_idot      : /*new_dot*/
#ifdef CHECK
               if( (info->i_symptr!=sINF) && (info->i_symptr!=sSUP) ){
                    d_checkerr(cILVALUE,pos,"info->i_symptr");
                    return(bincreate(cSemicolon));}
#endif
               result = bincreate(cPoint);
               (void) binappend(result,rec_comp=bincreate(cCsymbol));
               binupsym(rec_comp,info->i_symptr);
               (void) binlside(result,arr_comp);
               break;
          /*----------------------------------------------------------*/
          case d_cinterval :
          case d_cidot     : /*new_dot*/
#ifdef CHECK
               if( (info->c_symptr!=sIM) && (info->c_symptr!=sRE) ){
                    d_checkerr(cILVALUE,pos,"info->c_symptr");
                    return(bincreate(cSemicolon));}
               if( (info->i_symptr!=sINF) && (info->i_symptr!=sSUP) ){
                    d_checkerr(cILVALUE,pos,"info->i_symptr");
                    return(bincreate(cSemicolon));}
#endif
               result = bincreate(cPoint);
               (void) binappend(result,rec_comp=bincreate(cCsymbol));
               binupsym(rec_comp,info->i_symptr);
               help      = bincreate(cPoint);
               (void) binlside(result,help);
               (void) binappend(help,rec_comp=bincreate(cCsymbol));
               binupsym(rec_comp,info->c_symptr);
               (void) binlside(help,arr_comp);
               break;
          /*----------------------------------------------------------*/
          default :
#ifdef CHECK
                    d_checkerr(cIBASE,pos,NULL);
#endif
                    return(bincreate(cSemicolon));
          /*----------------------------------------------------------*/
          } /* switch(info->base) */



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



     return(result);

} /* d_gvarelem() */



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



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

/*--------------------------------------------------------------------*/
/* creates a named real constant.                                     */
/*--------------------------------------------------------------------*/

{
     postype   save_pos;
     binptr    res;


     /*---------------------------------------------------------------*/
#ifdef TRACE_ON
     d_trace("'d_gnrconst()'");
#endif
     /*---------------------------------------------------------------*/


     /*---------------------------------------------------------------*/
#ifdef CHECK
     if( work == NULL ){
          d_checkerr(cISNULL,pos,"work");
          return(bincreate(cSemicolon));}
     if( work->namekind!=d_binptr ){
          d_checkerr(cILNODE,work->pos,NULL);
          return(bincreate(cSemicolon));}
     if( work->kind != d_nconst ){
          d_checkerr(cILKIND,work->pos,NULL);
          return(bincreate(cSemicolon));}
     if( work->basetype != d_real ){
          d_checkerr(cILBASE,work->pos,NULL);
          return(bincreate(cSemicolon));}
#endif
     /*---------------------------------------------------------------*/

     save_pos = pos;
     pos = work->pos;
     res = bincopy(work->name.bin);
     pos = save_pos;
     return(res);

} /* d_gnrconst() */



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



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

/*--------------------------------------------------------------------*/
/* creates all constants excepted named real constants                */
/* (s.a. 'd_grnconst()').                                             */
/*--------------------------------------------------------------------*/

{
     postype             save_pos;
     register binptr     res,h;


     /*---------------------------------------------------------------*/
#ifdef TRACE_ON
     d_trace("'d_gconstant()'");
#endif
     /*---------------------------------------------------------------*/


     /*---------------------------------------------------------------*/
#ifdef CHECK
     if( work == NULL ){
          d_checkerr(cISNULL,pos,"work");
          return(bincreate(cSemicolon));}
     if( (work->kind!=d_constant) && (work->kind!=d_nconst) ){
          d_checkerr(cILKIND,work->pos,NULL);
          return(bincreate(cSemicolon));}
     if( (work->basetype!=d_real) && (work->basetype!=d_integer) ){
          d_checkerr(cILBASE,work->pos,NULL);
          return(bincreate(cSemicolon));}
#endif
     /*---------------------------------------------------------------*/


     if( (work->kind==d_nconst) && (work->basetype==d_real) )
          return(d_gnrconst(work));

     save_pos = pos;
     pos = work->pos;

     if( work->basetype == d_integer ){
          binupvalue(h=bincreate(cIcon),work->name.value);
          res = d_gfp("r_flot",1,h,0);}
     else
          binupcharp(res=bincreate(cRcon),d_getstring(work->name.str));

     pos = save_pos;
     return(res);

} /* d_gconstant() */



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



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

/*--------------------------------------------------------------------*/
/* This function generates the expression for rounded cRcon's         */
/* ( '(<...)' & '(>...)' ).                                           */
/*--------------------------------------------------------------------*/
/* work = pointer to work node                                        */
/*--------------------------------------------------------------------*/

{
     register binptr     res,help;



     /*---------------------------------------------------------------*/
#ifdef TRACE_ON
     d_trace("'d_grounded()'");
#endif
     /*---------------------------------------------------------------*/



     /*---------------------------------------------------------------*/
#ifdef CHECK
     if( work == NULL ){
          d_checkerr(cISNULL,pos,"work");
          return(bincreate(cSemicolon));}
     if( work->namekind!=d_direct ){
          d_checkerr(cILNODE,work->pos,NULL);
          return(bincreate(cSemicolon));}
     if( work->right == NULL ){
          d_checkerr(cCNSTEXPCT,work->pos,NULL);
          return(bincreate(cSemicolon));}
     if(    ( work->right->basetype !=d_real     )
          || ( work->right->kind    !=d_constant )     ){
          d_checkerr(cCNSTEXPCT,work->right->pos,NULL);
          return(bincreate(cSemicolon));}
#endif
     /*---------------------------------------------------------------*/



     binupcharp(help=bincreate(cScon),d_getstring(work->right->name.str));
     

     switch(work->name.direct){
          case d_lpard : res = bincreate(cLParD); break;
          case d_lparu : res = bincreate(cLParU); break;
          default :
#ifdef CHECK
                    d_checkerr(cILOPND,work->pos,NULL);
#endif
                    return(bincreate(cSemicolon));} /* switch(...) */

     (void)binappend(res,help);


     return(res);

} /* d_grounded() */



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



#ifdef LINT_ARGS
static boolean d_idoptim(binptr op[],int num)
#else
static boolean d_idoptim(op,num)
binptr    op[];
int       num;
#endif

/*--------------------------------------------------------------------*/
/* The function makes a test, if a function call may become optimized */
/*--------------------------------------------------------------------*/
/* op  = array, containing all parts of the function parameter        */
/* num = number of operands in the op-array                           */
/*--------------------------------------------------------------------*/

{
     int       n;
     binptr    help;


     for(n=0; n<num; n++){
          help = (binsymc(op[n])==cMMinus) ? binright(op[n]) : op[n];
          if( binsymc(help) == cIF )goto ok;
          if( binsymc(help) == cRcon )
               if( strcmp("0.0",bincharp(help)) == 0 )goto ok;
          return(false);
          ok : ;}

     return(true);

} /* d_idoptim() */



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



#ifdef LINT_ARGS
static void d_elimif(binptr op[],int num)
#else
static void d_elimif(op,num)
binptr    op[];
int       num;
#endif

/*--------------------------------------------------------------------*/
/* The function eliminates the if-statementes within the op-array.    */
/*--------------------------------------------------------------------*/
/* op  = array, containing all parts of the function parameter        */
/* num = number of operands in the op-array                           */
/*--------------------------------------------------------------------*/

{
     int       n,is_mminus;
     binptr    help;


     for(n=0; n<num; n++){
          is_mminus = ( binsymc(op[n]) == cMMinus );
          if( binsymc( ((is_mminus)?binright(op[n]):op[n]) ) == cIF ){
               bintdelete(&op[n]);
               binupcharp(help=bincreate(cRcon),d_getstring("1.0"));
               if(is_mminus){
                    op[n] = bincreate(cMMinus);
                    (void)binappend(op[n],help);}
               else
                    op[n] = help;} /* if() */} /* for() */

} /* d_elimif() */



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



#ifdef LINT_ARGS
static binptr d_gidcall(tVARINFO *info)
#else
static binptr d_gidcall(info)
tVARINFO  *info;
#endif

/*--------------------------------------------------------------------*/
/* This function generates a simulation of a call to function 'id'    */
/*--------------------------------------------------------------------*/
/* info = pointer to VarInfo-Block                                    */
/*--------------------------------------------------------------------*/

{
     binptr    result,help;



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

#ifdef CHECK
     if( info == NULL ){
          d_checkerr(cISNULL,pos,"info");
          return(bincreate(cSemicolon));}
     if( info->row == NIL ){
          d_checkerr(cNROWDEF,pos,NULL);
          return(bincreate(cSemicolon));}
     if( info->col == NIL ){
          d_checkerr(cNCOLDEF,pos,NULL);
          return(bincreate(cSemicolon));}
#endif



     /*---------------------------------------------------------------*/
     /* 'IM'-part of complex is always zero                           */
     /*---------------------------------------------------------------*/

     if(  (    (info->base==d_complex  ) ||
               (info->base==d_cinterval) ||
               (info->base==d_cidot       )       ) &&
          (      info->c_symptr == sIM         )       ){
          binupcharp(result=bincreate(cRcon),d_getstring("0.0"));
          return(result);}



     /*---------------------------------------------------------------*/
     /* The REAL part is 1.0, if row==col                             */
     /*---------------------------------------------------------------*/

     result = bincreate(cIF);

     /*---------------------------------------------------------------*/
     /* add 'row_var==col_var' to left side of cIF node               */
     /*---------------------------------------------------------------*/
     (void) binlside(result,help=bincreate(cEQ));
     (void) binlside(help,d_varcopy(info->row));
     (void) binappend(help,d_varcopy(info->col));

     /*---------------------------------------------------------------*/
     /* add cELSE node right of cIF node                              */
     /*---------------------------------------------------------------*/
     help = binappend(result,bincreate(cELSE));

     /*---------------------------------------------------------------*/
     /* add '1.0' to left, '0.0' to the cELSE node                    */
     /*---------------------------------------------------------------*/
     (void) binlside(help,bincreate(cRcon));
     binupcharp(binleft(help),d_getstring("1.0"));
     binupcharp(binappend(help,bincreate(cRcon)),d_getstring("0.0"));

     return(result);

} /* d_gidcall() */



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



#ifdef LINT_ARGS
static binptr d_gfuncarg(tNODE *work,tVARINFO *info,boolean *p_mode)
#else
static binptr d_gfuncarg(work,info,p_mode)
tNODE     *work;
tVARINFO  *info;
boolean   *p_mode;
#endif

/*--------------------------------------------------------------------*/
/* This function generates an function argument                       */
/*--------------------------------------------------------------------*/
/* work   = pointer to work node                                      */
/* info   = pointer to VarInfo-Block                                  */
/* p_mode = pointer to flag-variable                                  */
/*--------------------------------------------------------------------*/

{
     binptr         result,help;
     symptr         save_symptr;
     tARITHTYPE     save_base;
     tNODE          *h_work;
     postype        save_pos;



     save_pos = pos;
     pos = work->pos;



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

#ifdef CHECK
     if(work==NULL){
          d_checkerr(cISNULL,pos,"work");
          pos = save_pos;return(bincreate(cSemicolon));}
#endif



     /*---------------------------------------------------------------*/
     /* Handle constant and variable arguments                        */
     /*---------------------------------------------------------------*/

     switch(work->kind){
          case d_variable :
               info->ptr.varptr = work->name.varinfo;
               pos = save_pos;
               return(d_gvarelem(info));
          case d_constant :
          case d_nconst   :
               result = d_gconstant(work);
               pos = save_pos;
               return(result);
          case d_Operator:
               if(    (work->name.direct==d_lpard)
                      || (work->name.direct==d_lparu)  )
                    result = d_grounded(work);
               else{
#ifdef CHECK
                    d_checkerr(cILNAME,work->pos,NULL);
#endif
                    result = bincreate(cSemicolon);}
               pos = save_pos;
               return(result);
          case d_function:
               /* is to be handled later in this function */
               break;
          default : 
#ifdef CHECK
               d_checkerr(cILKIND,work->pos,NULL);
#endif
               return(bincreate(cSemicolon));} /* switch() */



     save_base = info->base;

     switch(work->name.direct){
          /*----------------------------------------------------------*/
          case d_inf      :
               save_symptr    = info->i_symptr;
               info->base     = work->right->basetype;
               info->i_symptr = sINF;
               result         = d_gfuncarg(work->right,info,p_mode);
               info->i_symptr = save_symptr;
               break;
          /*----------------------------------------------------------*/
          case d_sup      :
               save_symptr    = info->i_symptr;
               info->base     = work->right->basetype;
               info->i_symptr = sSUP;
               result         = d_gfuncarg(work->right,info,p_mode);
               info->i_symptr = save_symptr;
               break;
          /*----------------------------------------------------------*/
          case d_re       :
               save_symptr    = info->c_symptr;
               info->base     = work->right->basetype;
               info->c_symptr = sRE;
               result         = d_gfuncarg(work->right,info,p_mode);
               info->c_symptr = save_symptr;
               break;
          /*----------------------------------------------------------*/
          case d_im       :
               save_symptr    = info->c_symptr;
               info->base     = work->right->basetype;
               info->c_symptr = sIM;
               result         = d_gfuncarg(work->right,info,p_mode);
               info->c_symptr = save_symptr;
               break;
          /*----------------------------------------------------------*/
          case d_conj     :
               if(info->c_symptr==sIM)*p_mode = !(*p_mode);
               result = d_gfuncarg(work->right,info,p_mode);
               break;
          /*----------------------------------------------------------*/
          case d_intval   :
               save_symptr = info->i_symptr;
               h_work      = work->right;
               if(    (h_work->namekind      == d_direct )
                      && (h_work->name.direct == d_comma    )    ){
                    h_work = (info->i_symptr==sINF) ? h_work->left
                                                    : h_work->right;}
               info->base     = h_work->basetype; 
               info->i_symptr = symNIL;
               result         = d_gfuncarg(h_work,info,p_mode);
               info->i_symptr = save_symptr;
               break;
          /*----------------------------------------------------------*/
          case d_compl    :
               save_symptr = info->c_symptr;
               h_work      = work->right;
               if(    (h_work->namekind      == d_direct )
                      && (h_work->name.direct == d_comma    )    ){
                    h_work = (info->c_symptr==sRE) ? h_work->left
                                                   : h_work->right;
                    info->base     = h_work->basetype; 
                    info->c_symptr = symNIL;
                    result         = d_gfuncarg(h_work,info,p_mode);}
               else
                    if(info->c_symptr==sIM)
                         binupcharp(result=bincreate(cRcon),
                                    d_getstring("0.0"));
                    else{
                         info->base = h_work->basetype;
                         result     = d_gfuncarg(h_work,info,p_mode);}
               info->c_symptr = save_symptr;
               break;
          /*----------------------------------------------------------*/
          case d_transp   :
               help = info->row;info->row = info->col;info->col = help;
               info->mat_transp = !info->mat_transp;
               result = d_gfuncarg(work->right,info,p_mode);
               help = info->row;info->row = info->col;info->col = help;
               break;
          /*----------------------------------------------------------*/
          case d_id       :
               result = d_gidcall(info);
               break;
          /*----------------------------------------------------------*/
          case d_herm     :
               help = info->row;info->row = info->col;info->col = help;
               if(info->c_symptr==sIM)*p_mode = !(*p_mode);
               result = d_gfuncarg(work->right,info,p_mode);
               help = info->row;info->row = info->col;info->col = help;
               break;
          /*----------------------------------------------------------*/
#ifdef CHECK
          case d_rvector  :
          case d_cvector  :
          case d_ivector  :
          case d_civector :
          case d_rmatrix  :
          case d_cmatrix  :
          case d_imatrix  :
          case d_cimatrix :
               d_checkerr(cCASTFUNC,work->pos,NULL);
               result = d_gfuncarg(work->right,info,p_mode);
               break;
#endif
          /*----------------------------------------------------------*/
          default :
#ifdef CHECK
               d_checkerr(cILNAME,work->pos,NULL);
#endif
               pos = save_pos;return(bincreate(cSemicolon));
          /*----------------------------------------------------------*/
          } /* switch(work->name.direct) */

     info->base = save_base;
     pos = save_pos;
     return(result);

} /* d_gfuncarg() */



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



#ifdef LINT_ARGS
static void d_mmintoop(binptr opnd,tARITHTYPE base)
#else
static void d_mmintoop(opnd,base)
binptr     opnd;
tARITHTYPE base;
#endif

/*--------------------------------------------------------------------*/
/* creates the statement for unique minus with operand 'opnd'         */
/*--------------------------------------------------------------------*/

{
     opptr     opp;
     binptr    opnd_type;


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


#ifdef CHECK
     if( opnd == NIL ){
          d_checkerr(cISNIL,pos,"paramter 'opnd'");
          return;}
#endif



     if( binsymc(opnd) != cMMinus )
          return;

     switch(base){
          /*----------------------------------------------------------*/
          case d_integer   : opnd_type = integertype;            break;
          case d_real      : opnd_type = realtype;               break;
          case d_complex   : opnd_type = complextype;            break;
          case d_interval  : opnd_type = intervaltype;           break;
          case d_cinterval : opnd_type = cintervaltype;          break;
          /*----------------------------------------------------------*/
          case d_rdot      : opnd_type = dotprecisiontype;       break;
          case d_cdot      : opnd_type = cdotprecisiontype;      break;
          case d_idot      : opnd_type = idotprecisiontype;      break;
          case d_cidot     : opnd_type = cidotprecisiontype;     break;
          /*----------------------------------------------------------*/
          default:
#ifdef CHECK
               d_checkerr(cIBASE,pos,NULL);
#endif
               return;
          /*----------------------------------------------------------*/
          } /* switch(base) */


     if( (opp=opfnd(cMMinus,symNIL,NIL,opnd_type,pos)) != (opptr)NIL ){
          binchange(opnd,cCall);
          binupsym(opnd,opcsym(opp));
          }

} /* d_mmintoop() */



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



#ifdef LINT_ARGS
static binptr d_gfuncelem(tNODE *work,tVARINFO *info)
#else
static binptr d_gfuncelem(work,info)
tNODE     *work;
tVARINFO  *info;
#endif

/*--------------------------------------------------------------------*/
/* This function generates a bintree simulating a function call.      */
/* If 'info->undeclare' is returned  as 'true', then                  */
/* 'info->ptr.varptr' contains a pointer to a variable that should be */
/* freed with 'd_undecl()' after its use.                             */
/*--------------------------------------------------------------------*/
/* work = pointer to work node                                        */
/* info = pointer to VarInfo-Block                                    */
/*--------------------------------------------------------------------*/

{
     binptr    result,r_op[4],l_op[4],help,preass;
     binptr    reselem;
     int       ops,n;
     tVARBLK   tempblk;
     boolean   p_mode;
     postype   save_pos;



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



#ifdef CHECK
     if(work==NULL){
          d_checkerr(cISNULL,pos,"work");
          return(bincreate(cSemicolon));}
#endif



     save_pos = pos;
     pos = work->pos;



     /*---------------------------------------------------------------*/
     /* initialise the information block as known                     */
     /*---------------------------------------------------------------*/

     info->base     = work->basetype;
     info->id_opt   = false;



     /*---------------------------------------------------------------*/
     /* create the result                                             */
     /*---------------------------------------------------------------*/

     ops = 0;

     switch(work->basetype){
          /*----------------------------------------------------------*/
          case d_real      :
          case d_rdot      :
          case d_integer   :
               info->struc = work->structure;
               ops = 1;
               r_op[0] = d_gfuncarg(work,info,(p_mode=1,&p_mode));
               if(!p_mode){
                    (void) binappend(help=bincreate(cMMinus),r_op[0]);
                    r_op[0] = help;}
               info->undeclare = false;
               break;
          /*----------------------------------------------------------*/
          case d_complex   :
          case d_cdot      : /*new_dot*/
               if( work->basetype == d_complex )
                    tempblk.element = tempdecl("Ch",complextype);
               else
                    tempblk.element = tempdecl("Dc",cdotprecisiontype);
               info->c_symptr = sRE;
               cmpl_2nd :
                    info->struc = work->structure;
                    r_op[ops]   = d_gfuncarg(work,info,(p_mode=1,&p_mode));
                    if(!p_mode){
                         (void) binappend(help=bincreate(cMMinus),r_op[ops]);
                         r_op[ops] = help;}
                    info->struc      = d_scalar;
                    info->ptr.varptr = &tempblk;
                    l_op[ops++]      = d_gvarelem(info);
                    if( info->c_symptr == sRE ){
                         info->c_symptr = sIM;
                         goto cmpl_2nd;}
               reselem          = bincopy(info->ptr.varptr->element);
               info->undeclare  = true;
               info->ptr.binvar = tempblk.element;
               break;
          /*----------------------------------------------------------*/
          case d_interval  :
          case d_idot      : /*new_dot*/
               if( work->basetype == d_interval )
                    tempblk.element = tempdecl("Ih",intervaltype);
               else
                    tempblk.element = tempdecl("Di",idotprecisiontype);
               info->i_symptr  = sINF;
               intv_2nd :
                    info->struc = work->structure;
                    r_op[ops]   = d_gfuncarg(work,info,(p_mode=1,&p_mode));
                    if(!p_mode){
                         (void) binappend(help=bincreate(cMMinus),r_op[ops]);
                         r_op[ops] = help;}
                    info->struc      = d_scalar;
                    info->ptr.varptr = &tempblk;
                    l_op[ops++]      = d_gvarelem(info);
                    if( info->i_symptr == sINF ){
                         info->i_symptr = sSUP;
                         goto intv_2nd;}
               reselem = bincopy(info->ptr.varptr->element);
               info->undeclare     = true;
               info->ptr.binvar = tempblk.element;
               break;
          /*----------------------------------------------------------*/
          case d_cinterval :
          case d_cidot     : /*new_dot*/
               if( work->basetype == d_cinterval )
                    tempblk.element = tempdecl("Zh",cintervaltype);
               else
                    tempblk.element = tempdecl("Zh",cidotprecisiontype);
               info->i_symptr = sINF;
               cint1_2nd :
                    info->c_symptr = sRE;
                    cint2_2nd :
                         info->struc = work->structure;
                         r_op[ops] = d_gfuncarg(work,info,(p_mode=1,&p_mode));
                         if(!p_mode){
                              (void) binappend(help=bincreate(cMMinus),
                                                   r_op[ops]);
                              r_op[ops] = help;}
                         info->struc      = d_scalar;
                         info->ptr.varptr = &tempblk;
                         l_op[ops++]      = d_gvarelem(info);
                         if( info->c_symptr == sRE ){
                              info->c_symptr = sIM;
                              goto cint2_2nd;}
                    if( info->i_symptr == sINF ){
                         info->i_symptr = sSUP;
                         goto cint1_2nd;}
               reselem = bincopy(info->ptr.varptr->element);
               info->undeclare     = true;
               info->ptr.binvar = tempblk.element;
               break;
          /*----------------------------------------------------------*/
          default :
#ifdef CHECK
               d_checkerr(cILBASE,work->pos,NULL);
#endif
               pos = save_pos;return(bincreate(cSemicolon));
          /*----------------------------------------------------------*/
          } /* switch(work->basetype) */



     /*---------------------------------------------------------------*/
     /* optimize id()-calls                                           */
     /*---------------------------------------------------------------*/

     if( (info->id_opt=d_idoptim(r_op,ops)) == true )d_elimif(r_op,ops);


     /*---------------------------------------------------------------*/
     /* change monadic minus to function-calls if nessecary           */
     /*---------------------------------------------------------------*/

     for(n=0;n<ops;n++)d_mmintoop(r_op[n],d_real);


     /*---------------------------------------------------------------*/
     /* create comma list and return its pointer as result value      */
     /* (only used by results other than real,integer or r_dot)       */
     /*---------------------------------------------------------------*/

     if( ops == 1 )
          result = r_op[0];
     else{
          result = reselem;
          help = NIL;
          for(n=0; n<ops; n++)
               d_gstment( &help , d_gassign(l_op[n],r_op[n]) );
          preass = info->pre_add;
          d_gstment(&preass,help);
          info->pre_add = preass;}



     pos = save_pos;
     return(result);

} /* d_gfuncelem() */



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



#ifdef LINT_ARGS
static binptr d_goperand(tNODE *work,tVARINFO *info)
#else
static binptr d_goperand(work,info)
tNODE     *work;
tVARINFO  *info;
#endif

/*--------------------------------------------------------------------*/
/* This function generates a bintree, with represents an operand from */
/* the input work tree.                                               */
/*--------------------------------------------------------------------*/
/* work = pointer to work node                                        */
/* info = pointer to VarInfo-Block                                    */
/*--------------------------------------------------------------------*/


{
     binptr         result;
     postype        save_pos;
     tARITHTYPE     save_base;



     save_pos = pos;
     pos = work->pos;
     save_base = info->base;



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

#ifdef CHECK
     if( work == NULL ){
          d_checkerr(cISNULL,pos,"work");
          pos = save_pos;return(bincreate(cSemicolon));}
#endif



     switch(work->kind){
          /*----------------------------------------------------------*/
          case d_variable :
               info->id_opt     = false;
               info->ptr.varptr = work->name.varinfo;
               info->undeclare     = false;
               if ( work->basetype == d_integer )
                    info->base = d_integer;
               result = d_gvarelem(info);
               break;
          /*----------------------------------------------------------*/
          case d_function :
               result = d_gfuncelem(work,info);
               break;
          /*----------------------------------------------------------*/
          case d_constant :
          case d_nconst   :
               info->id_opt    = false;
               info->undeclare = false;
               result = d_gconstant(work);
               break;
          /*----------------------------------------------------------*/
          case d_Operator :
               result = d_grounded(work);
               break;
          /*----------------------------------------------------------*/
          default :
#ifdef CHECK
               d_checkerr(cILBASE,work->pos,NULL);
#endif
               pos = save_pos;
               return(bincreate(cSemicolon));} /* switch(...) */



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

     pos = save_pos;
     info->base = save_base;
     return(result);

} /* d_goperand() */



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



#ifdef LINT_ARGS
static tNODE *d_findvar(tNODE *work)
#else
static tNODE *d_findvar(work)
tNODE *work;
#endif

/*--------------------------------------------------------------------*/
/* This function searches for a variable in a function construction   */
/*--------------------------------------------------------------------*/
/* work = pointer to work tree (or subtree)                           */
/*--------------------------------------------------------------------*/

{
#ifdef CHECK
     if(work==NULL){d_checkerr(cISNULL,pos,"work");return(NULL);}
#endif



     while(work->kind!=d_variable){
          work = work->right;
#ifdef CHECK
          if(work==NULL){d_checkerr(cISNULL,pos,"work");return(NULL);}
#endif
          } /* while(...) */



     return(work);

} /* d_findvar() */



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



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

/*--------------------------------------------------------------------*/
/* This function creates the addition/subtraction statements for a    */
/* multiplication.                                                    */
/*--------------------------------------------------------------------*/
/* work = pointer into work tree                                      */
/*--------------------------------------------------------------------*/

{
     binptr         result,add_here,stm,loop_start;
     binptr         l_opnd,r_opnd,help;
     binptr         cnt_var;
     tVARINFO       info;
     tSTRUCTYPE     l_struc,r_struc;
     postype        save_pos;
     tOPTBLK        optblk;
     boolean        l_opt,r_opt;
     int            mat_sumdim;



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

#ifdef CHECK
     if( work == NULL ){
          d_checkerr(cISNULL,pos,"work");
          return(bincreate(cSemicolon));}
     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;



     /*---------------------------------------------------------------*/
     /* initialise the info block                                     */
     /*---------------------------------------------------------------*/

     info.row        = row_var;
     info.col        = col_var;
     info.base       = d_anyarith;
     info.pre_add    = NIL;
     info.c_symptr   = info.i_symptr = symNIL;
     info.mat_transp = false;



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

     l_struc = work->left->structure;
     r_struc = work->right->structure;
     result = cnt_var = NIL;



     /*---------------------------------------------------------------*/
     /* generate left and right operand and addition loop if needed   */
     /*---------------------------------------------------------------*/

     r_opt = l_opt = false;
     optblk.l_opt = optblk.r_opt = false;

     /*---------------------------------------------------------------*/
     /* assign variables to compare, if an 'id()' call is to be opti- */
     /* mized. If different variable(s) is(are) used, this will be    */
     /* changed when nessecary ( f.Ex.: [matrix]*[vector] ).          */
     /*---------------------------------------------------------------*/

     optblk.row = row_var;
     optblk.col = col_var;

     switch( work->left->structure ){
          /*----------------------------------------------------------*/
          case d_scalar :
               info.struc = l_struc;
               l_opnd     = d_goperand(work->left,&info);
               info.struc = r_struc;
               r_opnd     = d_goperand(work->right,&info);
               optblk.l_opt = r_opt = info.id_opt;
               break;
          /*----------------------------------------------------------*/
          case d_vector :
               switch( work->right->structure ){
                    case d_scalar :
                         info.struc = l_struc;
                         l_opnd     = d_goperand(work->left,&info);
                         info.struc = r_struc;
                         r_opnd     = d_goperand(work->right,&info);
                         break;
                    case d_vector :
                         cnt_var = tempdecl("Nl",integertype);
                         binupvalue(loop_start=bincreate(cIcon),(longint)0);
                         result = d_gloop(d_varcopy(cnt_var),loop_start,
                                             LENDIM(d_findvar(work->left),1),
                                             &add_here,cTO);
                         info.row   = cnt_var;
                         info.struc = l_struc;
                         l_opnd     = d_goperand(work->left,&info);
                         info.struc = r_struc;
                         r_opnd     = d_goperand(work->right,&info);
                         break;
                    default :
#ifdef CHECK
                         d_checkerr(cOPWSTRUC,work->pos,"d_vector");
#endif
                         pos = save_pos;result = bincreate(cSemicolon);
                    } /* switch(work->right->structure) */
               break;
          /*----------------------------------------------------------*/
          case d_matrix :
               switch( work->right->structure ){
                    case d_scalar :
                         info.struc = l_struc;
                         l_opnd     = d_goperand(work->left,&info);
                         optblk.r_opt = l_opt = info.id_opt;
                         info.struc = r_struc;
                         r_opnd     = d_goperand(work->right,&info);
                         break;
                    case d_vector :
                         cnt_var    = tempdecl("Nl",integertype);
                         info.col   = cnt_var;
                         info.struc = l_struc;
                         l_opnd     = d_goperand(work->left,&info);
                         l_opt      = info.id_opt;
                         if( l_opt )goto optim;
                         info.row   = cnt_var;
                         info.struc = r_struc;
                         r_opnd     = d_goperand(work->right,&info);
                         binupvalue(loop_start=bincreate(cIcon),(longint)0);
                         mat_sumdim = (info.mat_transp)?1:2;
                         result = d_gloop(d_varcopy(cnt_var),loop_start,
                                          LENDIM(d_findvar(work->left),
                                                 mat_sumdim),
                                          &add_here,cTO);
                         break;
                         optim:
                              info.row   = row_var;
                              info.struc = r_struc;
                              r_opnd     = d_goperand(work->right,&info);
                              break;
                    case d_matrix :
                         cnt_var    = tempdecl("Nl",integertype);
                         info.col   = cnt_var;
                         info.struc = l_struc;
                         l_opnd     = d_goperand(work->left,&info);
                         l_opt      = info.id_opt;
                         if( l_opt )goto optleft;
                         info.col   = col_var;
                         info.row   = cnt_var;
                         info.struc = r_struc;
                         r_opnd     = d_goperand(work->right,&info);
                         r_opt      = info.id_opt;
                         if( r_opt )goto optright;
                         binupvalue(loop_start=bincreate(cIcon),(longint)0);
                         mat_sumdim = (info.mat_transp)?1:2;
                         result = d_gloop(d_varcopy(cnt_var),loop_start,
                                          LENDIM(d_findvar(work->left),
                                                 mat_sumdim),
                                          &add_here,cTO);
                         break;
                         optleft:
                              info.row   = row_var;
                              info.col   = col_var;
                              info.struc = r_struc;
                              r_opnd     = d_goperand(work->right,&info);
                              optblk.r_opt = info.id_opt;
                              break;
                         optright:
                              info.row   = row_var;
                              info.col   = col_var;
                              info.struc = l_struc;
                              l_opnd     = d_goperand(work->left,&info);
                              optblk.l_opt = info.id_opt;
                              break;
                    default :
#ifdef CHECK
                         d_checkerr(cOPWSTRUC,work->pos,"d_matrix");
#endif
                         pos = save_pos;result = bincreate(cSemicolon);
                    } /* switch(work->right->structure) */
               break;
          /*----------------------------------------------------------*/
          } /* switch(work->left->structure) */



     /*---------------------------------------------------------------*/
     /* create addition statement and instert into result tree        */
     /*---------------------------------------------------------------*/

     if( l_opt )
          stm = d_gaddition(work->right,r_opnd,NIL,&optblk);
     else{
          if( r_opt )
               stm = d_gaddition(work->left,l_opnd,NIL,&optblk);
          else
               stm = d_gaddition(work,l_opnd,r_opnd,&optblk);}

     help = info.pre_add;
     d_gstment(&help,stm);
     stm = help;

     if( result == NIL )
          result = stm;
     else
          (void) binappend(add_here,stm);



     /*---------------------------------------------------------------*/
     /* undeclare temp variable and return generated bintree          */
     /*---------------------------------------------------------------*/

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

     pos = save_pos;
     return(result);

} /* d_gaddmul() */



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



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

/*--------------------------------------------------------------------*/
/* This function generates the statements for a sum loop              */
/*--------------------------------------------------------------------*/
/* work = pointer to work node                                        */
/*--------------------------------------------------------------------*/

{
     binptr    result,add_here;
     postype   save_pos;



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

#ifdef CHECK
     if( work == NULL )
          {d_checkerr(cISNULL,pos,"work");return(bincreate(cSemicolon));}
#endif



     save_pos = pos;
     pos = work->pos;



     /*---------------------------------------------------------------*/
     /* create the summation loop                                     */
     /*---------------------------------------------------------------*/

     result = d_gloop(bincopy(work->left->left->name.varinfo->element),
                          bincopy(work->left->right->name.bin),
                          bincopy(work->right->left->name.bin),
                          &add_here,
                          ((work->right->name.direct==d_to)?cTO:cDOWNTO) );

     /*---------------------------------------------------------------*/
     /* append the addition statements                                */
     /*---------------------------------------------------------------*/

     (void) binappend(add_here,d_gexpr(work->right->right));



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

     pos = save_pos;
     return(result);

} /* d_gaddsum() */



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



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

/*--------------------------------------------------------------------*/
/* This function creates the sequences for an addition order          */
/* the return value is a pointer to the generated statement list.     */
/*--------------------------------------------------------------------*/
/* work = pointer into work tree                                      */
/*--------------------------------------------------------------------*/

{
     binptr    stm,help;
     boolean   save_mode;
     tVARINFO  info;
     postype   save_pos;
     tOPTBLK   optblk;



     save_pos = pos;
     pos = work->pos;



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



#ifdef CHECK
     if( work == NULL ){
          d_checkerr(cISNULL,pos,"work");
          pos = save_pos;return(bincreate(cSemicolon));}
#endif



     /*---------------------------------------------------------------*/
     /* if is monadic minus change mode:  addition <=> subtraction    */
     /*---------------------------------------------------------------*/

     save_mode = plus_mode;

     if( (work->namekind==d_direct) && (work->name.direct==d_mminus) ){
          plus_mode = !plus_mode;
          work = work->right;}



     /*---------------------------------------------------------------*/
     /* initialise the info block                                     */
     /*---------------------------------------------------------------*/

     info.row       = row_var;
     info.col       = col_var;
     info.struc     = work->structure;
     info.base      = d_anyarith;
     info.pre_add   = NIL;
     info.c_symptr  = info.i_symptr = symNIL;



     /*---------------------------------------------------------------*/
     /* initialise optblk-structure                                   */
     /*---------------------------------------------------------------*/

     optblk.l_opt = optblk.r_opt = false;



     /*---------------------------------------------------------------*/
     /* distribute work as nessecary, integer operands are changed    */
     /* to reals.                                                     */
     /*---------------------------------------------------------------*/

     switch( work->kind ){
          /*----------------------------------------------------------*/
          case d_constant :
          case d_nconst   :
          case d_variable :
          case d_function :
               help         = d_goperand(work,&info);
               optblk.l_opt = info.id_opt;
               optblk.row      = row_var;
               optblk.col      = col_var;
               stm             = d_gaddition(work,help,NIL,&optblk);
               if( info.pre_add != NIL ){
                    help = stm;stm = info.pre_add;
                    d_gstment(&stm,help);}
               if(info.undeclare)d_undecl(info.ptr.binvar);
               break;
          /*----------------------------------------------------------*/
          case d_Operator :
               switch( work->name.direct ){
                    case d_mult  : stm = d_gaddmul(work);             break;
                    case d_sum   : stm = d_gaddsum(work);             break;
                    case d_lpard :
                    case d_lparu : stm = d_gaddition(work,d_grounded(work),
                                                     NIL,&optblk);    break;
                    default :
#ifdef CHECK
                              d_checkerr(cILOPND,work->pos,NULL);
#endif
                              return(bincreate(cSemicolon));
                    } /* switch(work->name.direct) */
               break;
          /*----------------------------------------------------------*/
          default :
#ifdef CHECK
                    d_checkerr(cILKIND,work->pos,NULL);
#endif
                    return(bincreate(cSemicolon));
          } /* switch(work->kind) */



     /*---------------------------------------------------------------*/
     /* return pointer to created tree                                */
     /*---------------------------------------------------------------*/

     plus_mode = save_mode;
     pos = save_pos;
     return(stm);

} /* d_gadlist() */



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