Logo Search packages:      
Sourcecode: tendra version File versions  Download package

flpt_fns.c

/*
             Crown Copyright (c) 1997

    This TenDRA(r) Computer Program is subject to Copyright
    owned by the United Kingdom Secretary of State for Defence
    acting through the Defence Evaluation and Research Agency
    (DERA).  It is made available to Recipients with a
    royalty-free licence for its use, reproduction, transfer
    to other parties and amendment for any purpose not excluding
    product development provided that any such use et cetera
    shall be deemed to be acceptance of the following conditions:-

        (1) Its Recipients shall ensure that this Notice is
        reproduced upon any copies or amended versions of it;

        (2) Any amended version of it shall be clearly marked to
        show both the nature of and the organisation responsible
        for the relevant amendment or amendments;

        (3) Its onward transfer from a recipient to another
        party shall be deemed to be that party's acceptance of
        these conditions;

        (4) DERA gives no warranty or assurance as to its
        quality or suitability for any purpose and DERA accepts
        no liability whatsoever in relation to any use to which
        it may be put.
*/


/**********************************************************************
$Author: release $
$Date: 1998/01/17 15:55:47 $
$Revision: 1.1.1.1 $
$Log: flpt_fns.c,v $
 * Revision 1.1.1.1  1998/01/17  15:55:47  release
 * First version to be checked into rolling release.
 *
 * Revision 1.1  1997/11/04  18:23:43  pwe
 * split install_fns with new flpt_fns
 *
***********************************************************************/



  /* This file consists of the floating point and complex operations
     extracted from install_fns.c, to reduce compilation unit sizes
  */

#include "config.h"
#include <ctype.h>
#include <time.h>
#include "common_types.h"
#include "basicread.h"
#include "exp.h"
#include "expmacs.h"
#include "main_reads.h"
#include "tags.h"
#include "flags.h"
#include "me_fns.h"
#include "installglob.h"
#include "readglob.h"
#include "table_fns.h"
#include "flpttypes.h"
#include "flpt.h"
#include "xalloc.h"
#include "shapemacs.h"
#include "read_fns.h"
#include "sortmacs.h"
#include "machine.h"
#include "spec.h"
#include "check_id.h"
#include "check.h"
#include "szs_als.h"
#include "messages_c.h"
#include "natmacs.h"
#include "f64.h"
#include "readglob.h"
#include "case_opt.h"
#include "install_fns.h"
#include "externs.h"


extern shape shcomplexsh;
extern shape complexsh;
extern shape complexdoublesh;
exp_list reorder_list PROTO_S ( ( exp_list, int ) ) ;
exp me_contents PROTO_S ( ( exp ) ) ;
extern int eq_et PROTO_S ( ( error_treatment, error_treatment ) ) ;
extern exp TDFcallaux PROTO_S ( ( error_treatment, exp, char *, shape ) ) ;
extern exp find_named_tg PROTO_S ( ( char *, shape ) ) ;

static exp me_complete_chain PROTO_S ( ( exp, exp, exp ) ) ;
static exp push PROTO_S ( ( exp, exp ) ) ;
static void square_x_iy PROTO_S ( ( error_treatment, exp *, exp *, exp ) ) ;
static void mult_w_by_z PROTO_S ( ( error_treatment, exp *, exp *, exp, exp, exp ) ) ;
static exp make_comp_1_z PROTO_S ( ( floating_variety, error_treatment, exp, exp, exp, exp, exp, exp ) ) ;
static exp f_bin_floating_plus PROTO_S ( ( error_treatment, exp, exp ) ) ;
static exp f_bin_floating_mult PROTO_S ( ( error_treatment, exp, exp ) ) ;
static exp real_power PROTO_S ( ( error_treatment, exp, exp ) ) ;



exp f_change_floating_variety
    PROTO_N ( (flpt_err, r, arg1) )
    PROTO_T ( error_treatment flpt_err X floating_variety r X exp arg1 )
{
  if (name(sh(arg1)) == bothd)
    return arg1;

#if check_shape
  if ( ! ( (is_complex(sh(arg1)) && is_complex(f_floating(r)) ) ||
         (is_float(sh(arg1)) && is_float(f_floating(r)) )
       )
     )
    failer(CHSH_CHFL);
#endif
 if (eq_shape(f_floating(r), sh(arg1)))         /* i.e. does nothing */
    return arg1;  /* Discard the other bits ? */

#if substitute_complex
  if (is_complex(sh(arg1)))
  {
    shape complex_shape = sh(arg1);
    floating_variety real_fv = f_float_of_complex (f_floating(r));

    exp c1 = me_startid (complex_shape, arg1, 0);

    exp obtain1_c1 = me_obtain(c1);       /* contents of arg1 */
    exp obtain2_c1 = me_obtain(c1);

    exp x = f_real_part      (obtain1_c1);            /* re(arg1) */
    exp y = f_imaginary_part (obtain2_c1);            /* im(arg1) */

    exp new_x = f_change_floating_variety (flpt_err, real_fv, x);
    exp new_y = f_change_floating_variety (flpt_err, real_fv, y);

    exp make_comp = f_make_complex (r, new_x, new_y);
    c1 = me_complete_id (c1, make_comp);        /* Does a 'hold_check' */

    return c1;
  };
#endif  /* substitute complex */

#if ishppa
  {
    exp t = me_c1(f_floating(r), flpt_err, arg1, chfl_tag);
    if (!optop(t) && name(sh(t))==doublehd) {
      exp id = me_startid(sh(t),t,0);
      exp tmp = me_complete_id(id,me_obtain(id));
      return tmp;
     }
    else
      return t;
  }
#endif
  return me_c1(f_floating(r), flpt_err, arg1, chfl_tag);
}



exp f_complex_conjugate
    PROTO_N ( (arg1) )
    PROTO_T ( exp arg1 )
{
  if (name(sh(arg1)) == bothd)
    return arg1;
#if check_shape
  if (!is_complex(sh(arg1)))
    failer(CHSH_CONJUGATE);
#endif

#if substitute_complex
  {
    shape complex_shape = sh(arg1);                     /* shape of our complex numbers */
    floating_variety real_fv = f_float_of_complex(complex_shape);
    shape real_shape = f_floating(real_fv);
    floating_variety complex_fv = f_complex_of_float(real_shape);

    exp c1 = me_startid(complex_shape, arg1, 0);

    exp obtain1_c1 = hold_check(me_obtain(c1));                     /* contents of arg1 */
    exp obtain2_c1 = hold_check(me_obtain(c1));

    exp x1 = f_real_part(obtain1_c1);                                       /* re(arg1) */
    exp y1 = f_imaginary_part(obtain2_c1);                                  /* im(arg1) */

    exp neg_im = f_floating_negate(f_impossible, y1);                           /* - im(arg1) */
    exp make_comp = f_make_complex(complex_fv, x1, neg_im);

    c1 = me_complete_id(c1, make_comp);

    return c1;
  }
#else
  return me_u3(sh(arg1), arg1, conj_tag);
#endif
}



exp f_float_int
    PROTO_N ( (flpt_err, f, arg1) )
    PROTO_T ( error_treatment flpt_err X floating_variety f X exp arg1 )
{
  if (name(sh(arg1)) == bothd)
    return arg1;

#if check_shape
  if (!is_integer(sh(arg1)))
    failer(CHSH_FLINT);
#endif

    if (is_complex(f_floating(f))) {
      flpt fzero_copy = new_flpt();
      floating_variety fv = f_float_of_complex(f_floating(f));
      shape real_shape = f_floating(fv);
      exp zero;
      exp res = f_float_int(flpt_err, fv, arg1);
      res = hold_check(res);
      flt_copy (flptnos[fzero_no], &flptnos[fzero_copy]);
      zero = getexp(real_shape, nilexp, 1, nilexp, nilexp, 0,
                  fzero_copy,  real_tag);
      return f_make_complex(f, res, zero);
    }
#if !has64bits
  if ((name(arg1)!=val_tag || flpt_err.err_code > 2)
             && shape_size(sh(arg1))> 32) {
#if use_long_double
      exp z = TDFcallaux(flpt_err, arg1,
            (is_signed(sh(arg1))?"__TDFUs_float":"__TDFUu_float"), doublesh);
      z = hold_check(z);
      if (f != doublefv) {
            z = me_c1(f_floating(f), flpt_err, z, chfl_tag);
      }
      return z;
#else
      exp z = TDFcallaux(flpt_err, arg1,
            (is_signed(sh(arg1))?"__TDFUs_float":"__TDFUu_float"), realsh);
      z = hold_check(z);
      if (f != realfv) {
            z = me_c1(f_floating(f), flpt_err, z, chfl_tag);
      }
      return z;
#endif
    }
#endif
  return me_c1(f_floating(f), flpt_err, arg1, float_tag);
}


exp f_floating_abs
    PROTO_N ( (ov_err, arg1) )
    PROTO_T ( error_treatment ov_err X exp arg1 )
{
  if (name(sh(arg1)) == bothd)
    return arg1;

#if check_shape
  if (!is_float(sh(arg1)))
    failer(CHSH_FLABS);
#endif

#if ishppa
  {
    exp r = me_u1(ov_err, arg1, fabs_tag);
    if (!optop(r) && name(sh(r))==doublehd) {
      exp id = me_startid(sh(r),r,0);
      exp tmp = me_complete_id(id,me_obtain(id));
      return tmp;
     }
    else
      return r;
  }
#endif
  return me_u1(ov_err, arg1, fabs_tag);
}


