1 /*************************************************************************
2 * *
3 * YAP Prolog *
4 * *
5 * Yap Prolog was developed at NCCUP - Universidade do Porto *
6 * *
7 * Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
8 * *
9 **************************************************************************
10 * *
11 * File: arith1.c *
12 * Last rev: *
13 * mods: *
14 * comments: bignum support through gmp *
15 * *
16 *************************************************************************/
17 #ifdef SCCS
18 static char SccsId[] = "%W% %G%";
19 #endif
20
21 #include "Yap.h"
22 #include "Yatom.h"
23
24 #if HAVE_STRING_H
25 #include <string.h>
26 #endif
27
28 #ifdef USE_GMP
29
30 #include "YapHeap.h"
31 #include "eval.h"
32 #include "alloc.h"
33
34 Term
Yap_MkBigIntTerm(MP_INT * big)35 Yap_MkBigIntTerm(MP_INT *big)
36 {
37 Int nlimbs;
38 MP_INT *dst = (MP_INT *)(H+2);
39 CELL *ret = H;
40
41 if (mpz_fits_slong_p(big)) {
42 long int out = mpz_get_si(big);
43 return MkIntegerTerm((Int)out);
44 }
45 nlimbs = big->_mp_alloc;
46 if (nlimbs > (ASP-ret)-1024) {
47 return TermNil;
48 }
49 H[0] = (CELL)FunctorBigInt;
50 H[1] = BIG_INT;
51
52 dst->_mp_size = big->_mp_size;
53 dst->_mp_alloc = big->_mp_alloc;
54 memmove((void *)(dst+1), (const void *)(big->_mp_d), nlimbs*CellSize);
55 H = (CELL *)(dst+1)+nlimbs;
56 H[0] = EndSpecials;
57 H++;
58 return AbsAppl(ret);
59 }
60
61 MP_INT *
Yap_BigIntOfTerm(Term t)62 Yap_BigIntOfTerm(Term t)
63 {
64 MP_INT *new = (MP_INT *)(RepAppl(t)+2);
65
66 new->_mp_d = (mp_limb_t *)(new+1);
67 return(new);
68 }
69
70 Term
Yap_MkBigRatTerm(MP_RAT * big)71 Yap_MkBigRatTerm(MP_RAT *big)
72 {
73 Int nlimbs;
74 MP_INT *dst = (MP_INT *)(H+2);
75 MP_INT *num = mpq_numref(big);
76 MP_INT *den = mpq_denref(big);
77 MP_RAT *rat;
78 CELL *ret = H;
79
80 if (mpz_cmp_si(den, 1) == 0)
81 return Yap_MkBigIntTerm(num);
82 if ((num->_mp_alloc+den->_mp_alloc)*(sizeof(mp_limb_t)/CellSize) > (ASP-ret)-1024) {
83 return TermNil;
84 }
85 H[0] = (CELL)FunctorBigInt;
86 H[1] = BIG_RATIONAL;
87 dst->_mp_size = 0;
88 rat = (MP_RAT *)(dst+1);
89 rat->_mp_num._mp_size = num->_mp_size;
90 rat->_mp_num._mp_alloc = num->_mp_alloc;
91 nlimbs = (num->_mp_alloc)*(sizeof(mp_limb_t)/CellSize);
92 memmove((void *)(rat+1), (const void *)(num->_mp_d), nlimbs*CellSize);
93 rat->_mp_den._mp_size = den->_mp_size;
94 rat->_mp_den._mp_alloc = den->_mp_alloc;
95 H = (CELL *)(rat+1)+nlimbs;
96 nlimbs = (den->_mp_alloc)*(sizeof(mp_limb_t)/CellSize);
97 memmove((void *)(H), (const void *)(den->_mp_d), nlimbs*CellSize);
98 H += nlimbs;
99 dst->_mp_alloc = (H-(CELL *)(dst+1));
100 H[0] = EndSpecials;
101 H++;
102 return AbsAppl(ret);
103 }
104
105 MP_RAT *
Yap_BigRatOfTerm(Term t)106 Yap_BigRatOfTerm(Term t)
107 {
108 MP_RAT *new = (MP_RAT *)(RepAppl(t)+2+sizeof(MP_INT)/sizeof(CELL));
109 mp_limb_t *nt;
110
111 nt = new->_mp_num._mp_d = (mp_limb_t *)(new+1);
112 nt += new->_mp_num._mp_alloc;
113 new->_mp_den._mp_d = nt;
114 return new;
115 }
116
117 Term
Yap_RatTermToApplTerm(Term t)118 Yap_RatTermToApplTerm(Term t)
119 {
120 Term ts[2];
121 MP_RAT *rat = Yap_BigRatOfTerm(t);
122
123 ts[0] = Yap_MkBigIntTerm(mpq_numref(rat));
124 ts[1] = Yap_MkBigIntTerm(mpq_denref(rat));
125 return Yap_MkApplTerm(FunctorRDiv,2,ts);
126 }
127
128
129 #endif
130
131 Term
Yap_MkULLIntTerm(YAP_ULONG_LONG n)132 Yap_MkULLIntTerm(YAP_ULONG_LONG n)
133 {
134 #if __GNUC__ && USE_GMP
135 mpz_t new;
136 char tmp[256];
137 Term t;
138
139 #ifdef _WIN32
140 snprintf(tmp,256,"%I64u",n);
141 #elif HAVE_SNPRINTF
142 snprintf(tmp,256,"%llu",n);
143 #else
144 sprintf(tmp,"%llu",n);
145 #endif
146 /* try to scan it as a bignum */
147 mpz_init_set_str (new, tmp, 10);
148 if (mpz_fits_slong_p(new)) {
149 return MkIntegerTerm(mpz_get_si(new));
150 }
151 t = Yap_MkBigIntTerm(new);
152 mpz_clear(new);
153 return t;
154 #else
155 return MkIntegerTerm(n);
156 #endif
157 }
158
159 static Int
p_is_bignum(void)160 p_is_bignum(void)
161 {
162 #ifdef USE_GMP
163 Term t = Deref(ARG1);
164 return(
165 IsNonVarTerm(t) &&
166 IsApplTerm(t) &&
167 FunctorOfTerm(t) == FunctorBigInt &&
168 RepAppl(t)[1] == BIG_INT
169 );
170 #else
171 return FALSE;
172 #endif
173 }
174
175 static Int
p_has_bignums(void)176 p_has_bignums(void)
177 {
178 #ifdef USE_GMP
179 return TRUE;
180 #else
181 return FALSE;
182 #endif
183 }
184
185 static Int
p_is_rational(void)186 p_is_rational(void)
187 {
188 Term t = Deref(ARG1);
189 if (IsVarTerm(t))
190 return FALSE;
191 if (IsIntTerm(t))
192 return TRUE;
193 if (IsApplTerm(t)) {
194 Functor f = FunctorOfTerm(t);
195 CELL *pt;
196
197 if (f == FunctorLongInt)
198 return TRUE;
199 if (f != FunctorBigInt)
200 return FALSE;
201 pt = RepAppl(t);
202 return ( pt[1] == BIG_RATIONAL || pt[1] == BIG_INT );
203 }
204 return FALSE;
205 }
206
207 static Int
p_rational(void)208 p_rational(void)
209 {
210 #ifdef USE_GMP
211 Term t = Deref(ARG1);
212 Functor f;
213 CELL *pt;
214 MP_RAT *rat;
215 Term t1, t2;
216
217 if (IsVarTerm(t))
218 return FALSE;
219 if (!IsApplTerm(t))
220 return FALSE;
221 f = FunctorOfTerm(t);
222 if (f != FunctorBigInt)
223 return FALSE;
224 pt = RepAppl(t);
225 if (pt[1] != BIG_RATIONAL)
226 return FALSE;
227 rat = Yap_BigRatOfTerm(t);
228 while ((t1 = Yap_MkBigIntTerm(mpq_numref(rat))) == TermNil ||
229 (t2 = Yap_MkBigIntTerm(mpq_denref(rat))) == TermNil) {
230 UInt size =
231 (mpq_numref(rat)->_mp_alloc)*(sizeof(mp_limb_t)/CellSize) +
232 (mpq_denref(rat)->_mp_alloc)*(sizeof(mp_limb_t)/CellSize);
233 if (!Yap_gcl(size, 3, ENV, P)) {
234 Yap_Error(OUT_OF_STACK_ERROR, t, Yap_ErrorMessage);
235 return FALSE;
236 }
237 }
238 return
239 Yap_unify(ARG2, t1) &&
240 Yap_unify(ARG3, t2);
241 #else
242 return FALSE;
243 #endif
244 }
245
246 Term
Yap_MkBlobStringTerm(const char * s,size_t len)247 Yap_MkBlobStringTerm(const char *s, size_t len)
248 {
249 CELL *ret = H;
250 size_t sz;
251 MP_INT *dst = (MP_INT *)(H+2);
252 blob_string_t *sp;
253 size_t siz;
254
255 sz = strlen(s);
256 if (len > 0 && sz > len) sz = len;
257 if (len/sizeof(CELL) > (ASP-ret)-1024) {
258 return TermNil;
259 }
260 H[0] = (CELL)FunctorBigInt;
261 H[1] = BLOB_STRING;
262
263 siz = (sizeof(size_t)+len+sizeof(CELL))/sizeof(CELL);
264 dst->_mp_size = 0L;
265 dst->_mp_alloc = siz;
266 sp = (blob_string_t *)(dst+1);
267 sp->len = sz;
268 strncpy((char *)(sp+1), s, sz);
269 H += siz;
270 H[0] = EndSpecials;
271 H++;
272 return AbsAppl(ret);
273 }
274
275 Term
Yap_MkBlobWideStringTerm(const wchar_t * s,size_t len)276 Yap_MkBlobWideStringTerm(const wchar_t *s, size_t len)
277 {
278 CELL *ret = H;
279 size_t sz;
280 MP_INT *dst = (MP_INT *)(H+2);
281 blob_string_t *sp;
282 size_t siz;
283
284 sz = wcslen(s);
285 if (len > 0 && sz > len) sz = len;
286 if (len/sizeof(CELL) > (ASP-ret)-1024) {
287 return TermNil;
288 }
289 H[0] = (CELL)FunctorBigInt;
290 H[1] = BLOB_WIDE_STRING;
291
292 siz = (sizeof(size_t)+(len+2)*sizeof(wchar_t))/sizeof(CELL);
293 dst->_mp_size = 0L;
294 dst->_mp_alloc = siz;
295 sp = (blob_string_t *)(dst+1);
296 sp->len = sz;
297 wcsncpy((wchar_t *)(sp+1), s, sz);
298 H += siz;
299 H[0] = EndSpecials;
300 H++;
301 return AbsAppl(ret);
302 }
303
304 char *
Yap_BlobStringOfTerm(Term t)305 Yap_BlobStringOfTerm(Term t)
306 {
307 blob_string_t *new = (blob_string_t *)(RepAppl(t)+2+sizeof(MP_INT)/sizeof(CELL));
308 return (char *)(new+1);
309 }
310
311 wchar_t *
Yap_BlobWideStringOfTerm(Term t)312 Yap_BlobWideStringOfTerm(Term t)
313 {
314 blob_string_t *new = (blob_string_t *)(RepAppl(t)+2+sizeof(MP_INT)/sizeof(CELL));
315 return (wchar_t *)(new+1);
316 }
317
318 char *
Yap_BlobStringOfTermAndLength(Term t,size_t * sp)319 Yap_BlobStringOfTermAndLength(Term t, size_t *sp)
320 {
321 blob_string_t *new = (blob_string_t *)(RepAppl(t)+2+sizeof(MP_INT)/sizeof(CELL));
322 *sp = new->len;
323 return (char *)(new+1);
324 }
325
326 void
Yap_InitBigNums(void)327 Yap_InitBigNums(void)
328 {
329 Yap_InitCPred("$has_bignums", 0, p_has_bignums, SafePredFlag|HiddenPredFlag);
330 Yap_InitCPred("$bignum", 1, p_is_bignum, SafePredFlag|HiddenPredFlag);
331 Yap_InitCPred("rational", 3, p_rational, 0);
332 Yap_InitCPred("rational", 1, p_is_rational, SafePredFlag);
333 }
334