/*****************************************************************************/
/*                                                                           */
/* File:       "DP_CHECK.C"                                                  */
/* Author:      R. Hammer                                                    */
/* Date:        01-21-90                                                     */
/* Last Change: Mar-07-92                                                    */
/*                                                                           */
/* Implementation module for dimensional checks.                             */
/*                                                                           */
/* History:                                                                  */
/*                                                                           */
/*   05-28-91 :  Error in d_gvecchk() and d_gmatchk() !  Branches for scalar */
/*               arguments of an compl() or intval() call changed.           */
/*   06-11-91 :  rounded constants (d_lpard, d_lparu) added                  */
/*   06-11-91 :  new tNODETYPE 'd_nconst' included.                          */
/*   07-02-91 :  Some initializations in d_gsclchk(), d_gvecchk, and         */
/*               d_gmatchk() added. So collen and rowlen will be ever        */
/*               properly initialized.                                       */
/* Feb-01-92 Just : Macro WPRINT_ON and dependend include of                 */
/*                  "DP_UTIL.INC" added.                                     */
/* Mar-07-92 Just : macro 'NEW_PROTO' --> 'LINT_ARGS'                        */
/*                                                                           */
/*****************************************************************************/



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

#include <stdio.h>

#include "impor.t"
#include    "error.h"
#include    "option.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_error.h"
#include "expor.t"
#include    "dp_check.h"
#include "implemen.t"


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


/*------------------------------------------------------------------*/
/* Prototype declarations of locally used subprograms and variables */
/*------------------------------------------------------------------*/


#ifdef LINT_ARGS
     static binptr  d_gif          ( binptr, binptr, int );
     static binptr  d_gdiff        ( binptr, binptr );
     static binptr  d_getveclen    ( tNODE* );
     static binptr  d_getcollen    ( tNODE* );
     static binptr  d_getrowlen    ( tNODE* );
     static void    d_gsclchk      ( tNODE*, binptr* );
     static void    d_gvecchk      ( tNODE*, binptr*, binptr* );
     static void    d_gmatchk      ( tNODE*, binptr*, binptr* );
#else
     static binptr  d_gif          ();
     static binptr  d_gdiff        ();
     static binptr  d_getveclen    ();
     static binptr  d_getcollen    ();
     static binptr  d_getrowlen    ();
     static void    d_gsclchk      ();
     static void    d_gvecchk      ();
     static void    d_gmatchk      ();
#endif


static binptr if_root;           /* Pointer to the sequence of if-statements */
                                 /* to be generated by the 'd_g???chk()'     */
                                 /* subroutines                              */

static binptr d_1stexpr;         /* Pointer to integer expression belonging */
                                 /* to global variable 'd_1stdim'           */

static binptr d_2ndexpr;         /* Pointer to integer expression belonging */
                                 /* to global variable 'd_2nddim'           */

/*===========================================================================*/

#ifdef LINT_ARGS
binptr d_gcall (char *str)
                                                   /* Generate Function Call */
                                                   /* -                 ---- */
#else
binptr d_gcall (str)
  char *str;
#endif

/*-----------------------------------------------------------------------------
 *
 *  The function is used to create a Call of the runtime routine 'str'. If
 *  the name of the routine is not already inserted to the symbol table
 *  it will be appended by a call of 'symins()'.
 *
 *
 *  I/O - Parameters:
 *  -----------------
 *
 *     Name      |   Type     |   I/O   |   Meaning
 *     ----------|------------|---------|-----------------------------
 *     str       |   string   |    I    |   Name of the routine to be
 *               |            |         |   called
 *
 *
 *  Called Routines:
 *  ----------------
 *
 *     Name         |   Short description
 *     -------------|-------------------------------------------------
 *     symins       |   Insert/Get entry of the symbol table
 *     binupsym     |   Updating a symbol pointer
 *     bincreate    |   Create a new 'binptr' node
 *
 *---------------------------------------------------------------------------*/

{ binptr h;  /* Head of binary tree to be returned */

#ifdef TRACE_ON
  print("Trace 'd_gcall(\"");print(str);print("\")'"); printline();
#endif


  /* func d_gcall */
  /*--------------*/

  h = bincreate(cCall); binupsym(h,symins(str));

  return(h);

} /* func d_gcall */
  /*--------------*/


/*===========================================================================*/

#ifdef LINT_ARGS
void d_suplparam ( binptr p, binptr q, boolean varflg )
                                                     /* Supplement Parameter */
                                                     /* --- -      -----     */
#else
void d_suplparam ( p, q, varflg )
  binptr    p, q;
  boolean   varflg;
#endif

/*-----------------------------------------------------------------------------
 *
 *  The parameter list of an already existing binary tree 'p' with a cCall-node
 *  as root will be supplemented by the parameter 'q'. The variable 'varflg' is
 *  used to indicate whether the parameter shall be refered to by address
 *  (true) or by value (false).
 *
 *  1. Case: No parameter supplemented so far
 *
 *       p ->  cCall           ===>          cCall         or       cCall
 *             /   \                         /   \                  /   \
 *                                                q                      &
 *                                                                       |
 *                                                                       q
 *
 *  2. Case: Supplemented another parameter
 *
 *       p ->  cCall           ===>          cCall         or       cCall
 *             /   \                         /   \                  /   \
 *                  r                             ,---                   ,---
 *                                                |   |                  |   |
 *                                                r   q                  r   &
 *                                                                           |
 *                                                                           q
 *
 *
 *  I/O - Parameters:
 *  -----------------
 *
 *     Name      |   Type     |   I/O   |   Meaning
 *     ----------|------------|---------|--------------------------------
 *     p         |   binptr   |   I/O   |   Root of an already existing
 *               |            |         |   function call
 *     q         |   binptr   |   I/O   |   New parameter to supplemented
 *     varflg    |   char     |    I    |   Indicates a call by address
 *
 *
 *  Called Routines:
 *  ----------------
 *
 *     Name         |   Short description
 *     -------------|-------------------------------------------------
 *     bincreate    |   Create a new 'binptr' node
 *     bininsert    |   Insert a node in front of the actual node
 *     binappend    |   Append node to the right
 *     binright     |   Go right
 *     binsymc      |   Get symbol code
 *
 *---------------------------------------------------------------------------*/

{ binptr   r;  /* Help pointer */


#ifdef TRACE_ON
  print("Trace 'd_suplparam()'"); printline();
#endif


  /* proc d_suplparam */
  /*------------------*/

  r = binright(p);

  if ( !r )
    /* No parameter so far */
    /*---------------------*/

    {
    if ( varflg )                             /* Insert an address node */
      p = binappend(p,bincreate(cAdres));     /* depending on 'varflg'  */

    (void) binappend(p,q);                    /* Function result not needed */
    }
  else
    {
    /* Looking for the rightmost cComma-node */
    /*---------------------------------------*/

    while (binsymc(r) == cComma)  r = binright(r);

    /* Insert a cComma-node and append */
    /* 'q' as right child              */
    /*---------------------------------*/

    r = bininsert(r,bincreate(cComma));

    if ( varflg )                             /* Insert an address node */
      r = binappend(r,bincreate(cAdres));     /* depending on 'varflg'  */

    (void) binappend(r,q);                    /* Function result not needed */
    }

} /* proc d_suplparam */
  /*------------------*/


/*===========================================================================*/

#ifdef LINT_ARGS
void d_gstment ( binptr *p, binptr q )
                                                       /* Generate Statement */
                                                       /* -        --   ---- */
#else
void d_gstment ( p, q )
  binptr  *p,   /* call by address ! */
           q;
#endif

/*-----------------------------------------------------------------------------
 *
 *  The statement 'q' will be appended to the statement sequence with root 'p'.
 *  If 'q' is a null pointer we return without any action.
 *  If 'p' is null 'p' is set to 'q'. Otherwise 'cSemicolon' nodes are skipped
 *  and a new 'cSemincolon' node with 'q' as right child will be inserted.
 *
 *  Example:  p1, p2, p3, q  statements
 *
 *         |                                      |
 *  p ->   ; --- ; ---           ===>      p ->   ; --- ; --- ; ---
 *         |     |    |                           |     |     |    |
 *         p1    p2   p3                          p1    p2    p3   q
 *
 *
 *
 *  I/O - Parameters:
 *  -----------------
 *
 *     Name      |   Type     |   I/O   |   Meaning
 *     ----------|------------|---------|-------------------------------
 *     p         |   binptr   |    I    |   Root of statement sequence
 *     q         |   binptr   |    I    |   New statement to be appended
 *
 *
 *  Called Routines:
 *  ----------------
 *
 *     Name         |   Short description
 *     -------------|-------------------------------------------------
 *     bincreate    |   Create a new 'binptr' node
 *     bininsert    |   Insert node
 *     binlside     |   Append node to the left
 *     binappend    |   Append node to the right
 *     binfather    |   Go to father node
 *     binright     |   Go right
 *     binsymc      |   Get symbol code
 *
 *---------------------------------------------------------------------------*/

