cgit.sxemacs.org Git - sxemacs/blob - src/ent/ent-int.c

   1 /*
   2   ent-int.c -- Ordinary Integers for SXEmacs
   3   Copyright (C) 2005, 2006 Sebastian Freundt
   4
   5   Author:  Sebastian Freundt
   6
   7 This file is part of SXEmacs
   8
   9 SXEmacs is free software: you can redistribute it and/or modify
  10 it under the terms of the GNU General Public License as published by
  11 the Free Software Foundation, either version 3 of the License, or
  12 (at your option) any later version.
  13
  14 SXEmacs is distributed in the hope that it will be useful,
  15 but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 GNU General Public License for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with this program.  If not, see <http://www.gnu.org/licenses/>. */
  21
  22
  23 #include <config.h>
  24 #include <limits.h>
  25 #include <math.h>
  26 #include "lisp.h"
  27 #include "sysproc.h"    /* For qxe_getpid */
  28
  29 #include "ent.h"
  30
  31 EMACS_INT Vmost_negative_int, Vmost_positive_int;
  32 Lisp_Object Qone;
  33
  34 \f
  35 static inline int
  36 ent_int_zerop(Lisp_Object l)
  37 {
  38         return (ent_int(l) == 0);
  39 }
  40 static inline int
  41 ent_int_onep(Lisp_Object l)
  42 {
  43         return (ent_int(l) == 1);
  44 }
  45 static inline int
  46 ent_int_unitp(Lisp_Object l)
  47 {
  48         EMACS_INT rl = ent_int(l);
  49         return (rl == 1 || rl == -1);
  50 }
  51
  52 static inline Lisp_Object
  53 ent_sum_INT_T(Lisp_Object l, Lisp_Object r)
  54 {
  55         return make_integer(ent_int(l) + ent_int(r));
  56 }
  57 static inline Lisp_Object
  58 ent_diff_INT_T(Lisp_Object l, Lisp_Object r)
  59 {
  60         return make_integer(ent_int(l) - ent_int(r));
  61 }
  62 static inline Lisp_Object
  63 ent_neg_INT_T(Lisp_Object l)
  64 {
  65         return make_integer(-ent_int(l));
  66 }
  67 static inline Lisp_Object
  68 ent_prod_INT_T(Lisp_Object l, Lisp_Object r)
  69 {
  70 /* Due to potential overflow, we compute using MP */
  71 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
  72         bigz bz;
  73         Lisp_Object result;
  74
  75         bigz_init(bz);
  76
  77         bigz_set_long(ent_scratch_bigz, ent_int(l));
  78         bigz_set_long(bz, ent_int(r));
  79         bigz_mul(ent_scratch_bigz, ent_scratch_bigz, bz);
  80         result = ent_mpz_downgrade_maybe(ent_scratch_bigz);
  81
  82         bigz_fini(bz);
  83         return result;
  84 #else
  85         return make_integer(ent_int(l) * ent_int(r));
  86 #endif
  87 }
  88 static inline Lisp_Object
  89 ent_div_INT_T(Lisp_Object l, Lisp_Object r)
  90 {
  91         if (ent_int(r) == 0) {
  92                 if (ent_int(l) > 0)
  93                         return make_indef(POS_INFINITY);
  94                 else if (ent_int(l) < 0)
  95                         return make_indef(NEG_INFINITY);
  96                 else
  97                         return make_indef(NOT_A_NUMBER);
  98         }
  99         return make_integer(ent_int(l)/ent_int(r));
 100 }
 101
 102 static inline Lisp_Object
 103 ent_inv_INT_T(Lisp_Object l)
 104 {
 105         if (ent_int(l) == 0) {
 106                 return make_indef(POS_INFINITY);
 107         }
 108         return make_integer(1L/ent_int(l));
 109 }
 110
 111 static inline Lisp_Object
 112 ent_rem_INT_T(Lisp_Object l, Lisp_Object r)
 113 {
 114         EMACS_INT rem;
 115
 116         if (ent_int(r) == 0) {
 117                 return Qzero;
 118         }
 119         rem = ent_int(l) % ent_int(r);
 120
 121         return make_int(rem);
 122 }
 123 static inline Lisp_Object
 124 ent_mod_INT_T(Lisp_Object l, Lisp_Object r)
 125 {
 126         EMACS_INT rem;
 127
 128         if (ent_int(r) == 0) {
 129                 return Qzero;
 130         }
 131         rem = ent_int(l) % ent_int(r);
 132
 133         /* If the "remainder" comes out with the wrong sign, fix it.  */
 134         if (ent_int(r) < 0 ? rem > 0 : rem < 0)
 135                 rem += ent_int(r);
 136
 137         return make_int(rem);
 138 }
 139
 140 static inline Lisp_Object
 141 ent_pow_INT_T_integer(Lisp_Object l, Lisp_Object r)
 142 {
 143         EMACS_INT retval;
 144         EMACS_INT x = ent_int(l);
 145         EMACS_INT y = ent_int(r);
 146
 147         if (y < 0) {
 148                 if (x == 1)
 149                         retval = 1;
 150                 else if (x == -1)
 151                         retval = (y & 1) ? -1 : 1;
 152                 else
 153                         retval = 0;
 154         } else {
 155                 retval = 1;
 156                 while (y > 0) {
 157                         if (y & 1)
 158                                 retval *= x;
 159                         x *= x;
 160                         y = (EMACS_UINT) y >> 1;
 161                 }
 162         }
 163         return make_int(retval);
 164 }
 165
 166 /* comparison relations */
 167 static inline int
 168 ent_lt_int(Lisp_Object l, Lisp_Object r)
 169 {
 170         return (ent_int(l) < ent_int(r));
 171 }
 172 static inline int
 173 ent_gt_int(Lisp_Object l, Lisp_Object r)
 174 {
 175         return (ent_int(l) > ent_int(r));
 176 }
 177 static inline int
 178 ent_eq_int(Lisp_Object l, Lisp_Object r)
 179 {
 180         return (ent_int(l) == ent_int(r));
 181 }
 182 static inline int
 183 ent_ne_int(Lisp_Object l, Lisp_Object r)
 184 {
 185         return (ent_int(l) != ent_int(r));
 186 }
 187
 188 \f
 189 static inline Lisp_Object
 190 ent_lift_INT_T_INT_T(Lisp_Object number, unsigned long SXE_UNUSED(precision))
 191 {
 192         return make_int(ent_int(number));
 193 }
 194
 195 static inline Lisp_Object
 196 ent_lift_INT_T(Lisp_Object number, ent_lift_args_t SXE_UNUSED(unused))
 197 {
 198         return make_int(ent_int(number));
 199 }
 200
 201 \f
 202 static inline void
 203 ent_int_nullary_optable_init(void)
 204 {
 205         Qzero = make_int(0);
 206         Qone = make_int(1);
 207         ent_nullop_register(ASE_NULLARY_OP_ZERO, INT_T, Qzero);
 208         ent_nullop_register(ASE_NULLARY_OP_ONE, INT_T, Qone);
 209 }
 210
 211 static inline void
 212 ent_int_unary_optable_init(void)
 213 {
 214         ent_unop_register(ASE_UNARY_OP_NEG, INT_T, ent_neg_INT_T);
 215         ent_unop_register(ASE_UNARY_OP_INV, INT_T, ent_inv_INT_T);
 216 }
 217
 218 static inline void
 219 ent_int_binary_optable_init(void)
 220 {
 221         ent_binop_register(ASE_BINARY_OP_SUM, INT_T, INT_T, ent_sum_INT_T);
 222         ent_binop_register(ASE_BINARY_OP_DIFF, INT_T, INT_T, ent_diff_INT_T);
 223         ent_binop_register(ASE_BINARY_OP_PROD, INT_T, INT_T, ent_prod_INT_T);
 224         ent_binop_register(ASE_BINARY_OP_DIV, INT_T, INT_T, ent_div_INT_T);
 225         ent_binop_register(ASE_BINARY_OP_QUO, INT_T, INT_T, ent_div_INT_T);
 226         ent_binop_register(ASE_BINARY_OP_REM, INT_T, INT_T, ent_rem_INT_T);
 227         ent_binop_register(ASE_BINARY_OP_MOD, INT_T, INT_T, ent_mod_INT_T);
 228         ent_binop_register(ASE_BINARY_OP_POW, INT_T, INT_T,
 229                            ent_pow_INT_T_integer);
 230 }
 231
 232 static inline void
 233 ent_int_unary_reltable_init(void)
 234 {
 235         ent_unrel_register(ASE_UNARY_REL_ZEROP, INT_T, ent_int_zerop);
 236         ent_unrel_register(ASE_UNARY_REL_ONEP, INT_T, ent_int_onep);
 237         ent_unrel_register(ASE_UNARY_REL_UNITP, INT_T, ent_int_unitp);
 238 }
 239
 240 static inline void
 241 ent_int_binary_reltable_init(void)
 242 {
 243         ent_binrel_register(ASE_BINARY_REL_LESSP,
 244                             INT_T, INT_T, ent_lt_int);
 245         ent_binrel_register(ASE_BINARY_REL_GREATERP,
 246                             INT_T, INT_T, ent_gt_int);
 247         ent_binrel_register(ASE_BINARY_REL_EQUALP,
 248                             INT_T, INT_T, ent_eq_int);
 249         ent_binrel_register(ASE_BINARY_REL_NEQP,
 250                             INT_T, INT_T, ent_ne_int);
 251 }
 252
 253 static inline void
 254 ent_int_lifttable_init(void)
 255 {
 256         ent_lift_register(INT_T, INT_T, ent_lift_INT_T);
 257         ent_lift_register(INDEF_T, INT_T, ent_lift_INDEF_T_COMPARABLE);
 258 }
 259
 260 void init_optables_INT_T(void)
 261 {
 262         ent_int_nullary_optable_init();
 263         ent_int_unary_optable_init();
 264         ent_int_binary_optable_init();
 265         ent_int_unary_reltable_init();
 266         ent_int_binary_reltable_init();
 267         ent_int_lifttable_init();
 268 }
 269
 270 void init_ent_int(void)
 271 {
 272 }
 273
 274 void syms_of_ent_int(void)
 275 {
 276 }
 277
 278 void vars_of_ent_int(void)
 279 {
 280         Vmost_negative_int = EMACS_INT_MIN;
 281         DEFVAR_CONST_INT("most-negative-fixnum", &Vmost_negative_int /*
 282 The (ordinary) integer closest in value to negative infinity.
 283                                                                    */);
 284
 285         Vmost_positive_int = EMACS_INT_MAX;
 286         DEFVAR_CONST_INT("most-positive-fixnum", &Vmost_positive_int /*
 287 The (ordinary) integer closest in value to positive infinity.
 288                                                                   */);
 289 }
 290
 291 /* ent-int.c ends here */