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 SXE_UNUSED(sym), Lisp_Object *val,
 257                                 Lisp_Object SXE_UNUSED(in_object),
 258                                 int SXE_UNUSED(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
 275 DEFUN("real", Freal, 1, 2, 0,   /*
 276 Return the real number numerically equal to NUMBER with
 277 respect to the variable `read-real-as'.
 278 If optional argument PRECISION is non-nil, its value
 279 \(an integer\) is used as precision.
 280 */
 281       (number, precision))
 282 {
 283         if (Vread_real_as == Qbigfr) {
 284 #if defined HAVE_MPFR && defined WITH_MPFR
 285                 return Fcoerce_number(number, Qbigfr, precision);
 286 #else  /* !HAVE_MPFR */
 287                 ;
 288 #endif  /* HAVE_MPFR */
 289         }
 290
 291         if (Vread_real_as == Qbigf) {
 292 #if defined HAVE_MPF && defined WITH_GMP
 293                 return Fcoerce_number(number, Qbigf, precision);
 294 #else  /* !HAVE_MPF */
 295                 ;
 296 #endif  /* HAVE_MPF */
 297         }
 298
 299         /* fallback to 'float */
 300         return Fcoerce_number(number, Qfloat, precision);
 301 }
 302
 303 \f
 304 /******************************** Comparables *******************************/
 305 DEFUN ("comparablep", Fcomparablep, 1, 1, 0, /*
 306 Return t if OBJECT is a comparable number, nil otherwise.
 307
 308 We call a number comparable if there exists a total (archimedean)
 309 order on the underlying structure.
 310 */
 311        (object))
 312 {
 313         return COMPARABLEP(object) ? Qt : Qnil;
 314 }
 315
 316
 317 \f
 318 /********************************** Biggs ***********************************/
 319 Lisp_Object Qbiggp;
 320
 321 DEFUN ("biggp", Fbiggp, 1, 1, 0, /*
 322 Return t if OBJECT is a bigg (a gaussian number), nil otherwise.
 323 */
 324        (object))
 325 {
 326         return BIGGP(object) ? Qt : Qnil;
 327 }
 328
 329 \f
 330 /********************************** Bigcs ***********************************/
 331 Lisp_Object Qbigcp;
 332
 333 DEFUN ("bigcp", Fbigcp, 1, 1, 0, /*
 334 Return t if OBJECT is a bigc, nil otherwise.
 335 */
 336        (object))
 337 {
 338         return BIGCP(object) ? Qt : Qnil;
 339 }
 340
 341 \f
 342 /******************************* Complex nums *******************************/
 343 DEFUN ("complexp", Fcomplexp, 1, 1, 0, /*
 344 Return t if OBJECT is a complex number (i.e. either a bigc
 345 or a bigg), nil otherwise.
 346 */
 347        (object))
 348 {
 349         return COMPLEXP(object) ? Qt : Qnil;
 350 }
 351
 352
 353 \f
 354 /********************************** Quaterns ********************************/
 355 Lisp_Object Qquaternp;
 356
 357 DEFUN ("quaternp", Fquaternp, 1, 1, 0, /*
 358 Return t if OBJECT is a quaternion, nil otherwise.
 359 */
 360        (object))
 361 {
 362         return QUATERNP(object) ? Qt : Qnil;
 363 }
 364
 365
 366 \f
 367 /******************************* Archimedeans *******************************/
 368 DEFUN ("archimedeanp", Farchimedeanp, 1, 1, 0, /*
 369 Return t if OBJECT is a number with an archimedean valuation, nil otherwise.
 370 */
 371        (object))
 372 {
 373         return ARCHIMEDEANP(object) ? Qt : Qnil;
 374 }
 375
 376 \f
 377 /***************************** Non-Archimedeans *****************************/
 378 DEFUN ("nonarchimedeanp", Fnonarchimedeanp, 1, 1, 0, /*
 379 Return t if OBJECT is a number with a non-archimedean valuation, nil
 380 otherwise.
 381 */
 382        (object))
 383 {
 384         return NONARCHIMEDEANP(object) ? Qt : Qnil;
 385 }
 386
 387 \f
 388 /******************************** Indefinite Symbols ************************/
 389 Lisp_Object Qinfinityp, Qindefinitep;
 390
 391 DEFUN("indefinitep", Findefinitep, 1, 1, 0, /*
 392 Return t if OBJECT is an indefinite symbol, nil otherwise.
 393 */
 394       (object))
 395 {
 396         return INDEFP(object) ? Qt : Qnil;
 397 }
 398
 399 DEFUN ("infinityp", Finfinityp, 1, 1, 0, /*
 400 Return t if OBJECT is a form of infinity, nil otherwise.
 401 */
 402        (object))
 403 {
 404         return INFINITYP(object) ? Qt : Qnil;
 405 }
 406
 407 \f
 408 /********************************* Numbers **********************************/
 409 DEFUN ("canonicalize-number", Fcanonicalize_number, 1, 1, 0, /*
 410 Return the canonical form of NUMBER.  DEPRECATED FUNCTION.
 411 */
 412        (number))
 413 {
 414         /* The tests should go in order from larger, more expressive, or more
 415            complex types to smaller, less expressive, or simpler types so that a
 416            number can cascade all the way down to the simplest type if
 417            appropriate. */
 418 #if defined HAVE_MPQ && defined WITH_GMP
 419         if (BIGQP(number))
 420                 return ent_mpq_downgrade_maybe(XBIGQ_DATA(number));
 421 #endif
 422 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 423         if (BIGZP(number))
 424                 return ent_mpz_downgrade_maybe(XBIGZ_DATA(number));
 425 #endif
 426 #if defined HAVE_MPFR && defined WITH_MPFR
 427         if (BIGFRP(number))
 428                 return ent_mpfr_wipe_indef(XBIGFR_DATA(number));
 429 #endif
 430         return number;
 431 }
 432
 433 /* new ase optable magic */
 434 static dllist_t ase_optable_freelist;
 435
 436 static inline void
 437 ase_optable_freelist_init(void)
 438 {
 439         long int i;
 440         ase_optable_freelist = make_noseeum_dllist();
 441         for (i = 0; i < lrecord_first_ent_type; i++) {
 442                 dllist_append(ase_optable_freelist, (void*)i);
 443         }
 444 }
 445
 446 int ase_optable_add(Lisp_Object typesym)
 447 {
 448         /* TYPESYM should be a symbol as used in dynacats */
 449         long int *foo = dllist_pop_car(ase_optable_freelist);
 450         long int idx = (long int)foo;
 451         Fput(typesym, Qoptable_index, make_int(idx));
 452         return idx;
 453 }
 454
 455 void ase_optable_del(Lisp_Object typesym)
 456 {
 457         /* TYPESYM should be a symbol as used in dynacats */
 458         long int idx = (long int)ase_optable_index_typesym(typesym);
 459         dllist_append(ase_optable_freelist, (void*)idx);
 460         return;
 461 }
 462
 463 int ase_optable_index(Lisp_Object arg)
 464 {
 465         switch ((unsigned int)XTYPE(arg)) {
 466         case Lisp_Type_Record: {
 467                 enum lrecord_type type =
 468                         XRECORD_LHEADER_IMPLEMENTATION(arg)->lrecord_type_index;
 469
 470                 switch ((unsigned int)type) {
 471                 case lrecord_type_marker:
 472                         return INT_T;
 473                 case lrecord_type_dynacat:
 474                         assert(SYMBOLP(XDYNACAT_TYPE(arg)));
 475                         /* must be an dynacat */
 476                         /* now we've got two options, either compute a
 477                          * hash-value from the symbol's address
 478                          * or store a cookie in the plist of the symbol
 479                          * for the moment, we prefer the latter option
 480                          */
 481                         return ase_optable_index_typesym(XDYNACAT_TYPE(arg));
 482                 default:
 483                         return type;
 484                 }
 485         }
 486         default:
 487                 return INT_T;
 488         }
 489         return -1; /* Should not reach here */
 490 }
 491
 492 int
 493 ase_optable_index_typesym(Lisp_Object typesym)
 494 {
 495         Lisp_Object idx = Fget(typesym, Qoptable_index, Qnil);
 496         assert(INTEGERP(idx));
 497         return XINT(idx);
 498 }
 499
 500 /* categorial subtleties */
 501 dllist_t ase_empty_sets = 0;
 502 Lisp_Object Qase_empty_sets;
 503
 504 \f
 505 #if 0
 506 inline Lisp_Object
 507 ent_normalise_number(Lisp_Object number)
 508 {
 509         if (CHARP(number))
 510                 return make_int(XCHAR(number));
 511         else if (MARKERP(number))
 512                 return make_int(marker_position(number));
 513
 514         return number;
 515 }
 516 #endif
 517
 518 unsigned long ent_normalise_precision(unsigned long precision)
 519 {
 520         /* MPFR will slaughter us when we pass a precision < MPFR_PREC_MIN */
 521         if (precision < MPFR_PREC_MIN)
 522                 return default_real_precision;
 523         if (precision > MPFR_PREC_MAX)
 524                 return max_real_precision;
 525
 526         return precision;
 527 }
 528
 529 /* Convert NUMBER to type TYPE.  If TYPE is BIGF_T then use the indicated
 530    PRECISION; otherwise, PRECISION is ignored. */
 531 static Lisp_Object
 532 internal_coerce_number (Lisp_Object o,
 533                         ase_object_type_t type,
 534                         unsigned long precision)
 535 {
 536         struct ent_lift_args_s la;
 537
 538         la.precision = ent_normalise_precision(precision);
 539
 540         return ent_lift(o, type, &la);
 541 }
 542
 543 \f
 544 unsigned long
 545 internal_get_precision(Lisp_Object precision)
 546 {
 547         unsigned long susp_prec = 0;
 548
 549         if (NILP(precision) && default_real_precision > 0) {
 550                 susp_prec = default_real_precision;
 551         } else if (INTP(precision)) {
 552                 susp_prec = XUINT(precision);
 553 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 554         } else if (BIGZP(precision)) {
 555                 if (!bigz_fits_ulong_p(XBIGZ_DATA(precision)))
 556                         susp_prec = max_real_precision;
 557                 else
 558                         susp_prec = bigz_to_ulong(XBIGZ_DATA(precision));
 559 #endif
 560         } else {
 561                 susp_prec = default_real_precision;
 562         }
 563
 564         /* final comparison */
 565         if (susp_prec < MPFR_PREC_MIN)
 566                 return MPFR_PREC_MIN;
 567         else if (susp_prec > MPFR_PREC_MAX)
 568                 return MPFR_PREC_MAX;
 569         else
 570                 return susp_prec;
 571 }
 572
 573 DEFUN("coerce-number", Fcoerce_number, 2, 3, 0, /*
 574 Convert NUMBER to the indicated type, possibly losing information.
 575 See `coerce'.
 576
 577 TYPE is one of the symbols:
 578 - 'fixnum or 'int     to convert to built-in integers
 579 - 'bigz or 'bignum    to convert to bigz integers
 580 - 'integer            to convert to the most suitable type out of
 581                       'bigz or 'int
 582
 583 - 'bigq or 'ratio     to convert to bigq fractions
 584 - 'rational           to convert to the most suitable type out of
 585                       'bigq, 'bigz or 'int
 586
 587 - 'float              to convert to built-in floats
 588 - 'bigf or 'bigfloat  to convert to bigf floats
 589 - 'bigfr              to convert to bigfr floats
 590 - 'real               to convert to the type indicated by
 591                       `read-real-as' with a fallback to 'float
 592
 593 - 'bigg               to convert to a Gaussian
 594 - 'bigc               to convert to a bigc complex number
 595
 596 - 'quatern            to convert to a Quaternion
 597
 598 NOTE: Not all of these types may be supported.
 599
 600 PRECISION is the number of bits of precision to use when converting to
 601 reals; it is ignored otherwise.  If nil, the default precision is used.
 602
 603 Note that some conversions lose information.  No error is signaled in such
 604 cases; the information is silently lost.
 605 */
 606        (number, type, precision))
 607 {
 608         struct ent_lift_args_s la;
 609
 610         CHECK_SYMBOL(type);
 611
 612         if (EQ(type, Qint) || EQ(type, Qfixnum))
 613                 return internal_coerce_number(number, INT_T, 0UL);
 614         else if (EQ(type, Qinteger)) {
 615                 /* If bignums are available, we always convert to one first,
 616                    then downgrade to a int if possible. */
 617 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 618                 return Fcanonicalize_number(
 619                         ent_lift(number, BIGZ_T, NULL));
 620 #else
 621                 return ent_lift(number, INT_T, NULL);
 622 #endif  /* HAVE_MPZ */
 623         }
 624 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 625         else if (EQ(type, Qbigz) || EQ(type, Qbignum)) {
 626                 /* always convert to bigz */
 627                 return ent_lift(number, BIGZ_T, NULL);
 628         }
 629 #endif
 630 #if defined HAVE_MPQ && defined WITH_GMP
 631         else if (EQ(type, Qrational)) {
 632                 /* convert to bigq and canonicalise */
 633                 return Fcanonicalize_number(
 634                         ent_lift(number, BIGQ_T, NULL));
 635
 636         } else if (EQ(type, Qbigq) || EQ(type, Qratio)) {
 637                 /* always convert to bigq */
 638                 return ent_lift(number, BIGQ_T, NULL);
 639         }
 640 #endif  /* HAVE_MPQ */
 641 #ifdef HAVE_FPFLOAT
 642         else if (EQ(type, Qfloat))
 643                 return ent_lift(number, FLOAT_T, NULL);
 644 #endif
 645 #if defined HAVE_MPF && defined WITH_GMP
 646         else if (EQ(type, Qbigf) || EQ(type, Qbigfloat)) {
 647                 la.precision = internal_get_precision(precision);
 648                 return ent_lift(number, BIGF_T, &la);
 649         }
 650 #endif /* HAVE_MPF */
 651 #if defined HAVE_MPFR && defined WITH_MPFR
 652         else if (EQ(type, Qbigfr)) {
 653                 la.precision = internal_get_precision(precision);
 654                 return ent_lift(number, BIGFR_T, &la);
 655         }
 656 #endif /* HAVE_MPFR */
 657         else if (EQ(type, Qreal)) {
 658                 /* respect `read-real-as' */
 659                 la.precision = internal_get_precision(precision);
 660                 if (0);
 661 #if defined HAVE_MPF && defined WITH_GMP
 662                 else if(Vread_real_as == Qbigf)
 663                         return ent_lift(number, BIGF_T, &la);
 664 #endif
 665 #if defined HAVE_MPFR && defined WITH_MPFR
 666                 else if (Vread_real_as == Qbigfr)
 667                         return ent_lift(number, BIGFR_T, &la);
 668 #endif
 669                 else
 670                         return ent_lift(number, FLOAT_T, &la);
 671         }
 672 #if defined(HAVE_PSEUG) && defined WITH_PSEUG
 673         else if (EQ(type, Qbigg)) { /* || EQ(type, Qcomplex)) { */
 674                 return ent_lift(number, BIGG_T, NULL);
 675         }
 676 #endif  /* HAVE_PSEUG */
 677 #if defined HAVE_MPC && defined WITH_MPC ||     \
 678         defined HAVE_PSEUC && defined WITH_PSEUC
 679         else if (EQ(type, Qbigc)) { /* || EQ(type, Qcomplex)) { */
 680                 la.precision = internal_get_precision(precision);
 681                 return ent_lift(number, BIGC_T, &la);
 682         }
 683 #endif /* HAVE_MPC */
 684 #if defined HAVE_QUATERN && defined WITH_QUATERN
 685         else if (EQ(type, Qquatern)) {
 686                 la.precision = internal_get_precision(precision);
 687                 return ent_lift(number, QUATERN_T, &la);
 688         }
 689 #endif /* HAVE_QUATERN */
 690
 691         Fsignal(Qunsupported_type, Qnil);
 692         /* NOTREACHED */
 693         return Qnil;
 694 }
 695
 696 \f
 697 /************************ Auxiliary Stuff **************************/
 698
 699 DEFUN("dump-ase-types", Fdump_ase_types, 0, 0, 0, /*
 700 */
 701       ())
 702 {
 703         ENT_CRITICAL("int:64\n");
 704         ENT_CRITICAL("bigz:%d\n", lrecord_type_bigz);
 705         ENT_CRITICAL("bigq:%d\n", lrecord_type_bigq);
 706         ENT_CRITICAL("bigf:%d\n", lrecord_type_bigf);
 707         ENT_CRITICAL("bigfr:%d\n", lrecord_type_bigfr);
 708         ENT_CRITICAL("float:%d\n", lrecord_type_float);
 709         ENT_CRITICAL("bigg:%d\n", lrecord_type_bigg);
 710         ENT_CRITICAL("bigc:%d\n", lrecord_type_bigc);
 711         ENT_CRITICAL("quatern:%d\n", lrecord_type_quatern);
 712         ENT_CRITICAL("indef:%d\n", lrecord_type_indef);
 713
 714         ENT_CRITICAL("last:%d\n", lrecord_type_last_built_in_type);
 715
 716         return Qt;
 717 }
 718
 719 \f
 720 /******************************* op tables ****************************/
 721
 722 static inline void
 723 initialise_operation_tables(void)
 724 {
 725         /* new optable magic */
 726         ase_optable_freelist_init();
 727         ase_nullary_optable_init();
 728         ase_unary_optable_init();
 729         ase_binary_optable_init();
 730         ase_unary_reltable_init();
 731         ase_binary_reltable_init();
 732         ase_lifttable_init();
 733 }
 734
 735 void init_ent_optables(void)
 736 {
 737         initialise_operation_tables();
 738
 739         init_optables_INDEF_T();
 740         init_optables_INT_T();
 741 #ifdef HAVE_FPFLOAT
 742         init_optables_FLOAT_T();
 743 #endif
 744 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 745         init_optables_BIGZ_T();
 746 #endif
 747 #if defined HAVE_MPQ && defined WITH_GMP
 748         init_optables_BIGQ_T();
 749 #endif
 750 #if defined HAVE_MPF && defined WITH_GMP
 751         init_optables_BIGF_T();
 752 #endif
 753 #if defined HAVE_MPFR && defined WITH_MPFR
 754         init_optables_BIGFR_T();
 755 #endif
 756 #if defined HAVE_MPC && defined WITH_MPC ||     \
 757         defined HAVE_PSEUC && defined WITH_PSEUC
 758         init_optables_BIGC_T();
 759 #endif
 760 #if defined HAVE_PSEUG && defined WITH_PSEUG
 761         init_optables_BIGG_T();
 762 #endif
 763 #if defined HAVE_QUATERN && defined WITH_QUATERN
 764         init_optables_QUATERN_T();
 765 #endif
 766 }
 767
 768 \f
 769 void syms_of_ent(void)
 770 {
 771         syms_of_ent_int();
 772         syms_of_ent_indef();
 773
 774 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 775         syms_of_ent_mpz();
 776 #endif
 777 #if defined HAVE_MPQ && defined WITH_GMP
 778         syms_of_ent_mpq();
 779 #endif
 780 #if defined HAVE_MPF && defined WITH_GMP
 781         syms_of_ent_mpf();
 782 #endif
 783 #ifdef HAVE_FPFLOAT
 784         syms_of_ent_float();
 785 #endif
 786 #if defined HAVE_MPFR && defined WITH_MPFR
 787         syms_of_ent_mpfr();
 788 #endif
 789 #if defined HAVE_MPC && defined WITH_MPC ||     \
 790         defined HAVE_PSEUC && defined WITH_PSEUC
 791         syms_of_ent_mpc();
 792 #endif
 793 #if defined HAVE_PSEUG && defined WITH_PSEUG
 794         syms_of_ent_gaussian();
 795 #endif
 796 #if defined HAVE_QUATERN && defined WITH_QUATERN
 797         syms_of_ent_quatern();
 798 #endif
 799
 800         /* Type predicates */
 801         DEFSYMBOL(Qbignump);
 802         DEFSYMBOL(Qbigzp);
 803         DEFSYMBOL(Qratiop);
 804         DEFSYMBOL(Qbigqp);
 805
 806         DEFSYMBOL(Qrationalp);
 807
 808         DEFSYMBOL(Qbigfloatp);
 809         DEFSYMBOL(Qbigfp);
 810         DEFSYMBOL(Qbigfrp);
 811         DEFSYMBOL(Qrealp);
 812         DEFSYMBOL(Qcomparablep);
 813
 814         DEFSYMBOL(Qbiggp);
 815         DEFSYMBOL(Qbigcp);
 816         DEFSYMBOL(Qquaternp);
 817
 818         DEFSYMBOL(Qinfinityp);
 819         DEFSYMBOL(Qindefinitep);
 820
 821         DEFSYMBOL(Qarchimedeanp);
 822         DEFSYMBOL(Qnonarchimedeanp);
 823
 824         /* some error categories */
 825         DEFERROR(Qoperation_error,
 826                  "Operation undefined over domain", Qarith_error);
 827         DEFERROR(Qrelation_error,
 828                  "Relation undefined over domain", Qarith_error);
 829         DEFERROR(Qvaluation_error,
 830                  "Valuation undefined over domain", Qarith_error);
 831
 832         /* Functions */
 833         DEFSUBR(Fbigzp);
 834         DEFSUBR(Fbignump);
 835         DEFSUBR(Fintegerp);
 836         DEFSUBR(Fevenp);
 837         DEFSUBR(Foddp);
 838
 839         DEFSUBR(Fratiop);
 840         DEFSUBR(Fbigqp);
 841         DEFSUBR(Fnumerator);
 842         DEFSUBR(Fdenominator);
 843
 844         DEFSUBR(Frationalp);
 845
 846         DEFSUBR(Fbigfp);
 847         DEFSUBR(Fbigfloatp);
 848
 849         DEFSUBR(Fbigfrp);
 850
 851         DEFSUBR(Frealp);
 852         DEFSUBR(Freal);
 853         DEFSUBR(Fcomparablep);
 854
 855         DEFSUBR(Fbiggp);
 856
 857         DEFSUBR(Fbigcp);
 858         DEFSUBR(Fcomplexp);
 859
 860         DEFSUBR(Fquaternp);
 861
 862         DEFSUBR(Farchimedeanp);
 863         DEFSUBR(Fnonarchimedeanp);
 864
 865         DEFSUBR(Finfinityp);
 866         DEFSUBR(Findefinitep);
 867
 868         DEFSUBR(Fcanonicalize_number);
 869         DEFSUBR(Fcoerce_number);
 870
 871         DEFSUBR(Fdump_ase_types);
 872
 873         DEFSYMBOL(Qoptable_index);
 874
 875         /* Errors */
 876         DEFERROR_STANDARD(Qunsupported_type, Qwrong_type_argument);
 877
 878         /* Operation Tables */
 879         init_ent_optables();
 880         syms_of_ent_nullary_op();
 881         syms_of_ent_unary_op();
 882         syms_of_ent_binary_op();
 883         syms_of_ent_unary_rel();
 884         syms_of_ent_binary_rel();
 885         syms_of_ent_lift();
 886 }
 887
 888 void vars_of_ent(void)
 889 {
 890         Fprovide(intern("number-types"));
 891         Fprovide(intern("ent"));
 892
 893         vars_of_ent_int();
 894         vars_of_ent_indef();
 895
 896 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 897         vars_of_ent_mpz();
 898 #endif
 899 #if defined HAVE_MPQ && defined WITH_GMP
 900         vars_of_ent_mpq();
 901 #endif
 902 #if defined HAVE_MPF && defined WITH_GMP
 903         vars_of_ent_mpf();
 904 #endif
 905 #ifdef HAVE_FPFLOAT
 906         vars_of_ent_float();
 907 #endif
 908 #if defined HAVE_MPFR && defined WITH_MPFR
 909         vars_of_ent_mpfr();
 910 #endif
 911 #if defined HAVE_MPC && defined WITH_MPC ||     \
 912         defined(HAVE_PSEUC) && defined WITH_PSEUC
 913         vars_of_ent_mpc();
 914 #endif
 915 #if defined HAVE_PSEUG && defined WITH_PSEUG
 916         vars_of_ent_gaussian();
 917 #endif
 918 #if defined HAVE_QUATERN && defined WITH_QUATERN
 919         vars_of_ent_quatern();
 920 #endif
 921
 922         max_real_precision = EMACS_INT_MAX;
 923
 924         DEFVAR_CONST_INT("max-real-precision", &max_real_precision /*
 925 The maximum number of bits of precision a bigf or bigfr can have.
 926 This is determined by the underlying library used to implement
 927 arbitrary-precision floats.
 928                                                                    */);
 929
 930         DEFVAR_LISP("read-real-as", &Vread_real_as /*
 931 *Indicate how real numbers should be read.
 932 If set to `nil' or 'float, reals are always converted to floats.
 933 If set to 'bigf or 'bigfr, reals are read as MPF floats or MPFR
 934 floats respectively.
 935                                                    */);
 936         Vread_real_as = Qfloat;
 937
 938         default_real_precision = 128;
 939         DEFVAR_INT_MAGIC("default-real-precision",
 940                          &default_real_precision, /*
 941 *The default floating-point precision for newly created
 942 floating point values.
 943 This should be an unsigned integer no greater than
 944 `maximum-real-precision' to create external floats
 945 with the indicated precision.
 946
 947 This variable is effective only when `read-real-as'
 948 is set to a float type which supports setting a
 949 precision.
 950                                                     */
 951                          default_real_precision_changed);
 952
 953         vars_of_ent_nullary_op();
 954         vars_of_ent_unary_op();
 955         vars_of_ent_binary_op();
 956         vars_of_ent_unary_rel();
 957         vars_of_ent_binary_rel();
 958         vars_of_ent_lift();
 959 }
 960
 961 void init_ent(void)
 962 {
 963         init_ent_optables();
 964
 965         if (!number_initialized) {
 966                 number_initialized = 1;
 967
 968                 init_ent_int();
 969                 init_ent_indef();
 970 #ifdef HAVE_FPFLOAT
 971                 init_ent_float();
 972 #endif
 973 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 974                 init_ent_mpz();
 975 #endif
 976 #if defined HAVE_MPQ && defined WITH_GMP
 977                 init_ent_mpq();
 978 #endif
 979 #if defined HAVE_MPF && defined WITH_GMP
 980                 init_ent_mpf();
 981 #endif
 982 #if defined HAVE_MPFR && defined WITH_MPFR
 983                 init_ent_mpfr();
 984 #endif
 985 #if defined HAVE_MPC && defined WITH_MPC ||     \
 986         defined HAVE_PSEUC && defined WITH_PSEUC
 987                 init_ent_mpc();
 988 #endif
 989 #if defined HAVE_PSEUG && defined WITH_PSEUG
 990                 init_ent_gaussian();
 991 #endif
 992 #if defined HAVE_QUATERN && defined WITH_QUATERN
 993                 init_ent_quatern();
 994 #endif
 995         }
 996
 997         /* promote our empty sets */
 998         ase_empty_sets = make_noseeum_dllist();
 999 }
1000
1001 /* ent.c ends here */