Code coverage tests

This page documents the degree to which the PARI/GP source code is tested by our public test suite, distributed with the source distribution in directory src/test/. This is measured by the gcov utility; we then process gcov output using the lcov frond-end.

We test a few variants depending on Configure flags on the pari.math.u-bordeaux.fr machine (x86_64 architecture), and agregate them in the final report:

The target is to exceed 90% coverage for all mathematical modules (given that branches depending on DEBUGLEVEL or DEBUGMEM are not covered). This script is run to produce the results below.

LCOV - code coverage report
Current view: top level - language - init.c (source / functions) Hit Total Coverage
Test: PARI/GP v2.14.0 lcov report (development 27775-aca467eab2) Lines: 1158 1491 77.7 %
Date: 2022-07-03 07:33:15 Functions: 134 162 82.7 %
Legend: Lines: hit not hit

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

Generated by: LCOV version 1.13