exp f_floating_div
    PROTO_N ( (ov_err, arg1, arg2) )
    PROTO_T ( error_treatment ov_err X exp arg1 X exp arg2 )
{
  if (name(sh(arg1)) == bothd)
    { kill_exp(arg2,arg2); return arg1; }
  if (name(sh(arg2)) == bothd)
    { kill_exp(arg1,arg1); return arg2; }

#if check_shape
  if (! ((is_float(sh(arg1)) || is_complex(sh(arg1))) && eq_shape(sh(arg1), sh(arg2))) )
    failer(CHSH_FLDIV);
#endif

/* PAB changes - 21 October 1994 */
#if substitute_complex
  if (is_complex(sh(arg1))) {

      shape complex_shape = sh(arg1);                     /* shape of our complex numbers */
      floating_variety real_fv = f_float_of_complex(complex_shape);
      shape real_shape = f_floating(real_fv);
      floating_variety complex_fv = f_complex_of_float(real_shape);

      exp z1 = me_startid(complex_shape, arg1, 0);
      exp z2 = me_startid(complex_shape, arg2, 0);

      exp obtain1_z1 = hold_check(me_obtain(z1));                     /* contents of arg1 */
      exp obtain2_z1 = hold_check(me_obtain(z1));
      exp obtain1_z2 = hold_check(me_obtain(z2));                     /* contents of arg2 */
      exp obtain2_z2 = hold_check(me_obtain(z2));

      exp z1_re = f_real_part(obtain1_z1);                           /* re(arg1) */
      exp z2_re = f_real_part(obtain1_z2);                           /* re(arg2) */
      exp z1_im = f_imaginary_part(obtain2_z1);                      /* im(arg1) */
      exp z2_im = f_imaginary_part(obtain2_z2);                      /* im(arg2) */

      exp x1 = me_startid(real_shape, z1_re, 0);
      exp x2 = me_startid(real_shape, z2_re, 0);
      exp y1 = me_startid(real_shape, z1_im, 0);
      exp y2 = me_startid(real_shape, z2_im, 0);

      exp obtain1_x1 = hold_check(me_obtain(x1));                     /* x1 is used twice */
      exp obtain2_x1 = hold_check(me_obtain(x1));
      exp obtain1_y1 = hold_check(me_obtain(y1));                     /* y1 is used twice */
      exp obtain2_y1 = hold_check(me_obtain(y1));

      exp obtain1_x2 = hold_check(me_obtain(x2));                /* x2 is used four times */
      exp obtain2_x2 = hold_check(me_obtain(x2));
      exp obtain3_x2 = hold_check(me_obtain(x2));
      exp obtain4_x2 = hold_check(me_obtain(x2));
      exp obtain1_y2 = hold_check(me_obtain(y2));                /* y2 is used four times */
      exp obtain2_y2 = hold_check(me_obtain(y2));
      exp obtain3_y2 = hold_check(me_obtain(y2));
      exp obtain4_y2 = hold_check(me_obtain(y2));

      exp mult_x2_x2 = f_bin_floating_mult(ov_err, obtain1_x2, obtain2_x2);
      exp mult_y2_y2 = f_bin_floating_mult(ov_err, obtain1_y2, obtain2_y2);
      exp mult_x1_x2 = f_bin_floating_mult(ov_err, obtain1_x1, obtain3_x2);
      exp mult_y1_y2 = f_bin_floating_mult(ov_err, obtain1_y1, obtain3_y2);
      exp mult_y1_x2 = f_bin_floating_mult(ov_err, obtain2_y1, obtain4_x2);
      exp mult_x1_y2 = f_bin_floating_mult(ov_err, obtain2_x1, obtain4_y2);

      exp plus1  = f_bin_floating_plus(ov_err, mult_x2_x2, mult_y2_y2);
      exp plus2  = f_bin_floating_plus(ov_err, mult_x1_x2, mult_y1_y2);
      exp minus1 = f_floating_minus(ov_err, mult_y1_x2, mult_x1_y2);

      exp denom = me_startid(real_shape, plus1, 0);

      exp obtain_denom1 = hold_check(me_obtain(denom));
      exp obtain_denom2 = hold_check(me_obtain(denom));

      exp answer_re = f_floating_div(ov_err, plus2,  obtain_denom1);
      exp answer_im = f_floating_div(ov_err, minus1, obtain_denom2);
      exp make_comp = f_make_complex(complex_fv, answer_re, answer_im);

      denom = me_complete_id(denom, make_comp);
      y2 = me_complete_id(y2, denom);
      y1 = me_complete_id(y1, y2);
      x2 = me_complete_id(x2, y1);
      x1 = me_complete_id(x1, x2);
      z2 = me_complete_id(z2, x1);
      z1 = me_complete_id(z1, z2);

      return z1;
  };
#endif
#if ishppa
  {
    exp r = hold_check(me_b1(ov_err, arg1, arg2, fdiv_tag));
    if (!optop(r) && name(sh(r))==doublehd) {
      exp id = me_startid(sh(r),r,0);
      exp tmp = me_complete_id(id,me_obtain(id));
      return tmp;
     }
    else
      return r;
  }
#endif
  return  hold_check(me_b1(ov_err, arg1, arg2, fdiv_tag));
}


exp f_floating_maximum
    PROTO_N ( (flpt_err, arg1, arg2) )
    PROTO_T ( error_treatment flpt_err X exp arg1 X exp arg2 )
{
  if (name(sh(arg1)) == bothd)
    { kill_exp(arg2,arg2); return arg1; }
  if (name(sh(arg2)) == bothd)
    { kill_exp(arg1,arg1); return arg2; }

#if check_shape
  if (!is_float(sh(arg1)) || !eq_shape(sh(arg1), sh(arg2)))
    failer(CHSH_FLMAX);
#endif
  return  hold_check(me_b1(flpt_err, arg1, arg2, fmax_tag));
}


exp f_floating_minimum
    PROTO_N ( (flpt_err, arg1, arg2) )
    PROTO_T ( error_treatment flpt_err X exp arg1 X exp arg2 )
{
  if (name(sh(arg1)) == bothd)
    { kill_exp(arg2,arg2); return arg1; }
  if (name(sh(arg2)) == bothd)
    { kill_exp(arg1,arg1); return arg2; }


#if check_shape
  if (!is_float(sh(arg1)) || !eq_shape(sh(arg1), sh(arg2)))
    failer(CHSH_FLMIN);
#endif
  return  hold_check(me_b1(flpt_err, arg1, arg2, fmin_tag));
}




/****************************************************************/
/*  The following code needs to generate labels for use with    */
/*  'cond_tag'.  This is currently implemented using the        */
/*  knowledge that a label can be obtained by taking a pointer  */
/*  to an EXP - a hack which was introduced because of the      */
/*  need to use 'f_integer_test' with 64-bit integers.  This    */
/*  hack is performed exclusively by the MACRO 'make_label'     */
/****************************************************************/

#define make_label(EXP) &EXP


/************************************************/
/*  'is_constant_arg' checks to see if E1 is    */
/*   a constant that will fit into type 'int'.  */
/************************************************/

#define is_constant_arg(E1) \
      ((name(E1) == val_tag) && !isbigval(E1) && \
      (is_signed(sh(E1)) || (no(E1) >> 31 == 0)))



