/**************************************************************************/
/*                                                                        */
/*                                 Sources                                */
/*                                from  the                               */
/*                           XSC SOFTWARE PACKAGE                         */
/*                                                                        */
/*                Copyright (c) 1997 University of Karlsruhe              */
/*                     Institute for Appl. Mathematics                    */
/*                                                                        */
/* This program is free software for non-commercial use. For details, see */
/* the file LICENSE.XSC, distributed with this software package.          */
/*                                                                        */
/* This program is distributed WITHOUT ANY WARRANTY. For details, see the */
/* file LICENSE.XSC, distributed with this software package.              */
/*                                                                        */
/**************************************************************************/

/* RCS $Id: b_adj.c,v 1.2 1997/09/25 16:55:07 ae59 Exp $ */
/*
$Log: b_adj.c,v $
 * Revision 1.2  1997/09/25  16:55:07  ae59
 * Copyright-message
 *
 * Revision 1.1  1994/01/27  13:20:55  ae59
 * Put under RCS control
 *
 */
/****************************************************************/
/*                                                              */
/*      Filename        : b_adj.c                               */
/*                                                              */
/*      Entries         : a_btyp b_adj(lang,expo)               */
/*                        a_btyp *lang;                         */
/*                        a_intg *expo;                         */
/*                                                              */
/*      Arguments       : lang = result mantissa of length BSIZE*/
/*                        expo = exponent of number             */
/*                                                              */
/*      Function value  : exception code                        */
/*                        OVERFLOW = overflow detected          */
/*                        UNDERFLOW = underflow detected        */
/*                        INEXACT = shifting of last D_U_RATIO  */
/*                                  elements of lang causes     */
/*                                  loss of accuracy            */
/*                                                              */
/*      Description     : Adjust denormalized number and        */
/*                        test for inexact data.                */
/*                                                              */
/*      Notes           : no significant bits for IEEE double   */
/*                        format are lost.                      */
/*                                                              */
/*      Date            : 1991-11-07                            */
/*      1991-11-07 : e_ofof set in case of overflow             */
/*      1991-07-17 : set LSB in case of bits being shifted out  */
/*      1991-05-02 : use status flags                           */
/*      1991-02-13 : E_TPUSH/E_TPOPP                            */
/*                   exponent set to EXPO_MIN if denormalized   */
/*                   changed test for underflow exception       */
/*      1990-07-06 : LINT_ARGS prototype                        */
/*                   unnecessary e_sofo() removed               */
/****************************************************************/

#ifndef ALL_IN_ONE
#ifdef AIX
#include "/u/p88c/runtime/o_defs.h"
#else
#include "o_defs.h"
#endif
#define local
extern a_bool e_efie;
extern a_bool e_efof;
extern a_bool e_efuf;
extern a_bool e_ofie;
extern a_bool e_ofuf;
extern a_bool e_ofof;
#endif

#ifdef LINT_ARGS
local a_btyp b_adj(a_btyp *lang,a_intg *expo)
#else
local a_btyp b_adj(lang,expo)

a_btyp *lang;
a_intg *expo;
#endif
        {
        a_intg i,k;
        a_btyp rc;

        E_TPUSH("b_adj")

        if (*expo>EXPO_MAX)
           {

           /* if overflow trap enabled, adjust exponent         */
           if (e_efof)
              {
              *expo -= EXPO_ADJUST;

              E_TPOPP("b_adj")
              return(OVERFLOW);
              }
           else
              {

              /* set all significant mantissa bits              */
              *lang = HIDDEN_BIT | MANT_HIGH;
              lang[1] = MAX_BASETYPE;
              lang[D_U_RATIO] = MSB;

              *expo = EXPO_MAX;
              e_ofof = TRUE;

              if (e_efie) return(INEXACT);
              e_ofie = TRUE;

              E_TPUSH("b_adj")
              return(NO_ERROR);
              }
           }
        else if (*expo<EXPO_MIN)
           {

           /* bits are lost due to denormalization */
           rc = NO_ERROR;
           for (i=D_U_RATIO;i<BSIZE;i++)
              {
              if (lang[i])
                 {
                 rc = UNDERFLOW;

                 /* if underflow trap enabled, adjust exponent */
                 if (e_efuf)
                    {
                    *expo += EXPO_ADJUST;

                    E_TPOPP("b_adj")
                    return(rc);
                    }

                 e_ofuf = TRUE;
                 break;
                 }
              }

           /* denormalized number will result or zero */
           k = (*expo<EXPO_MIN-MANTL) ? MANTL+1 : EXPO_MIN-*expo;
           b_shru(lang,BSIZE,k);

           if (rc==NO_ERROR)
              {
              for (i=D_U_RATIO;i<BSIZE;i++)
                 {
                 if (lang[i])
                    {
                    rc = UNDERFLOW;

                    /* if underflow trap enabled, adjust exponent */
                    if (e_efuf)
                       {
                       b_shlu(lang,BSIZE,k);
                       *expo += EXPO_ADJUST;

                       E_TPOPP("b_adj")
                       return(rc);
                       }

                    e_ofuf = TRUE;
                    break;
                    }
                 }
              }

           /* set least significant bit for the case that all bits */
           /* have been shifted out in case of detected UNDERFLOW  */
           else
              {
              lang[BSIZE-1] = LSB;
              }

           /* exponent set to minimum exponent */
           *expo = EXPO_MIN;
           }

        E_TPOPP("b_adj")
        return(NO_ERROR);
        }