{ binptr   r;  /* Help pointers */


#ifdef TRACE_ON
  print("Trace 'd_gstment()'"); printline();
#endif


  /* proc d_gstment */
  /*----------------*/

  if ( ! q ) return;          /* no action; nothing to append */

  if ( !(*p) ) *p = q;        /* p was a null pointer */
  else
    {
    /* Looking for the rightmost statement */
    /*-------------------------------------*/

    r = *p;
    while (binsymc(r) == cSemicolon)  r = binright(r);

    /* Insert a cSemicolon-node and append q */
    /* as right child                        */
    /*---------------------------------------*/

    if ( binfather(r) )                       /* Father node exists, i.e. at */
      {                                       /* least one cSemicolon node   */
      r = bininsert(r,bincreate(cSemicolon)); /* exists                      */
      (void) binappend(r,q);
      }
    else                                      /* Insert a first cSemicolon   */
      {                                       /* to build up a statement list*/
      *p = bincreate(cSemicolon);
       (void) binlside(*p,r);
       (void) binappend(*p,q);
       }
    }
} /* proc d_gstment */
  /*----------------*/


/*===========================================================================*/

#ifdef LINT_ARGS
static binptr d_gif ( binptr p, binptr q, int errnr )
                                                    /* Generate If-Statement */
                                                    /* -        --           */
#else
static binptr d_gif ( p, q, errnr )
  binptr   p, q;
  int      errnr;
#endif

/*-----------------------------------------------------------------------------
 *
 *  Generates an if-statement to compare two integer expresssions. If they are
 *  not equal, an error message will be returned at runtime.
 *
 *            cIF
 *         /       \
 *       /           \
 *     cNE          cCall
 *    /   \        /     \
 *  'p'   'q'  "e_trap"  cComma ----------- cComma ---- cComma-------+
 *                          |                  |           |         |
 *                       cRParent          cIcon: 2     cIcon:     cIcon:
 *                       /     \                        offset_2   errno
 *                 "a_btyp"    cIcon:
 *                             offset_1
 *
 *
 *  The values of 'errnr' are defined in module 'dp_error.h'.
 *  The values of 'offset_1' and 'offset_2' are defined in module "e_def.h"
 *  of the runtime library.
 *
 *
 *
 *  I/O - Parameters:
 *  -----------------
 *
 *     Name      |   Type     |   I/O   |   Meaning
 *     ----------|------------|---------|-------------------------------
 *     p         |   binptr   |    I    |   First integer expression
 *     q         |   binptr   |    I    |   Second integer expression
 *     errnr     |   int      |    I    |   Error number to be passed as
 *               |            |         |   argument for the error handling
 *               |            |         |   runtime routine "e_trap"
 *
 *
 *  Called Routines:
 *  ----------------
 *
 *     Name         |   Short description
 *     -------------|-------------------------------------------------
 *     bincreate    |   Create a new 'binptr' node
 *     binupvalue   |   Update value of a 'binptr' node representing
 *                  |   an integer node
 *     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  head, h, hh, arg;     /* Help pointers */

  int     offset_1 = 0x1300,    /* see module "o_def.h" of the */
          offset_2 = 0x7e00;    /* runtime library             */

#ifdef TRACE_ON
    print("Trace 'd_gif()'"); printline();
#endif


  /* func d_gif */
  /*------------*/

    /* Create if-statement and append its left side */
    /*----------------------------------------------*/

    head = bincreate(cIF);

    h = binlside(head,bincreate(cNE));
    (void) binlside(h,p);                  /* Function results not needed */
    (void) binappend(h,q);


    /* Create the right side of the if statement, i. e.  */
    /* a call of the runtime routine for error messages. */
    /*---------------------------------------------------*/

    h = d_gcall("e_trap");

    /* Build 1st argument, depending */
    /* on 'offset_1'                 */
    /*-------------------------------*/

    arg = bincreate(cRParent);           /* Head of 1st argument */

    hh = bincreate(cCsymbol);            /* Left child */
    binupsym(hh,symins("a_btyp"));
    (void) binlside(arg,hh);

    hh = bincreate(cIcon);               /* Right child */
    binupvalue(hh,(long)offset_1);
    (void) binappend(arg,hh);

    d_suplparam(h,arg,false);            /* supplement argument to "e_trap" */


    /* Build 2nd argument, i. e. the */
    /* number of arguments to follow */
    /*-------------------------------*/

    arg = bincreate(cIcon);
    binupvalue(arg,(long)2);
    d_suplparam(h,arg,false);


    /* Build 3rd argument, depending */
    /* on 'offset_2'                 */
    /*-------------------------------*/

    arg = bincreate(cIcon);
    binupvalue(arg,(long)offset_2);
    d_suplparam(h,arg,false);


    /* Build 4th argument, i. e. the */
    /* error number                  */
    /*-------------------------------*/

    arg = bincreate(cIcon);
    binupvalue(arg,(long)errnr);
    d_suplparam(h,arg,false);


    /* Append right side of the if-statement */
    /*---------------------------------------*/

    (void) binappend(head,h);            /* Function result not needed */

    return(head);

} /* func d_gif */
  /*------------*/


/*===========================================================================*/

#ifdef LINT_ARGS
binptr d_gassign ( binptr p, binptr q )
                                                      /* Generate Assignment */
                                                      /* -        ------     */
#else
binptr d_gassign ( p, q )
  binptr  p, q;
#endif

/*-----------------------------------------------------------------------------
 *
 *  The function generates an assignment
 *
 *                        |
 *                     cAssign
 *                     /     \
 *                   'p'     'q'
 *
 *  Of course the datatypes of left and right side have to be type compatible.
 *
 *
 *  I/O - Parameters:
 *  -----------------
 *
 *     Name      |   Type     |   I/O   |   Meaning
 *     ----------|------------|---------|------------------------------
 *     p         |   binptr   |    I    |   Left side of assignment
 *     q         |   binptr   |    I    |   Right side of assignment
 *
 *
 *  Called Routines:
 *  ----------------
 *
 *     Name         |   Short description
 *     -------------|-------------------------------------------------
 *     bincreate    |   Create a new 'binptr' node
 *     binlside     |   Append node to the left
 *     binappend    |   Append node to the right
 *
 *---------------------------------------------------------------------------*/

{ binptr   h;    /* Head of tree to be returned */


#ifdef TRACE_ON
    print("Trace 'd_gassign()'"); printline();
#endif


  /* func d_gassign */
  /*----------------*/

  h = bincreate(cAssign);

  (void) binlside(h,p);        /* Function results not needed */
  (void) binappend(h,q);

  return(h);

} /* func d_gassign */
  /*----------------*/


/*===========================================================================*/

#ifdef LINT_ARGS
static binptr d_gdiff ( binptr p, binptr q )
                                                      /* Generate Difference */
                                                      /* -        ----       */
#else
static binptr d_gdiff ( p, q )
  binptr  p, q;
#endif

/*-----------------------------------------------------------------------------
 *
 *  The function generates an integer expression for representing the
 *  expression 'p - q'.
 *
 *                        |
 *                      cMinus
 *                     /     \
 *                   'p'     'q'
 *
 *
 *  I/O - Parameters:
 *  -----------------
 *
 *     Name      |   Type     |   I/O   |   Meaning
 *     ----------|------------|---------|-----------------------------------
 *     p         |   tNODE *  |    I    |   Left side
 *     q         |   tNODE *  |    I    |   Right side
 *
 *
 *  Called Routines:
 *  ----------------
 *
 *     Name         |   Short description
 *     -------------|-------------------------------------------------
 *     bincreate    |   Create a new 'binptr' node
 *     binlside     |   Append node to the left
 *     binappend    |   Append node to the right
 *
 *---------------------------------------------------------------------------*/

{ binptr   h;    /* Head of tree to be returned */


#ifdef TRACE_ON
    print("Trace 'd_gdiff()'"); printline();
#endif


  /* func d_gdiff */
  /*--------------*/

  h = bincreate(cMinus);

  (void) binlside(h,p);           /* Function results not needed */
  (void) binappend(h,q);

  return(h);

} /* func d_gdiff */
  /*-------------*/


/*===========================================================================*/

#ifdef LINT_ARGS
binptr d_glen ( tNODE *p, int dim )
                                               /* Generate Length expression */
                                               /* -        ---               */
#else
binptr d_glen ( p, dim )
  tNODE  *p;
  int    dim;
#endif

/*-----------------------------------------------------------------------------
 *
 *  The function generates an integer expression for the length of the
 *  first (row) or second (column) dimension of a vector or matrix variable.
 *
 *                        |
 *                      cMinus
 *                     /     \
 *             upper bound   lower bound
 *
 *
 *  I/O - Parameters:
 *  -----------------
 *
 *     Name      |   Type     |   I/O   |   Meaning
 *     ----------|------------|---------|-----------------------------------
 *     p         |   tNODE *  |    I    |   Pointer to a variable work node
 *     dim       |   int      |    I    |   1 or 2 for row or column index
 *
 *
 *  Called Routines:
 *  ----------------
 *
 *     Name         |   Short description
 *     -------------|-------------------------------------------------
 *     bincreate    |   Create a new 'binptr' node
 *     binlside     |   Append node to the left
 *     binappend    |   Append node to the right
 *     -------------|-------------------------------------------------
 *     d_gdiff      |   Generate difference expression
 *
 *---------------------------------------------------------------------------*/