exp f_floating_power
    PROTO_N ( (ov_err, arg1, arg2) )
    PROTO_T ( error_treatment ov_err X exp arg1 X exp arg2 )
{
  if (name(sh(arg1)) == bothd)
    { kill_exp(arg2,arg2); return arg1; }
  if (name(sh(arg2)) == bothd)
    { kill_exp(arg1,arg1); return arg2; }

#if check_shape
  if (!( (is_float(sh(arg1)) || is_complex(sh(arg1))) && is_integer(sh(arg2)) ))
    failer(CHSH_FLPOWER);
#endif

/* PAB changes - 31 October 1994 */

  /* Gives shorter .s file if n<10 and arg1 is unknown */

  if (is_complex(sh(arg1))) {

      shape integer_shape = sh(arg2);
      shape complex_shape = sh(arg1);                     /* shape of our complex numbers */
      floating_variety real_fv = f_float_of_complex(complex_shape);
      shape real_shape = f_floating(real_fv);
      floating_variety complex_fv = f_complex_of_float(real_shape);

      exp sn = me_startid(integer_shape, arg2, 0);

      if (is_constant_arg(arg2) ||
      ((name(arg2) == name_tag) && (name(son(arg2)) == ident_tag)
         && !isvar(son(arg2)) && is_constant_arg(son(son(arg2)))))
      {                                                              /* we know the power */
        int n;
        int exponent;
        exp z = push (sn, me_startid(complex_shape, arg1, 0));

        if (is_constant_arg(arg2)) {
            exponent = no(arg2);    /* arg2 is a constant */
        }
        else {
            exponent = no(son(son(arg2)));
              /* arg2 identifies a constant */
        }

        n = abs(exponent);
        if (n == 0) {

            exp  answer_re, answer_im, make_comp;

            flpt fzero_copy = new_flpt();
            flpt fone_copy  = new_flpt();

            flt_copy (flptnos[fzero_no], &flptnos[fzero_copy]);
            flt_copy (flptnos[fone_no],  &flptnos[fone_copy]);

            answer_re = getexp(real_shape, nilexp, 1, nilexp, nilexp, 0, fone_copy,  real_tag);
            answer_im = getexp(real_shape, nilexp, 1, nilexp, nilexp, 0, fzero_copy, real_tag);

            make_comp = f_make_complex(complex_fv, answer_re, answer_im);
            return  me_complete_chain(z, arg2, make_comp);

        } else {

            exp link_next;

            exp z_re = f_real_part     (me_obtain(z));
            exp z_im = f_imaginary_part(me_obtain(z));

            exp x = push (z, me_startid(real_shape, z_re, 0));
            exp y = push (x, me_startid(real_shape, z_im, 0));

            exp u, v, mylast;;

            while ((n % 2) == 0) {
              mylast = y;
              square_x_iy(ov_err, &x, &y, mylast);
              n = n / 2;
            }

            if (n == 1) {                                                   /* return z */

              if (exponent < 0) {
                  link_next = make_comp_1_z(complex_fv, ov_err,
                                    me_obtain(x), me_obtain(x), me_obtain(x),
                                    me_obtain(y), me_obtain(y), me_obtain(y));
              } else {
                  link_next = f_make_complex(complex_fv, me_obtain(x), me_obtain(y));
              }

              return me_complete_chain(y, arg2, link_next);             /*  return z  */

            } else {                                                   /*  w = z  */

              u = push (y, me_startid(real_shape, me_obtain(x), 0));
              v = push (u, me_startid(real_shape, me_obtain(y), 0));
              mylast = v;
            }

            while (n != 1) {
              square_x_iy(ov_err, &x, &y, mylast);                         /*  z = z*z  */
              mylast = y;
              n = n / 2;
              if ((n % 2) == 1) {
                  mult_w_by_z (ov_err, &u, &v, x, y, mylast);              /*  w = w*z  */
                  mylast = v;
              }
            }

            if (exponent < 0) {
              link_next = make_comp_1_z(complex_fv, ov_err,
                                  me_obtain(u), me_obtain(u), me_obtain(u),
                                  me_obtain(v), me_obtain(v), me_obtain(v));
            } else {
              link_next = f_make_complex(complex_fv, me_obtain(u), me_obtain(v));
            }
            return me_complete_chain(v, arg2, link_next);                /*  return w  */
        }

      } else {

        exp  reinitialise_w, main_loop, make_comp;              /* main building blocks */
        exp  square_z, mult_z_w, half_n, update_w, repeat_body;
        exp  seq, seq_zero, make_comp1, make_comp2;
        exp  real0, real1, x, y, u, v;

        exp z  = me_startid(complex_shape, arg1, 0);

        exp abs_val_sn = f_abs(ov_err, me_obtain(sn));
        exp n = me_startid(sh(sn), abs_val_sn, 1);

        exp z_re = f_real_part     (me_obtain(z));
        exp z_im = f_imaginary_part(me_obtain(z));

        flpt fzero_copy = new_flpt();
        flpt fone_copy  = new_flpt();

        flt_copy (flptnos[fzero_no], &flptnos[fzero_copy]);
        flt_copy (flptnos[fone_no],  &flptnos[fone_copy]);

        real0 = getexp(real_shape, nilexp, 1, nilexp, nilexp, 0, fzero_copy, real_tag);
        real1 = getexp(real_shape, nilexp, 1, nilexp, nilexp, 0, fone_copy,  real_tag);

        x = me_startid(real_shape, z_re, 1);                                /* re(arg1) */
        y = me_startid(real_shape, z_im, 1);                                /* re(arg2) */

        u = me_startid(real_shape, real1, 1);                            /* re(w) = 1.0 */
        v = me_startid(real_shape, real0, 1);                            /* im(w) = 0.0 */


        /*  change value of w to z if n is odd  */

        {
            exp constant1  = me_shint(integer_shape, 1);
            exp constant2  = me_shint(integer_shape, 2);

            exp rem_n_2    = f_rem0 (f_impossible, f_impossible,
                               me_contents(n), constant2);

            exp assign_u = hold_check(me_b3(f_top, me_obtain(u), me_contents(x), ass_tag));
            exp assign_v = hold_check(me_b3(f_top, me_obtain(v), me_contents(y), ass_tag));

            exp top_cell  = me_l1(f_top, top_tag);
            exp alt_labst = hold_check(me_b3(sh(top_cell), me_null(f_top,0,clear_tag),
                                     top_cell, labst_tag));

            exp is_n_odd = f_integer_test (no_nat_option, f_equal,
                                   make_label(alt_labst), rem_n_2, constant1);

            exp seq_zero = hold_check(me_b2(is_n_odd, assign_u, 0));
            exp seq = hold_check(me_b3(sh(assign_v), seq_zero, assign_v, seq_tag));

            reinitialise_w = hold_check(me_b3(lub_shape(sh(seq),sh(alt_labst)),
                                    seq, alt_labst, cond_tag));
        }


        /*  z=z*z  */

        {
            exp minus_x_y = f_floating_minus(ov_err, me_contents(x), me_contents(y));
            exp  plus_x_y = f_bin_floating_plus(ov_err, me_contents(x), me_contents(y));
            exp  mult_x_y = f_bin_floating_mult(ov_err, me_contents(x), me_contents(y));

            exp tmp = me_startid(real_shape, mult_x_y, 0);

            exp answer_re  = f_bin_floating_mult(ov_err, minus_x_y, plus_x_y);
            exp answer_im  = f_bin_floating_plus(ov_err, me_obtain(tmp), me_obtain(tmp));

            exp assign_x = hold_check(me_b3(f_top, me_obtain(x), answer_re, ass_tag));
            exp assign_y = hold_check(me_b3(f_top, me_obtain(y), answer_im, ass_tag));

            exp seq_zero = hold_check(me_u2(assign_x, 0));
            exp seq      = hold_check(me_b3(sh(assign_y), seq_zero, assign_y, seq_tag));

            square_z = me_complete_id(tmp, seq);
        }


        /*  w=z*w  */

        {
            exp mult_x_u = f_bin_floating_mult(ov_err, me_contents(x), me_contents(u));
            exp mult_x_v = f_bin_floating_mult(ov_err, me_contents(x), me_contents(v));
            exp mult_y_u = f_bin_floating_mult(ov_err, me_contents(y), me_contents(u));
            exp mult_y_v = f_bin_floating_mult(ov_err, me_contents(y), me_contents(v));

            exp tmp = me_startid(real_shape, mult_y_u, 0);

            exp answer_re  = f_floating_minus(ov_err, mult_x_u, mult_y_v);
            exp answer_im  = f_bin_floating_plus(ov_err, mult_x_v, me_obtain(tmp));

            exp assign_u = hold_check(me_b3(f_top, me_obtain(u), answer_re, ass_tag));
            exp assign_v = hold_check(me_b3(f_top, me_obtain(v), answer_im, ass_tag));

            exp seq_zero = hold_check(me_u2(assign_u, 0));
            exp seq      = hold_check(me_b3(sh(assign_v), seq_zero, assign_v, seq_tag));

            mult_z_w = me_complete_id(tmp, seq);
        }


        /*  n=n/2  */

        {
            exp constant2  = me_shint(integer_shape, 2);

            exp answer = f_div0 (f_impossible, f_impossible,
                           me_contents(n), constant2);
            half_n = hold_check(me_b3(f_top, me_obtain(n), answer, ass_tag));
        }


        /*  if n is odd then w = z*w  */

        {
            exp constant1  = me_shint(integer_shape, 1);
            exp constant2  = me_shint(integer_shape, 2);

            exp rem_n_2    = f_rem0 (f_impossible, f_impossible,
                               me_contents(n), constant2);

            exp top_cell  = me_l1(f_top, top_tag);
            exp alt_labst = hold_check(me_b3(f_top, me_null(f_top,0,clear_tag),
                                     top_cell, labst_tag));

            exp is_n_odd = f_integer_test (no_nat_option, f_equal,
                                   make_label(alt_labst), rem_n_2, constant1);
            exp seq_zero = hold_check(me_u2(is_n_odd, 0));
            exp seq = hold_check(me_b3(sh(mult_z_w), seq_zero, mult_z_w, seq_tag));

            update_w = hold_check(me_b3(lub_shape(sh(seq),sh(alt_labst)),
                                seq, alt_labst, cond_tag));
        }


        /*  repeat + body  */

        {
            exp if_n_equals_1, seq_zero, seq, body_labst;

            exp constant1  = me_shint(integer_shape, 1);
            exp top_cell   = me_l1(f_top, top_tag);

            body_labst = hold_check(me_b3(sh(top_cell), me_null(f_top,0,clear_tag),
                                            top_cell, labst_tag));

            if_n_equals_1 = f_integer_test (no_nat_option, f_equal, make_label(body_labst),
                                    me_contents(n), constant1);

            seq_zero = me_b2(square_z, update_w, 0);
            setbro (square_z, half_n);                   /*  insert half_n between   */
            setbro (half_n, update_w);                   /*  square_x and update_w   */
            clearlast (half_n);
            seq_zero = hold_check(seq_zero);

            seq = hold_check(me_b3(sh(if_n_equals_1), seq_zero, if_n_equals_1, seq_tag));

            setbro(son(body_labst), seq);
            clearlast(son(body_labst));
            setfather(body_labst, seq);

            repeat_body = hold_check(me_b3(sh(seq), top_cell, body_labst, rep_tag));
            note_repeat(repeat_body);
        }


        /*  make loop - only done if  mod(n) > 1  */

        {
            exp constant1  = me_shint(integer_shape, 1);

            exp top_cell  = me_l1(f_top, top_tag);
            exp alt_labst = hold_check(me_b3(f_top, me_null(f_top,0,clear_tag),
                                     top_cell, labst_tag));

            exp is_n_gt_1 = f_integer_test (no_nat_option, f_greater_than,
                                    make_label(alt_labst), me_contents(n), constant1);

            exp seq_zero = hold_check(me_u2(is_n_gt_1, 0));
            exp seq = hold_check(me_b3(sh(repeat_body), seq_zero, repeat_body, seq_tag));

            main_loop = hold_check(me_b3(lub_shape(sh(seq),sh(alt_labst)),
                                 seq, alt_labst, cond_tag));
        }

        make_comp1 = f_make_complex(complex_fv, me_contents(u), me_contents(v));
        make_comp2 = make_comp_1_z(complex_fv, ov_err,
                                     me_contents(u), me_contents(u), me_contents(u),
                                     me_contents(v), me_contents(v), me_contents(v));


        /* if arg2 is negative then make_comp2 else make_comp1 */

        {
            exp constant0 = me_shint(integer_shape, 0);

            exp alt_labst = hold_check(me_b3(sh(make_comp1),
                                     me_null(f_top,0,clear_tag),
                                     make_comp1, labst_tag));

            exp is_arg2_negative = f_integer_test (no_nat_option, f_less_than,
                                         make_label(alt_labst),
                                         me_obtain(sn), constant0);

            exp seq_zero = hold_check(me_u2(is_arg2_negative, 0));
            exp seq = hold_check(me_b3(sh(make_comp2), seq_zero, make_comp2, seq_tag));

            make_comp = hold_check(me_b3(lub_shape(sh(seq),sh(alt_labst)),
                                 seq, alt_labst, cond_tag));
        }

      seq_zero = hold_check(me_b2(reinitialise_w, main_loop, 0));
      seq      = hold_check(me_b3(sh(make_comp), seq_zero, make_comp, seq_tag));


      v  = me_complete_id(v, seq);
      u  = me_complete_id(u, v);
      y  = me_complete_id(y, u);
      x  = me_complete_id(x, y);
      n  = me_complete_id(n, x);
      sn = me_complete_id(sn, n);
      z  = me_complete_id(z, sn);

      return z;
      }
  }

  return  real_power(ov_err, arg1, arg2);
}


