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