{

#ifdef TRACE_ON
    print("Trace 'd_glen()'"); printline();
#endif


  /* func d_glen */
  /*-------------*/

  if (dim == 1)
    return( d_gdiff ( bincopy(p->name.varinfo->rowub),
                      bincopy(p->name.varinfo->rowlb) ) );
  else
    return( d_gdiff ( bincopy(p->name.varinfo->colub),
                      bincopy(p->name.varinfo->collb) ) );

} /* func d_glen */
  /*-------------*/


/*===========================================================================*/

#ifdef LINT_ARGS
static binptr d_getveclen ( tNODE *p )
                                                        /* Get Vector Length */
                                                        /* --- ---    ---    */
#else
static binptr d_getveclen ( p )
  tNODE   *p;
#endif

/*-----------------------------------------------------------------------------
 *
 *  The function returns the length of a dotexpression with vector structure.
 *  It is used later as reference length for checking all the other summands
 *  of the dotexpression.
 *
 *
 *  For this goal we descend downwards until a variable node is found. For
 *  indicating whether we have to go to left or right in case of a 'd_mult'
 *  or 'd_id' node we use the flag 'transp_flag'.
 *
 *  We act as decribed below:
 *
 *    L*R      :   L scalar, R vector  ==>  go rightwards
 *                 L vector, R scalar  or
 *                 L matrix, R vector  ==>  go leftwards
 *                 both matrix         ==>  if 'transp_flag' is set go
 *                                          rightwards else go leftwards
 *
 *    id(L,R)  :   if 'transp_flag' is set go rightwards else go leftwards
 *
 *    herm()   :
 *    transp() :   skip 'transp_flag'
 *
 *    any other
 *    case     :   go rightwards by default
 *
 *
 *  I/O - Parameters:
 *  -----------------
 *
 *     Name      |   Type     |   I/O   |   Meaning
 *     ----------|------------|---------|--------------------------------
 *     p         |  tNODE *   |    I    |   Root of the dotexpression
 *
 *
 *  Called Routines:
 *  ----------------
 *
 *     Name      |   Short description
 *     ----------|-------------------------------------------------------
 *     d_glen    |   Generate a binary tree representing an expression
 *               |   for the length of a vector variable
 *
 *---------------------------------------------------------------------------*/

{ char   transp_flag;    /* Transponentiation flag: not set at beginning */

#ifdef TRACE_ON
  print("Trace 'd_getveclen()'"); printline();
#endif

  /* func d_getveclen */
  /*------------------*/


  transp_flag = false;

  while (p->kind != d_variable)

    /* All nodes must be named execpt of variable or constant nodes. The */
    /* latter will not be passed when descending, so we can look for the */
    /* 'name.direct' component, only.                                    */
    /*-------------------------------------------------------------------*/

    switch (p->name.direct)
    {
      default:

           /* go rightwards by default */
           /*--------------------------*/

           p = p->right;
           break;

      case d_mult:

           if (p->left->structure == d_scalar)

             /* scalar * vector */
             /*-----------------*/

             p = p->right;

           else

             /* vector * scalar  or */
             /* matrix * vector     */
             /*---------------------*/

             p = p->left;

           break;

      case d_id:

           if (p->right->name.direct == d_comma)

             /* id() and 2 Arguments */
             /*----------------------*/

             if (transp_flag)
               p = p->right->right;
             else
               p = p->right->left;

           else

             /* id() and 1 Argument */
             /*---------------------*/

             p = p->right;

           break;

      case d_herm  :
      case d_transp:

           /* Skip flag */
           /*-----------*/

           transp_flag = ! transp_flag;
           p = p->right;
           break;

    } /* switch, while */

    if (transp_flag)
      return(d_glen(p,2));
    else
      return(d_glen(p,1));

} /* func d_getveclen */
  /*------------------*/


/*===========================================================================*/

#ifdef LINT_ARGS
static binptr d_getcollen ( tNODE *p )
                                                        /* Get Column Length */
                                                        /* --- ---    ---    */
#else
static binptr d_getcollen ( p )
  tNODE   *p;
#endif

/*-----------------------------------------------------------------------------
 *
 *  The function returns the length of the column of a dotexpression with
 *  matrix structure. It will be used later as reference length for checking
 *  all the other summands of the dotexpression. The length of the column is
 *  the length of the first dimension of a matrix, if the matrix was transponed
 *  it is the length of the second dimension.
 *
 *  For this goal we descend downwards until a variable node is found. For
 *  indicating whether we have to go to left or right in case of a 'd_mult'
 *  or 'd_id' node we use the flag 'transp_flag'.
 *
 *  We act as decribed below:
 *
 *    L*R      :   L scalar, R matrix  ==>  go rightwards
 *                 L matrix, R scalar  ==>  go leftwards
 *                 both matrix         ==>  if 'transp_flag' is set go
 *                                          rightwards else go leftwards
 *
 *    id(L,R)  :   if 'transp_flag' is set go rightwards else go leftwards
 *
 *    herm()   :
 *    transp() :   skip 'transp_flag'
 *
 *    any other
 *    case     :   go rightwards by default
 *
 *
 *  I/O - Parameters:
 *  -----------------
 *
 *     Name      |   Type     |   I/O   |   Meaning
 *     ----------|------------|---------|--------------------------------
 *     p         |  tNODE *   |    I    |   Root of the dotexpression
 *
 *
 *  Called Routines:
 *  ----------------
 *
 *     Name      |   Short description
 *     ----------|-------------------------------------------------------
 *     d_glen    |   Generate a binary tree representing an expression
 *               |   for the length of a vector variable
 *
 *---------------------------------------------------------------------------*/

{ char   transp_flag;      /* Transponentiation flag: not set at beginning */


#ifdef TRACE_ON
  print("Trace 'd_getcollen()'"); printline();
#endif


  /* func d_getcollen */
  /*------------------*/

  transp_flag = false;

  while (p->kind != d_variable)
    switch (p->name.direct)
      {
      default      :  /* go rightwards by default */
                      /*--------------------------*/
                      p = p->right;
                      break;

      case d_mult  :  if (p->left->structure != d_matrix)

                        /* scalar * matrix */
                        /*-----------------*/

                        p = p->right;

                      else if (p->right->structure != d_matrix)

                        /* matrix * scalar */
                        /*-----------------*/

                        p = p->left;

                      else
                        /* matrix * matrix */
                        /*-----------------*/

                        if (transp_flag)
                          p = p->right;
                        else
                          p = p->left;

                      break;

      case d_id    :  if (p->right->name.direct == d_comma)

                        /* id() and 2 Arguments */
                        /*----------------------*/

                        if (transp_flag)
                          p = p->right->right;
                        else
                          p = p->right->left;

                      else

                        /* id() and 1 Argument */
                        /*---------------------*/

                        p = p->right;

                      break;

      case d_herm  :
      case d_transp:  /* Skip flag */
                      /*-----------*/

                      transp_flag = ! transp_flag;
                      p = p->right;
                      break;

      } /* switch, while */

  if (transp_flag)
    return(d_glen(p,2));
  else
    return(d_glen(p,1));

} /* func d_getcollen */
  /*------------------*/


/*===========================================================================*/

#ifdef LINT_ARGS
static binptr d_getrowlen ( tNODE *p )
                                                           /* Get Row Length */
                                                           /* --- --- ---    */
#else
static binptr d_getrowlen ( p )
  tNODE   *p;
#endif

/*-----------------------------------------------------------------------------
 *
 *  The function returns the length of the row of a dotexpression with matrix
 *  structure. It is used later as reference length for checking all the other
 *  summands of the dotexpression. The length of the row is the length of the
 *  second dimension of a matrix, if the matrix was transponed it is the length
 *  of the first dimension.
 *
 *  For this goal we descend rightwards until a variable node is found. For
 *  indicating whether we have to go to left or right in case of a 'd_mult'
 *  or 'd_id' node we use the flag 'transp_flag'.
 *
 *  We act as decribed below:
 *
 *    L*R      :   L scalar, R matrix  ==>  go rightwards
 *                 L matrix, R scalar  ==>  go leftwards
 *                 both matrix         ==>  if 'transp_flag' is set go
 *                                          leftwards else go rightwards
 *
 *    id(L,R)  :   if 'transp_flag' is set go leftwards else go rightwards
 *
 *    herm()   :
 *    transp() :   skip 'transp_flag'
 *
 *    any other
 *    case     :   go rightwards by default
 *
 *
 *  I/O - Parameters:
 *  -----------------
 *
 *     Name      |   Type     |   I/O   |   Meaning
 *     ----------|------------|---------|--------------------------------
 *     p         |  tNODE *   |    I    |   Root of the dotexpression
 *
 *
 *  Called Routines:
 *  ----------------
 *
 *     Name      |   Short description
 *     ----------|-------------------------------------------------------
 *     d_glen    |   Generate a binary tree representing an expression
 *               |   for the length of a vector variable
 *
 *---------------------------------------------------------------------------*/