exp f_floating_minus
    PROTO_N ( (ov_err, arg1, arg2) )
    PROTO_T ( error_treatment ov_err X exp arg1 X exp arg2 )
{
  if (name(sh(arg1)) == bothd)
    { kill_exp(arg2,arg2); return arg1; }
  if (name(sh(arg2)) == bothd)
    { kill_exp(arg1,arg1); return arg2; }

#if check_shape
  if (! ((is_float(sh(arg1)) || is_complex(sh(arg1))) && eq_shape(sh(arg1), sh(arg2))) )
    failer(CHSH_FLMINUS);
#endif

/* PAB changes - 18 October 1994 */
#if substitute_complex
  if (is_complex(sh(arg1))) {

      shape complex_shape = sh(arg1);                     /* shape of our complex numbers */
      floating_variety real_fv = f_float_of_complex(complex_shape);
      shape real_shape = f_floating(real_fv);
      floating_variety complex_fv = f_complex_of_float(real_shape);

      exp z1 = me_startid(complex_shape, arg1, 0);
      exp z2 = me_startid(complex_shape, arg2, 0);

      exp x1 = f_real_part     (me_obtain(z1));                      /* re(arg1) */
      exp x2 = f_real_part     (me_obtain(z2));                      /* re(arg2) */
      exp y1 = f_imaginary_part(me_obtain(z1));                      /* im(arg1) */
      exp y2 = f_imaginary_part(me_obtain(z2));                      /* im(arg2) */

      exp minus_re  = f_floating_minus(ov_err, x1, x2);
      exp minus_im  = f_floating_minus(ov_err, y1, y2);
      exp make_comp = f_make_complex(complex_fv, minus_re, minus_im);

      z2 = me_complete_id(z2, make_comp);
      z1 = me_complete_id(z1, z2);

      return z1;
  };
#endif
#if ishppa
  {
    exp r = hold_check(me_b1(ov_err, arg1, arg2, fminus_tag));
    if (!optop(r) && name(sh(r))==doublehd) {
      exp id = me_startid(sh(r),r,0);
      exp tmp = me_complete_id(id,me_obtain(id));
      return tmp;
     }
    else
      return r;
  }
#endif
  return  hold_check(me_b1(ov_err, arg1, arg2, fminus_tag));
}


exp f_floating_mult
    PROTO_N ( (ov_err, arg1) )
    PROTO_T ( error_treatment ov_err X exp_list arg1 )
{
  exp first = arg1.start;
  exp r = getexp (sh(first), nilexp, 0, first,
                  nilexp,
                  0, 0, fmult_tag);
  if (name(sh(first)) == bothd || arg1.number == 1)
    return first;
  clear_exp_list(arg1);
  seterrhandle(r, ov_err.err_code);
  if (isov(r))
   setjmp_dest(r, get_lab(ov_err.jmp_dest));

#if check_shape
  {exp t = first;
   while (1)
     {
       if (! ((is_float(sh(t)) || is_complex(sh(t))) && eq_shape(sh(t), sh(first))) )
         failer(CHSH_FLMULT);
       if (t == arg1.end)
         break;
       t = bro(t);
       if (name(sh(t)) == bothd)
         return t;
     };
  };
#endif

/* PAB changes - 19 October 1994 */
#if substitute_complex
  if (is_complex(sh(arg1.start))) {

      shape complex_shape = sh(arg1.start);            /* shape of our complex numbers */
      floating_variety real_fv = f_float_of_complex(complex_shape);
      shape real_shape = f_floating(real_fv);
      floating_variety complex_fv = f_complex_of_float(real_shape);

      exp  x1, y1, x2, y2, z1, z1_re, z1_im, t, link_next, prod_re, prod_im;

#if 0
      arg1 = reorder_list(arg1, 1);              /* reorder so constants are at the front */
#endif

      z1 = me_startid(complex_shape, arg1.start, 0);

      z1_re = f_real_part     (me_obtain(z1));                 /* re(arg1.first) */
      z1_im = f_imaginary_part(me_obtain(z1));                 /* im(arg1.first) */

      x1 = push(z1, me_startid(real_shape, z1_re, 0));
      y1 = push(x1, me_startid(real_shape, z1_im, 0));

      t = arg1.start;

      while (t != arg1.end) {

        t = bro(t);
        z1 = push(y1, me_startid(complex_shape, t, 0));

        z1_re = f_real_part     (me_obtain(z1));    /* contents of next */
        z1_im = f_imaginary_part(me_obtain(z1));    /* list element     */

        x2 = push(z1, me_startid(real_shape, z1_re, 0));
        y2 = push(x2, me_startid(real_shape, z1_im, 0));

        if (eq_exp(x1,x2) && eq_exp(y1,y2)) {

            exp minus_x1_x2 = f_floating_minus(ov_err, me_obtain(x1), me_obtain(x2));
            exp  plus_x1_x2 = f_bin_floating_plus(ov_err, me_obtain(x1), me_obtain(x2));
            exp  mult_x1_y1 = f_bin_floating_mult(ov_err, me_obtain(x1), me_obtain(y1));

            prod_re = f_bin_floating_mult(ov_err, minus_x1_x2, plus_x1_x2);
            prod_im = f_bin_floating_plus(ov_err,  mult_x1_y1, mult_x1_y1);
        }

        else

        {
            exp mult_x1_x2 = f_bin_floating_mult(ov_err, me_obtain(x1), me_obtain(x2));
            exp mult_y1_y2 = f_bin_floating_mult(ov_err, me_obtain(y1), me_obtain(y2));
            exp mult_x1_y2 = f_bin_floating_mult(ov_err, me_obtain(x1), me_obtain(y2));
            exp mult_x2_y1 = f_bin_floating_mult(ov_err, me_obtain(x2), me_obtain(y1));

            prod_re = f_floating_minus(ov_err, mult_x1_x2, mult_y1_y2);
            prod_im = f_bin_floating_plus(ov_err, mult_x1_y2, mult_x2_y1);
        }

        x1 = push(y2, me_startid(real_shape, prod_re, 0));
        y1 = push(x1, me_startid(real_shape, prod_im, 0));
      }

      link_next = f_make_complex(complex_fv, me_obtain(x1), me_obtain(y1));

      return  me_complete_chain(y1, arg1.start, link_next);
  }
#endif
  setfather (r, arg1.end);
#if ishppa
  if (!optop(r) && name(sh(r))==doublehd) {
    exp id = me_startid(sh(r),r,0);
    exp tmp = me_complete_id(id,me_obtain(id));
    return tmp;
   }
  else
#endif
  return r;
}


exp f_floating_negate
    PROTO_N ( (ov_err, arg1) )
    PROTO_T ( error_treatment ov_err X exp arg1 )
{
  if (name(sh(arg1)) == bothd)
    return arg1;

#if check_shape
  if (!is_float(sh(arg1)) && !is_complex(sh(arg1)))
    failer(CHSH_FLNEGATE);
#endif

/* PAB changes - 18 October 1994 */
#if substitute_complex
  if (is_complex(sh(arg1))) {

      shape complex_shape = sh(arg1);                     /* shape of our complex numbers */
      floating_variety real_fv = f_float_of_complex(complex_shape);
      shape real_shape = f_floating(real_fv);
      floating_variety complex_fv = f_complex_of_float(real_shape);

      exp c1 = me_startid(complex_shape, arg1, 0);

      exp obtain1_c1 = hold_check(me_obtain(c1));                     /* contents of arg1 */
      exp obtain2_c1 = hold_check(me_obtain(c1));

      exp x1 = f_real_part(obtain1_c1);                              /* re(arg1) */
      exp y1 = f_imaginary_part(obtain2_c1);                         /* im(arg1) */

      exp neg_re = f_floating_negate(ov_err, x1);                           /* - re(arg1) */
      exp neg_im = f_floating_negate(ov_err, y1);                           /* - im(arg1) */
      exp make_comp = f_make_complex(complex_fv, neg_re, neg_im);

      c1 = me_complete_id(c1, make_comp);

      return c1;
  };
#endif
#if ishppa
  {
    exp r = hold_check(me_u1(ov_err, arg1, fneg_tag));
    if (!optop(r) && name(sh(r))==doublehd) {
      exp id = me_startid(sh(r),r,0);
      exp tmp = me_complete_id(id,me_obtain(id));
      return tmp;
     }
    else
      return r;
  }
#endif
  return  hold_check(me_u1(ov_err, arg1, fneg_tag));
}


exp f_floating_plus
    PROTO_N ( (ov_err, arg1) )
    PROTO_T ( error_treatment ov_err X exp_list arg1 )
{
  exp first = arg1.start;
  exp r = getexp (sh(first), nilexp, 0, first,
                  nilexp, 0, 0, fplus_tag);
  if (name(sh(first)) == bothd || arg1.number == 1)
    return first;
  clear_exp_list(arg1);
  seterrhandle(r, ov_err.err_code);
  if (isov(r))
    setjmp_dest(r, get_lab(ov_err.jmp_dest));

#if check_shape
  {exp t = first;
   while (1)
     {
       if (! ((is_float(sh(t)) || is_complex(sh(t))) && eq_shape(sh(t), sh(first))) )
         failer(CHSH_FLPLUS);
       if (t == arg1.end)
         break;
       t = bro(t);
       if (name(sh(t)) == bothd)
         return t;
     };
  };
#endif

/* PAB changes - 18 October 1994 */
#if substitute_complex
  if (is_complex(sh(arg1.start))) {

      exp z1, z2, x1, y1, x2, y2, make_comp, t;

      shape complex_shape = sh(arg1.start);               /* shape of our complex numbers */
      floating_variety real_fv = f_float_of_complex(complex_shape);
      shape real_shape = f_floating(real_fv);
      floating_variety complex_fv = f_complex_of_float(real_shape);

#if 0
      arg1 = reorder_list(arg1, 1);              /* reorder so constants are at the front */
#endif

      z1 = me_startid(complex_shape, arg1.start, 0);

      x1 = f_real_part     (me_obtain(z1));                    /* re(arg1.first) */
      y1 = f_imaginary_part(me_obtain(z1));                    /* im(arg1.first) */

      t=arg1.start;
      z2 = z1;                                                   /* start chain of idents */

      while (t != arg1.end) {

        t = bro(t);
        z2 = push(z2, me_startid(complex_shape, t, 0));

        x2 = f_real_part     (me_obtain(z2));              /* contents of next */
        y2 = f_imaginary_part(me_obtain(z2));              /*   list element   */

        x1 = f_bin_floating_plus(ov_err, x1, x2);                    /* pass it this on */
        y1 = f_bin_floating_plus(ov_err, y1, y2);                    /*  as new result  */
      }

      make_comp = f_make_complex(complex_fv, x1, y1);

      return me_complete_chain(z2, arg1.start, make_comp);
  }
#endif
  setfather (r, arg1.end);
#if ishppa
  if (!optop(r) && name(sh(r))==doublehd) {
    exp id = me_startid(sh(r),r,0);
    exp tmp = me_complete_id(id,me_obtain(id));
    return tmp;
   }
  else
#endif
  return r;
}


