Line data Source code
1 : /* Copyright (C) 2000-2003 The PARI group.
2 :
3 : This file is part of the PARI/GP package.
4 :
5 : PARI/GP is free software; you can redistribute it and/or modify it under the
6 : terms of the GNU General Public License as published by the Free Software
7 : Foundation; either version 2 of the License, or (at your option) any later
8 : version. It is distributed in the hope that it will be useful, but WITHOUT
9 : ANY WARRANTY WHATSOEVER.
10 :
11 : Check the License for details. You should have received a copy of it, along
12 : with the package; see the file 'COPYING'. If not, write to the Free Software
13 : Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. */
14 :
15 : /*******************************************************************/
16 : /* */
17 : /* INITIALIZING THE SYSTEM, ERRORS, STACK MANAGEMENT */
18 : /* */
19 : /*******************************************************************/
20 : /* _GNU_SOURCE is needed before first include to get RUSAGE_THREAD */
21 : #undef _GNU_SOURCE /* avoid warning */
22 : #define _GNU_SOURCE
23 : #include <string.h>
24 : #if defined(_WIN32) || defined(__CYGWIN32__)
25 : # include "../systems/mingw/mingw.h"
26 : # include <process.h>
27 : #endif
28 : #include "paricfg.h"
29 : #if defined(STACK_CHECK) && !defined(__EMX__) && !defined(_WIN32)
30 : # include <sys/types.h>
31 : # include <sys/time.h>
32 : # include <sys/resource.h>
33 : #endif
34 : #if defined(HAS_WAITPID) && defined(HAS_SETSID)
35 : # include <sys/wait.h>
36 : #endif
37 : #ifdef HAS_MMAP
38 : # include <sys/mman.h>
39 : #endif
40 : #if defined(USE_GETTIMEOFDAY) || defined(USE_GETRUSAGE) || defined(USE_TIMES)
41 : # include <sys/time.h>
42 : #endif
43 : #if defined(USE_GETRUSAGE)
44 : # include <sys/resource.h>
45 : #endif
46 : #if defined(USE_FTIME) || defined(USE_FTIMEFORWALLTIME)
47 : # include <sys/timeb.h>
48 : #endif
49 : #if defined(USE_CLOCK_GETTIME) || defined(USE_TIMES)
50 : # include <time.h>
51 : #endif
52 : #if defined(USE_TIMES)
53 : # include <sys/times.h>
54 : #endif
55 : #define PARI_INIT
56 : #include "pari.h"
57 : #include "paripriv.h"
58 : #include "anal.h"
59 :
60 : const double LOG10_2 = 0.3010299956639812; /* log_10(2) */
61 : const double LOG2_10 = 3.321928094887362; /* log_2(10) */
62 :
63 : GEN gnil, gen_0, gen_1, gen_m1, gen_2, gen_m2, ghalf, err_e_STACK;
64 :
65 : static const ulong readonly_constants[] = {
66 : evaltyp(t_INT) | _evallg(2), /* gen_0 */
67 : evallgefint(2),
68 : evaltyp(t_INT) | _evallg(2), /* gnil */
69 : evallgefint(2),
70 : evaltyp(t_INT) | _evallg(3), /* gen_1 */
71 : evalsigne(1) | evallgefint(3),
72 : 1,
73 : evaltyp(t_INT) | _evallg(3), /* gen_2 */
74 : evalsigne(1) | evallgefint(3),
75 : 2,
76 : evaltyp(t_INT) | _evallg(3), /* gen_m1 */
77 : evalsigne(-1) | evallgefint(3),
78 : 1,
79 : evaltyp(t_INT) | _evallg(3), /* gen_m2 */
80 : evalsigne(-1) | evallgefint(3),
81 : 2,
82 : evaltyp(t_ERROR) | _evallg(2), /* err_e_STACK */
83 : e_STACK,
84 : evaltyp(t_FRAC) | _evallg(3), /* ghalf */
85 : (ulong)(readonly_constants+4),
86 : (ulong)(readonly_constants+7)
87 : };
88 : THREAD GEN zetazone, bernzone, eulerzone, primetab;
89 : pari_prime *pari_PRIMES;
90 : FILE *pari_outfile, *pari_errfile, *pari_logfile, *pari_infile;
91 : char *current_logfile, *current_psfile, *pari_datadir;
92 : long gp_colors[c_LAST];
93 : int disable_color;
94 : ulong DEBUGLEVEL, DEBUGMEM;
95 : THREAD long DEBUGVAR;
96 : ulong pari_mt_nbthreads;
97 : long precreal;
98 : ulong precdl, pari_logstyle;
99 : gp_data *GP_DATA;
100 :
101 : entree **varentries;
102 : THREAD long *varpriority;
103 :
104 : THREAD pari_sp avma;
105 : THREAD struct pari_mainstack *pari_mainstack;
106 :
107 : static void ** MODULES;
108 : static pari_stack s_MODULES;
109 : const long functions_tblsz = 135; /* size of functions_hash */
110 : entree **functions_hash, **defaults_hash;
111 :
112 : void (*cb_pari_display_hist)(long n);
113 : char *(*cb_pari_fgets_interactive)(char *s, int n, FILE *f);
114 : int (*cb_pari_get_line_interactive)(const char*, const char*, filtre_t *F);
115 : void (*cb_pari_quit)(long);
116 : void (*cb_pari_init_histfile)(void);
117 : void (*cb_pari_ask_confirm)(const char *);
118 : int (*cb_pari_handle_exception)(long);
119 : int (*cb_pari_err_handle)(GEN);
120 : int (*cb_pari_whatnow)(PariOUT *out, const char *, int);
121 : void (*cb_pari_sigint)(void);
122 : void (*cb_pari_pre_recover)(long);
123 : void (*cb_pari_err_recover)(long);
124 : int (*cb_pari_break_loop)(int);
125 : int (*cb_pari_is_interactive)(void);
126 : void (*cb_pari_start_output)(void);
127 : void (*cb_pari_long_help)(const char *s, long num);
128 :
129 : const char * pari_library_path = NULL;
130 :
131 : static THREAD GEN global_err_data;
132 : THREAD jmp_buf *iferr_env;
133 : const long CATCH_ALL = -1;
134 :
135 : static void pari_init_timer(void);
136 :
137 : /*********************************************************************/
138 : /* */
139 : /* BLOCKS & CLONES */
140 : /* */
141 : /*********************************************************************/
142 : /*#define DEBUG*/
143 : static THREAD long next_block;
144 : static THREAD GEN cur_block; /* current block in block list */
145 : static THREAD GEN root_block; /* current block in block list */
146 :
147 : static void
148 324441 : pari_init_blocks(void)
149 : {
150 324441 : next_block = 0; cur_block = NULL; root_block = NULL;
151 324441 : }
152 :
153 : static void
154 316652 : pari_close_blocks(void)
155 : {
156 2163401 : while (cur_block) killblock(cur_block);
157 322162 : }
158 :
159 : static long
160 11420114306 : blockheight(GEN bl) { return bl? bl_height(bl): 0; }
161 :
162 : static long
163 2741276382 : blockbalance(GEN bl)
164 2741276382 : { return bl ? blockheight(bl_left(bl)) - blockheight(bl_right(bl)): 0; }
165 :
166 : static void
167 2968839546 : fix_height(GEN bl)
168 2968839546 : { bl_height(bl) = maxss(blockheight(bl_left(bl)), blockheight(bl_right(bl)))+1; }
169 :
170 : static GEN
171 60537681 : bl_rotright(GEN y)
172 : {
173 60537681 : GEN x = bl_left(y), t = bl_right(x);
174 60537681 : bl_right(x) = y;
175 60537681 : bl_left(y) = t;
176 60537681 : fix_height(y);
177 60537671 : fix_height(x);
178 60537640 : return x;
179 : }
180 :
181 : static GEN
182 63532945 : bl_rotleft(GEN x)
183 : {
184 63532945 : GEN y = bl_right(x), t = bl_left(y);
185 63532945 : bl_left(y) = x;
186 63532945 : bl_right(x) = t;
187 63532945 : fix_height(x);
188 63533094 : fix_height(y);
189 63533113 : return y;
190 : }
191 :
192 : static GEN
193 1662990600 : blockinsert(GEN x, GEN bl, long *d)
194 : {
195 : long b, c;
196 1662990600 : if (!bl)
197 : {
198 232186195 : bl_left(x)=NULL; bl_right(x)=NULL;
199 232186195 : bl_height(x)=1; return x;
200 : }
201 1430804405 : c = cmpuu((ulong)x, (ulong)bl);
202 1430806561 : if (c < 0)
203 578748062 : bl_left(bl) = blockinsert(x, bl_left(bl), d);
204 852058499 : else if (c > 0)
205 852058499 : bl_right(bl) = blockinsert(x, bl_right(bl), d);
206 0 : else return bl; /* ??? Already exist in the tree ? */
207 1430790889 : fix_height(bl);
208 1430769841 : b = blockbalance(bl);
209 1430779391 : if (b > 1)
210 : {
211 32509053 : if (*d > 0) bl_left(bl) = bl_rotleft(bl_left(bl));
212 32509077 : return bl_rotright(bl);
213 : }
214 1398270338 : if (b < -1)
215 : {
216 30944802 : if (*d < 0) bl_right(bl) = bl_rotright(bl_right(bl));
217 30944806 : return bl_rotleft(bl);
218 : }
219 1367325536 : *d = c; return bl;
220 : }
221 :
222 : static GEN
223 1522248373 : blockdelete(GEN x, GEN bl)
224 : {
225 : long b;
226 1522248373 : if (!bl) return NULL; /* ??? Do not exist in the tree */
227 1522248373 : if (x < bl)
228 533038549 : bl_left(bl) = blockdelete(x, bl_left(bl));
229 989209824 : else if (x > bl)
230 705060255 : bl_right(bl) = blockdelete(x, bl_right(bl));
231 : else
232 : {
233 284149569 : if (!bl_left(bl) && !bl_right(bl)) return NULL;
234 94899111 : else if (!bl_left(bl)) return bl_right(bl);
235 73627511 : else if (!bl_right(bl)) return bl_left(bl);
236 : else
237 : {
238 51965718 : GEN r = bl_right(bl);
239 74822647 : while (bl_left(r)) r = bl_left(r);
240 51965718 : bl_right(r) = blockdelete(r, bl_right(bl));
241 51970718 : bl_left(r) = bl_left(bl);
242 51970718 : bl = r;
243 : }
244 : }
245 1290049301 : fix_height(bl);
246 1290029644 : b = blockbalance(bl);
247 1290027083 : if (b > 1)
248 : {
249 14554507 : if (blockbalance(bl_left(bl)) >= 0) return bl_rotright(bl);
250 : else
251 2091692 : { bl_left(bl) = bl_rotleft(bl_left(bl)); return bl_rotright(bl); }
252 : }
253 1275472576 : if (b < -1)
254 : {
255 6001840 : if (blockbalance(bl_right(bl)) <= 0) return bl_rotleft(bl);
256 : else
257 1978302 : { bl_right(bl) = bl_rotright(bl_right(bl)); return bl_rotleft(bl); }
258 : }
259 1269470736 : return bl;
260 : }
261 :
262 : static GEN
263 752677629 : blocksearch(GEN x, GEN bl)
264 : {
265 752677629 : if (isclone(x)) return x;
266 578228178 : if (isonstack(x) || is_universal_constant(x)) return NULL;
267 893507398 : while (bl)
268 : {
269 890527925 : if (x >= bl && x < bl + bl_size(bl))
270 229180062 : return bl;
271 661347863 : bl = x < bl ? bl_left(bl): bl_right(bl);
272 : }
273 2979473 : return NULL; /* Unknown address */
274 : }
275 :
276 : static int
277 1747556 : check_clone(GEN x)
278 : {
279 1747556 : GEN bl = root_block;
280 1747556 : if (isonstack(x) || is_universal_constant(x)) return 1;
281 2371126 : while (bl)
282 : {
283 2371126 : if (x >= bl && x < bl + bl_size(bl))
284 276232 : return 1;
285 2094894 : bl = x < bl ? bl_left(bl): bl_right(bl);
286 : }
287 0 : return 0; /* Unknown address */
288 : }
289 :
290 : void
291 376535130 : clone_lock(GEN x)
292 : {
293 376535130 : GEN y = blocksearch(x, root_block);
294 376231879 : if (y && isclone(y))
295 : {
296 201591711 : if (DEBUGMEM > 2)
297 0 : err_printf("locking block no %ld: %08lx from %08lx\n", bl_num(y), y, x);
298 201591711 : ++bl_refc(y);
299 : }
300 376231879 : }
301 :
302 : void
303 317224970 : clone_unlock(GEN x)
304 : {
305 317224970 : GEN y = blocksearch(x, root_block);
306 317170563 : if (y && isclone(y))
307 : {
308 149913953 : if (DEBUGMEM > 2)
309 0 : err_printf("unlocking block no %ld: %08lx from %08lx\n", bl_num(y), y, x);
310 149913953 : gunclone(y);
311 : }
312 317170563 : }
313 :
314 : void
315 59295466 : clone_unlock_deep(GEN x)
316 : {
317 59295466 : GEN y = blocksearch(x, root_block);
318 59295466 : if (y && isclone(y))
319 : {
320 52122097 : if (DEBUGMEM > 2)
321 0 : err_printf("unlocking deep block no %ld: %08lx from %08lx\n", bl_num(y), y, x);
322 52122097 : gunclone_deep(y);
323 : }
324 59295466 : }
325 :
326 : /* Return x, where:
327 : * x[-8]: AVL height
328 : * x[-7]: adress of left child or NULL
329 : * x[-6]: adress of right child or NULL
330 : * x[-5]: size
331 : * x[-4]: reference count
332 : * x[-3]: adress of next block
333 : * x[-2]: adress of preceding block.
334 : * x[-1]: number of allocated blocs.
335 : * x[0..n-1]: malloc-ed memory. */
336 : GEN
337 232185470 : newblock(size_t n)
338 : {
339 232185470 : long d = 0;
340 232185470 : long *x = (long *) pari_malloc((n + BL_HEAD)*sizeof(long)) + BL_HEAD;
341 :
342 232189505 : bl_size(x) = n;
343 232189505 : bl_refc(x) = 1;
344 232189505 : bl_next(x) = NULL;
345 232189505 : bl_prev(x) = cur_block;
346 232189505 : bl_num(x) = next_block++;
347 232189505 : if (cur_block) bl_next(cur_block) = x;
348 232189505 : root_block = blockinsert(x, root_block, &d);
349 232185985 : if (DEBUGMEM > 2)
350 0 : err_printf("new block, size %6lu (no %ld): %08lx\n", n, next_block-1, x);
351 232186011 : return cur_block = x;
352 : }
353 :
354 : GEN
355 37888 : gcloneref(GEN x)
356 : {
357 37888 : if (isclone(x)) { ++bl_refc(x); return x; }
358 37370 : else return gclone(x);
359 : }
360 :
361 : void
362 0 : gclone_refc(GEN x) { ++bl_refc(x); }
363 :
364 : void
365 382086244 : gunclone(GEN x)
366 : {
367 382086244 : if (--bl_refc(x) > 0) return;
368 232172193 : BLOCK_SIGINT_START;
369 232183118 : root_block = blockdelete(x, root_block);
370 232160682 : if (bl_next(x)) bl_prev(bl_next(x)) = bl_prev(x);
371 : else
372 : {
373 38265135 : cur_block = bl_prev(x);
374 38265135 : next_block = bl_num(x);
375 : }
376 232160682 : if (bl_prev(x)) bl_next(bl_prev(x)) = bl_next(x);
377 232160682 : if (DEBUGMEM > 2)
378 0 : err_printf("killing block (no %ld): %08lx\n", bl_num(x), x);
379 232160682 : free((void*)bl_base(x)); /* pari_free not needed: we already block */
380 232160682 : BLOCK_SIGINT_END;
381 : }
382 :
383 : static void
384 127307552 : vec_gunclone_deep(GEN x)
385 : {
386 127307552 : long i, l = lg(x);
387 3114391601 : for (i = 1; i < l; i++) gunclone_deep(gel(x,i));
388 127307287 : }
389 : /* Recursively look for clones in the container and kill them. Then kill
390 : * container if clone. */
391 : void
392 3241133233 : gunclone_deep(GEN x)
393 : {
394 : GEN v;
395 3241133233 : if (isclone(x) && bl_refc(x) > 1) { --bl_refc(x); return; }
396 3189010086 : BLOCK_SIGINT_START;
397 3189010089 : switch(typ(x))
398 : {
399 127306532 : case t_VEC: case t_COL: case t_MAT:
400 127306532 : vec_gunclone_deep(x);
401 127306529 : break;
402 5825 : case t_LIST:
403 5825 : if ((v = list_data(x))) { vec_gunclone_deep(v); gunclone(v); }
404 5825 : break;
405 : }
406 3189010086 : if (isclone(x)) gunclone(x);
407 3189009964 : BLOCK_SIGINT_END;
408 : }
409 :
410 : int
411 315637 : pop_entree_block(entree *ep, long loc)
412 : {
413 315637 : GEN x = (GEN)ep->value;
414 315637 : if (bl_num(x) < loc) return 0; /* older */
415 469 : if (DEBUGMEM>2)
416 0 : err_printf("popping %s (block no %ld)\n", ep->name, bl_num(x));
417 469 : gunclone_deep(x); return 1;
418 : }
419 :
420 : /***************************************************************************
421 : ** **
422 : ** Export **
423 : ** **
424 : ***************************************************************************/
425 :
426 : static hashtable *export_hash;
427 : static void
428 1851 : pari_init_export(void)
429 : {
430 1851 : export_hash = hash_create_str(1,0);
431 1851 : }
432 : static void
433 1841 : pari_close_export(void)
434 : {
435 1841 : hash_destroy(export_hash);
436 1841 : }
437 :
438 : /* Exported values are blocks, but do not have the clone bit set so that they
439 : * are not affected by clone_lock and ensure_nb, etc. */
440 :
441 : void
442 59 : export_add(const char *str, GEN val)
443 : {
444 : hashentry *h;
445 59 : val = gclone(val); unsetisclone(val);
446 59 : h = hash_search(export_hash, (void*) str);
447 59 : if (h)
448 : {
449 21 : GEN v = (GEN)h->val;
450 21 : h->val = val;
451 21 : setisclone(v); gunclone(v);
452 : }
453 : else
454 38 : hash_insert(export_hash,(void*)str, (void*) val);
455 59 : }
456 :
457 : void
458 24 : export_del(const char *str)
459 : {
460 24 : hashentry *h = hash_remove(export_hash,(void*)str);
461 24 : if (h)
462 : {
463 24 : GEN v = (GEN)h->val;
464 24 : setisclone(v); gunclone(v);
465 24 : pari_free(h);
466 : }
467 24 : }
468 :
469 : GEN
470 1500 : export_get(const char *str)
471 : {
472 1500 : return hash_haskey_GEN(export_hash,(void*)str);
473 : }
474 :
475 : void
476 6 : unexportall(void)
477 : {
478 6 : pari_sp av = avma;
479 6 : GEN keys = hash_keys(export_hash);
480 6 : long i, l = lg(keys);
481 24 : for (i = 1; i < l; i++) mt_export_del((const char *)keys[i]);
482 6 : set_avma(av);
483 6 : }
484 :
485 : void
486 6 : exportall(void)
487 : {
488 : long i;
489 816 : for (i = 0; i < functions_tblsz; i++)
490 : {
491 : entree *ep;
492 8982 : for (ep = functions_hash[i]; ep; ep = ep->next)
493 8172 : if (EpVALENCE(ep)==EpVAR) mt_export_add(ep->name, (GEN)ep->value);
494 : }
495 6 : }
496 :
497 : /*********************************************************************/
498 : /* */
499 : /* C STACK SIZE CONTROL */
500 : /* */
501 : /*********************************************************************/
502 : /* Avoid core dump on deep recursion. Adapted Perl code by Dominic Dunlop */
503 : THREAD void *PARI_stack_limit = NULL;
504 :
505 : #ifdef STACK_CHECK
506 :
507 : # ifdef __EMX__ /* Emulate */
508 : void
509 : pari_stackcheck_init(void *pari_stack_base)
510 : {
511 : if (!pari_stack_base) { PARI_stack_limit = NULL; return; }
512 : PARI_stack_limit = get_stack(1./16, 32*1024);
513 : }
514 : # elif _WIN32
515 : void
516 : pari_stackcheck_init(void *pari_stack_base)
517 : {
518 : ulong size = 1UL << 21;
519 : if (!pari_stack_base) { PARI_stack_limit = NULL; return; }
520 : if (size > (ulong)pari_stack_base)
521 : PARI_stack_limit = (void*)(((ulong)pari_stack_base) / 16);
522 : else
523 : PARI_stack_limit = (void*)((ulong)pari_stack_base - (size/16)*15);
524 : }
525 : # else /* !__EMX__ && !_WIN32 */
526 : /* Set PARI_stack_limit to (a little above) the lowest safe address that can be
527 : * used on the stack. Leave PARI_stack_limit at its initial value (NULL) to
528 : * show no check should be made [init failed]. Assume stack grows downward. */
529 : void
530 326297 : pari_stackcheck_init(void *pari_stack_base)
531 : {
532 : struct rlimit rip;
533 : ulong size;
534 326297 : if (!pari_stack_base) { PARI_stack_limit = NULL; return; }
535 326297 : if (getrlimit(RLIMIT_STACK, &rip)) return;
536 326310 : size = rip.rlim_cur;
537 326310 : if (size == (ulong)RLIM_INFINITY || size > (ulong)pari_stack_base)
538 0 : PARI_stack_limit = (void*)(((ulong)pari_stack_base) / 16);
539 : else
540 326311 : PARI_stack_limit = (void*)((ulong)pari_stack_base - (size/16)*15);
541 : }
542 : # endif /* !__EMX__ */
543 :
544 : #else
545 : void
546 : pari_stackcheck_init(void *pari_stack_base)
547 : {
548 : (void) pari_stack_base; PARI_stack_limit = NULL;
549 : }
550 : #endif /* STACK_CHECK */
551 :
552 : /*******************************************************************/
553 : /* HEAP TRAVERSAL */
554 : /*******************************************************************/
555 : struct getheap_t { long n, l; };
556 : /* x is a block, not necessarily a clone [x[0] may not be set] */
557 : static void
558 6664 : f_getheap(GEN x, void *D)
559 : {
560 6664 : struct getheap_t *T = (struct getheap_t*)D;
561 6664 : T->n++;
562 6664 : T->l += bl_size(x) + BL_HEAD;
563 6664 : }
564 : GEN
565 84 : getheap(void)
566 : {
567 84 : struct getheap_t T = { 0, 0 };
568 84 : traverseheap(&f_getheap, &T); return mkvec2s(T.n, T.l);
569 : }
570 :
571 : static void
572 13412 : traverseheap_r(GEN bl, void(*f)(GEN, void *), void *data)
573 : {
574 13412 : if (!bl) return;
575 6664 : traverseheap_r(bl_left(bl), f, data);
576 6664 : traverseheap_r(bl_right(bl), f, data);
577 6664 : f(bl, data);
578 : }
579 :
580 : void
581 84 : traverseheap( void(*f)(GEN, void *), void *data)
582 : {
583 84 : traverseheap_r(root_block,f, data);
584 84 : }
585 :
586 : /*********************************************************************/
587 : /* DAEMON / FORK */
588 : /*********************************************************************/
589 : #if defined(HAS_WAITPID) && defined(HAS_SETSID)
590 : /* Properly fork a process, detaching from main process group without creating
591 : * zombies on exit. Parent returns 1, son returns 0 */
592 : int
593 76 : pari_daemon(void)
594 : {
595 76 : pid_t pid = fork();
596 76 : switch(pid) {
597 0 : case -1: return 1; /* father, fork failed */
598 0 : case 0:
599 0 : (void)setsid(); /* son becomes process group leader */
600 0 : if (fork()) _exit(0); /* now son exits, also when fork fails */
601 0 : break; /* grandson: its father is the son, which exited,
602 : * hence father becomes 'init', that'll take care of it */
603 76 : default: /* father, fork succeeded */
604 76 : (void)waitpid(pid,NULL,0); /* wait for son to exit, immediate */
605 76 : return 1;
606 : }
607 : /* grandson. The silly '!' avoids a gcc-8 warning (unused value) */
608 0 : (void)!freopen("/dev/null","r",stdin);
609 0 : return 0;
610 : }
611 : #else
612 : int
613 : pari_daemon(void)
614 : {
615 : pari_err_IMPL("pari_daemon without waitpid & setsid");
616 : return 0;
617 : }
618 : #endif
619 :
620 : /*********************************************************************/
621 : /* */
622 : /* SYSTEM INITIALIZATION */
623 : /* */
624 : /*********************************************************************/
625 : static int try_to_recover = 0;
626 : THREAD VOLATILE int PARI_SIGINT_block = 0, PARI_SIGINT_pending = 0;
627 :
628 : /*********************************************************************/
629 : /* SIGNAL HANDLERS */
630 : /*********************************************************************/
631 : static void
632 0 : dflt_sigint_fun(void) { pari_err(e_MISC, "user interrupt"); }
633 :
634 : #if defined(_WIN32) || defined(__CYGWIN32__)
635 : int win32ctrlc = 0, win32alrm = 0;
636 : void
637 : dowin32ctrlc(void)
638 : {
639 : win32ctrlc = 0;
640 : cb_pari_sigint();
641 : }
642 : #endif
643 :
644 : static void
645 0 : pari_handle_SIGINT(void)
646 : {
647 : #ifdef _WIN32
648 : if (++win32ctrlc >= 5) _exit(3);
649 : #else
650 0 : cb_pari_sigint();
651 : #endif
652 0 : }
653 :
654 : typedef void (*pari_sighandler_t)(int);
655 :
656 : pari_sighandler_t
657 20301 : os_signal(int sig, pari_sighandler_t f)
658 : {
659 : #ifdef HAS_SIGACTION
660 : struct sigaction sa, oldsa;
661 :
662 20301 : sa.sa_handler = f;
663 20301 : sigemptyset(&sa.sa_mask);
664 20301 : sa.sa_flags = SA_NODEFER;
665 :
666 20301 : if (sigaction(sig, &sa, &oldsa)) return NULL;
667 20301 : return oldsa.sa_handler;
668 : #else
669 : return signal(sig,f);
670 : #endif
671 : }
672 :
673 : void
674 0 : pari_sighandler(int sig)
675 : {
676 : const char *msg;
677 : #ifndef HAS_SIGACTION
678 : /*SYSV reset the signal handler in the handler*/
679 : (void)os_signal(sig,pari_sighandler);
680 : #endif
681 0 : switch(sig)
682 : {
683 : #ifdef SIGBREAK
684 : case SIGBREAK:
685 : if (PARI_SIGINT_block==1)
686 : {
687 : PARI_SIGINT_pending=SIGBREAK;
688 : mt_sigint();
689 : }
690 : else pari_handle_SIGINT();
691 : return;
692 : #endif
693 :
694 : #ifdef SIGINT
695 0 : case SIGINT:
696 0 : if (PARI_SIGINT_block==1)
697 : {
698 0 : PARI_SIGINT_pending=SIGINT;
699 0 : mt_sigint();
700 : }
701 0 : else pari_handle_SIGINT();
702 0 : return;
703 : #endif
704 :
705 : #ifdef SIGSEGV
706 0 : case SIGSEGV:
707 0 : msg="PARI/GP (Segmentation Fault)"; break;
708 : #endif
709 : #ifdef SIGBUS
710 0 : case SIGBUS:
711 0 : msg="PARI/GP (Bus Error)"; break;
712 : #endif
713 : #ifdef SIGFPE
714 0 : case SIGFPE:
715 0 : msg="PARI/GP (Floating Point Exception)"; break;
716 : #endif
717 :
718 : #ifdef SIGPIPE
719 0 : case SIGPIPE:
720 : {
721 0 : pariFILE *f = GP_DATA->pp->file;
722 0 : if (f && pari_outfile == f->file)
723 : {
724 0 : GP_DATA->pp->file = NULL; /* to avoid oo recursion on error */
725 0 : pari_outfile = stdout; pari_fclose(f);
726 0 : pari_err(e_MISC, "Broken Pipe, resetting file stack...");
727 : }
728 : return; /* LCOV_EXCL_LINE */
729 : }
730 : #endif
731 :
732 0 : default: msg="signal handling"; break;
733 : }
734 0 : pari_err_BUG(msg);
735 : }
736 :
737 : void
738 3692 : pari_sig_init(void (*f)(int))
739 : {
740 : #ifdef SIGBUS
741 3692 : (void)os_signal(SIGBUS,f);
742 : #endif
743 : #ifdef SIGFPE
744 3692 : (void)os_signal(SIGFPE,f);
745 : #endif
746 : #ifdef SIGINT
747 3692 : (void)os_signal(SIGINT,f);
748 : #endif
749 : #ifdef SIGBREAK
750 : (void)os_signal(SIGBREAK,f);
751 : #endif
752 : #ifdef SIGPIPE
753 3692 : (void)os_signal(SIGPIPE,f);
754 : #endif
755 : #ifdef SIGSEGV
756 3692 : (void)os_signal(SIGSEGV,f);
757 : #endif
758 3692 : }
759 :
760 : /*********************************************************************/
761 : /* STACK AND UNIVERSAL CONSTANTS */
762 : /*********************************************************************/
763 : static void
764 1851 : init_universal_constants(void)
765 : {
766 1851 : gen_0 = (GEN)readonly_constants;
767 1851 : gnil = (GEN)readonly_constants+2;
768 1851 : gen_1 = (GEN)readonly_constants+4;
769 1851 : gen_2 = (GEN)readonly_constants+7;
770 1851 : gen_m1 = (GEN)readonly_constants+10;
771 1851 : gen_m2 = (GEN)readonly_constants+13;
772 1851 : err_e_STACK = (GEN)readonly_constants+16;
773 1851 : ghalf = (GEN)readonly_constants+18;
774 1851 : }
775 :
776 : static void
777 324861 : pari_init_errcatch(void)
778 : {
779 324861 : iferr_env = NULL;
780 324861 : global_err_data = NULL;
781 324861 : }
782 :
783 : void
784 1879 : setalldebug(long n)
785 : {
786 1879 : long i, l = numberof(pari_DEBUGLEVEL_ptr);
787 114619 : for (i = 0; i < l; i++) *pari_DEBUGLEVEL_ptr[i] = n;
788 1879 : }
789 :
790 : /*********************************************************************/
791 : /* INIT DEFAULTS */
792 : /*********************************************************************/
793 : void
794 1851 : pari_init_defaults(void)
795 : {
796 : long i;
797 1851 : initout(1);
798 :
799 1851 : precreal = 128;
800 1851 : precdl = 16;
801 1851 : DEBUGLEVEL = 0;
802 1851 : setalldebug(0);
803 1851 : DEBUGMEM = 1;
804 1851 : disable_color = 1;
805 1851 : pari_logstyle = logstyle_none;
806 :
807 1851 : current_psfile = pari_strdup("pari.ps");
808 1851 : current_logfile= pari_strdup("pari.log");
809 1851 : pari_logfile = NULL;
810 :
811 1851 : pari_datadir = os_getenv("GP_DATA_DIR");
812 1851 : if (!pari_datadir)
813 : {
814 : #if defined(_WIN32) || defined(__CYGWIN32__)
815 : if (paricfg_datadir[0]=='@' && paricfg_datadir[1]==0)
816 : pari_datadir = win32_datadir();
817 : else
818 : #endif
819 1851 : pari_datadir = pari_strdup(paricfg_datadir);
820 : }
821 0 : else pari_datadir= pari_strdup(pari_datadir);
822 14808 : for (i=0; i<c_LAST; i++) gp_colors[i] = c_NONE;
823 1851 : }
824 :
825 : /*********************************************************************/
826 : /* FUNCTION HASHTABLES, MODULES */
827 : /*********************************************************************/
828 : extern entree functions_basic[], functions_default[];
829 : static void
830 1851 : pari_init_functions(void)
831 : {
832 1851 : pari_stack_init(&s_MODULES, sizeof(*MODULES),(void**)&MODULES);
833 1851 : pari_stack_pushp(&s_MODULES,functions_basic);
834 1851 : functions_hash = (entree**) pari_calloc(sizeof(entree*)*functions_tblsz);
835 1851 : pari_fill_hashtable(functions_hash, functions_basic);
836 1851 : defaults_hash = (entree**) pari_calloc(sizeof(entree*)*functions_tblsz);
837 1851 : pari_add_defaults_module(functions_default);
838 1851 : }
839 :
840 : void
841 1841 : pari_add_module(entree *ep)
842 : {
843 1841 : pari_fill_hashtable(functions_hash, ep);
844 1841 : pari_stack_pushp(&s_MODULES, ep);
845 1841 : }
846 :
847 : void
848 1851 : pari_add_defaults_module(entree *ep)
849 1851 : { pari_fill_hashtable(defaults_hash, ep); }
850 :
851 : /*********************************************************************/
852 : /* PARI MAIN STACK */
853 : /*********************************************************************/
854 :
855 : #ifdef HAS_MMAP
856 : #define PARI_STACK_ALIGN (sysconf(_SC_PAGE_SIZE))
857 : #ifndef MAP_ANONYMOUS
858 : #define MAP_ANONYMOUS MAP_ANON
859 : #endif
860 : #ifndef MAP_NORESERVE
861 : #define MAP_NORESERVE 0
862 : #endif
863 : static void *
864 324888 : pari_mainstack_malloc(size_t size)
865 : {
866 : void *b;
867 : /* Check that the system allows reserving "size" bytes. This is just
868 : * a check, we immediately free the memory. */
869 324888 : BLOCK_SIGINT_START;
870 324888 : b = mmap(NULL, size, PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, -1, 0);
871 324888 : BLOCK_SIGINT_END;
872 324888 : if (b == MAP_FAILED) return NULL;
873 324888 : BLOCK_SIGINT_START;
874 324888 : munmap(b, size);
875 :
876 : /* Map again, this time with MAP_NORESERVE. On some operating systems
877 : * like Cygwin, this is needed because remapping with PROT_NONE and
878 : * MAP_NORESERVE does not work as expected. */
879 324888 : b = mmap(NULL, size, PROT_READ|PROT_WRITE,
880 : MAP_PRIVATE|MAP_ANONYMOUS|MAP_NORESERVE, -1, 0);
881 324888 : BLOCK_SIGINT_END;
882 324888 : if (b == MAP_FAILED) return NULL;
883 324888 : return b;
884 : }
885 :
886 : static void
887 324878 : pari_mainstack_mfree(void *s, size_t size)
888 : {
889 324878 : BLOCK_SIGINT_START;
890 324878 : munmap(s, size);
891 324878 : BLOCK_SIGINT_END;
892 324878 : }
893 :
894 : /* Completely discard the memory mapped between the addresses "from"
895 : * and "to" (which must be page-aligned).
896 : *
897 : * We use mmap() with PROT_NONE, which means that the underlying memory
898 : * is freed and that the kernel should not commit memory for it. We
899 : * still keep the mapping such that we can change the flags to
900 : * PROT_READ|PROT_WRITE later.
901 : *
902 : * NOTE: remapping with MAP_FIXED and PROT_NONE is not the same as
903 : * calling mprotect(..., PROT_NONE) because the latter will keep the
904 : * memory committed (this is in particular relevant on Linux with
905 : * vm.overcommit = 2). This remains true even when calling
906 : * madvise(..., MADV_DONTNEED). */
907 : static void
908 438382 : pari_mainstack_mreset(pari_sp from, pari_sp to)
909 : {
910 438382 : size_t s = to - from;
911 : void *addr, *res;
912 438382 : if (!s) return;
913 :
914 21 : addr = (void*)from;
915 21 : BLOCK_SIGINT_START;
916 21 : res = mmap(addr, s, PROT_NONE,
917 : MAP_FIXED|MAP_PRIVATE|MAP_ANONYMOUS|MAP_NORESERVE, -1, 0);
918 21 : BLOCK_SIGINT_END;
919 21 : if (res != addr) pari_err(e_MEM);
920 : }
921 :
922 : /* Commit (make available) the virtual memory mapped between the
923 : * addresses "from" and "to" (which must be page-aligned).
924 : * Return 0 if successful, -1 if failed. */
925 : static int
926 438382 : pari_mainstack_mextend(pari_sp from, pari_sp to)
927 : {
928 438382 : size_t s = to - from;
929 : int ret;
930 438382 : BLOCK_SIGINT_START;
931 438382 : ret = mprotect((void*)from, s, PROT_READ|PROT_WRITE);
932 438382 : BLOCK_SIGINT_END;
933 438382 : return ret;
934 : }
935 :
936 : /* Set actual stack size to the given size. This sets st->size and
937 : * st->bot. If not enough system memory is available, this can fail.
938 : * Return 1 if successful, 0 if failed (in that case, st->size is not
939 : * changed) */
940 : static int
941 438382 : pari_mainstack_setsize(struct pari_mainstack *st, size_t size)
942 : {
943 438382 : pari_sp newbot = st->top - size;
944 : /* Align newbot to pagesize */
945 438382 : pari_sp alignbot = newbot & ~(pari_sp)(PARI_STACK_ALIGN - 1);
946 438382 : if (pari_mainstack_mextend(alignbot, st->top))
947 : {
948 : /* Making the memory available did not work: limit vsize to the
949 : * current actual stack size. */
950 0 : st->vsize = st->size;
951 0 : pari_warn(warnstack, st->vsize);
952 0 : return 0;
953 : }
954 438382 : pari_mainstack_mreset(st->vbot, alignbot);
955 438382 : st->bot = newbot;
956 438382 : st->size = size;
957 438382 : return 1;
958 : }
959 :
960 : #else
961 : #define PARI_STACK_ALIGN (0x40UL)
962 : static void *
963 : pari_mainstack_malloc(size_t s)
964 : {
965 : char * tmp;
966 : BLOCK_SIGINT_START;
967 : tmp = malloc(s); /* NOT pari_malloc, e_MEM would be deadly */
968 : BLOCK_SIGINT_END;
969 : return tmp;
970 : }
971 :
972 : static void
973 : pari_mainstack_mfree(void *s, size_t size) { (void) size; pari_free(s); }
974 :
975 : static int
976 : pari_mainstack_setsize(struct pari_mainstack *st, size_t size)
977 : {
978 : st->bot = st->top - size;
979 : st->size = size;
980 : return 1;
981 : }
982 :
983 : #endif
984 :
985 : static const size_t MIN_STACK = 500032UL;
986 : static size_t
987 649766 : fix_size(size_t a)
988 : {
989 649766 : size_t ps = PARI_STACK_ALIGN;
990 649766 : size_t b = a & ~(ps - 1); /* Align */
991 649766 : if (b < a && b < ~(ps - 1)) b += ps;
992 649766 : if (b < MIN_STACK) b = MIN_STACK;
993 649766 : return b;
994 : }
995 :
996 : static void
997 324888 : pari_mainstack_alloc(int numerr, struct pari_mainstack *st, size_t rsize, size_t vsize)
998 : {
999 324888 : size_t sizemax = vsize ? vsize: rsize, s = fix_size(sizemax);
1000 : for (;;)
1001 : {
1002 324888 : st->vbot = (pari_sp)pari_mainstack_malloc(s);
1003 324888 : if (st->vbot) break;
1004 0 : if (s == MIN_STACK) pari_err(e_MEM); /* no way out. Die */
1005 0 : s = fix_size(s >> 1);
1006 0 : pari_warn(numerr, s);
1007 : }
1008 324888 : st->vsize = vsize ? s: 0;
1009 324888 : st->rsize = minuu(rsize, s);
1010 324888 : st->top = st->vbot+s;
1011 324888 : if (!pari_mainstack_setsize(st, st->rsize))
1012 : {
1013 : /* This should never happen since we only decrease the allocated space */
1014 0 : pari_err(e_MEM);
1015 : }
1016 324888 : st->memused = 0;
1017 324888 : }
1018 :
1019 : static void
1020 324878 : pari_mainstack_free(struct pari_mainstack *st)
1021 : {
1022 324878 : pari_mainstack_mfree((void*)st->vbot, st->vsize ? st->vsize : fix_size(st->rsize));
1023 324878 : st->top = st->bot = st->vbot = 0;
1024 324878 : st->size = st->vsize = 0;
1025 324878 : }
1026 :
1027 : static void
1028 424 : pari_mainstack_resize(struct pari_mainstack *st, size_t rsize, size_t vsize)
1029 : {
1030 424 : BLOCK_SIGINT_START;
1031 424 : pari_mainstack_free(st);
1032 424 : pari_mainstack_alloc(warnstack, st, rsize, vsize);
1033 424 : BLOCK_SIGINT_END;
1034 424 : }
1035 :
1036 : static void
1037 324454 : pari_mainstack_use(struct pari_mainstack *st)
1038 : {
1039 324454 : pari_mainstack = st;
1040 324454 : avma = st->top; /* don't use set_avma */
1041 324454 : }
1042 :
1043 : static void
1044 1851 : paristack_alloc(size_t rsize, size_t vsize)
1045 : {
1046 1851 : pari_mainstack_alloc(warnstack, pari_mainstack, rsize, vsize);
1047 1851 : pari_mainstack_use(pari_mainstack);
1048 1851 : }
1049 :
1050 : void
1051 0 : paristack_setsize(size_t rsize, size_t vsize)
1052 : {
1053 0 : pari_mainstack_resize(pari_mainstack, rsize, vsize);
1054 0 : pari_mainstack_use(pari_mainstack);
1055 0 : }
1056 :
1057 : void
1058 0 : parivstack_resize(ulong newsize)
1059 : {
1060 : size_t s;
1061 0 : if (newsize && newsize < pari_mainstack->rsize)
1062 0 : pari_err_DIM("stack sizes [parisizemax < parisize]");
1063 0 : if (newsize == pari_mainstack->vsize) return;
1064 0 : evalstate_reset();
1065 0 : paristack_setsize(pari_mainstack->rsize, newsize);
1066 0 : s = pari_mainstack->vsize ? pari_mainstack->vsize : pari_mainstack->rsize;
1067 0 : if (DEBUGMEM)
1068 0 : pari_warn(warner,"new maximum stack size = %lu (%.3f Mbytes)",
1069 : s, s/1048576.);
1070 0 : pari_init_errcatch();
1071 0 : cb_pari_err_recover(-1);
1072 : }
1073 :
1074 : void
1075 431 : paristack_newrsize(ulong newsize)
1076 : {
1077 431 : size_t s, vsize = pari_mainstack->vsize;
1078 431 : if (!newsize) newsize = pari_mainstack->rsize << 1;
1079 431 : if (newsize != pari_mainstack->rsize)
1080 424 : pari_mainstack_resize(pari_mainstack, newsize, vsize);
1081 431 : evalstate_reset();
1082 431 : s = pari_mainstack->rsize;
1083 431 : if (DEBUGMEM)
1084 431 : pari_warn(warner,"new stack size = %lu (%.3f Mbytes)", s, s/1048576.);
1085 431 : pari_init_errcatch();
1086 431 : cb_pari_err_recover(-1);
1087 0 : }
1088 :
1089 : void
1090 0 : paristack_resize(ulong newsize)
1091 : {
1092 0 : long size = pari_mainstack->size;
1093 0 : if (!newsize)
1094 0 : newsize = 2 * size;
1095 0 : newsize = minuu(newsize, pari_mainstack->vsize);
1096 0 : if (newsize <= pari_mainstack->size) return;
1097 0 : if (pari_mainstack_setsize(pari_mainstack, newsize))
1098 : {
1099 0 : if (DEBUGMEM)
1100 0 : pari_warn(warner, "increasing stack size to %lu", pari_mainstack->size);
1101 : }
1102 : else
1103 : {
1104 0 : pari_mainstack_setsize(pari_mainstack, size);
1105 0 : pari_err(e_STACK);
1106 : }
1107 : }
1108 :
1109 : void
1110 113494 : parivstack_reset(void)
1111 : {
1112 113494 : pari_mainstack_setsize(pari_mainstack, pari_mainstack->rsize);
1113 113494 : if (avma < pari_mainstack->bot)
1114 0 : pari_err_BUG("parivstack_reset [avma < bot]");
1115 113494 : }
1116 :
1117 : /* Enlarge the stack if needed such that the unused portion of the stack
1118 : * (between bot and avma) is large enough to contain x longs. */
1119 : void
1120 14 : new_chunk_resize(size_t x)
1121 : {
1122 14 : if (pari_mainstack->vsize==0
1123 14 : || x > (avma-pari_mainstack->vbot) / sizeof(long)) pari_err(e_STACK);
1124 0 : while (x > (avma-pari_mainstack->bot) / sizeof(long))
1125 0 : paristack_resize(0);
1126 0 : }
1127 :
1128 : /*********************************************************************/
1129 : /* PARI THREAD */
1130 : /*********************************************************************/
1131 :
1132 : /* Initial PARI thread structure t with a stack of size s and
1133 : * argument arg */
1134 :
1135 : static void
1136 322334 : pari_thread_set_global(struct pari_global_state *gs)
1137 : {
1138 322334 : setdebugvar(gs->debugvar);
1139 322329 : push_localbitprec(gs->bitprec);
1140 322413 : pari_set_primetab(gs->primetab);
1141 322406 : pari_set_seadata(gs->seadata);
1142 322379 : pari_set_varstate(gs->varpriority, &gs->varstate);
1143 320148 : }
1144 :
1145 : static void
1146 322613 : pari_thread_get_global(struct pari_global_state *gs)
1147 : {
1148 322613 : gs->debugvar = getdebugvar();
1149 322613 : gs->bitprec = get_localbitprec();
1150 322613 : gs->primetab = primetab;
1151 322613 : gs->seadata = pari_get_seadata();
1152 322613 : varstate_save(&gs->varstate);
1153 322613 : gs->varpriority = varpriority;
1154 322613 : }
1155 :
1156 : void
1157 322613 : pari_thread_alloc(struct pari_thread *t, size_t s, GEN arg)
1158 : {
1159 322613 : pari_mainstack_alloc(warnstackthread, &t->st,s,0);
1160 322613 : pari_thread_get_global(&t->gs);
1161 322613 : t->data = arg;
1162 322613 : }
1163 :
1164 : /* Initial PARI thread structure t with a stack of size s and virtual size v
1165 : * and argument arg */
1166 :
1167 : void
1168 0 : pari_thread_valloc(struct pari_thread *t, size_t s, size_t v, GEN arg)
1169 : {
1170 0 : pari_mainstack_alloc(warnstackthread, &t->st,s,v);
1171 0 : pari_thread_get_global(&t->gs);
1172 0 : t->data = arg;
1173 0 : }
1174 :
1175 : void
1176 322613 : pari_thread_free(struct pari_thread *t)
1177 : {
1178 322613 : pari_mainstack_free(&t->st);
1179 322613 : }
1180 :
1181 : void
1182 324449 : pari_thread_init(void)
1183 : {
1184 : long var;
1185 324449 : pari_stackcheck_init((void*)&var);
1186 324445 : pari_init_blocks();
1187 324429 : pari_init_errcatch();
1188 324423 : pari_init_rand();
1189 324364 : pari_init_floats();
1190 324372 : pari_init_hgm();
1191 324383 : pari_init_parser();
1192 324338 : pari_init_compiler();
1193 324253 : pari_init_evaluator();
1194 324208 : pari_init_files();
1195 324218 : pari_init_ellcondfile();
1196 324202 : }
1197 :
1198 : void
1199 322830 : pari_thread_close(void)
1200 : {
1201 322830 : pari_thread_close_files();
1202 318229 : pari_close_evaluator();
1203 322561 : pari_close_compiler();
1204 317568 : pari_close_parser();
1205 322314 : pari_close_floats();
1206 317614 : pari_close_hgm();
1207 316522 : pari_close_blocks();
1208 321841 : }
1209 :
1210 : GEN
1211 322606 : pari_thread_start(struct pari_thread *t)
1212 : {
1213 322606 : pari_mainstack_use(&t->st);
1214 322600 : pari_thread_init();
1215 322340 : pari_thread_set_global(&t->gs);
1216 320232 : mt_thread_init();
1217 320171 : return t->data;
1218 : }
1219 :
1220 : /*********************************************************************/
1221 : /* LIBPARI INIT / CLOSE */
1222 : /*********************************************************************/
1223 :
1224 : static void
1225 0 : pari_exit(void)
1226 : {
1227 0 : err_printf(" *** Error in the PARI system. End of program.\n");
1228 0 : exit(1);
1229 : }
1230 :
1231 : static void
1232 0 : dflt_err_recover(long errnum) { (void) errnum; pari_exit(); }
1233 :
1234 : static void
1235 0 : dflt_pari_quit(long err) { (void)err; /*do nothing*/; }
1236 :
1237 : /* initialize PARI data. Initialize [new|old]fun to NULL for default set. */
1238 : void
1239 1851 : pari_init_opts(size_t parisize, ulong maxprime, ulong init_opts)
1240 : {
1241 : ulong u;
1242 :
1243 1851 : pari_mt_nbthreads = 0;
1244 1851 : cb_pari_quit = dflt_pari_quit;
1245 1851 : cb_pari_init_histfile = NULL;
1246 1851 : cb_pari_get_line_interactive = NULL;
1247 1851 : cb_pari_fgets_interactive = NULL;
1248 1851 : cb_pari_whatnow = NULL;
1249 1851 : cb_pari_handle_exception = NULL;
1250 1851 : cb_pari_err_handle = pari_err_display;
1251 1851 : cb_pari_pre_recover = NULL;
1252 1851 : cb_pari_break_loop = NULL;
1253 1851 : cb_pari_is_interactive = NULL;
1254 1851 : cb_pari_start_output = NULL;
1255 1851 : cb_pari_sigint = dflt_sigint_fun;
1256 1851 : cb_pari_long_help = NULL;
1257 1851 : if (init_opts&INIT_JMPm) cb_pari_err_recover = dflt_err_recover;
1258 :
1259 1851 : pari_stackcheck_init(&u);
1260 1851 : pari_init_homedir();
1261 1851 : if (init_opts&INIT_DFTm) {
1262 0 : pari_init_defaults();
1263 0 : GP_DATA = default_gp_data();
1264 0 : pari_init_paths();
1265 : }
1266 :
1267 1851 : pari_mainstack = (struct pari_mainstack *) malloc(sizeof(*pari_mainstack));
1268 1851 : paristack_alloc(parisize, 0);
1269 1851 : init_universal_constants();
1270 1851 : pari_PRIMES = NULL;
1271 1851 : if (!(init_opts&INIT_noPRIMEm))
1272 : {
1273 0 : GP_DATA->primelimit = maxprime;
1274 0 : pari_init_primes(GP_DATA->primelimit);
1275 : }
1276 1851 : if (!(init_opts&INIT_noINTGMPm)) pari_kernel_init();
1277 1851 : pari_init_graphics();
1278 1851 : pari_thread_init();
1279 1851 : pari_set_primetab(NULL);
1280 1851 : pari_set_seadata(NULL);
1281 1851 : pari_init_functions();
1282 1851 : pari_init_export();
1283 1851 : pari_var_init();
1284 1851 : pari_init_timer();
1285 1851 : pari_init_buffers();
1286 1851 : (void)getabstime();
1287 1851 : try_to_recover = 1;
1288 1851 : if (!(init_opts&INIT_noIMTm)) pari_mt_init();
1289 1851 : if ((init_opts&INIT_SIGm)) pari_sig_init(pari_sighandler);
1290 1851 : }
1291 :
1292 : void
1293 0 : pari_init(size_t parisize, ulong maxprime)
1294 0 : { pari_init_opts(parisize, maxprime, INIT_JMPm | INIT_SIGm | INIT_DFTm); }
1295 :
1296 : void
1297 1841 : pari_close_opts(ulong init_opts)
1298 : {
1299 : long i;
1300 :
1301 1841 : BLOCK_SIGINT_START;
1302 1841 : if ((init_opts&INIT_SIGm)) pari_sig_init(SIG_DFL);
1303 1841 : if (!(init_opts&INIT_noIMTm)) pari_mt_close();
1304 :
1305 1841 : pari_var_close(); /* must come before destruction of functions_hash */
1306 250376 : for (i = 0; i < functions_tblsz; i++)
1307 : {
1308 248535 : entree *ep = functions_hash[i];
1309 2782887 : while (ep) {
1310 2534352 : entree *EP = ep->next;
1311 2534352 : if (!EpSTATIC(ep)) { freeep(ep); free(ep); }
1312 2534352 : ep = EP;
1313 : }
1314 : }
1315 1841 : pari_close_mf();
1316 1841 : pari_thread_close();
1317 1841 : pari_close_export();
1318 1841 : pari_close_files();
1319 1841 : pari_close_homedir();
1320 1841 : if (!(init_opts&INIT_noINTGMPm)) pari_kernel_close();
1321 :
1322 1841 : free((void*)functions_hash);
1323 1841 : free((void*)defaults_hash);
1324 1841 : if (pari_PRIMES) pari_close_primes();
1325 1841 : free(current_logfile);
1326 1841 : free(current_psfile);
1327 1841 : pari_mainstack_free(pari_mainstack);
1328 1841 : free((void*)pari_mainstack);
1329 1841 : pari_stack_delete(&s_MODULES);
1330 1841 : if (pari_datadir) free(pari_datadir);
1331 1841 : if (init_opts&INIT_DFTm)
1332 : { /* delete GP_DATA */
1333 1841 : pari_close_paths();
1334 1841 : if (GP_DATA->hist->v) free((void*)GP_DATA->hist->v);
1335 1841 : if (GP_DATA->pp->cmd) free((void*)GP_DATA->pp->cmd);
1336 1841 : if (GP_DATA->help) free((void*)GP_DATA->help);
1337 1841 : if (GP_DATA->plothsizes) free((void*)GP_DATA->plothsizes);
1338 1841 : if (GP_DATA->colormap) pari_free(GP_DATA->colormap);
1339 1841 : if (GP_DATA->graphcolors) pari_free(GP_DATA->graphcolors);
1340 1841 : free((void*)GP_DATA->prompt);
1341 1841 : free((void*)GP_DATA->prompt_cont);
1342 1841 : free((void*)GP_DATA->histfile);
1343 : }
1344 1841 : BLOCK_SIGINT_END;
1345 1841 : }
1346 :
1347 : void
1348 1841 : pari_close(void)
1349 1841 : { pari_close_opts(INIT_JMPm | INIT_SIGm | INIT_DFTm); }
1350 :
1351 : /*******************************************************************/
1352 : /* */
1353 : /* ERROR RECOVERY */
1354 : /* */
1355 : /*******************************************************************/
1356 : void
1357 136711 : gp_context_save(struct gp_context* rec)
1358 : {
1359 136711 : rec->prettyp = GP_DATA->fmt->prettyp;
1360 136711 : rec->listloc = next_block;
1361 136711 : rec->iferr_env = iferr_env;
1362 136711 : rec->err_data = global_err_data;
1363 136711 : varstate_save(&rec->var);
1364 136711 : evalstate_save(&rec->eval);
1365 136711 : parsestate_save(&rec->parse);
1366 136711 : filestate_save(&rec->file);
1367 136711 : }
1368 :
1369 : void
1370 12354 : gp_context_restore(struct gp_context* rec)
1371 : {
1372 : long i;
1373 :
1374 12354 : if (!try_to_recover) return;
1375 : /* disable gp_context_restore() and SIGINT */
1376 12354 : try_to_recover = 0;
1377 12354 : BLOCK_SIGINT_START
1378 12354 : if (DEBUGMEM>2) err_printf("entering recover(), loc = %ld\n", rec->listloc);
1379 12354 : evalstate_restore(&rec->eval);
1380 12354 : parsestate_restore(&rec->parse);
1381 12354 : filestate_restore(&rec->file);
1382 12354 : global_err_data = rec->err_data;
1383 12354 : iferr_env = rec->iferr_env;
1384 12354 : GP_DATA->fmt->prettyp = rec->prettyp;
1385 :
1386 1680144 : for (i = 0; i < functions_tblsz; i++)
1387 : {
1388 1667790 : entree *ep = functions_hash[i];
1389 19477803 : while (ep)
1390 : {
1391 17810013 : entree *EP = ep->next;
1392 17810013 : switch(EpVALENCE(ep))
1393 : {
1394 347713 : case EpVAR:
1395 348182 : while (pop_val_if_newer(ep,rec->listloc)) /* empty */;
1396 347713 : break;
1397 685556 : case EpNEW: break;
1398 : }
1399 17810013 : ep = EP;
1400 : }
1401 : }
1402 12354 : varstate_restore(&rec->var);
1403 12354 : if (DEBUGMEM>2) err_printf("leaving recover()\n");
1404 12354 : BLOCK_SIGINT_END
1405 12354 : try_to_recover = 1;
1406 : }
1407 :
1408 : static void
1409 12279 : err_recover(long numerr)
1410 : {
1411 12279 : if (cb_pari_pre_recover)
1412 12279 : cb_pari_pre_recover(numerr);
1413 0 : evalstate_reset();
1414 0 : killallfiles();
1415 0 : pari_init_errcatch();
1416 0 : cb_pari_err_recover(numerr);
1417 0 : }
1418 :
1419 : static void
1420 13046 : err_init(void)
1421 : {
1422 : /* make sure pari_err msg starts at the beginning of line */
1423 13046 : if (!pari_last_was_newline()) pari_putc('\n');
1424 13046 : pariOut->flush();
1425 13046 : pariErr->flush();
1426 13046 : out_term_color(pariErr, c_ERR);
1427 13046 : }
1428 :
1429 : static void
1430 12906 : err_init_msg(int user)
1431 : {
1432 : const char *gp_function_name;
1433 12906 : out_puts(pariErr, " *** ");
1434 12906 : if (!user && (gp_function_name = closure_func_err()))
1435 9242 : out_printf(pariErr, "%s: ", gp_function_name);
1436 : else
1437 3664 : out_puts(pariErr, " ");
1438 12906 : }
1439 :
1440 : void
1441 746 : pari_warn(int numerr, ...)
1442 : {
1443 : char *ch1;
1444 : va_list ap;
1445 :
1446 746 : va_start(ap,numerr);
1447 :
1448 746 : err_init();
1449 746 : err_init_msg(numerr==warnuser || numerr==warnstack);
1450 746 : switch (numerr)
1451 : {
1452 7 : case warnuser:
1453 7 : out_puts(pariErr, "user warning: ");
1454 7 : out_print1(pariErr, NULL, va_arg(ap, GEN), f_RAW);
1455 7 : break;
1456 :
1457 0 : case warnmem:
1458 0 : out_puts(pariErr, "collecting garbage in "); ch1=va_arg(ap, char*);
1459 0 : out_vprintf(pariErr, ch1,ap); out_putc(pariErr, '.');
1460 0 : break;
1461 :
1462 739 : case warner:
1463 739 : out_puts(pariErr, "Warning: "); ch1=va_arg(ap, char*);
1464 739 : out_vprintf(pariErr, ch1,ap); out_putc(pariErr, '.');
1465 739 : break;
1466 :
1467 0 : case warnprec:
1468 0 : out_vprintf(pariErr, "Warning: increasing prec in %s; new prec = %ld",
1469 : ap);
1470 0 : break;
1471 :
1472 0 : case warnfile:
1473 0 : out_puts(pariErr, "Warning: failed to "),
1474 0 : ch1 = va_arg(ap, char*);
1475 0 : out_printf(pariErr, "%s: %s", ch1, va_arg(ap, char*));
1476 0 : break;
1477 :
1478 0 : case warnstack:
1479 : case warnstackthread:
1480 : {
1481 0 : ulong s = va_arg(ap, ulong);
1482 : char buf[128];
1483 0 : const char * stk = numerr == warnstackthread
1484 0 : || mt_is_thread() ? "thread": "PARI";
1485 0 : sprintf(buf,"Warning: not enough memory, new %s stack %lu", stk, s);
1486 0 : out_puts(pariErr,buf);
1487 0 : break;
1488 : }
1489 : }
1490 746 : va_end(ap);
1491 746 : out_term_color(pariErr, c_NONE);
1492 746 : out_putc(pariErr, '\n');
1493 746 : pariErr->flush();
1494 746 : }
1495 : void
1496 0 : pari_sigint(const char *time_s)
1497 : {
1498 0 : int recover=0;
1499 0 : BLOCK_SIGALRM_START
1500 0 : err_init();
1501 0 : mt_break_recover();
1502 0 : closure_err(0);
1503 0 : err_init_msg(0);
1504 0 : out_puts(pariErr, "user interrupt after ");
1505 0 : out_puts(pariErr, time_s);
1506 0 : out_term_color(pariErr, c_NONE);
1507 0 : pariErr->flush();
1508 0 : if (cb_pari_handle_exception)
1509 0 : recover = cb_pari_handle_exception(-1);
1510 0 : if (!recover && !block)
1511 0 : PARI_SIGINT_pending = 0;
1512 0 : BLOCK_SIGINT_END
1513 0 : if (!recover) err_recover(e_MISC);
1514 0 : }
1515 :
1516 : #define retmkerr2(x,y)\
1517 : do { GEN _v = cgetg(3, t_ERROR);\
1518 : _v[1] = (x);\
1519 : gel(_v,2) = (y); return _v; } while(0)
1520 : #define retmkerr3(x,y,z)\
1521 : do { GEN _v = cgetg(4, t_ERROR);\
1522 : _v[1] = (x);\
1523 : gel(_v,2) = (y);\
1524 : gel(_v,3) = (z); return _v; } while(0)
1525 : #define retmkerr4(x,y,z,t)\
1526 : do { GEN _v = cgetg(5, t_ERROR);\
1527 : _v[1] = (x);\
1528 : gel(_v,2) = (y);\
1529 : gel(_v,3) = (z);\
1530 : gel(_v,4) = (t); return _v; } while(0)
1531 : #define retmkerr5(x,y,z,t,u)\
1532 : do { GEN _v = cgetg(6, t_ERROR);\
1533 : _v[1] = (x);\
1534 : gel(_v,2) = (y);\
1535 : gel(_v,3) = (z);\
1536 : gel(_v,4) = (t);\
1537 : gel(_v,5) = (u); return _v; } while(0)
1538 : #define retmkerr6(x,y,z,t,u,v)\
1539 : do { GEN _v = cgetg(7, t_ERROR);\
1540 : _v[1] = (x);\
1541 : gel(_v,2) = (y);\
1542 : gel(_v,3) = (z);\
1543 : gel(_v,4) = (t);\
1544 : gel(_v,5) = (u);\
1545 : gel(_v,6) = (v); return _v; } while(0)
1546 :
1547 : static GEN
1548 48976 : pari_err2GEN(long numerr, va_list ap)
1549 : {
1550 48976 : switch ((enum err_list) numerr)
1551 : {
1552 140 : case e_SYNTAX:
1553 : {
1554 140 : const char *msg = va_arg(ap, char*);
1555 140 : const char *s = va_arg(ap,char *);
1556 140 : const char *entry = va_arg(ap,char *);
1557 140 : retmkerr3(numerr,strtoGENstr(msg), mkvecsmall2((long)s,(long)entry));
1558 : }
1559 355 : case e_MISC: case e_ALARM:
1560 : {
1561 355 : const char *ch1 = va_arg(ap, char*);
1562 355 : retmkerr2(numerr, gvsprintf(ch1,ap));
1563 : }
1564 2723 : case e_NOTFUNC:
1565 : case e_USER:
1566 2723 : retmkerr2(numerr,va_arg(ap, GEN));
1567 0 : case e_FILE:
1568 : {
1569 0 : const char *f = va_arg(ap, const char*);
1570 0 : retmkerr3(numerr, strtoGENstr(f), strtoGENstr(va_arg(ap, char*)));
1571 : }
1572 36 : case e_FILEDESC:
1573 : {
1574 36 : const char *f = va_arg(ap, const char*);
1575 36 : retmkerr3(numerr, strtoGENstr(f), stoi(va_arg(ap, long)));
1576 : }
1577 1805 : case e_OVERFLOW:
1578 : case e_IMPL:
1579 : case e_DIM:
1580 : case e_CONSTPOL:
1581 : case e_ROOTS0:
1582 : case e_FLAG:
1583 : case e_PREC:
1584 : case e_BUG:
1585 : case e_ARCH:
1586 : case e_PACKAGE:
1587 1805 : retmkerr2(numerr, strtoGENstr(va_arg(ap, char*)));
1588 1680 : case e_MODULUS:
1589 : case e_VAR:
1590 : {
1591 1680 : const char *f = va_arg(ap, const char*);
1592 1680 : GEN x = va_arg(ap, GEN);
1593 1680 : GEN y = va_arg(ap, GEN);
1594 1680 : retmkerr4(numerr, strtoGENstr(f), x,y);
1595 : }
1596 35038 : case e_INV:
1597 : case e_IRREDPOL:
1598 : case e_PRIME:
1599 : case e_SQRTN:
1600 : case e_TYPE:
1601 : {
1602 35038 : const char *f = va_arg(ap, const char*);
1603 35038 : GEN x = va_arg(ap, GEN);
1604 35038 : retmkerr3(numerr, strtoGENstr(f), x);
1605 : }
1606 3990 : case e_COPRIME: case e_OP: case e_TYPE2:
1607 : {
1608 3990 : const char *f = va_arg(ap, const char*);
1609 3990 : GEN x = va_arg(ap, GEN);
1610 3990 : GEN y = va_arg(ap, GEN);
1611 3990 : retmkerr4(numerr,strtoGENstr(f),x,y);
1612 : }
1613 214 : case e_COMPONENT:
1614 : {
1615 214 : const char *f= va_arg(ap, const char *);
1616 214 : const char *op = va_arg(ap, const char *);
1617 214 : GEN l = va_arg(ap, GEN);
1618 214 : GEN x = va_arg(ap, GEN);
1619 214 : retmkerr5(numerr,strtoGENstr(f),strtoGENstr(op),l,x);
1620 : }
1621 2736 : case e_DOMAIN:
1622 : {
1623 2736 : const char *f = va_arg(ap, const char*);
1624 2736 : const char *v = va_arg(ap, const char *);
1625 2736 : const char *op = va_arg(ap, const char *);
1626 2736 : GEN l = va_arg(ap, GEN);
1627 2736 : GEN x = va_arg(ap, GEN);
1628 2736 : retmkerr6(numerr,strtoGENstr(f),strtoGENstr(v),strtoGENstr(op),l,x);
1629 : }
1630 245 : case e_PRIORITY:
1631 : {
1632 245 : const char *f = va_arg(ap, const char*);
1633 245 : GEN x = va_arg(ap, GEN);
1634 245 : const char *op = va_arg(ap, const char *);
1635 245 : long v = va_arg(ap, long);
1636 245 : retmkerr5(numerr,strtoGENstr(f),x,strtoGENstr(op),stoi(v));
1637 : }
1638 0 : case e_MAXPRIME:
1639 0 : retmkerr2(numerr, utoi(va_arg(ap, ulong)));
1640 14 : case e_STACK:
1641 14 : return err_e_STACK;
1642 0 : case e_STACKTHREAD:
1643 0 : retmkerr3(numerr, utoi(va_arg(ap, ulong)), utoi(va_arg(ap, ulong)));
1644 0 : default:
1645 0 : return mkerr(numerr);
1646 : }
1647 : }
1648 :
1649 : static char *
1650 7322 : type_dim(GEN x)
1651 : {
1652 7322 : char *v = stack_malloc(64);
1653 7322 : switch(typ(x))
1654 : {
1655 133 : case t_MAT:
1656 : {
1657 133 : long l = lg(x), r = (l == 1)? 1: lgcols(x);
1658 133 : sprintf(v, "t_MAT (%ld x %ld)", r-1,l-1);
1659 133 : break;
1660 : }
1661 133 : case t_COL:
1662 133 : sprintf(v, "t_COL (%ld elts)", lg(x)-1);
1663 133 : break;
1664 259 : case t_VEC:
1665 259 : sprintf(v, "t_VEC (%ld elts)", lg(x)-1);
1666 259 : break;
1667 6797 : default:
1668 6797 : v = (char*)type_name(typ(x));
1669 : }
1670 7322 : return v;
1671 : }
1672 :
1673 : static char *
1674 3682 : gdisplay(GEN x)
1675 : {
1676 3682 : char *s = GENtostr_raw(x);
1677 3682 : if (strlen(s) < 1600) return s;
1678 35 : if (! GP_DATA->breakloop) return (char*)"(...)";
1679 0 : return stack_sprintf("\n *** (...) Huge %s omitted; you can access it via dbg_err()", type_name(typ(x)));
1680 : }
1681 :
1682 : char *
1683 21078 : pari_err2str(GEN e)
1684 : {
1685 21078 : long numerr = err_get_num(e);
1686 21078 : switch ((enum err_list) numerr)
1687 : {
1688 0 : case e_ALARM:
1689 0 : return pari_sprintf("alarm interrupt after %Ps.",gel(e,2));
1690 343 : case e_MISC:
1691 343 : return pari_sprintf("%Ps.",gel(e,2));
1692 :
1693 0 : case e_ARCH:
1694 0 : return pari_sprintf("sorry, '%Ps' not available on this system.",gel(e,2));
1695 14 : case e_BUG:
1696 14 : return pari_sprintf("bug in %Ps, please report.",gel(e,2));
1697 21 : case e_CONSTPOL:
1698 21 : return pari_sprintf("constant polynomial in %Ps.", gel(e,2));
1699 84 : case e_COPRIME:
1700 252 : return pari_sprintf("elements not coprime in %Ps:\n %s\n %s",
1701 84 : gel(e,2), gdisplay(gel(e,3)), gdisplay(gel(e,4)));
1702 690 : case e_DIM:
1703 690 : return pari_sprintf("inconsistent dimensions in %Ps.", gel(e,2));
1704 0 : case e_FILE:
1705 0 : return pari_sprintf("error opening %Ps: `%Ps'.", gel(e,2), gel(e,3));
1706 36 : case e_FILEDESC:
1707 36 : return pari_sprintf("invalid file descriptor in %Ps [%Ps]", gel(e,2), gel(e,3));
1708 91 : case e_FLAG:
1709 91 : return pari_sprintf("invalid flag in %Ps.", gel(e,2));
1710 469 : case e_IMPL:
1711 469 : return pari_sprintf("sorry, %Ps is not yet implemented.", gel(e,2));
1712 0 : case e_PACKAGE:
1713 0 : return pari_sprintf("package %Ps is required, please install it.", gel(e,2));
1714 637 : case e_INV:
1715 637 : return pari_sprintf("impossible inverse in %Ps: %s.", gel(e,2),
1716 637 : gdisplay(gel(e,3)));
1717 63 : case e_IRREDPOL:
1718 126 : return pari_sprintf("not an irreducible polynomial in %Ps: %s.",
1719 63 : gel(e,2), gdisplay(gel(e,3)));
1720 0 : case e_MAXPRIME:
1721 : {
1722 0 : const char * msg = "not enough precomputed primes";
1723 0 : ulong c = itou(gel(e,2));
1724 0 : if (c) return pari_sprintf("%s, need primelimit ~ %lu.",msg, c);
1725 0 : else return pari_strdup(msg);
1726 : }
1727 0 : case e_MEM:
1728 0 : return pari_strdup("not enough memory");
1729 1316 : case e_MODULUS:
1730 : {
1731 1316 : GEN x = gel(e,3), y = gel(e,4);
1732 1316 : return pari_sprintf("inconsistent moduli in %Ps: %s != %s",
1733 1316 : gel(e,2), gdisplay(x), gdisplay(y));
1734 : }
1735 0 : case e_NONE: return NULL;
1736 2709 : case e_NOTFUNC:
1737 2709 : return pari_strdup("not a function in function call");
1738 3661 : case e_OP: case e_TYPE2:
1739 : {
1740 3661 : pari_sp av = avma;
1741 : char *v;
1742 3661 : const char *f, *op = GSTR(gel(e,2));
1743 3661 : const char *what = numerr == e_OP? "inconsistent": "forbidden";
1744 3661 : GEN x = gel(e,3);
1745 3661 : GEN y = gel(e,4);
1746 3661 : switch(*op)
1747 : {
1748 21 : case '+': f = "addition"; break;
1749 175 : case '*': f = "multiplication"; break;
1750 2744 : case '/': case '%': case '\\': f = "division"; break;
1751 0 : case '=': op = "-->"; f = "assignment"; break;
1752 721 : default: f = op; op = ","; break;
1753 : }
1754 3661 : v = pari_sprintf("%s %s %s %s %s.", what,f,type_dim(x),op,type_dim(y));
1755 3661 : set_avma(av); return v;
1756 : }
1757 214 : case e_COMPONENT:
1758 : {
1759 214 : const char *f= GSTR(gel(e,2));
1760 214 : const char *op= GSTR(gel(e,3));
1761 214 : GEN l = gel(e,4);
1762 214 : if (!*f)
1763 154 : return pari_sprintf("nonexistent component: index %s %Ps",op,l);
1764 60 : return pari_sprintf("nonexistent component in %s: index %s %Ps",f,op,l);
1765 : }
1766 2626 : case e_DOMAIN:
1767 : {
1768 2626 : const char *f = GSTR(gel(e,2));
1769 2626 : const char *v = GSTR(gel(e,3));
1770 2626 : const char *op= GSTR(gel(e,4));
1771 2626 : GEN l = gel(e,5);
1772 2626 : if (!*op)
1773 42 : return pari_sprintf("domain error in %s: %s out of range",f,v);
1774 2584 : return pari_sprintf("domain error in %s: %s %s %Ps",f,v,op,l);
1775 : }
1776 196 : case e_PRIORITY:
1777 : {
1778 196 : const char *f = GSTR(gel(e,2));
1779 196 : long vx = gvar(gel(e,3));
1780 196 : const char *op= GSTR(gel(e,4));
1781 196 : long v = itos(gel(e,5));
1782 196 : return pari_sprintf("incorrect priority in %s: variable %Ps %s %Ps",f,
1783 : pol_x(vx), op, pol_x(v));
1784 : }
1785 161 : case e_OVERFLOW:
1786 161 : return pari_sprintf("overflow in %Ps.", gel(e,2));
1787 231 : case e_PREC:
1788 231 : return pari_sprintf("precision too low in %Ps.", gel(e,2));
1789 98 : case e_PRIME:
1790 196 : return pari_sprintf("not a prime number in %Ps: %s.",
1791 98 : gel(e,2), gdisplay(gel(e,3)));
1792 63 : case e_ROOTS0:
1793 63 : return pari_sprintf("zero polynomial in %Ps.", gel(e,2));
1794 84 : case e_SQRTN:
1795 168 : return pari_sprintf("not an n-th power residue in %Ps: %s.",
1796 84 : gel(e,2), gdisplay(gel(e,3)));
1797 14 : case e_STACK:
1798 : case e_STACKTHREAD:
1799 : {
1800 14 : const char *what = numerr == e_STACK? "PARI": "thread";
1801 14 : const char *var = numerr == e_STACK? "parisizemax": "threadsizemax";
1802 14 : size_t s = numerr == e_STACK? pari_mainstack->vsize: GP_DATA->threadsizemax;
1803 14 : char *hint = (char *) pari_malloc(512*sizeof(char));
1804 14 : char *buf = (char *) pari_malloc(512*sizeof(char));
1805 14 : if (s)
1806 0 : sprintf(hint,"you can increase '%s' using default()", var);
1807 : else
1808 : {
1809 14 : s = (numerr != e_STACK || !GP_DATA->threadsize)? pari_mainstack->rsize
1810 28 : : GP_DATA->threadsize;
1811 14 : sprintf(hint,"set '%s' to a nonzero value in your GPRC", var);
1812 : }
1813 14 : sprintf(buf, "the %s stack overflows !\n"
1814 : " current stack size: %lu (%.3f Mbytes)\n [hint] %s\n",
1815 14 : what, (ulong)s, (double)s/1048576., hint);
1816 14 : return buf;
1817 : }
1818 0 : case e_SYNTAX:
1819 0 : return pari_strdup(GSTR(gel(e,2)));
1820 6879 : case e_TYPE:
1821 13758 : return pari_sprintf("incorrect type in %Ps (%s).",
1822 6879 : gel(e,2), type_name(typ(gel(e,3))));
1823 14 : case e_USER:
1824 14 : return pari_sprint0("user error: ", gel(e,2), f_RAW);
1825 364 : case e_VAR:
1826 : {
1827 364 : GEN x = gel(e,3), y = gel(e,4);
1828 1092 : return pari_sprintf("inconsistent variables in %Ps, %Ps != %Ps.",
1829 364 : gel(e,2), pol_x(varn(x)), pol_x(varn(y)));
1830 : }
1831 : }
1832 : return NULL; /*LCOV_EXCL_LINE*/
1833 : }
1834 :
1835 : int
1836 12300 : pari_err_display(GEN err)
1837 : {
1838 12300 : long numerr=err_get_num(err);
1839 12300 : err_init();
1840 12300 : if (numerr==e_SYNTAX)
1841 : {
1842 140 : const char *msg = GSTR(gel(err,2));
1843 140 : const char *s = (const char *) gmael(err,3,1);
1844 140 : const char *entry = (const char *) gmael(err,3,2);
1845 140 : print_errcontext(pariErr, msg, s, entry);
1846 : }
1847 : else
1848 : {
1849 : char *s;
1850 12160 : closure_err(0);
1851 12160 : err_init_msg(numerr==e_USER);
1852 12160 : s = pari_err2str(err); pariErr->puts(s); pari_free(s);
1853 12160 : if (numerr==e_NOTFUNC)
1854 : {
1855 2709 : GEN fun = gel(err,2);
1856 2709 : if (gequalX(fun))
1857 : {
1858 2709 : entree *ep = varentries[varn(fun)];
1859 2709 : const char *t = ep->name;
1860 2709 : if (cb_pari_whatnow) cb_pari_whatnow(pariErr,t,1);
1861 : }
1862 : }
1863 : }
1864 12286 : out_term_color(pariErr, c_NONE);
1865 12286 : pariErr->flush(); return 0;
1866 : }
1867 :
1868 : void
1869 48995 : pari_err(int numerr, ...)
1870 : {
1871 : va_list ap;
1872 : GEN E;
1873 :
1874 48995 : va_start(ap,numerr);
1875 :
1876 48995 : if (numerr)
1877 48976 : E = pari_err2GEN(numerr,ap);
1878 : else
1879 : {
1880 19 : E = va_arg(ap,GEN);
1881 19 : numerr = err_get_num(E);
1882 : }
1883 48994 : global_err_data = E;
1884 48994 : if (*iferr_env) longjmp(*iferr_env, numerr);
1885 12310 : mt_err_recover(numerr);
1886 12300 : va_end(ap);
1887 24586 : if (cb_pari_err_handle &&
1888 12300 : cb_pari_err_handle(E)) return;
1889 24563 : if (cb_pari_handle_exception &&
1890 12284 : cb_pari_handle_exception(numerr)) return;
1891 12279 : err_recover(numerr);
1892 : }
1893 :
1894 : GEN
1895 73370 : pari_err_last(void) { return global_err_data; }
1896 :
1897 : const char *
1898 27109 : numerr_name(long numerr)
1899 : {
1900 27109 : switch ((enum err_list) numerr)
1901 : {
1902 0 : case e_ALARM: return "e_ALARM";
1903 0 : case e_ARCH: return "e_ARCH";
1904 0 : case e_BUG: return "e_BUG";
1905 0 : case e_COMPONENT: return "e_COMPONENT";
1906 0 : case e_CONSTPOL: return "e_CONSTPOL";
1907 0 : case e_COPRIME: return "e_COPRIME";
1908 0 : case e_DIM: return "e_DIM";
1909 56 : case e_DOMAIN: return "e_DOMAIN";
1910 0 : case e_FILE: return "e_FILE";
1911 0 : case e_FILEDESC: return "e_FILEDESC";
1912 7 : case e_FLAG: return "e_FLAG";
1913 49 : case e_IMPL: return "e_IMPL";
1914 19101 : case e_INV: return "e_INV";
1915 0 : case e_IRREDPOL: return "e_IRREDPOL";
1916 0 : case e_MAXPRIME: return "e_MAXPRIME";
1917 0 : case e_MEM: return "e_MEM";
1918 0 : case e_MISC: return "e_MISC";
1919 0 : case e_MODULUS: return "e_MODULUS";
1920 0 : case e_NONE: return "e_NONE";
1921 0 : case e_NOTFUNC: return "e_NOTFUNC";
1922 0 : case e_OP: return "e_OP";
1923 0 : case e_OVERFLOW: return "e_OVERFLOW";
1924 0 : case e_PACKAGE: return "e_PACKAGE";
1925 0 : case e_PREC: return "e_PREC";
1926 0 : case e_PRIME: return "e_PRIME";
1927 49 : case e_PRIORITY: return "e_PRIORITY";
1928 0 : case e_ROOTS0: return "e_ROOTS0";
1929 0 : case e_SQRTN: return "e_SQRTN";
1930 0 : case e_STACK: return "e_STACK";
1931 0 : case e_SYNTAX: return "e_SYNTAX";
1932 0 : case e_STACKTHREAD: return "e_STACKTHREAD";
1933 0 : case e_TYPE2: return "e_TYPE2";
1934 7847 : case e_TYPE: return "e_TYPE";
1935 0 : case e_USER: return "e_USER";
1936 0 : case e_VAR: return "e_VAR";
1937 : }
1938 0 : return "invalid error number";
1939 : }
1940 :
1941 : long
1942 21 : name_numerr(const char *s)
1943 : {
1944 21 : if (!strcmp(s,"e_ALARM")) return e_ALARM;
1945 21 : if (!strcmp(s,"e_ARCH")) return e_ARCH;
1946 21 : if (!strcmp(s,"e_BUG")) return e_BUG;
1947 21 : if (!strcmp(s,"e_COMPONENT")) return e_COMPONENT;
1948 21 : if (!strcmp(s,"e_CONSTPOL")) return e_CONSTPOL;
1949 21 : if (!strcmp(s,"e_COPRIME")) return e_COPRIME;
1950 21 : if (!strcmp(s,"e_DIM")) return e_DIM;
1951 21 : if (!strcmp(s,"e_DOMAIN")) return e_DOMAIN;
1952 21 : if (!strcmp(s,"e_FILE")) return e_FILE;
1953 21 : if (!strcmp(s,"e_FILEDESC")) return e_FILEDESC;
1954 21 : if (!strcmp(s,"e_FLAG")) return e_FLAG;
1955 21 : if (!strcmp(s,"e_IMPL")) return e_IMPL;
1956 21 : if (!strcmp(s,"e_INV")) return e_INV;
1957 0 : if (!strcmp(s,"e_IRREDPOL")) return e_IRREDPOL;
1958 0 : if (!strcmp(s,"e_MAXPRIME")) return e_MAXPRIME;
1959 0 : if (!strcmp(s,"e_MEM")) return e_MEM;
1960 0 : if (!strcmp(s,"e_MISC")) return e_MISC;
1961 0 : if (!strcmp(s,"e_MODULUS")) return e_MODULUS;
1962 0 : if (!strcmp(s,"e_NONE")) return e_NONE;
1963 0 : if (!strcmp(s,"e_NOTFUNC")) return e_NOTFUNC;
1964 0 : if (!strcmp(s,"e_OP")) return e_OP;
1965 0 : if (!strcmp(s,"e_OVERFLOW")) return e_OVERFLOW;
1966 0 : if (!strcmp(s,"e_PACKAGE")) return e_PACKAGE;
1967 0 : if (!strcmp(s,"e_PREC")) return e_PREC;
1968 0 : if (!strcmp(s,"e_PRIME")) return e_PRIME;
1969 0 : if (!strcmp(s,"e_PRIORITY")) return e_PRIORITY;
1970 0 : if (!strcmp(s,"e_ROOTS0")) return e_ROOTS0;
1971 0 : if (!strcmp(s,"e_SQRTN")) return e_SQRTN;
1972 0 : if (!strcmp(s,"e_STACK")) return e_STACK;
1973 0 : if (!strcmp(s,"e_SYNTAX")) return e_SYNTAX;
1974 0 : if (!strcmp(s,"e_TYPE")) return e_TYPE;
1975 0 : if (!strcmp(s,"e_TYPE2")) return e_TYPE2;
1976 0 : if (!strcmp(s,"e_USER")) return e_USER;
1977 0 : if (!strcmp(s,"e_VAR")) return e_VAR;
1978 0 : pari_err(e_MISC,"unknown error name");
1979 : return -1; /* LCOV_EXCL_LINE */
1980 : }
1981 :
1982 : GEN
1983 27109 : errname(GEN err)
1984 : {
1985 27109 : if (typ(err)!=t_ERROR) pari_err_TYPE("errname",err);
1986 27109 : return strtoGENstr(numerr_name(err_get_num(err)));
1987 : }
1988 :
1989 : /* Try f (trapping error e), recover using r (break_loop, if NULL) */
1990 : GEN
1991 21 : trap0(const char *e, GEN r, GEN f)
1992 : {
1993 21 : long numerr = CATCH_ALL;
1994 : GEN x;
1995 21 : if (!e || !*e) numerr = CATCH_ALL;
1996 21 : else numerr = name_numerr(e);
1997 21 : if (!f) {
1998 0 : pari_warn(warner,"default handlers are no longer supported --> ignored");
1999 0 : return gnil;
2000 : }
2001 21 : x = closure_trapgen(f, numerr);
2002 14 : if (x == (GEN)1L) x = r? closure_evalgen(r): gnil;
2003 14 : return x;
2004 : }
2005 :
2006 : /*******************************************************************/
2007 : /* */
2008 : /* CLONING & COPY */
2009 : /* Replicate an existing GEN */
2010 : /* */
2011 : /*******************************************************************/
2012 : /* lontyp[tx] = 0 (non recursive type) or number of codewords for type tx */
2013 : const long lontyp[] = { 0,0,0,1,1,2,1,2,1,1, 2,2,0,1,1,1,1,1,1,1, 2,0,0,2,2,1 };
2014 :
2015 : static GEN
2016 6676 : list_internal_copy(GEN z, long nmax)
2017 : {
2018 : long i, l;
2019 : GEN a;
2020 6676 : if (!z) return NULL;
2021 1336 : l = lg(z);
2022 1336 : a = newblock(nmax+1);
2023 50018 : for (i = 1; i < l; i++) gel(a,i) = gel(z,i)? gclone(gel(z,i)): gen_0;
2024 1336 : a[0] = z[0]; setisclone(a); return a;
2025 : }
2026 :
2027 : static void
2028 6676 : listassign(GEN x, GEN y)
2029 : {
2030 6676 : long nmax = list_nmax(x);
2031 6676 : GEN L = list_data(x);
2032 6676 : if (!nmax && L) nmax = lg(L) + 32; /* not malloc'ed yet */
2033 6676 : y[1] = evaltyp(list_typ(x))|evallg(nmax);
2034 6676 : list_data(y) = list_internal_copy(L, nmax);
2035 6676 : }
2036 :
2037 : /* transform a non-malloced list (e.g. from gtolist or gtomap) to a malloced
2038 : * list suitable for listput */
2039 : GEN
2040 0 : listinit(GEN x)
2041 : {
2042 0 : GEN y = cgetg(3, t_LIST);
2043 0 : listassign(x, y); return y;
2044 : }
2045 :
2046 : /* copy list on the PARI stack */
2047 : GEN
2048 730 : listcopy(GEN x)
2049 : {
2050 730 : GEN y = mklist(), L = list_data(x);
2051 730 : if (L) list_data(y) = gcopy(L);
2052 730 : y[1] = evaltyp(list_typ(x));
2053 730 : return y;
2054 : }
2055 :
2056 : GEN
2057 4477137247 : gcopy(GEN x)
2058 : {
2059 4477137247 : long tx = typ(x), lx, i;
2060 : GEN y;
2061 4477137247 : switch(tx)
2062 : { /* non recursive types */
2063 3738661479 : case t_INT: return signe(x)? icopy(x): gen_0;
2064 482519293 : case t_REAL:
2065 : case t_STR:
2066 482519293 : case t_VECSMALL: return leafcopy(x);
2067 : /* one more special case */
2068 730 : case t_LIST: return listcopy(x);
2069 : }
2070 255955745 : y = cgetg_copy(x, &lx);
2071 256328469 : if (lontyp[tx] == 1) i = 1; else { y[1] = x[1]; i = 2; }
2072 1068336752 : for (; i<lx; i++) gel(y,i) = gcopy(gel(x,i));
2073 256327548 : return y;
2074 : }
2075 :
2076 : /* as gcopy, but truncate to the first lx components if recursive type
2077 : * [ leaves use their own lg ]. No checks. */
2078 : GEN
2079 742 : gcopy_lg(GEN x, long lx)
2080 : {
2081 742 : long tx = typ(x), i;
2082 : GEN y;
2083 742 : switch(tx)
2084 : { /* non recursive types */
2085 0 : case t_INT: return signe(x)? icopy(x): gen_0;
2086 0 : case t_REAL:
2087 : case t_STR:
2088 0 : case t_VECSMALL: return leafcopy(x);
2089 : /* one more special case */
2090 0 : case t_LIST: return listcopy(x);
2091 : }
2092 742 : y = cgetg(lx, tx);
2093 742 : if (lontyp[tx] == 1) i = 1; else { y[1] = x[1]; i = 2; }
2094 2051 : for (; i<lx; i++) gel(y,i) = gcopy(gel(x,i));
2095 742 : return y;
2096 : }
2097 :
2098 : /* cf cgetg_copy: "allocate" (by updating first codeword only) for subsequent
2099 : * copy of x, as if avma = *AVMA */
2100 : INLINE GEN
2101 984829323 : cgetg_copy_avma(GEN x, long *plx, pari_sp *AVMA) {
2102 : GEN z;
2103 984829323 : *plx = lg(x);
2104 984829323 : z = ((GEN)*AVMA) - *plx;
2105 984829323 : z[0] = x[0] & (TYPBITS|LGBITS);
2106 984829323 : *AVMA = (pari_sp)z; return z;
2107 : }
2108 : INLINE GEN
2109 620 : cgetlist_avma(pari_sp *AVMA)
2110 : {
2111 620 : GEN y = ((GEN)*AVMA) - 3;
2112 620 : y[0] = _evallg(3) | evaltyp(t_LIST);
2113 620 : *AVMA = (pari_sp)y; return y;
2114 : }
2115 :
2116 : /* copy x as if avma = *AVMA, update *AVMA */
2117 : GEN
2118 3264789988 : gcopy_avma(GEN x, pari_sp *AVMA)
2119 : {
2120 3264789988 : long i, lx, tx = typ(x);
2121 : GEN y;
2122 :
2123 3264789988 : switch(typ(x))
2124 : { /* non recursive types */
2125 3060450803 : case t_INT:
2126 3060450803 : if (lgefint(x) == 2) return gen_0;
2127 2549528998 : *AVMA = (pari_sp)icopy_avma(x, *AVMA);
2128 2549529079 : return (GEN)*AVMA;
2129 61635654 : case t_REAL: case t_STR: case t_VECSMALL:
2130 61635654 : *AVMA = (pari_sp)leafcopy_avma(x, *AVMA);
2131 61637706 : return (GEN)*AVMA;
2132 :
2133 : /* one more special case */
2134 616 : case t_LIST:
2135 616 : y = cgetlist_avma(AVMA);
2136 616 : listassign(x, y); return y;
2137 :
2138 : }
2139 142702915 : y = cgetg_copy_avma(x, &lx, AVMA);
2140 142767287 : if (lontyp[tx] == 1) i = 1; else { y[1] = x[1]; i = 2; }
2141 680488469 : for (; i<lx; i++) gel(y,i) = gcopy_avma(gel(x,i), AVMA);
2142 142768434 : return y;
2143 : }
2144 :
2145 : /* [copy_bin/bin_copy:] same as gcopy_avma but use NULL to code an exact 0, and
2146 : * make shallow copies of finalized t_LISTs */
2147 : static GEN
2148 3735363169 : gcopy_av0(GEN x, pari_sp *AVMA)
2149 : {
2150 3735363169 : long i, lx, tx = typ(x);
2151 : GEN y;
2152 :
2153 3735363169 : switch(tx)
2154 : { /* non recursive types */
2155 2432626559 : case t_INT:
2156 2432626559 : if (!signe(x)) return NULL; /* special marker */
2157 1606209091 : *AVMA = (pari_sp)icopy_avma(x, *AVMA);
2158 1606440647 : return (GEN)*AVMA;
2159 49 : case t_LIST:
2160 49 : if (list_data(x) && !list_nmax(x)) break; /* not finalized, need copy */
2161 : /* else finalized: shallow copy */
2162 : case t_REAL: case t_STR: case t_VECSMALL:
2163 461467749 : *AVMA = (pari_sp)leafcopy_avma(x, *AVMA);
2164 461457419 : return (GEN)*AVMA;
2165 : }
2166 841268861 : y = cgetg_copy_avma(x, &lx, AVMA);
2167 842067354 : if (lontyp[tx] == 1) i = 1; else { y[1] = x[1]; i = 2; }
2168 4128992691 : for (; i<lx; i++) gel(y,i) = gcopy_av0(gel(x,i), AVMA);
2169 842051761 : return y;
2170 : }
2171 :
2172 : INLINE GEN
2173 12 : icopy_avma_canon(GEN x, pari_sp AVMA)
2174 : {
2175 12 : long i, lx = lgefint(x);
2176 12 : GEN y = ((GEN)AVMA) - lx;
2177 12 : y[0] = evaltyp(t_INT)|_evallg(lx); /* kills isclone */
2178 12 : y[1] = x[1]; x = int_MSW(x);
2179 24 : for (i=2; i<lx; i++, x = int_precW(x)) y[i] = *x;
2180 12 : return y;
2181 : }
2182 :
2183 : /* [copy_bin_canon:] same as gcopy_av0, but copy integers in
2184 : * canonical (native kernel) form and make a full copy of t_LISTs */
2185 : static GEN
2186 32 : gcopy_av0_canon(GEN x, pari_sp *AVMA)
2187 : {
2188 32 : long i, lx, tx = typ(x);
2189 : GEN y;
2190 :
2191 32 : switch(tx)
2192 : { /* non recursive types */
2193 20 : case t_INT:
2194 20 : if (!signe(x)) return NULL; /* special marker */
2195 12 : *AVMA = (pari_sp)icopy_avma_canon(x, *AVMA);
2196 12 : return (GEN)*AVMA;
2197 0 : case t_REAL: case t_STR: case t_VECSMALL:
2198 0 : *AVMA = (pari_sp)leafcopy_avma(x, *AVMA);
2199 0 : return (GEN)*AVMA;
2200 :
2201 : /* one more special case */
2202 4 : case t_LIST:
2203 : {
2204 4 : long t = list_typ(x);
2205 4 : GEN y = cgetlist_avma(AVMA), z = list_data(x);
2206 4 : if (z) {
2207 0 : list_data(y) = gcopy_av0_canon(z, AVMA);
2208 0 : y[1] = evaltyp(t)|_evallg(lg(z)-1);
2209 : } else {
2210 4 : list_data(y) = NULL;
2211 4 : y[1] = evaltyp(t);
2212 : }
2213 4 : return y;
2214 : }
2215 : }
2216 8 : y = cgetg_copy_avma(x, &lx, AVMA);
2217 8 : if (lontyp[tx] == 1) i = 1; else { y[1] = x[1]; i = 2; }
2218 24 : for (; i<lx; i++) gel(y,i) = gcopy_av0_canon(gel(x,i), AVMA);
2219 8 : return y;
2220 : }
2221 :
2222 : /* [copy_bin/bin_copy:] size (number of words) required for
2223 : * gcopy_av0_canon(x) */
2224 : static long
2225 32 : taille0_canon(GEN x)
2226 : {
2227 32 : long i,n,lx, tx = typ(x);
2228 32 : switch(tx)
2229 : { /* non recursive types */
2230 20 : case t_INT: return signe(x)? lgefint(x): 0;
2231 0 : case t_REAL:
2232 : case t_STR:
2233 0 : case t_VECSMALL: return lg(x);
2234 :
2235 : /* one more special case */
2236 4 : case t_LIST:
2237 : {
2238 4 : GEN L = list_data(x);
2239 4 : return L? 3 + taille0_canon(L): 3;
2240 : }
2241 : }
2242 8 : n = lx = lg(x);
2243 24 : for (i=lontyp[tx]; i<lx; i++) n += taille0_canon(gel(x,i));
2244 8 : return n;
2245 : }
2246 :
2247 : /* [copy_bin/bin_copy:] size (number of words) required for gcopy_av0(x) */
2248 : static long
2249 3735622694 : taille0(GEN x)
2250 : {
2251 3735622694 : long i,n,lx, tx = typ(x);
2252 3735622694 : switch(tx)
2253 : { /* non recursive types */
2254 2432852863 : case t_INT:
2255 2432852863 : lx = lgefint(x);
2256 2432852863 : return lx == 2? 0: lx;
2257 49 : case t_LIST:
2258 : {
2259 49 : GEN L = list_data(x);
2260 49 : if (L && !list_nmax(x)) break; /* not finalized, deep copy */
2261 : }
2262 : /* else finalized: shallow */
2263 : case t_REAL:
2264 : case t_STR:
2265 : case t_VECSMALL:
2266 461457228 : return lg(x);
2267 : }
2268 841312603 : n = lx = lg(x);
2269 4128572198 : for (i=lontyp[tx]; i<lx; i++) n += taille0(gel(x,i));
2270 841624168 : return n;
2271 : }
2272 :
2273 : static long
2274 3352217607 : gsizeclone_i(GEN x)
2275 : {
2276 3352217607 : long i,n,lx, tx = typ(x);
2277 3352217607 : switch(tx)
2278 : { /* non recursive types */
2279 3060431167 : case t_INT: lx = lgefint(x); return lx == 2? 0: lx;;
2280 74430185 : case t_REAL:
2281 : case t_STR:
2282 74430185 : case t_VECSMALL: return lg(x);
2283 :
2284 6676 : case t_LIST: return 3;
2285 217349579 : default:
2286 217349579 : n = lx = lg(x);
2287 3482651072 : for (i=lontyp[tx]; i<lx; i++) n += gsizeclone_i(gel(x,i));
2288 217348286 : return n;
2289 : }
2290 : }
2291 :
2292 : /* #words needed to clone x; t_LIST is a special case since list_data() is
2293 : * malloc'ed later, in list_internal_copy() */
2294 : static long
2295 231445584 : gsizeclone(GEN x) { return (typ(x) == t_INT)? lgefint(x): gsizeclone_i(x); }
2296 :
2297 : long
2298 2240217 : gsizeword(GEN x)
2299 : {
2300 2240217 : long i, n, lx, tx = typ(x);
2301 2240217 : switch(tx)
2302 : { /* non recursive types */
2303 1700342 : case t_INT:
2304 : case t_REAL:
2305 : case t_STR:
2306 1700342 : case t_VECSMALL: return lg(x);
2307 :
2308 7 : case t_LIST:
2309 7 : x = list_data(x);
2310 7 : return x? 3 + gsizeword(x): 3;
2311 :
2312 539868 : default:
2313 539868 : n = lx = lg(x);
2314 2778069 : for (i=lontyp[tx]; i<lx; i++) n += gsizeword(gel(x,i));
2315 539868 : return n;
2316 : }
2317 : }
2318 : long
2319 168 : gsizebyte(GEN x) { return gsizeword(x) * sizeof(long); }
2320 :
2321 : /* return a clone of x structured as a gcopy */
2322 : GENbin*
2323 448626664 : copy_bin(GEN x)
2324 : {
2325 448626664 : long t = taille0(x);
2326 448711949 : GENbin *p = (GENbin*)pari_malloc(sizeof(GENbin) + t*sizeof(long));
2327 448762292 : pari_sp AVMA = (pari_sp)(GENbinbase(p) + t);
2328 448744691 : p->rebase = &shiftaddress;
2329 448744691 : p->len = t;
2330 448744691 : p->x = gcopy_av0(x, &AVMA);
2331 448708435 : p->base= (GEN)AVMA; return p;
2332 : }
2333 :
2334 : /* same, writing t_INT in canonical native form */
2335 : GENbin*
2336 16 : copy_bin_canon(GEN x)
2337 : {
2338 16 : long t = taille0_canon(x);
2339 16 : GENbin *p = (GENbin*)pari_malloc(sizeof(GENbin) + t*sizeof(long));
2340 16 : pari_sp AVMA = (pari_sp)(GENbinbase(p) + t);
2341 16 : p->rebase = &shiftaddress_canon;
2342 16 : p->len = t;
2343 16 : p->x = gcopy_av0_canon(x, &AVMA);
2344 16 : p->base= (GEN)AVMA; return p;
2345 : }
2346 :
2347 : GEN
2348 231445559 : gclone(GEN x)
2349 : {
2350 231445559 : long i,lx,tx = typ(x), t = gsizeclone(x);
2351 231445363 : GEN y = newblock(t);
2352 231447187 : switch(tx)
2353 : { /* non recursive types */
2354 144529109 : case t_INT:
2355 144529109 : lx = lgefint(x);
2356 144529109 : y[0] = evaltyp(t_INT)|_evallg(lx);
2357 876360118 : for (i=1; i<lx; i++) y[i] = x[i];
2358 144529109 : break;
2359 12403615 : case t_REAL:
2360 : case t_STR:
2361 : case t_VECSMALL:
2362 12403615 : lx = lg(x);
2363 132826762 : for (i=0; i<lx; i++) y[i] = x[i];
2364 12403615 : break;
2365 :
2366 : /* one more special case */
2367 6060 : case t_LIST:
2368 6060 : y[0] = evaltyp(t_LIST)|_evallg(3);
2369 6060 : listassign(x, y);
2370 6060 : break;
2371 74508403 : default: {
2372 74508403 : pari_sp AVMA = (pari_sp)(y + t);
2373 74508403 : lx = lg(x);
2374 74508403 : y[0] = x[0];
2375 74508403 : if (lontyp[tx] == 1) i = 1; else { y[1] = x[1]; i = 2; }
2376 2801640476 : for (; i<lx; i++) gel(y,i) = gcopy_avma(gel(x,i), &AVMA);
2377 : }
2378 : }
2379 231442066 : setisclone(y); return y;
2380 : }
2381 :
2382 : void
2383 2910064044 : shiftaddress(GEN x, long dec)
2384 : {
2385 2910064044 : long i, lx, tx = typ(x);
2386 2910064044 : if (is_recursive_t(tx))
2387 : {
2388 842257571 : if (tx == t_LIST)
2389 : {
2390 49 : if (!list_data(x) || list_nmax(x)) return; /* empty or finalized */
2391 : /* not finalized, update pointers */
2392 : }
2393 842257529 : lx = lg(x);
2394 4130109613 : for (i=lontyp[tx]; i<lx; i++) {
2395 3288026633 : if (!x[i]) gel(x,i) = gen_0;
2396 : else
2397 : {
2398 2487612837 : x[i] += dec;
2399 2487612837 : shiftaddress(gel(x,i), dec);
2400 : }
2401 : }
2402 : }
2403 : }
2404 :
2405 : void
2406 24 : shiftaddress_canon(GEN x, long dec)
2407 : {
2408 24 : long i, lx, tx = typ(x);
2409 24 : switch(tx)
2410 : { /* non recursive types */
2411 12 : case t_INT: {
2412 : GEN y;
2413 12 : lx = lgefint(x); if (lx <= 3) return;
2414 0 : y = x + 2;
2415 0 : x = int_MSW(x); if (x == y) return;
2416 0 : while (x > y) { lswap(*x, *y); x = int_precW(x); y++; }
2417 0 : break;
2418 : }
2419 0 : case t_REAL:
2420 : case t_STR:
2421 : case t_VECSMALL:
2422 0 : break;
2423 :
2424 : /* one more special case */
2425 4 : case t_LIST:
2426 4 : if (!list_data(x)) break;
2427 : default: /* Fall through */
2428 8 : lx = lg(x);
2429 24 : for (i=lontyp[tx]; i<lx; i++) {
2430 16 : if (!x[i]) gel(x,i) = gen_0;
2431 : else
2432 : {
2433 8 : x[i] += dec;
2434 8 : shiftaddress_canon(gel(x,i), dec);
2435 : }
2436 : }
2437 : }
2438 : }
2439 :
2440 : /********************************************************************/
2441 : /** **/
2442 : /** INSERT DYNAMIC OBJECT IN STRUCTURE **/
2443 : /** **/
2444 : /********************************************************************/
2445 : GEN
2446 42 : obj_reinit(GEN S)
2447 : {
2448 42 : GEN s, T = leafcopy(S);
2449 42 : long a = lg(T)-1;
2450 42 : s = gel(T,a);
2451 42 : gel(T,a) = zerovec(lg(s)-1);
2452 42 : return T;
2453 : }
2454 :
2455 : GEN
2456 1621912 : obj_init(long d, long n)
2457 : {
2458 1621912 : GEN S = cgetg(d+2, t_VEC);
2459 1621912 : gel(S, d+1) = zerovec(n);
2460 1621912 : return S;
2461 : }
2462 :
2463 : /* as obj_insert. WITHOUT cloning (for libpari, when creating a *new* obj
2464 : * from an existing one) */
2465 : GEN
2466 1747556 : obj_insert(GEN S, long K, GEN O)
2467 : {
2468 1747556 : GEN o, v = veclast(S);
2469 1747556 : if (typ(v) != t_VEC) pari_err_TYPE("obj_insert", S);
2470 1747556 : if (!check_clone(v))
2471 : {
2472 0 : if (DEBUGLEVEL) pari_warn(warner,"trying to update parent object");
2473 0 : return gclone(O);
2474 : }
2475 1747556 : o = gel(v,K);
2476 1747556 : gel(v,K) = gclone(O); /*SIGINT: before unclone(o)*/
2477 1747556 : if (isclone(o)) gunclone(o); return gel(v,K);
2478 : }
2479 :
2480 : GEN
2481 189945 : obj_insert_shallow(GEN S, long K, GEN O)
2482 : {
2483 189945 : GEN v = veclast(S);
2484 189945 : if (typ(v) != t_VEC) pari_err_TYPE("obj_insert", S);
2485 189945 : gel(v,K) = O;
2486 189945 : return gel(v,K);
2487 : }
2488 :
2489 : /* Does S [last position] contain data at position K ? Return it, or NULL */
2490 : GEN
2491 4506620 : obj_check(GEN S, long K)
2492 : {
2493 4506620 : GEN O, v = veclast(S);
2494 4506617 : if (typ(v) != t_VEC || K >= lg(v)) pari_err_TYPE("obj_check", S);
2495 4506617 : O = gel(v,K); return isintzero(O)? NULL: O;
2496 : }
2497 :
2498 : GEN
2499 1032141 : obj_checkbuild(GEN S, long tag, GEN (*build)(GEN))
2500 : {
2501 1032141 : GEN O = obj_check(S, tag);
2502 1032141 : if (!O)
2503 896453 : { pari_sp av = avma; O = obj_insert(S, tag, build(S)); set_avma(av); }
2504 1032135 : return O;
2505 : }
2506 :
2507 : GEN
2508 507417 : obj_checkbuild_prec(GEN S, long tag, GEN (*build)(GEN,long),
2509 : long (*pr)(GEN), long prec)
2510 : {
2511 507417 : pari_sp av = avma;
2512 507417 : GEN w = obj_check(S, tag);
2513 507417 : if (!w || pr(w) < prec) w = obj_insert(S, tag, build(S, prec));
2514 507417 : set_avma(av); return gcopy(w);
2515 : }
2516 : GEN
2517 398512 : obj_checkbuild_realprec(GEN S, long tag, GEN (*build)(GEN,long), long prec)
2518 398512 : { return obj_checkbuild_prec(S,tag,build,gprecision,prec); }
2519 : GEN
2520 546 : obj_checkbuild_padicprec(GEN S, long tag, GEN (*build)(GEN,long), long prec)
2521 546 : { return obj_checkbuild_prec(S,tag,build,padicprec_relative,prec); }
2522 :
2523 : /* Reset S [last position], freeing all clones */
2524 : void
2525 186340 : obj_free(GEN S)
2526 : {
2527 186340 : GEN v = veclast(S);
2528 : long i;
2529 186340 : if (typ(v) != t_VEC) pari_err_TYPE("obj_free", S);
2530 1206184 : for (i = 1; i < lg(v); i++)
2531 : {
2532 1019844 : GEN o = gel(v,i);
2533 1019844 : gel(v,i) = gen_0;
2534 1019844 : gunclone_deep(o);
2535 : }
2536 186340 : }
2537 :
2538 : /*******************************************************************/
2539 : /* */
2540 : /* STACK MANAGEMENT */
2541 : /* */
2542 : /*******************************************************************/
2543 : INLINE void
2544 4899844570 : dec_gerepile(pari_sp *x, pari_sp av0, pari_sp av, pari_sp tetpil, size_t dec)
2545 : {
2546 4899844570 : if (*x < av && *x >= av0)
2547 : { /* update address if in stack */
2548 4355820316 : if (*x < tetpil) *x += dec;
2549 0 : else pari_err_BUG("gerepile, significant pointers lost");
2550 : }
2551 4899845260 : }
2552 :
2553 : void
2554 6306501 : gerepileallsp(pari_sp av, pari_sp tetpil, int n, ...)
2555 : {
2556 6306501 : const pari_sp av0 = avma;
2557 6306501 : const size_t dec = av-tetpil;
2558 : int i;
2559 6306501 : va_list a; va_start(a, n);
2560 6306501 : (void)gerepile(av,tetpil,NULL);
2561 29501781 : for (i=0; i<n; i++) dec_gerepile((pari_sp*)va_arg(a,GEN*), av0,av,tetpil,dec);
2562 6307289 : va_end(a);
2563 6307289 : }
2564 :
2565 : /* Takes an array of pointers to GENs, of length n.
2566 : * Cleans up the stack between av and tetpil, updating those GENs. */
2567 : void
2568 21488578 : gerepilemanysp(pari_sp av, pari_sp tetpil, GEN* gptr[], int n)
2569 : {
2570 21488578 : const pari_sp av0 = avma;
2571 21488578 : const size_t dec = av-tetpil;
2572 : int i;
2573 21488578 : (void)gerepile(av,tetpil,NULL);
2574 64508571 : for (i=0; i<n; i++) dec_gerepile((pari_sp*)gptr[i], av0, av, tetpil, dec);
2575 21491907 : }
2576 :
2577 : /* Takes an array of GENs (cast to longs), of length n.
2578 : * Cleans up the stack between av and tetpil, updating those GENs. */
2579 : void
2580 307282038 : gerepilecoeffssp(pari_sp av, pari_sp tetpil, long *g, int n)
2581 : {
2582 307282038 : const pari_sp av0 = avma;
2583 307282038 : const size_t dec = av-tetpil;
2584 : int i;
2585 307282038 : (void)gerepile(av,tetpil,NULL);
2586 922362713 : for (i=0; i<n; i++,g++) dec_gerepile((pari_sp*)g, av0, av, tetpil, dec);
2587 307466747 : }
2588 :
2589 : static int
2590 0 : dochk_gerepileupto(GEN av, GEN x)
2591 : {
2592 : long i,lx,tx;
2593 0 : if (!isonstack(x)) return 1;
2594 0 : if (x > av)
2595 : {
2596 0 : pari_warn(warner,"bad object %Ps",x);
2597 0 : return 0;
2598 : }
2599 0 : tx = typ(x);
2600 0 : if (! is_recursive_t(tx)) return 1;
2601 :
2602 0 : lx = lg(x);
2603 0 : for (i=lontyp[tx]; i<lx; i++)
2604 0 : if (!dochk_gerepileupto(av, gel(x,i)))
2605 : {
2606 0 : pari_warn(warner,"bad component %ld in object %Ps",i,x);
2607 0 : return 0;
2608 : }
2609 0 : return 1;
2610 : }
2611 : /* check that x and all its components are out of stack, or have been
2612 : * created after av */
2613 : int
2614 0 : chk_gerepileupto(GEN x) { return dochk_gerepileupto(x, x); }
2615 :
2616 : /* print stack between avma & av */
2617 : void
2618 0 : dbg_gerepile(pari_sp av)
2619 : {
2620 0 : GEN x = (GEN)avma;
2621 0 : while (x < (GEN)av)
2622 : {
2623 0 : const long tx = typ(x), lx = lg(x);
2624 : GEN *a;
2625 :
2626 0 : pari_printf(" [%ld] %Ps:", x - (GEN)avma, x);
2627 0 : if (! is_recursive_t(tx)) { pari_putc('\n'); x += lx; continue; }
2628 0 : a = (GEN*)x + lontyp[tx]; x += lx;
2629 0 : for ( ; a < (GEN*)x; a++)
2630 : {
2631 0 : if (*a == gen_0)
2632 0 : pari_puts(" gen_0");
2633 0 : else if (*a == gen_1)
2634 0 : pari_puts(" gen_1");
2635 0 : else if (*a == gen_m1)
2636 0 : pari_puts(" gen_m1");
2637 0 : else if (*a == gen_2)
2638 0 : pari_puts(" gen_2");
2639 0 : else if (*a == gen_m2)
2640 0 : pari_puts(" gen_m2");
2641 0 : else if (*a == ghalf)
2642 0 : pari_puts(" ghalf");
2643 0 : else if (isclone(*a))
2644 0 : pari_printf(" %Ps (clone)", *a);
2645 : else
2646 0 : pari_printf(" %Ps [%ld]", *a, *a - (GEN)avma);
2647 0 : if (a+1 < (GEN*)x) pari_putc(',');
2648 : }
2649 0 : pari_printf("\n");
2650 : }
2651 0 : }
2652 : void
2653 0 : dbg_gerepileupto(GEN q)
2654 : {
2655 0 : err_printf("%Ps:\n", q);
2656 0 : dbg_gerepile((pari_sp) (q+lg(q)));
2657 0 : }
2658 :
2659 : GEN
2660 1204117357 : gerepile(pari_sp av, pari_sp tetpil, GEN q)
2661 : {
2662 1204117357 : const size_t dec = av - tetpil;
2663 1204117357 : const pari_sp av0 = avma;
2664 : GEN x, a;
2665 :
2666 1204117357 : if (dec == 0) return q;
2667 1009455358 : if ((long)dec < 0) pari_err(e_MISC,"lbot>ltop in gerepile");
2668 :
2669 : /* dec_gerepile(&q, av0, av, tetpil, dec), saving 1 comparison */
2670 1009870376 : if (q >= (GEN)av0 && q < (GEN)tetpil)
2671 681713700 : q = (GEN) (((pari_sp)q) + dec);
2672 :
2673 27297130829 : for (x = (GEN)av, a = (GEN)tetpil; a > (GEN)av0; ) *--x = *--a;
2674 1009870376 : set_avma((pari_sp)x);
2675 6127409198 : while (x < (GEN)av)
2676 : {
2677 5116632224 : const long tx = typ(x), lx = lg(x);
2678 :
2679 5116632224 : if (! is_recursive_t(tx)) { x += lx; continue; }
2680 1065233786 : a = x + lontyp[tx]; x += lx;
2681 5284638807 : for ( ; a < x; a++) dec_gerepile((pari_sp*)a, av0, av, tetpil, dec);
2682 : }
2683 1010776974 : return q;
2684 : }
2685 :
2686 : void
2687 0 : dbg_fill_stack(void)
2688 : {
2689 : #ifdef LONG_IS_64BIT
2690 0 : const long JUNK = 0xBADC0FFEE0DDF00D;
2691 : #else
2692 0 : const long JUNK = 0xDEADBEEF;
2693 : #endif
2694 0 : GEN x = ((GEN)pari_mainstack->bot);
2695 0 : while (x < (GEN)avma) *x++ = JUNK;
2696 0 : }
2697 :
2698 : void
2699 0 : debug_stack(void)
2700 : {
2701 0 : pari_sp top = pari_mainstack->top, bot = pari_mainstack->bot;
2702 : GEN z;
2703 0 : err_printf("bot=0x%lx\ttop=0x%lx\tavma=0x%lx\n", bot, top, avma);
2704 0 : for (z = ((GEN)top)-1; z >= (GEN)avma; z--)
2705 0 : err_printf("%p:\t0x%lx\t%lu\n",z,*z,*z);
2706 0 : }
2707 :
2708 : void
2709 322344 : setdebugvar(long n) { DEBUGVAR=n; }
2710 :
2711 : long
2712 322613 : getdebugvar(void) { return DEBUGVAR; }
2713 :
2714 : long
2715 7 : getstack(void) { return pari_mainstack->top-avma; }
2716 :
2717 : /*******************************************************************/
2718 : /* */
2719 : /* timer_delay */
2720 : /* */
2721 : /*******************************************************************/
2722 :
2723 : #if defined(USE_CLOCK_GETTIME)
2724 : #if defined(_POSIX_THREAD_CPUTIME)
2725 : static THREAD clockid_t time_type = CLOCK_THREAD_CPUTIME_ID;
2726 : #else
2727 : static const THREAD clockid_t time_type = CLOCK_PROCESS_CPUTIME_ID;
2728 : #endif
2729 : static void
2730 : pari_init_timer(void)
2731 : {
2732 : #if defined(_POSIX_THREAD_CPUTIME)
2733 : time_type = CLOCK_PROCESS_CPUTIME_ID;
2734 : #endif
2735 : }
2736 :
2737 : void
2738 : timer_start(pari_timer *T)
2739 : {
2740 : struct timespec t;
2741 : clock_gettime(time_type,&t);
2742 : T->us = t.tv_nsec / 1000;
2743 : T->s = t.tv_sec;
2744 : }
2745 : #elif defined(USE_GETRUSAGE)
2746 : #ifdef RUSAGE_THREAD
2747 : static THREAD int rusage_type = RUSAGE_THREAD;
2748 : #else
2749 : static const THREAD int rusage_type = RUSAGE_SELF;
2750 : #endif /*RUSAGE_THREAD*/
2751 : static void
2752 1851 : pari_init_timer(void)
2753 : {
2754 : #ifdef RUSAGE_THREAD
2755 1851 : rusage_type = RUSAGE_SELF;
2756 : #endif
2757 1851 : }
2758 :
2759 : void
2760 340861 : timer_start(pari_timer *T)
2761 : {
2762 : struct rusage r;
2763 340861 : getrusage(rusage_type,&r);
2764 340861 : T->us = r.ru_utime.tv_usec;
2765 340861 : T->s = r.ru_utime.tv_sec;
2766 340861 : }
2767 : #elif defined(USE_FTIME)
2768 :
2769 : static void
2770 : pari_init_timer(void) { }
2771 :
2772 : void
2773 : timer_start(pari_timer *T)
2774 : {
2775 : struct timeb t;
2776 : ftime(&t);
2777 : T->us = ((long)t.millitm) * 1000;
2778 : T->s = t.time;
2779 : }
2780 :
2781 : #else
2782 :
2783 : static void
2784 : _get_time(pari_timer *T, long Ticks, long TickPerSecond)
2785 : {
2786 : T->us = (long) ((Ticks % TickPerSecond) * (1000000. / TickPerSecond));
2787 : T->s = Ticks / TickPerSecond;
2788 : }
2789 :
2790 : # ifdef USE_TIMES
2791 : static void
2792 : pari_init_timer(void) { }
2793 :
2794 : void
2795 : timer_start(pari_timer *T)
2796 : {
2797 : # ifdef _SC_CLK_TCK
2798 : long tck = sysconf(_SC_CLK_TCK);
2799 : # else
2800 : long tck = CLK_TCK;
2801 : # endif
2802 : struct tms t; times(&t);
2803 : _get_time(T, t.tms_utime, tck);
2804 : }
2805 : # elif defined(_WIN32)
2806 : static void
2807 : pari_init_timer(void) { }
2808 :
2809 : void
2810 : timer_start(pari_timer *T)
2811 : { _get_time(T, win32_timer(), 1000); }
2812 : # else
2813 : # include <time.h>
2814 : # ifndef CLOCKS_PER_SEC
2815 : # define CLOCKS_PER_SEC 1000000 /* may be false on YOUR system */
2816 : # endif
2817 : static void
2818 : pari_init_timer(void) { }
2819 :
2820 : void
2821 : timer_start(pari_timer *T)
2822 : { _get_time(T, clock(), CLOCKS_PER_SEC); }
2823 : # endif
2824 : #endif
2825 :
2826 : /* round microseconds to milliseconds */
2827 : static long
2828 207083 : rndus(long x) { return (x + 500) / 1000; }
2829 : static long
2830 207075 : timer_aux(pari_timer *T, pari_timer *U, void (*settime)(pari_timer *))
2831 : {
2832 207075 : long s = T->s, us = T->us;
2833 207075 : settime(U); return 1000 * (U->s - s) + rndus(U->us - us);
2834 : }
2835 :
2836 : /* return delay, set timer checkpoint */
2837 : long
2838 104413 : timer_delay(pari_timer *T) { return timer_aux(T, T, &timer_start); }
2839 : /* return delay, don't set checkpoint */
2840 : long
2841 1869 : timer_get(pari_timer *T) {pari_timer t; return timer_aux(T, &t, &timer_start);}
2842 :
2843 : static void
2844 0 : timer_vprintf(pari_timer *T, const char *format, va_list args)
2845 : {
2846 0 : out_puts(pariErr, "Time ");
2847 0 : out_vprintf(pariErr, format,args);
2848 0 : out_printf(pariErr, ": %ld\n", timer_delay(T));
2849 0 : pariErr->flush();
2850 0 : }
2851 : void
2852 0 : timer_printf(pari_timer *T, const char *format, ...)
2853 : {
2854 0 : va_list args; va_start(args, format);
2855 0 : timer_vprintf(T, format, args);
2856 0 : va_end(args);
2857 0 : }
2858 :
2859 : long
2860 0 : timer(void) { static THREAD pari_timer T; return timer_delay(&T);}
2861 : long
2862 3620 : gettime(void) { static THREAD pari_timer T; return timer_delay(&T);}
2863 :
2864 : static THREAD pari_timer timer2_T, abstimer_T;
2865 : long
2866 0 : timer2(void) { return timer_delay(&timer2_T);}
2867 : void
2868 0 : msgtimer(const char *format, ...)
2869 : {
2870 0 : va_list args; va_start(args, format);
2871 0 : timer_vprintf(&timer2_T, format, args);
2872 0 : va_end(args);
2873 0 : }
2874 : long
2875 1863 : getabstime(void) { return timer_get(&abstimer_T);}
2876 :
2877 : void
2878 236864 : walltimer_start(pari_timer *ti)
2879 : {
2880 : #if defined(USE_CLOCK_GETTIME)
2881 : struct timespec t;
2882 : if (!clock_gettime(CLOCK_REALTIME,&t))
2883 : { ti->s = t.tv_sec; ti->us = rndus(t.tv_nsec); return; }
2884 : #elif defined(USE_GETTIMEOFDAY)
2885 : struct timeval tv;
2886 236864 : if (!gettimeofday(&tv, NULL))
2887 236864 : { ti->s = tv.tv_sec; ti->us = tv.tv_usec; return; }
2888 : #elif defined(USE_FTIMEFORWALLTIME)
2889 : struct timeb tp;
2890 : if (!ftime(&tp))
2891 : { ti->s = tp.time; ti->us = tp.millitm*1000; return; }
2892 : #endif
2893 0 : timer_start(ti);
2894 : }
2895 : /* return delay, set timer checkpoint */
2896 : long
2897 100793 : walltimer_delay(pari_timer *T) { return timer_aux(T, T, &walltimer_start); }
2898 : /* return delay, don't set checkpoint */
2899 : long
2900 0 : walltimer_get(pari_timer *T)
2901 : {
2902 : pari_timer t;
2903 0 : return timer_aux(T, &t, &walltimer_start);
2904 : }
2905 :
2906 : static GEN
2907 8 : timetoi(ulong s, ulong m)
2908 : {
2909 8 : pari_sp av = avma;
2910 8 : return gerepileuptoint(av, addiu(muluu(s, 1000), m));
2911 : }
2912 : GEN
2913 8 : getwalltime(void)
2914 : {
2915 : pari_timer ti;
2916 8 : walltimer_start(&ti);
2917 8 : return timetoi(ti.s, rndus(ti.us));
2918 : }
2919 :
2920 : /*******************************************************************/
2921 : /* */
2922 : /* FUNCTIONS KNOWN TO THE ANALYZER */
2923 : /* */
2924 : /*******************************************************************/
2925 :
2926 : GEN
2927 127 : setdebug(const char *s, long n)
2928 : {
2929 127 : long i, l = numberof(pari_DEBUGLEVEL_str);
2930 : GEN V, V1, V2;
2931 127 : if (s)
2932 : {
2933 120 : if (n > 20)
2934 0 : pari_err_DOMAIN("setdebug", "n", ">", utoipos(20), stoi(n));
2935 2276 : for (i = 0; i < l; i++)
2936 2248 : if (!strcmp(s, pari_DEBUGLEVEL_str[i])) break;
2937 120 : if (i == l)
2938 28 : pari_err_DOMAIN("setdebug", s, "not a valid",
2939 : strtoGENstr("debug domain"), strtoGENstr(s));
2940 92 : if (n >= 0) { *pari_DEBUGLEVEL_ptr[i] = n; return gnil; }
2941 42 : return stoi(*pari_DEBUGLEVEL_ptr[i]);
2942 : }
2943 7 : V = cgetg(3,t_MAT);
2944 7 : V1 = gel(V,1) = cgetg(l+1, t_COL);
2945 7 : V2 = gel(V,2) = cgetg(l+1, t_COL);
2946 427 : for (i = 0; i < l; i++)
2947 : {
2948 420 : gel(V1, i+1) = strtoGENstr(pari_DEBUGLEVEL_str[i]);
2949 420 : gel(V2, i+1) = stoi(*pari_DEBUGLEVEL_ptr[i]);
2950 : }
2951 7 : return V;
2952 : }
2953 :
2954 : GEN
2955 7 : pari_version(void)
2956 : {
2957 7 : const ulong mask = (1UL<<PARI_VERSION_SHIFT) - 1;
2958 7 : ulong major, minor, patch, n = paricfg_version_code;
2959 7 : patch = n & mask; n >>= PARI_VERSION_SHIFT;
2960 7 : minor = n & mask; n >>= PARI_VERSION_SHIFT;
2961 7 : major = n;
2962 7 : if (*paricfg_vcsversion) {
2963 7 : const char *ver = paricfg_vcsversion;
2964 7 : const char *s = strchr(ver, '-');
2965 : char t[8];
2966 7 : const long len = s-ver;
2967 : GEN v;
2968 7 : if (!s || len > 6) pari_err_BUG("pari_version()"); /* paranoia */
2969 7 : memcpy(t, ver, len); t[len] = 0;
2970 7 : v = cgetg(6, t_VEC);
2971 7 : gel(v,1) = utoi(major);
2972 7 : gel(v,2) = utoi(minor);
2973 7 : gel(v,3) = utoi(patch);
2974 7 : gel(v,4) = stoi( atoi(t) );
2975 7 : gel(v,5) = strtoGENstr(s+1);
2976 7 : return v;
2977 : } else {
2978 0 : GEN v = cgetg(4, t_VEC);
2979 0 : gel(v,1) = utoi(major);
2980 0 : gel(v,2) = utoi(minor);
2981 0 : gel(v,3) = utoi(patch);
2982 0 : return v;
2983 : }
2984 : }
2985 :
2986 : /* List of GP functions: generated from the description system.
2987 : * Format (struct entree) :
2988 : * char *name : name (under GP).
2989 : * ulong valence: (EpNEW, EpALIAS,EpVAR, EpINSTALL)|EpSTATIC
2990 : * void *value : For PREDEFINED FUNCTIONS: C function to call.
2991 : * For USER FUNCTIONS: pointer to defining data (block) =
2992 : * entree*: NULL, list of entree (arguments), NULL
2993 : * char* : function text
2994 : * long menu : which help section do we belong to
2995 : * 1: Standard monadic or dyadic OPERATORS
2996 : * 2: CONVERSIONS and similar elementary functions
2997 : * 3: functions related to COMBINATORICS
2998 : * 4: TRANSCENDENTAL functions, etc.
2999 : * char *code : GP prototype, aka Parser Code (see libpari's manual)
3000 : * if NULL, use valence instead.
3001 : * char *help : short help text (init to NULL).
3002 : * void *pvalue : push_val history.
3003 : * long arity : maximum number of arguments.
3004 : * entree *next : next entree (init to NULL, used in hashing code). */
3005 : #include "init.h"
3006 : #include "default.h"
|
