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 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.10.0 lcov report (development 19825-b77c7f8) Lines: 799 1157 69.1 %
Date: 2016-12-06 05:49:02 Functions: 96 130 73.8 %
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. It is distributed in the hope that it will be useful, but WITHOUT
       8             : ANY WARRANTY WHATSOEVER.
       9             : 
      10             : Check the License for details. You should have received a copy of it, along
      11             : with the package; see the file 'COPYING'. If not, write to the Free Software
      12             : Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. */
      13             : 
      14             : /*******************************************************************/
      15             : /*                                                                 */
      16             : /*        INITIALIZING THE SYSTEM, ERRORS, STACK MANAGEMENT        */
      17             : /*                                                                 */
      18             : /*******************************************************************/
      19             : /* _GNU_SOURCE is needed before first include to get RUSAGE_THREAD */
      20             : #undef _GNU_SOURCE /* avoid warning */
      21             : #define _GNU_SOURCE
      22             : #include <string.h>
      23             : #if defined(_WIN32) || defined(__CYGWIN32__)
      24             : #  include "../systems/mingw/mingw.h"
      25             : #  include <process.h>
      26             : #endif
      27             : #include "paricfg.h"
      28             : #if defined(STACK_CHECK) && !defined(__EMX__)
      29             : #  include <sys/types.h>
      30             : #  include <sys/time.h>
      31             : #  include <sys/resource.h>
      32             : #endif
      33             : #if defined(HAS_WAITPID) && defined(HAS_SETSID)
      34             : #  include <sys/wait.h>
      35             : #endif
      36             : #ifdef HAS_MMAP
      37             : #  include <sys/mman.h>
      38             : #endif
      39             : #if defined(USE_GETTIMEOFDAY) || defined(USE_GETRUSAGE) || defined(USE_TIMES)
      40             : #  include <sys/time.h>
      41             : #endif
      42             : #if defined(USE_GETRUSAGE)
      43             : #  include <sys/resource.h>
      44             : #endif
      45             : #if defined(USE_FTIME) || defined(USE_FTIMEFORWALLTIME)
      46             : #  include <sys/timeb.h>
      47             : #endif
      48             : #if defined(USE_CLOCK_GETTIME) || defined(USE_TIMES)
      49             : #  include <time.h>
      50             : #endif
      51             : #if defined(USE_TIMES)
      52             : #  include <sys/times.h>
      53             : #endif
      54             : #include "pari.h"
      55             : #include "paripriv.h"
      56             : #include "anal.h"
      57             : 
      58             : const double LOG2    = 0.6931471805599453; /* log(2) */
      59             : const double LOG10_2 = 0.3010299956639812; /* log_10(2) */
      60             : const double LOG2_10 = 3.321928094887362;  /* log_2(10) */
      61             : 
      62             : GEN gnil, gen_0, gen_1, gen_m1, gen_2, gen_m2, ghalf, err_e_STACK;
      63             : 
      64             : static const ulong readonly_constants[] = {
      65             :   evaltyp(t_INT) | _evallg(2),  /* gen_0 */
      66             :   evallgefint(2),
      67             :   evaltyp(t_INT) | _evallg(2),  /* gnil */
      68             :   evallgefint(2),
      69             :   evaltyp(t_INT) | _evallg(3),  /* gen_1 */
      70             :   evalsigne(1) | evallgefint(3),
      71             :   1,
      72             :   evaltyp(t_INT) | _evallg(3),  /* gen_2 */
      73             :   evalsigne(1) | evallgefint(3),
      74             :   2,
      75             :   evaltyp(t_INT) | _evallg(3),  /* gen_m1 */
      76             :   evalsigne(-1) | evallgefint(3),
      77             :   1,
      78             :   evaltyp(t_INT) | _evallg(3),  /* gen_m2 */
      79             :   evalsigne(-1) | evallgefint(3),
      80             :   2,
      81             :   evaltyp(t_FRAC) | _evallg(3), /* ghalf */
      82             :   (ulong)(readonly_constants+4),
      83             :   (ulong)(readonly_constants+7)
      84             : };
      85             : static const ulong readonly_err_STACK[] = {
      86             :   evaltyp(t_ERROR) | _evallg(2),
      87             :   e_STACK
      88             : };
      89             : THREAD GEN    bernzone;
      90             : GEN     primetab; /* private primetable */
      91             : byteptr diffptr;
      92             : FILE    *pari_outfile, *pari_errfile, *pari_logfile, *pari_infile;
      93             : char    *current_logfile, *current_psfile, *pari_datadir;
      94             : long    gp_colors[c_LAST];
      95             : int     disable_color;
      96             : ulong   DEBUGFILES, DEBUGLEVEL, DEBUGMEM;
      97             : long    DEBUGVAR;
      98             : ulong   pari_mt_nbthreads;
      99             : long    precreal;
     100             : ulong   precdl, logstyle;
     101             : gp_data *GP_DATA;
     102             : 
     103             : GEN colormap, pari_graphcolors;
     104             : 
     105             : entree  **varentries;
     106             : THREAD long *varpriority;
     107             : 
     108             : THREAD pari_sp avma;
     109             : THREAD struct pari_mainstack *pari_mainstack;
     110             : 
     111             : static void ** MODULES;
     112             : static pari_stack s_MODULES;
     113             : const long functions_tblsz = 135; /* size of functions_hash */
     114             : entree **functions_hash, **defaults_hash;
     115             : 
     116             : char *(*cb_pari_fgets_interactive)(char *s, int n, FILE *f);
     117             : int (*cb_pari_get_line_interactive)(const char*, const char*, filtre_t *F);
     118             : void (*cb_pari_quit)(long);
     119             : void (*cb_pari_init_histfile)(void);
     120             : void (*cb_pari_ask_confirm)(const char *);
     121             : int  (*cb_pari_handle_exception)(long);
     122             : int  (*cb_pari_err_handle)(GEN);
     123             : int  (*cb_pari_whatnow)(PariOUT *out, const char *, int);
     124             : void (*cb_pari_sigint)(void);
     125             : void (*cb_pari_pre_recover)(long);
     126             : void (*cb_pari_err_recover)(long);
     127             : int (*cb_pari_break_loop)(int);
     128             : int (*cb_pari_is_interactive)(void);
     129             : void (*cb_pari_start_output)();
     130             : 
     131             : const char * pari_library_path = NULL;
     132             : 
     133             : static THREAD GEN global_err_data;
     134             : THREAD jmp_buf *iferr_env;
     135             : const long CATCH_ALL = -1;
     136             : 
     137             : static void pari_init_timer(void);
     138             : 
     139             : /*********************************************************************/
     140             : /*                                                                   */
     141             : /*                       BLOCKS & CLONES                             */
     142             : /*                                                                   */
     143             : /*********************************************************************/
     144             : /*#define DEBUG*/
     145             : static THREAD long next_block;
     146             : static THREAD GEN cur_block; /* current block in block list */
     147             : #ifdef DEBUG
     148             : static THREAD long NUM;
     149             : #endif
     150             : 
     151             : static void
     152       62799 : pari_init_blocks(void)
     153             : {
     154       62799 :   next_block = 0; cur_block = NULL;
     155             : #ifdef DEBUG
     156             :   NUM = 0;
     157             : #endif
     158       62799 : }
     159             : 
     160             : static void
     161       64307 : pari_close_blocks(void)
     162             : {
     163       64307 :   while (cur_block) killblock(cur_block);
     164       64188 : }
     165             : 
     166             : /* Return x, where:
     167             :  * x[-4]: reference count
     168             :  * x[-3]: adress of next block
     169             :  * x[-2]: adress of preceding block.
     170             :  * x[-1]: number of allocated blocs.
     171             :  * x[0..n-1]: malloc-ed memory. */
     172             : GEN
     173   137567662 : newblock(size_t n)
     174             : {
     175   137567662 :   long *x = (long *) pari_malloc((n + BL_HEAD)*sizeof(long)) + BL_HEAD;
     176             : 
     177   137568498 :   bl_refc(x) = 1;
     178   137568498 :   bl_next(x) = NULL;
     179   137568498 :   bl_prev(x) = cur_block;
     180   137568498 :   bl_num(x)  = next_block++;
     181   137568498 :   if (cur_block) bl_next(cur_block) = x;
     182             : #ifdef DEBUG
     183             :   err_printf("+ %ld\n", ++NUM);
     184             : #endif
     185   137568498 :   if (DEBUGMEM)
     186             :   {
     187           0 :     if (!n) pari_warn(warner,"mallocing NULL object in newblock");
     188           0 :     if (DEBUGMEM > 2)
     189           0 :       err_printf("new block, size %6lu (no %ld): %08lx\n", n, next_block-1, x);
     190             :   }
     191   137568396 :   return cur_block = x;
     192             : }
     193             : 
     194             : GEN
     195         297 : gcloneref(GEN x)
     196             : {
     197         297 :   if (isclone(x)) { ++bl_refc(x); return x; }
     198         297 :   else return gclone(x);
     199             : }
     200             : 
     201             : void
     202           0 : gclone_refc(GEN x) { ++bl_refc(x); }
     203             : 
     204             : void
     205   179829580 : gunclone(GEN x)
     206             : {
     207   359659193 :   if (--bl_refc(x) > 0) return;
     208   137575894 :   BLOCK_SIGINT_START;
     209   137576096 :   if (bl_next(x)) bl_prev(bl_next(x)) = bl_prev(x);
     210             :   else
     211             :   {
     212    24617024 :     cur_block = bl_prev(x);
     213    24617024 :     next_block = bl_num(x);
     214             :   }
     215   137576096 :   if (bl_prev(x)) bl_next(bl_prev(x)) = bl_next(x);
     216   137576096 :   if (DEBUGMEM > 2)
     217           0 :     err_printf("killing block (no %ld): %08lx\n", bl_num(x), x);
     218   137576109 :   free((void*)bl_base(x)); /* pari_free not needed: we already block */
     219   137576109 :   BLOCK_SIGINT_END;
     220             : #ifdef DEBUG
     221             :   err_printf("- %ld\n", NUM--);
     222             : #endif
     223             : }
     224             : 
     225             : /* Recursively look for clones in the container and kill them. Then kill
     226             :  * container if clone. SIGINT could be blocked until it returns */
     227             : void
     228  2535593093 : gunclone_deep(GEN x)
     229             : {
     230             :   long i, lx;
     231             :   GEN v;
     232  5071186186 :   if (isclone(x) && bl_refc(x) > 1) { --bl_refc(x); return; }
     233  2514004918 :   BLOCK_SIGINT_START;
     234  2514004918 :   switch(typ(x))
     235             :   {
     236             :     case t_VEC: case t_COL: case t_MAT:
     237    33015400 :       lx = lg(x);
     238    33015400 :       for (i=1;i<lx;i++) gunclone_deep(gel(x,i));
     239    33015400 :       break;
     240             :     case t_LIST:
     241         270 :       v = list_data(x); lx = v? lg(v): 1;
     242         270 :       for (i=1;i<lx;i++) gunclone_deep(gel(v,i));
     243         270 :       if (v) killblock(v);
     244         270 :       break;
     245             :   }
     246  2514004918 :   if (isclone(x)) gunclone(x);
     247  2514004918 :   BLOCK_SIGINT_END;
     248             : }
     249             : 
     250             : int
     251      128191 : pop_entree_block(entree *ep, long loc)
     252             : {
     253      128191 :   GEN x = (GEN)ep->value;
     254      128191 :   if (bl_num(x) < loc) return 0; /* older */
     255         112 :   if (DEBUGMEM>2)
     256           0 :     err_printf("popping %s (block no %ld)\n", ep->name, bl_num(x));
     257         112 :   gunclone_deep(x); return 1;
     258             : }
     259             : 
     260             : /*********************************************************************/
     261             : /*                                                                   */
     262             : /*                       C STACK SIZE CONTROL                        */
     263             : /*                                                                   */
     264             : /*********************************************************************/
     265             : /* Avoid core dump on deep recursion. Adapted Perl code by Dominic Dunlop */
     266             : THREAD void *PARI_stack_limit = NULL;
     267             : 
     268             : #ifdef STACK_CHECK
     269             : 
     270             : #  ifdef __EMX__                                /* Emulate */
     271             : void
     272             : pari_stackcheck_init(void *pari_stack_base)
     273             : {
     274             :   (void) pari_stack_base;
     275             :   if (!pari_stack_base) { PARI_stack_limit = NULL; return; }
     276             :   PARI_stack_limit = get_stack(1./16, 32*1024);
     277             : }
     278             : #  else /* !__EMX__ */
     279             : /* Set PARI_stack_limit to (a little above) the lowest safe address that can be
     280             :  * used on the stack. Leave PARI_stack_limit at its initial value (NULL) to
     281             :  * show no check should be made [init failed]. Assume stack grows downward. */
     282             : void
     283        1350 : pari_stackcheck_init(void *pari_stack_base)
     284             : {
     285             :   struct rlimit rip;
     286             :   ulong size;
     287        1350 :   if (!pari_stack_base) { PARI_stack_limit = NULL; return; }
     288        1350 :   if (getrlimit(RLIMIT_STACK, &rip)) return;
     289        1350 :   size = rip.rlim_cur;
     290        1350 :   if (size == (ulong)RLIM_INFINITY || size > (ulong)pari_stack_base)
     291           0 :     PARI_stack_limit = (void*)(((ulong)pari_stack_base) / 16);
     292             :   else
     293        1350 :     PARI_stack_limit = (void*)((ulong)pari_stack_base - (size/16)*15);
     294             : }
     295             : #  endif /* !__EMX__ */
     296             : 
     297             : #else
     298             : void
     299             : pari_stackcheck_init(void *pari_stack_base)
     300             : {
     301             :   (void) pari_stack_base; PARI_stack_limit = NULL;
     302             : }
     303             : #endif /* STACK_CHECK */
     304             : 
     305             : /*******************************************************************/
     306             : /*                         HEAP TRAVERSAL                          */
     307             : /*******************************************************************/
     308             : struct getheap_t { long n, l; };
     309             : static void
     310        6615 : f_getheap(GEN x, void *D)
     311             : {
     312        6615 :   struct getheap_t *T = (struct getheap_t*)D;
     313        6615 :   T->n++;
     314        6615 :   T->l += gsizeword(x);
     315        6615 : }
     316             : GEN
     317          84 : getheap(void)
     318             : {
     319          84 :   struct getheap_t T = { 0, 0 };
     320          84 :   traverseheap(&f_getheap, &T);
     321          84 :   return mkvec2s(T.n, T.l + BL_HEAD * T.n);
     322             : }
     323             : 
     324             : void
     325          84 : traverseheap( void(*f)(GEN, void *), void *data )
     326             : {
     327             :   GEN x;
     328          84 :   for (x = cur_block; x; x = bl_prev(x)) f(x, data);
     329          84 : }
     330             : 
     331             : /*********************************************************************/
     332             : /*                          DAEMON / FORK                            */
     333             : /*********************************************************************/
     334             : #if defined(HAS_WAITPID) && defined(HAS_SETSID)
     335             : /* Properly fork a process, detaching from main process group without creating
     336             :  * zombies on exit. Parent returns 1, son returns 0 */
     337             : int
     338         508 : pari_daemon(void)
     339             : {
     340         508 :   pid_t pid = fork();
     341        1016 :   switch(pid) {
     342           0 :       case -1: return 1; /* father, fork failed */
     343             :       case 0:
     344         508 :         (void)setsid(); /* son becomes process group leader */
     345         508 :         if (fork()) exit(0); /* now son exits, also when fork fails */
     346         508 :         break; /* grandson: its father is the son, which exited,
     347             :                 * hence father becomes 'init', that'll take care of it */
     348             :       default: /* father, fork succeeded */
     349         508 :         (void)waitpid(pid,NULL,0); /* wait for son to exit, immediate */
     350         508 :         return 1;
     351             :   }
     352             :   /* grandson */
     353         508 :   return 0;
     354             : }
     355             : #else
     356             : int
     357             : pari_daemon(void)
     358             : {
     359             :   pari_err_IMPL("pari_daemon without waitpid & setsid");
     360             :   return 0;
     361             : }
     362             : #endif
     363             : 
     364             : /*********************************************************************/
     365             : /*                                                                   */
     366             : /*                       SYSTEM INITIALIZATION                       */
     367             : /*                                                                   */
     368             : /*********************************************************************/
     369             : static int try_to_recover = 0;
     370             : THREAD VOLATILE int PARI_SIGINT_block = 0, PARI_SIGINT_pending = 0;
     371             : 
     372             : /*********************************************************************/
     373             : /*                         SIGNAL HANDLERS                           */
     374             : /*********************************************************************/
     375             : static void
     376           0 : dflt_sigint_fun(void) { pari_err(e_MISC, "user interrupt"); }
     377             : 
     378             : #if defined(_WIN32) || defined(__CYGWIN32__)
     379             : int win32ctrlc = 0, win32alrm = 0;
     380             : void
     381             : dowin32ctrlc(void)
     382             : {
     383             :   win32ctrlc = 0;
     384             :   cb_pari_sigint();
     385             : }
     386             : #endif
     387             : 
     388             : static void
     389           0 : pari_handle_SIGINT(void)
     390             : {
     391             : #ifdef _WIN32
     392             :   if (++win32ctrlc >= 5) _exit(3);
     393             : #else
     394           0 :   cb_pari_sigint();
     395             : #endif
     396           0 : }
     397             : 
     398             : void
     399           0 : pari_sighandler(int sig)
     400             : {
     401             :   const char *msg;
     402             : #ifndef HAS_SIGACTION
     403             :   /*SYSV reset the signal handler in the handler*/
     404             :   (void)os_signal(sig,pari_sighandler);
     405             : #endif
     406           0 :   switch(sig)
     407             :   {
     408             : #ifdef SIGBREAK
     409             :     case SIGBREAK:
     410             :       if (PARI_SIGINT_block==1)
     411             :       {
     412             :         PARI_SIGINT_pending=SIGBREAK;
     413             :         mt_sigint();
     414             :       }
     415             :       else pari_handle_SIGINT();
     416             :       return;
     417             : #endif
     418             : 
     419             : #ifdef SIGINT
     420             :     case SIGINT:
     421           0 :       if (PARI_SIGINT_block==1)
     422             :       {
     423           0 :         PARI_SIGINT_pending=SIGINT;
     424           0 :         mt_sigint();
     425             :       }
     426           0 :       else pari_handle_SIGINT();
     427           0 :       return;
     428             : #endif
     429             : 
     430             : #ifdef SIGSEGV
     431             :     case SIGSEGV:
     432           0 :       msg="PARI/GP (Segmentation Fault)"; break;
     433             : #endif
     434             : #ifdef SIGBUS
     435             :     case SIGBUS:
     436           0 :       msg="PARI/GP (Bus Error)"; break;
     437             : #endif
     438             : #ifdef SIGFPE
     439             :     case SIGFPE:
     440           0 :       msg="PARI/GP (Floating Point Exception)"; break;
     441             : #endif
     442             : 
     443             : #ifdef SIGPIPE
     444             :     case SIGPIPE:
     445             :     {
     446           0 :       pariFILE *f = GP_DATA->pp->file;
     447           0 :       if (f && pari_outfile == f->file)
     448             :       {
     449           0 :         GP_DATA->pp->file = NULL; /* to avoid oo recursion on error */
     450           0 :         pari_outfile = stdout; pari_fclose(f);
     451           0 :         pari_err(e_MISC, "Broken Pipe, resetting file stack...");
     452             :       }
     453           0 :       return; /* not reached */
     454             :     }
     455             : #endif
     456             : 
     457           0 :     default: msg="signal handling"; break;
     458             :   }
     459           0 :   pari_err_BUG(msg);
     460             : }
     461             : 
     462             : void
     463        3207 : pari_sig_init(void (*f)(int))
     464             : {
     465             : #ifdef SIGBUS
     466        3207 :   (void)os_signal(SIGBUS,f);
     467             : #endif
     468             : #ifdef SIGFPE
     469        3207 :   (void)os_signal(SIGFPE,f);
     470             : #endif
     471             : #ifdef SIGINT
     472        3207 :   (void)os_signal(SIGINT,f);
     473             : #endif
     474             : #ifdef SIGBREAK
     475             :   (void)os_signal(SIGBREAK,f);
     476             : #endif
     477             : #ifdef SIGPIPE
     478        3207 :   (void)os_signal(SIGPIPE,f);
     479             : #endif
     480             : #ifdef SIGSEGV
     481        3207 :   (void)os_signal(SIGSEGV,f);
     482             : #endif
     483        3207 : }
     484             : 
     485             : /*********************************************************************/
     486             : /*                      STACK AND UNIVERSAL CONSTANTS                */
     487             : /*********************************************************************/
     488             : static void
     489        1350 : init_universal_constants(void)
     490             : {
     491        1350 :   gen_0  = (GEN)readonly_constants;
     492        1350 :   gnil   = (GEN)readonly_constants+2;
     493        1350 :   gen_1  = (GEN)readonly_constants+4;
     494        1350 :   gen_2  = (GEN)readonly_constants+7;
     495        1350 :   gen_m1 = (GEN)readonly_constants+10;
     496        1350 :   gen_m2 = (GEN)readonly_constants+13;
     497        1350 :   ghalf  = (GEN)readonly_constants+16;
     498        1350 :   err_e_STACK = (GEN)readonly_err_STACK;
     499        1350 : }
     500             : 
     501             : static void
     502       62954 : pari_init_errcatch(void)
     503             : {
     504       62954 :   iferr_env = NULL;
     505       62954 :   global_err_data = NULL;
     506       62954 : }
     507             : 
     508             : /*********************************************************************/
     509             : /*                           INIT DEFAULTS                           */
     510             : /*********************************************************************/
     511             : void
     512        1350 : pari_init_defaults(void)
     513             : {
     514             :   long i;
     515        1350 :   initout(1);
     516             : 
     517             : #ifdef LONG_IS_64BIT
     518        1159 :   precreal = 128;
     519             : #else
     520         191 :   precreal = 96;
     521             : #endif
     522             : 
     523        1350 :   precdl = 16;
     524        1350 :   DEBUGFILES = DEBUGLEVEL = DEBUGMEM = 0;
     525        1350 :   disable_color = 1;
     526        1350 :   logstyle = logstyle_none;
     527             : 
     528        1350 :   current_psfile = pari_strdup("pari.ps");
     529        1350 :   current_logfile= pari_strdup("pari.log");
     530        1350 :   pari_logfile = NULL;
     531             : 
     532        1350 :   pari_datadir = os_getenv("GP_DATA_DIR");
     533        1350 :   if (!pari_datadir)
     534             :   {
     535             : #if defined(_WIN32) || defined(__CYGWIN32__)
     536             :     if (paricfg_datadir[0]=='@' && paricfg_datadir[1]==0)
     537             :       pari_datadir = win32_datadir();
     538             :     else
     539             : #endif
     540        1350 :       pari_datadir = pari_strdup(paricfg_datadir);
     541             :   }
     542           0 :   else pari_datadir= pari_strdup(pari_datadir);
     543        1350 :   for (i=0; i<c_LAST; i++) gp_colors[i] = c_NONE;
     544        1350 :   colormap = NULL; pari_graphcolors = NULL;
     545        1350 : }
     546             : 
     547             : /*********************************************************************/
     548             : /*                   FUNCTION HASHTABLES, MODULES                    */
     549             : /*********************************************************************/
     550             : extern entree functions_basic[], functions_default[];
     551             : static void
     552        1350 : pari_init_functions(void)
     553             : {
     554        1350 :   pari_stack_init(&s_MODULES, sizeof(*MODULES),(void**)&MODULES);
     555        1350 :   pari_stack_pushp(&s_MODULES,functions_basic);
     556        1350 :   functions_hash = (entree**) pari_calloc(sizeof(entree*)*functions_tblsz);
     557        1350 :   pari_fill_hashtable(functions_hash, functions_basic);
     558        1350 :   defaults_hash = (entree**) pari_calloc(sizeof(entree*)*functions_tblsz);
     559        1350 :   pari_add_defaults_module(functions_default);
     560        1350 : }
     561             : 
     562             : void
     563        2698 : pari_add_module(entree *ep)
     564             : {
     565        2698 :   pari_fill_hashtable(functions_hash, ep);
     566        2698 :   pari_stack_pushp(&s_MODULES, ep);
     567        2698 : }
     568             : 
     569             : void
     570        1350 : pari_add_defaults_module(entree *ep)
     571        1350 : { pari_fill_hashtable(defaults_hash, ep); }
     572             : 
     573             : /*********************************************************************/
     574             : /*                       PARI MAIN STACK                             */
     575             : /*********************************************************************/
     576             : 
     577             : #ifdef HAS_MMAP
     578             : #define PARI_STACK_ALIGN (sysconf(_SC_PAGE_SIZE))
     579             : #ifndef MAP_ANONYMOUS
     580             : #define MAP_ANONYMOUS MAP_ANON
     581             : #endif
     582             : #ifndef MAP_NORESERVE
     583             : #define MAP_NORESERVE 0
     584             : #endif
     585             : static void *
     586       64360 : pari_mainstack_malloc(size_t size)
     587             : {
     588       64360 :   void *b = mmap(NULL, size, PROT_READ|PROT_WRITE,
     589             :                              MAP_PRIVATE|MAP_ANONYMOUS|MAP_NORESERVE,-1,0);
     590       64360 :   return (b == MAP_FAILED) ? NULL: b;
     591             : }
     592             : 
     593             : static void
     594       64867 : pari_mainstack_mfree(void *s, size_t size)
     595             : {
     596       64867 :   munmap(s, size);
     597       64867 : }
     598             : 
     599             : static void
     600       68206 : pari_mainstack_mreset(void *s, size_t size)
     601             : {
     602       68206 :   madvise(s, size, MADV_DONTNEED);
     603       68206 : }
     604             : 
     605             : #else
     606             : #define PARI_STACK_ALIGN (0x40UL)
     607             : static void *
     608             : pari_mainstack_malloc(size_t s)
     609             : {
     610             :   return malloc(s); /* NOT pari_malloc, e_MEM would be deadly */
     611             : }
     612             : 
     613             : static void
     614             : pari_mainstack_mfree(void *s, size_t size) { (void) size; free(s); }
     615             : 
     616             : static void
     617             : pari_mainstack_mreset(void *s, size_t size) { (void) s; (void) size; }
     618             : 
     619             : #endif
     620             : 
     621             : static const size_t MIN_STACK = 500032UL;
     622             : static size_t
     623      129227 : fix_size(size_t a)
     624             : {
     625      129227 :   size_t ps = PARI_STACK_ALIGN;
     626      129227 :   size_t b = a & ~(ps - 1); /* Align */
     627      129227 :   if (b < a && b < ~(ps - 1)) b += ps;
     628      129227 :   if (b < MIN_STACK) b = MIN_STACK;
     629      129227 :   return b;
     630             : }
     631             : 
     632             : static void
     633       64360 : pari_mainstack_alloc(struct pari_mainstack *st, size_t rsize, size_t vsize)
     634             : {
     635       64360 :   size_t sizemax = vsize ? vsize: rsize, s = fix_size(sizemax);
     636             :   for (;;)
     637             :   {
     638       64360 :     st->vbot = (pari_sp)pari_mainstack_malloc(s);
     639       64360 :     if (st->vbot) break;
     640           0 :     if (s == MIN_STACK) pari_err(e_MEM); /* no way out. Die */
     641           0 :     s = fix_size(s >> 1);
     642           0 :     pari_warn(warnstack, s);
     643           0 :   }
     644       64360 :   st->vsize = vsize ? s: 0;
     645       64360 :   st->rsize = minuu(rsize, s);
     646       64360 :   st->size = st->rsize;
     647       64360 :   st->top = st->vbot+s;
     648       64360 :   st->bot = st->top - st->size;
     649       64360 :   st->memused = 0;
     650       64360 : }
     651             : 
     652             : static void
     653       64867 : pari_mainstack_free(struct pari_mainstack *st)
     654             : {
     655       64867 :   pari_mainstack_mfree((void*)st->vbot, st->vsize ? st->vsize : fix_size(st->rsize));
     656       64867 :   st->top = st->bot = st->vbot = 0;
     657       64867 :   st->size = st->vsize =0;
     658       64867 : }
     659             : 
     660             : static void
     661         162 : pari_mainstack_resize(struct pari_mainstack *st, size_t rsize, size_t vsize)
     662             : {
     663         162 :   BLOCK_SIGINT_START;
     664         162 :   pari_mainstack_free(st);
     665         162 :   pari_mainstack_alloc(st, rsize, vsize);
     666         162 :   BLOCK_SIGINT_END;
     667         162 : }
     668             : 
     669             : static void
     670       62836 : pari_mainstack_use(struct pari_mainstack *st)
     671             : {
     672       62836 :   pari_mainstack = st;
     673       62836 :   avma = st->top;
     674       62836 : }
     675             : 
     676             : static void
     677        1350 : paristack_alloc(size_t rsize, size_t vsize)
     678             : {
     679        1350 :   pari_mainstack_alloc(pari_mainstack, rsize, vsize);
     680        1350 :   pari_mainstack_use(pari_mainstack);
     681        1350 : }
     682             : 
     683             : void
     684           0 : paristack_setsize(size_t rsize, size_t vsize)
     685             : {
     686           0 :   pari_mainstack_resize(pari_mainstack, rsize, vsize);
     687           0 :   pari_mainstack_use(pari_mainstack);
     688           0 : }
     689             : 
     690             : void
     691           0 : parivstack_resize(ulong newsize)
     692             : {
     693             :   size_t s;
     694           0 :   if (newsize && newsize < pari_mainstack->rsize)
     695           0 :     pari_err_DIM("stack sizes [parisizemax < parisize]");
     696           0 :   if (newsize == pari_mainstack->vsize) return;
     697           0 :   evalstate_reset();
     698           0 :   paristack_setsize(pari_mainstack->rsize, newsize);
     699           0 :   s = pari_mainstack->vsize ? pari_mainstack->vsize : pari_mainstack->rsize;
     700           0 :   pari_warn(warner,"new maximum stack size = %lu (%.3f Mbytes)", s, s/1048576.);
     701           0 :   pari_init_errcatch();
     702           0 :   cb_pari_err_recover(-1);
     703             : }
     704             : 
     705             : void
     706         168 : paristack_newrsize(ulong newsize)
     707             : {
     708         168 :   size_t s, vsize = pari_mainstack->vsize;
     709         168 :   if (!newsize) newsize = pari_mainstack->rsize << 1;
     710         168 :   if (newsize != pari_mainstack->rsize)
     711         162 :     pari_mainstack_resize(pari_mainstack, newsize, vsize);
     712         168 :   evalstate_reset();
     713         168 :   s = pari_mainstack->rsize;
     714         168 :   pari_warn(warner,"new stack size = %lu (%.3f Mbytes)", s, s/1048576.);
     715         168 :   pari_init_errcatch();
     716         168 :   cb_pari_err_recover(-1);
     717           0 : }
     718             : 
     719             : void
     720           0 : paristack_resize(ulong newsize)
     721             : {
     722           0 :   size_t vsize = pari_mainstack->vsize;
     723           0 :   if (!newsize)
     724           0 :     newsize = pari_mainstack->size << 1;
     725           0 :   newsize = maxuu(minuu(newsize, vsize), pari_mainstack->size);
     726           0 :   pari_mainstack->size = newsize;
     727           0 :   pari_mainstack->bot = pari_mainstack->top - pari_mainstack->size;
     728           0 :   pari_warn(warner,"increasing stack size to %lu",newsize);
     729           0 : }
     730             : 
     731             : void
     732       68206 : parivstack_reset(void)
     733             : {
     734       68206 :   pari_mainstack->size = pari_mainstack->rsize;
     735       68206 :   pari_mainstack->bot = pari_mainstack->top - pari_mainstack->size;
     736       68206 :   pari_mainstack_mreset((void *)pari_mainstack->vbot,
     737       68206 :                         pari_mainstack->bot-pari_mainstack->vbot);
     738       68206 : }
     739             : 
     740             : void
     741           0 : new_chunk_resize(size_t x)
     742             : {
     743           0 :   if (pari_mainstack->vsize==0
     744           0 :     || x > (avma-pari_mainstack->vbot) / sizeof(long)) pari_err(e_STACK);
     745           0 :   while (x > (avma-pari_mainstack->bot) / sizeof(long))
     746           0 :     paristack_resize(0);
     747           0 : }
     748             : 
     749             : /*********************************************************************/
     750             : /*                       PARI THREAD                                 */
     751             : /*********************************************************************/
     752             : 
     753             : /* Initial PARI thread structure t with a stack of size s and virtual size v
     754             :  * and argument arg */
     755             : 
     756             : void
     757           0 : pari_thread_valloc(struct pari_thread *t, size_t s, size_t v, GEN arg)
     758             : {
     759           0 :   pari_mainstack_alloc(&t->st,s,v);
     760           0 :   t->data = arg;
     761           0 : }
     762             : 
     763             : /* Initial PARI thread structure t with a stack of size s and
     764             :  * argument arg */
     765             : 
     766             : void
     767       62848 : pari_thread_alloc(struct pari_thread *t, size_t s, GEN arg)
     768             : {
     769       62848 :   pari_mainstack_alloc(&t->st,s,0);
     770       62848 :   t->data = arg;
     771       62848 : }
     772             : 
     773             : void
     774       62848 : pari_thread_free(struct pari_thread *t)
     775             : {
     776       62848 :   pari_mainstack_free(&t->st);
     777       62848 : }
     778             : 
     779             : void
     780       62744 : pari_thread_init(void)
     781             : {
     782       62744 :   pari_init_blocks();
     783       63180 :   pari_init_errcatch();
     784       62867 :   pari_init_rand();
     785       64036 :   pari_init_floats();
     786       64025 :   pari_init_parser();
     787       64065 :   pari_init_compiler();
     788       64006 :   pari_init_evaluator();
     789       63877 :   pari_init_files();
     790       63676 :   pari_thread_init_seadata();
     791       63614 : }
     792             : 
     793             : void
     794        3928 : pari_thread_sync(void)
     795             : {
     796        3928 :   pari_pthread_init_varstate();
     797        3928 :   pari_pthread_init_seadata();
     798        3928 : }
     799             : 
     800             : void
     801       64577 : pari_thread_close(void)
     802             : {
     803       64577 :   pari_thread_close_files();
     804       64586 :   pari_close_evaluator();
     805       64556 :   pari_close_compiler();
     806       64504 :   pari_close_parser();
     807       64452 :   pari_close_floats();
     808       64396 :   pari_close_blocks();
     809       64062 : }
     810             : 
     811             : GEN
     812       61490 : pari_thread_start(struct pari_thread *t)
     813             : {
     814       61490 :   pari_mainstack_use(&t->st);
     815       61366 :   pari_thread_init();
     816       62229 :   pari_thread_init_varstate();
     817       62808 :   return t->data;
     818             : }
     819             : 
     820             : /*********************************************************************/
     821             : /*                       LIBPARI INIT / CLOSE                        */
     822             : /*********************************************************************/
     823             : 
     824             : static void
     825           0 : pari_exit(void)
     826             : {
     827           0 :   err_printf("  ***   Error in the PARI system. End of program.\n");
     828           0 :   exit(1);
     829             : }
     830             : 
     831             : static void
     832           0 : dflt_err_recover(long errnum) { (void) errnum; pari_exit(); }
     833             : 
     834             : static void
     835           0 : dflt_pari_quit(long err) { (void)err; /*do nothing*/; }
     836             : 
     837             : static int pari_err_display(GEN err);
     838             : 
     839             : /* initialize PARI data. Initialize [new|old]fun to NULL for default set. */
     840             : void
     841        1350 : pari_init_opts(size_t parisize, ulong maxprime, ulong init_opts)
     842             : {
     843             :   ulong u;
     844             : 
     845        1350 :   pari_mt_nbthreads = 0;
     846        1350 :   cb_pari_quit = dflt_pari_quit;
     847        1350 :   cb_pari_init_histfile = NULL;
     848        1350 :   cb_pari_get_line_interactive = NULL;
     849        1350 :   cb_pari_fgets_interactive = NULL;
     850        1350 :   cb_pari_whatnow = NULL;
     851        1350 :   cb_pari_handle_exception = NULL;
     852        1350 :   cb_pari_err_handle = pari_err_display;
     853        1350 :   cb_pari_pre_recover = NULL;
     854        1350 :   cb_pari_break_loop = NULL;
     855        1350 :   cb_pari_is_interactive = NULL;
     856        1350 :   cb_pari_start_output = NULL;
     857        1350 :   cb_pari_sigint = dflt_sigint_fun;
     858        1350 :   if (init_opts&INIT_JMPm) cb_pari_err_recover = dflt_err_recover;
     859             : 
     860        1350 :   pari_stackcheck_init(&u);
     861        1350 :   pari_init_homedir();
     862        1350 :   if (init_opts&INIT_DFTm) {
     863           0 :     pari_init_defaults();
     864           0 :     GP_DATA = default_gp_data();
     865           0 :     gp_expand_path(GP_DATA->path);
     866             :   }
     867             : 
     868        1350 :   pari_mainstack = (struct pari_mainstack *) malloc(sizeof(*pari_mainstack));
     869        1350 :   paristack_alloc(parisize, 0);
     870        1350 :   init_universal_constants();
     871        1350 :   diffptr = NULL;
     872        1350 :   if (!(init_opts&INIT_noPRIMEm))  pari_init_primes(maxprime);
     873        1350 :   if (!(init_opts&INIT_noINTGMPm)) pari_kernel_init();
     874             : 
     875        1350 :   primetab = cgetalloc(t_VEC, 1);
     876        1350 :   pari_init_seadata();
     877        1350 :   pari_thread_init();
     878        1350 :   pari_init_functions();
     879        1350 :   pari_var_init();
     880        1350 :   pari_init_timer();
     881        1350 :   pari_init_buffers();
     882        1350 :   (void)getabstime();
     883        1350 :   try_to_recover = 1;
     884        1350 :   if (!(init_opts&INIT_noIMTm)) pari_mt_init();
     885        1350 :   if ((init_opts&INIT_SIGm)) pari_sig_init(pari_sighandler);
     886        1350 : }
     887             : 
     888             : void
     889           0 : pari_init(size_t parisize, ulong maxprime)
     890           0 : { pari_init_opts(parisize, maxprime, INIT_JMPm | INIT_SIGm | INIT_DFTm); }
     891             : 
     892             : void
     893        1857 : pari_close_opts(ulong init_opts)
     894             : {
     895             :   long i;
     896             : 
     897        1857 :   BLOCK_SIGINT_START;
     898        1857 :   if ((init_opts&INIT_SIGm)) pari_sig_init(SIG_DFL);
     899        1857 :   if (!(init_opts&INIT_noIMTm)) pari_mt_close();
     900             : 
     901      252552 :   for (i = 0; i < functions_tblsz; i++)
     902             :   {
     903      250695 :     entree *ep = functions_hash[i];
     904     2343116 :     while (ep) {
     905     1841726 :       entree *EP = ep->next;
     906     1841726 :       if (!EpSTATIC(ep)) { freeep(ep); free(ep); }
     907     1841726 :       ep = EP;
     908             :     }
     909             :   }
     910        1857 :   pari_var_close();
     911        1857 :   free((void*)primetab);
     912        1857 :   pari_thread_close();
     913        1857 :   pari_close_files();
     914        1857 :   pari_close_homedir();
     915        1857 :   pari_kernel_close();
     916             : 
     917        1857 :   free((void*)functions_hash);
     918        1857 :   free((void*)defaults_hash);
     919        1857 :   if (diffptr) pari_close_primes();
     920        1857 :   free(current_logfile);
     921        1857 :   free(current_psfile);
     922        1857 :   pari_mainstack_free(pari_mainstack);
     923        1857 :   free((void*)pari_mainstack);
     924        1857 :   pari_stack_delete(&s_MODULES);
     925        1857 :   if (pari_datadir) free(pari_datadir);
     926        1857 :   if (init_opts&INIT_DFTm)
     927             :   { /* delete GP_DATA */
     928        1857 :     if (GP_DATA->hist->v) free((void*)GP_DATA->hist->v);
     929        1857 :     if (GP_DATA->pp->cmd) free((void*)GP_DATA->pp->cmd);
     930        1857 :     delete_dirs(GP_DATA->path);
     931        1857 :     free((void*)GP_DATA->path->PATH);
     932        1857 :     delete_dirs(GP_DATA->sopath);
     933        1857 :     free((void*)GP_DATA->sopath->PATH);
     934        1857 :     if (GP_DATA->help) free((void*)GP_DATA->help);
     935        1857 :     free((void*)GP_DATA->prompt);
     936        1857 :     free((void*)GP_DATA->prompt_cont);
     937        1857 :     free((void*)GP_DATA->histfile);
     938             :   }
     939        1857 :   BLOCK_SIGINT_END;
     940        1857 : }
     941             : 
     942             : void
     943        1857 : pari_close(void)
     944        1857 : { pari_close_opts(INIT_JMPm | INIT_SIGm | INIT_DFTm); }
     945             : 
     946             : /*******************************************************************/
     947             : /*                                                                 */
     948             : /*                         ERROR RECOVERY                          */
     949             : /*                                                                 */
     950             : /*******************************************************************/
     951             : void
     952       82185 : gp_context_save(struct gp_context* rec)
     953             : {
     954       82185 :   rec->file = pari_last_tmp_file();
     955       82185 :   if (DEBUGFILES>1)
     956           0 :     err_printf("gp_context_save: %s\n", rec->file ? rec->file->name: "NULL");
     957       82185 :   rec->prettyp = GP_DATA->fmt->prettyp;
     958       82185 :   rec->listloc = next_block;
     959       82185 :   rec->iferr_env = iferr_env;
     960       82185 :   rec->err_data  = global_err_data;
     961       82185 :   varstate_save(&rec->var);
     962       82185 :   evalstate_save(&rec->eval);
     963       82185 :   parsestate_save(&rec->parse);
     964       82185 : }
     965             : 
     966             : void
     967       15917 : gp_context_restore(struct gp_context* rec)
     968             : {
     969             :   long i;
     970             : 
     971       31834 :   if (!try_to_recover) return;
     972             :   /* disable gp_context_restore() and SIGINT */
     973       15917 :   try_to_recover = 0;
     974       15917 :   BLOCK_SIGINT_START
     975       15917 :   if (DEBUGMEM>2) err_printf("entering recover(), loc = %ld\n", rec->listloc);
     976       15917 :   evalstate_restore(&rec->eval);
     977       15917 :   parsestate_restore(&rec->parse);
     978       15917 :   filestate_restore(rec->file);
     979       15917 :   global_err_data = rec->err_data;
     980       15917 :   iferr_env = rec->iferr_env;
     981       15917 :   GP_DATA->fmt->prettyp = rec->prettyp;
     982             : 
     983     2164712 :   for (i = 0; i < functions_tblsz; i++)
     984             :   {
     985     2148795 :     entree *ep = functions_hash[i];
     986    20682018 :     while (ep)
     987             :     {
     988    16384428 :       entree *EP = ep->next;
     989    16384428 :       switch(EpVALENCE(ep))
     990             :       {
     991             :         case EpVAR:
     992      164460 :           while (pop_val_if_newer(ep,rec->listloc)) /* empty */;
     993      164460 :           break;
     994      637225 :         case EpNEW: break;
     995             :       }
     996    16384428 :       ep = EP;
     997             :     }
     998             :   }
     999       15917 :   varstate_restore(&rec->var);
    1000       15917 :   if (DEBUGMEM>2) err_printf("leaving recover()\n");
    1001       15917 :   BLOCK_SIGINT_END
    1002       15917 :   try_to_recover = 1;
    1003             : }
    1004             : 
    1005             : static void
    1006       15861 : err_recover(long numerr)
    1007             : {
    1008       15861 :   if (cb_pari_pre_recover)
    1009       15861 :     cb_pari_pre_recover(numerr);
    1010           0 :   evalstate_reset();
    1011           0 :   killallfiles();
    1012           0 :   pari_init_errcatch();
    1013           0 :   cb_pari_err_recover(numerr);
    1014           0 : }
    1015             : 
    1016             : static void
    1017       16288 : err_init(void)
    1018             : {
    1019             :   /* make sure pari_err msg starts at the beginning of line */
    1020       16288 :   if (!pari_last_was_newline()) pari_putc('\n');
    1021       16288 :   pariOut->flush();
    1022       16288 :   pariErr->flush();
    1023       16288 :   out_term_color(pariErr, c_ERR);
    1024       16288 : }
    1025             : 
    1026             : static void
    1027       16260 : err_init_msg(int user)
    1028             : {
    1029             :   const char *gp_function_name;
    1030       16260 :   out_puts(pariErr, "  *** ");
    1031       16260 :   if (!user && (gp_function_name = closure_func_err()))
    1032       11479 :     out_printf(pariErr, "%s: ", gp_function_name);
    1033             :   else
    1034        4781 :     out_puts(pariErr, "  ");
    1035       16260 : }
    1036             : 
    1037             : void
    1038         406 : pari_warn(int numerr, ...)
    1039             : {
    1040             :   char *ch1;
    1041             :   va_list ap;
    1042             : 
    1043         406 :   va_start(ap,numerr);
    1044             : 
    1045         406 :   err_init();
    1046         406 :   err_init_msg(numerr==warnuser || numerr==warnstack);
    1047         406 :   switch (numerr)
    1048             :   {
    1049             :     case warnuser:
    1050           7 :       out_puts(pariErr, "user warning: ");
    1051           7 :       out_print0(pariErr, NULL, va_arg(ap, GEN), f_RAW);
    1052           7 :       break;
    1053             : 
    1054             :     case warnmem:
    1055           0 :       out_puts(pariErr, "collecting garbage in "); ch1=va_arg(ap, char*);
    1056           0 :       out_vprintf(pariErr, ch1,ap); out_putc(pariErr, '.');
    1057           0 :       break;
    1058             : 
    1059             :     case warner:
    1060         399 :       out_puts(pariErr, "Warning: "); ch1=va_arg(ap, char*);
    1061         399 :       out_vprintf(pariErr, ch1,ap); out_putc(pariErr, '.');
    1062         399 :       break;
    1063             : 
    1064             :     case warnprec:
    1065           0 :       out_vprintf(pariErr, "Warning: increasing prec in %s; new prec = %ld",
    1066             :                       ap);
    1067           0 :       break;
    1068             : 
    1069             :     case warnfile:
    1070           0 :       out_puts(pariErr, "Warning: failed to "),
    1071           0 :       ch1 = va_arg(ap, char*);
    1072           0 :       out_printf(pariErr, "%s: %s", ch1, va_arg(ap, char*));
    1073           0 :       break;
    1074             : 
    1075             :     case warnstack:
    1076             :     {
    1077           0 :       ulong  s = va_arg(ap, ulong);
    1078             :       char buf[128];
    1079           0 :       sprintf(buf,"Warning: not enough memory, new stack %lu", (ulong)s);
    1080           0 :       out_puts(pariErr,buf);
    1081           0 :       break;
    1082             :     }
    1083             : 
    1084             :   }
    1085         406 :   va_end(ap);
    1086         406 :   out_term_color(pariErr, c_NONE);
    1087         406 :   out_putc(pariErr, '\n');
    1088         406 :   pariErr->flush();
    1089         406 : }
    1090             : void
    1091           0 : pari_sigint(const char *time_s)
    1092             : {
    1093           0 :   int recover=0;
    1094           0 :   BLOCK_SIGALRM_START
    1095           0 :   err_init();
    1096           0 :   closure_err(0);
    1097           0 :   err_init_msg(0);
    1098           0 :   out_puts(pariErr, "user interrupt after ");
    1099           0 :   out_puts(pariErr, time_s);
    1100           0 :   out_term_color(pariErr, c_NONE);
    1101           0 :   pariErr->flush();
    1102           0 :   if (cb_pari_handle_exception)
    1103           0 :     recover = cb_pari_handle_exception(-1);
    1104           0 :   if (!recover && !block)
    1105           0 :     PARI_SIGINT_pending = 0;
    1106           0 :   BLOCK_SIGINT_END
    1107           0 :   if (!recover) err_recover(e_MISC);
    1108           0 : }
    1109             : 
    1110             : #define retmkerr2(x,y)\
    1111             :   do { GEN _v = cgetg(3, t_ERROR);\
    1112             :        _v[1] = (x);\
    1113             :        gel(_v,2) = (y); return _v; } while(0)
    1114             : #define retmkerr3(x,y,z)\
    1115             :   do { GEN _v = cgetg(4, t_ERROR);\
    1116             :        _v[1] = (x);\
    1117             :        gel(_v,2) = (y);\
    1118             :        gel(_v,3) = (z); return _v; } while(0)
    1119             : #define retmkerr4(x,y,z,t)\
    1120             :   do { GEN _v = cgetg(5, t_ERROR);\
    1121             :        _v[1] = (x);\
    1122             :        gel(_v,2) = (y);\
    1123             :        gel(_v,3) = (z);\
    1124             :        gel(_v,4) = (t); return _v; } while(0)
    1125             : #define retmkerr5(x,y,z,t,u)\
    1126             :   do { GEN _v = cgetg(6, t_ERROR);\
    1127             :        _v[1] = (x);\
    1128             :        gel(_v,2) = (y);\
    1129             :        gel(_v,3) = (z);\
    1130             :        gel(_v,4) = (t);\
    1131             :        gel(_v,5) = (u); return _v; } while(0)
    1132             : #define retmkerr6(x,y,z,t,u,v)\
    1133             :   do { GEN _v = cgetg(7, t_ERROR);\
    1134             :        _v[1] = (x);\
    1135             :        gel(_v,2) = (y);\
    1136             :        gel(_v,3) = (z);\
    1137             :        gel(_v,4) = (t);\
    1138             :        gel(_v,5) = (u);\
    1139             :        gel(_v,6) = (v); return _v; } while(0)
    1140             : 
    1141             : static GEN
    1142       30435 : pari_err2GEN(long numerr, va_list ap)
    1143             : {
    1144       30435 :   switch ((enum err_list) numerr)
    1145             :   {
    1146             :   case e_SYNTAX:
    1147             :     {
    1148          28 :       const char *msg = va_arg(ap, char*);
    1149          28 :       const char *s = va_arg(ap,char *);
    1150          28 :       const char *entry = va_arg(ap,char *);
    1151          28 :       retmkerr3(numerr,strtoGENstr(msg), mkvecsmall2((long)s,(long)entry));
    1152             :     }
    1153             :   case e_MISC: case e_ALARM:
    1154             :     {
    1155        2678 :       const char *ch1 = va_arg(ap, char*);
    1156        2678 :       retmkerr2(numerr, gvsprintf(ch1,ap));
    1157             :     }
    1158             :   case e_NOTFUNC:
    1159             :   case e_USER:
    1160        2730 :     retmkerr2(numerr,va_arg(ap, GEN));
    1161             :   case e_FILE:
    1162             :     {
    1163           0 :       const char *f = va_arg(ap, const char*);
    1164           0 :       retmkerr3(numerr, strtoGENstr(f), strtoGENstr(va_arg(ap, char*)));
    1165             :     }
    1166             :   case e_OVERFLOW:
    1167             :   case e_IMPL:
    1168             :   case e_DIM:
    1169             :   case e_CONSTPOL:
    1170             :   case e_ROOTS0:
    1171             :   case e_FLAG:
    1172             :   case e_PREC:
    1173             :   case e_BUG:
    1174             :   case e_ARCH:
    1175             :   case e_PACKAGE:
    1176        1542 :     retmkerr2(numerr, strtoGENstr(va_arg(ap, char*)));
    1177             :   case e_MODULUS:
    1178             :   case e_VAR:
    1179             :     {
    1180         924 :       const char *f = va_arg(ap, const char*);
    1181         924 :       GEN x = va_arg(ap, GEN);
    1182         924 :       GEN y = va_arg(ap, GEN);
    1183         924 :       retmkerr4(numerr, strtoGENstr(f), x,y);
    1184             :     }
    1185             :   case e_INV:
    1186             :   case e_IRREDPOL:
    1187             :   case e_PRIME:
    1188             :   case e_SQRTN:
    1189             :   case e_TYPE:
    1190             :     {
    1191       13734 :       const char *f = va_arg(ap, const char*);
    1192       13734 :       GEN x = va_arg(ap, GEN);
    1193       13734 :       retmkerr3(numerr, strtoGENstr(f), x);
    1194             :     }
    1195             :   case e_COPRIME: case e_OP: case e_TYPE2:
    1196             :     {
    1197        3360 :       const char *f = va_arg(ap, const char*);
    1198        3360 :       GEN x = va_arg(ap, GEN);
    1199        3360 :       GEN y = va_arg(ap, GEN);
    1200        3360 :       retmkerr4(numerr,strtoGENstr(f),x,y);
    1201             :     }
    1202             :   case e_COMPONENT:
    1203             :     {
    1204         224 :       const char *f= va_arg(ap, const char *);
    1205         224 :       const char *op = va_arg(ap, const char *);
    1206         224 :       GEN l = va_arg(ap, GEN);
    1207         224 :       GEN x = va_arg(ap, GEN);
    1208         224 :       retmkerr5(numerr,strtoGENstr(f),strtoGENstr(op),l,x);
    1209             :     }
    1210             :   case e_DOMAIN:
    1211             :     {
    1212        5096 :       const char *f = va_arg(ap, const char*);
    1213        5096 :       const char *v = va_arg(ap, const char *);
    1214        5096 :       const char *op = va_arg(ap, const char *);
    1215        5096 :       GEN l = va_arg(ap, GEN);
    1216        5096 :       GEN x = va_arg(ap, GEN);
    1217        5096 :       retmkerr6(numerr,strtoGENstr(f),strtoGENstr(v),strtoGENstr(op),l,x);
    1218             :     }
    1219             :   case e_PRIORITY:
    1220             :     {
    1221         119 :       const char *f = va_arg(ap, const char*);
    1222         119 :       GEN x = va_arg(ap, GEN);
    1223         119 :       const char *op = va_arg(ap, const char *);
    1224         119 :       long v = va_arg(ap, long);
    1225         119 :       retmkerr5(numerr,strtoGENstr(f),x,strtoGENstr(op),stoi(v));
    1226             :     }
    1227             :   case e_MAXPRIME:
    1228           0 :     retmkerr2(numerr, utoi(va_arg(ap, ulong)));
    1229             :   case e_STACK:
    1230           0 :     return err_e_STACK;
    1231             :   case e_STACKTHREAD:
    1232           0 :     retmkerr3(numerr, utoi(va_arg(ap, ulong)), utoi(va_arg(ap, ulong)));
    1233             :   default:
    1234           0 :     return mkerr(numerr);
    1235             :   }
    1236             : }
    1237             : 
    1238             : static char *
    1239        6132 : type_dim(GEN x)
    1240             : {
    1241        6132 :   char *v = stack_malloc(64);
    1242        6132 :   switch(typ(x))
    1243             :   {
    1244             :     case t_MAT:
    1245             :     {
    1246          63 :       long l = lg(x), r = (l == 1)? 1: lgcols(x);
    1247          63 :       sprintf(v, "t_MAT (%ldx%ld)", r-1,l-1);
    1248          63 :       break;
    1249             :     }
    1250             :     case t_COL:
    1251          91 :       sprintf(v, "t_COL (%ld elts)", lg(x)-1);
    1252          91 :       break;
    1253             :     case t_VEC:
    1254         133 :       sprintf(v, "t_VEC (%ld elts)", lg(x)-1);
    1255         133 :       break;
    1256             :     default:
    1257        5845 :       v = (char*)type_name(typ(x));
    1258             :   }
    1259        6132 :   return v;
    1260             : }
    1261             : 
    1262             : static char *
    1263        2219 : gdisplay(GEN x)
    1264             : {
    1265        2219 :   char *s = GENtostr_raw(x);
    1266        2219 :   if (strlen(s) < 1600) return s;
    1267          21 :   if (! GP_DATA->breakloop) return (char*)"(...)";
    1268           0 :   return stack_sprintf("\n  ***  (...) Huge %s omitted; you can access it via dbg_err()", type_name(typ(x)));
    1269             : }
    1270             : 
    1271             : char *
    1272       22721 : pari_err2str(GEN e)
    1273             : {
    1274       22721 :   long numerr = err_get_num(e);
    1275       22721 :   switch ((enum err_list) numerr)
    1276             :   {
    1277             :   case e_ALARM:
    1278           0 :     return pari_sprintf("alarm interrupt after %Ps.",gel(e,2));
    1279             :   case e_MISC:
    1280        2676 :     return pari_sprintf("%Ps.",gel(e,2));
    1281             : 
    1282             :   case e_ARCH:
    1283           0 :     return pari_sprintf("sorry, '%Ps' not available on this system.",gel(e,2));
    1284             :   case e_BUG:
    1285          14 :     return pari_sprintf("bug in %Ps, please report.",gel(e,2));
    1286             :   case e_CONSTPOL:
    1287           7 :     return pari_sprintf("constant polynomial in %Ps.", gel(e,2));
    1288             :   case e_COPRIME:
    1289         189 :     return pari_sprintf("elements not coprime in %Ps:\n    %s\n    %s",
    1290         189 :                         gel(e,2), gdisplay(gel(e,3)), gdisplay(gel(e,4)));
    1291             :   case e_DIM:
    1292         918 :     return pari_sprintf("inconsistent dimensions in %Ps.", gel(e,2));
    1293             :   case e_FILE:
    1294           0 :     return pari_sprintf("error opening %Ps: `%Ps'.", gel(e,2), gel(e,3));
    1295             :   case e_FLAG:
    1296          14 :     return pari_sprintf("invalid flag in %Ps.", gel(e,2));
    1297             :   case e_IMPL:
    1298         224 :     return pari_sprintf("sorry, %Ps is not yet implemented.", gel(e,2));
    1299             :   case e_PACKAGE:
    1300           0 :     return pari_sprintf("package %Ps is required, please install it.", gel(e,2));
    1301             :   case e_INV:
    1302         483 :     return pari_sprintf("impossible inverse in %Ps: %s.", gel(e,2),
    1303         483 :                         gdisplay(gel(e,3)));
    1304             :   case e_IRREDPOL:
    1305          42 :     return pari_sprintf("not an irreducible polynomial in %Ps: %s.",
    1306          42 :                         gel(e,2), gdisplay(gel(e,3)));
    1307             :   case e_MAXPRIME:
    1308             :     {
    1309           0 :       const char * msg = "not enough precomputed primes";
    1310           0 :       ulong c = itou(gel(e,2));
    1311           0 :       if (c) return pari_sprintf("%s, need primelimit ~ %lu.",msg, c);
    1312           0 :       else   return pari_strdup(msg);
    1313             :     }
    1314             :   case e_MEM:
    1315           0 :     return pari_strdup("not enough memory");
    1316             :   case e_MODULUS:
    1317             :     {
    1318         728 :       GEN x = gel(e,3), y = gel(e,4);
    1319        1456 :       return pari_sprintf("inconsistent moduli in %Ps: %s != %s",
    1320         728 :                           gel(e,2), gdisplay(x), gdisplay(y));
    1321             :     }
    1322           0 :   case e_NONE: return NULL;
    1323             :   case e_NOTFUNC:
    1324        2716 :     return pari_strdup("not a function in function call");
    1325             :   case e_OP: case e_TYPE2:
    1326             :     {
    1327        3066 :       pari_sp av = avma;
    1328             :       char *v;
    1329        3066 :       const char *f, *op = GSTR(gel(e,2));
    1330        3066 :       const char *what = numerr == e_OP? "inconsistent": "forbidden";
    1331        3066 :       GEN x = gel(e,3);
    1332        3066 :       GEN y = gel(e,4);
    1333        3066 :       switch(*op)
    1334             :       {
    1335           7 :       case '+': f = "addition"; break;
    1336          49 :       case '*': f = "multiplication"; break;
    1337        2387 :       case '/': case '%': case '\\': f = "division"; break;
    1338           0 :       case '=': op = "-->"; f = "assignment"; break;
    1339         623 :       default:  f = op; op = ","; break;
    1340             :       }
    1341        3066 :       v = pari_sprintf("%s %s %s %s %s.", what,f,type_dim(x),op,type_dim(y));
    1342        3066 :       avma = av; return v;
    1343             :     }
    1344             :   case e_COMPONENT:
    1345             :     {
    1346         224 :       const char *f= GSTR(gel(e,2));
    1347         224 :       const char *op= GSTR(gel(e,3));
    1348         224 :       GEN l = gel(e,4);
    1349         224 :       if (!*f)
    1350         126 :         return pari_sprintf("non-existent component: index %s %Ps",op,l);
    1351          98 :       return pari_sprintf("non-existent component in %s: index %s %Ps",f,op,l);
    1352             :     }
    1353             :   case e_DOMAIN:
    1354             :     {
    1355        4998 :       const char *f = GSTR(gel(e,2));
    1356        4998 :       const char *v = GSTR(gel(e,3));
    1357        4998 :       const char *op= GSTR(gel(e,4));
    1358        4998 :       GEN l = gel(e,5);
    1359        4998 :       if (!*op)
    1360          28 :         return pari_sprintf("domain error in %s: %s out of range",f,v);
    1361        4970 :       return pari_sprintf("domain error in %s: %s %s %Ps",f,v,op,l);
    1362             :     }
    1363             :   case e_PRIORITY:
    1364             :     {
    1365          70 :       const char *f = GSTR(gel(e,2));
    1366          70 :       long vx = gvar(gel(e,3));
    1367          70 :       const char *op= GSTR(gel(e,4));
    1368          70 :       long v = itos(gel(e,5));
    1369          70 :       return pari_sprintf("incorrect priority in %s: variable %Ps %s %Ps",f,
    1370             :              pol_x(vx), op, pol_x(v));
    1371             :     }
    1372             :   case e_OVERFLOW:
    1373          70 :     return pari_sprintf("overflow in %Ps.", gel(e,2));
    1374             :   case e_PREC:
    1375         217 :     return pari_sprintf("precision too low in %Ps.", gel(e,2));
    1376             :   case e_PRIME:
    1377         112 :     return pari_sprintf("not a prime number in %Ps: %s.",
    1378         112 :                         gel(e,2), gdisplay(gel(e,3)));
    1379             :   case e_ROOTS0:
    1380          35 :     return pari_sprintf("zero polynomial in %Ps.", gel(e,2));
    1381             :   case e_SQRTN:
    1382         154 :     return pari_sprintf("not an n-th power residue in %Ps: %s.",
    1383         154 :                         gel(e,2), gdisplay(gel(e,3)));
    1384             :   case e_STACK:
    1385             :   case e_STACKTHREAD:
    1386             :     {
    1387           0 :       const char *stack = numerr == e_STACK? "PARI": "thread";
    1388           0 :       const char *var = numerr == e_STACK? "parisizemax": "threadsizemax";
    1389           0 :       size_t rsize = numerr == e_STACKTHREAD && GP_DATA->threadsize ?
    1390           0 :                                 GP_DATA->threadsize: pari_mainstack->rsize;
    1391           0 :       size_t vsize = numerr == e_STACK? pari_mainstack->vsize:
    1392           0 :                                         GP_DATA->threadsizemax;
    1393           0 :       char *buf = (char *) pari_malloc(512*sizeof(char));
    1394           0 :       if (vsize)
    1395             :       {
    1396           0 :         sprintf(buf, "the %s stack overflows !\n"
    1397             :             "  current stack size: %lu (%.3f Mbytes)\n"
    1398             :             "  [hint] you can increase '%s' using default()\n",
    1399           0 :             stack, (ulong)vsize, (double)vsize/1048576., var);
    1400             :       }
    1401             :       else
    1402             :       {
    1403           0 :         sprintf(buf, "the %s stack overflows !\n"
    1404             :             "  current stack size: %lu (%.3f Mbytes)\n"
    1405             :             "  [hint] set '%s' to a non-zero value in your GPRC\n",
    1406           0 :             stack, (ulong)rsize, (double)rsize/1048576., var);
    1407             :       }
    1408           0 :       return buf;
    1409             :     }
    1410             :   case e_SYNTAX:
    1411           0 :     return pari_strdup(GSTR(gel(e,2)));
    1412             :   case e_TYPE:
    1413       11668 :     return pari_sprintf("incorrect type in %Ps (%s).",
    1414       11668 :                         gel(e,2), type_name(typ(gel(e,3))));
    1415             :   case e_USER:
    1416          14 :     return pari_sprint0("user error: ", gel(e,2), f_RAW);
    1417             :   case e_VAR:
    1418             :     {
    1419         196 :       GEN x = gel(e,3), y = gel(e,4);
    1420         588 :       return pari_sprintf("inconsistent variables in %Ps, %Ps != %Ps.",
    1421         588 :                           gel(e,2), pol_x(varn(x)), pol_x(varn(y)));
    1422             :     }
    1423             :   }
    1424           0 :   return NULL; /*NOT REACHED*/
    1425             : }
    1426             : 
    1427             : static int
    1428       15882 : pari_err_display(GEN err)
    1429             : {
    1430       15882 :   long numerr=err_get_num(err);
    1431       15882 :   err_init();
    1432       15882 :   if (numerr==e_SYNTAX)
    1433             :   {
    1434          28 :     const char *msg = GSTR(gel(err,2));
    1435          28 :     const char *s     = (const char *) gmael(err,3,1);
    1436          28 :     const char *entry = (const char *) gmael(err,3,2);
    1437          28 :     print_errcontext(pariErr, msg, s, entry);
    1438             :   }
    1439             :   else
    1440             :   {
    1441       15854 :     char *s = pari_err2str(err);
    1442       15854 :     closure_err(0);
    1443       15854 :     err_init_msg(numerr==e_USER);
    1444       15854 :     pariErr->puts(s);
    1445       15854 :     if (numerr==e_NOTFUNC)
    1446             :     {
    1447        2716 :       GEN fun = gel(err,2);
    1448        2716 :       if (gequalX(fun))
    1449             :       {
    1450        2716 :         entree *ep = varentries[varn(fun)];
    1451        2716 :         const char *s = ep->name;
    1452        2716 :         if (cb_pari_whatnow) cb_pari_whatnow(pariErr,s,1);
    1453             :       }
    1454             :     }
    1455       15840 :     pari_free(s);
    1456             :   }
    1457       15868 :   out_term_color(pariErr, c_NONE);
    1458       15868 :   pariErr->flush(); return 0;
    1459             : }
    1460             : 
    1461             : void
    1462       30451 : pari_err(int numerr, ...)
    1463             : {
    1464             :   va_list ap;
    1465             :   GEN E;
    1466             : 
    1467       30451 :   va_start(ap,numerr);
    1468             : 
    1469       30451 :   if (numerr)
    1470       30435 :     E = pari_err2GEN(numerr,ap);
    1471             :   else
    1472             :   {
    1473          16 :     E = va_arg(ap,GEN);
    1474          16 :     numerr = err_get_num(E);
    1475             :   }
    1476       30451 :   global_err_data = E;
    1477       30451 :   if (*iferr_env) longjmp(*iferr_env, numerr);
    1478       15884 :   mt_err_recover(numerr);
    1479       15882 :   va_end(ap);
    1480       31750 :   if (cb_pari_err_handle &&
    1481       15882 :       cb_pari_err_handle(E)) return;
    1482       31729 :   if (cb_pari_handle_exception &&
    1483       15868 :       cb_pari_handle_exception(numerr)) return;
    1484       15861 :   err_recover(numerr);
    1485             : }
    1486             : 
    1487             : GEN
    1488       29123 : pari_err_last(void) { return global_err_data; }
    1489             : 
    1490             : const char *
    1491        7298 : numerr_name(long numerr)
    1492             : {
    1493        7298 :   switch ((enum err_list) numerr)
    1494             :   {
    1495           0 :   case e_ALARM:    return "e_ALARM";
    1496           0 :   case e_ARCH:     return "e_ARCH";
    1497           0 :   case e_BUG:      return "e_BUG";
    1498           0 :   case e_COMPONENT: return "e_COMPONENT";
    1499           0 :   case e_CONSTPOL: return "e_CONSTPOL";
    1500           0 :   case e_COPRIME:  return "e_COPRIME";
    1501           0 :   case e_DIM:      return "e_DIM";
    1502          56 :   case e_DOMAIN:   return "e_DOMAIN";
    1503           0 :   case e_FILE:     return "e_FILE";
    1504           7 :   case e_FLAG:     return "e_FLAG";
    1505          28 :   case e_IMPL:     return "e_IMPL";
    1506          53 :   case e_INV:      return "e_INV";
    1507           0 :   case e_IRREDPOL: return "e_IRREDPOL";
    1508           0 :   case e_MAXPRIME: return "e_MAXPRIME";
    1509           0 :   case e_MEM:      return "e_MEM";
    1510           0 :   case e_MISC:     return "e_MISC";
    1511           0 :   case e_MODULUS:  return "e_MODULUS";
    1512           0 :   case e_NONE:     return "e_NONE";
    1513           0 :   case e_NOTFUNC:  return "e_NOTFUNC";
    1514           0 :   case e_OP:       return "e_OP";
    1515           0 :   case e_OVERFLOW: return "e_OVERFLOW";
    1516           0 :   case e_PACKAGE:  return "e_PACKAGE";
    1517           0 :   case e_PREC:     return "e_PREC";
    1518           0 :   case e_PRIME:    return "e_PRIME";
    1519          49 :   case e_PRIORITY: return "e_PRIORITY";
    1520           0 :   case e_ROOTS0:   return "e_ROOTS0";
    1521           0 :   case e_SQRTN:    return "e_SQRTN";
    1522           0 :   case e_STACK:    return "e_STACK";
    1523           0 :   case e_SYNTAX:   return "e_SYNTAX";
    1524           0 :   case e_STACKTHREAD:   return "e_STACKTHREAD";
    1525           0 :   case e_TYPE2:    return "e_TYPE2";
    1526        7105 :   case e_TYPE:     return "e_TYPE";
    1527           0 :   case e_USER:     return "e_USER";
    1528           0 :   case e_VAR:      return "e_VAR";
    1529             :   }
    1530           0 :   return "invalid error number";
    1531             : }
    1532             : 
    1533             : long
    1534          21 : name_numerr(const char *s)
    1535             : {
    1536          21 :   if (!strcmp(s,"e_ALARM"))    return e_ALARM;
    1537          21 :   if (!strcmp(s,"e_ARCH"))     return e_ARCH;
    1538          21 :   if (!strcmp(s,"e_BUG"))      return e_BUG;
    1539          21 :   if (!strcmp(s,"e_COMPONENT")) return e_COMPONENT;
    1540          21 :   if (!strcmp(s,"e_CONSTPOL")) return e_CONSTPOL;
    1541          21 :   if (!strcmp(s,"e_COPRIME"))  return e_COPRIME;
    1542          21 :   if (!strcmp(s,"e_DIM"))      return e_DIM;
    1543          21 :   if (!strcmp(s,"e_DOMAIN"))   return e_DOMAIN;
    1544          21 :   if (!strcmp(s,"e_FILE"))     return e_FILE;
    1545          21 :   if (!strcmp(s,"e_FLAG"))     return e_FLAG;
    1546          21 :   if (!strcmp(s,"e_IMPL"))     return e_IMPL;
    1547          21 :   if (!strcmp(s,"e_INV"))      return e_INV;
    1548           0 :   if (!strcmp(s,"e_IRREDPOL")) return e_IRREDPOL;
    1549           0 :   if (!strcmp(s,"e_MAXPRIME")) return e_MAXPRIME;
    1550           0 :   if (!strcmp(s,"e_MEM"))      return e_MEM;
    1551           0 :   if (!strcmp(s,"e_MISC"))     return e_MISC;
    1552           0 :   if (!strcmp(s,"e_MODULUS"))  return e_MODULUS;
    1553           0 :   if (!strcmp(s,"e_NONE"))     return e_NONE;
    1554           0 :   if (!strcmp(s,"e_NOTFUNC"))  return e_NOTFUNC;
    1555           0 :   if (!strcmp(s,"e_OP"))       return e_OP;
    1556           0 :   if (!strcmp(s,"e_OVERFLOW")) return e_OVERFLOW;
    1557           0 :   if (!strcmp(s,"e_PACKAGE"))  return e_PACKAGE;
    1558           0 :   if (!strcmp(s,"e_PREC"))     return e_PREC;
    1559           0 :   if (!strcmp(s,"e_PRIME"))    return e_PRIME;
    1560           0 :   if (!strcmp(s,"e_PRIORITY")) return e_PRIORITY;
    1561           0 :   if (!strcmp(s,"e_ROOTS0"))   return e_ROOTS0;
    1562           0 :   if (!strcmp(s,"e_SQRTN"))    return e_SQRTN;
    1563           0 :   if (!strcmp(s,"e_STACK"))    return e_STACK;
    1564           0 :   if (!strcmp(s,"e_SYNTAX"))   return e_SYNTAX;
    1565           0 :   if (!strcmp(s,"e_TYPE"))     return e_TYPE;
    1566           0 :   if (!strcmp(s,"e_TYPE2"))    return e_TYPE2;
    1567           0 :   if (!strcmp(s,"e_USER"))     return e_USER;
    1568           0 :   if (!strcmp(s,"e_VAR"))      return e_VAR;
    1569           0 :   pari_err(e_MISC,"unknown error name");
    1570           0 :   return -1; /* NOT REACHED */
    1571             : }
    1572             : 
    1573             : GEN
    1574        7298 : errname(GEN err)
    1575             : {
    1576        7298 :   if (typ(err)!=t_ERROR) pari_err_TYPE("errname",err);
    1577        7298 :   return strtoGENstr(numerr_name(err_get_num(err)));
    1578             : }
    1579             : 
    1580             : /* Try f (trapping error e), recover using r (break_loop, if NULL) */
    1581             : GEN
    1582          21 : trap0(const char *e, GEN r, GEN f)
    1583             : {
    1584          21 :   long numerr = CATCH_ALL;
    1585             :   GEN x;
    1586          21 :   if (!e || !*e) numerr = CATCH_ALL;
    1587          21 :   else numerr = name_numerr(e);
    1588          21 :   if (!f) {
    1589           0 :     pari_warn(warner,"default handlers are no longer supported --> ignored");
    1590           0 :     return gnil;
    1591             :   }
    1592          21 :   x = closure_trapgen(f, numerr);
    1593          14 :   if (x == (GEN)1L) x = r? closure_evalgen(r): gnil;
    1594          14 :   return x;
    1595             : }
    1596             : 
    1597             : /*******************************************************************/
    1598             : /*                                                                */
    1599             : /*                       CLONING & COPY                            */
    1600             : /*                  Replicate an existing GEN                      */
    1601             : /*                                                                 */
    1602             : /*******************************************************************/
    1603             : /* lontyp[tx] = 0 (non recursive type) or number of codewords for type tx */
    1604             : 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 };
    1605             : 
    1606             : static GEN
    1607         690 : list_internal_copy(GEN z, long nmax)
    1608             : {
    1609             :   long i, l;
    1610             :   GEN a;
    1611         690 :   if (!z) return NULL;
    1612         560 :   l = lg(z);
    1613         560 :   a = newblock(nmax+1);
    1614         560 :   for (i = 1; i < l; i++) gel(a,i) = gel(z,i)? gclone(gel(z,i)): gen_0;
    1615         560 :   a[0] = z[0]; return a;
    1616             : }
    1617             : 
    1618             : static void
    1619         690 : listassign(GEN x, GEN y)
    1620             : {
    1621         690 :   long nmax = list_nmax(x);
    1622         690 :   GEN L = list_data(x);
    1623         690 :   if (!nmax && L) nmax = lg(L) + 32; /* not malloc'ed yet */
    1624         690 :   y[1] = evaltyp(list_typ(x))|evallg(nmax);
    1625         690 :   list_data(y) = list_internal_copy(L, nmax);
    1626         690 : }
    1627             : 
    1628             : /* copy list on the PARI stack */
    1629             : GEN
    1630         165 : listcopy(GEN x)
    1631             : {
    1632         165 :   GEN y = mklist(), L = list_data(x);
    1633         165 :   if (L) list_data(y) = gcopy(L);
    1634         165 :   y[1] = evaltyp(list_typ(x));
    1635         165 :   return y;
    1636             : }
    1637             : 
    1638             : GEN
    1639  3089714592 : gcopy(GEN x)
    1640             : {
    1641  3089714592 :   long tx = typ(x), lx, i;
    1642             :   GEN y;
    1643  3089714592 :   switch(tx)
    1644             :   { /* non recursive types */
    1645  2869003019 :     case t_INT: return signe(x)? icopy(x): gen_0;
    1646             :     case t_REAL:
    1647             :     case t_STR:
    1648   122915712 :     case t_VECSMALL: return leafcopy(x);
    1649             :     /* one more special case */
    1650         165 :     case t_LIST: return listcopy(x);
    1651             :   }
    1652    97795696 :   y = cgetg_copy(x, &lx);
    1653    97795695 :   if (lontyp[tx] == 1) i = 1; else { y[1] = x[1]; i = 2; }
    1654    97795695 :   for (; i<lx; i++) gel(y,i) = gcopy(gel(x,i));
    1655    97795696 :   return y;
    1656             : }
    1657             : 
    1658             : /* as gcopy, but truncate to the first lx components if recursive type
    1659             :  * [ leaves use their own lg ]. No checks. */
    1660             : GEN
    1661         588 : gcopy_lg(GEN x, long lx)
    1662             : {
    1663         588 :   long tx = typ(x), i;
    1664             :   GEN y;
    1665         588 :   switch(tx)
    1666             :   { /* non recursive types */
    1667           0 :     case t_INT: return signe(x)? icopy(x): gen_0;
    1668             :     case t_REAL:
    1669             :     case t_STR:
    1670           0 :     case t_VECSMALL: return leafcopy(x);
    1671             :     /* one more special case */
    1672           0 :     case t_LIST: return listcopy(x);
    1673             :   }
    1674         588 :   y = cgetg(lx, tx);
    1675         588 :   if (lontyp[tx] == 1) i = 1; else { y[1] = x[1]; i = 2; }
    1676         588 :   for (; i<lx; i++) gel(y,i) = gcopy(gel(x,i));
    1677         588 :   return y;
    1678             : }
    1679             : 
    1680             : /* cf cgetg_copy: "allocate" (by updating first codeword only) for subsequent
    1681             :  * copy of x, as if avma = *AVMA */
    1682             : INLINE GEN
    1683   186002021 : cgetg_copy_avma(GEN x, long *plx, pari_sp *AVMA) {
    1684             :   GEN z;
    1685   186002021 :   *plx = lg(x);
    1686   186002021 :   z = ((GEN)*AVMA) - *plx;
    1687   186002021 :   z[0] = x[0] & (TYPBITS|LGBITS);
    1688   186002021 :   *AVMA = (pari_sp)z; return z;
    1689             : }
    1690             : INLINE GEN
    1691         133 : cgetlist_avma(pari_sp *AVMA)
    1692             : {
    1693         133 :   GEN y = ((GEN)*AVMA) - 3;
    1694         133 :   y[0] = _evallg(3) | evaltyp(t_LIST);
    1695         133 :   *AVMA = (pari_sp)y; return y;
    1696             : }
    1697             : 
    1698             : /* copy x as if avma = *AVMA, update *AVMA */
    1699             : GEN
    1700  2533330843 : gcopy_avma(GEN x, pari_sp *AVMA)
    1701             : {
    1702  2533330843 :   long i, lx, tx = typ(x);
    1703             :   GEN y;
    1704             : 
    1705  2533330843 :   switch(typ(x))
    1706             :   { /* non recursive types */
    1707             :     case t_INT:
    1708  2476282833 :       *AVMA = (pari_sp)icopy_avma(x, *AVMA);
    1709  2476282805 :       return (GEN)*AVMA;
    1710             :     case t_REAL: case t_STR: case t_VECSMALL:
    1711    13926469 :       *AVMA = (pari_sp)leafcopy_avma(x, *AVMA);
    1712    13926461 :       return (GEN)*AVMA;
    1713             : 
    1714             :     /* one more special case */
    1715             :     case t_LIST:
    1716         133 :       y = cgetlist_avma(AVMA);
    1717         133 :       listassign(x, y); return y;
    1718             : 
    1719             :   }
    1720    43121408 :   y = cgetg_copy_avma(x, &lx, AVMA);
    1721    43121402 :   if (lontyp[tx] == 1) i = 1; else { y[1] = x[1]; i = 2; }
    1722    43121402 :   for (; i<lx; i++) gel(y,i) = gcopy_avma(gel(x,i), AVMA);
    1723    43121407 :   return y;
    1724             : }
    1725             : 
    1726             : /* [copy_bin/bin_copy:] same as gcopy_avma but use NULL to code an exact 0, and
    1727             :  * make shallow copies of finalized t_LISTs */
    1728             : static GEN
    1729   763632212 : gcopy_av0(GEN x, pari_sp *AVMA)
    1730             : {
    1731   763632212 :   long i, lx, tx = typ(x);
    1732             :   GEN y;
    1733             : 
    1734   763632212 :   switch(tx)
    1735             :   { /* non recursive types */
    1736             :     case t_INT:
    1737   541036747 :       if (!signe(x)) return NULL; /* special marker */
    1738   284044154 :       *AVMA = (pari_sp)icopy_avma(x, *AVMA);
    1739   284044149 :       return (GEN)*AVMA;
    1740             :     case t_LIST:
    1741          49 :       if (list_data(x) && !list_nmax(x)) break; /* not finalized, need copy */
    1742             :       /* else finalized: shallow copy */
    1743             :     case t_REAL: case t_STR: case t_VECSMALL:
    1744    79714912 :       *AVMA = (pari_sp)leafcopy_avma(x, *AVMA);
    1745    79714921 :       return (GEN)*AVMA;
    1746             :   }
    1747   142880553 :   y = cgetg_copy_avma(x, &lx, AVMA);
    1748   142880597 :   if (lontyp[tx] == 1) i = 1; else { y[1] = x[1]; i = 2; }
    1749   142880597 :   for (; i<lx; i++) gel(y,i) = gcopy_av0(gel(x,i), AVMA);
    1750   142880668 :   return y;
    1751             : }
    1752             : 
    1753             : INLINE GEN
    1754           0 : icopy_avma_canon(GEN x, pari_sp AVMA)
    1755             : {
    1756           0 :   long i, lx = lgefint(x);
    1757           0 :   GEN y = ((GEN)AVMA) - lx;
    1758           0 :   y[0] = evaltyp(t_INT)|evallg(lx); /* kills isclone */
    1759           0 :   y[1] = x[1]; x = int_MSW(x);
    1760           0 :   for (i=2; i<lx; i++, x = int_precW(x)) y[i] = *x;
    1761           0 :   return y;
    1762             : }
    1763             : 
    1764             : /* [copy_bin_canon:] same as gcopy_av0, but copy integers in
    1765             :  * canonical (native kernel) form and make a full copy of t_LISTs */
    1766             : static GEN
    1767           0 : gcopy_av0_canon(GEN x, pari_sp *AVMA)
    1768             : {
    1769           0 :   long i, lx, tx = typ(x);
    1770             :   GEN y;
    1771             : 
    1772           0 :   switch(tx)
    1773             :   { /* non recursive types */
    1774             :     case t_INT:
    1775           0 :       if (!signe(x)) return NULL; /* special marker */
    1776           0 :       *AVMA = (pari_sp)icopy_avma_canon(x, *AVMA);
    1777           0 :       return (GEN)*AVMA;
    1778             :     case t_REAL: case t_STR: case t_VECSMALL:
    1779           0 :       *AVMA = (pari_sp)leafcopy_avma(x, *AVMA);
    1780           0 :       return (GEN)*AVMA;
    1781             : 
    1782             :     /* one more special case */
    1783             :     case t_LIST:
    1784             :     {
    1785           0 :       long t = list_typ(x);
    1786           0 :       GEN y = cgetlist_avma(AVMA), z = list_data(x);
    1787           0 :       if (z) {
    1788           0 :         list_data(y) = gcopy_av0_canon(z, AVMA);
    1789           0 :         y[1] = evaltyp(t)|evallg(lg(z)-1);
    1790             :       } else {
    1791           0 :         list_data(y) = NULL;
    1792           0 :         y[1] = evaltyp(t);
    1793             :       }
    1794           0 :       return y;
    1795             :     }
    1796             :   }
    1797           0 :   y = cgetg_copy_avma(x, &lx, AVMA);
    1798           0 :   if (lontyp[tx] == 1) i = 1; else { y[1] = x[1]; i = 2; }
    1799           0 :   for (; i<lx; i++) gel(y,i) = gcopy_av0_canon(gel(x,i), AVMA);
    1800           0 :   return y;
    1801             : }
    1802             : 
    1803             : /* [copy_bin/bin_copy:] size (number of words) required for
    1804             :  * gcopy_av0_canon(x) */
    1805             : static long
    1806           0 : taille0_canon(GEN x)
    1807             : {
    1808           0 :   long i,n,lx, tx = typ(x);
    1809           0 :   switch(tx)
    1810             :   { /* non recursive types */
    1811           0 :     case t_INT: return signe(x)? lgefint(x): 0;
    1812             :     case t_REAL:
    1813             :     case t_STR:
    1814           0 :     case t_VECSMALL: return lg(x);
    1815             : 
    1816             :     /* one more special case */
    1817             :     case t_LIST:
    1818             :     {
    1819           0 :       GEN L = list_data(x);
    1820           0 :       return L? 3 + taille0_canon(L): 3;
    1821             :     }
    1822             :   }
    1823           0 :   n = lx = lg(x);
    1824           0 :   for (i=lontyp[tx]; i<lx; i++) n += taille0_canon(gel(x,i));
    1825           0 :   return n;
    1826             : }
    1827             : 
    1828             : /* [copy_bin/bin_copy:] size (number of words) required for gcopy_av0(x) */
    1829             : static long
    1830   763632577 : taille0(GEN x)
    1831             : {
    1832   763632577 :   long i,n,lx, tx = typ(x);
    1833   763632577 :   switch(tx)
    1834             :   { /* non recursive types */
    1835             :     case t_INT:
    1836   541036979 :       lx = lgefint(x);
    1837   541036979 :       return lx == 2? 0: lx;
    1838             :     case t_LIST:
    1839             :     {
    1840          49 :       GEN L = list_data(x);
    1841          49 :       if (L && !list_nmax(x)) break; /* not finalized, deep copy */
    1842             :     }
    1843             :     /* else finalized: shallow */
    1844             :     case t_REAL:
    1845             :     case t_STR:
    1846             :     case t_VECSMALL:
    1847    79714929 :       return lg(x);
    1848             :   }
    1849   142880669 :   n = lx = lg(x);
    1850   142880669 :   for (i=lontyp[tx]; i<lx; i++) n += taille0(gel(x,i));
    1851   142880664 :   return n;
    1852             : }
    1853             : 
    1854             : /* How many words do we need to allocate to copy x ? t_LIST is a special case
    1855             :  * since list_data() is malloc'ed later, in list_internal_copy() */
    1856             : static long
    1857  2670881616 : words_to_allocate(GEN x)
    1858             : {
    1859  2670881616 :   long i,n,lx, tx = typ(x);
    1860  2670881616 :   switch(tx)
    1861             :   { /* non recursive types */
    1862  2571617756 :     case t_INT: return lgefint(x);
    1863             :     case t_REAL:
    1864             :     case t_STR:
    1865    19698308 :     case t_VECSMALL: return lg(x);
    1866             : 
    1867         697 :     case t_LIST: return 3;
    1868             :     default:
    1869    79564855 :       n = lx = lg(x);
    1870    79564855 :       for (i=lontyp[tx]; i<lx; i++) n += words_to_allocate(gel(x,i));
    1871    79564863 :       return n;
    1872             :   }
    1873             : }
    1874             : 
    1875             : long
    1876        6636 : gsizeword(GEN x)
    1877             : {
    1878             :   GEN L;
    1879        6636 :   if (typ(x) != t_LIST) return words_to_allocate(x);
    1880             :   /* For t_LIST, return the actual list size, words_to_allocate() is always 3 */
    1881         147 :   L = list_data(x);
    1882         147 :   return L? 3 + words_to_allocate(L): 3;
    1883             : }
    1884             : long
    1885          21 : gsizebyte(GEN x) { return gsizeword(x) * sizeof(long); }
    1886             : 
    1887             : /* return a clone of x structured as a gcopy */
    1888             : GENbin*
    1889    37572292 : copy_bin(GEN x)
    1890             : {
    1891    37572292 :   long t = taille0(x);
    1892    37572273 :   GENbin *p = (GENbin*)pari_malloc(sizeof(GENbin) + t*sizeof(long));
    1893    37572326 :   pari_sp AVMA = (pari_sp)(GENbinbase(p) + t);
    1894    37572314 :   p->rebase = &shiftaddress;
    1895    37572314 :   p->len = t;
    1896    37572314 :   p->x   = gcopy_av0(x, &AVMA);
    1897    37572311 :   p->base= (GEN)AVMA; return p;
    1898             : }
    1899             : 
    1900             : /* same, writing t_INT in canonical native form */
    1901             : GENbin*
    1902           0 : copy_bin_canon(GEN x)
    1903             : {
    1904           0 :   long t = taille0_canon(x);
    1905           0 :   GENbin *p = (GENbin*)pari_malloc(sizeof(GENbin) + t*sizeof(long));
    1906           0 :   pari_sp AVMA = (pari_sp)(GENbinbase(p) + t);
    1907           0 :   p->rebase = &shiftaddress_canon;
    1908           0 :   p->len = t;
    1909           0 :   p->x   = gcopy_av0_canon(x, &AVMA);
    1910           0 :   p->base= (GEN)AVMA; return p;
    1911             : }
    1912             : 
    1913             : GEN
    1914   137463616 : gclone(GEN x)
    1915             : {
    1916   137463616 :   long i,lx,tx = typ(x), t = words_to_allocate(x);
    1917   137463615 :   GEN y = newblock(t);
    1918   137463616 :   switch(tx)
    1919             :   { /* non recursive types */
    1920             :     case t_INT:
    1921    95198191 :       lx = lgefint(x);
    1922    95198191 :       y[0] = evaltyp(t_INT)|evallg(lx);
    1923    95198191 :       for (i=1; i<lx; i++) y[i] = x[i];
    1924    95198191 :       break;
    1925             :     case t_REAL:
    1926             :     case t_STR:
    1927             :     case t_VECSMALL:
    1928     5859309 :       lx = lg(x);
    1929     5859309 :       for (i=0; i<lx; i++) y[i] = x[i];
    1930     5859309 :       break;
    1931             : 
    1932             :     /* one more special case */
    1933             :     case t_LIST:
    1934         557 :       y[0] = evaltyp(t_LIST)|_evallg(3);
    1935         557 :       listassign(x, y);
    1936         557 :       break;
    1937             :     default: {
    1938    36405559 :       pari_sp AVMA = (pari_sp)(y + t);
    1939    36405559 :       lx = lg(x);
    1940    36405559 :       y[0] = x[0];
    1941    36405559 :       if (lontyp[tx] == 1) i = 1; else { y[1] = x[1]; i = 2; }
    1942    36405559 :       for (; i<lx; i++) gel(y,i) = gcopy_avma(gel(x,i), &AVMA);
    1943             :     }
    1944             :   }
    1945   137463615 :   setisclone(y); return y;
    1946             : }
    1947             : 
    1948             : void
    1949   506639685 : shiftaddress(GEN x, long dec)
    1950             : {
    1951   506639685 :   long i, lx, tx = typ(x);
    1952   506639685 :   if (is_recursive_t(tx))
    1953             :   {
    1954   142880707 :     if (tx == t_LIST)
    1955             :     {
    1956   506639757 :       if (!list_data(x) || list_nmax(x)) return; /* empty or finalized */
    1957             :       /* not finalized, update pointers  */
    1958             :     }
    1959   142880665 :     lx = lg(x);
    1960   868940822 :     for (i=lontyp[tx]; i<lx; i++) {
    1961   726060125 :       if (!x[i]) gel(x,i) = gen_0;
    1962             :       else
    1963             :       {
    1964   469069992 :         x[i] += dec;
    1965   469069992 :         shiftaddress(gel(x,i), dec);
    1966             :       }
    1967             :     }
    1968             :   }
    1969             : }
    1970             : 
    1971             : void
    1972           0 : shiftaddress_canon(GEN x, long dec)
    1973             : {
    1974           0 :   long i, lx, tx = typ(x);
    1975           0 :   switch(tx)
    1976             :   { /* non recursive types */
    1977             :     case t_INT: {
    1978             :       GEN y;
    1979           0 :       lx = lgefint(x); if (lx <= 3) return;
    1980           0 :       y = x + 2;
    1981           0 :       x = int_MSW(x);  if (x == y) return;
    1982           0 :       while (x > y) { lswap(*x, *y); x = int_precW(x); y++; }
    1983           0 :       break;
    1984             :     }
    1985             :     case t_REAL:
    1986             :     case t_STR:
    1987             :     case t_VECSMALL:
    1988           0 :       break;
    1989             : 
    1990             :     /* one more special case */
    1991             :     case t_LIST: {
    1992           0 :       GEN Lx = list_data(x);
    1993           0 :       if (Lx) {
    1994           0 :         pari_sp av = avma;
    1995           0 :         GEN L = (GEN)((long)Lx+dec);
    1996           0 :         shiftaddress_canon(L, dec);
    1997           0 :         list_data(x) = list_internal_copy(L, lg(L)); avma = av;
    1998             :       }
    1999             :     }
    2000             :     default:
    2001           0 :       lx = lg(x);
    2002           0 :       for (i=lontyp[tx]; i<lx; i++) {
    2003           0 :         if (!x[i]) gel(x,i) = gen_0;
    2004             :         else
    2005             :         {
    2006           0 :           x[i] += dec;
    2007           0 :           shiftaddress_canon(gel(x,i), dec);
    2008             :         }
    2009             :       }
    2010             :   }
    2011             : }
    2012             : 
    2013             : /********************************************************************/
    2014             : /**                                                                **/
    2015             : /**                INSERT DYNAMIC OBJECT IN STRUCTURE              **/
    2016             : /**                                                                **/
    2017             : /********************************************************************/
    2018             : GEN
    2019          21 : obj_reinit(GEN S)
    2020             : {
    2021          21 :   GEN s, T = leafcopy(S);
    2022          21 :   long a = lg(T)-1;
    2023          21 :   s = gel(T,a);
    2024          21 :   gel(T,a) = zerovec(lg(s)-1);
    2025          21 :   return T;
    2026             : }
    2027             : 
    2028             : GEN
    2029     1833912 : obj_init(long d, long n)
    2030             : {
    2031     1833912 :   GEN S = cgetg(d+2, t_VEC);
    2032     1833912 :   gel(S, d+1) = zerovec(n);
    2033     1833913 :   return S;
    2034             : }
    2035             : /* insert O in S [last position] at position K, return it */
    2036             : GEN
    2037     1085895 : obj_insert(GEN S, long K, GEN O)
    2038     1085895 : { return obj_insert_shallow(S, K, gclone(O)); }
    2039             : /* as obj_insert. WITHOUT cloning (for libpari, when creating a *new* obj
    2040             :  * from an existing one) */
    2041             : GEN
    2042     1089682 : obj_insert_shallow(GEN S, long K, GEN O)
    2043             : {
    2044     1089682 :   GEN o, v = gel(S, lg(S)-1);
    2045     1089682 :   if (typ(v) != t_VEC) pari_err_TYPE("obj_insert", S);
    2046     1089682 :   o = gel(v,K);
    2047     1089682 :   gel(v,K) = O; /*SIGINT: before unclone(o)*/
    2048     1089682 :   if (isclone(o)) gunclone(o);
    2049     1089682 :   return gel(v,K);
    2050             : }
    2051             : 
    2052             : /* Does S [last position] contain data at position K ? Return it, or NULL */
    2053             : GEN
    2054     2383053 : obj_check(GEN S, long K)
    2055             : {
    2056     2383053 :   GEN O, v = gel(S, lg(S)-1);
    2057     2383053 :   if (typ(v) != t_VEC || K >= lg(v)) pari_err_TYPE("obj_check", S);
    2058     2383053 :   O = gel(v,K); return isintzero(O)? NULL: O;
    2059             : }
    2060             : 
    2061             : GEN
    2062      711612 : obj_checkbuild(GEN S, long tag, GEN (*build)(GEN))
    2063             : {
    2064      711612 :   GEN O = obj_check(S, tag);
    2065      711612 :   if (!O)
    2066      628267 :   { pari_sp av = avma; O = obj_insert(S, tag, build(S)); avma = av; }
    2067      711612 :   return O;
    2068             : }
    2069             : 
    2070             : GEN
    2071       26979 : obj_checkbuild_prec(GEN S, long tag, GEN (*build)(GEN,long),
    2072             :   long (*pr)(GEN), long prec)
    2073             : {
    2074       26979 :   pari_sp av = avma;
    2075       26979 :   GEN w = obj_check(S, tag);
    2076       26979 :   if (!w || pr(w) < prec) w = obj_insert(S, tag, build(S, prec));
    2077       26979 :   avma = av; return gcopy(w);
    2078             : }
    2079             : GEN
    2080        4341 : obj_checkbuild_realprec(GEN S, long tag, GEN (*build)(GEN,long), long prec)
    2081        4341 : { return obj_checkbuild_prec(S,tag,build,gprecision,prec); }
    2082             : GEN
    2083         455 : obj_checkbuild_padicprec(GEN S, long tag, GEN (*build)(GEN,long), long prec)
    2084         455 : { return obj_checkbuild_prec(S,tag,build,padicprec_relative,prec); }
    2085             : 
    2086             : /* Reset S [last position], freeing all clones */
    2087             : void
    2088        4956 : obj_free(GEN S)
    2089             : {
    2090        4956 :   GEN v = gel(S, lg(S)-1);
    2091             :   long i;
    2092        4956 :   if (typ(v) != t_VEC) pari_err_TYPE("obj_free", S);
    2093       28280 :   for (i = 1; i < lg(v); i++)
    2094             :   {
    2095       23324 :     GEN o = gel(v,i);
    2096       23324 :     if (isclone(o)) gunclone(o);
    2097       23324 :     gel(v,i) = gen_0;
    2098             :   }
    2099        4956 : }
    2100             : 
    2101             : /*******************************************************************/
    2102             : /*                                                                 */
    2103             : /*                         STACK MANAGEMENT                        */
    2104             : /*                                                                 */
    2105             : /*******************************************************************/
    2106             : INLINE void
    2107  1972922889 : dec_gerepile(pari_sp *x, pari_sp av0, pari_sp av, pari_sp tetpil, size_t dec)
    2108             : {
    2109  1972922889 :   if (*x < av && *x >= av0)
    2110             :   { /* update address if in stack */
    2111  1603559886 :     if (*x < tetpil) *x += dec;
    2112           0 :     else pari_err_BUG("gerepile, significant pointers lost");
    2113             :   }
    2114  1972922889 : }
    2115             : 
    2116             : void
    2117      187096 : gerepileallsp(pari_sp av, pari_sp tetpil, int n, ...)
    2118             : {
    2119      187096 :   const pari_sp av0 = avma;
    2120      187096 :   const size_t dec = av-tetpil;
    2121             :   int i;
    2122      187096 :   va_list a; va_start(a, n);
    2123      187096 :   (void)gerepile(av,tetpil,NULL);
    2124      187096 :   for (i=0; i<n; i++) dec_gerepile((pari_sp*)va_arg(a,GEN*), av0,av,tetpil,dec);
    2125      187096 :   va_end(a);
    2126      187096 : }
    2127             : 
    2128             : /* Takes an array of pointers to GENs, of length n.
    2129             :  * Cleans up the stack between av and tetpil, updating those GENs. */
    2130             : void
    2131     5239419 : gerepilemanysp(pari_sp av, pari_sp tetpil, GEN* gptr[], int n)
    2132             : {
    2133     5239419 :   const pari_sp av0 = avma;
    2134     5239419 :   const size_t dec = av-tetpil;
    2135             :   int i;
    2136     5239419 :   (void)gerepile(av,tetpil,NULL);
    2137     5239419 :   for (i=0; i<n; i++) dec_gerepile((pari_sp*)gptr[i], av0, av, tetpil, dec);
    2138     5239419 : }
    2139             : 
    2140             : /* Takes an array of GENs (cast to longs), of length n.
    2141             :  * Cleans up the stack between av and tetpil, updating those GENs. */
    2142             : void
    2143   101154122 : gerepilecoeffssp(pari_sp av, pari_sp tetpil, long *g, int n)
    2144             : {
    2145   101154122 :   const pari_sp av0 = avma;
    2146   101154122 :   const size_t dec = av-tetpil;
    2147             :   int i;
    2148   101154122 :   (void)gerepile(av,tetpil,NULL);
    2149   101154122 :   for (i=0; i<n; i++,g++) dec_gerepile((pari_sp*)g, av0, av, tetpil, dec);
    2150   101154122 : }
    2151             : 
    2152             : static int
    2153           0 : dochk_gerepileupto(GEN av, GEN x)
    2154             : {
    2155             :   long i,lx,tx;
    2156           0 :   if (!isonstack(x)) return 1;
    2157           0 :   if (x > av)
    2158             :   {
    2159           0 :     pari_warn(warner,"bad object %Ps",x);
    2160           0 :     return 0;
    2161             :   }
    2162           0 :   tx = typ(x);
    2163           0 :   if (! is_recursive_t(tx)) return 1;
    2164             : 
    2165           0 :   lx = lg(x);
    2166           0 :   for (i=lontyp[tx]; i<lx; i++)
    2167           0 :     if (!dochk_gerepileupto(av, gel(x,i)))
    2168             :     {
    2169           0 :       pari_warn(warner,"bad component %ld in object %Ps",i,x);
    2170           0 :       return 0;
    2171             :     }
    2172           0 :   return 1;
    2173             : }
    2174             : /* check that x and all its components are out of stack, or have been
    2175             :  * created after av */
    2176             : int
    2177           0 : chk_gerepileupto(GEN x) { return dochk_gerepileupto(x, x); }
    2178             : 
    2179             : /* print stack between avma & av */
    2180             : void
    2181           0 : dbg_gerepile(pari_sp av)
    2182             : {
    2183           0 :   GEN x = (GEN)avma;
    2184           0 :   while (x < (GEN)av)
    2185             :   {
    2186           0 :     const long tx = typ(x), lx = lg(x);
    2187             :     GEN *a;
    2188             : 
    2189           0 :     pari_printf(" [%ld] %Ps:", x - (GEN)avma, x);
    2190           0 :     if (! is_recursive_t(tx)) { pari_putc('\n'); x += lx; continue; }
    2191           0 :     a = (GEN*)x + lontyp[tx]; x += lx;
    2192           0 :     for (  ; a < (GEN*)x; a++)
    2193             :     {
    2194           0 :       if (*a == gen_0)
    2195           0 :         pari_puts("  gen_0");
    2196           0 :       else if (*a == gen_1)
    2197           0 :         pari_puts("  gen_1");
    2198           0 :       else if (*a == gen_m1)
    2199           0 :         pari_puts("  gen_m1");
    2200           0 :       else if (*a == gen_2)
    2201           0 :         pari_puts("  gen_2");
    2202           0 :       else if (*a == gen_m2)
    2203           0 :         pari_puts("  gen_m2");
    2204           0 :       else if (*a == ghalf)
    2205           0 :         pari_puts("  ghalf");
    2206           0 :       else if (isclone(*a))
    2207           0 :         pari_printf("  %Ps (clone)", *a);
    2208             :       else
    2209           0 :         pari_printf("  %Ps [%ld]", *a, *a - (GEN)avma);
    2210           0 :       if (a+1 < (GEN*)x) pari_putc(',');
    2211             :     }
    2212           0 :     pari_printf("\n");
    2213             :   }
    2214           0 : }
    2215             : void
    2216           0 : dbg_gerepileupto(GEN q)
    2217             : {
    2218           0 :   err_printf("%Ps:\n", q);
    2219           0 :   dbg_gerepile((pari_sp) (q+lg(q)));
    2220           0 : }
    2221             : 
    2222             : GEN
    2223   400513926 : gerepile(pari_sp av, pari_sp tetpil, GEN q)
    2224             : {
    2225   400513926 :   const size_t dec = av - tetpil;
    2226   400513926 :   const pari_sp av0 = avma;
    2227             :   GEN x, a;
    2228             : 
    2229   400513926 :   if (dec == 0) return q;
    2230   338213605 :   if ((long)dec < 0) pari_err(e_MISC,"lbot>ltop in gerepile");
    2231             : 
    2232             :   /* dec_gerepile(&q, av0, av, tetpil, dec), saving 1 comparison */
    2233   338159620 :   if (q >= (GEN)av0 && q < (GEN)tetpil)
    2234   235221991 :     q = (GEN) (((pari_sp)q) + dec);
    2235             : 
    2236   338159620 :   for (x = (GEN)av, a = (GEN)tetpil; a > (GEN)av0; ) *--x = *--a;
    2237   338159620 :   avma = (pari_sp)x;
    2238  2598266361 :   while (x < (GEN)av)
    2239             :   {
    2240  1921877697 :     const long tx = typ(x), lx = lg(x);
    2241             : 
    2242  1921877697 :     if (! is_recursive_t(tx)) { x += lx; continue; }
    2243   408152993 :     a = x + lontyp[tx]; x += lx;
    2244   408152993 :     for (  ; a < x; a++) dec_gerepile((pari_sp*)a, av0, av, tetpil, dec);
    2245             :   }
    2246   338229044 :   return q;
    2247             : }
    2248             : 
    2249             : void
    2250           0 : fill_stack(void)
    2251             : {
    2252           0 :   GEN x = ((GEN)pari_mainstack->bot);
    2253           0 :   while (x < (GEN)avma) *x++ = 0xfefefefeUL;
    2254           0 : }
    2255             : 
    2256             : void
    2257           0 : debug_stack(void)
    2258             : {
    2259           0 :   pari_sp top = pari_mainstack->top, bot = pari_mainstack->bot;
    2260             :   GEN z;
    2261           0 :   err_printf("bot=0x%lx\ttop=0x%lx\tavma=0x%lx\n", bot, top, avma);
    2262           0 :   for (z = ((GEN)top)-1; z >= (GEN)avma; z--)
    2263           0 :     err_printf("%p:\t0x%lx\t%lu\n",z,*z,*z);
    2264           0 : }
    2265             : 
    2266             : void
    2267           0 : setdebugvar(long n) { DEBUGVAR=n; }
    2268             : 
    2269             : long
    2270           0 : getdebugvar(void) { return DEBUGVAR; }
    2271             : 
    2272             : long
    2273           7 : getstack(void) { return pari_mainstack->top-avma; }
    2274             : 
    2275             : /*******************************************************************/
    2276             : /*                                                                 */
    2277             : /*                               timer_delay                             */
    2278             : /*                                                                 */
    2279             : /*******************************************************************/
    2280             : 
    2281             : #if defined(USE_CLOCK_GETTIME)
    2282             : #if defined(_POSIX_THREAD_CPUTIME)
    2283             : static THREAD clockid_t time_type = CLOCK_THREAD_CPUTIME_ID;
    2284             : #else
    2285             : static const THREAD clockid_t time_type = CLOCK_PROCESS_CPUTIME_ID;
    2286             : #endif
    2287             : static void
    2288             : pari_init_timer(void)
    2289             : {
    2290             : #if defined(_POSIX_THREAD_CPUTIME)
    2291             :   time_type = CLOCK_PROCESS_CPUTIME_ID;
    2292             : #endif
    2293             : }
    2294             : 
    2295             : void
    2296             : timer_start(pari_timer *T)
    2297             : {
    2298             :   struct timespec t;
    2299             :   clock_gettime(time_type,&t);
    2300             :   T->us = t.tv_nsec / 1000;
    2301             :   T->s  = t.tv_sec;
    2302             : }
    2303             : #elif defined(USE_GETRUSAGE)
    2304             : #ifdef RUSAGE_THREAD
    2305             : static THREAD int rusage_type = RUSAGE_THREAD;
    2306             : #else
    2307             : static const THREAD int rusage_type = RUSAGE_SELF;
    2308             : #endif /*RUSAGE_THREAD*/
    2309             : static void
    2310        1350 : pari_init_timer(void)
    2311             : {
    2312             : #ifdef RUSAGE_THREAD
    2313        1350 :   rusage_type = RUSAGE_SELF;
    2314             : #endif
    2315        1350 : }
    2316             : 
    2317             : void
    2318      449304 : timer_start(pari_timer *T)
    2319             : {
    2320             :   struct rusage r;
    2321      449304 :   getrusage(rusage_type,&r);
    2322      449304 :   T->us = r.ru_utime.tv_usec;
    2323      449304 :   T->s  = r.ru_utime.tv_sec;
    2324      449304 : }
    2325             : #elif defined(USE_FTIME)
    2326             : 
    2327             : static void
    2328             : pari_init_timer(void) { }
    2329             : 
    2330             : void
    2331             : timer_start(pari_timer *T)
    2332             : {
    2333             :   struct timeb t;
    2334             :   ftime(&t);
    2335             :   T->us = ((long)t.millitm) * 1000;
    2336             :   T->s  = t.time;
    2337             : }
    2338             : 
    2339             : #else
    2340             : 
    2341             : static void
    2342             : _get_time(pari_timer *T, long Ticks, long TickPerSecond)
    2343             : {
    2344             :   T->us = (long) ((Ticks % TickPerSecond) * (1000000. / TickPerSecond));
    2345             :   T->s  = Ticks / TickPerSecond;
    2346             : }
    2347             : 
    2348             : # ifdef USE_TIMES
    2349             : static void
    2350             : pari_init_timer(void) { }
    2351             : 
    2352             : void
    2353             : timer_start(pari_timer *T)
    2354             : {
    2355             : # ifdef _SC_CLK_TCK
    2356             :   long tck = sysconf(_SC_CLK_TCK);
    2357             : # else
    2358             :   long tck = CLK_TCK;
    2359             : # endif
    2360             :   struct tms t; times(&t);
    2361             :   _get_time(T, t.tms_utime, tck);
    2362             : }
    2363             : # elif defined(_WIN32)
    2364             : static void
    2365             : pari_init_timer(void) { }
    2366             : 
    2367             : void
    2368             : timer_start(pari_timer *T)
    2369             : { _get_time(T, win32_timer(), 1000); }
    2370             : # else
    2371             : #  include <time.h>
    2372             : #  ifndef CLOCKS_PER_SEC
    2373             : #   define CLOCKS_PER_SEC 1000000 /* may be false on YOUR system */
    2374             : #  endif
    2375             : static void
    2376             : pari_init_timer(void) { }
    2377             : 
    2378             : void
    2379             : timer_start(pari_timer *T)
    2380             : { _get_time(T, clock(), CLOCKS_PER_SEC); }
    2381             : # endif
    2382             : #endif
    2383             : 
    2384             : static long
    2385       56716 : timer_aux(pari_timer *T, pari_timer *U)
    2386             : {
    2387       56716 :   long s = T->s, us = T->us; timer_start(U);
    2388       56716 :   return 1000 * (U->s - s) + (U->us - us + 500) / 1000;
    2389             : }
    2390             : /* return delay, reset timer */
    2391             : long
    2392       55364 : timer_delay(pari_timer *T) { return timer_aux(T, T); }
    2393             : /* return delay, don't reset timer */
    2394             : long
    2395        1352 : timer_get(pari_timer *T) { pari_timer t; return timer_aux(T, &t); }
    2396             : 
    2397             : static void
    2398           0 : timer_vprintf(pari_timer *T, const char *format, va_list args)
    2399             : {
    2400           0 :   out_puts(pariErr, "Time ");
    2401           0 :   out_vprintf(pariErr, format,args);
    2402           0 :   out_printf(pariErr, ": %ld\n", timer_delay(T));
    2403           0 :   pariErr->flush();
    2404           0 : }
    2405             : void
    2406           0 : timer_printf(pari_timer *T, const char *format, ...)
    2407             : {
    2408           0 :   va_list args; va_start(args, format);
    2409           0 :   timer_vprintf(T, format, args);
    2410           0 :   va_end(args);
    2411           0 : }
    2412             : 
    2413             : long
    2414           0 : timer(void)  { static THREAD pari_timer T; return timer_delay(&T);}
    2415             : long
    2416        3180 : gettime(void)  { static THREAD pari_timer T; return timer_delay(&T);}
    2417             : 
    2418             : static THREAD pari_timer timer2_T, abstimer_T;
    2419             : long
    2420           0 : timer2(void) {  return timer_delay(&timer2_T);}
    2421             : void
    2422           0 : msgtimer(const char *format, ...)
    2423             : {
    2424           0 :   va_list args; va_start(args, format);
    2425           0 :   timer_vprintf(&timer2_T, format, args);
    2426           0 :   va_end(args);
    2427           0 : }
    2428             : long
    2429        1350 : getabstime(void)  { return timer_get(&abstimer_T);}
    2430             : #if defined(USE_CLOCK_GETTIME) || defined(USE_GETTIMEOFDAY) \
    2431             :  || defined(USE_FTIMEFORWALLTIME)
    2432             : static GEN
    2433           0 : timetoi(ulong s, ulong m)
    2434             : {
    2435           0 :   pari_sp av = avma;
    2436           0 :   GEN r = addiu(muliu(utoi(s), 1000), m);
    2437           0 :   return gerepileuptoint(av, r);
    2438             : }
    2439             : #endif
    2440             : GEN
    2441           0 : getwalltime(void)
    2442             : {
    2443             : #if defined(USE_CLOCK_GETTIME)
    2444             :   struct timespec t;
    2445             :   if (!clock_gettime(CLOCK_REALTIME,&t))
    2446             :     return timetoi(t.tv_sec, (t.tv_nsec + 500000)/1000000);
    2447             : #elif defined(USE_GETTIMEOFDAY)
    2448             :   struct timeval tv;
    2449           0 :   if (!gettimeofday(&tv, NULL))
    2450           0 :     return timetoi(tv.tv_sec, (tv.tv_usec + 500)/1000);
    2451             : #elif defined(USE_FTIMEFORWALLTIME)
    2452             :   struct timeb tp;
    2453             :   ftime(&tp); return timetoi(tp.time, tp.millitm);
    2454             : #endif
    2455           0 :   return utoi(getabstime());
    2456             : }
    2457             : 
    2458             : /*******************************************************************/
    2459             : /*                                                                 */
    2460             : /*                   FUNCTIONS KNOWN TO THE ANALYZER               */
    2461             : /*                                                                 */
    2462             : /*******************************************************************/
    2463             : GEN
    2464           7 : pari_version(void)
    2465             : {
    2466           7 :   const ulong mask = (1UL<<PARI_VERSION_SHIFT) - 1;
    2467           7 :   ulong major, minor, patch, n = paricfg_version_code;
    2468           7 :   patch = n & mask; n >>= PARI_VERSION_SHIFT;
    2469           7 :   minor = n & mask; n >>= PARI_VERSION_SHIFT;
    2470           7 :   major = n;
    2471           7 :   if (*paricfg_vcsversion) {
    2472           7 :     const char *ver = paricfg_vcsversion;
    2473           7 :     const char *s = strchr(ver, '-');
    2474             :     char t[8];
    2475           7 :     const long len = s-ver;
    2476             :     GEN v;
    2477           7 :     if (!s || len > 6) pari_err_BUG("pari_version()"); /* paranoia */
    2478           7 :     memcpy(t, ver, len); t[len] = 0;
    2479           7 :     v = cgetg(6, t_VEC);
    2480           7 :     gel(v,1) = utoi(major);
    2481           7 :     gel(v,2) = utoi(minor);
    2482           7 :     gel(v,3) = utoi(patch);
    2483           7 :     gel(v,4) = stoi( atoi(t) );
    2484           7 :     gel(v,5) = strtoGENstr(s+1);
    2485           7 :     return v;
    2486             :   } else {
    2487           0 :     GEN v = cgetg(4, t_VEC);
    2488           0 :     gel(v,1) = utoi(major);
    2489           0 :     gel(v,2) = utoi(minor);
    2490           0 :     gel(v,3) = utoi(patch);
    2491           0 :     return v;
    2492             :   }
    2493             : }
    2494             : 
    2495             : /* List of GP functions: generated from the description system.
    2496             :  * Format (struct entree) :
    2497             :  *   char *name   : name (under GP).
    2498             :  *   ulong valence: (EpNEW, EpALIAS,EpVAR, EpINSTALL)|EpSTATIC
    2499             :  *   void *value  : For PREDEFINED FUNCTIONS: C function to call.
    2500             :  *                  For USER FUNCTIONS: pointer to defining data (block) =
    2501             :  *                   entree*: NULL, list of entree (arguments), NULL
    2502             :  *                   char*  : function text
    2503             :  *   long menu    : which help section do we belong to
    2504             :  *                   1: Standard monadic or dyadic OPERATORS
    2505             :  *                   2: CONVERSIONS and similar elementary functions
    2506             :  *                   3: TRANSCENDENTAL functions, etc.
    2507             :  *   char *code   : GP prototype, aka Parser Code (see libpari's manual)
    2508             :  *                  if NULL, use valence instead.
    2509             :  *   char *help   : short help text (init to NULL).
    2510             :  *   void *pvalue : push_val history.
    2511             :  *   long arity   : maximum number of arguments.
    2512             :  *   entree *next : next entree (init to NULL, used in hashing code). */
    2513             : #include "init.h"
    2514             : #include "default.h"

Generated by: LCOV version 1.11