exp f_floating_test
    PROTO_N ( (prob, flpt_err, nt, dest, arg1, arg2) )
    PROTO_T ( nat_option prob X error_treatment flpt_err X ntest nt X label dest X exp arg1 X exp arg2 )
{
  if (name(sh(arg1)) == bothd)
    { kill_exp(arg2,arg2); return arg1; }
  if (name(sh(arg2)) == bothd)
    { kill_exp(arg1,arg1); return arg2; }

#if check_shape
  if (! ((is_float(sh(arg1)) || is_complex(sh(arg1))) && eq_shape(sh(arg1), sh(arg2))) )
    failer(CHSH_FLTEST);
#endif

/* PAB changes - 18 October 1994 */
#if substitute_complex
  if (is_complex(sh(arg1))) {                               /* is arg1 a complex number ? */

      shape complex_shape = sh(arg1);                     /* shape of our complex numbers */
      exp z1 = me_startid(complex_shape, arg1, 0);
      exp z2 = me_startid(complex_shape, arg2, 0);

      exp obtain1_z1 = hold_check(me_obtain(z1));                     /* contents of arg1 */
      exp obtain2_z1 = hold_check(me_obtain(z1));
      exp obtain1_z2 = hold_check(me_obtain(z2));                     /* contents of arg2 */
      exp obtain2_z2 = hold_check(me_obtain(z2));

      exp x1 = f_real_part     (obtain1_z1);                         /* re(arg1) */
      exp x2 = f_real_part     (obtain1_z2);                         /* re(arg2) */
      exp y1 = f_imaginary_part(obtain2_z1);                         /* im(arg1) */
      exp y2 = f_imaginary_part(obtain2_z2);                         /* im(arg2) */

#if check_shape
      if ((nt != f_equal) && (nt != f_not_equal))
        failer(CHSH_FLTEST);
#endif

      if (nt == f_equal) {                                       /* equality of z1 and z2 */

        exp test1 = f_floating_test (prob, flpt_err, f_equal, dest, x1, x2);
        exp test2 = f_floating_test (prob, flpt_err, f_equal, dest, y1, y2);

        exp seq_zero = hold_check(me_u2(test1, 0));
        exp seq      = hold_check(me_b3(sh(test2), seq_zero, test2, seq_tag));
        z2           = me_complete_id(z2, seq);

      } else {                                                 /* inequality of z1 and z2 */

        exp seq, conditional;

        exp top_cell = me_l1(f_top, top_tag);
        exp alt_labst = hold_check(me_b3(f_top, me_null(f_top,0,clear_tag),
                                                          top_cell, labst_tag));

        exp test1 = f_floating_test (prob, flpt_err, f_equal,
                               make_label(alt_labst), x1, x2);
        exp test2 = f_floating_test (prob, flpt_err, f_not_equal,
                               dest, y1, y2);
              exp seq_zero = hold_check(me_b2(test1, test2, 0));

        seq = hold_check(me_b3(f_bottom, seq_zero, f_make_top(), seq_tag));

        conditional = hold_check(me_b3(f_top,
                               seq, alt_labst, cond_tag));

        z2 = me_complete_id(z2, conditional);
      }
      z1 = me_complete_id(z1, z2);

      return z1;
  }
#endif
  return me_q2(prob, flpt_err, nt, dest, arg1, arg2, test_tag);
}



exp f_imaginary_part
    PROTO_N ( (arg1) )
    PROTO_T ( exp arg1 )
{
  shape real_shape;

  if (name(sh(arg1)) == bothd)
    return arg1;
#if check_shape
  if (!is_complex(sh(arg1)))
    failer(CHSH_IMAG);
#endif

/* PAB changes - 25 May 1995 */
  real_shape = f_floating(f_float_of_complex(sh(arg1)));
#if substitute_complex
  {
    exp t = me_u3(real_shape, arg1, field_tag);
    no(t) = shape_size(real_shape);
    return hold_check(t);
  }
#else
  return me_u3(real_shape, arg1, imag_tag);
#endif
}


exp f_real_part
    PROTO_N ( (arg1) )
    PROTO_T ( exp arg1 )
{
  shape real_shape;

  if (name(sh(arg1)) == bothd)
    return arg1;
#if check_shape
  if (!is_complex(sh(arg1)))
    failer(CHSH_REAL);
#endif

/* PAB changes - 25 May 1995 */
  real_shape = f_floating(f_float_of_complex(sh(arg1)));
#if substitute_complex
  {
    exp t = me_u3(real_shape, arg1, field_tag);
    no(t) = 0;
    return hold_check(t);
  }
#else
  return me_u3(real_shape, arg1, realpart_tag);
#endif
}



exp f_make_complex
    PROTO_N ( (f, arg1, arg2) )
    PROTO_T ( floating_variety f X exp arg1 X exp arg2 )
{
  if (name(sh(arg1)) == bothd)
    { kill_exp(arg2,arg2); return arg1; }
  if (name(sh(arg2)) == bothd)
    { kill_exp(arg1,arg1); return arg2; }

#if check_shape
  if (!is_float(sh(arg1)) || !is_float(sh(arg2)) ||
      !eq_shape(sh(arg1), sh(arg2)) || f != f_complex_of_float(sh(arg1)))
    failer(CHSH_MAKE_COMPLEX);
#endif


/* PAB changes - 19 October 1994 */
#if substitute_complex
  switch (f) {
     case shcomplexfv:
        {
       shape off_set = f_offset(SHREAL_ALIGN, SHREAL_ALIGN);
       exp val1 = me_shint(off_set, 0);
       exp val2 = me_shint(off_set, SHREAL_SZ);
       exp sz = me_shint(off_set, SHREAL_SZ + SHREAL_SZ);
       exp r = getexp(f_compound(sz), nilexp, 0, val1, nilexp, 0, 0, compound_tag);

       setbro(val1, arg1);
       clearlast(val1);
       setbro(arg1, val2);
       clearlast(arg1);
       setbro(val2, arg2);
       clearlast(val2);
       setfather(r, arg2);
       return hold_check(r);
       }
     case complexfv:
       {
       shape off_set = f_offset(REAL_ALIGN, REAL_ALIGN);
       exp val1 = me_shint(off_set, 0);
       exp val2 = me_shint(off_set, REAL_SZ);
       exp sz = me_shint(off_set, REAL_SZ + REAL_SZ);
       exp r = getexp(f_compound(sz), nilexp, 0, val1, nilexp, 0, 0, compound_tag);

       setbro(val1, arg1);
       clearlast(val1);
       setbro(arg1, val2);
       clearlast(arg1);
       setbro(val2, arg2);
       clearlast(val2);
       setfather(r, arg2);
       return hold_check(r);
       }
     case complexdoublefv:
       {
       shape off_set = f_offset(DOUBLE_ALIGN, DOUBLE_ALIGN);
       exp val1 = me_shint(off_set, 0);
       exp val2 = me_shint(off_set, DOUBLE_SZ);
       exp sz = me_shint(off_set, DOUBLE_SZ + DOUBLE_SZ);
       exp r = getexp(f_compound(sz), nilexp, 0, val1, nilexp, 0, 0, compound_tag);

       setbro(val1, arg1);
       clearlast(val1);
       setbro(arg1, val2);
       clearlast(arg1);
       setbro(val2, arg2);
       clearlast(val2);
       setfather(r, arg2);
       return hold_check(r);
       }
     default:
       {
       failer("Illegal floating_variety for make_complex_tag\n");
       }
  }
#endif
  return me_b3(f_floating(f), arg1, arg2,
             make_complex_tag);
}


#if FBASE == 10

exp f_make_floating
    PROTO_N ( (fv, rm, sign, mantissa, base, expo) )
    PROTO_T ( floating_variety fv X rounding_mode rm X bool sign X string mantissa X nat base X signed_nat expo )
{
  int ignore_zero = 1;
  int lg = mantissa.number;
  flpt f = new_flpt ();
  int  sig_digs = 0;
  int  i;
  int point = 0;
  char ch;
  int exponent = snatint(expo);

  if (PIC_code)
    proc_externs = 1;

  if (snatneg(expo))
    exponent = - exponent;

  if (natint(base) != 10)
    failer (BASE_NOT_10);
  for (i = 0; i < MANT_SIZE; ++i)
    (flptnos[f].mant)[i] = 0;

  for (i = 0; i < lg; ++i) {
    ch = mantissa.ints.chars[i];
    if (ch == '0' && ignore_zero) {
      if (point)
      --exponent;
    }
    else {
      if (ch == '.')
      point = 1;
      else {
      ignore_zero = 0;
      if (!point)
        ++exponent;
      if (sig_digs < MANT_SIZE)
        (flptnos[f].mant)[sig_digs++] = ch - '0';
      };
    };
  };

  if (ignore_zero) {
    flptnos[f].exp = 0;
    flptnos[f].sign = 0;
  }
  else {
    flptnos[f].exp = exponent - 1;
    flptnos[f].sign = (sign ? -1 : 1);
  };

  if (flptnos[f].exp > target_dbl_maxexp)
    failer (BIG_FLPT);

  return (getexp (f_floating(fv), nilexp, 0, nilexp, nilexp,
             0, f, real_tag));

}

