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