cgit.sxemacs.org Git - sxemacs/blob - modules/ase/ase-resclass.c

   1 /*** ase-resclass.c -- Residue Class Rings for SXEmacs
   2  *
   3  * Copyright (C) 2006 - 2008 Sebastian Freundt
   4  *
   5  * Author:  Sebastian Freundt <hroptatyr@sxemacs.org>
   6  *
   7  * This file is part of SXEmacs.
   8  *
   9  * Redistribution and use in source and binary forms, with or without
  10  * modification, are permitted provided that the following conditions
  11  * are met:
  12  *
  13  * 1. Redistributions of source code must retain the above copyright
  14  *    notice, this list of conditions and the following disclaimer.
  15  *
  16  * 2. Redistributions in binary form must reproduce the above copyright
  17  *    notice, this list of conditions and the following disclaimer in the
  18  *    documentation and/or other materials provided with the distribution.
  19  *
  20  * 3. Neither the name of the author nor the names of any contributors
  21  *    may be used to endorse or promote products derived from this
  22  *    software without specific prior written permission.
  23  *
  24  * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
  25  * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  26  * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  27  * DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
  28  * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  29  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  30  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
  31  * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  32  * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
  33  * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
  34  * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  35  *
  36  ***/
  37
  38 /* Synched up with: Not in FSF. */
  39
  40 #include "config.h"
  41 #include "sxemacs.h"
  42 #include "ent/ent.h"
  43 #include "ase-resclass.h"
  44
  45 #define EMOD_ASE_DEBUG_RESC(args...)    EMOD_ASE_DEBUG("[RESC]: " args)
  46
  47 PROVIDE(ase_resclass);
  48 REQUIRE(ase_resclass, "ase");
  49
  50 Lisp_Object Qase_resclass;
  51 Lisp_Object Qase_resc_rng, Qase_resc_rng_p, Qase_resc_elm, Qase_resc_elm_p;
  52 static int sane_small;
  53
  54 #if 0
  55 static ase_nullary_operation_f Qase_resclass_zero, Qase_resclass_one;
  56 #endif
  57
  58 \f
  59 static inline int
  60 _resc_rng_buffer_size(ase_resc_rng_t a)
  61 {
  62         /* returns a sane size for buffer allocation */
  63 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
  64         if (ase_resc_rng_smallp(a))
  65                 return sane_small;
  66         else
  67                 return (mpz_sizeinbase(ase_resc_rng_ring(a), 10) + 7) & -3;
  68 #else
  69         return sane_small;
  70 #endif
  71 }
  72
  73 static inline void
  74 _ase_resc_rng_to_string(char *buf, int len, ase_resc_rng_t a)
  75 {
  76         if (ase_resc_rng_smallp(a)) {
  77                 int sz = snprintf(buf, len, "%ld", a->small_ring);
  78                 assert(sz >= 0 && sz < len);
  79         } else
  80                 resc_rng_to_string(buf, len, ase_resc_rng_ring(a));
  81         return;
  82 }
  83
  84 void
  85 _ase_resc_rng_prnt(ase_resc_rng_t a, Lisp_Object pcf)
  86 {
  87         int sane_sz = sizeof(char)*_resc_rng_buffer_size(a);
  88         char *fstr = alloca(sane_sz);
  89         _ase_resc_rng_to_string(fstr, sane_sz, a);
  90         write_c_string("Z/", pcf);
  91         write_c_string(fstr, pcf);
  92         write_c_string("Z", pcf);
  93         return;
  94 }
  95
  96 static void
  97 ase_resc_rng_prnt(Lisp_Object obj, Lisp_Object pcf, int unused)
  98 {
  99         EMOD_ASE_DEBUG_RESC("i:0x%016lx@0x%016lx (rc:%d)\n",
 100                             (long unsigned int)(XASE_RESC_RNG(obj)),
 101                             (long unsigned int)obj, 1);
 102         write_c_string("#<", pcf);
 103         print_internal(XDYNACAT_TYPE(obj), pcf, unused);
 104         write_c_string(" ", pcf);
 105         _ase_resc_rng_prnt(XASE_RESC_RNG(obj), pcf);
 106         if (XASE_RESC_RNG_SMALLP(obj))
 107                 write_c_string(", small", pcf);
 108         write_c_string(">", pcf);
 109 }
 110
 111 static inline int
 112 _resc_elm_buffer_size(ase_resc_elm_t a)
 113 {
 114         /* returns a sane size for buffer allocation */
 115 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 116         if (ase_resc_rng_smallp(a))
 117                 return sane_small;
 118         else
 119                 return (mpz_sizeinbase(ase_resc_elm_data(a), 10) + 7) & -3;
 120 #else
 121         return sane_small;
 122 #endif
 123 }
 124
 125 static inline void
 126 _ase_resc_elm_to_string(char *buf, int len, ase_resc_elm_t a)
 127 {
 128         if (ase_resc_elm_smallp(a)) {
 129                 int sz = snprintf(buf, len, "%ld", a->small_data);
 130                 assert(sz>=0 && sz < len);
 131         } else
 132                 resc_elm_to_string(buf, len, ase_resc_elm_data(a));
 133         return;
 134 }
 135
 136 void
 137 _ase_resc_elm_prnt(ase_resc_elm_t a, Lisp_Object pcf)
 138 {
 139         int sane_sz_rng = sizeof(char)*_resc_rng_buffer_size(
 140                 XASE_RESC_RNG(ase_resc_elm_ring(a)));
 141         int sane_sz_elm = sizeof(char)*_resc_elm_buffer_size(a);
 142         char *rng_str = alloca(sane_sz_rng);
 143         char *elm_str = alloca(sane_sz_elm);
 144
 145         _ase_resc_rng_to_string(rng_str, sane_sz_rng,
 146                                 XASE_RESC_RNG(ase_resc_elm_ring(a)));
 147         _ase_resc_elm_to_string(elm_str, sane_sz_elm, a);
 148
 149         write_c_string(elm_str, pcf);
 150         write_c_string("+", pcf);
 151         write_c_string(rng_str, pcf);
 152         write_c_string("Z", pcf);
 153         return;
 154 }
 155
 156 static void
 157 ase_resc_elm_prnt(Lisp_Object obj, Lisp_Object pcf, int unused)
 158 {
 159         EMOD_ASE_DEBUG_RESC("i:0x%016lx@0x%016lx (rc:%d)\n",
 160                             (long unsigned int)(XASE_RESC_ELM(obj)),
 161                             (long unsigned int)obj, 1);
 162         write_c_string("#<", pcf);
 163         print_internal(XDYNACAT_TYPE(obj), pcf, unused);
 164         write_c_string(" ", pcf);
 165         _ase_resc_elm_prnt(XASE_RESC_ELM(obj), pcf);
 166         if (XASE_RESC_ELM_SMALLP(obj))
 167                 write_c_string(", small", pcf);
 168         write_c_string(">", pcf);
 169 }
 170
 171 /* stuff for the dynacat, markers */
 172 static inline void
 173 _ase_resc_rng_mark(ase_resc_rng_t a)
 174 {
 175         if (a == NULL)
 176                 return;
 177         return;
 178 }
 179
 180 static void
 181 ase_resc_rng_mark(Lisp_Object obj)
 182 {
 183         EMOD_ASE_DEBUG_RESC("i:0x%016lx@0x%016lx (rc:%d) shall be marked...\n",
 184                             (long unsigned int)(XASE_RESC_RNG(obj)),
 185                             (long unsigned int)obj, 1);
 186         _ase_resc_rng_mark(XASE_RESC_RNG(obj));
 187         return;
 188 }
 189
 190 static inline void
 191 _ase_resc_elm_mark(ase_resc_elm_t a)
 192 {
 193         mark_object(ase_resc_elm_ring(a));
 194 }
 195
 196 static void
 197 ase_resc_elm_mark(Lisp_Object obj)
 198 {
 199         EMOD_ASE_DEBUG_RESC("i:0x%016lx@0x%016lx (rc:%d) shall be marked...\n",
 200                             (long unsigned int)(XASE_RESC_ELM(obj)),
 201                             (long unsigned int)obj, 1);
 202         _ase_resc_elm_mark(XASE_RESC_ELM(obj));
 203         return;
 204 }
 205
 206 /* stuff for the dynacat, finalisers */
 207 static inline void
 208 _ase_resc_rng_fini(ase_resc_rng_t a)
 209 {
 210         if (!ase_resc_rng_smallp(a))
 211                 resc_rng_fini(ase_resc_rng_ring(a));
 212         return;
 213 }
 214
 215 static void
 216 ase_resc_rng_fini(Lisp_Object obj, int unused)
 217 {
 218         ase_resc_rng_t a = XASE_RESC_RNG(obj);
 219
 220         EMOD_ASE_DEBUG_GC("i:0x%016lx@0x%016lx (rc:%d) shall be freed...\n",
 221                           (long unsigned int)(a), obj, 1);
 222
 223         _ase_resc_rng_fini(a);
 224         xfree(a);
 225         return;
 226 }
 227
 228 static inline void
 229 _ase_resc_elm_fini(ase_resc_elm_t a)
 230 {
 231         if (!ase_resc_elm_smallp(a))
 232                 resc_elm_fini(ase_resc_elm_data(a));
 233         return;
 234 }
 235
 236 static void
 237 ase_resc_elm_fini(Lisp_Object obj, int unused)
 238 {
 239         ase_resc_elm_t a = XASE_RESC_ELM(obj);
 240
 241         EMOD_ASE_DEBUG_GC("i:0x%016lx@0x%016lx (rc:%d) shall be freed...\n",
 242                           (long unsigned int)(a), obj, 1);
 243
 244         _ase_resc_elm_fini(a);
 245         xfree(a);
 246         return;
 247 }
 248
 249 \f
 250 static inline Lisp_Object
 251 _ase_wrap_resc_rng(ase_resc_rng_t a)
 252 {
 253         Lisp_Object result;
 254
 255         result = make_dynacat(a);
 256         XDYNACAT(result)->type = Qase_resc_rng;
 257
 258 #if 0
 259         if (a)
 260                 ase_interval_incref(a);
 261 #endif
 262
 263         set_dynacat_printer(result, ase_resc_rng_prnt);
 264         set_dynacat_marker(result, ase_resc_rng_mark);
 265         set_dynacat_finaliser(result, ase_resc_rng_fini);
 266         set_dynacat_intprinter(
 267                 result, (dynacat_intprinter_f)_ase_resc_rng_prnt);
 268
 269         EMOD_ASE_DEBUG_RESC("i:0x%016lx (rc:%d) "
 270                             "shall be wrapped to 0x%016lx...\n",
 271                             (long unsigned int)a, 1,
 272                             (long unsigned int)result);
 273
 274         return result;
 275 }
 276
 277 ase_resc_rng_t
 278 _ase_make_resc_rng(Lisp_Object modulus)
 279 {
 280         ase_resc_rng_t a = xnew(struct ase_resc_rng_s);
 281
 282         if (INTP(modulus)) {
 283                 a->smallp = 1;
 284                 a->small_ring = XINT(modulus);
 285 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 286         } else if (BIGZP(modulus)) {
 287                 a->smallp = 0;
 288                 resc_rng_init(ase_resc_rng_ring(a));
 289                 resc_rng_set_bigz(ase_resc_rng_ring(a), XBIGZ_DATA(modulus));
 290 #endif
 291         }
 292
 293         EMOD_ASE_DEBUG_RESC("i:0x%016lx (rc:0) shall be created...\n",
 294                             (long unsigned int)a);
 295         return a;
 296 }
 297
 298 /* specialised versions for the lisp reader */
 299 static inline ase_resc_rng_t
 300 __ase_make_resc_rng_eint(EMACS_INT modulus)
 301 {
 302         ase_resc_rng_t a = xnew(struct ase_resc_rng_s);
 303
 304         a->smallp = 1;
 305         a->small_ring = modulus;
 306         EMOD_ASE_DEBUG_RESC("i:0x%016lx (rc:0) shall be created...\n",
 307                             (long unsigned int)a);
 308         return a;
 309 }
 310 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 311 static inline ase_resc_rng_t
 312 __ase_make_resc_rng_bigz(resc_rng modulus)
 313 {
 314         ase_resc_rng_t a = xnew(struct ase_resc_rng_s);
 315
 316         a->smallp = 0;
 317         *a->ring = *modulus;
 318         EMOD_ASE_DEBUG_RESC("i:0x%016lx (rc:0) shall be created...\n",
 319                             (long unsigned int)a);
 320         return a;
 321 }
 322 #endif
 323
 324 Lisp_Object
 325 ase_make_resc_rng(Lisp_Object modulus)
 326 {
 327         ase_resc_rng_t a = NULL;
 328         Lisp_Object result = Qnil;
 329
 330         a = _ase_make_resc_rng(modulus);
 331         XSETASE_RESC_RNG(result, a);
 332
 333         return result;
 334 }
 335
 336 Lisp_Object
 337 _ase_wrap_resc_elm(ase_resc_elm_t a)
 338 {
 339         Lisp_Object result;
 340
 341         result = make_dynacat(a);
 342         XDYNACAT(result)->type = Qase_resc_elm;
 343
 344 #if 0
 345         if (a)
 346                 ase_interval_incref(a);
 347 #endif
 348
 349         set_dynacat_printer(result, ase_resc_elm_prnt);
 350         set_dynacat_marker(result, ase_resc_elm_mark);
 351         set_dynacat_finaliser(result, ase_resc_elm_fini);
 352         set_dynacat_intprinter(
 353                 result, (dynacat_intprinter_f)_ase_resc_elm_prnt);
 354
 355         EMOD_ASE_DEBUG_RESC("i:0x%016lx (rc:%d) "
 356                             "shall be wrapped to 0x%016lx...\n",
 357                             (long unsigned int)a, 1,
 358                             (long unsigned int)result);
 359
 360         return result;
 361 }
 362
 363 static inline void
 364 _ase_resc_elm_canonicalise_small(ase_resc_elm_t a)
 365 {
 366         if ((a->small_data = a->small_data %
 367              XASE_RESC_RNG(ase_resc_elm_ring(a))->small_ring) < 0)
 368                 a->small_data +=
 369                         XASE_RESC_RNG(ase_resc_elm_ring(a))->small_ring;
 370 }
 371
 372 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 373 static void
 374 _ase_resc_elm_canonicalise_big(ase_resc_elm_t a)
 375 {
 376         bigz_mod(ase_resc_elm_data(a), ase_resc_elm_data(a),
 377                  XASE_RESC_RNG_RING(ase_resc_elm_ring(a)));
 378 }
 379 #endif
 380
 381 static inline void
 382 _ase_resc_elm_canonicalise(ase_resc_elm_t a)
 383 {
 384 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 385         if (LIKELY(ase_resc_elm_smallp(a))) {
 386                 _ase_resc_elm_canonicalise_small(a);
 387         } else {
 388                 _ase_resc_elm_canonicalise_big(a);
 389         }
 390 #else
 391         ase_resc_elm_sdata(a) =
 392                 ase_resc_elm_sdata(a) %
 393                 XASE_RESC_RNG_SRING(ase_resc_elm_ring(a));
 394 #endif
 395         return;
 396 }
 397
 398 ase_resc_elm_t
 399 _ase_make_resc_elm(Lisp_Object class, Lisp_Object ring)
 400 {
 401         ase_resc_elm_t a = xnew(struct ase_resc_elm_s);
 402
 403         ase_resc_elm_ring(a) = ring;
 404
 405         if (!(a->smallp = XASE_RESC_RNG(ring)->smallp)) {
 406                 resc_elm_init(ase_resc_elm_data(a));
 407         }
 408
 409         EMOD_ASE_DEBUG_RESC("i:0x%016lx (rc:0) shall be created...\n",
 410                             (long unsigned int)a);
 411
 412         if (INTP(class) && a->smallp) {
 413                 a->small_data = XINT(class);
 414         } else if (INTP(class)) {
 415                 resc_elm_set_eint(ase_resc_elm_data(a), XINT(class));
 416 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 417         } else if (BIGZP(class) && a->smallp) {
 418                 Lisp_Object newcl = _ent_binop(
 419                         ASE_BINARY_OP_MOD,
 420                         BIGZ_T, class,
 421                         INT_T, make_int(XASE_RESC_RNG(ring)->small_ring));
 422                 a->small_data = XINT(newcl);
 423                 return a;
 424         } else if (BIGZP(class)) {
 425                 resc_elm_set_bigz(ase_resc_elm_data(a),
 426                                   XBIGZ_DATA(class));
 427 #endif
 428         }
 429
 430         _ase_resc_elm_canonicalise(a);
 431         return a;
 432 }
 433
 434 /* specialised versions for the lisp reader */
 435 static ase_resc_elm_t
 436 __ase_make_resc_elm_eint(EMACS_INT class)
 437 {
 438         ase_resc_elm_t a = xnew(struct ase_resc_elm_s);
 439
 440         a->smallp = 1;
 441         a->small_data = class;
 442         EMOD_ASE_DEBUG_RESC("i:%p (rc:0) shall be created...\n", a);
 443         return a;
 444 }
 445 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 446 static ase_resc_elm_t
 447 __ase_make_resc_elm_bigz(resc_elm class)
 448 {
 449         ase_resc_elm_t a = xnew(struct ase_resc_elm_s);
 450
 451         a->smallp = 0;
 452         *a->data = *class;
 453         EMOD_ASE_DEBUG_RESC("i:%p (rc:0) shall be created...\n", a);
 454         return a;
 455 }
 456 #endif
 457
 458 Lisp_Object
 459 ase_make_resc_elm(Lisp_Object class, Lisp_Object ring)
 460 {
 461         ase_resc_elm_t a = NULL;
 462         Lisp_Object result = Qnil;
 463
 464         a = _ase_make_resc_elm(class, ring);
 465         XSETASE_RESC_ELM(result, a);
 466
 467         return result;
 468 }
 469
 470 \f
 471 /* basic functions */
 472 /* read a resclass off the wire */
 473 /* the next 4 funs are hooked in the lisp reader (lread.c) */
 474 static Lisp_Object
 475 ase_resc_rng_from_string(char *cp)
 476 {
 477         ase_resc_rng_t r = NULL;
 478         char *start, *tail;
 479         char tmp;
 480         EMACS_INT small_ring;
 481
 482         /* Jump over Z */
 483         cp++;
 484         /* Jump over / */
 485         cp++;
 486
 487         start = cp;
 488
 489         while ((*cp >= '0' && *cp <= '9'))
 490                 cp++;
 491
 492         /* MPZ cannot read numbers with characters after them.
 493          * See limitations of GMP-MPZ strings
 494          */
 495         tmp = (Bufbyte)*cp;
 496         *cp = '\0';
 497         errno = 0;
 498         small_ring = strtol(start, &tail, 10);
 499         if (errno == 0) {
 500                 r = __ase_make_resc_rng_eint(small_ring);
 501 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 502         } else if (errno == ERANGE) {
 503                 resc_rng ring;
 504                 resc_rng_init(ring);
 505                 resc_rng_set_string(ring, start);
 506                 r = __ase_make_resc_rng_bigz(ring);
 507 #endif
 508         } else {
 509                 /* panic */
 510         }
 511         *cp = tmp;
 512
 513         /* generate and return the ring */
 514         return _ase_wrap_resc_rng(r);
 515 }
 516
 517 static Lisp_Object
 518 ase_resc_elm_from_string(char *cp)
 519 {
 520         ase_resc_elm_t e = NULL;
 521         ase_resc_rng_t r = NULL;
 522         char *start, *tail;
 523         char tmp;
 524         EMACS_INT small_ring;
 525         EMACS_INT small_elm;
 526
 527         /* MPZ bigz_set_string has no effect
 528          * with initial + sign */
 529         if (*cp == '+')
 530                 cp++;
 531
 532         start = cp;
 533
 534         if (*cp == '-') {
 535                 /* jump over a leading minus */
 536                 cp++;
 537         }
 538
 539         while ((*cp >= '0' && *cp <= '9'))
 540                 cp++;
 541
 542         /* MPZ cannot read numbers with characters after them.
 543          * See limitations of GMP-MPZ strings
 544          */
 545         tmp = *cp;
 546         *cp = '\0';
 547         errno = 0;
 548         small_elm = strtol(start, &tail, 10);
 549         if (errno == 0) {
 550                 e = __ase_make_resc_elm_eint(small_elm);
 551 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 552         } else if (errno == ERANGE) {
 553                 resc_elm elm;
 554                 resc_elm_init(elm);
 555                 resc_elm_set_string(elm, start);
 556                 e = __ase_make_resc_elm_bigz(elm);
 557 #endif
 558         } else {
 559                 /* panic */
 560         }
 561         *cp = tmp;
 562
 563         /* read the modulus */
 564         if (*cp == '+')
 565                 cp++;
 566         start = cp;
 567         while ((*cp >= '0' && *cp <= '9'))
 568                 cp++;
 569         tmp = *cp;
 570         *cp = '\0';
 571         errno = 0;
 572         small_ring = strtol(start, &tail, 10);
 573         if (errno == 0) {
 574                 r = __ase_make_resc_rng_eint(small_ring);
 575 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 576         } else if (errno == ERANGE) {
 577                 resc_rng ring;
 578                 resc_rng_init(ring);
 579                 resc_rng_set_string(ring, start);
 580                 r = __ase_make_resc_rng_bigz(ring);
 581 #endif
 582         } else {
 583                 /* panic */
 584         }
 585         *cp = tmp;
 586
 587         /* now we have 4 possibilites: */
 588         if (e->smallp && r->smallp) {
 589                 e->ring = _ase_wrap_resc_rng(r);
 590                 _ase_resc_elm_canonicalise_small(e);
 591                 return _ase_wrap_resc_elm(e);
 592 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 593         } else if (e->smallp) {
 594                 /* the class is small, the ring is not,
 595                  * thus we have to promote the class now */
 596                 resc_elm_init(ase_resc_elm_data(e));
 597                 resc_elm_set_eint(ase_resc_elm_data(e), e->small_data);
 598                 e->smallp = 0;
 599                 e->ring = _ase_wrap_resc_rng(r);
 600                 _ase_resc_elm_canonicalise_big(e);
 601                 return _ase_wrap_resc_elm(e);
 602         } else if (r->smallp) {
 603                 /* we're in deep shit, the class is bigz, the ring is small
 604                  * and to make it worse, we can't use the ENT mod table */
 605                 bigz_set_long(ent_scratch_bigz, r->small_ring);
 606                 bigz_mod(ent_scratch_bigz,
 607                          ase_resc_elm_data(e), ent_scratch_bigz);
 608                 /* now ent_scratch_bigz should fit into a long */
 609                 e->small_data = bigz_to_long(ent_scratch_bigz);
 610                 e->smallp = 1;
 611                 /* finish the temporarily assigned big data slot */
 612                 resc_elm_fini(ase_resc_elm_data(e));
 613                 e->ring = _ase_wrap_resc_rng(r);
 614                 /* no need to canonicalise */
 615                 return _ase_wrap_resc_elm(e);
 616         } else {
 617                 /* phew, finally an easy case */
 618                 e->ring = _ase_wrap_resc_rng(r);
 619                 _ase_resc_elm_canonicalise_big(e);
 620                 return _ase_wrap_resc_elm(e);
 621 #endif
 622         }
 623         return Qnil;
 624 }
 625
 626 #define LEAD_INT 1
 627 #define DOT_CHAR 2
 628 #define TRAIL_INT 4
 629 #define E_CHAR 8
 630 #define EXP_INT 16
 631 /* for complex numbers */
 632 #define INTERMEDIATE_UNARY_SYMBOL 32
 633 #define LEAD_INT2 64
 634 #define DOT_CHAR2 128
 635 #define TRAIL_INT2 256
 636 #define E_CHAR2 512
 637 #define EXP_INT2 1024
 638 #define I_CHAR 2048
 639 #define LEAD_Z 2
 640 #define Z_CHAR 4096
 641
 642 static int
 643 ase_resc_rng_string_p(const char *cp)
 644 {
 645         int state;
 646         const Bufbyte *ucp = (const Bufbyte *)cp;
 647
 648
 649         /* parse the residue class */
 650         state = 0;
 651         if (*ucp++ == 'Z' && *ucp++ == '/')
 652                 state |= LEAD_Z;
 653
 654         /* check if we had a int number until here */
 655         if (!(state == (LEAD_Z)))
 656                 return 0;
 657
 658         /* now look for the modulus */
 659         state = 0;
 660         if (*ucp >= '1' && *ucp <= '9') {
 661                 state |= LEAD_INT2;
 662                 while (*ucp >= '0' && *ucp <= '9')
 663                         ucp++;
 664         }
 665         if (*ucp == 'Z') {
 666                 state |= Z_CHAR;
 667                 ucp++;
 668         }
 669         return (((*ucp == 0) || (*ucp == ' ') || (*ucp == '\t') ||
 670                  (*ucp == '\n') || (*ucp == '\r') || (*ucp == '\f')) &&
 671                 (state == (LEAD_INT2 | Z_CHAR)));
 672 }
 673
 674 static int
 675 ase_resc_elm_string_p(const char *cp)
 676 {
 677         int state;
 678         const Bufbyte *ucp = (const Bufbyte *)cp;
 679
 680
 681         /* parse the residue class */
 682         state = 0;
 683         if (*ucp == '+' || *ucp == '-')
 684                 ucp++;
 685
 686         if (*ucp >= '0' && *ucp <= '9') {
 687                 state |= LEAD_INT;
 688                 while (*ucp >= '0' && *ucp <= '9')
 689                         ucp++;
 690         }
 691
 692         /* check if we had a int number until here */
 693         if (!(state == (LEAD_INT)))
 694                 return 0;
 695
 696         /* now look for the residue class ring */
 697         state = 0;
 698         if (*ucp == '+') {
 699                 state |= INTERMEDIATE_UNARY_SYMBOL;
 700                 ucp++;
 701         }
 702
 703         if (*ucp >= '1' && *ucp <= '9') {
 704                 state |= LEAD_INT2;
 705                 while (*ucp >= '0' && *ucp <= '9')
 706                         ucp++;
 707         }
 708         if (*ucp == 'Z') {
 709                 state |= Z_CHAR;
 710                 ucp++;
 711         }
 712         return (((*ucp == 0) || (*ucp == ' ') || (*ucp == '\t') ||
 713                  (*ucp == '\n') || (*ucp == '\r') || (*ucp == '\f')) &&
 714                 (state == (INTERMEDIATE_UNARY_SYMBOL | LEAD_INT2 | Z_CHAR)));
 715 }
 716
 717 \f
 718 #if 0
 719 static Lisp_Object
 720 ent_intersection_factor_module(Lisp_Object *l, Lisp_Object *r)
 721 {
 722         Lisp_Object result_ring;
 723
 724         /* return a resulting ring by intersection of the rings in l and r and
 725          * coerce l and r to that ring.
 726          */
 727
 728         if (!bigz_eql(XRESC_RNG_DATA(XRESC_ELM_RING(*l)),
 729                       XRESC_RNG_DATA(XRESC_ELM_RING(*r)))) {
 730
 731                 /* find a ring by intersection */
 732                 bigz_lcm(ent_scratch_bigz,
 733                          XRESC_RNG_DATA(XRESC_ELM_RING(*l)),
 734                          XRESC_RNG_DATA(XRESC_ELM_RING(*r)));
 735                 result_ring = make_resc_rng_bz(ent_scratch_bigz);
 736
 737                 /* coerce the left ring element to the lcm-ring */
 738                 bigz_div(ent_scratch_bigz,
 739                          XRESC_RNG_DATA(result_ring),
 740                          XRESC_RNG_DATA(XRESC_ELM_RING(*l)));
 741                 bigz_mul(ent_scratch_bigz,
 742                          XRESC_ELM_DATA(*l),
 743                          ent_scratch_bigz);
 744                 *l = make_resc_elm_bz(ent_scratch_bigz, result_ring);
 745
 746                 /* coerce the right ring element to the lcm-ring */
 747                 bigz_div(ent_scratch_bigz,
 748                          XRESC_RNG_DATA(result_ring),
 749                          XRESC_RNG_DATA(XRESC_ELM_RING(*r)));
 750                 bigz_mul(ent_scratch_bigz,
 751                          XRESC_ELM_DATA(*r),
 752                          ent_scratch_bigz);
 753                 *r = make_resc_elm_bz(ent_scratch_bigz, result_ring);
 754
 755         } else
 756                 result_ring = XRESC_ELM_RING(*l);
 757
 758         return result_ring;
 759 }
 760 #endif
 761
 762 static int
 763 ase_resclass_check_rings(Lisp_Object l, Lisp_Object r)
 764 {
 765         if (XASE_RESC_ELM_SMALLP(l) ^ XASE_RESC_ELM_SMALLP(r)) {
 766         domain_error:
 767                 Fsignal(Qdomain_error, list2(
 768                                 XASE_RESC_ELM_RING(l), XASE_RESC_ELM_RING(r)));
 769                 return 0;
 770         } else if (XASE_RESC_ELM_SMALLP(l) &&
 771                    XASE_RESC_RNG_SRING(XASE_RESC_ELM_RING(l)) ==
 772                    XASE_RESC_RNG_SRING(XASE_RESC_ELM_RING(r))) {
 773                 return 1;
 774 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 775         } else if (!XASE_RESC_ELM_SMALLP(l) &&
 776                    bigz_eql(XASE_RESC_RNG_RING(XASE_RESC_ELM_RING(l)),
 777                             XASE_RESC_RNG_RING(XASE_RESC_ELM_RING(r)))) {
 778                 return 1;
 779 #endif
 780         }
 781         goto domain_error;
 782         return 0;
 783 }
 784
 785 static inline Lisp_Object
 786 ase_resclass_sum_small(Lisp_Object l, Lisp_Object r, Lisp_Object result_ring)
 787 {
 788         EMACS_INT sum =
 789                 XASE_RESC_ELM(l)->small_data + XASE_RESC_ELM(r)->small_data;
 790         return ase_make_resc_elm(make_int(sum), result_ring);
 791 }
 792
 793 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 794 static inline Lisp_Object
 795 ase_resclass_sum_big(Lisp_Object l, Lisp_Object r, Lisp_Object result_ring)
 796 {
 797         ase_resc_elm_t e = NULL;
 798         bigz_add(ent_scratch_bigz,
 799                  XASE_RESC_ELM_DATA(l), XASE_RESC_ELM_DATA(r));
 800         e = __ase_make_resc_elm_bigz(ent_scratch_bigz);
 801         e->smallp = 0;
 802         e->ring = result_ring;
 803         _ase_resc_elm_canonicalise_big(e);
 804         return _ase_wrap_resc_elm(e);
 805 }
 806 #endif
 807
 808 static Lisp_Object
 809 ase_resclass_sum(Lisp_Object l, Lisp_Object r)
 810 {
 811         ase_resclass_check_rings(l, r);
 812
 813 #if 0
 814         result_ring = ent_intersection_factor_module(&l, &r);
 815 #endif
 816
 817         if (XASE_RESC_ELM_SMALLP(l) && XASE_RESC_ELM_SMALLP(r)) {
 818                 return ase_resclass_sum_small(l, r, XASE_RESC_ELM_RING(l));
 819         } else {
 820 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 821                 return ase_resclass_sum_big(l, r, XASE_RESC_ELM_RING(l));
 822 #endif
 823         }
 824         return Qnil;
 825 }
 826
 827
 828 static inline Lisp_Object
 829 ase_resclass_sum_intg_small(
 830         Lisp_Object l, Lisp_Object intg, Lisp_Object result_ring)
 831 {
 832         if (INTP(intg)) {
 833                 EMACS_INT sum =
 834                         XASE_RESC_ELM(l)->small_data + XINT(intg);
 835                 return ase_make_resc_elm(make_int(sum), result_ring);
 836 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 837         } else if (BIGZP(intg)) {
 838                 EMACS_INT sum;
 839                 bigz_set_long(ent_scratch_bigz,
 840                               XASE_RESC_RNG(XASE_RESC_ELM_RING(l))->small_ring);
 841                 bigz_mod(ent_scratch_bigz, XBIGZ_DATA(intg), ent_scratch_bigz);
 842                 sum = XASE_RESC_ELM(l)->small_data +
 843                         bigz_to_long(ent_scratch_bigz);
 844                 return ase_make_resc_elm(make_int(sum), result_ring);
 845 #endif
 846         }
 847         return Qnil;
 848 }
 849
 850 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 851 static inline Lisp_Object
 852 ase_resclass_sum_intg_big(
 853         Lisp_Object l, Lisp_Object intg, Lisp_Object result_ring)
 854 {
 855         if (INTP(intg)) {
 856                 ase_resc_elm_t e = NULL;
 857                 bigz_set_long(ent_scratch_bigz, XINT(intg));
 858                 bigz_add(ent_scratch_bigz,
 859                          XASE_RESC_ELM_DATA(l), ent_scratch_bigz);
 860                 e = __ase_make_resc_elm_bigz(ent_scratch_bigz);
 861                 e->smallp = 0;
 862                 e->ring = result_ring;
 863                 _ase_resc_elm_canonicalise_big(e);
 864                 return _ase_wrap_resc_elm(e);
 865         } else if (BIGZP(intg)) {
 866                 ase_resc_elm_t e = NULL;
 867                 bigz_add(ent_scratch_bigz,
 868                          XASE_RESC_ELM_DATA(l), XBIGZ_DATA(intg));
 869                 e = __ase_make_resc_elm_bigz(ent_scratch_bigz);
 870                 e->smallp = 0;
 871                 e->ring = result_ring;
 872                 _ase_resc_elm_canonicalise_big(e);
 873                 return _ase_wrap_resc_elm(e);
 874         }
 875         return Qnil;
 876 }
 877 #endif
 878
 879 static Lisp_Object
 880 ase_resclass_sum_intg(Lisp_Object l, Lisp_Object r)
 881 {
 882         if (INTEGERP(l) && XASE_RESC_ELM_SMALLP(r)) {
 883                 return ase_resclass_sum_intg_small(
 884                         r, l, XASE_RESC_ELM_RING(r));
 885         } else if (INTEGERP(r) && XASE_RESC_ELM_SMALLP(l)) {
 886                 return ase_resclass_sum_intg_small(
 887                         l, r, XASE_RESC_ELM_RING(l));
 888 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 889         } else if (INTEGERP(l)) {
 890                 return ase_resclass_sum_intg_big(
 891                         r, l, XASE_RESC_ELM_RING(r));
 892         } else if (INTEGERP(r)) {
 893                 return ase_resclass_sum_intg_big(
 894                         l, r, XASE_RESC_ELM_RING(l));
 895 #endif
 896         }
 897         return Qnil;
 898 }
 899
 900
 901 static inline Lisp_Object
 902 ase_resclass_diff_small(Lisp_Object l, Lisp_Object r, Lisp_Object result_ring)
 903 {
 904         EMACS_INT diff =
 905                 XASE_RESC_ELM(l)->small_data - XASE_RESC_ELM(r)->small_data;
 906         return ase_make_resc_elm(make_int(diff), result_ring);
 907 }
 908
 909 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 910 static inline Lisp_Object
 911 ase_resclass_diff_big(Lisp_Object l, Lisp_Object r, Lisp_Object result_ring)
 912 {
 913         ase_resc_elm_t e = NULL;
 914         bigz_sub(ent_scratch_bigz,
 915                  XASE_RESC_ELM_DATA(l), XASE_RESC_ELM_DATA(r));
 916         e = __ase_make_resc_elm_bigz(ent_scratch_bigz);
 917         e->smallp = 0;
 918         e->ring = result_ring;
 919         _ase_resc_elm_canonicalise_big(e);
 920         return _ase_wrap_resc_elm(e);
 921 }
 922 #endif
 923
 924 static Lisp_Object
 925 ase_resclass_diff(Lisp_Object l, Lisp_Object r)
 926 {
 927         ase_resclass_check_rings(l, r);
 928
 929 #if 0
 930         result_ring = ent_intersection_factor_module(&l, &r);
 931 #endif
 932
 933         if (XASE_RESC_ELM_SMALLP(l) && XASE_RESC_ELM_SMALLP(r)) {
 934                 return ase_resclass_diff_small(l, r, XASE_RESC_ELM_RING(l));
 935         } else {
 936 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 937                 return ase_resclass_diff_big(l, r, XASE_RESC_ELM_RING(l));
 938 #endif
 939         }
 940         return Qnil;
 941 }
 942
 943
 944 static inline Lisp_Object
 945 ase_resclass_diff_intg_small(
 946         Lisp_Object l, Lisp_Object intg, Lisp_Object result_ring)
 947 {
 948         if (INTP(intg)) {
 949                 EMACS_INT diff =
 950                         XASE_RESC_ELM(l)->small_data - XINT(intg);
 951                 return ase_make_resc_elm(make_int(diff), result_ring);
 952 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 953         } else if (BIGZP(intg)) {
 954                 EMACS_INT diff;
 955                 bigz_set_long(ent_scratch_bigz,
 956                               XASE_RESC_RNG(XASE_RESC_ELM_RING(l))->small_ring);
 957                 bigz_mod(ent_scratch_bigz, XBIGZ_DATA(intg), ent_scratch_bigz);
 958                 diff = XASE_RESC_ELM(l)->small_data -
 959                         bigz_to_long(ent_scratch_bigz);
 960                 return ase_make_resc_elm(make_int(diff), result_ring);
 961 #endif
 962         }
 963         return Qnil;
 964 }
 965
 966 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 967 static inline Lisp_Object
 968 ase_resclass_diff_intg_big(
 969         Lisp_Object l, Lisp_Object intg, Lisp_Object result_ring)
 970 {
 971         if (INTP(intg)) {
 972                 ase_resc_elm_t e = NULL;
 973                 bigz_set_long(ent_scratch_bigz, XINT(intg));
 974                 bigz_sub(ent_scratch_bigz,
 975                          XASE_RESC_ELM_DATA(l), ent_scratch_bigz);
 976                 e = __ase_make_resc_elm_bigz(ent_scratch_bigz);
 977                 e->smallp = 0;
 978                 e->ring = result_ring;
 979                 _ase_resc_elm_canonicalise_big(e);
 980                 return _ase_wrap_resc_elm(e);
 981         } else if (BIGZP(intg)) {
 982                 ase_resc_elm_t e = NULL;
 983                 bigz_sub(ent_scratch_bigz,
 984                          XASE_RESC_ELM_DATA(l), XBIGZ_DATA(intg));
 985                 e = __ase_make_resc_elm_bigz(ent_scratch_bigz);
 986                 e->smallp = 0;
 987                 e->ring = result_ring;
 988                 _ase_resc_elm_canonicalise_big(e);
 989                 return _ase_wrap_resc_elm(e);
 990         }
 991         return Qnil;
 992 }
 993 #endif
 994
 995 static Lisp_Object
 996 ase_resclass_diff_intg(Lisp_Object l, Lisp_Object r)
 997 {
 998         if (XASE_RESC_ELM_SMALLP(l)) {
 999                 return ase_resclass_diff_intg_small(
1000                         l, r, XASE_RESC_ELM_RING(l));
1001 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1002         } else {
1003                 return ase_resclass_diff_intg_big(
1004                         l, r, XASE_RESC_ELM_RING(l));
1005 #endif
1006         }
1007         return Qnil;
1008 }
1009
1010
1011 static inline Lisp_Object
1012 ase_resclass_prod_small(Lisp_Object l, Lisp_Object r, Lisp_Object result_ring)
1013 {
1014         EMACS_INT prod =
1015                 XASE_RESC_ELM(l)->small_data * XASE_RESC_ELM(r)->small_data;
1016         return ase_make_resc_elm(make_int(prod), result_ring);
1017 }
1018
1019 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1020 static inline Lisp_Object
1021 ase_resclass_prod_big(Lisp_Object l, Lisp_Object r, Lisp_Object result_ring)
1022 {
1023         ase_resc_elm_t e = NULL;
1024         bigz_mul(ent_scratch_bigz,
1025                  XASE_RESC_ELM_DATA(l), XASE_RESC_ELM_DATA(r));
1026         e = __ase_make_resc_elm_bigz(ent_scratch_bigz);
1027         e->smallp = 0;
1028         e->ring = result_ring;
1029         _ase_resc_elm_canonicalise_big(e);
1030         return _ase_wrap_resc_elm(e);
1031 }
1032 #endif
1033
1034 static Lisp_Object
1035 ase_resclass_prod(Lisp_Object l, Lisp_Object r)
1036 {
1037         ase_resclass_check_rings(l, r);
1038
1039 #if 0
1040         result_ring = ent_intersection_factor_module(&l, &r);
1041 #endif
1042
1043         if (XASE_RESC_ELM_SMALLP(l) && XASE_RESC_ELM_SMALLP(r)) {
1044                 return ase_resclass_prod_small(l, r, XASE_RESC_ELM_RING(l));
1045         } else {
1046 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1047                 return ase_resclass_prod_big(l, r, XASE_RESC_ELM_RING(l));
1048 #endif
1049         }
1050         return Qnil;
1051 }
1052
1053 static inline Lisp_Object
1054 ase_resclass_prod_intg_small(
1055         Lisp_Object l, Lisp_Object intg, Lisp_Object result_ring)
1056 {
1057         if (INTP(intg)) {
1058                 EMACS_INT prod =
1059                         XASE_RESC_ELM(l)->small_data * XINT(intg);
1060                 return ase_make_resc_elm(make_int(prod), result_ring);
1061 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1062         } else if (BIGZP(intg)) {
1063                 EMACS_INT prod;
1064                 bigz_set_long(ent_scratch_bigz,
1065                               XASE_RESC_RNG(XASE_RESC_ELM_RING(l))->small_ring);
1066                 bigz_mod(ent_scratch_bigz, XBIGZ_DATA(intg), ent_scratch_bigz);
1067                 prod = XASE_RESC_ELM(l)->small_data *
1068                         bigz_to_long(ent_scratch_bigz);
1069                 return ase_make_resc_elm(make_int(prod), result_ring);
1070 #endif
1071         }
1072         return Qnil;
1073 }
1074
1075 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1076 static inline Lisp_Object
1077 ase_resclass_prod_intg_big(
1078         Lisp_Object l, Lisp_Object intg, Lisp_Object result_ring)
1079 {
1080         if (INTP(intg)) {
1081                 ase_resc_elm_t e = NULL;
1082                 bigz_set_long(ent_scratch_bigz, XINT(intg));
1083                 bigz_mul(ent_scratch_bigz,
1084                          XASE_RESC_ELM_DATA(l), ent_scratch_bigz);
1085                 e = __ase_make_resc_elm_bigz(ent_scratch_bigz);
1086                 e->smallp = 0;
1087                 e->ring = result_ring;
1088                 _ase_resc_elm_canonicalise_big(e);
1089                 return _ase_wrap_resc_elm(e);
1090         } else if (BIGZP(intg)) {
1091                 ase_resc_elm_t e = NULL;
1092                 bigz_mul(ent_scratch_bigz,
1093                          XASE_RESC_ELM_DATA(l), XBIGZ_DATA(intg));
1094                 e = __ase_make_resc_elm_bigz(ent_scratch_bigz);
1095                 e->smallp = 0;
1096                 e->ring = result_ring;
1097                 _ase_resc_elm_canonicalise_big(e);
1098                 return _ase_wrap_resc_elm(e);
1099         }
1100         return Qnil;
1101 }
1102 #endif
1103
1104 static Lisp_Object
1105 ase_resclass_prod_intg(Lisp_Object l, Lisp_Object r)
1106 {
1107         if (INTEGERP(l) && XASE_RESC_ELM_SMALLP(r)) {
1108                 return ase_resclass_prod_intg_small(
1109                         r, l, XASE_RESC_ELM_RING(r));
1110         } else if (INTEGERP(r) && XASE_RESC_ELM_SMALLP(l)) {
1111                 return ase_resclass_prod_intg_small(
1112                         l, r, XASE_RESC_ELM_RING(l));
1113 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1114         } else if (INTEGERP(l)) {
1115                 return ase_resclass_prod_intg_big(
1116                         r, l, XASE_RESC_ELM_RING(r));
1117         } else if (INTEGERP(r)) {
1118                 return ase_resclass_prod_intg_big(
1119                         l, r, XASE_RESC_ELM_RING(l));
1120 #endif
1121         }
1122         return Qnil;
1123 }
1124
1125
1126 static Lisp_Object
1127 ase_resclass_div(Lisp_Object l, Lisp_Object r)
1128 {
1129         ase_object_type_t idx = ase_optable_index_typesym(Qase_resc_elm);
1130         Lisp_Object inv = _ent_unop(ASE_UNARY_OP_INV, idx, r);
1131         Lisp_Object mul = _ent_binop(ASE_BINARY_OP_PROD, idx, l, idx, inv);
1132         return mul;
1133 }
1134
1135 static Lisp_Object
1136 ase_resclass_div_INT_T(Lisp_Object l, Lisp_Object r)
1137 {
1138         ase_object_type_t idx = ase_optable_index_typesym(Qase_resc_elm);
1139         Lisp_Object inv = _ent_unop(ASE_UNARY_OP_INV, idx, l);
1140         Lisp_Object mul = _ent_binop(ASE_BINARY_OP_PROD, idx, inv, INT_T, r);
1141         return mul;
1142 }
1143
1144 static Lisp_Object
1145 ase_resclass_INT_T_div(Lisp_Object l, Lisp_Object r)
1146 {
1147         ase_object_type_t idx = ase_optable_index_typesym(Qase_resc_elm);
1148         Lisp_Object inv = _ent_unop(ASE_UNARY_OP_INV, idx, r);
1149         Lisp_Object mul = _ent_binop(ASE_BINARY_OP_PROD, idx, l, INT_T, inv);
1150         return mul;
1151 }
1152
1153 static Lisp_Object
1154 ase_resclass_div_BIGZ_T(Lisp_Object l, Lisp_Object r)
1155 {
1156         ase_object_type_t idx = ase_optable_index_typesym(Qase_resc_elm);
1157         Lisp_Object inv = _ent_unop(ASE_UNARY_OP_INV, idx, l);
1158         Lisp_Object mul = _ent_binop(ASE_BINARY_OP_PROD, idx, inv, BIGZ_T, r);
1159         return mul;
1160 }
1161
1162 static Lisp_Object
1163 ase_resclass_BIGZ_T_div(Lisp_Object l, Lisp_Object r)
1164 {
1165         ase_object_type_t idx = ase_optable_index_typesym(Qase_resc_elm);
1166         Lisp_Object inv = _ent_unop(ASE_UNARY_OP_INV, idx, r);
1167         Lisp_Object mul = _ent_binop(ASE_BINARY_OP_PROD, idx, l, BIGZ_T, inv);
1168         return mul;
1169 }
1170
1171 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1172 static Lisp_Object
1173 ase_resclass_pow(Lisp_Object l, Lisp_Object r)
1174 {
1175         Lisp_Object rng = XASE_RESC_ELM_RING(l);
1176         bigz expo;
1177
1178         bigz_init(expo);
1179         if (INTP(r)) {
1180                 bigz_set_long(expo, ent_int(r));
1181         } else if (BIGZP(r)) {
1182                 bigz_set(expo, XBIGZ_DATA(r));
1183         } else {
1184                 Fsignal(Qoperation_error, r);
1185         }
1186
1187         if (XASE_RESC_ELM_SMALLP(l)) {
1188                 long res = 0;
1189                 bigz tmp;
1190
1191                 bigz_init(tmp);
1192                 bigz_set_long(tmp, XASE_RESC_RNG_SRING(rng));
1193                 bigz_set_long(ent_scratch_bigz, XASE_RESC_ELM_SDATA(l));
1194                 mpz_powm(ent_scratch_bigz, ent_scratch_bigz, expo, tmp);
1195                 res = bigz_to_long(ent_scratch_bigz);
1196                 bigz_fini(tmp);
1197                 bigz_fini(expo);
1198                 return ase_make_resc_elm(make_int(res), rng);
1199         } else {
1200                 ase_resc_elm_t e = NULL;
1201                 mpz_powm(ent_scratch_bigz, XASE_RESC_ELM_DATA(l),
1202                          expo, XASE_RESC_RNG_RING(l));
1203                 e = __ase_make_resc_elm_bigz(ent_scratch_bigz);
1204                 e->smallp = 0;
1205                 e->ring = XASE_RESC_ELM_RING(l);
1206                 _ase_resc_elm_canonicalise_big(e);
1207                 bigz_fini(expo);
1208                 return _ase_wrap_resc_elm(e);
1209         }
1210         bigz_fini(expo);
1211         return Qnil;
1212 }
1213 #endif
1214
1215 static Lisp_Object
1216 ase_resclass_neg(Lisp_Object l)
1217 {
1218         Lisp_Object rng = XASE_RESC_ELM_RING(l);
1219         if (XASE_RESC_ELM_SMALLP(l)) {
1220                 EMACS_INT sum =
1221                         XASE_RESC_RNG_SRING(rng) - XASE_RESC_ELM_SDATA(l);
1222                 return ase_make_resc_elm(make_int(sum), rng);
1223 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1224         } else {
1225                 ase_resc_elm_t e = NULL;
1226                 bigz_set(ent_scratch_bigz, XASE_RESC_RNG_RING(rng));
1227                 bigz_sub(ent_scratch_bigz,
1228                          ent_scratch_bigz, XASE_RESC_ELM_DATA(l));
1229                 e = __ase_make_resc_elm_bigz(ent_scratch_bigz);
1230                 e->smallp = 0;
1231                 e->ring = rng;
1232                 _ase_resc_elm_canonicalise_big(e);
1233                 return _ase_wrap_resc_elm(e);
1234 #endif
1235         }
1236         return Qnil;
1237 }
1238
1239 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1240 static Lisp_Object
1241 ase_resclass_inv(Lisp_Object r)
1242 {
1243         Lisp_Object rng = XASE_RESC_ELM_RING(r);
1244         int state = 0;
1245
1246
1247         if (XASE_RESC_ELM_SMALLP(r)) {
1248                 bigz tmp;
1249                 bigz_init(tmp);
1250                 bigz_set_long(tmp, XASE_RESC_ELM_SDATA(r));
1251                 bigz_set_long(ent_scratch_bigz, XASE_RESC_RNG_SRING(rng));
1252                 state = mpz_invert(ent_scratch_bigz, tmp, ent_scratch_bigz);
1253                 bigz_fini(tmp);
1254         } else {
1255                 state = mpz_invert(ent_scratch_bigz,
1256                                    XASE_RESC_ELM_DATA(r),
1257                                    XASE_RESC_RNG_RING(rng));
1258         }
1259
1260         if (!state) {
1261                 error("cannot operate on zero divisor");
1262                 return Qzero;
1263         }
1264
1265         if (XASE_RESC_ELM_SMALLP(r)) {
1266                 return ase_make_resc_elm(
1267                         make_int(bigz_to_long(ent_scratch_bigz)), rng);
1268         } else {
1269                 ase_resc_elm_t e = __ase_make_resc_elm_bigz(ent_scratch_bigz);
1270                 e->smallp = 0;
1271                 e->ring = rng;
1272                 _ase_resc_elm_canonicalise_big(e);
1273                 return _ase_wrap_resc_elm(e);
1274         }
1275         return Qnil;
1276 }
1277 #endif
1278
1279 /* relations */
1280 static int
1281 ase_resclass_eq(Lisp_Object l, Lisp_Object r)
1282 {
1283         ase_resclass_check_rings(l, r);
1284
1285         if (XASE_RESC_ELM_SMALLP(l)) {
1286                 return (XASE_RESC_ELM_SDATA(l) == XASE_RESC_ELM_SDATA(r));
1287 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1288         } else if (!XASE_RESC_ELM_SMALLP(l)) {
1289                 return bigz_eql(XASE_RESC_ELM_DATA(l), XASE_RESC_ELM_DATA(r));
1290 #endif
1291         }
1292         return 0;
1293 }
1294
1295 static int
1296 ase_resclass_ne(Lisp_Object l, Lisp_Object r)
1297 {
1298         ase_resclass_check_rings(l, r);
1299
1300         if (XASE_RESC_ELM_SMALLP(l)) {
1301                 return (XASE_RESC_ELM_SDATA(l) != XASE_RESC_ELM_SDATA(r));
1302 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1303         } else if (!XASE_RESC_ELM_SMALLP(l)) {
1304                 return !bigz_eql(XASE_RESC_ELM_DATA(l), XASE_RESC_ELM_DATA(r));
1305 #endif
1306         }
1307         return 1;
1308 }
1309
1310 static int
1311 ase_resclass_zerop(Lisp_Object elm)
1312 {
1313         if (XASE_RESC_ELM_SMALLP(elm)) {
1314                 return (XASE_RESC_ELM_SDATA(elm) == 0);
1315 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1316         } else if (!XASE_RESC_ELM_SMALLP(elm)) {
1317 #               define __d      XASE_RESC_ELM_DATA(elm)
1318                 return (bigz_fits_long_p(__d) && bigz_to_long(__d) == 0);
1319 #               undef __d
1320 #endif
1321         }
1322         return 0;
1323 }
1324
1325 static int
1326 ase_resclass_onep(Lisp_Object elm)
1327 {
1328         if (XASE_RESC_ELM_SMALLP(elm)) {
1329                 return (XASE_RESC_ELM_SDATA(elm) == 1);
1330 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1331         } else if (!XASE_RESC_ELM_SMALLP(elm)) {
1332 #               define __d      XASE_RESC_ELM_DATA(elm)
1333                 return (bigz_fits_long_p(__d) && bigz_to_long(__d) == 1);
1334 #               undef __d
1335 #endif
1336         }
1337         return 0;
1338 }
1339
1340 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1341 static int
1342 ase_resclass_unitp(Lisp_Object elm)
1343 {
1344         Lisp_Object rng = XASE_RESC_ELM_RING(elm);
1345         int state = 0;
1346
1347
1348         if (XASE_RESC_ELM_SMALLP(elm)) {
1349                 bigz tmp;
1350                 bigz_set_long(tmp, XASE_RESC_ELM_SDATA(elm));
1351                 bigz_set_long(ent_scratch_bigz, XASE_RESC_RNG_SRING(rng));
1352                 state = mpz_invert(ent_scratch_bigz, tmp, ent_scratch_bigz);
1353                 bigz_init(tmp);
1354         } else {
1355                 state = mpz_invert(ent_scratch_bigz,
1356                                    XASE_RESC_ELM_DATA(elm),
1357                                    XASE_RESC_RNG_RING(rng));
1358         }
1359         return state;
1360 }
1361 #endif
1362
1363 \f
1364 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1365 static Lisp_Object
1366 ase_resclass_lift_to_BIGZ_T(Lisp_Object number, ent_lift_args_t SXE_UNUSED(la))
1367 {
1368         if (XASE_RESC_ELM_SMALLP(number)) {
1369                 make_bigz(XASE_RESC_ELM_SDATA(number));
1370         } else {
1371                 return make_bigz_bz(XASE_RESC_ELM_DATA(number));
1372         }
1373         return Qnil;
1374 }
1375 #endif
1376
1377 static Lisp_Object
1378 ase_resclass_lift_to_INT_T(Lisp_Object number, ent_lift_args_t SXE_UNUSED(la))
1379 {
1380         if (XASE_RESC_ELM_SMALLP(number)) {
1381                 return make_int(XASE_RESC_ELM_SDATA(number));
1382 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1383         } else {
1384                 return make_int(bigz_to_long(XASE_RESC_ELM_DATA(number)));
1385 #endif
1386         }
1387         return Qnil;
1388 }
1389
1390 #ifdef HAVE_FPFLOAT
1391 static Lisp_Object
1392 ase_resclass_lift_to_FLOAT_T(Lisp_Object number, ent_lift_args_t SXE_UNUSED(la))
1393 {
1394         if (XASE_RESC_ELM_SMALLP(number)) {
1395                 return make_float(XASE_RESC_ELM_SDATA(number));
1396 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1397         } else {
1398                 return make_float(bigz_to_fpfloat(XASE_RESC_ELM_DATA(number)));
1399 #endif
1400         }
1401         return Qnil;
1402 }
1403 #endif
1404
1405 \f
1406 static inline void
1407 ent_resclass_nullary_optable_init(void)
1408 {
1409         ent_nullop_register(ASE_NULLARY_OP_ZERO, INDEF_T, Qzero);
1410         ent_nullop_register(ASE_NULLARY_OP_ONE, INDEF_T, Qone);
1411 }
1412
1413 static inline void
1414 ent_resclass_unary_optable_init(void)
1415 {
1416         ase_object_type_t idx = ase_optable_index_typesym(Qase_resc_elm);
1417         ent_unop_register(ASE_UNARY_OP_NEG, idx, ase_resclass_neg);
1418 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1419         ent_unop_register(ASE_UNARY_OP_INV, idx, ase_resclass_inv);
1420 #endif
1421 }
1422
1423 static inline void
1424 ent_resclass_binary_optable_init(void)
1425 {
1426         ase_object_type_t idx = ase_optable_index_typesym(Qase_resc_elm);
1427
1428         ent_binop_register(ASE_BINARY_OP_SUM,
1429                            idx, idx, ase_resclass_sum);
1430         ent_binop_register(ASE_BINARY_OP_SUM,
1431                            idx, INT_T, ase_resclass_sum_intg);
1432         ent_binop_register(ASE_BINARY_OP_SUM,
1433                            INT_T, idx, ase_resclass_sum_intg);
1434         ent_binop_register(ASE_BINARY_OP_SUM,
1435                            idx, BIGZ_T, ase_resclass_sum_intg);
1436         ent_binop_register(ASE_BINARY_OP_SUM,
1437                            BIGZ_T, idx, ase_resclass_sum_intg);
1438
1439         ent_binop_register(ASE_BINARY_OP_DIFF,
1440                            idx, idx, ase_resclass_diff);
1441         ent_binop_register(ASE_BINARY_OP_DIFF,
1442                            idx, INT_T, ase_resclass_diff_intg);
1443         ent_binop_register(ASE_BINARY_OP_DIFF,
1444                            idx, BIGZ_T, ase_resclass_diff_intg);
1445
1446         ent_binop_register(ASE_BINARY_OP_PROD,
1447                            idx, idx, ase_resclass_prod);
1448         ent_binop_register(ASE_BINARY_OP_PROD,
1449                            idx, INT_T, ase_resclass_prod_intg);
1450         ent_binop_register(ASE_BINARY_OP_PROD,
1451                            INT_T, idx, ase_resclass_prod_intg);
1452         ent_binop_register(ASE_BINARY_OP_PROD,
1453                            idx, BIGZ_T, ase_resclass_prod_intg);
1454         ent_binop_register(ASE_BINARY_OP_PROD,
1455                            BIGZ_T, idx, ase_resclass_prod_intg);
1456
1457         ent_binop_register(ASE_BINARY_OP_DIV,
1458                            idx, idx, ase_resclass_div);
1459         ent_binop_register(ASE_BINARY_OP_QUO,
1460                            idx, idx, ase_resclass_div);
1461         ent_binop_register(ASE_BINARY_OP_DIV,
1462                            idx, INT_T, ase_resclass_div_INT_T);
1463         ent_binop_register(ASE_BINARY_OP_QUO,
1464                            idx, INT_T, ase_resclass_div_INT_T);
1465         ent_binop_register(ASE_BINARY_OP_DIV,
1466                            INT_T, idx, ase_resclass_INT_T_div);
1467         ent_binop_register(ASE_BINARY_OP_QUO,
1468                            INT_T, idx, ase_resclass_INT_T_div);
1469         ent_binop_register(ASE_BINARY_OP_DIV,
1470                            idx, BIGZ_T, ase_resclass_div_BIGZ_T);
1471         ent_binop_register(ASE_BINARY_OP_QUO,
1472                            idx, BIGZ_T, ase_resclass_div_BIGZ_T);
1473         ent_binop_register(ASE_BINARY_OP_DIV,
1474                            BIGZ_T, idx, ase_resclass_BIGZ_T_div);
1475         ent_binop_register(ASE_BINARY_OP_QUO,
1476                            BIGZ_T, idx, ase_resclass_BIGZ_T_div);
1477
1478 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1479         ent_binop_register(ASE_BINARY_OP_POW,
1480                            idx, INT_T, ase_resclass_pow);
1481         ent_binop_register(ASE_BINARY_OP_POW,
1482                            idx, BIGZ_T, ase_resclass_pow);
1483 #endif
1484 }
1485
1486 static inline void
1487 ent_resclass_unary_reltable_init(void)
1488 {
1489         ase_object_type_t idx = ase_optable_index_typesym(Qase_resc_elm);
1490         ent_unrel_register(ASE_UNARY_REL_ZEROP, idx, ase_resclass_zerop);
1491         ent_unrel_register(ASE_UNARY_REL_ONEP, idx, ase_resclass_onep);
1492 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1493         ent_unrel_register(ASE_UNARY_REL_UNITP, idx, ase_resclass_unitp);
1494 #endif
1495 }
1496
1497 static inline void
1498 ent_resclass_binary_reltable_init(void)
1499 {
1500         ase_object_type_t idx = ase_optable_index_typesym(Qase_resc_elm);
1501         ent_binrel_register(ASE_BINARY_REL_EQUALP,
1502                             idx, idx, ase_resclass_eq);
1503         ent_binrel_register(ASE_BINARY_REL_NEQP,
1504                             idx, idx, ase_resclass_ne);
1505 }
1506
1507 static inline void
1508 ent_resclass_lifttable_init(void)
1509 {
1510         ase_object_type_t idx = ase_optable_index_typesym(Qase_resc_elm);
1511         ent_lift_register(idx, INT_T, ase_resclass_lift_to_INT_T);
1512 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1513         ent_lift_register(idx, BIGZ_T, ase_resclass_lift_to_BIGZ_T);
1514 #endif
1515 #ifdef HAVE_FPFLOAT
1516         ent_lift_register(idx, FLOAT_T, ase_resclass_lift_to_FLOAT_T);
1517 #endif
1518 }
1519
1520 \f
1521 /* ###autoload */
1522 DEFUN("make-residue-class-ring", Fmake_residue_class_ring, 1, 1, 0, /*
1523 Return a residue class ring of size MODULUS (>= 2).
1524 */
1525        (modulus))
1526 {
1527         CHECK_INTEGER(modulus);
1528         if (NILP(Fnonnegativep(modulus)))
1529                 error("cannot create ring with negative modulus");
1530         if (ent_unrel_zerop(modulus))
1531                 error("cannot create ring of size 0");
1532         if (ent_unrel_onep(modulus))
1533                 error("ring is identical to Z");
1534
1535         return ase_make_resc_rng(modulus);
1536 }
1537
1538 /* ###autoload */
1539 DEFUN("make-residue-class", Fmake_residue_class, 2, 2, 0, /*
1540 Return the residue class of ELEMENT in RING.
1541 */
1542       (element, ring))
1543 {
1544         CHECK_ASE_RESC_RNG(ring);
1545         CHECK_INTEGER(element);
1546
1547         return ase_make_resc_elm(element, ring);
1548 }
1549
1550 /* ###autoload */
1551 DEFUN("residue-class-ring", Fresidue_class_ring, 1, 1, 0, /*
1552 Return the parental residue class ring (the world) of RESCLASS.
1553 */
1554       (resclass))
1555 {
1556         CHECK_ASE_RESC_ELM(resclass);
1557
1558         return XASE_RESC_ELM_RING(resclass);
1559 }
1560
1561 #if 0
1562 /* ###autoload */
1563 D3FUN("residue-class-modulus", Fresidue_class_modulus, 1, 1, 0, /*
1564 Return the modulus of the residue class ring RING-OR-ELEMENT,
1565 or the modulus of a residue class, respectively.
1566                                                                 */
1567        (ring_or_element))
1568 {
1569         Lisp_Object rng;
1570
1571         if (!ASE_RESC_ELM_P(ring_or_element) &&
1572             !ASE_RESC_RNG_P(ring_or_element)) {
1573                 return wrong_type_argument(Qase_resc_elm_p, ring_or_element);
1574         }
1575
1576         if (ASE_RESC_ELM_P(ring_or_element))
1577                 rng = XASE_RESC_ELM_RING(ring_or_element);
1578         else if (ASE_RESC_RNG_P(ring_or_element))
1579                 rng = ring_or_element;
1580         else
1581                 return Qzero;
1582
1583         return make_bigz_bz(XASE_RESC_RNG_RING(rng));
1584 }
1585
1586 /* ###autoload */
1587 D3FUN("residue-class-representant", Fresidue_class_representant, 1, 1, 0, /*
1588 Return the representant of the residue class ELEMENT lifted
1589 to the ring of rational integers.
1590                                                                           */
1591        (element))
1592 {
1593         CHECK_ASE_RESC_ELM(element);
1594
1595         return make_bigz_bz(XASE_RESC_ELM_DATA(element));
1596 }
1597 #endif
1598
1599 /* ###autoload */
1600 DEFUN ("residue-class-ring-p", Fresidue_class_ring_p, 1, 1, 0, /*
1601 Return t if OBJECT is a residue class ring, nil otherwise.
1602 */
1603        (object))
1604 {
1605         return ASE_RESC_RNG_P(object) ? Qt : Qnil;
1606 }
1607
1608 /* ###autoload */
1609 DEFUN ("residue-class-p", Fresidue_class_p, 1, 1, 0, /*
1610 Return t if OBJECT is a residue class, nil otherwise.
1611 */
1612        (object))
1613 {
1614         return ASE_RESC_ELM_P(object) ? Qt : Qnil;
1615 }
1616
1617 /* from number-to-string */
1618 #ifdef HAVE_RESCLASS
1619         if (RESC_ELMP(number)) {
1620                 char *estr = (char*)resc_elm_to_string(
1621                         XRESC_ELM_DATA(number), 10);
1622                 char *rstr = (char*)resc_rng_to_string(
1623                         XRESC_RNG_DATA(XRESC_ELM_RING(number)), 10);
1624                 int elen = strlen(estr);
1625                 int rlen = strlen(rstr);
1626                 Lisp_Object result;
1627
1628                 XREALLOC_ARRAY(estr, char, elen+1+rlen+1 + 1);
1629                 strncat(estr, "+", 1);
1630                 strncat(estr, rstr, rlen);
1631                 strncat(estr, "Z", 1);
1632                 result = build_string(estr);
1633                 free(estr);
1634                 free(rstr);
1635                 return result;
1636         }
1637 #endif
1638
1639 /* from zero-divisor-p */
1640 #ifdef HAVE_RESCLASS
1641         case RESC_ELM_T: {
1642                 bigz bz;
1643
1644                 bigz_init(bz);
1645                 if (mpz_invert(bz, XRESC_ELM_DATA(number),
1646                                XRESC_RNG_DATA(XRESC_ELM_RING(number))))
1647                         result = Qnil;
1648                 else
1649                         result = Qt;
1650
1651                 bigz_fini(bz);
1652                 break;
1653         }
1654 #endif
1655
1656 \f
1657 /* initialiser code */
1658 #define EMODNAME        ase_resclass
1659
1660 static inline void
1661 ase_resclass_binary_optable_init(void)
1662 {
1663         ent_resclass_nullary_optable_init();
1664         ent_resclass_unary_optable_init();
1665         ent_resclass_binary_optable_init();
1666         ent_resclass_unary_reltable_init();
1667         ent_resclass_binary_reltable_init();
1668         ent_resclass_lifttable_init();
1669 }
1670
1671 void
1672 EMOD_PUBINIT(void)
1673 {
1674         DEFSUBR(Fmake_residue_class_ring);
1675         DEFSUBR(Fmake_residue_class);
1676         DEFSUBR(Fresidue_class_ring);
1677 #if 0
1678         DEFSUBR(Fresidue_class_modulus);
1679         DEFSUBR(Fresidue_class_representant);
1680 #endif
1681         DEFSUBR(Fresidue_class_ring_p);
1682         DEFSUBR(Fresidue_class_p);
1683
1684         DEFSYMBOL(Qase_resclass);
1685         DEFASETYPE_WITH_OPS(Qase_resc_rng, "ase:residue-class-ring");
1686         defsymbol(&Qase_resc_rng_p, "ase:residue-class-ring-p");
1687         DEFASETYPE_WITH_OPS(Qase_resc_elm, "ase:residue-class");
1688         defsymbol(&Qase_resc_elm_p, "ase:residue-class-p");
1689
1690         ase_resclass_binary_optable_init();
1691
1692         Fprovide(Qase_resclass);
1693         Fprovide(intern("resclass"));
1694
1695         EMOD_PUBREINIT();
1696 }
1697
1698 void
1699 EMOD_PUBREINIT(void)
1700 {
1701         sane_small = (snprintf(NULL, 0, "%ld", EMACS_INT_MAX) + 7) & -3;
1702         /* defined in lread.c, declared in ent.h */
1703         ase_resc_rng_pred_f = ase_resc_rng_string_p;
1704         ase_resc_rng_f = ase_resc_rng_from_string;
1705         ase_resc_elm_pred_f = ase_resc_elm_string_p;
1706         ase_resc_elm_f = ase_resc_elm_from_string;
1707 }
1708
1709 void
1710 EMOD_PUBDEINIT(void)
1711 {
1712         Frevoke(Qase_resclass);
1713         Frevoke(intern("resclass"));
1714 }
1715
1716 /* ent-resclass.c ends here */