#else

exp f_make_floating
    PROTO_N ( (fv, rm, sign, mantissa, natbase, expo) )
    PROTO_T ( floating_variety fv X rounding_mode rm X bool sign X string mantissa X nat natbase X signed_nat expo )
{
  int ignore_zero = 1;
  int lg = mantissa.number;
  flpt f = new_flpt ();
  int  has_sig_digs = 0;
  int  i;
  int point = 0;
  int exponent = snatint(expo);
  flt fr;
  int base = natint(natbase);


  flt_zero(&fr);

  if (PIC_code)
    proc_externs = 1;

  if (base != 10 && base != 16 && base !=8 && base != 2 && base != 4)
    failer (BAD_BASE);

  if (snatneg(expo))
    exponent = - exponent;

  for (i = 0; i < lg; ++i) {
    char c = mantissa.ints.chars[i];
    if (c != '0' || !ignore_zero) {
      ignore_zero = 0;
      if (c == '.')
      point = 1;
      else {
      c = c - '0';
      if (c != 0)
        has_sig_digs = 1;
        exponent -= point;
      flpt_newdig((unsigned int)c, &fr, base);
      };
    };
  };

  if (ignore_zero) {
    fr.exp = 0;
    fr.sign = 0;
  }
  else {
    if (has_sig_digs)
      fr.sign = (sign ? -1 : 1);
    else
      fr.sign = 0;
    flpt_scale(exponent, &fr, base);
  };


  flpt_round((int)rm, flpt_bits((floating_variety)fv), &fr);

  if (flpt_const_overflow_fail) {
    r2l r;
    r = real2longs_IEEE(&fr, fv);
    UNUSED(r);
  };

  flptnos[f] = fr;

  return (getexp (f_floating(fv), nilexp, 0, nilexp, nilexp,
             0, f, real_tag));

}

#endif



exp f_power
    PROTO_N ( (ov_err, arg1, arg2) )
    PROTO_T ( error_treatment ov_err X exp arg1 X exp arg2 )
{
  if (name(sh(arg1)) == bothd)
    { kill_exp(arg2,arg2); return arg1; }
  if (name(sh(arg2)) == bothd)
    { kill_exp(arg1,arg1); return arg2; }
#if check_shape
  if (!is_integer(sh(arg1)) || !is_integer(sh(arg2)))
    failer(CHSH_POWER);
#endif

  return  real_power(ov_err, arg1, arg2);
}


exp f_round_with_mode
    PROTO_N ( (flpt_err, mode, r, arg1) )
    PROTO_T ( error_treatment flpt_err X rounding_mode mode X variety r X exp arg1 )
{
  exp res;
  if (name(sh(arg1)) == bothd)
    return arg1;
  if (is_complex(sh(arg1))) {
      arg1 = f_real_part(arg1);
  }
#if check_shape
  if (!is_float(sh(arg1)))
    failer(CHSH_ROUND);
#endif
#if !has64bits
      if ( shape_size(r)>32 && (name(arg1) != real_tag || flpt_err.err_code>=4)   ) {
            int s = is_signed(r);
            char * fn;
            exp e;
#if use_long_double
              arg1 = hold_check(
              f_change_floating_variety(f_impossible, 2, arg1));
#else
              arg1 = hold_check(
              f_change_floating_variety(f_impossible, 1, arg1));
#endif
            switch(mode) {
            case R2NEAR: fn = (s)?"__TDFUs_R2NEAR":"__TDFUu_R2NEAR"; break;
            case R2PINF: fn = (s)?"__TDFUs_R2PINF":"__TDFUu_R2PINF"; break;
            case R2NINF: fn = (s)?"__TDFUs_R2NINF":"__TDFUu_R2NINF"; break;
            case R2ZERO: fn = (s)?"__TDFUs_R2ZERO":"__TDFUu_R2ZERO"; break;
            default: fn = (s)?"__TDFUs_ASSTATE":"__TDFUu_R2ASSTATE";
            }
            e = TDFcallaux(flpt_err, arg1, fn, r);
            return (hold_check(e));
      }
#endif
#if ismips
      /* mips does not seem to get float->unsigned long right -
            so convert to signed long and adjust if too big*/
      else
      if (name(arg1)!=real_tag && shape_size(r)==32 && !is_signed(r) ) {
            floating_variety fa = (shape_size(sh(arg1))==32)?0:1;
            exp_list st;
            exp z;
            exp d1 = me_startid(r, arg1, 0);
            exp hldr = getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0, 0);
            exp lb = getexp(f_top, nilexp, 0, hldr, nilexp, 0, 0, labst_tag);

            exp fmax = hold_check(f_float_int(f_impossible, fa,
                              me_shint(ulongsh,0x80000000 )));
            exp d2 = me_startid(r, fmax, 0);
            exp tst =  f_floating_test(no_nat_option,
                        f_impossible, f_less_than, &lb,
                        me_obtain(d1), me_obtain(d2));
            exp nconv = f_round_with_mode(flpt_err, mode, slongsh,
                              me_obtain(d1));
            exp first; exp alt; exp cnd;
            st = new_exp_list(1);
            st = add_exp_list(st, tst, 0);
            first = f_sequence(st, f_change_variety(flpt_err, r, nconv));
            z = f_round_with_mode(flpt_err, mode, slongsh,
                  f_floating_minus(f_impossible, me_obtain(d1), me_obtain(d2)));
            alt = f_plus(f_impossible,
               f_change_variety(f_impossible, r, z), me_shint(r, 0x80000000));
            cnd = f_conditional(&lb, first, alt);
            return me_complete_id(d1, me_complete_id(d2, cnd));

      }
#endif
#if ispower
 if (name(arg1)!=real_tag || flpt_err.err_code>2) {
  if (architecture!=POWERPC_CODE)
  {
    exp id;
    exp apply1;
    exp apply2;
    long shp_sze = shape_size(f_integer(r));
    bool sgned = is_signed(f_integer(r));
    bool err = (flpt_err.err_code>2);
    char *nm ;
    char *nm_err;
    int power_mode;

    /* Set up ident to hold arg1 */
    if (name(sh(arg1))==shrealhd)
    {
      arg1 = f_change_floating_variety(f_impossible,realfv,arg1);
    }
    id = me_startid(f_top,arg1,0);

  /* Set up power_mode */
    switch (mode)
    {

      case R2ZERO: power_mode = 0;break;
      case R2NEAR: power_mode = 1;break;
      case R2PINF: power_mode = 2;break;
      case R2NINF: power_mode = 3;break;
      default:power_mode = 1;break;
    }

    /* Work out which functions to call */
    if (sgned)
    {
      nm = "__TDFrnd_sgned";
      nm_err = "__TDFerr_rnd_sgned";
    }
    else
    {
      nm = "__TDFrnd_unsgned";
      nm_err = "__TDFerr_rnd_unsgned";
    }

    {
      exp_list pars2;
      exp_option no_var ;
      pars2 = new_exp_list(2);
      no_var.present = 0;
      pars2 = add_exp_list(pars2,me_obtain(id),0);
      pars2 = add_exp_list(pars2,me_shint(uwordsh,power_mode),1);
      apply2 = f_apply_proc(sgned?slongsh:ulongsh,me_obtain(find_named_tg(nm,f_proc)),pars2,no_var);
    }

    if (err)
    {
      exp_list st;
      exp seq;
      exp pl;
      exp_list pars1;
      exp_option no_var;
      no_var.present = 0;

      pars1 = new_exp_list(2);
      pars1 = add_exp_list(pars1,me_obtain(id),0);
      pars1 = add_exp_list(pars1,me_shint(uwordsh,power_mode),1);
      apply1 = f_apply_proc(f_top,me_obtain(find_named_tg(nm_err,f_proc)),pars1,no_var);

      pl = f_plus(flpt_err,me_shint(slongsh,INT_MAX),me_obtain(find_named_tg("__TDFrnd_error",slongsh)));
      st = new_exp_list(2);
      st = add_exp_list(st,apply1,0);
      st = add_exp_list(st,pl,1);
      seq = f_sequence(st,apply2);
      id = me_complete_id(id,seq);
    }
    else
    {
      id = me_complete_id(id,apply2);
    }
    if (shp_sze <32)
    {
      id = f_change_variety(flpt_err,f_integer(r),id);
    }
    return id;
  }/*end ispower */
 }
  /* FALL THROUGH */
#endif

  res = getexp (f_integer(r), nilexp, 0, arg1, nilexp,
           0, 0, round_tag);
  setround_number(res, mode);
  seterrhandle(res, flpt_err.err_code);
  if (flpt_err.err_code ==  4)
    setjmp_dest(res, get_lab(flpt_err.jmp_dest));
  setfather (res, arg1);
  return res;
}



floating_variety f_flvar_parms
    PROTO_N ( (base, mantissa_digits, minimum_exponent, maximum_exponent) )
    PROTO_T ( nat base X nat mantissa_digits X nat minimum_exponent X nat maximum_exponent )
{
  int b = natint(base);
  int mantdig = natint(mantissa_digits);
  int neg_minexp = natint(minimum_exponent);
  int maxexp = natint(maximum_exponent);

  while (b !=2) {
      if ((b & 1) != 0) {
            failer("base in flvar_parms must be a power of 2");
      }
      mantdig+=mantdig;
      neg_minexp+=neg_minexp;
      maxexp+=maxexp;
      b = (b>>1);
  }

      if (mantdig <= 24 && neg_minexp <= 126 &&
                 maxexp <= 127)
        return (0);
      if (mantdig <= 53 && neg_minexp <= 1022 &&
                 maxexp <= 1023)
        return (1);

#if use_long_double
      if (mantdig <= 64 && neg_minexp <= 16382 &&
                 maxexp <= 16383)
        return (2);
      return (2);
#else
        return 1;
#endif
}


floating_variety f_complex_parms
    PROTO_N ( (base, mantissa_digits, minimum_exponent, maximum_exponent) )
    PROTO_T ( nat base X nat mantissa_digits X nat minimum_exponent X nat maximum_exponent )
{
  return float_to_complex_var(f_flvar_parms(base, mantissa_digits,
                   minimum_exponent, maximum_exponent));
}


