Algol 68 Genie

rts-mach.c

     
   1  //! @file rts-mach.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-2024 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  //! Machine parameters.
  25  
  26  // These routines are variants/extensions of SLATEC routines.
  27  // SLATEC Common Mathematical Library is a FORTRAN 77 library of general purpose
  28  // mathematical and statistical routines, developed at US Government research 
  29  // laboratories and therefore public domain software. 
  30  // Repository: http://www.netlib.org/slatec/
  31  
  32  #include "a68g.h"
  33  #include "a68g-prelude.h"
  34  #include "a68g-genie.h"
  35  #include "a68g-numbers.h"
  36  #include "a68g-double.h"
  37  
  38  int a68g_i32mach (int i)
  39  {
  40  // Based SLATEC routine I1MACH.
  41    switch (i) {
  42  // i32mach(1) = the standard input unit. 
  43      case 1: {
  44       return STDIN_FILENO;
  45        }
  46  // i32mach(2) = the standard output unit. 
  47      case 2: {
  48       return STDOUT_FILENO;
  49        }
  50  // i32mach(3) = the standard punch unit. 
  51      case 3: {
  52       return STDOUT_FILENO;
  53        }
  54  // i32mach(4) = the standard error message unit. 
  55      case 4: {
  56       return STDERR_FILENO;
  57        }
  58  // i32mach(5) = the number of bits per int storage unit. 
  59      case 5: {
  60       return CHAR_BIT * sizeof (int);
  61        }
  62  // i32mach(6) = the number of characters per int storage unit. 
  63      case 6: {
  64       return sizeof (int);
  65        }
  66  // i32mach(7) = a, the base. 
  67      case 7: {
  68       return 2;
  69        }
  70  // i32mach(8) = s, the number of base-a digits. 
  71      case 8: {
  72       return CHAR_BIT * sizeof (int) - 1;
  73        }
  74  // i32mach(9) = a**s - 1, the largest magnitude. 
  75      case 9: {
  76       return INT_MAX;
  77        }
  78  // i32mach(10) = b, the base. 
  79      case 10: {
  80       return FLT_RADIX;
  81        }
  82  // i32mach(11) = t, the number of base-b digits. 
  83      case 11: {
  84       return FLT_MANT_DIG;
  85        }
  86  // i32mach(12) = emin, the smallest exponent e. 
  87      case 12: {
  88       return FLT_MIN_EXP;
  89        }
  90  // i32mach(13) = emax, the largest exponent e. 
  91      case 13: {
  92       return FLT_MAX_EXP;
  93        }
  94  // i32mach(14) = t, the number of base-b digits. 
  95      case 14: {
  96       return DBL_MANT_DIG;
  97        }
  98  // i32mach(15) = emin, the smallest exponent e. 
  99      case 15: {
 100      return DBL_MIN_EXP;
 101        }
 102  // i32mach(16) = emax, the largest exponent e. 
 103      case 16: {
 104      return DBL_MAX_EXP;
 105        }
 106      default: {
 107      return 0;
 108        }
 109      }
 110  }
 111  
 112  //! @brief PROC i32mach (INT) INT
 113  
 114  void genie_i32mach (NODE_T *p)
 115  {
 116    A68_INT i;
 117    POP_OBJECT (p, &i, A68_INT);
 118    PUSH_VALUE (p, a68g_i32mach (VALUE (&i)), A68_INT);
 119  }
 120  
 121  REAL_T a68g_r64mach (int i)
 122  {
 123  // Based SLATEC routine R1MACH.
 124    switch (i) {
 125  // r64mach(1) = b**(emin-1), the smallest positive magnitude. 
 126      case 1: {
 127      return DBL_MIN;
 128        }
 129  // r64mach(2) = b**emax*(1 - b**(-t)), the largest magnitude. 
 130      case 2: {
 131      return DBL_MAX;
 132        }
 133  // r64mach(3) = b**(-t), the smallest relative spacing. 
 134      case 3: {
 135      return 0.5 * DBL_EPSILON;
 136        }
 137  // r64mach(4) = b**(1-t), the largest relative spacing. 
 138      case 4: {
 139      return DBL_EPSILON;
 140        }
 141  // r64mach(5) = log10(b) 
 142      case 5: {
 143      return CONST_M_LOG10_2;
 144        }
 145  // r64mach(6), the minimum exponent in base 10.
 146      case 6: {
 147          return DBL_MIN_10_EXP;
 148        }
 149  // r64mach(7), the maximum exponent in base 10.
 150      case 7: {
 151          return DBL_MAX_10_EXP;
 152        }
 153  // r64mach(8), the number of significant digits in base 10.
 154      case 8: {
 155          return DBL_DIG;
 156        }
 157  // r64mach(9), the number of mantissa bits.
 158      case 9: {
 159          return DBL_MANT_DIG;
 160        }
 161      default: {
 162      return 0.0;
 163        }
 164      }
 165  }
 166  
 167  //! @brief PROC r64mach (INT) REAL
 168  
 169  void genie_r64mach (NODE_T *p)
 170  {
 171    A68_INT i;
 172    POP_OBJECT (p, &i, A68_INT);
 173    PUSH_VALUE (p, a68g_r64mach (VALUE (&i)), A68_REAL);
 174  }
 175  
 176  #if (A68_LEVEL >= 3)
 177  
 178  INT_T a68g_i64mach (int i)
 179  {
 180  // Based SLATEC routine I1MACH.
 181    switch (i) {
 182  // i64mach(6) = the number of characters per int storage unit. 
 183      case 6: {
 184      return sizeof (INT_T);
 185        }
 186  // i64mach(9) = a**s - 1, the largest magnitude. 
 187      case 9: {
 188      return LLONG_MAX;
 189        }
 190      default: {
 191      return a68g_i32mach (i);
 192        }
 193      }
 194  }
 195  
 196  //! @brief PROC i64mach (INT) INT
 197  
 198  void genie_i64mach (NODE_T *p)
 199  {
 200    A68_INT i;
 201    POP_OBJECT (p, &i, A68_INT);
 202    PUSH_VALUE (p, a68g_i64mach (VALUE (&i)), A68_INT);
 203  }
 204  
 205  DOUBLE_T a68g_r128mach (int i)
 206  {
 207  // Based SLATEC routine D1MACH.
 208    switch (i) {
 209  // r128mach(1) = b**(emin-1), the smallest positive magnitude. 
 210      case 1: {
 211      return FLT128_MIN;
 212        }
 213  // r128mach(2) = b**emax*(1 - b**(-t)), the largest magnitude. 
 214      case 2: {
 215      return FLT128_MAX;
 216        }
 217  // r128mach(3) = b**(-t), the smallest relative spacing. 
 218      case 3: {
 219      return 0.5 * FLT128_EPSILON;
 220        }
 221  // r128mach(4) = b**(1-t), the largest relative spacing. 
 222      case 4: {
 223      return FLT128_EPSILON;
 224        }
 225  // r128mach(5) = log10(b) 
 226      case 5: {
 227      return CONST_M_LOG10_2_Q;
 228        }
 229  // r128mach(6), the minimum exponent in base 10.
 230      case 6: {
 231          return FLT128_MIN_10_EXP;
 232        }
 233  // r128mach(7), the maximum exponent in base 10.
 234      case 7: {
 235          return FLT128_MAX_10_EXP;
 236        }
 237  // r128mach(8), the number of significant digits in base 10.
 238      case 8: {
 239          return FLT128_DIG;
 240        }
 241  // r128mach(9), the number of mantissa bits.
 242      case 9: {
 243          return FLT128_MANT_DIG;
 244        }
 245      default: {
 246      return 0.0;
 247        }
 248      }
 249  }
 250  
 251  //! @brief PROC r128mach (INT) REAL
 252  
 253  void genie_r128mach (NODE_T *p)
 254  {
 255    A68_INT i;
 256    POP_OBJECT (p, &i, A68_INT);
 257    PUSH_VALUE (p, dble (a68g_r128mach (VALUE (&i))), A68_LONG_REAL);
 258  }
 259  
 260  #endif
Deze website is gearchiveerd door de KB, nationale bibliotheek.

This website is archived by the National Library of the Netherlands.