{ char   transp_flag = false;      /* Not set at beginning */


#ifdef TRACE_ON
  print("Trace 'd_getrowlen()'"); printline();
#endif


  /* func d_getrowlen */
  /*------------------*/

  while (p->kind != d_variable)
    switch (p->name.direct)
      {
      default      :  /* go rightwards by default */
                      /*--------------------------*/
                      p = p->right;
                      break;

      case d_mult  :  if (p->left->structure != d_matrix)

                        /* scalar * matrix */
                        /*-----------------*/

                        p = p->right;

                      else if (p->right->structure != d_matrix)

                        /* matrix * scalar */
                        /*-----------------*/

                        p = p->left;

                      else
                        /* matrix * matrix */
                        /*-----------------*/

                        if (transp_flag)
                          p = p->left;
                        else
                          p = p->right;

                      break;

      case d_id    :  if (p->right->name.direct == d_comma)

                        /* id() and 2 Arguments */
                        /*----------------------*/

                        if (transp_flag)
                          p = p->right->left;
                        else
                          p = p->right->right;

                      else

                        /* id() and 1 Argument */
                        /*---------------------*/

                        p = p->right;

                      break;

      case d_herm  :
      case d_transp:  /* Skip flag */
                      /*-----------*/

                      transp_flag = ! transp_flag;
                      p = p->right;
                      break;

      } /* switch, while */

  if (transp_flag)
    return(d_glen(p,1));
  else
    return(d_glen(p,2));

} /* func d_getrowlen */
  /*------------------*/


/*===========================================================================*/


/* Generates an if-statement only if the integer expressions for     */
/* the length 'len' and the reference length 'reflen' are not equal. */
/*-------------------------------------------------------------------*/

#define GEN_IF(len,refvar,errnr)                         \
  if ( ! bincompare(len,refvar) )                        \
    d_gstment(&if_root,d_gif(len,refvar,errnr))



/* If both expressions, the one for 'len' and the one for 'reflen'  */
/* are equal, then use the variable 'refvar' instead of the whole   */
/* expression 'reflen'.                                             */
/*------------------------------------------------------------------*/

#define SUBST_LEN(len,reflen,refvar)                     \
  if ( bincompare(len,reflen) )   len = refvar;


/*===========================================================================*/

#ifdef LINT_ARGS
static void d_gsclchk ( tNODE *p , binptr *collen )
                                                  /* Generate Scalar Checks */
                                                  /* -    -- -   --  - -- - */
#else
static void d_gsclchk ( p , collen )
  tNODE   *p;
  binptr  *collen;    /* call by address */
#endif

/*-----------------------------------------------------------------------------
 *
 *  The procedure generates the dimension checks for a scalar dotexpression.
 *  I. e. if there is any scalar product within the dotexpression, an
 *  if-statement will be generated for checking whether the lenghts of both
 *  factors are the same or not. If the factors represent the same variable
 *  the if-statement is not to be generated.
 *
 *  1. The procedure is implemented by recursive descending with respect to
 *     parameter 'p'.
 *
 *  2. To reduce the number of formal parameters in this recursive procedure
 *     we use a static variable which is global to all routines in this
 *     module:
 *
 *        Name     |   Description
 *        ---------|-------------------------------------------------------
 *        if_root  |   A pointer to the root of the if-statements generated
 *                 |   by 'd_gsclchk()'
 *
 *     This variable will be used later by procedure 'd_gscheck()' to
 *     collect and return all generated check statements.
 *
 *  3. The procedure has a reference parameter 'collen' which is used to pass
 *     the length of vectors from bottom to the top of the working tree
 *     as far as necessary. Depending on the kind of the work node we act as
 *     described below:
 *
 *     Operators:
 *     ----------
 *             +          - check left and right operand
 *           /   \        - reset 'collen'
 *          L     R
 *
 *             *          - check left and right factor
 *           /   \        - if the factors are vectors then
 *          L     R         -- generate an if-statement for comparing
 *                             both lenghts
 *                        - reset 'collen'
 *
 *             ,          - check left and right argument
 *           /   \        - if both arguments are vectors then
 *          L     R         -- generate an if-statement for comparing
 *                             both lengths
 *                          -- pass the length of the left argument by
 *                             'collen' to the top
 *                        - else reset 'collen'
 *     Sharp-Operators,
 *     Sum, To, Downto,
 *     Monadic Minus   :    check right child and pass its length to the top
 *
 *     Any other
 *     Operator        :    should not happen  ==>  implementation error
 *

 *     Functions:           check right child and pass its length to the top
 *     ----------
 *
 *     Variables:           if it is a vector pass its length to the top
 *     ----------           else reset 'collen'
 *
 *     Constants:           reset 'collen'
 *     ----------
 *
 *     Any other kind:    Should not happen  ==>  implementation error
 *     ---------------
 *
 *
 *  4. Example:  To check the dotexpression
 *
 *                   u := #*( u * intval(v,w) );
 *
 *               with u, v, and w  vectors, the following mnemonic sequence of
 *               if-statements will be generated:
 *
 *                   if ( length(v) != length(w) ) then error_handling;
 *                   if ( length(u) != length(v) ) then error_handling;
 *
 *
 *  I/O - Parameters:
 *  -----------------
 *
 *     Name      |   Type      |   I/O   |   Meaning
 *     ----------|-------------|---------|-----------------------------
 *     p         |   tNODE *   |    I    |   Pointer to the root of the
 *               |             |         |   working tree
 *     collen    |   binptr *  |   I/O   |   Length of a variable to be
 *               |             |         |   passed to the top
 *
 *
 *  Called Routines:
 *  ----------------
 *
 *     Name          |   Short description
 *     --------------|-------------------------------------------------
 *     g_glen        |   Generate an expression for the length of a
 *                   |   variable
 *     d_gif         |   Generate an if-statement
 *     d_gstment     |   Generate another statement
 *     d_gsclchk     |   Recursively called
 *
 *---------------------------------------------------------------------------*/

{ binptr   lcollen, rcollen;     /* Help pointers for descending to left  */
                                 /* and right childs                      */

  postype  save_pos;             /* To store the global position 'pos' */
                                 /* when executing code of this module */

  /* proc d_gsclchk */
  /*----------------*/

  save_pos = pos;      /* Set 'pos' to the correct position of the */
  pos = p->pos;        /* work node within the source line         */


  switch (p->kind)
  {
    case d_Operator:

         /* Operators of the working tree */
         /*-------------------------------*/

         switch (p->name.direct)
         {
           case d_lpard      :
           case d_lparu      :
           case d_sharp      :
           case d_sharpnext  :
           case d_sharpup    :
           case d_sharpdown  :
           case d_sharpintval:
           case d_mminus     :
           case d_sum        :
           case d_to         :
           case d_downto     :

                /* Operators whose right child */
                /* is to be examined           */
                /*-----------------------------*/

                d_gsclchk(p->right,collen);
                break;

           case d_plus :

                /* Addition */
                /*----------*/

                d_gsclchk(p->left, collen);
                d_gsclchk(p->right,collen);
                *collen = NIL;
                break;

           case d_mult:

                /* Multiplication */
                /*----------------*/

                d_gsclchk(p->left, &lcollen);
                d_gsclchk(p->right,&rcollen);

                if (lcollen)         /* left and right factors are vectors */
                                     /*------------------------------------*/
                  GEN_IF(lcollen,rcollen,dSCLPRD);

                *collen = NIL;

                break;

           case d_comma:

                /* Argumentlist of a function with two parameters */
                /*------------------------------------------------*/

                d_gsclchk(p->left, &lcollen);
                d_gsclchk(p->right,&rcollen);

                if (lcollen)         /* left and right factors are vectors */
                  {                  /*------------------------------------*/

                  GEN_IF(lcollen,rcollen,dFCTVEC);
                  *collen = bincopy(lcollen);
                  }
                else
                  *collen = NIL;

                break;

           default:;
                /* This branch should not be accessed */
                /*------------------------------------*/
#ifdef CHECK
                print("'d_gsclchk()'  ->   implement. error ");
                printline();
                print("   error in a case of a switch (No 1)");
                printline();
                break;
#endif
         } /*  switch (p->name.direct)  */

         break;


    case d_function:

         /* Function calls */
         /*----------------*/

         d_gsclchk(p->right,collen);
         break;


    case d_variable:

         /* Variable operands */
         /*-------------------*/

         if (p->structure == d_vector)
           *collen = d_glen(p,1);
         else
           *collen = NIL;
         break;


    case d_constant:
    case d_nconst  :

         /* Real or integer Constants */
         /*---------------------------*/

         *collen = NIL;
         break;

    default:;

         /* This branch should not be accessed */
         /*------------------------------------*/
#ifdef CHECK
         print("'d_gsclchk()'  ->   implement. error ");
         printline();
         print("   error in a case of a switch (No 2)");
         printline();
         break;
#endif

  } /*  switch (p->kind)  */

  pos = save_pos;     /* Rebuild global position pointer */

} /* proc d_gsclchk */
  /*----------------*/


