libguile/num2integral.i.c

   1 /* this file is #include'd (many times) by numbers.c */
   2
   3 ITYPE
   4 NUM2INTEGRAL (SCM num, unsigned long int pos, const char *s_caller)
   5 {
   6   if (SCM_INUMP (num))
   7     { /* immediate */
   8
   9       scm_t_signed_bits n = SCM_INUM (num);
  10
  11 #ifdef UNSIGNED
  12       if (n < 0)
  13         scm_out_of_range (s_caller, num);
  14 #endif
  15
  16       if (sizeof (ITYPE) >= sizeof (scm_t_signed_bits))
  17         /* can't fit anything too big for this type in an inum
  18            anyway */
  19         return (ITYPE) n;
  20       else
  21         { /* an inum can be out of range, so check */
  22           if (n > (scm_t_signed_bits)MAX_VALUE
  23 #ifndef UNSIGNED
  24               || n < (scm_t_signed_bits)MIN_VALUE
  25 #endif
  26               )
  27             scm_out_of_range (s_caller, num);
  28           else
  29             return (ITYPE) n;
  30         }
  31     }
  32   else if (SCM_BIGP (num))
  33     { /* bignum */
  34
  35       ITYPE res = 0;
  36       size_t l;
  37
  38 #ifdef UNSIGNED
  39       if (SCM_BIGSIGN (num))
  40         scm_out_of_range (s_caller, num);
  41 #endif
  42
  43       for (l = SCM_NUMDIGS (num); l--;)
  44         {
  45           ITYPE new = SCM_I_BIGUP (ITYPE, res) + SCM_BDIGITS (num)[l];
  46           if (new < res
  47 #ifndef UNSIGNED
  48               && !(new == MIN_VALUE && l == 0)
  49 #endif
  50               )
  51             scm_out_of_range (s_caller, num);
  52           res = new;
  53         }
  54
  55 #ifdef UNSIGNED
  56       return res;
  57 #else
  58       if (SCM_BIGSIGN (num))
  59         {
  60           res = -res;
  61           if (res <= 0)
  62             return res;
  63           else
  64             scm_out_of_range (s_caller, num);
  65         }
  66       else
  67         {
  68           if (res >= 0)
  69             return res;
  70           else
  71             scm_out_of_range (s_caller, num);
  72         }
  73 #endif
  74     }
  75   else
  76     scm_wrong_type_arg (s_caller, pos, num);
  77 }
  78
  79 SCM
  80 INTEGRAL2NUM (ITYPE n)
  81 {
  82   /* Determine at compile time whether we need to porferm the FIXABLE
  83      test or not.  This is not done to get more optimal code out of
  84      the compiler (it can figure this out on its already), but to
  85      avoid a spurious warning.
  86   */
  87
  88 #ifdef NEED_CHECK
  89 #undef NEED_CHECK
  90 #endif
  91
  92 #ifdef NO_PREPRO_MAGIC
  93 #define NEED_CHECK
  94 #else
  95 #ifdef UNSIGNED
  96   /*#if MAX_VALUE > SCM_MOST_POSITIVE_FIXNUM*/
  97 #define NEED_CHECK
  98   /*#endif*/
  99 #else
 100   /*#if MIN_VALUE<SCM_MOST_NEGATIVE_FIXNUM || MAX_VALUE>SCM_MOST_POSITIVE_FIXNUM*/
 101 #define NEED_CHECK
 102   /*#endif*/
 103 #endif
 104 #endif
 105
 106 #ifndef UNSIGNED
 107 #ifdef NEED_CHECK
 108   if (SCM_FIXABLE (n))
 109 #endif
 110 #else
 111 #ifdef NEED_CHECK
 112   if (SCM_POSFIXABLE (n))
 113 #endif
 114 #endif
 115     return SCM_MAKINUM ((scm_t_signed_bits) n);
 116
 117 #undef NEED_CHECK
 118
 119 #ifdef SCM_BIGDIG
 120   return INTEGRAL2BIG (n);
 121 #else
 122   return scm_make_real ((double) n);
 123 #endif
 124 }
 125
 126 #ifdef SCM_BIGDIG
 127
 128 SCM
 129 INTEGRAL2BIG (ITYPE n)
 130 {
 131   SCM res;
 132   int neg_p;
 133   unsigned int n_digits;
 134   size_t i;
 135   SCM_BIGDIG *digits;
 136
 137 #ifndef UNSIGNED
 138   neg_p = (n < 0);
 139   if (neg_p) n = -n;
 140 #else
 141   neg_p = 0;
 142 #endif
 143
 144 #ifndef UNSIGNED
 145   if (n == MIN_VALUE)
 146     /* special case */
 147     n_digits =
 148       (sizeof (ITYPE) + sizeof (SCM_BIGDIG) - 1) / sizeof (SCM_BIGDIG);
 149   else
 150 #endif
 151     {
 152       ITYPE tn;
 153       for (tn = n, n_digits = 0;
 154            tn;
 155            ++n_digits, tn = SCM_BIGDN (tn))
 156         ;
 157     }
 158
 159   i = 0;
 160   res = scm_i_mkbig (n_digits, neg_p);
 161   digits = SCM_BDIGITS (res);
 162
 163   while (i < n_digits)
 164     {
 165       digits[i++] = SCM_BIGLO (n);
 166       n = SCM_BIGDN (n);
 167     }
 168
 169   return res;
 170 }
 171
 172 #endif
 173
 174 /* clean up */
 175 #undef INTEGRAL2NUM
 176 #undef INTEGRAL2BIG
 177 #undef NUM2INTEGRAL
 178 #undef UNSIGNED
 179 #undef ITYPE
 180 #undef MIN_VALUE
 181 #undef MAX_VALUE
 182 #undef NO_PREPRO_MAGIC
 183
 184 /*
 185   Local Variables:
 186   c-file-style: "gnu"
 187   End:
 188 */