void init_floating_variety
    PROTO_Z ()
{
  shrealsh = getshape(0, const_al1, const_al1, SHREAL_ALIGN,
                   SHREAL_SZ, shrealhd);
  realsh = getshape(0, const_al1, const_al1, REAL_ALIGN, REAL_SZ, realhd);
  doublesh = getshape(0, const_al1, const_al1, DOUBLE_ALIGN,
                   DOUBLE_SZ, doublehd);
#if substitute_complex
  shcomplexsh = getshape(0, const_al1, const_al1, SHREAL_ALIGN,
                   2*SHREAL_SZ, cpdhd);
  complexsh = getshape(0, const_al1, const_al1, REAL_ALIGN,
                   2*REAL_SZ, cpdhd);
  complexdoublesh = getshape(0, const_al1, const_al1, DOUBLE_ALIGN,
                   2*DOUBLE_SZ, cpdhd);
#else
  shcomplexsh = getshape(0, const_al1, const_al1, SHREAL_ALIGN,
                   2*SHREAL_SZ, shcomplexhd);
  complexsh = getshape(0, const_al1, const_al1, REAL_ALIGN,
                   2*REAL_SZ, complexhd);
  complexdoublesh = getshape(0, const_al1, const_al1, DOUBLE_ALIGN,
                   2*DOUBLE_SZ, complexdoublehd);
#endif
  return;
}



floating_variety f_dummy_floating_variety;

floating_variety f_float_of_complex
    PROTO_N ( (sha) )
    PROTO_T ( shape sha )
{
      int s = shape_size(sha)/2;
      if (s==SHREAL_SZ) return shrealfv;
      if (s==REAL_SZ) return realfv;
      if (s==DOUBLE_SZ) return doublefv;
      failer("Expecting a complex shape");

      return f_dummy_floating_variety;
}

floating_variety f_complex_of_float
    PROTO_N ( (sha) )
    PROTO_T ( shape sha )
{
      int s = shape_size(sha);
      if (s==SHREAL_SZ) return shcomplexfv;
      if (s==REAL_SZ) return complexfv;
      if (s==DOUBLE_SZ) return complexdoublefv;
      failer("Expecting a floating shape");
      return f_dummy_floating_variety;
}

floating_variety fv_of_shape
    PROTO_N ( (sha) )
    PROTO_T ( shape sha )
{
      int s = shape_size(sha);
      if (s==SHREAL_SZ) return shrealfv;
      if (s==REAL_SZ) return realfv;
      if (s==DOUBLE_SZ) return doublefv;
      failer("Expecting a complex shape");

      return f_dummy_floating_variety;
}



static void square_x_iy
    PROTO_N ( (ov_err, arg1, arg2, arg3) )
    PROTO_T ( error_treatment ov_err X exp *arg1 X exp *arg2 X exp arg3 )
{
    exp x = *arg1;
    exp y = *arg2;

    exp obtain1_x = me_obtain(x);
    exp obtain2_x = me_obtain(x);
    exp obtain3_x = me_obtain(x);
    exp obtain1_y = me_obtain(y);
    exp obtain2_y = me_obtain(y);
    exp obtain3_y = me_obtain(y);

    exp minus_x_y = f_floating_minus(ov_err, obtain1_x, obtain1_y);
    exp  plus_x_y = f_bin_floating_plus(ov_err, obtain2_x, obtain2_y);
    exp  mult_x_y = f_bin_floating_mult(ov_err, obtain3_x, obtain3_y);

    exp tmp = push(arg3, me_startid(sh(x), mult_x_y, 0));

    exp obtain1_tmp = hold_check(me_obtain(tmp));
    exp obtain2_tmp = hold_check(me_obtain(tmp));

    exp answer_re  = f_bin_floating_mult(ov_err, minus_x_y, plus_x_y);
    exp answer_im  = f_bin_floating_plus(ov_err, obtain1_tmp, obtain2_tmp);

    x = push(tmp, me_startid(sh(x), answer_re, 0));
    y = push(x, me_startid(sh(x), answer_im, 0));

    *arg1 = x;
    *arg2 = y;

    return;
}


static void mult_w_by_z
    PROTO_N ( (ov_err, arg1, arg2, arg3, arg4, arg5) )
    PROTO_T ( error_treatment ov_err X exp *arg1 X exp *arg2 X exp arg3 X exp arg4 X exp arg5 )
{
    exp u = *arg1;
    exp v = *arg2;
    exp x =  arg3;
    exp y =  arg4;

    exp obtain1_x = me_obtain(x);
    exp obtain2_x = me_obtain(x);
    exp obtain1_y = me_obtain(y);
    exp obtain2_y = me_obtain(y);

    exp obtain1_u = me_obtain(u);
    exp obtain2_u = me_obtain(u);
    exp obtain1_v = me_obtain(v);
    exp obtain2_v = me_obtain(v);

    exp mult_x_u = f_bin_floating_mult(ov_err, obtain1_x, obtain1_u);
    exp mult_x_v = f_bin_floating_mult(ov_err, obtain2_x, obtain1_v);
    exp mult_y_u = f_bin_floating_mult(ov_err, obtain1_y, obtain2_u);
    exp mult_y_v = f_bin_floating_mult(ov_err, obtain2_y, obtain2_v);

    exp tmp = push(arg5, me_startid(sh(x), mult_y_u, 0));
    exp obtain_tmp = hold_check(me_obtain(tmp));

    exp answer_re  = f_floating_minus(ov_err, mult_x_u, mult_y_v);
    exp answer_im  = f_bin_floating_plus(ov_err, mult_x_v, obtain_tmp);

    u = push(tmp, me_startid(sh(x), answer_re, 0));
    v = push(u, me_startid(sh(x), answer_im, 0));

    *arg1 = u;
    *arg2 = v;

    return;
}


static exp make_comp_1_z
    PROTO_N ( (complex_fv, ov_err, contents1_u, contents2_u, contents3_u,
             contents1_v, contents2_v, contents3_v) )
    PROTO_T ( floating_variety complex_fv X error_treatment ov_err X
            exp contents1_u X exp contents2_u X exp contents3_u X
            exp contents1_v X exp contents2_v X exp contents3_v )
{
    exp mult_u_u    = f_bin_floating_mult(ov_err, contents1_u, contents2_u);
    exp mult_v_v    = f_bin_floating_mult(ov_err, contents1_v, contents2_v);
    exp mod_squared = f_bin_floating_plus(ov_err, mult_u_u, mult_v_v);
    exp mod_sq      = me_startid(sh(contents1_u), mod_squared, 0);

    exp obtain1_mod_sq = me_obtain(mod_sq);
    exp obtain2_mod_sq = me_obtain(mod_sq);

    exp v_div_mod_sq = f_floating_div(ov_err, contents3_v, obtain2_mod_sq);

    exp answer_re = f_floating_div(ov_err, contents3_u, obtain1_mod_sq);
    exp answer_im = f_floating_negate(ov_err, v_div_mod_sq);

    exp make_comp = f_make_complex(complex_fv, answer_re, answer_im);
    return  me_complete_id(mod_sq, make_comp);
}


#define is_const(X)  (name(X) != ident_tag)

exp_list reorder_list
    PROTO_N ( (arg1, consts_first) )
    PROTO_T ( exp_list arg1 X int consts_first )
{
    exp type1_start, type1_end, type2_start, type2_end, t;

    type1_start = type1_end = type2_start = type2_end = nilexp;
    setbro(arg1.end, nilexp);
    for (t = arg1.start; t != arg1.end; t=bro(t)) {
      if ((is_const(t) && consts_first) || !(is_const(t) || consts_first)) {
          if (type1_start == nilexp) {
            type1_start = type1_end = t;                          /* first of type 1 */
          } else {
            setbro(type1_end, t);                        /* add to existing type 1's */
            type1_end = t;
          }
      } else {
          if (type2_start == nilexp) {
            type2_start = type2_end = t;                          /* first of type 2 */
          } else {
            setbro(type2_end, t);                        /* add to existing type 2's */
            type2_end = t;
          }
      }
    }

    if ((type1_start != nilexp) && (type2_start != nilexp)) {
      arg1.start = type1_start;
        setbro(type1_end, type2_start);                      /* if list is not a mixture */
      arg1.end = type2_end;                            /* no reordering has to be done */
    }

    return arg1;
}


exp me_contents
    PROTO_N ( (arg1) )
    PROTO_T ( exp arg1 )
{
  exp r = me_u3(sh(arg1), me_obtain(arg1), cont_tag);

  return hold_check(r);
}



  /* Used in conjunction with the function "me_complete_chain",
     this function is used to push "ident_tag" declarations
     onto a "stack" so that they can be linked up later.  It is
     used in loops where the number of "ident_tag"s is unknown
     and they need to be bound together in a "first-used last-
     bound" order - hence the stack.

     arg1 is the new element
     arg2 is the top element on the stack
 */

static exp push
    PROTO_N ( (arg1, arg2) )
    PROTO_T ( exp arg1 X exp arg2 )
{
    setbro(arg2, arg1);
    return arg2;
}


  /* Take the stack full of "ident_tag" declarations and link them
     together with the last element in the list being "last_link"
     and the body around which the declarations are put be "link_to".
  */

static exp me_complete_chain
    PROTO_N ( (ident_chain, last_link, link_to) )
    PROTO_T ( exp ident_chain X exp last_link X exp link_to )
{
    exp remove_link;

    while (son(ident_chain) != last_link) {
      remove_link = bro(ident_chain);
      link_to = me_complete_id(ident_chain, link_to);
      ident_chain = remove_link;
    };

    return me_complete_id(ident_chain, link_to);
}



/* Binary version of 'f_floating_plus' */

static exp f_bin_floating_plus
    PROTO_N ( (ov_err, arg1, arg2) )
    PROTO_T ( error_treatment ov_err X exp arg1 X exp arg2 )
{
  exp_list el;
  el = new_exp_list(2);
  el = add_exp_list(el, arg1, 0);
  el = add_exp_list(el, arg2, 1);
  return f_floating_plus (ov_err,el);
}


/* Binary version of 'f_floating_mult' */

