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