Real-time collaboration for Jupyter Notebooks, Linux Terminals, LaTeX, VS Code, R IDE, and more,
all in one place.
Real-time collaboration for Jupyter Notebooks, Linux Terminals, LaTeX, VS Code, R IDE, and more,
all in one place.
| Download
GAP 4.8.9 installation with standard packages -- copy to your CoCalc project to get it
Project: cocalc-sagemath-dev-slelievre
Views: 418346/****************************************************************************1**2*W gmpints.c GAP source John McDermott3**4**5**6**7*Y Copyright (C) 1996, Lehrstuhl D für Mathematik, RWTH Aachen, Germany8*Y (C) 1998 School Math and Comp. Sci., University of St Andrews, Scotland9*Y Copyright (C) 2002 The GAP Group10**11** This file implements the functions handling GMP integers.12**13*/14#include "system.h" /* Ints, UInts */1516#include "gasman.h" /* garbage collector */17#include "objects.h" /* objects */18#include "scanner.h" /* scanner */1920#include "gvars.h" /* global variables */2122#include "calls.h" /* generic call mechanism */23#include "opers.h" /* generic operations */2425#include "ariths.h" /* basic arithmetic */2627#include "bool.h" /* booleans */2829#include "gap.h" /* error handling, initialisation */30#include "code.h" /* needed by stats.h */31#include "stats.h" /* for TakeInterrupt */3233#include "records.h" /* generic records */34#include "precord.h" /* plain records */3536#include "lists.h" /* generic lists */37#include "string.h" /* strings */3839#include "saveload.h" /* saving and loading */4041#include "intfuncs.h"4243#include <stdio.h>4445#ifdef HAVE_MATH_H46#include <math.h>47#endif4849#include <stdlib.h>5051#include <assert.h>52#include <string.h>53#include <ctype.h>545556#ifdef USE_GMP5758/* TODO: Remove after Ward2 */59#ifndef WARD_ENABLED6061// GMP must be included outside of 'extern C'62#ifdef GAP_IN_EXTERN_C63}64#endif65#include <gmp.h>66#ifdef GAP_IN_EXTERN_C67extern "C" {68#endif6970#include "gmpints.h" /* GMP integers */7172#ifdef SYS_IS_64_BIT73#define SaveLimb SaveUInt874#define LoadLimb LoadUInt875#else76#define SaveLimb SaveUInt477#define LoadLimb LoadUInt478#endif7980#define INTBASE (1L << (GMP_LIMB_BITS/2))818283/* macros to save typing later :) */84#define VAL_LIMB0(obj) ( *(TypLimb *)ADDR_OBJ(obj) )85#define SET_VAL_LIMB0(obj,val) ( *(TypLimb *)ADDR_OBJ(obj) = val )86#define IS_INTPOS(obj) ( TNUM_OBJ(obj) == T_INTPOS )87#define IS_INTNEG(obj) ( TNUM_OBJ(obj) == T_INTNEG )88#define IS_LARGEINT(obj) ( ( TNUM_OBJ(obj) == T_INTPOS ) || \89( TNUM_OBJ(obj) == T_INTNEG ) )9091/* for fallbacks to library */92Obj String;939495/****************************************************************************96**97*F TypeInt(<gmp>) . . . . . . . . . . . . . . . . . . . type of integer98**99** 'TypeInt' returns the type of the integer <gmp>.100**101** 'TypeInt' is the function in 'TypeObjFuncs' for integers.102*/103Obj TYPE_INT_SMALL_ZERO;104Obj TYPE_INT_SMALL_POS;105Obj TYPE_INT_SMALL_NEG;106Obj TYPE_INT_LARGE_POS;107Obj TYPE_INT_LARGE_NEG;108109Obj TypeIntSmall (110Obj val )111{112if ( 0 == INT_INTOBJ(val) ) {113return TYPE_INT_SMALL_ZERO;114}115else if ( 0 < INT_INTOBJ(val) ) {116return TYPE_INT_SMALL_POS;117}118else {119return TYPE_INT_SMALL_NEG;120}121}122123Obj TypeIntLargePos ( Obj val )124{125return TYPE_INT_LARGE_POS;126}127128Obj TypeIntLargeNeg ( Obj val )129{130return TYPE_INT_LARGE_NEG;131}132133134/****************************************************************************135**136*F FuncIS_INT( <self>, <val> ) . . . . . . . . . . internal function 'IsInt'137**138** 'FuncIS_INT' implements the internal filter 'IsInt'.139**140** 'IsInt( <val> )'141**142** 'IsInt' returns 'true' if the value <val> is an small integer or a143** large int, and 'false' otherwise.144*/145Obj IsIntFilt;146147Obj FuncIS_INT ( Obj self, Obj val )148{149if ( TNUM_OBJ(val) == T_INT150|| TNUM_OBJ(val) == T_INTPOS151|| TNUM_OBJ(val) == T_INTNEG ) {152return True;153}154else if ( TNUM_OBJ(val) < FIRST_EXTERNAL_TNUM ) {155return False;156}157else {158return DoFilter( self, val );159}160}161162163/****************************************************************************164**165*F SaveInt( <gmp> )166**167**168*/169void SaveInt( Obj gmp )170{171TypLimb *ptr;172UInt i;173ptr = (TypLimb *)ADDR_INT(gmp);174for (i = 0; i < SIZE_INT(gmp); i++)175SaveLimb(*ptr++);176return;177}178179180/****************************************************************************181**182*F LoadInt( <gmp> )183**184**185*/186void LoadInt( Obj gmp )187{188TypLimb *ptr;189UInt i;190ptr = (TypLimb *)ADDR_INT(gmp);191for (i = 0; i < SIZE_INT(gmp); i++)192*ptr++ = LoadLimb();193return;194}195196197/****************************************************************************198**199*F NEW_INT( <gmp> )200**201**202*/203static inline Obj NEW_INT( Obj gmp )204{205Obj new;206207new = NewBag( TNUM_OBJ(gmp), SIZE_OBJ(gmp) );208memcpy( ADDR_INT(new), ADDR_INT(gmp), SIZE_OBJ(gmp) );209210return new;211}212213214/****************************************************************************215**216*F NEW_INTPOS( <gmp> )217**218**219*/220static inline Obj NEW_INTPOS( Obj gmp )221{222Obj new;223224new = NewBag( T_INTPOS, SIZE_OBJ(gmp) );225memcpy( ADDR_INT(new), ADDR_INT(gmp), SIZE_OBJ(gmp) );226227return new;228}229230231/****************************************************************************232**233*F NEW_INTNEG( <gmp> )234**235**236**237static inline Obj NEW_INTNEG( Obj gmp )238{239Obj new;240241new = NewBag( T_INTNEG, SIZE_OBJ(gmp) );242memcpy( ADDR_INT(new), ADDR_INT(gmp), SIZE_OBJ(gmp) );243244return new;245}246*/247248/****************************************************************************249**250*F GMP_NORMALIZE( <gmp> ) . . . . . . . remove leading zeros from a GMP bag251**252** 'GMP_NORMALIZE' removes any leading zeros from a <GMP> and returns a253** small int or resizes the bag if possible.254**255*/256Obj FuncGMP_NORMALIZE( Obj self, Obj gmp )257{258if ( !IS_LARGEINT(gmp) ) return Fail;259return GMP_NORMALIZE( gmp );260}261262Obj GMP_NORMALIZE ( Obj gmp )263{264TypGMPSize size;265if IS_INTOBJ( gmp ) {266return gmp;267}268for ( size = SIZE_INT(gmp); size != (TypGMPSize)1; size-- ) {269if ( ADDR_INT(gmp)[(size - 1)] != (TypLimb)0 ) {270break;271}272}273if ( size < SIZE_INT(gmp) ) {274ResizeBag( gmp, size*sizeof(TypLimb) );275}276return gmp;277}278279Obj FuncGMP_REDUCE( Obj self, Obj gmp )280{281if ( !IS_LARGEINT(gmp) ) return Fail;282return GMP_REDUCE( gmp );283}284285Obj GMP_REDUCE( Obj gmp )286{287if IS_INTOBJ( gmp ) {288return gmp;289}290if ( SIZE_INT(gmp) == 1){291if ( ( VAL_LIMB0(gmp) < (TypLimb)((1L<<NR_SMALL_INT_BITS)) ) ||292( IS_INTNEG(gmp) &&293( VAL_LIMB0(gmp) == (TypLimb)(1L<<NR_SMALL_INT_BITS) ) ) ) {294if ( IS_INTNEG(gmp) ) {295return INTOBJ_INT( -(Int)VAL_LIMB0(gmp) );296}297else {298return INTOBJ_INT( (Int)VAL_LIMB0(gmp) );299}300}301}302return gmp;303}304305306/****************************************************************************307**308*F FuncGMP_INTOBJ(<gmp>) . . . . . . . . . . . . . . . . . . . . conversion309**310*/311Obj FuncGMP_INTOBJ( Obj self, Obj i )312{313Obj gmp;314Int j;315316if ( !IS_INTOBJ(i) ) {317return Fail;318}319else {320j = INT_INTOBJ( i );321if ( j < 0 ) {322gmp = NewBag( T_INTNEG, sizeof(TypLimb) );323j = -j;324}325else {326gmp = NewBag( T_INTPOS, sizeof(TypLimb) );327}328}329memcpy( ADDR_INT(gmp), &j, sizeof(Int) );330return gmp;331}332333334/****************************************************************************335**336*F GMPorINTOBJ_INT( <cint> ) . . . . . . . . convert c int to gmp or intobj337**338** 'GMPorINTOBJ_INT' takes the C integer <cint> and returns the equivalent339** GMP obj or int obj, according to the value of <cint>.340**341*/342Obj GMPorINTOBJ_INT( Int i )343{344Obj gmp;345346if ( (-(1L<<NR_SMALL_INT_BITS) <= i) && (i < 1L<<NR_SMALL_INT_BITS )) {347return INTOBJ_INT(i);348}349else if (i < 0 ) {350gmp = NewBag( T_INTNEG, sizeof(TypLimb) );351}352else {353gmp = NewBag( T_INTPOS, sizeof(TypLimb) );354}355SET_VAL_LIMB0( gmp, i );356return gmp;357}358359Obj ObjInt_Int( Int i )360{361return GMPorINTOBJ_INT( i );362}363364Obj ObjInt_UInt( UInt i )365{366Obj gmp;367UInt bound = 1UL << NR_SMALL_INT_BITS;368369if (i < bound) {370return INTOBJ_INT(i);371}372else {373gmp = NewBag( T_INTPOS, sizeof(TypLimb) );374SET_VAL_LIMB0( gmp, i );375return gmp;376}377}378379380/****************************************************************************381**382*F PrintInt( <gmp> ) . . . . . . . . . . . . . . . . print a GMP constant383**384** 'PrintInt' prints the GMP integer <gmp> in the usual decimal385** notation.386**387** cf PrintInt in integer.c388*/389void PrintInt ( Obj op )390{391Char buf[20000];392UInt signlength;393Obj str;394/* print a small integer */395if ( IS_INTOBJ(op) ) {396Pr( "%>%d%<", INT_INTOBJ(op), 0L );397}398399/* print a large integer */400else if ( SIZE_INT(op) < 1000 ) {401/* use gmp func to print int to buffer */402if (!IS_INTPOS(op)) {403buf[0] ='-';404signlength = 1;405} else {406signlength = 0;407}408gmp_snprintf((char *)(buf+signlength),20000-signlength,409"%Nd", (TypLimb *)ADDR_INT(op),410(TypGMPSize)SIZE_INT(op));411412/* print the buffer, %> means insert '\' before a linebreak */413Pr("%>%s%<",(Int)buf, 0);414}415else {416str = CALL_1ARGS( String, op );417Pr("%>%s%<",(Int)(CHARS_STRING(str)), 0);418/* for a long time Print of large ints did not follow the general idea419* that Print should produce something that can be read back into GAP:420Pr("<<an integer too large to be printed>>",0L,0L); */421}422}423424425/****************************************************************************426**427*F FuncHexStringInt( <self>, <gmp> ) . . . . . . . . hex string for gmp int428*F FuncIntHexString( <self>, <string> ) . . . . . . gmp int from hex string429**430** The function `FuncHexStringInt' constructs from a gmp integer the431** corresponding string in hexadecimal notation. It has a leading '-'432** for negative numbers and the digits 10..15 are written as A..F.433**434** The function `FuncIntHexString' does the converse, but here the435** letters a..f are also allowed in <string> instead of A..F.436**437*/438Obj FuncHexStringInt( Obj self, Obj integer )439{440size_t alloc_size, str_size;441Int i, j, n; /* len */442UInt nf;443/* TypLimb d, f; */444UInt1 *p, a, *s;445Obj res;446447/* immediate integers */448if (IS_INTOBJ(integer)) {449n = INT_INTOBJ(integer);450/* 0 is special */451if (n == 0) {452res = NEW_STRING(1);453CHARS_STRING(res)[0] = '0';454return res;455}456457/* else we create a string big enough for any immediate integer */458res = NEW_STRING(2 * INTEGER_UNIT_SIZE + 1);459p = CHARS_STRING(res);460/* handle sign */461if (n<0) {462p[0] = '-';463n = -n;464p++;465}466else467SET_LEN_STRING(res, GET_LEN_STRING(res)-1);468/* collect digits, skipping leading zeros */469j = 0;470nf = ((UInt)15) << (4*(2*INTEGER_UNIT_SIZE-1));471for (i = 2*INTEGER_UNIT_SIZE; i; i-- ) {472a = ((UInt)n & nf) >> (4*(i-1));473if (j==0 && a==0) SET_LEN_STRING(res, GET_LEN_STRING(res)-1);474else if (a<10) p[j++] = a + '0';475else p[j++] = a - 10 + 'A';476nf = nf >> 4;477}478/* final null character */479p[j] = 0;480return res;481}482483else if ( IS_LARGEINT(integer) ) {484alloc_size = SIZE_INT(integer)*sizeof(TypLimb)*2+1;485alloc_size += IS_INTNEG(integer);486487res = NEW_STRING( alloc_size );488s = CHARS_STRING( res );489490if ( IS_INTNEG(integer) )491*s++ = '-';492493str_size = mpn_get_str( s, 16, ADDR_INT(integer), SIZE_INT(integer) );494assert ( str_size <= alloc_size - ( IS_INTNEG(integer) ) );495496for (j = 0; j < str_size-1; j++)497if (s[j] != 0)498break;499500501for ( i = 0; i < str_size-j; i++ )502s[i] = "0123456789ABCDEF"[s[i+j]];503504assert ( str_size - j == 1 || *s != '0' );505506/* findme - this fails: */507/* assert ( strlen( CSTR_STRING(res) ) == alloc_size ); */508/* adjust length in case of trailing \0 characters */509/* [Is there a way to get it right from the beginning? FL] */510/* while (s[alloc_size-1] == '\0')511alloc_size--; */512SET_LEN_STRING(res, str_size-j + (IS_INTNEG(integer)));513/* assert ( strlen( CSTR_STRING(res) ) == GET_LEN_STRING(res) ); */514return res;515}516517else518ErrorReturnObj("HexStringInt: argument must be a int, (not a %s)",519(Int)TNAM_OBJ(integer), 0L,520"");521/* please picky cc */522return (Obj) 0L;523524}525526527Obj FuncIntHexString( Obj self, Obj str )528{529Obj res;530Int i, j, len, sign, nd;531UInt n;532UInt1 *p, a;533UChar c;534535if (! IsStringConv(str))536ErrorReturnObj("IntHexString: argument must be string (not a %s)",537(Int)TNAM_OBJ(str), 0L,538"");539540len = GET_LEN_STRING(str);541if (len == 0) {542res = INTOBJ_INT(0);543return res;544}545if (*(CHARS_STRING(str)) == '-') {546sign = -1;547i = 1;548}549else {550sign = 1;551i = 0;552}553554while ((CHARS_STRING(str))[i] == '0' && i < len)555i++;556557558if ((len-i)*4 <= NR_SMALL_INT_BITS) {559n = 0;560p = CHARS_STRING(str);561for (; i<len; i++) {562a = p[i];563if (a>96)564a -= 87;565else if (a>64)566a -= 55;567else568a -= 48;569if (a > 15)570ErrorReturnObj("IntHexString: non-valid character in hex-string",5710L, 0L, "");572n = (n << 4) + a;573}574res = INTOBJ_INT(sign * n);575return res;576}577578else {579nd = (len-i)/INTEGER_UNIT_SIZE;580if (nd * INTEGER_UNIT_SIZE < (len-i)) nd++;581/* nd += ((3*nd) % 4); */582if (sign == 1)583res = NewBag( T_INTPOS, nd*sizeof(TypLimb) );584else585res = NewBag( T_INTNEG, nd*sizeof(TypLimb) );586587p = CHARS_STRING(str)+i;588589/* findme */590/* the following destroys the supplied string - document this */591for (j=0;j<len-i;j++){592c=p[j];593if (IsDigit(c))594p[j] = c - '0';595else if (islower((unsigned int)c))596p[j] = c - 'a' + 10;597else if (isupper((unsigned int)c))598p[j] = c - 'A' + 10;599else600ErrorReturnObj("IntHexString: non-valid character in hex-string",6010L, 0L, "");602if (p[j] >= 16)603ErrorReturnObj("IntHexString: non-valid character in hex-string",6040L, 0L, "");605}606607mpn_set_str(ADDR_INT(res),p,len-i,16);608res = GMP_NORMALIZE(res);609return res;610}611}612613/****************************************************************************614**615** Implementation of Log2Int for C integers.616*/617618Int CLog2Int(Int a)619{620Int res, mask;621if (a < 0) a = -a;622if (a < 1) return -1;623if (a < 65536) {624for(mask = 2, res = 0; ;mask *= 2, res += 1) {625if(a < mask) return res;626}627}628for(mask = 65536, res = 15; ;mask *= 2, res += 1) {629if(a < mask) return res;630}631}632633/****************************************************************************634**635*F FuncLog2Int( <self>, <gmp> ) . . . . . . . . . . nr of bits of a GMP - 1636**637** Given to GAP-Level as "Log2Int".638*/639Obj FuncLog2Int( Obj self, Obj integer)640{641Int d;642Int a, len;643TypLimb dmask;644645/* case of small ints */646if (IS_INTOBJ(integer)) {647return INTOBJ_INT(CLog2Int(INT_INTOBJ(integer)));648}649650/* case of long ints */651if ( IS_LARGEINT(integer) ) {652for (len = SIZE_INT(integer); ADDR_INT(integer)[len-1] == 0; len--);653/* Instead of computing654res = len * GMP_LIMB_BITS - d;655we keep len and d separate, because on 32 bit systems res may656not fit into an Int (and not into an immediate integer). */657d = 1;658a = (TypLimb)(ADDR_INT(integer)[len-1]);659for(dmask = (TypLimb)1 << (GMP_LIMB_BITS - 1);660(dmask & a) == 0 && dmask != (TypLimb)0;661dmask = dmask >> 1, d++);662return DiffInt(ProdInt(INTOBJ_INT(len), INTOBJ_INT(GMP_LIMB_BITS)),663INTOBJ_INT(d));664}665else {666ErrorReturnObj("Log2Int: argument must be a int, (not a %s)",667(Int)TNAM_OBJ(integer), 0L,668"");669/* please picky cc */670return (Obj) 0L;671}672}673674/****************************************************************************675**676*F FuncSTRING_INT( <self>, <gmp> ) . . . . . . . . convert a GMP to a string677**678** `FuncSTRING_INT' returns an immutable string representing the integer679** <gmp>680**681*/682Obj FuncSTRING_INT( Obj self, Obj integer )683{684Int x;685Obj str;686Int len;687Int i;688Char c;689Int neg;690691692/* handle a small integer */693if ( IS_INTOBJ(integer) ) {694x = INT_INTOBJ(integer);695str = NEW_STRING( (NR_SMALL_INT_BITS+5)/3 );696RetypeBag(str, T_STRING+IMMUTABLE);697len = 0;698/* Case of zero */699if (x == 0)700{701CHARS_STRING(str)[0] = '0';702CHARS_STRING(str)[1] = '\0';703ResizeBag(str, SIZEBAG_STRINGLEN(1));704SET_LEN_STRING(str, 1);705706return str;707}708/* Negative numbers */709if (x < 0)710{711CHARS_STRING(str)[len++] = '-';712x = -x;713neg = 1;714}715else716neg = 0;717718/* Now the main case */719while (x != 0)720{721CHARS_STRING(str)[len++] = '0'+ x % 10;722x /= 10;723}724CHARS_STRING(str)[len] = '\0';725726/* finally, reverse the digits in place */727for (i = neg; i < (neg+len)/2; i++)728{729c = CHARS_STRING(str)[neg+len-1-i];730CHARS_STRING(str)[neg+len-1-i] = CHARS_STRING(str)[i];731CHARS_STRING(str)[i] = c;732}733734ResizeBag(str, SIZEBAG_STRINGLEN(len));735SET_LEN_STRING(str, len);736return str;737}738739/* handle a large integer */740else if ( SIZE_INT(integer) < 1000 ) {741742/* findme - enough space for a 1000 limb gmp int on a 64 bit machine */743/* change when 128 bit comes along! */744Char buf[20000];745746if IS_INTNEG(integer) {747len = gmp_snprintf( buf, sizeof(buf)-1, "-%Ni", (TypLimb *)ADDR_INT(integer),748(TypGMPSize)SIZE_INT(integer) );749}750else {751len = gmp_snprintf( buf, sizeof(buf)-1, "%Ni", (TypLimb *)ADDR_INT(integer),752(TypGMPSize)SIZE_INT(integer) );753}754755assert(len < sizeof(buf));756C_NEW_STRING( str, (TypGMPSize)len, buf );757758return str;759760}761762else {763764/* Very large integer, fall back on the GAP function */765return CALL_1ARGS( String, integer);766}767}768769770/****************************************************************************771**772*F EqInt( <gmpL>, <gmpR> ) . . . . . . . . . test if two integers are equal773**774**775** 'EqInt' returns 1 if the two integer arguments <intL> and <intR> are776** equal and 0 otherwise.777*/778779/* findme - For comparisons, do we first normalize and, if possible,780reduce? Or (for one small, one gmp int) make the small int into a7811-limb gmp to compare to the gmp. Or should we assume that gmp ints782cannot be 'small'? */783784Int EqInt ( Obj gmpL, Obj gmpR )785{786Obj opL;787Obj opR;788789/* compare two small integers */790if ( ARE_INTOBJS( gmpL, gmpR ) ) {791if ( INT_INTOBJ(gmpL) == INT_INTOBJ(gmpR) ) return 1L;792else return 0L;793}794795/* small ints fit into one limb of a GMP */796if IS_INTOBJ(gmpL) {797if ( ( INT_INTOBJ(gmpL) < 0 && IS_INTPOS(gmpR) ) ||798( 0 <= INT_INTOBJ(gmpL) && IS_INTNEG(gmpR) ) ||799( SIZE_INT(gmpR) > (TypGMPSize)1 ) ) return 0L;800opL = FuncGMP_INTOBJ( (Obj)0, gmpL );801}802else {803opL = gmpL;804}805806if IS_INTOBJ(gmpR) {807if ( ( INT_INTOBJ(gmpR) < 0 && IS_INTPOS(gmpL) ) ||808( 0 <= INT_INTOBJ(gmpR) && IS_INTNEG(gmpL) ) ||809( SIZE_INT(gmpL) > (TypGMPSize)1 ) ) return 0L;810opR = FuncGMP_INTOBJ( (Obj)0, gmpR );811}812else {813opR = gmpR;814}815816/* compare the sign and size */817if ( TNUM_OBJ(opL) != TNUM_OBJ(opR)818|| SIZE_INT(opL) != SIZE_INT(opR) )819return 0L;820821if ( mpn_cmp( ADDR_INT(opL), ADDR_INT(opR), SIZE_INT(opL) ) == 0 )822return 1L;823else824return 0L;825}826827/****************************************************************************828**829*F LtInt( <gmpL>, <gmpR> ) . . . . . . . . . . test whether <gmpL> < <gmpR>830**831*/832Int LtInt ( Obj gmpL, Obj gmpR )833{834Obj opL;835Obj opR;836837/* compare two small integers */838if ( ARE_INTOBJS( gmpL, gmpR ) ) {839if ( INT_INTOBJ(gmpL) < INT_INTOBJ(gmpR) ) return 1L;840else return 0L;841}842843/* compare a small and a large integer */844if ( IS_INTOBJ(gmpL) ) {845if ( SIZE_INT(gmpR) > (TypGMPSize)1 ) {846if ( IS_INTPOS(gmpR) ) return 1L;847else return 0L;848}849else opL = FuncGMP_INTOBJ( (Obj)0, gmpL );850}851else {852opL = gmpL;853}854855if ( IS_INTOBJ(gmpR) ) {856if ( SIZE_INT(gmpL) > (TypGMPSize)1 ) {857if ( IS_INTNEG(gmpL) ) return 1L;858else return 0L;859}860else opR = FuncGMP_INTOBJ( (Obj)0, gmpR );861}862else {863opR = gmpR;864}865866/* compare two large integers */867if ( IS_INTNEG(opL) && IS_INTPOS(opR) )868return 1L;869else if ( IS_INTPOS(opL) && IS_INTNEG(opR) )870return 0L;871else if ( ( IS_INTPOS(opR) && SIZE_INT(opL) < SIZE_INT(opR) ) ||872( IS_INTNEG(opR) && SIZE_INT(opL) > SIZE_INT(opR) ) )873return 1L;874else if ( ( IS_INTPOS(opL) && SIZE_INT(opL) > SIZE_INT(opR) ) ||875( IS_INTNEG(opL) && SIZE_INT(opL) < SIZE_INT(opR) ) )876return 0L;877else if ( IS_INTPOS(opL) ) {878if ( mpn_cmp( ADDR_INT(opL), ADDR_INT(opR), SIZE_INT(opL) ) < 0 )879return 1L;880else881return 0L;882}883else {884if ( mpn_cmp( ADDR_INT(opL), ADDR_INT(opR), SIZE_INT(opL) ) > 0 )885return 1L;886else887return 0L;888}889}890891892/****************************************************************************893**894*F SumInt( <gmpL>, <gmpR> ) . . . . . . . . . . . . sum of two GMP integers895**896*/897Obj SumInt ( Obj gmpL, Obj gmpR )898{899Obj sum;900901sum = SumOrDiffInt( gmpL, gmpR, +1 );902903return sum;904905}906907908/****************************************************************************909**910*F DiffInt( <gmpL>, <gmpR> ) . . . . . . . . difference of two GMP integers911**912*/913Obj DiffInt ( Obj gmpL, Obj gmpR )914{915Obj dif;916917dif = SumOrDiffInt( gmpL, gmpR, -1 );918919return dif;920}921922923/****************************************************************************924**925*F SumOrDiffInt( <gmpL>, <gmpR> ) . . . . . sum or diff of two Int integers926**927** 'SumOrDiffInt' returns the sum or difference of the two GMP int arguments928** <gmpL> and <gmpR>. 'SumOrDiffInt' handles operands of type 'T_INT',929** 'T_INTPOS' and 'T_INTNEG'.930**931** 'SumOrDiffInt' is a little bit tricky since there are many different932** cases to handle, each operand can be positive or negative, small or large933** integer.934*/935Obj SumOrDiffInt ( Obj gmpL, Obj gmpR, Int sign )936{937Obj res; /* handle of result bag */938Int twosmall; /* sum of two smalls */939Int onesmall; /* set to 1 if one of args is a small int, 0 otherwise */940Int swapped; /* set to 1 if args were swapped, 0 otherwise */941Int resneg; /* set to 1 if result will be negative */942TypLimb carry; /* hold any carry or borrow */943944twosmall = 0;945onesmall = 0;946swapped = 0;947resneg = 0;948949/* findme - later change to put the non-overflow versions of these small950int adds/subs into the caller funcs SumInt, DiffInt. Then remove check of951SUM or DIFF _INTOBJS and document (at least in code) that this should not952be called directly */953954if ( sign != 1 && sign != -1 ) {955ErrorReturnObj(956"SumOrDiffInt: <sign> must be +1 or -1. \nDo not call this function directly.",9570L, 0L,958"" );959}960961/* adding two small integers */962if ( ARE_INTOBJS( gmpL, gmpR ) ) {963964/* add or subtract two small integers with a small sum */965if (sign == 1) {966if ( SUM_INTOBJS( res, gmpL, gmpR ) ) {967return res;968}969else {970twosmall = INT_INTOBJ(gmpL) + INT_INTOBJ(gmpR);971}972}973else if (sign == -1) {974if ( DIFF_INTOBJS( res, gmpL, gmpR ) ) {975return res;976}977else {978twosmall = INT_INTOBJ(gmpL) - INT_INTOBJ(gmpR);979}980}981982/* if two small integers have a large sum or difference form the gmp int*/983if ( 0 < twosmall ) {984res = NewBag( T_INTPOS, sizeof(TypLimb) );985SET_VAL_LIMB0( res, (TypLimb)twosmall );986}987else {988res = NewBag( T_INTNEG, sizeof(TypLimb) );989SET_VAL_LIMB0( res, (TypLimb)(-twosmall) );990}991992return res;993}994995/* findme - we repeat some of this work in the 'add' part later on.996Can we recycle some code? */997998/* the case of one small integer and one large */999else if ( IS_INTOBJ( gmpL ) || IS_INTOBJ( gmpR ) ) {1000onesmall = 1;1001if ( IS_INTOBJ( gmpL ) ) {1002/* findme - do we need to normalize here? */1003gmpR = GMP_NORMALIZE( gmpR );1004gmpR = GMP_REDUCE( gmpR );1005if ( IS_INTOBJ(gmpR) ) {1006return INTOBJ_INT( INT_INTOBJ(gmpL) + sign*INT_INTOBJ(gmpR) );1007}1008res = gmpL; gmpL = gmpR; gmpR = res;1009swapped = 1;1010}1011else {1012gmpL = GMP_NORMALIZE( gmpL );1013gmpL = GMP_REDUCE( gmpL );1014if ( IS_INTOBJ(gmpL) ) {1015return INTOBJ_INT( INT_INTOBJ(gmpL) + sign*INT_INTOBJ(gmpR) );1016}1017}1018}10191020/* two large ints */1021else if ( SIZE_INT( gmpL ) < SIZE_INT( gmpR ) ) {1022/* swap gmpL and gmpR */1023res = gmpL; gmpL = gmpR; gmpR = res;1024swapped = 1;1025}10261027if ( ( ( sign == +1 ) &&1028( ( ( onesmall ) &&1029( (IS_INTNEG(gmpL) && 0 <= INT_INTOBJ(gmpR)) ||1030(IS_INTPOS(gmpL) && 0 > INT_INTOBJ(gmpR)) ) ) ||1031( !( onesmall ) &&1032( (IS_INTPOS(gmpL) && IS_INTNEG(gmpR)) ||1033(IS_INTNEG(gmpL) && IS_INTPOS(gmpR)) ) ) ) ) ||1034( ( sign == -1 ) &&1035( ( ( onesmall ) &&1036( (IS_INTNEG(gmpL) && 0 > INT_INTOBJ(gmpR)) ||1037(IS_INTPOS(gmpL) && 0 <= INT_INTOBJ(gmpR)) ) ) ||1038( !( onesmall ) &&1039( (IS_INTPOS(gmpL) && IS_INTPOS(gmpR)) ||1040(IS_INTNEG(gmpL) && IS_INTNEG(gmpR)) ) ) ) ) ) {10411042/* the args have different sign (or same sign and this is a subtraction)1043- compare to see which to subtract */1044if ( onesmall ) {1045if ( ( ( ( swapped == 1 && sign == +1 ) || swapped == 0 )1046&& IS_INTNEG(gmpL) ) ||1047( swapped == 1 && sign == -1 && IS_INTPOS(gmpL) ) ) {1048res = NewBag( T_INTNEG, SIZE_OBJ(gmpL) );1049}1050else {1051res = NewBag( T_INTPOS, SIZE_OBJ(gmpL) );1052}1053gmpR = FuncGMP_INTOBJ( (Obj)0, gmpR );1054carry = mpn_sub_1( ADDR_INT(res),1055ADDR_INT(gmpL), SIZE_INT(gmpL),1056*ADDR_INT(gmpR) );1057}1058/* this test correct since size(gmpL) >= size(gmpR) */1059else if ( SIZE_INT(gmpL) != SIZE_INT(gmpR) ) {1060if ( ( ( ( swapped == 1 && sign == +1 ) || swapped == 0 )1061&& IS_INTNEG(gmpL) ) ||1062( swapped == 1 && sign == -1 && IS_INTPOS(gmpL) ) ) {1063res = NewBag( T_INTNEG, SIZE_OBJ(gmpL) );1064}1065else {1066res = NewBag( T_INTPOS, SIZE_OBJ(gmpL) );1067}1068carry = mpn_sub( ADDR_INT(res),1069ADDR_INT(gmpL), SIZE_INT(gmpL),1070ADDR_INT(gmpR), SIZE_INT(gmpR) );1071}1072/* ok, so they're the same size in limbs - which is the bigger number? */1073else if ( mpn_cmp( ADDR_INT(gmpL),1074ADDR_INT(gmpR), SIZE_INT(gmpL) ) < 0 ) {1075if ( IS_INTPOS(gmpL) ) {1076res = NewBag( T_INTNEG, SIZE_OBJ(gmpL) );1077}1078else {1079res = NewBag( T_INTPOS, SIZE_OBJ(gmpL) );1080}1081carry = mpn_sub_n( ADDR_INT(res),1082ADDR_INT(gmpR),1083ADDR_INT(gmpL), SIZE_INT(gmpR) );1084}10851086else {1087if ( IS_INTNEG(gmpL) ) {1088res = NewBag( T_INTNEG, SIZE_OBJ(gmpL) );1089}1090else {1091res = NewBag( T_INTPOS, SIZE_OBJ(gmpL) );1092}1093carry = mpn_sub_n( ADDR_INT(res),1094ADDR_INT(gmpL),1095ADDR_INT(gmpR), SIZE_INT(gmpL) );1096}10971098res = GMP_NORMALIZE( res );1099res = GMP_REDUCE( res );1100return res;1101}11021103else {1104/* The args have the same sign (or opp sign and this is a subtraction)1105- so add them. At this stage, we are dealing with a large and a1106small, or two large integers */11071108/* Will the result be negative? */1109if ( ( sign == 1 && IS_INTNEG(gmpL) ) ||1110( sign == -1 &&1111( ( swapped == 0 && IS_INTNEG(gmpL) ) ||1112( swapped == 1 && IS_INTPOS(gmpL) ) ) ) ) {1113resneg = 1;1114}1115/* ( ( onesmall && IS_INTNEG(gmpL) ) ||1116( IS_INTNEG(gmpL) && IS_INTNEG(gmpR) ) ||1117( SIZE_INT(gmpL) > SIZE_INT(gmpR) && IS_INTNEG(gmpL) ) ) ) ||1118if ( resneg == 0 && sign == 1 && SIZE_INT(gmpL) == SIZE_INT(gmpR) ) {1119compare = mpn_cmp( ADDR_INT(gmpL), ADDR_INT(gmpR), SIZE_INT(gmpL) );1120if ( ( compare >= 0 && IS_INTNEG(gmpL) ) ||1121( compare < 0 && IS_INTNEG(gmpR) ) ) {1122resneg = 1;1123}1124}1125*/1126if ( onesmall ) {1127if ( resneg == 0 ) {1128res = NewBag( T_INTPOS, SIZE_OBJ(gmpL) + sizeof(TypLimb) );1129}1130else {1131res = NewBag( T_INTNEG, SIZE_OBJ(gmpL) + sizeof(TypLimb) );1132}1133gmpR = FuncGMP_INTOBJ( (Obj)0, gmpR );1134carry = mpn_add_1( ADDR_INT(res),1135ADDR_INT(gmpL),SIZE_INT(gmpL),1136*ADDR_INT(gmpR) );1137if ( carry == (TypLimb)0 ) {1138ResizeBag( res, SIZE_OBJ(gmpL) );1139}1140else {1141( ADDR_INT(res) )[ SIZE_INT(gmpL) ] = (TypLimb)1; /* = carry ? */1142}1143/* findme - debugging 2311071144res = GMP_NORMALIZE( res );1145res = GMP_REDUCE( res ); */1146}11471148else {1149/* put the smaller one (in limbs) to the right */1150if ( SIZE_INT(gmpL) < SIZE_INT(gmpR) ) {1151res = gmpR; gmpR = gmpL; gmpL = res;1152}11531154/* allocate result bag */1155if ( resneg == 0 ) {1156res = NewBag( T_INTPOS, ( SIZE_OBJ(gmpL) + sizeof(TypLimb) ) );1157}1158else {1159res = NewBag( T_INTNEG, ( SIZE_OBJ(gmpL) + sizeof(TypLimb) ) );1160}11611162/* mpn_lshift is faster still than mpn_add_n for adding a TypLimb1163number to itself */1164if ( gmpL == gmpR ) {1165carry = mpn_lshift( ADDR_INT(res),1166ADDR_INT(gmpL), SIZE_INT(gmpL),11671 );1168}1169else {1170carry = mpn_add( ADDR_INT(res),1171ADDR_INT(gmpL), SIZE_INT(gmpL),1172ADDR_INT(gmpR), SIZE_INT(gmpR) );1173}1174if ( carry == (TypLimb)0 ){1175ResizeBag( res, SIZE_OBJ(gmpL) );1176}1177else{1178( ADDR_INT(res) )[ SIZE_INT(gmpL) ] = (TypLimb)1;1179}1180/* findme - don't need this after carry ? */1181/* res = GMP_NORMALIZE( res );1182res = GMP_REDUCE( res ); */1183}11841185return res;1186}11871188}118911901191/****************************************************************************1192**1193*F ZeroInt(<gmp>) . . . . . . . . . . . . . . . . . . . . zero of integers1194*/1195Obj ZeroInt ( Obj op )1196{1197return INTOBJ_INT( (Int)0 );1198}119912001201/****************************************************************************1202**1203*F AInvInt(<gmp>) . . . . . . . . . . . . . . additive inverse of an integer1204*/1205Obj AInvInt ( Obj gmp )1206{1207Obj inv;12081209/* handle small integer */1210if ( IS_INTOBJ( gmp ) ) {12111212/* special case (ugh) */1213if ( gmp == INTOBJ_INT( -(1L<<NR_SMALL_INT_BITS) ) ) {1214inv = NewBag( T_INTPOS, sizeof(TypLimb) );1215SET_VAL_LIMB0( inv, 1L<<NR_SMALL_INT_BITS );1216}12171218/* general case */1219else {1220inv = INTOBJ_INT( - INT_INTOBJ( gmp ) );1221}12221223}12241225else {1226if ( IS_INTPOS(gmp) ) {1227/* special case */1228if ( ( SIZE_INT(gmp) == 1 )1229&& ( VAL_LIMB0(gmp) == (TypLimb) (1L<<NR_SMALL_INT_BITS) ) ) {1230return INTOBJ_INT( -(Int) (1L<<NR_SMALL_INT_BITS) );1231}1232else {1233inv = NewBag( T_INTNEG, SIZE_OBJ(gmp) );1234}1235}12361237else {1238inv = NewBag( T_INTPOS, SIZE_OBJ(gmp) );1239}12401241memcpy( ADDR_INT(inv), ADDR_INT(gmp), SIZE_OBJ(gmp) );1242}12431244/* return the inverse */1245return inv;12461247}12481249Obj AbsInt( Obj gmp )1250{1251Obj a;1252if (IS_INTOBJ(gmp)) {1253if (((Int)gmp) > 0)1254return gmp;1255else if (gmp == INTOBJ_INT(-(1L << NR_SMALL_INT_BITS)))1256return AInvInt(gmp);1257else1258return (Obj)(2-(Int)gmp);1259}1260if (TNUM_OBJ(gmp) == T_INTPOS)1261return gmp;1262a = NewBag(T_INTPOS, SIZE_OBJ(gmp));1263memcpy( ADDR_INT(a), ADDR_INT(gmp), SIZE_OBJ(gmp) );1264return a;1265}12661267Obj FuncABS_INT(Obj self, Obj gmp)1268{1269return AbsInt(gmp);1270}127112721273/****************************************************************************1274**1275*F ProdInt( <intL>, <intR> ) . . . . . . . . . . . . product of two integers1276**1277** 'ProdInt' returns the product of the two integer arguments <intL> and1278** <intR>. 'ProdInt' handles operands of type 'T_INT', 'T_INTPOS' and1279** 'T_INTNEG'.1280**1281** It can also be used in the cases that both operands are small integers1282** and the result is a small integer too, i.e., that no overflow occurs.1283** This case is usually already handled in 'EvalProd' for a better efficiency.1284**1285** Is called from the 'EvalProd' binop so both operands are already evaluated.1286**1287** The only difficulty about this function is the fact that is has to handle1288** 3 different situations, depending on how many arguments are small ints.1289*/1290Obj ProdInt ( Obj gmpL, Obj gmpR )1291{1292Obj prd; /* handle of the result bag */1293Int i; /* hold small int value */1294Int k; /* hold small int value */1295TypLimb carry; /* most significant limb */1296TypLimb tmp1, tmp2;12971298/* multiplying two small integers */1299if ( ARE_INTOBJS( gmpL, gmpR ) ) {13001301/* multiply two small integers with a small product */1302/* multiply and divide back to check that no overflow occured */1303if ( PROD_INTOBJS( prd, gmpL, gmpR ) ) {1304return prd;1305}13061307/* get the integer values */1308i = INT_INTOBJ(gmpL);1309k = INT_INTOBJ(gmpR);13101311/* allocate the product bag */1312if ( (0 < i && 0 < k) || (i < 0 && k < 0) )1313prd = NewBag( T_INTPOS, 2*sizeof(TypLimb) );1314else1315prd = NewBag( T_INTNEG, 2*sizeof(TypLimb) );13161317/* make both operands positive */1318if ( i < 0 ) i = -i;1319if ( k < 0 ) k = -k;13201321/* multiply */1322tmp1 = (TypLimb)i;1323tmp2 = (TypLimb)k;1324mpn_mul_n( ADDR_INT( prd ), &tmp1, &tmp2, 1 );1325}13261327/* multiply a small and a large integer */1328else if ( IS_INTOBJ(gmpL) || IS_INTOBJ(gmpR) ) {13291330/* make the right operand the small one */1331if ( IS_INTOBJ(gmpL) ) {1332k = INT_INTOBJ(gmpL); gmpL = gmpR;1333}1334else {1335k = INT_INTOBJ(gmpR);1336}13371338/* handle trivial cases first */1339if ( k == 0 )1340return INTOBJ_INT(0);1341if ( k == 1 )1342return gmpL;13431344/* eg: for 32 bit systems, the large integer 1<<28 times -1 is the small1345integer -(1<<28) */1346if ( ( k == -1 ) && (SIZE_INT(gmpL)==1)1347&& ( VAL_LIMB0(gmpL) == (TypLimb)(1L<<NR_SMALL_INT_BITS) ) )1348return INTOBJ_INT(-(Int)(1L<<NR_SMALL_INT_BITS));13491350/* multiplication by -1 is easy, just switch the sign and copy */1351if ( k == -1 ) {1352if ( TNUM_OBJ(gmpL) == T_INTPOS ) {1353prd = NewBag( T_INTNEG, SIZE_OBJ(gmpL) );1354}1355else {1356prd = NewBag( T_INTPOS, SIZE_OBJ(gmpL) );1357}1358memcpy( ADDR_OBJ(prd), ADDR_OBJ(gmpL), SIZE_OBJ(gmpL) );1359return prd;1360}13611362/* allocate a bag for the result */1363if ( (0 < k && TNUM_OBJ(gmpL) == T_INTPOS)1364|| (k < 0 && TNUM_OBJ(gmpL) == T_INTNEG) ) {1365prd = NewBag( T_INTPOS, (SIZE_INT(gmpL)+1)*sizeof(TypLimb) );1366}1367else {1368prd = NewBag( T_INTNEG, (SIZE_INT(gmpL)+1)*sizeof(TypLimb) );1369}13701371if ( k < 0 ) k = -k;13721373/* multiply */1374carry = mpn_mul_1( ADDR_INT(prd), ADDR_INT(gmpL),1375SIZE_INT(gmpL), (TypLimb)k );1376if ( carry == (TypLimb)0 ) {1377ResizeBag( prd, SIZE_OBJ(gmpL) );1378}1379else {1380( ADDR_INT(prd) )[ SIZE_INT(gmpL) ] = carry;1381}1382}13831384/* multiply two large integers */1385else {13861387/* make the right operand the smaller one, for the mpn function */1388if ( SIZE_INT(gmpL) < SIZE_INT(gmpR) ) {1389prd = gmpR; gmpR = gmpL; gmpL = prd;1390}13911392/* allocate a bag for the result */1393if ( TNUM_OBJ(gmpL) == TNUM_OBJ(gmpR) )1394prd = NewBag( T_INTPOS, SIZE_OBJ(gmpL)+SIZE_OBJ(gmpR) );1395else1396prd = NewBag( T_INTNEG, SIZE_OBJ(gmpL)+SIZE_OBJ(gmpR) );13971398/* multiply */1399mpn_mul( ADDR_INT(prd),1400ADDR_INT(gmpL), SIZE_INT(gmpL),1401ADDR_INT(gmpR), SIZE_INT(gmpR) );1402}14031404/* normalize and return the product */1405prd = GMP_NORMALIZE( prd );1406prd = GMP_REDUCE( prd );1407return prd;1408}140914101411/****************************************************************************1412**1413*F ProdIntObj(<n>,<op>) . . . . . . . . product of an integer and an object1414*/1415Obj ProdIntObj ( Obj n, Obj op )1416{1417Obj res = 0; /* result */1418UInt i, k; /* loop variables */1419TypLimb l; /* loop variable */14201421/* if the integer is zero, return the neutral element of the operand */1422if ( TNUM_OBJ(n) == T_INT && INT_INTOBJ(n) == 0 ) {1423res = ZERO( op );1424}14251426/* if the integer is one, return the object if immutable -1427if mutable, add the object to its ZeroSameMutability to1428ensure correct mutability propagation */1429else if ( TNUM_OBJ(n) == T_INT && INT_INTOBJ(n) == 1 ) {1430if (IS_MUTABLE_OBJ(op))1431res = SUM(ZERO(op),op);1432else1433res = op;1434}14351436/* if the integer is minus one, return the inverse of the operand */1437else if ( TNUM_OBJ(n) == T_INT && INT_INTOBJ(n) == -1 ) {1438res = AINV( op );1439}14401441/* if the integer is negative, invert the operand and the integer */1442else if ( ( TNUM_OBJ(n) == T_INT && INT_INTOBJ(n) < -1 )1443|| IS_INTNEG(n) ) {1444res = AINV( op );1445if ( res == Fail ) {1446return ErrorReturnObj(1447"Operations: <obj> must have an additive inverse",14480L, 0L,1449"you can supply an inverse <inv> for <obj> via 'return <inv>;'" );1450}1451res = PROD( AINV( n ), res );1452}14531454/* if the integer is small, compute the product by repeated doubling */1455/* the loop invariant is <result> = <k>*<res> + <l>*<op>, <l> < <k> */1456/* <res> = 0 means that <res> is the neutral element */1457else if ( TNUM_OBJ(n) == T_INT && INT_INTOBJ(n) > 1 ) {1458res = 0;1459k = 1L << (NR_SMALL_INT_BITS+1);1460l = INT_INTOBJ(n);1461while ( 1 < k ) {1462res = (res == 0 ? res : SUM( res, res ));1463k = k / 2;1464if ( k <= l ) {1465res = (res == 0 ? op : SUM( res, op ));1466l = l - k;1467}1468}1469}14701471/* if the integer is large, compute the product by repeated doubling */1472else if ( TNUM_OBJ(n) == T_INTPOS ) {1473res = 0;1474for ( i = SIZE_INT(n); 0 < i; i-- ) {1475k = 8*sizeof(TypLimb);1476l = ((TypLimb*) ADDR_INT(n))[i-1];1477while ( 0 < k ) {1478res = (res == 0 ? res : SUM( res, res ));1479k--;1480if ( (l >> k) & 1 ) {1481res = (res == 0 ? op : SUM( res, op ));1482}1483}1484}1485}14861487/* return the result */1488return res;1489}14901491Obj ProdIntObjFunc;14921493Obj FuncPROD_INT_OBJ ( Obj self, Obj opL, Obj opR )1494{1495return ProdIntObj( opL, opR );1496}149714981499/****************************************************************************1500**1501*F OneInt(<gmp>) . . . . . . . . . . . . . . . . . . . . . one of an integer1502*/1503static Obj OneAttr;15041505Obj OneInt ( Obj op )1506{1507return INTOBJ_INT( 1 );1508}150915101511/****************************************************************************1512**1513*F PowInt( <intL>, <intR> ) . . . . . . . . . . . . . . power of an integer1514**1515** 'PowInt' returns the <intR>-th (an integer) power of the integer <intL>.1516** 'PowInt' handles operands of type 'T_INT', 'T_INTPOS' and 'T_INTNEG'.1517**1518** It can also be used in the cases that both operands are small integers1519** and the result is a small integer too, i.e., that no overflow occurs.1520** This case is usually already handled in 'EvalPow' for a better efficiency.1521**1522** Is called from the 'EvalPow' binop so both operands are already evaluated.1523*/1524Obj PowInt ( Obj gmpL, Obj gmpR )1525{1526Int i;1527Obj pow;15281529/* power with a large exponent */1530if ( ! IS_INTOBJ(gmpR) ) {1531if ( gmpL == INTOBJ_INT(0) )1532pow = INTOBJ_INT(0);1533else if ( gmpL == INTOBJ_INT(1) )1534pow = INTOBJ_INT(1);1535else if ( gmpL == INTOBJ_INT(-1) && ADDR_INT(gmpR)[0] % 2 == 0 )1536pow = INTOBJ_INT(1);1537else if ( gmpL == INTOBJ_INT(-1) && ADDR_INT(gmpR)[0] % 2 != 0 )1538pow = INTOBJ_INT(-1);1539else {1540gmpR = ErrorReturnObj(1541"Integer operands: <exponent> is too large",15420L, 0L,1543"you can replace the integer <exponent> via 'return <exponent>;'" );1544return POW( gmpL, gmpR );1545}1546}15471548/* power with a negative exponent */1549else if ( INT_INTOBJ(gmpR) < 0 ) {1550if ( gmpL == INTOBJ_INT(0) ) {1551gmpL = ErrorReturnObj(1552"Integer operands: <base> must not be zero",15530L, 0L,1554"you can replace the integer <base> via 'return <base>;'" );1555return POW( gmpL, gmpR );1556}1557else if ( gmpL == INTOBJ_INT(1) )1558pow = INTOBJ_INT(1);1559else if ( gmpL == INTOBJ_INT(-1) && INT_INTOBJ(gmpR) % 2 == 0 )1560pow = INTOBJ_INT(1);1561else if ( gmpL == INTOBJ_INT(-1) && INT_INTOBJ(gmpR) % 2 != 0 )1562pow = INTOBJ_INT(-1);1563else1564pow = QUO( INTOBJ_INT(1),1565PowInt( gmpL, INTOBJ_INT( -INT_INTOBJ(gmpR)) ) );1566}15671568/* findme - can we use the gmp function mpz_n_pow_ui? */15691570/* power with a small positive exponent, do it by a repeated squaring */1571else {1572pow = INTOBJ_INT(1);1573i = INT_INTOBJ(gmpR);1574while ( i != 0 ) {1575if ( i % 2 == 1 ) pow = ProdInt( pow, gmpL );1576if ( i > 1 ) gmpL = ProdInt( gmpL, gmpL );1577TakeInterrupt();1578i = i / 2;1579}1580}15811582/* return the power */1583return pow;1584}158515861587/****************************************************************************1588**1589*F PowObjInt(<op>,<n>) . . . . . . . . . . power of an object and an integer1590*/1591Obj PowObjInt ( Obj op, Obj n )1592{1593Obj res = 0; /* result */1594UInt i, k; /* loop variables */1595TypLimb l; /* loop variable */15961597/* if the integer is zero, return the neutral element of the operand */1598if ( TNUM_OBJ(n) == T_INT && INT_INTOBJ(n) == 0 ) {1599return ONE_MUT( op );1600}16011602/* if the integer is one, return a copy of the operand */1603else if ( TNUM_OBJ(n) == T_INT && INT_INTOBJ(n) == 1 ) {1604res = CopyObj( op, 1 );1605}16061607/* if the integer is minus one, return the inverse of the operand */1608else if ( TNUM_OBJ(n) == T_INT && INT_INTOBJ(n) == -1 ) {1609res = INV_MUT( op );1610}16111612/* if the integer is negative, invert the operand and the integer */1613else if ( TNUM_OBJ(n) == T_INT && INT_INTOBJ(n) < 0 ) {1614res = INV_MUT( op );1615if ( res == Fail ) {1616return ErrorReturnObj(1617"Operations: <obj> must have an inverse",16180L, 0L,1619"you can supply an inverse <inv> for <obj> via 'return <inv>;'" );1620}1621res = POW( res, AINV( n ) );1622}16231624/* if the integer is negative, invert the operand and the integer */1625else if ( TNUM_OBJ(n) == T_INTNEG ) {1626res = INV_MUT( op );1627if ( res == Fail ) {1628return ErrorReturnObj(1629"Operations: <obj> must have an inverse",16300L, 0L,1631"you can supply an inverse <inv> for <obj> via 'return <inv>;'" );1632}1633res = POW( res, AINV( n ) );1634}16351636/* if the integer is small, compute the power by repeated squaring */1637/* the loop invariant is <result> = <res>^<k> * <op>^<l>, <l> < <k> */1638/* <res> = 0 means that <res> is the neutral element */1639else if ( TNUM_OBJ(n) == T_INT && INT_INTOBJ(n) > 0 ) {1640res = 0;1641k = 1L << (NR_SMALL_INT_BITS+1);1642l = INT_INTOBJ(n);1643while ( 1 < k ) {1644res = (res == 0 ? res : PROD( res, res ));1645k = k / 2;1646if ( k <= l ) {1647res = (res == 0 ? op : PROD( res, op ));1648l = l - k;1649}1650}1651}16521653/* if the integer is large, compute the power by repeated squaring */1654else if ( TNUM_OBJ(n) == T_INTPOS ) {1655res = 0;1656for ( i = SIZE_INT(n); 0 < i; i-- ) {1657k = 8*sizeof(TypLimb);1658l = ((TypLimb*) ADDR_INT(n))[i-1];1659while ( 0 < k ) {1660res = (res == 0 ? res : PROD( res, res ));1661k--;1662if ( (l>>k) & 1 ) {1663res = (res == 0 ? op : PROD( res, op ));1664}1665}1666}1667}16681669/* return the result */1670return res;1671}16721673Obj PowObjIntFunc;16741675Obj FuncPOW_OBJ_INT ( Obj self, Obj opL, Obj opR )1676{1677return PowObjInt( opL, opR );1678}167916801681/****************************************************************************1682**1683*F ModInt( <intL>, <intR> ) . representative of residue class of an integer1684**1685** 'ModInt' returns the smallest positive representant of the residue class1686** of the integer <intL> modulo the integer <intR>. 'ModInt' handles1687** operands of type 'T_INT', 'T_INTPOS', 'T_INTNEG'.1688**1689** It can also be used in the cases that both operands are small integers1690** and the result is a small integer too, i.e., that no overflow occurs.1691** This case is usually already handled in 'EvalMod' for a better efficiency.1692p**1693** Is called from the 'EvalMod' binop so both operands are already evaluated.1694*/1695Obj ModInt ( Obj opL, Obj opR )1696{1697Int i; /* loop count, value for small int */1698Int k; /* loop count, value for small int */1699UInt c; /* product of two digits */1700Obj mod; /* handle of the remainder bag */1701Obj quo; /* handle of the quotient bag */17021703/* compute the remainder of two small integers */1704if ( ARE_INTOBJS( opL, opR ) ) {17051706/* pathological case first */1707if ( opR == INTOBJ_INT(0) ) {1708opR = ErrorReturnObj(1709"Integer operations: <divisor> must be nonzero",17100L, 0L,1711"you can replace the integer <divisor> via 'return <divisor>;'" );1712return MOD( opL, opR );1713}17141715/* get the integer values */1716i = INT_INTOBJ(opL);1717k = INT_INTOBJ(opR);17181719/* compute the remainder, make sure we divide only positive numbers */1720if ( 0 <= i && 0 <= k ) i = ( i % k );1721else if ( 0 <= i && k < 0 ) i = ( i % -k );1722else if ( i < 0 && 0 <= k ) i = ( k - ( -i % k )) % k;1723else if ( i < 0 && k < 0 ) i = (-k - ( -i % -k )) % k;1724mod = INTOBJ_INT( i );17251726}17271728/* compute the remainder of a small integer by a large integer */1729else if ( IS_INTOBJ(opL) ) {17301731/* the small int -(1<<28) mod the large int (1<<28) is 0 */1732if ( opL == INTOBJ_INT(-(Int)(1L<<NR_SMALL_INT_BITS) )1733&& ( TNUM_OBJ(opR) == T_INTPOS )1734&& ( SIZE_INT(opR) == 1 )1735&& ( VAL_LIMB0(opR) == (TypLimb)(1L<<NR_SMALL_INT_BITS) ) )1736mod = INTOBJ_INT(0);17371738/* in all other cases the remainder is equal the left operand */1739else if ( 0 <= INT_INTOBJ(opL) )1740mod = opL;1741else if ( TNUM_OBJ(opR) == T_INTPOS )1742mod = SumOrDiffInt( opL, opR, 1 );1743else1744mod = SumOrDiffInt( opL, opR, -1 );1745}17461747/* compute the remainder of a large integer by a small integer */1748else if ( IS_INTOBJ(opR) ) {17491750/* pathological case first */1751if ( opR == INTOBJ_INT(0) ) {1752opR = ErrorReturnObj(1753"Integer operations: <divisor> must be nonzero",17540L, 0L,1755"you can replace the integer <divisor> via 'return <divisor>;'" );1756return MOD( opL, opR );1757}17581759/* get the integer value, make positive */1760i = INT_INTOBJ(opR); if ( i < 0 ) i = -i;17611762/* maybe it's trivial */1763if ( INTBASE % i == 0 ) {1764c = ADDR_INT(opL)[0] % i;1765}17661767/* otherwise use the gmp function to divide */1768else {1769c = mpn_mod_1( ADDR_INT(opL), SIZE_INT(opL), (TypLimb)i );1770}17711772/* now c is the result, it has the same sign as the left operand */1773if ( TNUM_OBJ(opL) == T_INTPOS )1774mod = INTOBJ_INT( c );1775else if ( c == 0 )1776mod = INTOBJ_INT( c );1777else if ( 0 <= INT_INTOBJ(opR) )1778mod = SumOrDiffInt( INTOBJ_INT( -(Int)c ), opR, 1 );1779else1780mod = SumOrDiffInt( INTOBJ_INT( -(Int)c ), opR, -1 );17811782}17831784/* compute the remainder of a large integer modulo a large integer */1785else {17861787/* trivial case first */1788if ( SIZE_INT(opL) < SIZE_INT(opR) ) {1789if ( TNUM_OBJ(opL) == T_INTPOS )1790return opL;1791else if ( TNUM_OBJ(opR) == T_INTPOS )1792mod = SumOrDiffInt( opL, opR, 1 );1793else1794mod = SumOrDiffInt( opL, opR, -1 );1795if IS_INTNEG(mod) return NEW_INTPOS(mod);1796else return mod;1797}17981799mod = NewBag( TNUM_OBJ(opL), (SIZE_INT(opL)+1)*sizeof(TypLimb) );18001801quo = NewBag( T_INTPOS,1802(SIZE_INT(opL)-SIZE_INT(opR)+1)*sizeof(TypLimb) );18031804/* and let gmp do the work */1805mpn_tdiv_qr( ADDR_INT(quo), ADDR_INT(mod), 0,1806ADDR_INT(opL), SIZE_INT(opL),1807ADDR_INT(opR), SIZE_INT(opR) );18081809/* reduce to small integer if possible, otherwise shrink bag */1810mod = GMP_NORMALIZE( mod );1811mod = GMP_REDUCE( mod );18121813/* make the representative positive */1814if ( (TNUM_OBJ(mod) == T_INT && INT_INTOBJ(mod) < 0)1815|| TNUM_OBJ(mod) == T_INTNEG ) {1816if ( TNUM_OBJ(opR) == T_INTPOS )1817mod = SumOrDiffInt( mod, opR, 1 );1818else1819mod = SumOrDiffInt( mod, opR, -1 );1820}18211822}18231824/* return the result */1825if IS_INTNEG(mod)1826return NEW_INTPOS(mod);1827else if ( IS_INTOBJ(mod) && 0 > INT_INTOBJ(mod) )1828return INTOBJ_INT(-INT_INTOBJ(mod));1829else1830return mod;1831}183218331834/****************************************************************************1835**1836*F QuoInt( <intL>, <intR> ) . . . . . . . . . . . quotient of two integers1837**1838** 'QuoInt' returns the integer part of the two integers <intL> and <intR>.1839** 'QuoInt' handles operands of type 'T_INT', 'T_INTPOS' and 'T_INTNEG'.1840**1841** It can also be used in the cases that both operands are small integers1842** and the result is a small integer too, i.e., that no overflow occurs.1843**1844** Note that this routine is not called from 'EvalQuo', the division of two1845** integers yields a rational and is therefor performed in 'QuoRat'.1846** This operation is however available through the internal function 'Quo'.1847*/1848Obj QuoInt ( Obj opL, Obj opR )1849{1850Int i; /* loop count, value for small int */1851Int k; /* loop count, value for small int */1852Obj quo; /* handle of the result bag */1853Obj rem; /* handle of the remainder bag */18541855/* divide two small integers */1856if ( ARE_INTOBJS( opL, opR ) ) {18571858/* pathological case first */1859if ( opR == INTOBJ_INT(0) ) {1860opR = ErrorReturnObj(1861"Integer operations: <divisor> must be nonzero",18620L, 0L,1863"you can replace the integer <divisor> via 'return <divisor>;'" );1864return QUO( opL, opR );1865}18661867/* the small int -(1<<28) divided by -1 is the large int (1<<28) */1868if ( opL == INTOBJ_INT(-(Int)(1L<<NR_SMALL_INT_BITS))1869&& opR == INTOBJ_INT(-1) ) {1870quo = NewBag( T_INTPOS, sizeof(TypLimb) );1871SET_VAL_LIMB0( quo, 1L<<NR_SMALL_INT_BITS );1872return quo;1873}18741875/* get the integer values */1876i = INT_INTOBJ(opL);1877k = INT_INTOBJ(opR);18781879/* divide, make sure we divide only positive numbers */1880if ( 0 <= i && 0 <= k ) i = ( i / k );1881else if ( 0 <= i && k < 0 ) i = - ( i / -k );1882else if ( i < 0 && 0 <= k ) i = - ( -i / k );1883else if ( i < 0 && k < 0 ) i = ( -i / -k );1884quo = INTOBJ_INT( i );18851886}18871888/* divide a small integer by a large one */1889else if ( IS_INTOBJ(opL) ) {18901891/* the small int -(1<<28) divided by the large int (1<<28) is -1 */18921893if ( opL == INTOBJ_INT(-(Int)(1L<<NR_SMALL_INT_BITS))1894&& TNUM_OBJ(opR) == T_INTPOS && SIZE_INT(opR) == 11895&& VAL_LIMB0(opR) == 1L<<NR_SMALL_INT_BITS )1896quo = INTOBJ_INT(-1);18971898/* in all other cases the quotient is of course zero */1899else1900quo = INTOBJ_INT(0);19011902}19031904/* divide a large integer by a small integer */1905else if ( IS_INTOBJ(opR) ) {19061907/* pathological case first */1908if ( opR == INTOBJ_INT(0) ) {1909opR = ErrorReturnObj(1910"Integer operations: <divisor> must be nonzero",19110L, 0L,1912"you can replace the integer <divisor> via 'return <divisor>;'" );1913return QUO( opL, opR );1914}19151916/* allocate a bag for the result and set up the pointers */1917if ( (TNUM_OBJ(opL)==T_INTPOS && 0 < INT_INTOBJ(opR))1918|| (TNUM_OBJ(opL)==T_INTNEG && INT_INTOBJ(opR) < 0) )1919quo = NewBag( T_INTPOS, SIZE_OBJ(opL) );1920else1921quo = NewBag( T_INTNEG, SIZE_OBJ(opL) );19221923opR = FuncGMP_INTOBJ( (Obj)0, opR );19241925/* use gmp function for dividing by a 1-limb number */1926mpn_divrem_1( ADDR_INT(quo), 0,1927ADDR_INT(opL), SIZE_INT(opL),1928*ADDR_INT(opR) );1929}19301931/* divide a large integer by a large integer */1932else {19331934/* trivial case first */1935if ( SIZE_INT(opL) < SIZE_INT(opR) )1936return INTOBJ_INT(0);19371938/* create a new bag for the remainder */1939rem = NewBag( TNUM_OBJ(opL), (SIZE_INT(opL)+1)*sizeof(TypLimb) );19401941/* allocate a bag for the quotient */1942if ( TNUM_OBJ(opL) == TNUM_OBJ(opR) )1943quo = NewBag( T_INTPOS,1944(SIZE_INT(opL)-SIZE_INT(opR)+1)*sizeof(TypLimb) );1945else1946quo = NewBag( T_INTNEG,1947(SIZE_INT(opL)-SIZE_INT(opR)+1)*sizeof(TypLimb) );19481949mpn_tdiv_qr( ADDR_INT(quo), ADDR_INT(rem), 0,1950ADDR_INT(opL), SIZE_INT(opL),1951ADDR_INT(opR), SIZE_INT(opR) );1952}19531954/* normalize and return the result */1955quo = GMP_NORMALIZE(quo);1956quo = GMP_REDUCE( quo );1957return quo;1958}195919601961/****************************************************************************1962**1963*F FuncQUO_INT(<self>,<opL>,<opR>) . . . . . . . internal function 'QuoInt'1964**1965** 'FuncQUO_INT' implements the internal function 'QuoInt'.1966**1967** 'QuoInt( <i>, <k> )'1968**1969** 'Quo' returns the integer part of the quotient of its integer operands.1970** If <i> and <k> are positive 'Quo( <i>, <k> )' is the largest positive1971** integer <q> such that '<q> * <k> \<= <i>'. If <i> or <k> or both are1972** negative we define 'Abs( Quo(<i>,<k>) ) = Quo( Abs(<i>), Abs(<k>) )' and1973** 'Sign( Quo(<i>,<k>) ) = Sign(<i>) * Sign(<k>)'. Dividing by 0 causes an1974** error. 'Rem' (see "Rem") can be used to compute the remainder.1975*/1976Obj FuncQUO_INT ( Obj self, Obj opL, Obj opR )1977{1978/* check the arguments */1979while ( TNUM_OBJ(opL) != T_INT1980&& TNUM_OBJ(opL) != T_INTPOS1981&& TNUM_OBJ(opL) != T_INTNEG ) {1982opL = ErrorReturnObj(1983"QuoInt: <left> must be a int (not a %s)",1984(Int)TNAM_OBJ(opL), 0L,1985"you can replace <left> via 'return <left>;'" );1986}1987while ( TNUM_OBJ(opR) != T_INT1988&& TNUM_OBJ(opR) != T_INTPOS1989&& TNUM_OBJ(opR) != T_INTNEG ) {1990opR = ErrorReturnObj(1991"QuoInt: <right> must be a int (not a %s)",1992(Int)TNAM_OBJ(opR), 0L,1993"you can replace <right> via 'return <right>;'" );1994}19951996/* return the quotient */1997return QuoInt( opL, opR );1998}199920002001/****************************************************************************2002**2003*F RemInt( <intL>, <intR> ) . . . . . . . . . . . remainder of two integers2004**2005** 'RemInt' returns the remainder of the quotient of the integers <intL>2006** and <intR>. 'RemInt' handles operands of type 'T_INT', 'T_INTPOS' and2007** 'T_INTNEG'.2008**2009** Note that the remainder is different from the value returned by the 'mod'2010** operator which is always positive.2011*/2012Obj RemInt ( Obj opL, Obj opR )2013{2014Int i; /* loop count, value for small int */2015Int k; /* loop count, value for small int */2016UInt c; /* product of two digits */2017Obj rem; /* handle of the remainder bag */2018Obj quo; /* handle of the quotient bag */20192020/* compute the remainder of two small integers */2021if ( ARE_INTOBJS( opL, opR ) ) {20222023/* pathological case first */2024if ( opR == INTOBJ_INT(0) ) {2025opR = ErrorReturnObj(2026"Integer operations: <divisor> must be nonzero",20270L, 0L,2028"you can replace the integer <divisor> via 'return <divisor>;'" );2029return QUO( opL, opR );2030}20312032/* get the integer values */2033i = INT_INTOBJ(opL);2034k = INT_INTOBJ(opR);20352036/* compute the remainder, make sure we divide only positive numbers */2037if ( 0 <= i && 0 <= k ) i = ( i % k );2038else if ( 0 <= i && k < 0 ) i = ( i % -k );2039else if ( i < 0 && 0 <= k ) i = - ( -i % k );2040else if ( i < 0 && k < 0 ) i = - ( -i % -k );2041rem = INTOBJ_INT( i );20422043}20442045/* compute the remainder of a small integer by a large integer */2046else if ( IS_INTOBJ(opL) ) {20472048/* the small int -(1<<28) rem the large int (1<<28) is 0 */2049if ( opL == INTOBJ_INT(-(Int)(1L<<NR_SMALL_INT_BITS))2050&& TNUM_OBJ(opR) == T_INTPOS && SIZE_INT(opR) == 12051&& VAL_LIMB0(opR) == 1L<<NR_SMALL_INT_BITS )2052rem = INTOBJ_INT(0);20532054/* in all other cases the remainder is equal the left operand */2055else2056rem = opL;2057}20582059/* compute the remainder of a large integer by a small integer */2060else if ( IS_INTOBJ(opR) ) {20612062/* pathological case first */2063if ( opR == INTOBJ_INT(0) ) {2064opR = ErrorReturnObj(2065"Integer operations: <divisor> must be nonzero",20660L, 0L,2067"you can replace the integer <divisor> via 'return <divisor>;'" );2068return QUO( opL, opR );2069}20702071/* maybe it's trivial */2072if ( INTBASE % INT_INTOBJ(AbsInt(opR)) == 0 ) {2073c = ADDR_INT(opL)[0] % INT_INTOBJ(AbsInt(opR));2074}20752076/* otherwise run through the left operand and divide digitwise */2077else {2078opR = FuncGMP_INTOBJ( (Obj)0, opR );2079c = mpn_mod_1( ADDR_INT(opL), SIZE_INT(opL), *ADDR_INT(opR) );2080}20812082/* now c is the result, it has the same sign as the left operand */2083if ( TNUM_OBJ(opL) == T_INTPOS )2084rem = INTOBJ_INT( c );2085else2086rem = INTOBJ_INT( -(Int)c );20872088}20892090/* compute the remainder of a large integer modulo a large integer */2091else {20922093/* trivial case first */2094if ( SIZE_INT(opL) < SIZE_INT(opR) )2095return opL;20962097rem = NewBag( TNUM_OBJ(opL), (SIZE_INT(opL)+1)*sizeof(TypLimb) );20982099quo = NewBag( T_INTPOS,2100(SIZE_INT(opL)-SIZE_INT(opR)+1)*sizeof(TypLimb) );21012102/* and let gmp do the work */2103mpn_tdiv_qr( ADDR_INT(quo), ADDR_INT(rem), 0,2104ADDR_INT(opL), SIZE_INT(opL),2105ADDR_INT(opR), SIZE_INT(opR) );21062107/* reduce to small integer if possible, otherwise shrink bag */2108rem = GMP_NORMALIZE( rem );2109rem = GMP_REDUCE( rem );21102111}21122113/* return the result */2114return rem;2115}211621172118/****************************************************************************2119**2120*F FuncREM_INT(<self>,<opL>,<opR>) . . . . . . . internal function 'RemInt'2121**2122** 'FuncREM_INT' implements the internal function 'RemInt'.2123**2124** 'RemInt( <i>, <k> )'2125**2126** 'Rem' returns the remainder of its two integer operands, i.e., if <k> is2127** not equal to zero 'Rem( <i>, <k> ) = <i> - <k> * Quo( <i>, <k> )'. Note2128** that the rules given for 'Quo' (see "Quo") imply that 'Rem( <i>, <k> )'2129** has the same sign as <i> and its absolute value is strictly less than the2130** absolute value of <k>. Dividing by 0 causes an error.2131*/2132Obj FuncREM_INT ( Obj self, Obj opL, Obj opR )2133{2134/* check the arguments */2135while ( TNUM_OBJ(opL) != T_INT2136&& TNUM_OBJ(opL) != T_INTPOS2137&& TNUM_OBJ(opL) != T_INTNEG ) {2138opL = ErrorReturnObj(2139"RemInt: <left> must be an integer (not a %s)",2140(Int)TNAM_OBJ(opL), 0L,2141"you can replace <left> via 'return <left>;'" );2142}2143while ( TNUM_OBJ(opR) != T_INT2144&& TNUM_OBJ(opR) != T_INTPOS2145&& TNUM_OBJ(opR) != T_INTNEG ) {2146opR = ErrorReturnObj(2147"RemInt: <right> must be an integer (not a %s)",2148(Int)TNAM_OBJ(opR), 0L,2149"you can replace <right> via 'return <right>;'" );2150}21512152/* return the remainder */2153return RemInt( opL, opR );2154}215521562157/****************************************************************************2158**2159*F GcdInt( <opL>, <opR> ) . . . . . . . . . . . gcd of two GMP integers2160**2161** 'GcdInt' returns the gcd of the two integers <opL> and <opR>.2162**2163** It is called from 'FuncGCD_INT' and from the rational package.2164*/2165Obj GcdInt ( Obj opL, Obj opR )2166{2167Int i; /* loop count, value for small int */2168Int k; /* loop count, value for small int */2169UInt c; /* product of two digits */2170Obj gmpL; /* copy of the first arg */2171Obj gmpR; /* copy of the second arg */2172Obj gcd; /* handle of the result */2173TypLimb gcdsize; /* number of limbs mpn_gcd returns */2174Int p,q; /* number of zero limbs per arg */2175Int r,s; /* number of zero bits per arg */2176TypLimb bmask; /* bit mask */2177UInt plimbs; /* zero limbs to shift by */2178UInt prest; /* and remaining zero bits */2179UInt overflow; /* possible overflow from most2180significant word */21812182/* compute the gcd of two small integers */2183if ( ARE_INTOBJS( opL, opR ) ) {21842185/* get the integer values, make them positive */2186i = INT_INTOBJ(opL); if ( i < 0 ) i = -i;2187k = INT_INTOBJ(opR); if ( k < 0 ) k = -k;21882189/* compute the gcd using Euclids algorithm */2190while ( k != 0 ) {2191c = k;2192k = i % k;2193i = c;2194}21952196/* now i is the result */2197gcd = GMPorINTOBJ_INT( (Int)i );2198return gcd;2199}22002201/* compute the gcd of a small and a large integer */2202else if ( IS_INTOBJ(opL) || IS_INTOBJ(opR) ) {22032204/* make the right operand the small one */2205if ( IS_INTOBJ(opL) ) {2206gcd = opL; opL = opR; opR = gcd;2207}22082209/* maybe it's trivial */2210if ( opR == INTOBJ_INT(0) ) {2211if( TNUM_OBJ( opL ) == T_INTNEG ) {2212/* If opL is negative, change the sign. We do this by2213copying opL into a bag of type T_INTPOS. Note that2214opL is a large negative number, so it cannot be the2215the negative of 1 << NR_SMALL_INT_BITS. */2216gcd = NEW_INTPOS( opL );2217return gcd;2218}2219else return opL;2220}22212222/* compute the gcd */2223opR = FuncGMP_INTOBJ( (Obj)0, opR );2224i = mpn_gcd_1( ADDR_INT(opL), SIZE_INT(opL), *ADDR_INT(opR) );2225gcd = GMPorINTOBJ_INT( (Int)i );2226return gcd;2227}22282229/* compute the gcd of two large integers */2230else {2231if ( EqInt(opL,opR) ) {2232if IS_INTNEG(opL) {2233return NEW_INTPOS(opL);2234}2235else {2236return opL;2237}2238}2239gmpL = NEW_INT(opL); gmpR = NEW_INT(opR);22402241/* find highest power of 2 dividing gmpL and divide out by this */2242for ( p = 0 ; ADDR_INT(gmpL)[p] == (TypLimb)0; p++ ) {2243for ( i = 0 ; i < mp_bits_per_limb ; i++ ) {2244}2245}2246for ( bmask = (TypLimb)1, r = 0 ;2247( (bmask & ADDR_INT(gmpL)[p]) == 0 ) && bmask != (TypLimb)0 ;2248bmask = bmask << 1, r++ ) {2249}2250p = p*mp_bits_per_limb+r;2251for ( i = 0 ; i < p ; i++ ){2252mpn_rshift( ADDR_INT(gmpL), ADDR_INT(gmpL),2253SIZE_INT(gmpL), (UInt)1 );2254}2255gmpL = GMP_NORMALIZE(gmpL);22562257/* find highest power of 2 dividing gmpR and divide out by this */2258for ( q = 0 ; ADDR_INT(gmpR)[q] == (TypLimb)0; q++ ) {2259for ( i = 0 ; i < mp_bits_per_limb ; i++ ) {2260}2261}2262for ( bmask = (TypLimb)1, s = 0 ;2263( (bmask & ADDR_INT(gmpR)[q]) == 0 ) && bmask != (TypLimb)0 ;2264bmask=bmask << 1, s++ ) {2265}2266q = q*mp_bits_per_limb+s;2267for (i=0;i<q;i++){2268mpn_rshift( ADDR_INT(gmpR), ADDR_INT(gmpR),2269SIZE_INT(gmpR), (UInt)1 );2270}2271gmpR = GMP_NORMALIZE(gmpR);22722273/* put smaller object to right */2274if ( SIZE_INT(gmpL) < SIZE_INT(gmpR) ||2275( SIZE_INT(gmpL) == SIZE_INT(gmpR) &&2276mpn_cmp( ADDR_INT(gmpL), ADDR_INT(gmpR), SIZE_INT(gmpL) ) < 0 ) ) {2277gcd = gmpR; gmpR = gmpL; gmpL = gcd;2278}22792280/* get gcd of odd numbers gmpL, gmpR - put it in a bag as big as one2281of the original args, which will be big enough for the gcd */2282gcd = NewBag( T_INTPOS, SIZE_OBJ(opR) );22832284/* choose smaller of p,q and make it p2285we are going to multiply back in by 2 to that power */2286if ( p > q ) p = q;2287plimbs = p/mp_bits_per_limb;2288prest = p - plimbs*mp_bits_per_limb;22892290/* We deal with most of the power of two by placing some22910 limbs below the least significant limb of the GCD */2292for (i = 0; i < plimbs; i++)2293ADDR_INT(gcd)[i] = 0;22942295/* Now we do the GCD -- gcdsize tells us the number of2296limbs used for the result */22972298gcdsize = mpn_gcd( plimbs + ADDR_INT(gcd),2299ADDR_INT(gmpL), SIZE_INT(gmpL),2300ADDR_INT(gmpR), SIZE_INT(gmpR) );23012302/* Now we do the rest of the power of two */2303if (prest != 0)2304{2305overflow = mpn_lshift( plimbs + ADDR_INT(gcd), plimbs + ADDR_INT(gcd),2306gcdsize, (UInt)prest );23072308/* which might extend the GCD to one more limb */2309if (overflow != 0)2310{2311ADDR_INT(gcd)[gcdsize + plimbs] = overflow;2312gcdsize++;2313}2314}23152316/* if the bag is too big, reduce it (stuff in extra space may not be 0) */2317if ( gcdsize+plimbs != SIZE_INT(opR) ) {2318ResizeBag( gcd, (gcdsize+plimbs)*sizeof(TypLimb) );2319}23202321}2322gcd = GMP_NORMALIZE(gcd);2323gcd = GMP_REDUCE(gcd);23242325/* return the result */2326return gcd;2327}23282329/****************************************************************************2330**2331*F FuncGCD_INT(<self>,<opL>,<opR>) . . . . . . . internal function 'GcdInt'2332**2333** 'FuncGCD_INT' implements the internal function 'GcdInt'.2334**2335** 'GcdInt( <i>, <k> )'2336**2337** 'Gcd' returns the greatest common divisor of the two integers <m> and2338** <n>, i.e., the greatest integer that divides both <m> and <n>. The2339** greatest common divisor is never negative, even if the arguments are. We2340** define $gcd( m, 0 ) = gcd( 0, m ) = abs( m )$ and $gcd( 0, 0 ) = 0$.2341*/2342Obj FuncGCD_INT ( Obj self, Obj opL, Obj opR )2343{2344/* check the arguments */2345while ( TNUM_OBJ(opL) != T_INT2346&& TNUM_OBJ(opL) != T_INTPOS2347&& TNUM_OBJ(opL) != T_INTNEG ) {2348opL = ErrorReturnObj(2349"GcdInt: <left> must be an integer (not a %s)",2350(Int)TNAM_OBJ(opL), 0L,2351"you can replace <left> via 'return <left>;'" );2352}2353while ( TNUM_OBJ(opR) != T_INT2354&& TNUM_OBJ(opR) != T_INTPOS2355&& TNUM_OBJ(opR) != T_INTNEG ) {2356opR = ErrorReturnObj(2357"GcdInt: <right> must be an integer (not a %s)",2358(Int)TNAM_OBJ(opR), 0L,2359"you can replace <right> via 'return <right>;'" );2360}23612362/* return the gcd */2363return GcdInt( opL, opR );2364}2365236623672368236923702371/****************************************************************************2372**2373** * * * * * * * "Mersenne twister" random numbers * * * * * * * * * * * * *2374**2375** Part of this code for fast generation of 32 bit pseudo random numbers with2376** a period of length 2^19937-1 and a 623-dimensional equidistribution is2377** taken from:2378** http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html2379** (Also look in Wikipedia for "Mersenne twister".)2380*/23812382/****************************************************************************2383**2384*F RandomIntegerMT( <mtstr>, <nrbits> )2385**2386** Returns an integer with at most <nrbits> bits in uniform distribution.2387** <nrbits> must be a small integer. <mtstr> is a string as returned by2388** InitRandomMT.2389**2390** Implementation details are a bit tricky to obtain the same random2391** integers on 32 bit and 64 bit machines (which have different long2392** integer digit lengths and different ranges of small integers).2393**2394*/2395/* for comparison in case result is small int */2396Obj SMALLEST_INTPOS = NULL;23972398Obj FuncRandomIntegerMT(Obj self, Obj mtstr, Obj nrbits)2399{2400Obj res;2401Int i, n, q, r, qoff, len;2402UInt4 *mt, rand;2403UInt4 *pt;2404while (! IsStringConv(mtstr)) {2405mtstr = ErrorReturnObj(2406"<mtstr> must be a string, not a %s)",2407(Int)TNAM_OBJ(mtstr), 0L,2408"you can replace <mtstr> via 'return <mtstr>;'" );2409}2410while ((! IsStringConv(mtstr)) || GET_LEN_STRING(mtstr) < 2500) {2411mtstr = ErrorReturnObj(2412"<mtstr> must be a string with at least 2500 characters, ",24130L, 0L,2414"you can replace <mtstr> via 'return <mtstr>;'" );2415}2416while ((! IS_INTOBJ(nrbits)) || INT_INTOBJ(nrbits) < 0) {2417nrbits = ErrorReturnObj(2418"<nrbits> must be a small non-negative integer, not a %s)",2419(Int)TNAM_OBJ(nrbits), 0L,2420"you can replace <mtstr> via 'return <mtstr>;'" );2421}2422n = INT_INTOBJ(nrbits);24232424/* small int case */2425if (n <= NR_SMALL_INT_BITS) {2426mt = (UInt4*) CHARS_STRING(mtstr);2427#ifdef SYS_IS_64_BIT2428if (n <= 32) {2429res = INTOBJ_INT((Int)(nextrandMT_int32(mt) & ((UInt4) -1L >> (32-n))));2430}2431else {2432unsigned long rd;2433rd = nextrandMT_int32(mt);2434rd += (unsigned long) ((UInt4) nextrandMT_int32(mt) &2435((UInt4) -1L >> (64-n))) << 32;2436res = INTOBJ_INT((Int)rd);2437}2438#else2439res = INTOBJ_INT((Int)(nextrandMT_int32(mt) & ((UInt4) -1L >> (32-n))));2440#endif2441}2442else {2443/* large int case */2444q = n / 32;2445r = n - q * 32;2446/* qoff = number of 32 bit words we need */2447qoff = q + (r==0 ? 0:1);2448/* len = number of limbs we need (limbs currently are either 32 or 64 bit wide) */2449len = (qoff*4 + sizeof(TypLimb) - 1) / sizeof(TypLimb);2450res = NewBag( T_INTPOS, len*sizeof(TypLimb) );2451pt = (UInt4*) ADDR_INT(res);2452mt = (UInt4*) CHARS_STRING(mtstr);2453for (i = 0; i < qoff; i++, pt++) {2454rand = (UInt4) nextrandMT_int32(mt);2455*pt = rand;2456}2457if (r != 0) {2458/* we generated too many random bits -- chop of the extra bits */2459pt = (UInt4*) ADDR_INT(res);2460pt[qoff-1] = pt[qoff-1] & ((UInt4)(-1) >> (32-r));2461}2462/* shrink bag if necessary */2463res = GMP_NORMALIZE(res);2464/* convert result if small int */2465res = GMP_REDUCE(res);2466}24672468return res;2469}24702471/****************************************************************************2472**2473*F * * * * * * * * * * * * * initialize package * * * * * * * * * * * * * * *2474*/24752476/****************************************************************************2477**2478*V GVarFilts . . . . . . . . . . . . . . . . . . . list of filters to export2479*/2480static StructGVarFilt GVarFilts [] = {24812482{ "IS_INT", "obj", &IsIntFilt,2483FuncIS_INT, "src/gmpints.c:IS_INT" },24842485{ 0 }24862487};248824892490/****************************************************************************2491**2492*V GVarFuncs . . . . . . . . . . . . . . . . . . list of functions to export2493*/2494static StructGVarFunc GVarFuncs [] = {24952496{ "QUO_INT", 2, "gmp1, gmp2",2497FuncQUO_INT, "src/gmpints.c:QUO_INT" },24982499{ "ABS_INT", 1, "x",2500FuncABS_INT, "src/gmpints.c:ABS_INT" },25012502{ "REM_INT", 2, "gmp1, gmp2",2503FuncREM_INT, "src/gmpints.c:REM_INT" },25042505{ "GCD_INT", 2, "gmp1, gmp2",2506FuncGCD_INT, "src/gmpints.c:GCD_INT" },25072508{ "PROD_INT_OBJ", 2, "gmp, obj",2509FuncPROD_INT_OBJ, "src/gmpints.c:PROD_INT_OBJ" },25102511{ "POW_OBJ_INT", 2, "obj, gmp",2512FuncPOW_OBJ_INT, "src/gmpints.c:POW_OBJ_INT" },25132514{ "GMP_REDUCE", 1, "obj",2515FuncGMP_REDUCE, "src/gmpints.c:GMP_REDUCE" },25162517{ "GMP_NORMALIZE", 1, "obj",2518FuncGMP_NORMALIZE, "src/gmpints.c:GMP_NORMALIZE" },25192520{ "HexStringInt", 1, "gmp",2521FuncHexStringInt, "src/gmpints.c:HexStringInt" },25222523{ "IntHexString", 1, "string",2524FuncIntHexString, "src/gmpints.c:IntHexString" },25252526{ "Log2Int", 1, "gmp",2527FuncLog2Int, "src/gmpints.c:Log2Int" },25282529{ "STRING_INT", 1, "gmp",2530FuncSTRING_INT, "src/gmpints.c:STRING_INT" },25312532{ "RandomIntegerMT", 2, "mtstr, nrbits",2533FuncRandomIntegerMT, "src/gmpints.c:RandomIntegerMT" },253425352536{ 0 }25372538};253925402541/****************************************************************************2542**2543*F InitKernel( <module> ) . . . . . . . . initialise kernel data structures2544*/2545static Int InitKernel ( StructInitInfo * module )2546{2547UInt t1, t2;25482549if (mp_bits_per_limb != GMP_LIMB_BITS) {2550FPUTS_TO_STDERR("Panic, GMP limb size mismatch\n");2551SyExit( 1 );2552}25532554/* init filters and functions */2555InitHdlrFiltsFromTable( GVarFilts );2556InitHdlrFuncsFromTable( GVarFuncs );25572558/* install the marking functions */2559InfoBags[ T_INT ].name = "integer";2560#ifdef SYS_IS_64_BIT2561InfoBags[ T_INTPOS ].name = "integer (>= 2^60)";2562InfoBags[ T_INTNEG ].name = "integer (< -2^60)";2563#else2564InfoBags[ T_INTPOS ].name = "integer (>= 2^28)";2565InfoBags[ T_INTNEG ].name = "integer (< -2^28)";2566#endif2567InitMarkFuncBags( T_INTPOS, MarkNoSubBags );2568InitMarkFuncBags( T_INTNEG, MarkNoSubBags );25692570/* Install the saving methods */2571SaveObjFuncs [ T_INTPOS ] = SaveInt;2572SaveObjFuncs [ T_INTNEG ] = SaveInt;2573LoadObjFuncs [ T_INTPOS ] = LoadInt;2574LoadObjFuncs [ T_INTNEG ] = LoadInt;25752576/* install the printing functions */2577PrintObjFuncs[ T_INT ] = PrintInt;2578PrintObjFuncs[ T_INTPOS ] = PrintInt;2579PrintObjFuncs[ T_INTNEG ] = PrintInt;25802581/* install the comparison methods */2582for ( t1 = T_INT; t1 <= T_INTNEG; t1++ ) {2583for ( t2 = T_INT; t2 <= T_INTNEG; t2++ ) {2584EqFuncs [ t1 ][ t2 ] = EqInt;2585LtFuncs [ t1 ][ t2 ] = LtInt;2586}2587}25882589/* install the unary arithmetic methods */2590for ( t1 = T_INT; t1 <= T_INTNEG; t1++ ) {2591ZeroFuncs[ t1 ] = ZeroInt;2592ZeroMutFuncs[ t1 ] = ZeroInt;2593AInvFuncs[ t1 ] = AInvInt;2594AInvMutFuncs[ t1 ] = AInvInt;2595OneFuncs [ t1 ] = OneInt;2596OneMutFuncs [ t1 ] = OneInt;2597}25982599/* install the default product and power methods */2600for ( t1 = T_INT; t1 <= T_INTNEG; t1++ ) {2601for ( t2 = FIRST_CONSTANT_TNUM; t2 <= LAST_CONSTANT_TNUM; t2++ ) {2602ProdFuncs[ t1 ][ t2 ] = ProdIntObj;2603PowFuncs [ t2 ][ t1 ] = PowObjInt;2604}2605for ( t2 = FIRST_RECORD_TNUM; t2 <= LAST_RECORD_TNUM; t2++ ) {2606ProdFuncs[ t1 ][ t2 ] = ProdIntObj;2607PowFuncs [ t2 ][ t1 ] = PowObjInt;2608}2609for ( t2 = FIRST_LIST_TNUM; t2 <= LAST_LIST_TNUM; t2++ ) {2610ProdFuncs[ t1 ][ t2 ] = ProdIntObj;2611PowFuncs [ t2 ][ t1 ] = PowObjInt;2612}2613}26142615/* install the binary arithmetic methods */2616for ( t1 = T_INT; t1 <= T_INTNEG; t1++ ) {2617for ( t2 = T_INT; t2 <= T_INTNEG; t2++ ) {2618EqFuncs [ t1 ][ t2 ] = EqInt;2619LtFuncs [ t1 ][ t2 ] = LtInt;2620SumFuncs [ t1 ][ t2 ] = SumInt;2621DiffFuncs[ t1 ][ t2 ] = DiffInt;2622ProdFuncs[ t1 ][ t2 ] = ProdInt;2623PowFuncs [ t1 ][ t2 ] = PowInt;2624ModFuncs [ t1 ][ t2 ] = ModInt;2625}2626}26272628/* gvars to import from the library */2629ImportGVarFromLibrary( "TYPE_INT_SMALL_ZERO", &TYPE_INT_SMALL_ZERO );2630ImportGVarFromLibrary( "TYPE_INT_SMALL_POS", &TYPE_INT_SMALL_POS );2631ImportGVarFromLibrary( "TYPE_INT_SMALL_NEG", &TYPE_INT_SMALL_NEG );2632ImportGVarFromLibrary( "TYPE_INT_LARGE_POS", &TYPE_INT_LARGE_POS );2633ImportGVarFromLibrary( "TYPE_INT_LARGE_NEG", &TYPE_INT_LARGE_NEG );2634ImportGVarFromLibrary( "SMALLEST_INTPOS", &SMALLEST_INTPOS );26352636ImportFuncFromLibrary( "String", &String );2637ImportFuncFromLibrary( "One", &OneAttr);26382639/* install the type functions */2640TypeObjFuncs[ T_INT ] = TypeIntSmall;2641TypeObjFuncs[ T_INTPOS ] = TypeIntLargePos;2642TypeObjFuncs[ T_INTNEG ] = TypeIntLargeNeg;26432644MakeBagTypePublic( T_INTPOS );2645MakeBagTypePublic( T_INTNEG );26462647/* return success */2648return 0;2649}265026512652/****************************************************************************2653**2654*F InitLibrary( <module> ) . . . . . . . initialise library data structures2655*/2656static Int InitLibrary ( StructInitInfo * module )2657{2658UInt gvar;26592660/* init filters and functions */2661InitGVarFiltsFromTable( GVarFilts );2662InitGVarFuncsFromTable( GVarFuncs );26632664SMALLEST_INTPOS = NewBag( T_INTPOS, sizeof(TypLimb) );2665SET_VAL_LIMB0(SMALLEST_INTPOS, (1L<<NR_SMALL_INT_BITS));2666gvar = GVarName("SMALLEST_INTPOS");2667MakeReadWriteGVar( gvar );2668AssGVar( gvar, SMALLEST_INTPOS );2669MakeReadOnlyGVar(gvar);26702671/* return success */2672return 0;2673}267426752676/****************************************************************************2677**2678*F InitInfoInt() . . . . . . . . . . . . . . . . . . table of init functions2679*/2680static StructInitInfo module = {2681MODULE_BUILTIN, /* type */2682"gmpints", /* name */26830, /* revision entry of c file */26840, /* revision entry of h file */26850, /* version */26860, /* crc */2687InitKernel, /* initKernel */2688InitLibrary, /* initLibrary */26890, /* checkInit */26900, /* preSave */26910, /* postSave */26920 /* postRestore */2693};26942695StructInitInfo * InitInfoInt ( void )2696{2697return &module;2698}26992700#endif /* ! WARD_ENABLED */2701#endif /* USE_GMP */27022703/****************************************************************************2704**2705*E gmpints.c . . . . . . . . . . . . . . . . . . . . . . . . . . . ends here2706*/270727082709