static exp f_bin_floating_mult
    PROTO_N ( (ov_err, arg1, arg2) )
    PROTO_T ( error_treatment ov_err X exp arg1 X exp arg2 )
{
  exp_list el;
  el = new_exp_list(2);
  el = add_exp_list(el, arg1, 0);
  el = add_exp_list(el, arg2, 1);
  return f_floating_mult (ov_err,el);
}

static exp optimise_with_wrap
    PROTO_N ( (arg, shape1, shape2) )
    PROTO_T ( exp arg X shape shape1 X shape shape2 )
{
  if (! eq_shape(shape1,shape2))
    return  f_change_variety (f_wrap, shape2, arg);

  return (arg);
}

static exp real_power
    PROTO_N ( (ov_err, arg1, arg2) )
    PROTO_T ( error_treatment ov_err X exp arg1 X exp arg2 )
{

    /* Gives shorter .s file if n<10 and arg1 is unknown */

    exp real1, sn;
    exp (*f_real_mult) PROTO_S ((error_treatment, exp, exp));
    shape real_shape, integer_shape, tmp_shape;


/* With wrap, we may as well work with 'int's and change back after */

    tmp_shape = sh(arg1);
    if (is_integer(tmp_shape) && !is_signed(tmp_shape) &&
      shape_size(sh(arg1)) < 32 &&
      eq_et(ov_err, f_wrap))
    {
      arg1 = hold_check (f_change_variety (f_impossible, ulongsh, arg1));
    }


/* Widen to 'int' if necessary - guarantees negate will work */

    if (shape_size(sh(arg2)) < 32) {
      arg2 = hold_check (f_change_variety (f_impossible, slongsh, arg2));
    }

    real_shape = sh(arg1);                       /* shape of the result */
    integer_shape = sh(arg2);
    sn = me_startid(integer_shape, arg2, 0);


/* Identify an exp which represents the value 1 (or 1.0) */

    if (is_integer(real_shape)) {
      real1 = me_shint(real_shape,1);
    }
    else {
      real1 = me_shint(integer_shape,1);
      real1 = f_float_int (f_impossible, fv_of_shape(real_shape), real1);
      real1 = hold_check (real1);         /* This should be reduced to 1.0 */
    }
    real1 = push (sn, me_startid(real_shape, real1, 0));


/* Decide which is the suitable function for multiplying two numbers */

    f_real_mult = (is_integer(real_shape) ? f_mult : f_bin_floating_mult);

    if (is_constant_arg(arg2) ||
      ((name(arg2) == name_tag) && (name(son(arg2)) == ident_tag)
         && !isvar(son(arg2)) && is_constant_arg(son(son(arg2)))))
    {                                                                /* we know the power */
      int exponent;
      exp x;

      if (is_constant_arg(arg2)) {
          exponent = no(arg2);      /* arg2 is a constant */
      }
      else {
          exponent = no(son(son(arg2)));
            /* arg2 identifies a constant */
      }

      if (exponent < 0) {
          if (is_integer(real_shape)) {
            failer("constant value out of range: power: must be non-negative");
          }
          else {              /* take reciprocal */
            arg1 = hold_check (f_floating_div (ov_err, me_obtain(real1), arg1));
          }
      }
      x = push (real1, me_startid(real_shape, arg1, 0));

      if (exponent == 0) {
          return  me_complete_chain (x, arg2, optimise_with_wrap (
                     me_obtain(real1), real_shape, tmp_shape));
      }

      {
          exp  w, mylast = x;
          int n = abs(exponent);

          while ((n % 2) == 0) {
            exp mult_x_x;
            mult_x_x = (*f_real_mult)(ov_err, me_obtain(x), me_obtain(x));
            mylast = x = push (mylast,
                   me_startid(real_shape, hold_check(mult_x_x), 0));
            n = n / 2;
          }

          if (n == 1) {
            return  me_complete_chain (x, arg2, optimise_with_wrap (
                        me_obtain(x), real_shape, tmp_shape));        /* return x  */
          }
          else {                                                       /*  w = x  */
            mylast = w = push (x, me_startid(real_shape, me_obtain(x), 0));
          }

          while (n != 1) {
            exp mult_x_x;
            mult_x_x = (*f_real_mult)(ov_err, me_obtain(x), me_obtain(x));
            mylast = x = push (mylast,
                  me_startid(real_shape, hold_check(mult_x_x), 0));
            n = n / 2;
            if ((n % 2) == 1) {
                exp mult_w_x;
                mult_w_x = (*f_real_mult)(ov_err, me_obtain(w), me_obtain(x));
                mylast = w = push (mylast,
                  me_startid(real_shape, hold_check(mult_w_x), 0));
            }
          }

          return  me_complete_chain (w, arg2, optimise_with_wrap (
                        me_obtain(w), real_shape, tmp_shape));    /*  return w  */
      }

    } else {

      exp  reinitialise_w, main_loop, make_comp;              /* main building blocks */
      exp  square_x, mult_x_w, half_n, update_w, repeat_body;
      exp  seq, w, x, n;

      n = me_obtain(sn);
      if (!is_integer(real_shape)) {      /* Must be positive for integer powers */
          n = f_abs (f_impossible, n);
      }

      n = push (real1, me_startid (integer_shape, n, 1));
      w = push (n, me_startid(real_shape, me_obtain(real1), 1));
      x = push (w, me_startid(real_shape, arg1, 1));


      /*  change value of w to z if n is odd  */

      {
          exp rem_n_2 = f_and (me_contents(n), me_shint(integer_shape, 1));
          exp assign_w = f_assign (me_obtain(w), me_contents(x));
          exp alt_labst = hold_check(me_b3(f_top, f_make_value(f_top),
                                     f_make_top(), labst_tag));
          exp is_n_odd = f_integer_test (no_nat_option, f_equal, make_label(alt_labst),
                        rem_n_2, me_shint(integer_shape, 1));
          exp seq = f_sequence (add_exp_list(new_exp_list(1), is_n_odd, 0), assign_w);
          reinitialise_w = hold_check(me_b3(lub_shape(sh(seq),sh(alt_labst)),
                                    seq, alt_labst, cond_tag));
      }

      /*  x=x*x  */
      {
          exp mult_x_x;
          mult_x_x = (*f_real_mult) (ov_err, me_contents(x), me_contents(x));
          square_x = f_assign (me_obtain(x), mult_x_x);
      }

      /*  w=x*w  */
      {
          exp answer;
          answer = (*f_real_mult)(ov_err, me_contents(x), me_contents(w));
          mult_x_w = f_assign (me_obtain(w), answer);
      }

      /*  n=n/2  */
      {
          exp answer = f_shift_right (me_contents(n), me_shint(integer_shape, 1));
          half_n = f_assign (me_obtain(n), answer);
      }

      /*  if n is odd then w = z*w  */
      {
          exp rem_n_2 = f_and (me_contents(n), me_shint(integer_shape, 1));
          exp alt_labst = hold_check(me_b3(f_top, f_make_value(f_top),
                                   f_make_top(), labst_tag));
          exp is_n_odd = f_integer_test (no_nat_option, f_equal, make_label(alt_labst),
                                 rem_n_2, me_shint(integer_shape, 1));
          exp seq = f_sequence (add_exp_list(new_exp_list(1),
                              is_n_odd, 0), mult_x_w);
          update_w = hold_check(me_b3(lub_shape(sh(seq),sh(alt_labst)),
                              seq, alt_labst, cond_tag));
      }

      /*  repeat + body  */
      {
          exp body_labst, if_n_equals_1;
          exp_list st;

          body_labst = hold_check(me_b3(f_top, f_make_value(f_top), f_make_top(), labst_tag));

          if_n_equals_1 = f_integer_test (no_nat_option, f_equal, make_label(body_labst),
                                  me_contents(n), me_shint(integer_shape, 1));

          st = new_exp_list(1);
          st = add_exp_list(st, square_x, 0);
          st = add_exp_list(st, half_n, 1);
          st = add_exp_list(st, update_w, 2);
          seq = f_sequence (st, if_n_equals_1);

          setbro (son(body_labst), seq);
          setsh (body_labst, sh (seq));                    /*  put seq into the body  */
          clearlast (son(body_labst));                     /*  of the labst           */
          setfather (body_labst, seq);

          repeat_body = hold_check(me_b3(sh(body_labst), f_make_top(), body_labst, rep_tag));
          note_repeat(repeat_body);
      }

      /*  make loop - only done if  mod(n) > 1  */
      {
          exp alt_labst = hold_check(me_b3(f_top, f_make_value(f_top),
                                 f_make_top(), labst_tag));
          exp is_n_gt_1 = f_integer_test (no_nat_option, f_greater_than, make_label(alt_labst),
                                  me_contents(n), me_shint(integer_shape, 1));
          exp seq = f_sequence (add_exp_list(new_exp_list(1),
                               is_n_gt_1, 0), repeat_body);
          main_loop = hold_check(me_b3(lub_shape(sh(seq),sh(alt_labst)),
                               seq, alt_labst, cond_tag));
      }

      if (is_integer(real_shape)) {
          make_comp = me_contents(w);
      }
      else {
          exp make_comp2 = f_floating_div(ov_err, me_obtain(real1), me_contents(w));
          exp alt_labst = hold_check(me_b3(real_shape, f_make_value(f_top),
                                   make_comp2, labst_tag));
          exp is_arg2_positive = f_integer_test (no_nat_option, f_greater_than_or_equal,
                                     make_label(alt_labst), me_obtain(sn),
                                     me_shint(integer_shape, 0));
          exp seq = f_sequence (add_exp_list(new_exp_list(1),
                              is_arg2_positive, 0), me_contents(w));

          make_comp = hold_check(me_b3(lub_shape(sh(seq),sh(alt_labst)),
                               seq, alt_labst, cond_tag));
      }

      seq = f_sequence (add_exp_list (add_exp_list(new_exp_list(1),
                        reinitialise_w, 0), main_loop, 1), make_comp);
      seq = optimise_with_wrap (seq, real_shape, tmp_shape);
      return  me_complete_chain(x, arg2, seq);
    }
}

Generated by  Doxygen 1.6.0   Back to index