/*===========================================================================*/

#ifdef LINT_ARGS
binptr d_gscheck ( tNODE *p )
                                                   /* Generate Scalar Checks */
                                                   /* -        -      -----  */
#else
binptr d_gscheck ( p )
  tNODE  *p;
#endif

/*-----------------------------------------------------------------------------
 *
 *  The procedure is used to return all check statements which were generated
 *  by the recursive procedure 'd_gsclchk()'. Both procedures communicate by
 *  a static variable:
 *
 *        Name     |   Description
 *        ---------|-------------------------------------------------------
 *        if_root  |   A pointer to the root of the if-statements generated
 *                 |   by 'd_gsclchk()'
 *        d_1stdim |   Not used but initialized properly
 *        d_2nddim |
 *
 *
 *  I/O - Parameters:
 *  -----------------
 *
 *     Name      |   Type      |   I/O   |   Meaning
 *     ----------|-------------|---------|-----------------------------
 *     p         |   tNODE *   |    I    |   Pointer to the root of the
 *               |             |         |   working tree
 *
 *
 *  Called Routines:
 *  ----------------
 *
 *     Name          |   Short description
 *     --------------|-------------------------------------------------
 *     g_gsclchk     |   Generate checks by recursive descending
 *     d_gstment     |   Generate another statement
 *
 *---------------------------------------------------------------------------*/

{  binptr   row,           /* Help variable */
            stm_root;      /* Root of statements to be returned */

#ifdef TRACE_ON
  print("Trace 'd_scheck()'"); printline();
#endif


   /* func d_gscheck */
   /*----------------*/
                                                      /* Static variables:   */
   stm_root = if_root = d_1stdim = d_2nddim = NIL;    /*   if_root           */
                                                      /*   d_1stdim          */
                                                      /*   d_2nddim          */

   /* Generate and return check statements */
   /*--------------------------------------*/

   d_gsclchk(p,&row);
   d_gstment(&stm_root,if_root);

   return(stm_root);

}  /* func d_gscheck */
   /*----------------*/


/*===========================================================================*/

#ifdef LINT_ARGS
static void d_gvecchk ( tNODE *p , binptr *collen, binptr *rowlen )
                                                   /* Generate Vector Checks */
                                                   /* -        ---    --  -  */
#else
static void d_gvecchk ( p , collen, rowlen )
  tNODE   *p;
  binptr  *collen, *rowlen;    /* call by address */
#endif

/*-----------------------------------------------------------------------------
 *
 *  The procedure generates the dimension checks for a vector dotexpression.
 *  There are two kinds of checks to be done. First check if the lengths of
 *  each vector summand are the same, second check if scalar products occuring
 *  in 'matrix * vector' multiplications are well defined.
 *
 *  1. The procedure is implemented by recursive descending with respect to
 *     parameter 'p'.
 *
 *  2. To reduce the number of formal parameters in this recursive procedure
 *     we use some global variables:
 *
 *        Name      |   Description
 *        ----------|-------------------------------------------------------
 *        d_1stdim  |   A pointer to an integer variable. Its value is used
 *                  |   as reference length for all summands and will be set
 *                  |   by 'd_gvcheck()'.
 *                  |   It is declared as extern in "dp_check.h".
 *        d_1stexpr |   A pointer to the integer expression belonging to
 *                  |   the reference variable 'd_1stdim' mentioned above.
 *                  |   It will be set by 'd_gvcheck()'.
 *                  |   It is declared as static in this module.
 *        if_root   |   A pointer to the root of the if-statements generated
 *                  |   by 'd_gvecchk()'.
 *                  |   It is declared as static in this module.
 *
 *     These variables will be used later by procedure 'd_gvcheck()' to
 *     collect and return all generated check statements.
 *
 *  3. The procedure has two reference parameters 'collen' and 'rowlen' which
 *     are used to pass length information from bottom to the top as far as
 *     necessary:
 *
 *        Name     |  Description
 *        ---------|-------------------------------------------------------
 *        collen   |  Length of a vector or length of the column of a matrix
 *        rowlen   |  Length of the row of a matrix or not used
 *
 *     Depending on the kind of the work node we act as described below:
 *
 *     Operators:
 *     ----------
 *             +          - check left and right operand
 *           /   \        - if check statements for the left operand are
 *          L     R         not yet done, generate an if-statement for
 *                          comparing  the length of 'L' with the reference
 *                          length
 *                        - act in equivalent manner for 'R'
 *                        - reset 'collen' and 'rowlen'
 *
 *             *          - check left and right factor
 *           /   \        - if a 'matrix * vector' product was found
 *          L     R         -- generate an if-statement for comparing the
 *                             length of a column of 'L' with the reference
 *                             length
 *                          -- generate an if-statement for comparing the
 *                             length of a row of 'L' with the length of 'R'
 *                        - if a 'vector * scalar' product was found
 *                          -- generate an if-statement for comparing the
 *                             length of 'L' with the reference length
 *                        - if a 'scalar * vector' product was found
 *                          -- generate an if-statement for comparing the
 *                             length 'R' with the reference length
 *                        - reset 'collen' and 'rowlen'
 *
 *             ,          - check left and right argument
 *           /   \        - if they are arguments of an id(..) call
 *          L     R         -- generate an if-statement for comparing the
 *                             length of a row of 'L' with the length of a
 *                             column of 'R'
 *                          -- pass the length of a column of 'L' to 'collen'
 *                             and the length of a row of 'R' to 'rowlen'
 *                        - if they are arguments of an intval(..) or compl(..)
 *                          call
 *                          -- if they are both matrices
 *                             --- generate if-statements for comparing their
 *                                 column and row lengths
 *                             --- pass column and row length of 'L' to
 *                                 'collen' and 'rowlen' respectively
 *                          -- if they are both vectors
 *                             --- generate an if-statement for comparing their
 *                                 lengths
 *                             --- pass the length of 'L' to 'collen' and reset
 *                                 'rowlen'
 *                          -- if they are both scalars
 *                             --- reset 'collen' and 'rowlen'
 *
 *     Sharp-Operators,
 *     Sum, To, Downto,
 *     Monadic Minus   :  - check right child. If 'collen' was set, generate an
 *                          if-statement for comparing it with the reference
 *                          length
 *                        - reset 'collen' and 'rowlen'
 *
 *     Any other
 *     Operator        :    should not happen  ==>  implementation error
 *

 *     Functions:         - Check right child and pass its length to the top
 *     ----------         - if a call of transp(..) or herm(..) is examined,
 *                          swap 'collen' and 'rowlen'
 *
 *     Variables:         - if it is a vector pass its length to the top
 *     ----------           and reset 'rowlen'
 *                        - if it is a matrix pass the lengths of its column
 *                          and its row to the top
 *                        - else reset 'collen' and 'rowlen'
 *
 *     Constants:           reset 'collen' and 'rowlen'
 *     ----------
 *
 *     Any other kind:      should not happen  ==>  implementation error
 *     ---------------
 *
 *
 *  4. Example:  To check the dotexpression
 *
 *                   u := #*( v + transp(intval(A,B)) * w );
 *
 *               with u, v, w  vectors and A, B matrices, the following
 *               mnemonic sequence of if-statements will be generated,
 *               where n is the value of the reference vector length:
 *
 *                   if ( length(v) != n ) then error_handling;
 *
 *                   if ( column_length(A) != column_length(B) ) then
 *                     error_handling;
 *
 *                   if ( row_length(A) != row_length(B) ) then
 *                     error_handling;
 *
 *                   if ( column_length(A) != length(w) ) then
 *                     error_handling;
 *
 *                   if ( row_length(A) != n ) then error_handling;
 *
 *
 *  I/O - Parameters:
 *  -----------------
 *
 *     Name      |   Type      |   I/O   |   Meaning
 *     ----------|-------------|---------|-------------------------------
 *     p         |   tNODE *   |    I    |   Pointer to the root of the
 *               |             |         |   working tree
 *     collen    |   binptr *  |   I/O   |   Length of a vector or of a
 *               |             |         |   column of a matrix to be passed
 *               |             |         |   to the top
 *     rowlen    |   binptr *  |   I/O   |   Length of a row of a matrix to
 *               |             |         |   be passed to the top
 *
 *
 *  Called Routines:
 *  ----------------
 *
 *     Name          |   Short description
 *     --------------|-------------------------------------------------
 *     g_glen        |   Generate an expression for the length of a
 *                   |   variable
 *     d_gif         |   Generate an if-statement
 *     d_gstment     |   Generate another statement
 *     d_gvecchk     |   Recursively called
 *
 *---------------------------------------------------------------------------*/

