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