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