{ binptr   lcollen, lrowlen,      /* Help pointers for lengths of columns  */
           rcollen, rrowlen,      /* and rows of a vector or matrix        */

           dummy;                 /* dummy: result will not be used */

  postype  save_pos;              /* To store the global position 'pos' */
                                  /* when executing code of this module */

  /* proc d_gvecchk */
  /*----------------*/

  save_pos = pos;      /* Set 'pos' to the correct position of the */
  pos = p->pos;        /* work node within the source line         */


  switch (p->kind)
  {
    case d_Operator:

         /* Operators of the working tree */
         /*-------------------------------*/

         switch (p->name.direct)
         {
           case d_lpard       :
           case d_lparu       :
           case d_sharp       :
           case d_sharpnext   :
           case d_sharpup     :
           case d_sharpdown   :
           case d_sharpintval :
           case d_mminus      :
           case d_sum         :
           case d_to          :
           case d_downto      :

                /* Operators whose right child is to be examined. */
                /* If the length of a variable is passed, an      */
                /* if-statement is to be generated                */
                /*------------------------------------------------*/

                d_gvecchk(p->right,collen,&dummy);

                if (*collen)
                  GEN_IF(*collen,d_1stdim,dSUMVEC);

                *collen = *rowlen = NIL;
                break;

           case d_plus :

                /* Addition */
                /*----------*/

                d_gvecchk(p->left, &lcollen,&dummy);
                d_gvecchk(p->right,&rcollen,&dummy);

                if (lcollen)    /* check statements for left side not yet */
                                /* generated                              */
                                /*----------------------------------------*/

                  GEN_IF(lcollen,d_1stdim,dSUMVEC);


                if (rcollen)    /* check statements for right side not yet */
                                /* generated                               */
                                /*-----------------------------------------*/

                  GEN_IF(rcollen,d_1stdim,dSUMVEC);

                *collen = *rowlen = NIL;
                break;

           case d_mult:

                /* Multiplication */
                /*----------------*/

                d_gvecchk(p->left, &lcollen,&lrowlen);
                d_gvecchk(p->right,&rcollen,&dummy);

                if (lrowlen)         /*  'matrix * vector' found  */
                  {                  /*---------------------------*/

                  GEN_IF(lcollen,d_1stdim,dSUMVEC);
                  GEN_IF(lrowlen,rcollen,dPRDMATVEC);
                  }

                else if (lcollen)    /*  'vector * scalar' found  */
                                     /*---------------------------*/

                  GEN_IF(lcollen,d_1stdim,dSUMVEC);

                else                 /*  'scalar * vector' found  */
                                     /*---------------------------*/

                  GEN_IF(rcollen,d_1stdim,dSUMVEC);

                *collen = *rowlen =NIL;
                break;

           case d_comma:

                /* Argumentlist of a function with two parameters */
                /*------------------------------------------------*/

                d_gvecchk(p->left, &lcollen,&lrowlen);
                d_gvecchk(p->right,&rcollen,&rrowlen);

                switch (p->father->name.direct)
                {
                  case d_id:

                       /* Arguments of id(.,.), both arguments matrices */
                       /*-----------------------------------------------*/

                       GEN_IF(lrowlen,rcollen,dFCTPRD);

                       *collen = lcollen;
                       *rowlen = rrowlen;
                       break;

                  case d_intval:
                  case d_compl :

                       /* Arguments of intval(.,.) or compl(.,.) */
                       /* with both arguments                    */
                       /*      - matrices or                     */
                       /*      - vectors  or                     */
                       /*      - scalars                         */
                       /*----------------------------------------*/

                       if (lrowlen)    /* arguments are matrices */
                         {             /*------------------------*/

                         GEN_IF(lcollen,rcollen,dFCTROW);
                         GEN_IF(lrowlen,rrowlen,dFCTCOL);

                         *collen = bincopy(lcollen);    /* copy necessary    */
                         *rowlen = bincopy(lrowlen);    /* else side-effects */
                         }
                       else if (lcollen)     /* arguments are vectors  */
                         {                   /*------------------------*/

                         GEN_IF(lcollen,rcollen,dFCTVEC);

                         *collen = bincopy(lcollen);    /* copy necessary    */
                         *rowlen = NIL;                 /* else side-effects */
                         }
                       else                  /* arguments are scalars  */
                                             /*------------------------*/

                         *collen = *rowlen = NIL;

                       break;

                  default:;

                       /* This branch should not be accesed */
                       /*-----------------------------------*/
#ifdef CHECK
                       print("'d_gvecchk()'   ->   implement. error");
                       printline();
                       print("    error in a case of a switch (No1)");
                       printline();
                       break;
#endif
                }   /*  switch (p->father ...)  */

                break;

         default:;

                /* This branch should not be accesed */
                /*-----------------------------------*/
#ifdef CHECK
                print("'d_gvecchk()'   ->   implement. error");
                printline();
                print("    error in a case of a switch (No2)");
                printline();
                break;
#endif
         }   /*  switch (p->name.direct)  */
         break;


    case d_function:

         /* Function calls */
         /*----------------*/

         d_gvecchk(p->right,collen,rowlen);

         switch (p->name.direct)
         {
           case d_herm:
           case d_transp:
                dummy   = *collen;        /* swap of row and column length */
                *collen = *rowlen;        /*-------------------------------*/
                *rowlen = dummy;
                break;

           default:                       /* no action else */
                break;                    /*----------------*/
         }
         break;


    case d_variable:

         /* Variable operands */
         /*-------------------*/

         switch (p->structure)
         {
           case d_vector:                       /* pass length of a vector */
                *collen = d_glen(p,1);          /* to the top              */
                *rowlen = NIL;                  /*-------------------------*/

                SUBST_LEN(*collen,d_1stexpr,d_1stdim);
                break;

           case d_matrix:                       /* pass lengths of row and */
                *collen = d_glen(p,1);          /* column to the top       */
                *rowlen = d_glen(p,2);          /*-------------------------*/

                SUBST_LEN(*collen,d_1stexpr,d_1stdim);
                SUBST_LEN(*rowlen,d_1stexpr,d_1stdim);
                break;

           default:
                *collen = *rowlen = NIL;        /* reset both lengths */
                break;                          /*--------------------*/
         }
         break;

    case d_constant:
    case d_nconst  :

         /* Real or interger contants */
         /*---------------------------*/

         *collen = *rowlen = NIL;              /* reset both lengths */
         break;                                /*--------------------*/


    default:;
         /* This branch should not be accesed */
         /*-----------------------------------*/
#ifdef CHECK
         print("'d_gvecchk()'   ->   implement. error");
         printline();
         print("    error in a case of a switch (No3)");
         printline();
         break;
#endif

  }   /*  switch (p->kind)  */

  pos = save_pos;   /* Rebuild global position pointer */

}  /* proc d_vecchk */
   /*---------------*/


/*===========================================================================*/

#ifdef LINT_ARGS
binptr d_gvcheck ( tNODE *p )
                                                   /* Generate Vector Checks */
                                                   /* -        -      -----  */
#else
binptr d_gvcheck ( p )
  tNODE  *p;
#endif

/*-----------------------------------------------------------------------------
 *
 *  The procedure is used
 *
 *     1. to set the value of the reference length 'd_1stdim'
 *     2. to return all check statements, if the switch for
 *        generating check statements is set on
 *
 *  We use the recursive procedure 'd_gvecchk()'. Both procedures communicate
 *  by some global variables:
 *
 *        Name      |   Description
 *        ----------|-------------------------------------------------------
 *        d_1stdim  |   A pointer to an integer variable. Its value is used
 *                  |   as reference length for all summands and is set
 *                  |   by this procedure.
 *                  |   It is declared as extern in "dp_check.h".
 *        d_1stexpr |   A pointer to the integer expression belonging to
 *                  |   the reference variable 'd_1stdim' mentioned above.
 *                  |   It is declared as static in this module.
 *        d_2nddim  |   Not used but initialized properly.
 *        if_root   |   A pointer to the root of the if-statements generated
 *                  |   by 'd_gvecchk()'.
 *                  |   It is declared as static in this module.
 *
 *
 *  I/O - Parameters:
 *  -----------------
 *
 *     Name      |   Type      |   I/O   |   Meaning
 *     ----------|-------------|---------|-----------------------------
 *     p         |   tNODE *   |    I    |   Pointer to the root of the
 *               |             |         |   working tree
 *
 *
 *  Called Routines:
 *  ----------------
 *
 *     Name          |   Short description
 *     --------------|-------------------------------------------------
 *     g_gvecchk     |   Generate checks by recursive descending
 *     d_gstment     |   Generate another statement
 *
 *---------------------------------------------------------------------------*/

