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

   1 /*
   2   ent.c -- Numeric types for SXEmacs
   3   Copyright (C) 2004 Jerry James
   4   Copyright (C) 2004, 2005, 2006 Sebastian Freundt
   5
   6   XEmacs Author:  Jerry James
   7   Author: Sebastian Freundt
   8   Backport:  Sebastian Freundt
   9
  10 This file is part of SXEmacs
  11
  12 SXEmacs is free software: you can redistribute it and/or modify
  13 it under the terms of the GNU General Public License as published by
  14 the Free Software Foundation, either version 3 of the License, or
  15 (at your option) any later version.
  16
  17 SXEmacs is distributed in the hope that it will be useful,
  18 but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 GNU General Public License for more details.
  21
  22 You should have received a copy of the GNU General Public License
  23 along with this program.  If not, see <http://www.gnu.org/licenses/>. */
  24
  25
  26 #include <config.h>
  27 #include <limits.h>
  28 #include "lisp.h"
  29 #include "dynacat.h"
  30
  31 #include "ent.h"
  32
  33 Lisp_Object Qrationalp, Qrealp, Qcomparablep;
  34 Lisp_Object Qarchimedeanp, Qnonarchimedeanp;
  35 Lisp_Object Qcomplexp, Qgaussianp;
  36
  37 /* errors */
  38 Lisp_Object Qoperation_error, Qrelation_error, Qvaluation_error;
  39
  40 Lisp_Object Vread_real_as;
  41 Fixnum default_real_precision;
  42 Fixnum max_real_precision;
  43 static Lisp_Object Qunsupported_type;
  44 static int number_initialized;
  45 Lisp_Object Qoptable_index;
  46
  47 #define PREC_D2B_CONST          ((double)3.321928094887362)
  48 #define PREC_B2D_CONST          ((double)0.301029995663981)
  49
  50 #define PREC_D2B_UP(x)          ((unsigned long)(PREC_D2B_CONST*(x))+1)
  51 #define PREC_D2B_DOWN(x)        ((unsigned long)(PREC_D2B_CONST*(x)))
  52 #define PREC_B2D_UP(x)          ((unsigned long)(PREC_B2D_CONST*(x))+1)
  53 #define PREC_B2D_DOWN(x)        ((unsigned long)(PREC_B2D_CONST*(x)))
  54
  55 #define PREC_MIN                PREC_D2B_UP(1)
  56
  57
  58 \f
  59 /************************* Big Rational Integers ****************************/
  60 Lisp_Object Qbigzp;
  61 Lisp_Object Qbignump;           /* to be compatible to XE 21.5 */
  62
  63 DEFUN ("bignump", Fbignump, 1, 1, 0, /*
  64 Return t if OBJECT is a bignum, nil otherwise.
  65 */
  66        (object))
  67 {
  68         return BIGZP (object) ? Qt : Qnil;
  69 }
  70
  71 DEFUN ("bigzp", Fbigzp, 1, 1, 0, /*
  72 Return t if OBJECT is a bigz, nil otherwise.
  73 */
  74        (object))
  75 {
  76         return BIGZP (object) ? Qt : Qnil;
  77 }
  78
  79 \f
  80 /********************************* Integers *********************************/
  81 /*  To remember: integers are the union of all integer-like types.          */
  82 DEFUN ("integerp", Fintegerp, 1, 1, 0, /*
  83 Return t if OBJECT is an integer, nil otherwise.
  84 */
  85        (object))
  86 {
  87         return INTEGERP(object) ? Qt : Qnil;
  88 }
  89
  90 DEFUN ("evenp", Fevenp, 1, 1, 0, /*
  91 Return t if INTEGER is even, nil otherwise.
  92 */
  93        (integer))
  94 {
  95         if (INDEFP(integer))
  96                 return Qnil;
  97
  98         CONCHECK_INTEGER(integer);
  99 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 100         if (BIGZP(integer))
 101                 return bigz_evenp(XBIGZ_DATA(integer)) ? Qt : Qnil;
 102 #endif
 103         if (INTP(integer))
 104                 return (XTYPE(integer) == Lisp_Type_Int_Even) ? Qt : Qnil;
 105
 106         /* big else case */
 107         return Qnil;
 108 }
 109
 110 DEFUN ("oddp", Foddp, 1, 1, 0, /*
 111 Return t if INTEGER is odd, nil otherwise.
 112 */
 113        (integer))
 114 {
 115         if (INDEFP(integer))
 116                 return Qnil;
 117
 118         CONCHECK_INTEGER (integer);
 119 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 120         if (BIGZP(integer))
 121                 return bigz_oddp(XBIGZ_DATA(integer)) ? Qt : Qnil;
 122 #endif
 123         if (INTP(integer))
 124                 return (XTYPE(integer) == Lisp_Type_Int_Odd) ? Qt : Qnil;
 125
 126         /* big else case */
 127         return Qnil;
 128 }
 129
 130 \f
 131 /************************** Rational Integer Fractions **********************/
 132 /* bigq objects are derived from quotients of bigz objects.                 */
 133 /* In XE 21.5 bigq is called ratio.                                         */
 134 Lisp_Object Qbigqp;
 135 Lisp_Object Qratiop;            /* to be compatible to XE 21.5 */
 136
 137 DEFUN ("ratiop", Fratiop, 1, 1, 0, /*
 138 Return t if OBJECT is a ratio, nil otherwise.
 139 */
 140        (object))
 141 {
 142         return BIGQP(object) ? Qt : Qnil;
 143 }
 144
 145 DEFUN ("bigqp", Fbigqp, 1, 1, 0, /*
 146 Return t if OBJECT is a bigq, nil otherwise.
 147 */
 148        (object))
 149 {
 150         return BIGQP(object) ? Qt : Qnil;
 151 }
 152
 153 \f
 154 /********************************* Rationals ********************************/
 155 DEFUN ("rationalp", Frationalp, 1, 1, 0, /*
 156 Return t if OBJECT is a rational (i.e. a rational integer or a rational
 157 quotient), nil otherwise.
 158 */
 159        (object))
 160 {
 161         return RATIONALP(object) ? Qt : Qnil;
 162 }
 163
 164 DEFUN ("numerator", Fnumerator, 1, 1, 0, /*
 165 Return the numerator of the canonical form of RATIONAL.
 166 If RATIONAL is an integer, RATIONAL is returned.
 167 */
 168        (rational))
 169 {
 170         CONCHECK_RATIONAL(rational);
 171 #if defined HAVE_MPQ && defined WITH_GMP
 172         return BIGQP(rational)
 173                 ? make_bigz_bz(XBIGQ_NUMERATOR(rational))
 174                 : rational;
 175 #else
 176         return rational;
 177 #endif
 178 }
 179
 180 DEFUN ("denominator", Fdenominator, 1, 1, 0, /*
 181 Return the denominator of the canonical form of RATIONAL.
 182 If RATIONAL is an integer, 1 is returned.
 183 */
 184        (rational))
 185 {
 186         CONCHECK_RATIONAL(rational);
 187 #if defined HAVE_MPQ && defined WITH_GMP
 188         return BIGQP(rational)
 189                 ? make_bigz_bz(XBIGQ_DENOMINATOR(rational))
 190                 : make_int(1);
 191 #else
 192         return make_int(1);
 193 #endif
 194 }
 195
 196 \f
 197 /********************************** Bigfs ***********************************/
 198 Lisp_Object Qbigfp;
 199 Lisp_Object Qbigfloatp;         /* to be compatible to XE 21.5 */
 200
 201 DEFUN ("bigfloatp", Fbigfloatp, 1, 1, 0, /*
 202 Return t if OBJECT is a bigfloat, nil otherwise.
 203 */
 204        (object))
 205 {
 206         return BIGFP(object) ? Qt : Qnil;
 207 }
 208
 209 DEFUN ("bigfp", Fbigfp, 1, 1, 0, /*
 210 Return t if OBJECT is a bigf, nil otherwise.
 211 */
 212        (object))
 213 {
 214         return BIGFP(object) ? Qt : Qnil;
 215 }
 216
 217 \f
 218 /********************************* Floats ***********************************/
 219 #ifdef HAVE_FPFLOAT
 220 /* I wanted to define the lrecord implementation here, but that breaks at
 221  * Steve's site, so ... :(
 222  */
 223 #endif
 224
 225 \f
 226 /********************************** Bigfrs **********************************/
 227
 228 #ifndef MPFR_PREC_MIN
 229 #define MPFR_PREC_MIN 2UL
 230 #endif
 231 #ifndef MPFR_PREC_MAX
 232 #define MPFR_PREC_MAX 1024UL
 233 #endif
 234
 235 Lisp_Object Qbigfrp;
 236
 237 DEFUN ("bigfrp", Fbigfrp, 1, 1, 0, /*
 238 Return t if OBJECT is a bigfr, nil otherwise.
 239 */
 240        (object))
 241 {
 242         return BIGFRP(object) ? Qt : Qnil;
 243 }
 244
 245 \f
 246 /********************************** Reals ***********************************/
 247 DEFUN ("realp", Frealp, 1, 1, 0, /*
 248 Return t if OBJECT is a real, nil otherwise.
 249 */
 250        (object))
 251 {
 252         return REALP(object) ? Qt : Qnil;
 253 }
 254
 255 static int
 256 default_real_precision_changed (Lisp_Object sym, Lisp_Object *val,
 257                                 Lisp_Object in_object,
 258                                 int flags)
 259 {
 260         unsigned long prec;
 261
 262         CONCHECK_INTEGER(*val);
 263         prec = internal_get_precision(*val);
 264 #if defined HAVE_MPF && defined WITH_GMP
 265         if (prec != 0UL)
 266                 bigf_set_default_prec(prec);
 267 #endif
 268 #if defined HAVE_MPFR && defined WITH_MPFR
 269         if (prec != 0UL)
 270                 bigfr_set_default_prec(prec);
 271 #endif
 272         return 0;
 273
 274         /* less warnings */
 275         if (sym == Qnil);
 276         if (in_object == Qnil);
 277         if (flags);
 278 }
 279
 280 DEFUN("real", Freal, 1, 2, 0,   /*
 281 Return the real number numerically equal to NUMBER with
 282 respect to the variable `read-real-as'.
 283 If optional argument PRECISION is non-nil, its value
 284 \(an integer\) is used as precision.
 285 */
 286       (number, precision))
 287 {
 288         if (Vread_real_as == Qbigfr) {
 289 #if defined HAVE_MPFR && defined WITH_MPFR
 290                 return Fcoerce_number(number, Qbigfr, precision);
 291 #else  /* !HAVE_MPFR */
 292                 ;
 293 #endif  /* HAVE_MPFR */
 294         }
 295
 296         if (Vread_real_as == Qbigf) {
 297 #if defined HAVE_MPF && defined WITH_GMP
 298                 return Fcoerce_number(number, Qbigf, precision);
 299 #else  /* !HAVE_MPF */
 300                 ;
 301 #endif  /* HAVE_MPF */
 302         }
 303
 304         /* fallback to 'float */
 305         return Fcoerce_number(number, Qfloat, precision);
 306 }
 307
 308 \f
 309 /******************************** Comparables *******************************/
 310 DEFUN ("comparablep", Fcomparablep, 1, 1, 0, /*
 311 Return t if OBJECT is a comparable number, nil otherwise.
 312
 313 We call a number comparable if there exists a total (archimedean)
 314 order on the underlying structure.
 315 */
 316        (object))
 317 {
 318         return COMPARABLEP(object) ? Qt : Qnil;
 319 }
 320
 321
 322 \f
 323 /********************************** Biggs ***********************************/
 324 Lisp_Object Qbiggp;
 325
 326 DEFUN ("biggp", Fbiggp, 1, 1, 0, /*
 327 Return t if OBJECT is a bigg (a gaussian number), nil otherwise.
 328 */
 329        (object))
 330 {
 331         return BIGGP(object) ? Qt : Qnil;
 332 }
 333
 334 \f
 335 /********************************** Bigcs ***********************************/
 336 Lisp_Object Qbigcp;
 337
 338 DEFUN ("bigcp", Fbigcp, 1, 1, 0, /*
 339 Return t if OBJECT is a bigc, nil otherwise.
 340 */
 341        (object))
 342 {
 343         return BIGCP(object) ? Qt : Qnil;
 344 }
 345
 346 \f
 347 /******************************* Complex nums *******************************/
 348 DEFUN ("complexp", Fcomplexp, 1, 1, 0, /*
 349 Return t if OBJECT is a complex number (i.e. either a bigc
 350 or a bigg), nil otherwise.
 351 */
 352        (object))
 353 {
 354         return COMPLEXP(object) ? Qt : Qnil;
 355 }
 356
 357
 358 \f
 359 /********************************** Quaterns ********************************/
 360 Lisp_Object Qquaternp;
 361
 362 DEFUN ("quaternp", Fquaternp, 1, 1, 0, /*
 363 Return t if OBJECT is a quaternion, nil otherwise.
 364 */
 365        (object))
 366 {
 367         return QUATERNP(object) ? Qt : Qnil;
 368 }
 369
 370
 371 \f
 372 /******************************* Archimedeans *******************************/
 373 DEFUN ("archimedeanp", Farchimedeanp, 1, 1, 0, /*
 374 Return t if OBJECT is a number with an archimedean valuation, nil otherwise.
 375 */
 376        (object))
 377 {
 378         return ARCHIMEDEANP(object) ? Qt : Qnil;
 379 }
 380
 381 \f
 382 /***************************** Non-Archimedeans *****************************/
 383 DEFUN ("nonarchimedeanp", Fnonarchimedeanp, 1, 1, 0, /*
 384 Return t if OBJECT is a number with a non-archimedean valuation, nil
 385 otherwise.
 386 */
 387        (object))
 388 {
 389         return NONARCHIMEDEANP(object) ? Qt : Qnil;
 390 }
 391
 392 \f
 393 /******************************** Indefinite Symbols ************************/
 394 Lisp_Object Qinfinityp, Qindefinitep;
 395
 396 DEFUN("indefinitep", Findefinitep, 1, 1, 0, /*
 397 Return t if OBJECT is an indefinite symbol, nil otherwise.
 398 */
 399       (object))
 400 {
 401         return INDEFP(object) ? Qt : Qnil;
 402 }
 403
 404 DEFUN ("infinityp", Finfinityp, 1, 1, 0, /*
 405 Return t if OBJECT is a form of infinity, nil otherwise.
 406 */
 407        (object))
 408 {
 409         return INFINITYP(object) ? Qt : Qnil;
 410 }
 411
 412 \f
 413 /********************************* Numbers **********************************/
 414 DEFUN ("canonicalize-number", Fcanonicalize_number, 1, 1, 0, /*
 415 Return the canonical form of NUMBER.  DEPRECATED FUNCTION.
 416 */
 417        (number))
 418 {
 419         /* The tests should go in order from larger, more expressive, or more
 420            complex types to smaller, less expressive, or simpler types so that a
 421            number can cascade all the way down to the simplest type if
 422            appropriate. */
 423 #if defined HAVE_MPQ && defined WITH_GMP
 424         if (BIGQP(number))
 425                 return ent_mpq_downgrade_maybe(XBIGQ_DATA(number));
 426 #endif
 427 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 428         if (BIGZP(number))
 429                 return ent_mpz_downgrade_maybe(XBIGZ_DATA(number));
 430 #endif
 431 #if defined HAVE_MPFR && defined WITH_MPFR
 432         if (BIGFRP(number))
 433                 return ent_mpfr_wipe_indef(XBIGFR_DATA(number));
 434 #endif
 435         return number;
 436 }
 437
 438 /* new ase optable magic */
 439 static dllist_t ase_optable_freelist;
 440
 441 static inline void
 442 ase_optable_freelist_init(void)
 443 {
 444         long int i;
 445         ase_optable_freelist = make_noseeum_dllist();
 446         for (i = 0; i < lrecord_first_ent_type; i++) {
 447                 dllist_append(ase_optable_freelist, (void*)i);
 448         }
 449 }
 450
 451 int ase_optable_add(Lisp_Object typesym)
 452 {
 453         /* TYPESYM should be a symbol as used in dynacats */
 454         long int *foo = dllist_pop_car(ase_optable_freelist);
 455         long int idx = (long int)foo;
 456         Fput(typesym, Qoptable_index, make_int(idx));
 457         return idx;
 458 }
 459
 460 void ase_optable_del(Lisp_Object typesym)
 461 {
 462         /* TYPESYM should be a symbol as used in dynacats */
 463         long int idx = (long int)ase_optable_index_typesym(typesym);
 464         dllist_append(ase_optable_freelist, (void*)idx);
 465         return;
 466 }
 467
 468 int ase_optable_index(Lisp_Object arg)
 469 {
 470         switch ((unsigned int)XTYPE(arg)) {
 471         case Lisp_Type_Record: {
 472                 enum lrecord_type type =
 473                         XRECORD_LHEADER_IMPLEMENTATION(arg)->lrecord_type_index;
 474
 475                 switch ((unsigned int)type) {
 476                 case lrecord_type_marker:
 477                         return INT_T;
 478                 case lrecord_type_dynacat:
 479                         assert(SYMBOLP(XDYNACAT_TYPE(arg)));
 480                         /* must be an dynacat */
 481                         /* now we've got two options, either compute a
 482                          * hash-value from the symbol's address
 483                          * or store a cookie in the plist of the symbol
 484                          * for the moment, we prefer the latter option
 485                          */
 486                         return ase_optable_index_typesym(XDYNACAT_TYPE(arg));
 487                 default:
 488                         return type;
 489                 }
 490         }
 491         default:
 492                 return INT_T;
 493         }
 494         return -1; /* Should not reach here */
 495 }
 496
 497 int
 498 ase_optable_index_typesym(Lisp_Object typesym)
 499 {
 500         Lisp_Object idx = Fget(typesym, Qoptable_index, Qnil);
 501         assert(INTEGERP(idx));
 502         return XINT(idx);
 503 }
 504
 505 /* categorial subtleties */
 506 dllist_t ase_empty_sets = 0;
 507 Lisp_Object Qase_empty_sets;
 508
 509 \f
 510 #if 0
 511 inline Lisp_Object
 512 ent_normalise_number(Lisp_Object number)
 513 {
 514         if (CHARP(number))
 515                 return make_int(XCHAR(number));
 516         else if (MARKERP(number))
 517                 return make_int(marker_position(number));
 518
 519         return number;
 520 }
 521 #endif
 522
 523 unsigned long ent_normalise_precision(unsigned long precision)
 524 {
 525         /* MPFR will slaughter us when we pass a precision < MPFR_PREC_MIN */
 526         if (precision < MPFR_PREC_MIN)
 527                 return default_real_precision;
 528         if (precision > MPFR_PREC_MAX)
 529                 return max_real_precision;
 530
 531         return precision;
 532 }
 533
 534 /* Convert NUMBER to type TYPE.  If TYPE is BIGF_T then use the indicated
 535    PRECISION; otherwise, PRECISION is ignored. */
 536 static Lisp_Object
 537 internal_coerce_number (Lisp_Object o,
 538                         ase_object_type_t type,
 539                         unsigned long precision)
 540 {
 541         struct ent_lift_args_s la;
 542
 543         la.precision = ent_normalise_precision(precision);
 544
 545         return ent_lift(o, type, &la);
 546 }
 547
 548 \f
 549 unsigned long
 550 internal_get_precision(Lisp_Object precision)
 551 {
 552         unsigned long susp_prec = 0;
 553
 554         if (NILP(precision) && default_real_precision > 0) {
 555                 susp_prec = default_real_precision;
 556         } else if (INTP(precision)) {
 557                 susp_prec = XUINT(precision);
 558 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 559         } else if (BIGZP(precision)) {
 560                 if (!bigz_fits_ulong_p(XBIGZ_DATA(precision)))
 561                         susp_prec = max_real_precision;
 562                 else
 563                         susp_prec = bigz_to_ulong(XBIGZ_DATA(precision));
 564 #endif
 565         } else {
 566                 susp_prec = default_real_precision;
 567         }
 568
 569         /* final comparison */
 570         if (susp_prec < MPFR_PREC_MIN)
 571                 return MPFR_PREC_MIN;
 572         else if (susp_prec > MPFR_PREC_MAX)
 573                 return MPFR_PREC_MAX;
 574         else
 575                 return susp_prec;
 576 }
 577
 578 DEFUN("coerce-number", Fcoerce_number, 2, 3, 0, /*
 579 Convert NUMBER to the indicated type, possibly losing information.
 580 See `coerce'.
 581
 582 TYPE is one of the symbols:
 583 - 'fixnum or 'int     to convert to built-in integers
 584 - 'bigz or 'bignum    to convert to bigz integers
 585 - 'integer            to convert to the most suitable type out of
 586                       'bigz or 'int
 587
 588 - 'bigq or 'ratio     to convert to bigq fractions
 589 - 'rational           to convert to the most suitable type out of
 590                       'bigq, 'bigz or 'int
 591
 592 - 'float              to convert to built-in floats
 593 - 'bigf or 'bigfloat  to convert to bigf floats
 594 - 'bigfr              to convert to bigfr floats
 595 - 'real               to convert to the type indicated by
 596                       `read-real-as' with a fallback to 'float
 597
 598 - 'bigg               to convert to a Gaussian
 599 - 'bigc               to convert to a bigc complex number
 600
 601 - 'quatern            to convert to a Quaternion
 602
 603 NOTE: Not all of these types may be supported.
 604
 605 PRECISION is the number of bits of precision to use when converting to
 606 reals; it is ignored otherwise.  If nil, the default precision is used.
 607
 608 Note that some conversions lose information.  No error is signaled in such
 609 cases; the information is silently lost.
 610 */
 611        (number, type, precision))
 612 {
 613         struct ent_lift_args_s la;
 614
 615         CHECK_SYMBOL(type);
 616
 617         if (EQ(type, Qint) || EQ(type, Qfixnum))
 618                 return internal_coerce_number(number, INT_T, 0UL);
 619         else if (EQ(type, Qinteger)) {
 620                 /* If bignums are available, we always convert to one first,
 621                    then downgrade to a int if possible. */
 622 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 623                 return Fcanonicalize_number(
 624                         ent_lift(number, BIGZ_T, NULL));
 625 #else
 626                 return ent_lift(number, INT_T, NULL);
 627 #endif  /* HAVE_MPZ */
 628         }
 629 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 630         else if (EQ(type, Qbigz) || EQ(type, Qbignum)) {
 631                 /* always convert to bigz */
 632                 return ent_lift(number, BIGZ_T, NULL);
 633         }
 634 #endif
 635 #if defined HAVE_MPQ && defined WITH_GMP
 636         else if (EQ(type, Qrational)) {
 637                 /* convert to bigq and canonicalise */
 638                 return Fcanonicalize_number(
 639                         ent_lift(number, BIGQ_T, NULL));
 640
 641         } else if (EQ(type, Qbigq) || EQ(type, Qratio)) {
 642                 /* always convert to bigq */
 643                 return ent_lift(number, BIGQ_T, NULL);
 644         }
 645 #endif  /* HAVE_MPQ */
 646 #ifdef HAVE_FPFLOAT
 647         else if (EQ(type, Qfloat))
 648                 return ent_lift(number, FLOAT_T, NULL);
 649 #endif
 650 #if defined HAVE_MPF && defined WITH_GMP
 651         else if (EQ(type, Qbigf) || EQ(type, Qbigfloat)) {
 652                 la.precision = internal_get_precision(precision);
 653                 return ent_lift(number, BIGF_T, &la);
 654         }
 655 #endif /* HAVE_MPF */
 656 #if defined HAVE_MPFR && defined WITH_MPFR
 657         else if (EQ(type, Qbigfr)) {
 658                 la.precision = internal_get_precision(precision);
 659                 return ent_lift(number, BIGFR_T, &la);
 660         }
 661 #endif /* HAVE_MPFR */
 662         else if (EQ(type, Qreal)) {
 663                 /* respect `read-real-as' */
 664                 la.precision = internal_get_precision(precision);
 665                 if (0);
 666 #if defined HAVE_MPF && defined WITH_GMP
 667                 else if(Vread_real_as == Qbigf)
 668                         return ent_lift(number, BIGF_T, &la);
 669 #endif
 670 #if defined HAVE_MPFR && defined WITH_MPFR
 671                 else if (Vread_real_as == Qbigfr)
 672                         return ent_lift(number, BIGFR_T, &la);
 673 #endif
 674                 else
 675                         return ent_lift(number, FLOAT_T, &la);
 676         }
 677 #if defined(HAVE_PSEUG) && defined WITH_PSEUG
 678         else if (EQ(type, Qbigg)) { /* || EQ(type, Qcomplex)) { */
 679                 return ent_lift(number, BIGG_T, NULL);
 680         }
 681 #endif  /* HAVE_PSEUG */
 682 #if defined HAVE_MPC && defined WITH_MPC ||     \
 683         defined HAVE_PSEUC && defined WITH_PSEUC
 684         else if (EQ(type, Qbigc)) { /* || EQ(type, Qcomplex)) { */
 685                 la.precision = internal_get_precision(precision);
 686                 return ent_lift(number, BIGC_T, &la);
 687         }
 688 #endif /* HAVE_MPC */
 689 #if defined HAVE_QUATERN && defined WITH_QUATERN
 690         else if (EQ(type, Qquatern)) {
 691                 la.precision = internal_get_precision(precision);
 692                 return ent_lift(number, QUATERN_T, &la);
 693         }
 694 #endif /* HAVE_QUATERN */
 695
 696         Fsignal(Qunsupported_type, Qnil);
 697         /* NOTREACHED */
 698         return Qnil;
 699 }
 700
 701 \f
 702 /************************ Auxiliary Stuff **************************/
 703
 704 DEFUN("dump-ase-types", Fdump_ase_types, 0, 0, 0, /*
 705 */
 706       ())
 707 {
 708         ENT_CRITICAL("int:64\n");
 709         ENT_CRITICAL("bigz:%d\n", lrecord_type_bigz);
 710         ENT_CRITICAL("bigq:%d\n", lrecord_type_bigq);
 711         ENT_CRITICAL("bigf:%d\n", lrecord_type_bigf);
 712         ENT_CRITICAL("bigfr:%d\n", lrecord_type_bigfr);
 713         ENT_CRITICAL("float:%d\n", lrecord_type_float);
 714         ENT_CRITICAL("bigg:%d\n", lrecord_type_bigg);
 715         ENT_CRITICAL("bigc:%d\n", lrecord_type_bigc);
 716         ENT_CRITICAL("quatern:%d\n", lrecord_type_quatern);
 717         ENT_CRITICAL("indef:%d\n", lrecord_type_indef);
 718
 719         ENT_CRITICAL("last:%d\n", lrecord_type_last_built_in_type);
 720
 721         return Qt;
 722 }
 723
 724 \f
 725 /******************************* op tables ****************************/
 726
 727 static inline void
 728 initialise_operation_tables(void)
 729 {
 730         /* new optable magic */
 731         ase_optable_freelist_init();
 732         ase_nullary_optable_init();
 733         ase_unary_optable_init();
 734         ase_binary_optable_init();
 735         ase_unary_reltable_init();
 736         ase_binary_reltable_init();
 737         ase_lifttable_init();
 738 }
 739
 740 void init_ent_optables(void)
 741 {
 742         initialise_operation_tables();
 743
 744         init_optables_INDEF_T();
 745         init_optables_INT_T();
 746 #ifdef HAVE_FPFLOAT
 747         init_optables_FLOAT_T();
 748 #endif
 749 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 750         init_optables_BIGZ_T();
 751 #endif
 752 #if defined HAVE_MPQ && defined WITH_GMP
 753         init_optables_BIGQ_T();
 754 #endif
 755 #if defined HAVE_MPF && defined WITH_GMP
 756         init_optables_BIGF_T();
 757 #endif
 758 #if defined HAVE_MPFR && defined WITH_MPFR
 759         init_optables_BIGFR_T();
 760 #endif
 761 #if defined HAVE_MPC && defined WITH_MPC ||     \
 762         defined HAVE_PSEUC && defined WITH_PSEUC
 763         init_optables_BIGC_T();
 764 #endif
 765 #if defined HAVE_PSEUG && defined WITH_PSEUG
 766         init_optables_BIGG_T();
 767 #endif
 768 #if defined HAVE_QUATERN && defined WITH_QUATERN
 769         init_optables_QUATERN_T();
 770 #endif
 771 }
 772
 773 \f
 774 void syms_of_ent(void)
 775 {
 776         syms_of_ent_int();
 777         syms_of_ent_indef();
 778
 779 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 780         syms_of_ent_mpz();
 781 #endif
 782 #if defined HAVE_MPQ && defined WITH_GMP
 783         syms_of_ent_mpq();
 784 #endif
 785 #if defined HAVE_MPF && defined WITH_GMP
 786         syms_of_ent_mpf();
 787 #endif
 788 #ifdef HAVE_FPFLOAT
 789         syms_of_ent_float();
 790 #endif
 791 #if defined HAVE_MPFR && defined WITH_MPFR
 792         syms_of_ent_mpfr();
 793 #endif
 794 #if defined HAVE_MPC && defined WITH_MPC ||     \
 795         defined HAVE_PSEUC && defined WITH_PSEUC
 796         syms_of_ent_mpc();
 797 #endif
 798 #if defined HAVE_PSEUG && defined WITH_PSEUG
 799         syms_of_ent_gaussian();
 800 #endif
 801 #if defined HAVE_QUATERN && defined WITH_QUATERN
 802         syms_of_ent_quatern();
 803 #endif
 804
 805         /* Type predicates */
 806         DEFSYMBOL(Qbignump);
 807         DEFSYMBOL(Qbigzp);
 808         DEFSYMBOL(Qratiop);
 809         DEFSYMBOL(Qbigqp);
 810
 811         DEFSYMBOL(Qrationalp);
 812
 813         DEFSYMBOL(Qbigfloatp);
 814         DEFSYMBOL(Qbigfp);
 815         DEFSYMBOL(Qbigfrp);
 816         DEFSYMBOL(Qrealp);
 817         DEFSYMBOL(Qcomparablep);
 818
 819         DEFSYMBOL(Qbiggp);
 820         DEFSYMBOL(Qbigcp);
 821         DEFSYMBOL(Qquaternp);
 822
 823         DEFSYMBOL(Qinfinityp);
 824         DEFSYMBOL(Qindefinitep);
 825
 826         DEFSYMBOL(Qarchimedeanp);
 827         DEFSYMBOL(Qnonarchimedeanp);
 828
 829         /* some error categories */
 830         DEFERROR(Qoperation_error,
 831                  "Operation undefined over domain", Qarith_error);
 832         DEFERROR(Qrelation_error,
 833                  "Relation undefined over domain", Qarith_error);
 834         DEFERROR(Qvaluation_error,
 835                  "Valuation undefined over domain", Qarith_error);
 836
 837         /* Functions */
 838         DEFSUBR(Fbigzp);
 839         DEFSUBR(Fbignump);
 840         DEFSUBR(Fintegerp);
 841         DEFSUBR(Fevenp);
 842         DEFSUBR(Foddp);
 843
 844         DEFSUBR(Fratiop);
 845         DEFSUBR(Fbigqp);
 846         DEFSUBR(Fnumerator);
 847         DEFSUBR(Fdenominator);
 848
 849         DEFSUBR(Frationalp);
 850
 851         DEFSUBR(Fbigfp);
 852         DEFSUBR(Fbigfloatp);
 853
 854         DEFSUBR(Fbigfrp);
 855
 856         DEFSUBR(Frealp);
 857         DEFSUBR(Freal);
 858         DEFSUBR(Fcomparablep);
 859
 860         DEFSUBR(Fbiggp);
 861
 862         DEFSUBR(Fbigcp);
 863         DEFSUBR(Fcomplexp);
 864
 865         DEFSUBR(Fquaternp);
 866
 867         DEFSUBR(Farchimedeanp);
 868         DEFSUBR(Fnonarchimedeanp);
 869
 870         DEFSUBR(Finfinityp);
 871         DEFSUBR(Findefinitep);
 872
 873         DEFSUBR(Fcanonicalize_number);
 874         DEFSUBR(Fcoerce_number);
 875
 876         DEFSUBR(Fdump_ase_types);
 877
 878         DEFSYMBOL(Qoptable_index);
 879
 880         /* Errors */
 881         DEFERROR_STANDARD(Qunsupported_type, Qwrong_type_argument);
 882
 883         /* Operation Tables */
 884         init_ent_optables();
 885         syms_of_ent_nullary_op();
 886         syms_of_ent_unary_op();
 887         syms_of_ent_binary_op();
 888         syms_of_ent_unary_rel();
 889         syms_of_ent_binary_rel();
 890         syms_of_ent_lift();
 891 }
 892
 893 void vars_of_ent(void)
 894 {
 895         Fprovide(intern("number-types"));
 896         Fprovide(intern("ent"));
 897
 898         vars_of_ent_int();
 899         vars_of_ent_indef();
 900
 901 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 902         vars_of_ent_mpz();
 903 #endif
 904 #if defined HAVE_MPQ && defined WITH_GMP
 905         vars_of_ent_mpq();
 906 #endif
 907 #if defined HAVE_MPF && defined WITH_GMP
 908         vars_of_ent_mpf();
 909 #endif
 910 #ifdef HAVE_FPFLOAT
 911         vars_of_ent_float();
 912 #endif
 913 #if defined HAVE_MPFR && defined WITH_MPFR
 914         vars_of_ent_mpfr();
 915 #endif
 916 #if defined HAVE_MPC && defined WITH_MPC ||     \
 917         defined(HAVE_PSEUC) && defined WITH_PSEUC
 918         vars_of_ent_mpc();
 919 #endif
 920 #if defined HAVE_PSEUG && defined WITH_PSEUG
 921         vars_of_ent_gaussian();
 922 #endif
 923 #if defined HAVE_QUATERN && defined WITH_QUATERN
 924         vars_of_ent_quatern();
 925 #endif
 926
 927         max_real_precision = EMACS_INT_MAX;
 928
 929         DEFVAR_CONST_INT("max-real-precision", &max_real_precision /*
 930 The maximum number of bits of precision a bigf or bigfr can have.
 931 This is determined by the underlying library used to implement
 932 arbitrary-precision floats.
 933                                                                    */);
 934
 935         DEFVAR_LISP("read-real-as", &Vread_real_as /*
 936 *Indicate how real numbers should be read.
 937 If set to `nil' or 'float, reals are always converted to floats.
 938 If set to 'bigf or 'bigfr, reals are read as MPF floats or MPFR
 939 floats respectively.
 940                                                    */);
 941         Vread_real_as = Qfloat;
 942
 943         default_real_precision = 128;
 944         DEFVAR_INT_MAGIC("default-real-precision",
 945                          &default_real_precision, /*
 946 *The default floating-point precision for newly created
 947 floating point values.
 948 This should be an unsigned integer no greater than
 949 `maximum-real-precision' to create external floats
 950 with the indicated precision.
 951
 952 This variable is effective only when `read-real-as'
 953 is set to a float type which supports setting a
 954 precision.
 955                                                     */
 956                          default_real_precision_changed);
 957
 958         vars_of_ent_nullary_op();
 959         vars_of_ent_unary_op();
 960         vars_of_ent_binary_op();
 961         vars_of_ent_unary_rel();
 962         vars_of_ent_binary_rel();
 963         vars_of_ent_lift();
 964 }
 965
 966 void init_ent(void)
 967 {
 968         init_ent_optables();
 969
 970         if (!number_initialized) {
 971                 number_initialized = 1;
 972
 973                 init_ent_int();
 974                 init_ent_indef();
 975 #ifdef HAVE_FPFLOAT
 976                 init_ent_float();
 977 #endif
 978 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 979                 init_ent_mpz();
 980 #endif
 981 #if defined HAVE_MPQ && defined WITH_GMP
 982                 init_ent_mpq();
 983 #endif
 984 #if defined HAVE_MPF && defined WITH_GMP
 985                 init_ent_mpf();
 986 #endif
 987 #if defined HAVE_MPFR && defined WITH_MPFR
 988                 init_ent_mpfr();
 989 #endif
 990 #if defined HAVE_MPC && defined WITH_MPC ||     \
 991         defined HAVE_PSEUC && defined WITH_PSEUC
 992                 init_ent_mpc();
 993 #endif
 994 #if defined HAVE_PSEUG && defined WITH_PSEUG
 995                 init_ent_gaussian();
 996 #endif
 997 #if defined HAVE_QUATERN && defined WITH_QUATERN
 998                 init_ent_quatern();
 999 #endif
1000         }
1001
1002         /* promote our empty sets */
1003         ase_empty_sets = make_noseeum_dllist();
1004 }
1005
1006 /* ent.c ends here */