a68g-conversion.c

     
   1  //! @file a68g-conversion.c
   2  //! @author J. Marcel van der Veer
   3  //!
   4  //! @section Copyright
   5  //!
   6  //! This file is part of Algol68G - an Algol 68 compiler-interpreter.
   7  //! Copyright 2001-2023 J. Marcel van der Veer [algol68g@xs4all.nl].
   8  //!
   9  //! @section License
  10  //!
  11  //! This program is free software; you can redistribute it and/or modify it 
  12  //! under the terms of the GNU General Public License as published by the 
  13  //! Free Software Foundation; either version 3 of the License, or 
  14  //! (at your option) any later version.
  15  //!
  16  //! This program is distributed in the hope that it will be useful, but 
  17  //! WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 
  18  //! or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for 
  19  //! more details. You should have received a copy of the GNU General Public 
  20  //! License along with this program. If not, see [http://www.gnu.org/licenses/].
  21  
  22  //! @section Synopsis
  23  //!
  24  //! Conversion tables for IEEE platforms.
  25  
  26  #include "a68g.h"
  27  #include "a68g-prelude.h"
  28  #include "a68g-mp.h"
  29  #include "a68g-genie.h"
  30  #include "a68g-postulates.h"
  31  #include "a68g-parser.h"
  32  #include "a68g-options.h"
  33  #include "a68g-optimiser.h"
  34  #include "a68g-listing.h"
  35  
  36  // A list of 10 ^ 2 ^ n for conversion purposes on IEEE 754 platforms.
  37  
  38  #if (A68_LEVEL >= 3)
  39  
  40  #include "a68g-quad.h"
  41  
  42  //! @brief 10 ** expo
  43  
  44  static DOUBLE_T pow_10_double[] = {
  45    10.0q, 100.0q, 1.0e4q, 1.0e8q, 1.0e16q, 1.0e32q, 1.0e64q, 1.0e128q, 1.0e256q, 1.0e512q, 1.0e1024q, 1.0e2048q, 1.0e4096q
  46  };
  47  
  48  DOUBLE_T ten_up_double (int expo)
  49  {
  50  // This way appears sufficiently accurate.
  51    DOUBLE_T dbl_expo = 1.0q, *dep;
  52    BOOL_T neg_expo;
  53    if (expo == 0) {
  54      return 1.0q;
  55    }
  56    neg_expo = (BOOL_T) (expo < 0);
  57    if (neg_expo) {
  58      expo = -expo;
  59    }
  60    if (expo > MAX_DOUBLE_EXPO) {
  61      expo = 0;
  62      errno = EDOM;
  63    }
  64    ABEND (expo > MAX_DOUBLE_EXPO, ERROR_INVALID_VALUE, __func__);
  65    for (dep = pow_10_double; expo != 0; expo >>= 1, dep++) {
  66      if (expo & 0x1) {
  67        dbl_expo *= *dep;
  68      }
  69    }
  70    return neg_expo ? 1.0q / dbl_expo : dbl_expo;
  71  }
  72  
  73  //! @brief ten_up_quad_real
  74  
  75  QUAD_T ten_up_quad_real (int n)
  76  {
  77    QUAD_T s = QUAD_REAL_TEN, t;
  78    unsigned k, m;
  79    t = QUAD_REAL_ONE;
  80    if (n < 0) {
  81      m = -n;
  82      if ((sigerr_quad_real (real_cmp_quad_real (&s, &QUAD_REAL_ZERO) == 0, QUAD_REAL_EBADEXP, "pwr_quad_real"))) {
  83        return QUAD_REAL_ZERO;
  84      }
  85      s = div_quad_real (QUAD_REAL_ONE, s);
  86    } else {
  87      m = n;
  88    }
  89    if (m != 0) {
  90      k = 1;
  91      while (1) {
  92        if (k & m) {
  93          t = mul_quad_real (s, t);
  94        }
  95        if ((k <<= 1) <= m) {
  96          s = mul_quad_real (s, s);
  97        } else {
  98          break;
  99        }
 100      }
 101    } else {
 102      sigerr_quad_real (real_cmp_quad_real (&s, &QUAD_REAL_ZERO) == 0, QUAD_REAL_EBADEXP, "pwr_quad_real");
 103    }
 104    return t;
 105  }
 106  
 107  #endif
 108  
 109  static REAL_T pow_10[] = {
 110    10.0, 100.0, 1.0e4, 1.0e8, 1.0e16, 1.0e32, 1.0e64, 1.0e128, 1.0e256
 111  };
 112  
 113  //! @brief 10 ** expo
 114  
 115  REAL_T ten_up (int expo)
 116  {
 117  // This way appears sufficiently accurate.
 118    REAL_T dbl_expo = 1.0, *dep;
 119    BOOL_T neg_expo = (BOOL_T) (expo < 0);
 120    if (neg_expo) {
 121      expo = -expo;
 122    }
 123    ABEND (expo > MAX_REAL_EXPO, ERROR_INVALID_VALUE, __func__);
 124    for (dep = pow_10; expo != 0; expo >>= 1, dep++) {
 125      if (expo & 0x1) {
 126        dbl_expo *= *dep;
 127      }
 128    }
 129    return neg_expo ? 1 / dbl_expo : dbl_expo;
 130  }