{  binptr   col, row, stm_root;

#ifdef TRACE_ON
  print("Trace 'd_vcheck()'"); printline();
#endif


   /* func d_gvcheck */
   /*----------------*/

                                                      /* Static variables:   */
   stm_root = if_root = d_1stdim = d_2nddim = NIL;    /*   if_root           */
                                                      /*   d_1stdim          */
                                                      /*   d_2nddim          */

   /* Set referenece length */
   /*-----------------------*/

   d_1stdim = tempdecl("Nn",integertype);
   d_1stexpr = d_getveclen(p);
   d_gstment(&stm_root,d_gassign(bincopy(d_1stdim),d_1stexpr));

   /* Generate and return check statements, if necessary */
   /*----------------------------------------------------*/

   if (on_index)
     {
     d_gvecchk(p,&col,&row);
     d_gstment(&stm_root,if_root);
     }

   return(stm_root);


}  /* func d_gvcheck */
   /*----------------*/


/*===========================================================================*/

#ifdef LINT_ARGS
static void d_gmatchk ( tNODE *p, binptr *collen, binptr *rowlen )
                                                   /* Generate Matrix Checks */
                                                   /* -        ---    --  -  */
#else
static void d_gmatchk ( p , collen, rowlen )
  tNODE   *p;
  binptr  *collen, *rowlen;    /* call by address */
#endif

/*-----------------------------------------------------------------------------
 *
 *  The procedure generates the dimension checks for a matrix dotexpression.
 *  There are two kinds of checks to be done. First check if the outer lengths,
 *  i. e. the lengths of column and row, of each matrix summand are the same.
 *  Second check if the inner lengths in 'matrix * matrix' multiplications are
 *  the same.
 *
 *  1. The procedure is implemented by recursive descending with respect to
 *     parameter 'p'.
 *
 *  2. To reduce the number of formal parameters in this recursive procedure
 *     we use some global variables:
 *
 *        Name      |   Description
 *        ----------|-------------------------------------------------------
 *        d_1stdim  |   A pointer to an integer variable. Its value is used
 *                  |   as reference length for the length of rows of all
 *                  |   summands and is set by 'd_gmcheck()'.
 *                  |   It is declared as extern in "dp_check.h".
 *        d_1stexpr |   A pointer to the integer expression belonging to
 *                  |   the reference variable 'd_1stdim' mentioned above.
 *                  |   It will be set by 'd_gmcheck()'.
 *                  |   It is declared as static in this module.
 *        d_2nddim  |   A pointer to an integer variable. Its value is used
 *                  |   as reference length for the length of columns of all
 *                  |   summands and is set by 'd_gmcheck()'.
 *                  |   It is declared as extern in "dp_check.h".
 *        d_2ndexpr |   A pointer to the integer expression belonging to
 *                  |   the reference variable 'd_2nddim' mentioned above.
 *                  |   It will be set by 'd_gmcheck()'.
 *                  |   It is declared as static in this module.
 *        if_root   |   A pointer to the root of the if-statements generated
 *                  |   by 'd_gmatchk()'.
 *                  |   It is declared as static in this module.
 *
 *     These variables will be used later by procedure 'd_gmcheck()' to
 *     collect and return all generated check statements.
 *
 *  3. The procedure has two reference parameters 'collen' and 'rowlen' which
 *     are used to pass length information from bottom to the top as far as
 *     necessary:
 *
 *        Name     |  Description
 *        ---------|-----------------------------------
 *        collen   |  Length of the column of a matrix
 *        rowlen   |  Length of the row of a matrix
 *
 *     Depending on the kind of the work node we act as described below:
 *
 *     Operators:
 *     ----------
 *             +          - check left and right operand
 *           /   \        - if check statements for the left operand are
 *          L     R         not yet created, generate if-statements for
 *                          comparing the outer lengths of 'L' and 'R' with
 *                          the reference lengths
 *                        - reset 'collen' and 'rowlen'
 *
 *             *          - check left and right factor
 *           /   \        - if a 'matrix * matrix' product was found
 *          L     R         -- generate if-statements for comparing the outer
 *                             lengths of 'L' and 'R' with the reference
 *                             lengths
 *                          -- generate an if-statement for comparing the
 *                             inner lengths of 'L' and 'R'
 *                        - if a 'matrix * scalar' product was found
 *                          -- generate if-statements for comparing the
 *                             outer lengths of 'L' with the reference lengths
 *                        - if a 'scalar * matrix' product was found
 *                          -- generate if-statements for comparing the
 *                             outer lengths of 'R' with the reference lengths
 *                        - reset 'collen' and 'rowlen'
 *
 *             ,          - check left and right argument
 *           /   \        - if they are arguments of an id(..) call
 *          L     R         -- generate an if-statement for comparing the
 *                             inner lengths 'L' and 'R'
 *                          -- pass the length of a column of 'L' to 'collen'
 *                             and the length of a row of 'R' to 'rowlen'
 *                        - if they are arguments of an intval(..) or compl(..)
 *                          call
 *                          -- if they are both matrices
 *                             --- generate if-statements for comparing the
 *                                 outer lengths of 'L' and 'R'
 *                             --- pass the lengths of column and row of 'L'
 *                                 to  'collen' and 'rowlen' respectively
 *                          -- if they are both scalars
 *                             --- reset 'collen' and 'rowlen'
 *
 *     Sharp-Operators,
 *     Sum, To, Downto,
 *     Monadic Minus   :  - check right child. If 'collen' was set generate
 *                          if-statements for comparing its outer lengths
 *                          with the reference lengths
 *                        - reset 'collen' and 'rowlen'
 *
 *     Any other
 *     Operator        :    should not happen  ==>  implementation error
 *
 *     Functions:         - Check right child and pass its length to the top
 *     ----------         - in case of a call of transp(..) or herm(..)
 *                          swap 'collen' and 'rowlen'
 *
 *     Variables:         - if it is a matrix pass its lengths of column
 *     ----------           and row to the top by 'collen' and 'rowlen'
 *                        - else reset 'collen' and 'rowlen'
 *
 *     Constants:           reset 'collen' and 'rowlen'
 *     ----------
 *
 *     Any other kind:      should not happen  ==>  implementation error
 *     ---------------
 *
 *
 *  4. Example:  To check the dotexpression
 *
 *                   E := #*( A + id(B,C) * transp(D) );
 *
 *               with A, B, C, D and E matrices, the following mnemonic
 *               sequence of if-statements will be generated, where n and m
 *               are the values of the reference lengths for the columns
 *               and rows of each summand:
 *
 *                   if ( column_length(A) != n ) then error_handling;
 *                   if ( row_length(A) != m )    then error_handling;
 *
 *                   if ( row_length(B) != column_length(C) ) then
 *                     error_handling;
 *
 *                   if ( column_length(B) != n ) then error_handling;
 *                   if ( column_length(D) != m ) then error_handling;
 *
 *                   if ( row_length(C) != row_length(D) ) then
 *                     error_handling;
 *
 *
 *  I/O - Parameters:
 *  -----------------
 *
 *     Name      |   Type      |   I/O   |   Meaning
 *     ----------|-------------|---------|-------------------------------
 *     p         |   tNODE *   |    I    |   Pointer to the root of the
 *               |             |         |   working tree
 *     collen    |   binptr *  |   I/O   |   Length of a column of a matrix
 *               |             |         |   to be passed to the top
 *     rowlen    |   binptr *  |   I/O   |   Length of a row of a matrix
 *               |             |         |   to be passed to the top
 *
 *
 *  Called Routines:
 *  ----------------
 *
 *     Name          |   Short description
 *     --------------|-------------------------------------------------
 *     g_glen        |   Generate an expression for the length of a
 *                   |   variable
 *     d_gif         |   Generate an if-statement
 *     d_gstment     |   Generate another statement
 *     d_gmatchk     |   Recursively called
 *
 *---------------------------------------------------------------------------*/

{ binptr   lcollen, lrowlen,      /* Help pointers for lengths of rows and */
           rcollen, rrowlen,      /* columns of a vector or matrix         */

           help;                  /* Help variable for swapping */

  postype  save_pos;              /* To store the global position 'pos' */
                                  /* when executing code of this module */

  /* proc d_gmatchk */
  /*----------------*/

  save_pos = pos;      /* Set 'pos' to the correct position of the */
  pos = p->pos;        /* work node within the source line         */


  switch (p->kind)
  {
    case d_Operator:

         /* Operators of the working tree */
         /*-------------------------------*/

         switch (p->name.direct)
         {
           case d_lpard       :
           case d_lparu       :
           case d_sharp       :
           case d_sharpnext   :
           case d_sharpup     :
           case d_sharpdown   :
           case d_sharpintval :
           case d_mminus      :
           case d_sum         :
           case d_to          :
           case d_downto      :

                /* Operators whose right child is to be examined.  */
                /* If the lengths of row and column of a variable  */
                /* is passed two if-statements are to be generated */
                /*-------------------------------------------------*/

                d_gmatchk(p->right,collen,rowlen);
                if (*collen)
                  {
                  GEN_IF(*collen,d_1stdim,dSUMROW);
                  GEN_IF(*rowlen,d_2nddim,dSUMCOL);
                  }

                *collen = *rowlen = NIL;
                break;

           case d_plus :

                /* Addition */
                /*----------*/

                d_gmatchk(p->left, &lcollen,&lrowlen);
                d_gmatchk(p->right,&rcollen,&rrowlen);

                if (lcollen)    /* check statements for left side */
                                /* not yet generated              */
                  {             /*--------------------------------*/

                  GEN_IF(lcollen,d_1stdim,dSUMROW);
                  GEN_IF(lrowlen,d_2nddim,dSUMCOL);
                  }

                if (rcollen)    /* check statements for right side */
                                /* not yet generated               */
                  {             /*---------------------------------*/

                  GEN_IF(rcollen,d_1stdim,dSUMROW);
                  GEN_IF(rrowlen,d_2nddim,dSUMCOL);
                  }

                *collen = *rowlen = NIL;
                break;

           case d_mult:

                /* Multiplication */
                /*----------------*/

                d_gmatchk(p->left, &lcollen,&lrowlen);
                d_gmatchk(p->right,&rcollen,&rrowlen);

                if (lrowlen && rcollen)      /* 'matrix * matrix' found */
                                             /*-------------------------*/
                  {
                  GEN_IF(lcollen,d_1stdim,dSUMROW);
                  GEN_IF(rrowlen,d_2nddim,dSUMCOL);
                  GEN_IF(lrowlen,rcollen,dPRDMATMAT);
                  }

                else if (lrowlen)            /* 'matrix * scalar' found */
                                             /*-------------------------*/
                  {
                  GEN_IF(lcollen,d_1stdim,dSUMROW);
                  GEN_IF(lrowlen,d_2nddim,dSUMCOL);
                  }

                else                         /* 'scalar * matrix' found */
                                             /*-------------------------*/
                  {
                  GEN_IF(rcollen,d_1stdim,dSUMROW);
                  GEN_IF(rrowlen,d_2nddim,dSUMCOL);
                  }

                *collen = *rowlen = NIL;
                break;

           case d_comma:

                /* Argumentlist of a function with two parameters */
                /*------------------------------------------------*/

                d_gmatchk(p->left, &lcollen,&lrowlen);
                d_gmatchk(p->right,&rcollen,&rrowlen);

                switch (p->father->name.direct)
                {
                  case d_id:

                       /* Arguments of id(.,.), both arguments matrices */
                       /*-----------------------------------------------*/

                       GEN_IF(lrowlen,rcollen,dFCTPRD);

                       *collen = lcollen;
                       *rowlen = rrowlen;
                       break;

                  case d_intval:
                  case d_compl:

                       /* Arguments of intval(.,.) or compl(.,.) */
                       /* with both arguments                    */
                       /*     - matrices or                      */
                       /*     - scalars                          */
                       /*----------------------------------------*/

                       if (lcollen)    /* arguments are matrices */
                                       /*------------------------*/
                         {
                         GEN_IF(lcollen,rcollen,dFCTROW);
                         GEN_IF(lrowlen,rrowlen,dFCTCOL);

                         *collen = bincopy(lcollen);    /* copy necessary    */
                         *rowlen = bincopy(lrowlen);    /* else side-effects */
                         }
                       else            /* arguments are scalars  */
                                       /*------------------------*/

                         *collen = *rowlen = NIL;

                       break;

                  default:;

                       /* This branch should not be accesed */
                       /*-----------------------------------*/
#ifdef CHECK
                       print("'d_gmatchk()'   ->   implement. error");
                       printline();
                       print("    error in a case of a switch (No1)");
                       printline();
                       break;
#endif
                }   /*  switch (p->father ...)  */

                break;

         default:;

                /* This branch should not be accesed */
                /*-----------------------------------*/
#ifdef CHECK
                print("'d_gmatchk()'   ->   implement. error");
                printline();
                print("    error in a case of a switch (No2)");
                printline();
                break;
#endif
         }   /*  switch (p->name.direct)  */
         break;


    case d_function:

         /* Function calls */
         /*----------------*/

         d_gmatchk(p->right,collen,rowlen);

         switch (p->name.direct)
         {
           case d_herm:
           case d_transp:
                help    = *collen;     /* swap of row and column length */
                *collen = *rowlen;     /*-------------------------------*/
                *rowlen = help;
                break;

           default:                    /* no action else */
                break;                 /*----------------*/
         }
         break;


    case d_variable:

         /* Variable operands */
         /*-------------------*/

         if (p->structure == d_matrix)
           {
           *collen = d_glen(p,1);           /* pass length of row and */
           *rowlen = d_glen(p,2);           /* column to the top      */
                                            /*------------------------*/

           SUBST_LEN(*collen,d_1stexpr,d_1stdim);
           SUBST_LEN(*collen,d_2ndexpr,d_2nddim);

           SUBST_LEN(*rowlen,d_1stexpr,d_1stdim);
           SUBST_LEN(*rowlen,d_2ndexpr,d_2nddim);
           }
         else
           *collen = *rowlen = NIL;         /* reset both lengths */
         break;                             /*--------------------*/


    case d_constant:
    case d_nconst  :

         /* Real or interger contants */
         /*---------------------------*/

         *collen = *rowlen = NIL;            /* reset both lengths */
         break;                              /*--------------------*/


    default:;
         /* This branch should not be accesed */
         /*-----------------------------------*/
#ifdef CHECK
         print("'d_gmatchk()'   ->   implement. error");
         printline();
         print("    error in a case of a switch (No3)");
         printline();
         break;
#endif

  }   /*  switch (p->kind)  */

  pos = save_pos;   /* Rebuild global position pointer */

}  /* proc d_matchk */
   /*---------------*/


/*===========================================================================*/

#ifdef LINT_ARGS
binptr d_gmcheck ( tNODE *p )
                                                   /* Generate Matrix Checks */
                                                   /* -        -      -----  */
#else
binptr d_gmcheck ( p )
  tNODE  *p;
#endif

/*-----------------------------------------------------------------------------
 *
 *  The procedure is used
 *
 *     1. to set the values of the reference lengths 'd_1stdim' and 'd_2nddim'
 *     2. to return all check statements if the switch for generating check
 *        statements was set on
 *
 *  We use the recursive procedure 'd_gmatchk()'. Both procedures communicate
 *  by some global variables:
 *
 *        Name      |   Description
 *        ----------|-------------------------------------------------------
 *        d_1stdim  |   A pointer to an integer variable. Its value is used
 *                  |   as reference length for the length of rows of all
 *                  |   summands and is set by 'd_gmcheck()'.
 *                  |   It is declared as extern in "dp_check.h".
 *        d_1stexpr |   A pointer to the integer expression belonging to
 *                  |   the reference variable 'd_1stdim'.
 *                  |   It is declared as static in this module.
 *        d_2nddim  |   A pointer to an integer variable. Its value is used
 *                  |   as reference length for the length of columns of all
 *                  |   summands and is set by 'd_gmcheck()'.
 *                  |   It is declared as extern in "dp_check.h".
 *        d_2nddim  |   A pointer to the integer expression belonging to
 *                  |   the reference variable 'd_2nddim'.
 *                  |   It is declared as static in this module.
 *        if_root   |   A pointer to the root of the if-statements generated
 *                  |   by 'd_gmatchk()'.
 *                  |   It is declared as static in this module.
 *
 *
 *  I/O - Parameters:
 *  -----------------
 *
 *     Name      |   Type      |   I/O   |   Meaning
 *     ----------|-------------|---------|-----------------------------
 *     p         |   tNODE *   |    I    |   Pointer to the root of the
 *               |             |         |   working tree
 *
 *
 *  Called Routines:
 *  ----------------
 *
 *     Name          |   Short description
 *     --------------|-------------------------------------------------
 *     g_gmatchk     |   Generate checks by recursive descending
 *     d_gstment     |   Generate another statement
 *
 *---------------------------------------------------------------------------*/

{  binptr   col, row, stm_root;

#ifdef TRACE_ON
   print("Trace 'd_mcheck()'"); printline();
#endif


   /* func d_gmcheck */
   /*----------------*/
                                                      /* Static variables:   */
   stm_root = if_root = d_1stdim = d_2nddim = NIL;    /*   if_root           */
                                                      /*   d_1stdim          */
                                                      /*   d_2nddim          */

   /* Set reference elements for row and column */
   /*-------------------------------------------*/

   d_1stdim = tempdecl("Nn",integertype);
   d_1stexpr = d_getcollen(p);

   d_2nddim = tempdecl("Nm",integertype);
   d_2ndexpr = d_getrowlen(p);

   d_gstment(&stm_root,d_gassign(bincopy(d_1stdim),d_1stexpr));
   d_gstment(&stm_root,d_gassign(bincopy(d_2nddim),d_2ndexpr));


   /* Generate and return check statements, if necessary */
   /*----------------------------------------------------*/

   if (on_index)
     {
     d_gmatchk(p,&col,&row);
     d_gstment(&stm_root,if_root);
     }

   return(stm_root);

}  /* func d_gmcheck */
   /*----------------*/


/*===========================================================================*/
