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 - es.c (source / functions) Hit Total Coverage
Test: PARI/GP v2.8.0 lcov report (development 19226-b907b8d) Lines: 1520 2540 59.8 %
Date: 2016-07-29 07:10:27 Functions: 202 293 68.9 %
Legend: Lines: hit not hit

          Line data    Source code
       1             : /* Copyright (C) 2000  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             : /**                 INPUT/OUTPUT SUBROUTINES                      **/
      17             : /**                                                               **/
      18             : /*******************************************************************/
      19             : #ifdef _WIN32
      20             : #include "../systems/mingw/pwinver.h"
      21             : #include <windows.h>
      22             : #include <process.h> /* for getpid */
      23             : #include "../systems/mingw/mingw.h"
      24             : #endif
      25             : #include "paricfg.h"
      26             : #ifdef HAS_STAT
      27             : #include <sys/stat.h>
      28             : #endif
      29             : #ifdef HAS_OPENDIR
      30             : #include <dirent.h>
      31             : #endif
      32             : 
      33             : #include "pari.h"
      34             : #include "paripriv.h"
      35             : #include "anal.h"
      36             : 
      37             : static const char esc = (0x1f & '['); /* C-[ = escape */
      38             : 
      39             : typedef struct outString {
      40             :   char *string; /* start of the output buffer */
      41             :   char *end;    /* end of the output buffer */
      42             :   char *cur;   /* current writing place in the output buffer */
      43             :   size_t size; /* buffer size */
      44             :   int use_stack; /* use stack_malloc instead of malloc ? */
      45             : } outString;
      46             : 
      47             : typedef void (*OUT_FUN)(GEN, pariout_t *, outString *);
      48             : 
      49             : static void bruti_sign(GEN g, pariout_t *T, outString *S, int addsign);
      50             : static void matbruti(GEN g, pariout_t *T, outString *S);
      51             : static void texi_sign(GEN g, pariout_t *T, outString *S, int addsign);
      52             : 
      53      667870 : static void bruti(GEN g, pariout_t *T, outString *S)
      54      667870 : { bruti_sign(g,T,S,1); }
      55          56 : static void texi(GEN g, pariout_t *T, outString *S)
      56          56 : { texi_sign(g,T,S,1); }
      57             : 
      58             : void
      59           0 : pari_ask_confirm(const char *s)
      60             : {
      61           0 :   if (!cb_pari_ask_confirm)
      62           0 :     pari_err(e_MISC,"Can't ask for confirmation. Please define cb_pari_ask_confirm()");
      63           0 :   cb_pari_ask_confirm(s);
      64           0 : }
      65             : 
      66             : /********************************************************************/
      67             : /**                                                                **/
      68             : /**                        INPUT FILTER                            **/
      69             : /**                                                                **/
      70             : /********************************************************************/
      71             : #define ONE_LINE_COMMENT   2
      72             : #define MULTI_LINE_COMMENT 1
      73             : #define LBRACE '{'
      74             : #define RBRACE '}'
      75             : 
      76             : static int
      77        1332 : in_help(filtre_t *F)
      78             : {
      79             :   char c;
      80        1332 :   if (!F->buf) return (*F->s == '?');
      81        1318 :   c = *F->buf->buf;
      82        1318 :   return c? (c == '?'): (*F->s == '?');
      83             : }
      84             : /* Filter F->s into F->t */
      85             : static char *
      86      117069 : filtre0(filtre_t *F)
      87             : {
      88      117069 :   const char *s = F->s;
      89             :   char *t;
      90             :   char c;
      91             : 
      92      117069 :   if (!F->t) F->t = (char*)pari_malloc(strlen(s)+1);
      93      117069 :   t = F->t;
      94             : 
      95      117069 :   if (F->more_input == 1) F->more_input = 0;
      96    73660424 :   while ((c = *s++))
      97             :   {
      98    73426762 :     if (F->in_string)
      99             :     {
     100     7904824 :       *t++ = c; /* copy verbatim */
     101     7904824 :       switch(c)
     102             :       {
     103             :         case '\\': /* in strings, \ is the escape character */
     104         504 :           if (*s) *t++ = *s++;
     105         504 :           break;
     106             : 
     107     1107496 :         case '"': F->in_string = 0;
     108             :       }
     109     7904824 :       continue;
     110             :     }
     111             : 
     112    65521938 :     if (F->in_comment)
     113             :     { /* look for comment's end */
     114        4238 :       if (F->in_comment == MULTI_LINE_COMMENT)
     115             :       {
     116       24588 :         while (c != '*' || *s != '/')
     117             :         {
     118       22671 :           if (!*s)
     119             :           {
     120         217 :             if (!F->more_input) F->more_input = 1;
     121         217 :             goto END;
     122             :           }
     123       22454 :           c = *s++;
     124             :         }
     125         850 :         s++;
     126             :       }
     127             :       else
     128        3171 :         while (c != '\n' && *s) c = *s++;
     129        4021 :       F->in_comment = 0;
     130        4021 :       continue;
     131             :     }
     132             : 
     133             :     /* weed out comments and spaces */
     134    65517700 :     if (c=='\\' && *s=='\\') { F->in_comment = ONE_LINE_COMMENT; continue; }
     135    65514529 :     if (isspace((int)c)) continue;
     136    64657916 :     *t++ = c;
     137    64657916 :     switch(c)
     138             :     {
     139             :       case '/':
     140      116457 :         if (*s == '*') { t--; F->in_comment = MULTI_LINE_COMMENT; }
     141      116457 :         break;
     142             : 
     143             :       case '\\':
     144         701 :         if (!*s) {
     145           7 :           if (in_help(F)) break; /* '?...\' */
     146           7 :           t--;
     147           7 :           if (!F->more_input) F->more_input = 1;
     148           7 :           goto END;
     149             :         }
     150         694 :         if (*s == '\r') s++; /* DOS */
     151         694 :         if (*s == '\n') {
     152         259 :           if (in_help(F)) break; /* '?...\' */
     153         252 :           t--; s++;
     154         252 :           if (!*s)
     155             :           {
     156         252 :             if (!F->more_input) F->more_input = 1;
     157         252 :             goto END;
     158             :           }
     159             :         } /* skip \<CR> */
     160         435 :         break;
     161             : 
     162     1107496 :       case '"': F->in_string = 1;
     163     1107496 :         break;
     164             : 
     165             :       case LBRACE:
     166        1813 :         t--;
     167        1813 :         if (F->wait_for_brace) pari_err_IMPL("embedded braces (in parser)");
     168        1813 :         F->more_input = 2;
     169        1813 :         F->wait_for_brace = 1;
     170        1813 :         break;
     171             : 
     172             :       case RBRACE:
     173        1813 :         if (!F->wait_for_brace) pari_err(e_MISC,"unexpected closing brace");
     174        1813 :         F->more_input = 0; t--;
     175        1813 :         F->wait_for_brace = 0;
     176        1813 :         break;
     177             :     }
     178             :   }
     179             : 
     180      116593 :   if (t != F->t) /* non empty input */
     181             :   {
     182      101796 :     c = t[-1]; /* last char */
     183      101796 :     if (c == '=') { if (!in_help(F)) F->more_input = 2; }
     184      100730 :     else if (! F->wait_for_brace) F->more_input = 0;
     185       22750 :     else if (c == RBRACE)       { F->more_input = 0; t--; F->wait_for_brace--;}
     186             :   }
     187             : 
     188             : END:
     189      117069 :   F->end = t; *t = 0; return F->t;
     190             : }
     191             : #undef ONE_LINE_COMMENT
     192             : #undef MULTI_LINE_COMMENT
     193             : 
     194             : char *
     195       10108 : gp_filter(const char *s)
     196             : {
     197             :   filtre_t T;
     198       10108 :   T.buf = NULL;
     199       10108 :   T.s = s;    T.in_string = 0; T.more_input = 0;
     200       10108 :   T.t = NULL; T.in_comment= 0; T.wait_for_brace = 0;
     201       10108 :   return filtre0(&T);
     202             : }
     203             : 
     204             : void
     205        4751 : init_filtre(filtre_t *F, Buffer *buf)
     206             : {
     207        4751 :   F->buf = buf;
     208        4751 :   F->in_string  = 0;
     209        4751 :   F->in_comment = 0;
     210        4751 : }
     211             : 
     212             : /********************************************************************/
     213             : /**                                                                **/
     214             : /**                        INPUT METHODS                           **/
     215             : /**                                                                **/
     216             : /********************************************************************/
     217             : /* create */
     218             : Buffer *
     219        3806 : new_buffer(void)
     220             : {
     221        3806 :   Buffer *b = (Buffer*) pari_malloc(sizeof(Buffer));
     222        3806 :   b->len = 1024;
     223        3806 :   b->buf = (char*)pari_malloc(b->len);
     224        3806 :   return b;
     225             : }
     226             : /* delete */
     227             : void
     228        4314 : delete_buffer(Buffer *b)
     229             : {
     230        8628 :   if (!b) return;
     231        4314 :   pari_free((void*)b->buf); pari_free((void*)b);
     232             : }
     233             : /* resize */
     234             : void
     235        1925 : fix_buffer(Buffer *b, long newlbuf)
     236             : {
     237        1925 :   b->len = newlbuf;
     238        1925 :   b->buf = (char*)pari_realloc((void*)b->buf, b->len);
     239        1925 : }
     240             : 
     241             : static int
     242        3367 : gp_read_stream_buf(FILE *fi, Buffer *b)
     243             : {
     244             :   input_method IM;
     245             :   filtre_t F;
     246             : 
     247        3367 :   init_filtre(&F, b);
     248             : 
     249        3367 :   IM.file = (void*)fi;
     250        3367 :   IM.fgets = (fgets_t)&fgets;
     251        3367 :   IM.getline = &file_input;
     252        3367 :   IM.free = 0;
     253        3367 :   return input_loop(&F,&IM);
     254             : }
     255             : 
     256             : GEN
     257        2401 : gp_read_stream(FILE *fi)
     258             : {
     259        2401 :   Buffer *b = new_buffer();
     260        2401 :   GEN x = gp_read_stream_buf(fi, b)? readseq(b->buf): gnil;
     261        2401 :   delete_buffer(b); return x;
     262             : }
     263             : 
     264             : static GEN
     265           0 : gp_read_from_input(input_method* IM, int loop, char *last)
     266             : {
     267           0 :   Buffer *b = new_buffer();
     268           0 :   GEN x = gnil;
     269             :   filtre_t F;
     270           0 :   if (last) *last = 0;
     271             :   do {
     272             :     char *s;
     273           0 :     init_filtre(&F, b);
     274           0 :     if (!input_loop(&F, IM)) break;
     275           0 :     s = b->buf;
     276           0 :     if (s[0])
     277             :     {
     278           0 :       x = readseq(s);
     279           0 :       if (last) *last = s[strlen(s) - 1];
     280             :     }
     281           0 :   } while (loop);
     282           0 :   delete_buffer(b);
     283           0 :   return x;
     284             : }
     285             : 
     286             : GEN
     287           7 : gp_read_file(const char *s)
     288             : {
     289           7 :   GEN x = gnil;
     290           7 :   FILE *f = switchin(s);
     291           0 :   if (file_is_binary(f))
     292             :   {
     293           0 :     x = readbin(s,f, NULL);
     294           0 :     if (!x) pari_err_FILE("input file",s);
     295             :   }
     296             :   else {
     297           0 :     Buffer *b = new_buffer();
     298           0 :     x = gnil;
     299             :     for (;;) {
     300           0 :       if (!gp_read_stream_buf(f, b)) break;
     301           0 :       if (*(b->buf)) x = readseq(b->buf);
     302           0 :     }
     303           0 :     delete_buffer(b);
     304             :   }
     305           0 :   popinfile(); return x;
     306             : }
     307             : 
     308             : static char*
     309           0 : string_gets(char *s, int size, const char **ptr)
     310             : {
     311             :   /* f is actually a const char** */
     312           0 :   const char *in = *ptr;
     313             :   int i;
     314             :   char c;
     315             : 
     316             :   /* Copy from in to s */
     317           0 :   for (i = 0; i+1 < size && in[i] != 0;)
     318             :   {
     319           0 :     s[i] = c = in[i]; i++;
     320           0 :     if (c == '\n') break;
     321             :   }
     322           0 :   s[i] = 0;  /* Terminating 0 byte */
     323           0 :   if (i == 0) return NULL;
     324             : 
     325           0 :   *ptr += i;
     326           0 :   return s;
     327             : }
     328             : 
     329             : GEN
     330           0 : gp_read_str_multiline(const char *s, char *last)
     331             : {
     332             :   input_method IM;
     333           0 :   const char *ptr = s;
     334             : 
     335           0 :   IM.file = (void*)(&ptr);
     336           0 :   IM.fgets = (fgets_t)&string_gets;
     337           0 :   IM.getline = &file_input;
     338           0 :   IM.free = 0;
     339             : 
     340           0 :   return gp_read_from_input(&IM, 1, last);
     341             : }
     342             : 
     343             : void
     344           0 : gp_embedded_init(long rsize, long vsize)
     345             : {
     346           0 :   pari_init(rsize, 500000);
     347           0 :   paristack_setsize(rsize, vsize);
     348           0 : }
     349             : 
     350             : char *
     351           0 : gp_embedded(const char *s)
     352             : {
     353             :   char last, *res;
     354             :   struct gp_context state;
     355           0 :   gp_context_save(&state);
     356           0 :   pari_CATCH(CATCH_ALL)
     357             :   {
     358           0 :     GENbin* err = copy_bin(pari_err_last());
     359           0 :     gp_context_restore(&state);
     360           0 :     res = pari_err2str(bin_copy(err));
     361             :   } pari_TRY {
     362           0 :     GEN z = gp_read_str_multiline(s, &last);
     363             :     ulong n;
     364           0 :     pari_add_hist(z, 0);
     365           0 :     n = pari_nb_hist();
     366           0 :     parivstack_reset();
     367           0 :     res = (z==gnil || last==';') ? stack_strdup(""):
     368           0 :           stack_sprintf("%%%lu = %Ps", n, pari_get_hist(n));
     369           0 :   } pari_ENDCATCH;
     370           0 :   avma = pari_mainstack->top;
     371           0 :   return res;
     372             : }
     373             : 
     374             : GEN
     375          21 : gp_readvec_stream(FILE *fi)
     376             : {
     377          21 :   pari_sp ltop = avma;
     378          21 :   Buffer *b = new_buffer();
     379          21 :   long i = 1, n = 16;
     380          21 :   GEN z = cgetg(n+1,t_VEC);
     381             :   for(;;)
     382             :   {
     383         966 :     if (!gp_read_stream_buf(fi, b)) break;
     384         945 :     if (!*(b->buf)) continue;
     385         945 :     if (i>n)
     386             :     {
     387          42 :       if (DEBUGLEVEL) err_printf("gp_readvec_stream: reaching %ld entries\n",n);
     388          42 :       n <<= 1;
     389          42 :       z = vec_lengthen(z,n);
     390             :     }
     391         945 :     gel(z,i++) = readseq(b->buf);
     392         945 :   }
     393          21 :   if (DEBUGLEVEL) err_printf("gp_readvec_stream: found %ld entries\n",i-1);
     394          21 :   setlg(z,i); delete_buffer(b);
     395          21 :   return gerepilecopy(ltop,z);
     396             : }
     397             : 
     398             : GEN
     399           0 : gp_readvec_file(char *s)
     400             : {
     401           0 :   GEN x = NULL;
     402           0 :   FILE *f = switchin(s);
     403           0 :   if (file_is_binary(f)) {
     404             :     int junk;
     405           0 :     x = readbin(s,f,&junk);
     406           0 :     if (!x) pari_err_FILE("input file",s);
     407             :   } else
     408           0 :     x = gp_readvec_stream(f);
     409           0 :   popinfile(); return x;
     410             : }
     411             : 
     412             : char *
     413      108818 : file_getline(Buffer *b, char **s0, input_method *IM)
     414             : {
     415      108818 :   const ulong MAX = (1UL << 31) - 1;
     416             :   ulong used0, used;
     417             : 
     418      108818 :   **s0 = 0; /* paranoia */
     419      108818 :   used0 = used = *s0 - b->buf;
     420             :   for(;;)
     421             :   {
     422      110547 :     ulong left = b->len - used, l, read;
     423             :     char *s;
     424             : 
     425             :     /* If little space left, double the buffer size before next read. */
     426      110547 :     if (left < 512)
     427             :     {
     428        1911 :       fix_buffer(b, b->len << 1);
     429        1911 :       left = b->len - used;
     430        1911 :       *s0 = b->buf + used0;
     431             :     }
     432             :     /* # of chars read by fgets is an int; be careful */
     433      110547 :     read = minuu(left, MAX);
     434      110547 :     s = b->buf + used;
     435      110547 :     if (! IM->fgets(s, (int)read, IM->file)) return **s0? *s0: NULL; /* EOF */
     436             : 
     437      108690 :     l = strlen(s);
     438      108690 :     if (l+1 < read || s[l-1] == '\n') return *s0; /* \n */
     439        1729 :     used += l;
     440        1729 :   }
     441             : }
     442             : 
     443             : /* Read from file (up to '\n' or EOF) and copy at s0 (points in b->buf) */
     444             : char *
     445      108818 : file_input(char **s0, int junk, input_method *IM, filtre_t *F)
     446             : {
     447             :   (void)junk;
     448      108818 :   return file_getline(F->buf, s0, IM);
     449             : }
     450             : 
     451             : /* Read a "complete line" and filter it. Return: 0 if EOF, 1 otherwise */
     452             : int
     453       82454 : input_loop(filtre_t *F, input_method *IM)
     454             : {
     455       82454 :   Buffer *b = (Buffer*)F->buf;
     456       82454 :   char *to_read, *s = b->buf;
     457             : 
     458             :   /* read first line */
     459       82454 :   if (! (to_read = IM->getline(&s,1, IM, F)) )
     460             :   {
     461        1857 :     if (F->in_string)
     462             :     {
     463           0 :       pari_warn(warner,"run-away string. Closing it");
     464           0 :       F->in_string = 0;
     465             :     }
     466        1857 :     if (F->in_comment)
     467             :     {
     468           0 :       pari_warn(warner,"run-away comment. Closing it");
     469           0 :       F->in_comment = 0;
     470             :     }
     471        1857 :     return 0;
     472             :   }
     473             : 
     474             :   /* buffer is not empty, init filter */
     475       80597 :   F->in_string = 0;
     476       80597 :   F->more_input= 0;
     477       80597 :   F->wait_for_brace = 0;
     478             :   for(;;)
     479             :   {
     480      106961 :     F->s = to_read;
     481      106961 :     F->t = s;
     482      106961 :     (void)filtre0(F); /* pre-processing of line, read by previous call to IM->getline */
     483      106961 :     if (IM->free) pari_free(to_read);
     484      106961 :     if (! F->more_input) break;
     485             : 
     486             :     /* read continuation line */
     487       26364 :     s = F->end;
     488       26364 :     to_read = IM->getline(&s,0, IM, F);
     489       26364 :     if (!to_read) break;
     490       26364 :   }
     491       80597 :   return 1;
     492             : }
     493             : 
     494             : /********************************************************************/
     495             : /**                                                                **/
     496             : /**                  GENERAL PURPOSE PRINTING                      **/
     497             : /**                                                                **/
     498             : /********************************************************************/
     499             : PariOUT *pariOut, *pariErr;
     500             : static void
     501      345615 : _fputs(const char *s, FILE *f ) {
     502             : #ifdef _WIN32
     503             :    win32_ansi_fputs(s, f);
     504             : #else
     505      345615 :   fputs(s, f);
     506             : #endif
     507      345615 : }
     508             : static void
     509     7459769 : _putc_log(char c) { if (pari_logfile) (void)putc(c, pari_logfile); }
     510             : static void
     511      345615 : _puts_log(const char *s)
     512             : {
     513      345615 :   FILE *f = pari_logfile;
     514             :   const char *p;
     515      345615 :   if (!f) return;
     516           0 :   if (logstyle != logstyle_color)
     517           0 :     while ( (p = strchr(s, esc)) )
     518             :     { /* skip ANSI color escape sequence */
     519           0 :       if ( p!=s ) fwrite(s, 1, p-s, f);
     520           0 :       s = strchr(p, 'm');
     521           0 :       if (!s) return;
     522           0 :       s++;
     523             :     }
     524           0 :   fputs(s, f);
     525             : }
     526             : static void
     527      186817 : _flush_log(void) { (void)fflush(pari_logfile); }
     528             : 
     529             : static void
     530     6769295 : normalOutC(char c) { putc(c, pari_outfile); _putc_log(c); }
     531             : static void
     532          13 : normalOutS(const char *s) { _fputs(s, pari_outfile); _puts_log(s); }
     533             : static void
     534      138814 : normalOutF(void) { fflush(pari_outfile); _flush_log(); }
     535             : static PariOUT defaultOut = {normalOutC, normalOutS, normalOutF};
     536             : 
     537             : static void
     538      690474 : normalErrC(char c) { putc(c, pari_errfile); _putc_log(c); }
     539             : static void
     540      345602 : normalErrS(const char *s) { _fputs(s, pari_errfile); _puts_log(s); }
     541             : static void
     542       48003 : normalErrF(void) { fflush(pari_errfile); _flush_log(); }
     543             : static PariOUT defaultErr = {normalErrC, normalErrS, normalErrF};
     544             : 
     545             : /**                         GENERIC PRINTING                       **/
     546             : void
     547        1328 : resetout(int initerr)
     548             : {
     549        1328 :   pariOut = &defaultOut;
     550        1328 :   if (initerr) pariErr = &defaultErr;
     551        1328 : }
     552             : void
     553        1328 : initout(int initerr)
     554             : {
     555        1328 :   pari_infile = stdin;
     556        1328 :   pari_outfile = stdout;
     557        1328 :   pari_errfile = stderr;
     558        1328 :   resetout(initerr);
     559        1328 : }
     560             : 
     561             : static int last_was_newline = 1;
     562             : 
     563             : static void
     564     1287431 : set_last_newline(char c) { last_was_newline = (c == '\n'); }
     565             : 
     566             : void
     567      850304 : out_putc(PariOUT *out, char c) { set_last_newline(c); out->putch(c); }
     568             : void
     569      158507 : pari_putc(char c) { out_putc(pariOut, c); }
     570             : 
     571             : void
     572      439822 : out_puts(PariOUT *out, const char *s) {
     573      439822 :   if (*s) { set_last_newline(s[strlen(s)-1]); out->puts(s); }
     574      439822 : }
     575             : void
     576       28439 : pari_puts(const char *s) { out_puts(pariOut, s); }
     577             : 
     578             : int
     579       66104 : pari_last_was_newline(void) { return last_was_newline; }
     580             : void
     581       92295 : pari_set_last_newline(int last) { last_was_newline = last; }
     582             : 
     583             : void
     584      122673 : pari_flush(void) { pariOut->flush(); }
     585             : 
     586             : void
     587           7 : err_flush(void) { pariErr->flush(); }
     588             : 
     589             : static GEN
     590          12 : log10_2(void)
     591          12 : { return divrr(mplog2(LOWDEFAULTPREC), mplog(utor(10,LOWDEFAULTPREC))); }
     592             : 
     593             : /* e binary exponent, return exponent in base ten */
     594             : static long
     595       15468 : ex10(long e) {
     596             :   pari_sp av;
     597             :   GEN z;
     598       15468 :   if (e >= 0) {
     599       14454 :     if (e < 1e15) return (long)(e*LOG10_2);
     600           6 :     av = avma; z = mulur(e, log10_2());
     601           6 :     z = floorr(z); e = itos(z);
     602             :   }
     603             :   else /* e < 0 */
     604             :   {
     605        1014 :     if (e > -1e15) return (long)(-(-e*LOG10_2)-1);
     606           6 :     av = avma; z = mulsr(e, log10_2());
     607           6 :     z = floorr(z); e = itos(z) - 1;
     608             :   }
     609          12 :   avma = av; return e;
     610             : }
     611             : 
     612             : static char *
     613        6167 : zeros(char *b, long nb) { while (nb-- > 0) *b++ = '0'; *b = 0; return b; }
     614             : 
     615             : /* # of decimal digits, assume l > 0 */
     616             : static long
     617      716837 : numdig(ulong l)
     618             : {
     619      716837 :   if (l < 100000)
     620             :   {
     621      481955 :     if (l < 100)    return (l < 10)? 1: 2;
     622      203010 :     if (l < 10000)  return (l < 1000)? 3: 4;
     623       50949 :     return 5;
     624             :   }
     625      234882 :   if (l < 10000000)   return (l < 1000000)? 6: 7;
     626      104056 :   if (l < 1000000000) return (l < 100000000)? 8: 9;
     627           0 :   return 10;
     628             : }
     629             : 
     630             : /* let ndig <= 9, x < 10^ndig, write in p[-ndig..-1] the decimal digits of x */
     631             : static void
     632     1447880 : utodec(char *p, ulong x, long ndig)
     633             : {
     634     1447880 :   switch(ndig)
     635             :   {
     636      756674 :     case  9: *--p = x % 10 + '0'; x = x/10;
     637      835099 :     case  8: *--p = x % 10 + '0'; x = x/10;
     638      894780 :     case  7: *--p = x % 10 + '0'; x = x/10;
     639      965925 :     case  6: *--p = x % 10 + '0'; x = x/10;
     640     1016874 :     case  5: *--p = x % 10 + '0'; x = x/10;
     641     1079943 :     case  4: *--p = x % 10 + '0'; x = x/10;
     642     1168935 :     case  3: *--p = x % 10 + '0'; x = x/10;
     643     1256494 :     case  2: *--p = x % 10 + '0'; x = x/10;
     644     1447880 :     case  1: *--p = x % 10 + '0'; x = x/10;
     645             :   }
     646     1447880 : }
     647             : 
     648             : /* convert abs(x) != 0 to str. Prepend '-' if (sx < 0) */
     649             : static char *
     650      716837 : itostr_sign(GEN x, int sx, long *len)
     651             : {
     652             :   long l, d;
     653      716837 :   ulong *res = convi(x, &l);
     654             :   /* l 9-digits words (< 10^9) + (optional) sign + \0 */
     655      716837 :   char *s = (char*)new_chunk(nchar2nlong(l*9 + 1 + 1)), *t = s;
     656             : 
     657      716837 :   if (sx < 0) *t++ = '-';
     658      716837 :   d = numdig(*--res); t += d; utodec(t, *res, d);
     659      716837 :   while (--l > 0) { t += 9; utodec(t, *--res, 9); }
     660      716837 :   *t = 0; *len = t - s; return s;
     661             : }
     662             : 
     663             : /********************************************************************/
     664             : /**                                                                **/
     665             : /**                        WRITE A REAL NUMBER                     **/
     666             : /**                                                                **/
     667             : /********************************************************************/
     668             : /* 19 digits (if 64 bits, at most 2^60-1) + 1 sign */
     669             : static const long MAX_EXPO_LEN = 20;
     670             : 
     671             : /* write z to buf, inserting '.' at 'point', 0 < point < strlen(z) */
     672             : static void
     673        8405 : wr_dec(char *buf, char *z, long point)
     674             : {
     675        8405 :   char *s = buf + point;
     676        8405 :   strncpy(buf, z, point); /* integer part */
     677        8405 :   *s++ = '.'; z += point;
     678        8405 :   while ( (*s++ = *z++) ) /* empty */;
     679        8405 : }
     680             : 
     681             : static char *
     682          21 : zerotostr(void)
     683             : {
     684          21 :   char *s = (char*)new_chunk(1);
     685          21 :   s[0] = '0';
     686          21 :   s[1] = 0; return s;
     687             : }
     688             : 
     689             : /* write a real 0 of exponent ex in format f */
     690             : static char *
     691          35 : real0tostr_width_frac(long width_frac)
     692             : {
     693             :   char *buf, *s;
     694          35 :   if (width_frac == 0) return zerotostr();
     695          28 :   buf = s = stack_malloc(width_frac + 3);
     696          28 :   *s++ = '0';
     697          28 :   *s++ = '.';
     698          28 :   (void)zeros(s, width_frac);
     699          28 :   return buf;
     700             : }
     701             : 
     702             : /* write a real 0 of exponent ex */
     703             : static char *
     704         896 : real0tostr(long ex, char format, char exp_char, long wanted_dec)
     705             : {
     706             :   char *buf, *buf0;
     707             : 
     708         896 :   if (format == 'f') {
     709           0 :     long width_frac = wanted_dec;
     710           0 :     if (width_frac < 0) width_frac = (ex >= 0)? 0: (long)(-ex * LOG10_2);
     711           0 :     return real0tostr_width_frac(width_frac);
     712             :   } else {
     713         896 :     buf0 = buf = stack_malloc(3 + MAX_EXPO_LEN + 1);
     714         896 :     *buf++ = '0';
     715         896 :     *buf++ = '.';
     716         896 :     *buf++ = exp_char;
     717         896 :     sprintf(buf, "%ld", ex10(ex) + 1);
     718             :   }
     719         896 :   return buf0;
     720             : }
     721             : 
     722             : /* format f, width_frac >= 0: number of digits in fractional part, */
     723             : static char *
     724         315 : absrtostr_width_frac(GEN x, int width_frac)
     725             : {
     726         315 :   long beta, ls, point, lx, sx = signe(x);
     727             :   char *s, *buf;
     728             :   GEN z;
     729             : 
     730         315 :   if (!sx) return real0tostr_width_frac(width_frac);
     731             : 
     732             :   /* x != 0 */
     733         280 :   lx = realprec(x);
     734         280 :   beta = width_frac;
     735         280 :   if (beta) /* >= 0 */
     736             :   { /* z = |x| 10^beta, 10^b = 5^b * 2^b, 2^b goes into exponent */
     737         280 :     if (beta > 4e9) lx++;
     738         280 :     z = mulrr(x, rpowuu(5UL, (ulong)beta, lx+1));
     739         280 :     setsigne(z, 1);
     740         280 :     shiftr_inplace(z, beta);
     741             :   }
     742             :   else
     743           0 :     z = mpabs(x);
     744         280 :   z = roundr_safe(z);
     745         280 :   if (!signe(z)) return real0tostr_width_frac(width_frac);
     746             : 
     747         280 :   s = itostr_sign(z, 1, &ls); /* ls > 0, number of digits in s */
     748         280 :   point = ls - beta; /* position of . in s; <= ls, may be < 0 */
     749         280 :   if (point > 0) /* write integer_part.fractional_part */
     750             :   {
     751             :     /* '.', trailing \0 */
     752         259 :     buf = stack_malloc( ls + 1+1 );
     753         259 :     if (ls == point)
     754           0 :       strcpy(buf, s); /* no '.' */
     755             :     else
     756         259 :       wr_dec(buf, s, point);
     757             :   } else { /* point <= 0, fractional part must be written */
     758             :     char *t;
     759             :     /* '0', '.', zeroes, trailing \0 */
     760          21 :     buf = t = stack_malloc( 1 + 1 - point + ls + 1 );
     761          21 :     *t++ = '0';
     762          21 :     *t++ = '.';
     763          21 :     t = zeros(t, -point);
     764          21 :     strcpy(t, s);
     765             :   }
     766         280 :   return buf;
     767             : }
     768             : 
     769             : /* Return t_REAL |x| in floating point format.
     770             :  * Allocate freely, the caller must clean the stack.
     771             :  *   FORMAT: E/e (exponential), F/f (floating point), G/g
     772             :  *   wanted_dec: number of significant digits to print (all if < 0).
     773             :  */
     774             : static char *
     775       15160 : absrtostr(GEN x, int sp, char FORMAT, long wanted_dec)
     776             : {
     777       15160 :   const char format = (char)tolower((int)FORMAT), exp_char = (format == FORMAT)? 'e': 'E';
     778       15160 :   long beta, ls, point, lx, sx = signe(x), ex = expo(x);
     779             :   char *s, *buf, *buf0;
     780             :   GEN z;
     781             : 
     782       15160 :   if (!sx) return real0tostr(ex, format, exp_char, wanted_dec);
     783             : 
     784             :   /* x != 0 */
     785       14264 :   lx = realprec(x);
     786       14264 :   if (wanted_dec >= 0)
     787             :   { /* reduce precision if possible */
     788       14264 :     long w = ndec2prec(wanted_dec); /* digits -> pari precision in words */
     789       14264 :     if (lx > w) lx = w; /* truncature with guard, no rounding */
     790             :   }
     791       14264 :   beta = ex10(prec2nbits(lx) - ex);
     792       14264 :   if (beta)
     793             :   { /* z = |x| 10^beta, 10^b = 5^b * 2^b, 2^b goes into exponent */
     794       14257 :     if (beta > 0)
     795             :     {
     796       14174 :       if (beta > 18) { lx++; x = rtor(x, lx); }
     797       14174 :       z = mulrr(x, rpowuu(5UL, (ulong)beta, lx+1));
     798             :     }
     799             :     else
     800             :     {
     801          83 :       if (beta < -18) { lx++; x = rtor(x, lx); }
     802          83 :       z = divrr(x, rpowuu(5UL, (ulong)-beta, lx+1));
     803             :     }
     804       14257 :     setsigne(z, 1);
     805       14257 :     shiftr_inplace(z, beta);
     806             :   }
     807             :   else
     808           7 :     z = x;
     809       14264 :   z = roundr_safe(z);
     810       14264 :   if (!signe(z)) return real0tostr(ex, format, exp_char, wanted_dec);
     811             : 
     812       14264 :   s = itostr_sign(z, 1, &ls); /* ls > 0, number of digits in s */
     813       14264 :   if (wanted_dec < 0)
     814           0 :     wanted_dec = ls;
     815       14264 :   else if (ls > wanted_dec)
     816             :   {
     817        9609 :     beta -= ls - wanted_dec;
     818        9609 :     ls = wanted_dec;
     819        9609 :     if (s[ls] >= '5') /* round up */
     820             :     {
     821             :       long i;
     822        9233 :       for (i = ls-1; i >= 0; s[i--] = '0')
     823        9212 :         if (++s[i] <= '9') break;
     824        4410 :       if (i < 0) { s[0] = '1'; beta--; }
     825             :     }
     826        9609 :     s[ls] = 0;
     827             :   }
     828             : 
     829             :   /* '.', " E", exponent, trailing \0 */
     830       14264 :   point = ls - beta; /* position of . in s; < 0 or > 0 */
     831       14264 :   if (beta <= 0 || format == 'e' || (format == 'g' && point-1 < -4))
     832             :   { /* e format */
     833         523 :     buf0 = buf = stack_malloc(ls+1+2+MAX_EXPO_LEN + 1);
     834         523 :     wr_dec(buf, s, 1); buf += ls + 1;
     835         523 :     if (sp) *buf++ = ' ';
     836         523 :     *buf++ = exp_char;
     837         523 :     sprintf(buf, "%ld", point-1);
     838             :   }
     839       13741 :   else if (point > 0) /* f format, write integer_part.fractional_part */
     840             :   {
     841        7623 :     buf0 = buf = stack_malloc(ls+1 + 1);
     842        7623 :     wr_dec(buf, s, point); /* point < ls since beta > 0 */
     843             :   }
     844             :   else /* f format, point <= 0, write fractional part */
     845             :   {
     846        6118 :     buf0 = buf = stack_malloc(2-point+ls + 1);
     847        6118 :     *buf++ = '0';
     848        6118 :     *buf++ = '.';
     849        6118 :     buf = zeros(buf, -point);
     850        6118 :     strcpy(buf, s);
     851             :   }
     852       14264 :   return buf0;
     853             : }
     854             : 
     855             : /* vsnprintf implementation rewritten from snprintf.c to be found at
     856             :  *
     857             :  * http://www.nersc.gov/~scottc/misc/docs/snort-2.1.1-RC1/snprintf_8c-source.html
     858             :  * The original code was
     859             :  *   Copyright (C) 1998-2002 Martin Roesch <roesch@sourcefire.com>
     860             :  * available under the terms of the GNU GPL version 2 or later. It
     861             :  * was itself adapted from an original version by Patrick Powell. */
     862             : 
     863             : /* Modifications for format %Ps: R.Butel IMB/CNRS 2007/12/03 */
     864             : 
     865             : /* l = old len, L = new len */
     866             : static void
     867        1124 : str_alloc0(outString *S, long l, long L)
     868             : {
     869             :   char *s;
     870        1124 :   if (S->use_stack)
     871             :   {
     872        1096 :     s = stack_malloc(L);
     873        1096 :     memcpy(s, S->string, l);
     874             :   }
     875             :   else
     876          28 :     s = (char*)pari_realloc((void*)S->string, L);
     877        1124 :   S->string = s;
     878        1124 :   S->cur = s + l;
     879        1124 :   S->end = s + L;
     880        1124 :   S->size = L;
     881        1124 : }
     882             : /* make sure S is large enough to write l further words (<= l * 20 chars).
     883             :  * To avoid automatic extension in between av = avma / avma = av pairs
     884             :  * [ would destroy S->string if (S->use_stack) ] */
     885             : static void
     886      368982 : str_alloc(outString *S, long l)
     887             : {
     888      368982 :   l *= 20;
     889      368982 :   if (S->end - S->cur <= l)
     890        1033 :     str_alloc0(S, S->cur - S->string, S->size + maxss(S->size, l));
     891      368982 : }
     892             : static void
     893     7666771 : str_putc(outString *S, char c) {
     894     7666771 :   *S->cur++ = c;
     895     7666771 :   if (S->cur == S->end) str_alloc0(S, S->size, S->size << 1);
     896     7666771 : }
     897             : 
     898             : static void
     899      195709 : str_init(outString *S, int use_stack)
     900             : {
     901             :   char *s;
     902      195709 :   S->size = 1024;
     903      195709 :   S->use_stack = use_stack;
     904      195709 :   if (S->use_stack)
     905      154009 :     s = (char*)stack_malloc(S->size);
     906             :   else
     907       41700 :     s = (char*)pari_malloc(S->size);
     908      195709 :   S->string = S->cur = s;
     909      195709 :   S->end = S->string + S->size;
     910      195709 : }
     911             : static void
     912     1227392 : str_puts(outString *S, const char *s) { while (*s) str_putc(S, *s++); }
     913             : 
     914             : static void
     915       80590 : str_putscut(outString *S, const char *str, int cut)
     916             : {
     917       80590 :   if (cut < 0) str_puts(S, str);
     918             :   else {
     919          35 :     while (*str && cut-- > 0) str_putc(S, *str++);
     920             :   }
     921       80590 : }
     922             : 
     923             : /* not stack clean */
     924             : static char *
     925      151958 : stack_GENtostr_fun(GEN x, pariout_t *T, OUT_FUN out)
     926             : {
     927      151958 :   outString S; str_init(&S, 1);
     928      151958 :   out(x, T, &S); *S.cur = 0;
     929      151958 :   return S.string;
     930             : }
     931             : /* same but remove quotes "" around t_STR */
     932             : static char *
     933      199214 : stack_GENtostr_fun_unquoted(GEN x, pariout_t *T, OUT_FUN f)
     934      199214 : { return (typ(x)==t_STR)? GSTR(x): stack_GENtostr_fun(x, T, f); }
     935             : 
     936             : /* stack-clean: pari-malloc'ed */
     937             : static char *
     938         693 : GENtostr_fun(GEN x, pariout_t *T, OUT_FUN out)
     939             : {
     940         693 :   pari_sp av = avma;
     941         693 :   outString S; str_init(&S, 0);
     942         693 :   out(x, T, &S); *S.cur = 0;
     943         693 :   avma = av; return S.string;
     944             : }
     945             : 
     946             : /* lbuf = strlen(buf), len < 0: unset */
     947             : static void
     948        4414 : outpad(outString *S, const char *buf, long lbuf, int sign, long ljust, long len, long zpad)
     949             : {
     950        4414 :   long padlen = len - lbuf;
     951        4414 :   if (padlen < 0) padlen = 0;
     952        4414 :   if (ljust) padlen = -padlen;
     953        4414 :   if (padlen > 0)
     954             :   {
     955          42 :     if (zpad) {
     956           0 :       if (sign) { str_putc(S, sign); --padlen; }
     957           0 :       while (padlen > 0) { str_putc(S, '0'); --padlen; }
     958             :     }
     959             :     else
     960             :     {
     961          42 :       if (sign) --padlen;
     962          42 :       while (padlen > 0) { str_putc(S, ' '); --padlen; }
     963          42 :       if (sign) str_putc(S, sign);
     964             :     }
     965             :   } else
     966        4372 :     if (sign) str_putc(S, sign);
     967        4414 :   str_puts(S, buf);
     968        4414 :   while (padlen < 0) { str_putc(S, ' '); ++padlen; }
     969        4414 : }
     970             : 
     971             : /* len < 0 or maxwidth < 0: unset */
     972             : static void
     973       80590 : fmtstr(outString *S, const char *buf, int ljust, int len, int maxwidth)
     974             : {
     975       80590 :   int padlen, lbuf = strlen(buf);
     976             : 
     977       80590 :   if (maxwidth >= 0 && lbuf > maxwidth) lbuf = maxwidth;
     978             : 
     979       80590 :   padlen = len - lbuf;
     980       80590 :   if (padlen < 0) padlen = 0;
     981       80590 :   if (ljust) padlen = -padlen;
     982       80590 :   while (padlen > 0) { str_putc(S, ' '); --padlen; }
     983       80590 :   str_putscut(S, buf, maxwidth);
     984       80590 :   while (padlen < 0) { str_putc(S, ' '); ++padlen; }
     985       80590 : }
     986             : 
     987             : /* abs(base) is 8, 10, 16. If base < 0, some "alternate" form
     988             :  * -- print hex in uppercase
     989             :  * -- prefix octal with 0
     990             :  * signvalue = -1: unsigned, otherwise ' ' or '+' */
     991             : static void
     992        3882 : fmtnum(outString *S, long lvalue, GEN gvalue, int base, int signvalue,
     993             :        int ljust, int len, int zpad)
     994             : {
     995             :   int caps;
     996             :   char *buf0, *buf;
     997             :   long lbuf, mxl;
     998        3882 :   GEN uvalue = NULL;
     999        3882 :   ulong ulvalue = 0;
    1000        3882 :   pari_sp av = avma; /* Assume !S->use_stack */
    1001             : 
    1002        3882 :   if (gvalue)
    1003             :   {
    1004             :     long s, l;
    1005        1078 :     if (typ(gvalue) != t_INT) {
    1006             :       long i, j, h;
    1007           0 :       l = lg(gvalue);
    1008           0 :       switch(typ(gvalue))
    1009             :       {
    1010             :         case t_VEC:
    1011           0 :           str_putc(S, '[');
    1012           0 :           for (i = 1; i < l; i++)
    1013             :           {
    1014           0 :             fmtnum(S, 0, gel(gvalue,i), base, signvalue, ljust,len,zpad);
    1015           0 :             if (i < l-1) str_putc(S, ',');
    1016             :           }
    1017           0 :           str_putc(S, ']');
    1018           0 :           return;
    1019             :         case t_COL:
    1020           0 :           str_putc(S, '[');
    1021           0 :           for (i = 1; i < l; i++)
    1022             :           {
    1023           0 :             fmtnum(S, 0, gel(gvalue,i), base, signvalue, ljust,len,zpad);
    1024           0 :             if (i < l-1) str_putc(S, ',');
    1025             :           }
    1026           0 :           str_putc(S, ']');
    1027           0 :           str_putc(S, '~');
    1028           0 :           return;
    1029             :         case t_MAT:
    1030           0 :           if (l == 1)
    1031           0 :             str_puts(S, "[;]");
    1032             :           else
    1033             :           {
    1034           0 :             h = lgcols(gvalue);
    1035           0 :             for (i=1; i<l; i++)
    1036             :             {
    1037           0 :               str_putc(S, '[');
    1038           0 :               for (j=1; j<h; j++)
    1039             :               {
    1040           0 :                 fmtnum(S, 0, gcoeff(gvalue,i,j), base, signvalue, ljust,len,zpad);
    1041           0 :                 if (j<h-1) str_putc(S, ' ');
    1042             :               }
    1043           0 :               str_putc(S, ']');
    1044           0 :               str_putc(S, '\n');
    1045           0 :               if (i<l-1) str_putc(S, '\n');
    1046             :             }
    1047             :           }
    1048           0 :           return;
    1049             :       }
    1050           0 :       gvalue = gfloor( simplify_shallow(gvalue) );
    1051           0 :       if (typ(gvalue) != t_INT)
    1052           0 :         pari_err(e_MISC,"not a t_INT in integer format conversion: %Ps", gvalue);
    1053             :     }
    1054        1078 :     s = signe(gvalue);
    1055        1078 :     if (!s) { lbuf = 1; buf = zerotostr(); signvalue = 0; goto END; }
    1056             : 
    1057        1064 :     l = lgefint(gvalue);
    1058        1064 :     uvalue = gvalue;
    1059        1064 :     if (signvalue < 0)
    1060             :     {
    1061          21 :       if (s < 0) uvalue = addii(int2n(bit_accuracy(l)), gvalue);
    1062          21 :       signvalue = 0;
    1063             :     }
    1064             :     else
    1065             :     {
    1066        1043 :       if (s < 0) { signvalue = '-'; uvalue = absi(uvalue); }
    1067             :     }
    1068        1064 :     mxl = (l-2)* 22 + 1; /* octal at worst; 22 octal chars per 64bit word */
    1069             :   } else {
    1070        2804 :     ulvalue = lvalue;
    1071        2804 :     if (signvalue < 0)
    1072         182 :       signvalue = 0;
    1073             :     else
    1074        2622 :       if (lvalue < 0) { signvalue = '-'; ulvalue = - lvalue; }
    1075        2804 :     mxl = 22 + 1; /* octal at worst; 22 octal chars to write down 2^64 - 1 */
    1076             :   }
    1077        3868 :   if (base > 0) caps = 0; else { caps = 1; base = -base; }
    1078             : 
    1079        3868 :   buf0 = buf = stack_malloc(mxl) + mxl; /* fill from the right */
    1080        3868 :   *--buf = 0; /* trailing \0 */
    1081        3868 :   if (gvalue) {
    1082        1064 :     if (base == 10) {
    1083             :       long i, l, cnt;
    1084        1043 :       ulong *larray = convi(uvalue, &l);
    1085        1043 :       larray -= l;
    1086        9331 :       for (i = 0; i < l; i++) {
    1087        8288 :         cnt = 0;
    1088        8288 :         ulvalue = larray[i];
    1089             :         do {
    1090       65758 :           *--buf = '0' + ulvalue%10;
    1091       65758 :           ulvalue = ulvalue / 10;
    1092       65758 :           cnt++;
    1093       65758 :         } while (ulvalue);
    1094        8288 :         if (i + 1 < l)
    1095        7245 :           for (;cnt<9;cnt++) *--buf = '0';
    1096             :       }
    1097          21 :     } else if (base == 16) {
    1098          21 :       long i, l = lgefint(uvalue);
    1099          21 :       GEN up = int_LSW(uvalue);
    1100          74 :       for (i = 2; i < l; i++, up = int_nextW(up)) {
    1101          53 :         ulong ucp = (ulong)*up;
    1102             :         long j;
    1103         522 :         for (j=0; j < BITS_IN_LONG/4; j++) {
    1104         490 :           unsigned char cv = ucp & 0xF;
    1105         490 :           *--buf = (caps? "0123456789ABCDEF":"0123456789abcdef")[cv];
    1106         490 :           ucp >>= 4;
    1107         490 :           if (ucp == 0 && i+1 == l) break;
    1108             :         }
    1109             :       } /* loop on hex digits in word */
    1110           0 :     } else if (base == 8) {
    1111           0 :       long i, l = lgefint(uvalue);
    1112           0 :       GEN up = int_LSW(uvalue);
    1113           0 :       ulong rem = 0;
    1114           0 :       int shift = 0;
    1115           0 :       int mask[3] = {0, 1, 3};
    1116           0 :       for (i = 2; i < l; i++, up = int_nextW(up)) {
    1117           0 :         ulong ucp = (ulong)*up;
    1118           0 :         long j, ldispo = BITS_IN_LONG;
    1119           0 :         if (shift) { /* 0, 1 or 2 */
    1120           0 :           unsigned char cv = ((ucp & mask[shift]) <<(3-shift)) + rem;
    1121           0 :           *--buf = "01234567"[cv];
    1122           0 :           ucp >>= shift;
    1123           0 :           ldispo -= shift;
    1124             :         };
    1125           0 :         shift = (shift + 3 - BITS_IN_LONG % 3) % 3;
    1126           0 :         for (j=0; j < BITS_IN_LONG/3; j++) {
    1127           0 :           unsigned char cv = ucp & 0x7;
    1128           0 :           if (ucp == 0 && i+1 == l) { rem = 0; break; };
    1129           0 :           *--buf = "01234567"[cv];
    1130           0 :           ucp >>= 3;
    1131           0 :           ldispo -= 3;
    1132           0 :           rem = ucp;
    1133           0 :           if (ldispo < 3) break;
    1134             :         }
    1135             :       } /* loop on hex digits in word */
    1136           0 :       if (rem) *--buf = "01234567"[rem];
    1137             :     }
    1138             :   } else { /* not a gvalue, thus a standard integer */
    1139             :     do {
    1140        5216 :       *--buf = (caps? "0123456789ABCDEF":"0123456789abcdef")[ulvalue % (unsigned)base ];
    1141        5216 :       ulvalue /= (unsigned)base;
    1142        5216 :     } while (ulvalue);
    1143             :   }
    1144             :   /* leading 0 if octal and alternate # form */
    1145        3868 :   if (caps && base == 8) *--buf = '0';
    1146        3868 :   lbuf = (buf0 - buf) - 1;
    1147             : END:
    1148        3882 :   outpad(S, buf, lbuf, signvalue, ljust, len, zpad);
    1149        3882 :   avma = av;
    1150             : }
    1151             : 
    1152             : static GEN
    1153        1617 : v_get_arg(GEN arg_vector, int *index, const char *save_fmt)
    1154             : {
    1155        1617 :   if (*index >= lg(arg_vector))
    1156           7 :     pari_err(e_MISC, "missing arg %d for printf format '%s'", *index, save_fmt);
    1157        1610 :   return gel(arg_vector, (*index)++);
    1158             : }
    1159             : 
    1160             : static int
    1161        4169 : dosign(int blank, int plus)
    1162             : {
    1163        4169 :   if (plus) return('+');
    1164        4155 :   if (blank) return(' ');
    1165        4155 :   return 0;
    1166             : }
    1167             : 
    1168             : /* x * 10 + 'digit whose char value is ch'. Do not check for overflow */
    1169             : static int
    1170         847 : shift_add(int x, int ch)
    1171             : {
    1172         847 :   if (x < 0) /* was unset */
    1173         665 :     x = ch - '0';
    1174             :   else
    1175         182 :     x = x*10 + ch - '0';
    1176         847 :   return x;
    1177             : }
    1178             : 
    1179             : static long
    1180         532 : get_sigd(GEN gvalue, char ch, int maxwidth)
    1181             : {
    1182             :   long sigd, e;
    1183         532 :   if (maxwidth < 0) return nbits2ndec(precreal);
    1184         518 :   switch(ch)
    1185             :   {
    1186             :     case 'E':
    1187         147 :     case 'e': sigd = maxwidth+1; break;
    1188             :     case 'F':
    1189             :     case 'f':
    1190         315 :       e = gexpo(gvalue);
    1191         315 :       if (e == -(long)HIGHEXPOBIT) /* exact 0 */
    1192           7 :         sigd = 0;
    1193             :       else
    1194         308 :         sigd = ex10(e) + 1 + maxwidth;
    1195         315 :       break;
    1196             :     /* 'g', 'G' */
    1197          56 :     default : sigd = maxwidth? maxwidth: 1; break;
    1198             :   }
    1199         518 :   return sigd;
    1200             : }
    1201             : 
    1202             : static void
    1203         560 : fmtreal(outString *S, GEN gvalue, int space, int signvalue, int FORMAT,
    1204             :         int maxwidth, int ljust, int len, int zpad)
    1205             : {
    1206         560 :   pari_sp av = avma; /* Assume !S->use_stack */
    1207             :   long sigd;
    1208             :   char *buf;
    1209             : 
    1210         560 :   if (typ(gvalue) == t_REAL)
    1211         476 :     sigd = get_sigd(gvalue, FORMAT, maxwidth);
    1212             :   else
    1213             :   {
    1214          84 :     long i, j, h, l = lg(gvalue);
    1215          84 :     switch(typ(gvalue))
    1216             :     {
    1217             :       case t_VEC:
    1218          21 :         str_putc(S, '[');
    1219          63 :         for (i = 1; i < l; i++)
    1220             :         {
    1221          42 :           fmtreal(S, gel(gvalue,i), space, signvalue, FORMAT, maxwidth,
    1222             :                   ljust,len,zpad);
    1223          42 :           if (i < l-1) str_putc(S, ',');
    1224             :         }
    1225          21 :         str_putc(S, ']');
    1226          21 :         return;
    1227             :       case t_COL:
    1228           0 :         str_putc(S, '[');
    1229           0 :         for (i = 1; i < l; i++)
    1230             :         {
    1231           0 :           fmtreal(S, gel(gvalue,i), space, signvalue, FORMAT, maxwidth,
    1232             :                   ljust,len,zpad);
    1233           0 :           if (i < l-1) str_putc(S, ',');
    1234             :         }
    1235           0 :         str_putc(S, ']');
    1236           0 :         str_putc(S, '~');
    1237           0 :         return;
    1238             :       case t_MAT:
    1239           7 :         if (l == 1)
    1240           0 :           str_puts(S, "[;]");
    1241             :         else
    1242             :         {
    1243           7 :           h = lgcols(gvalue);
    1244          21 :           for (i=1; i<l; i++)
    1245             :           {
    1246          14 :             str_putc(S, '[');
    1247          28 :             for (j=1; j<h; j++)
    1248             :             {
    1249          14 :               fmtreal(S, gcoeff(gvalue,j,i), space, signvalue, FORMAT, maxwidth,
    1250             :                       ljust,len,zpad);
    1251          14 :               if (j<h-1) str_putc(S, ' ');
    1252             :             }
    1253          14 :             str_putc(S, ']');
    1254          14 :             str_putc(S, '\n');
    1255          14 :             if (i<l-1) str_putc(S, '\n');
    1256             :           }
    1257             :         }
    1258           7 :         return;
    1259             :     }
    1260          56 :     sigd = get_sigd(gvalue, FORMAT, maxwidth);
    1261          56 :     gvalue = gtofp(gvalue, ndec2prec(sigd));
    1262          56 :     if (typ(gvalue) != t_REAL)
    1263           0 :       pari_err(e_MISC,"impossible conversion to t_REAL: %Ps",gvalue);
    1264             :   }
    1265         532 :   if ((FORMAT == 'f' || FORMAT == 'F') && maxwidth >= 0)
    1266         315 :     buf = absrtostr_width_frac(gvalue, maxwidth);
    1267             :   else
    1268         217 :     buf = absrtostr(gvalue, space, FORMAT, sigd);
    1269         532 :   if (signe(gvalue) < 0) signvalue = '-';
    1270         532 :   outpad(S, buf, strlen(buf), signvalue, ljust, len, zpad);
    1271         532 :   avma = av;
    1272             : }
    1273             : /* format handling "inspired" by the standard draft at
    1274             : -- http://www.open-std.org/jtc1/sc22/wg14/www/docs/n1124.pdf pages 274ff
    1275             :  * fmt is a standard printf format, except 'P' is a "length modifier"
    1276             :  * allowing GEN arguments. Use either the arg_vector or (if NULL) the va_list */
    1277             : static char *
    1278       40993 : sm_dopr(const char *fmt, GEN arg_vector, va_list args)
    1279             : {
    1280       40993 :   int GENflag = 0, longflag = 0, pointflag = 0;
    1281             :   int print_plus, print_blank, with_sharp, ch, ljust, len, maxwidth, zpad;
    1282             :   long lvalue;
    1283       40993 :   int index = 1;
    1284             :   GEN gvalue;
    1285       40993 :   const char *save_fmt = fmt;
    1286       40993 :   outString __S, *S = &__S;
    1287             : 
    1288       40993 :   str_init(S, 0);
    1289             : 
    1290      670719 :   while ((ch = *fmt++) != '\0') {
    1291      588754 :     switch(ch) {
    1292             :       case '%':
    1293       85361 :         ljust = zpad = 0;
    1294       85361 :         len = maxwidth = -1;
    1295       85361 :         GENflag = longflag = pointflag = 0;
    1296       85361 :         print_plus = print_blank = with_sharp = 0;
    1297             : nextch:
    1298      109444 :         ch = *fmt++;
    1299      109444 :         switch(ch) {
    1300             :           case 0:
    1301           0 :             pari_err(e_MISC, "printf: end of format");
    1302             : /*------------------------------------------------------------------------
    1303             :                              -- flags
    1304             : ------------------------------------------------------------------------*/
    1305             :           case '-':
    1306          42 :             ljust = 1;
    1307          42 :             goto nextch;
    1308             :           case '+':
    1309          14 :             print_plus = 1;
    1310          14 :             goto nextch;
    1311             :           case '#':
    1312          14 :             with_sharp = 1;
    1313          14 :             goto nextch;
    1314             :           case ' ':
    1315           0 :             print_blank = 1;
    1316           0 :             goto nextch;
    1317             :           case '0':
    1318             :             /* appears as a flag: set zero padding */
    1319         182 :             if (len < 0 && !pointflag) { zpad = '0'; goto nextch; }
    1320             : 
    1321             :             /* else part of a field width or precision */
    1322             :             /* fall through */
    1323             : /*------------------------------------------------------------------------
    1324             :                        -- maxwidth or precision
    1325             : ------------------------------------------------------------------------*/
    1326             :           case '1':
    1327             :           case '2':
    1328             :           case '3':
    1329             :           case '4':
    1330             :           case '5':
    1331             :           case '6':
    1332             :           case '7':
    1333             :           case '8':
    1334             :           case '9':
    1335         847 :             if (pointflag)
    1336         616 :               maxwidth = shift_add(maxwidth, ch);
    1337             :             else
    1338         231 :               len = shift_add(len, ch);
    1339         847 :             goto nextch;
    1340             : 
    1341             :           case '*':
    1342             :           {
    1343          28 :             int *t = pointflag? &maxwidth: &len;
    1344          28 :             if (arg_vector)
    1345          28 :               *t = (int)gtolong( v_get_arg(arg_vector, &index, save_fmt) );
    1346             :             else
    1347           0 :               *t = va_arg(args, int);
    1348          28 :             goto nextch;
    1349             :           }
    1350             :           case '.':
    1351         532 :             if (pointflag)
    1352           0 :               pari_err(e_MISC, "two '.' in conversion specification");
    1353         532 :             pointflag = 1;
    1354         532 :             goto nextch;
    1355             : /*------------------------------------------------------------------------
    1356             :                        -- length modifiers
    1357             : ------------------------------------------------------------------------*/
    1358             :           case 'l':
    1359        3791 :             if (GENflag)
    1360           0 :               pari_err(e_MISC, "P/l length modifiers in the same conversion");
    1361             : #if !defined(_WIN64)
    1362        3791 :             if (longflag)
    1363           0 :               pari_err_IMPL( "ll length modifier in printf");
    1364             : #endif
    1365        3791 :             longflag = 1;
    1366        3791 :             goto nextch;
    1367             :           case 'P':
    1368       18808 :             if (longflag)
    1369           0 :               pari_err(e_MISC, "P/l length modifiers in the same conversion");
    1370       18808 :             if (GENflag)
    1371           0 :               pari_err(e_MISC, "'P' length modifier appears twice");
    1372       18808 :             GENflag = 1;
    1373       18808 :             goto nextch;
    1374             :           case 'h': /* dummy: va_arg promotes short into int */
    1375           0 :             goto nextch;
    1376             : /*------------------------------------------------------------------------
    1377             :                        -- conversions
    1378             : ------------------------------------------------------------------------*/
    1379             :           case 'u': /* not a signed conversion: print_(blank|plus) ignored */
    1380             : #define get_num_arg() \
    1381             :   if (arg_vector) { \
    1382             :     lvalue = 0; \
    1383             :     gvalue = v_get_arg(arg_vector, &index, save_fmt); \
    1384             :   } else { \
    1385             :     if (GENflag) { \
    1386             :       lvalue = 0; \
    1387             :       gvalue = va_arg(args, GEN); \
    1388             :     } else { \
    1389             :       lvalue = longflag? va_arg(args, long): va_arg(args, int); \
    1390             :       gvalue = NULL; \
    1391             :     } \
    1392             :   }
    1393         182 :             get_num_arg();
    1394         182 :             fmtnum(S, lvalue, gvalue, 10, -1, ljust, len, zpad);
    1395         182 :             break;
    1396             :           case 'o': /* not a signed conversion: print_(blank|plus) ignored */
    1397           0 :             get_num_arg();
    1398           0 :             fmtnum(S, lvalue, gvalue, with_sharp? -8: 8, -1, ljust, len, zpad);
    1399           0 :             break;
    1400             :           case 'd':
    1401             :           case 'i':
    1402        3672 :             get_num_arg();
    1403        3665 :             fmtnum(S, lvalue, gvalue, 10,
    1404             :                    dosign(print_blank, print_plus), ljust, len, zpad);
    1405        3665 :             break;
    1406             :           case 'p':
    1407           0 :             str_putc(S, '0'); str_putc(S, 'x');
    1408           0 :             if (arg_vector)
    1409           0 :               lvalue = (long)v_get_arg(arg_vector, &index, save_fmt);
    1410             :             else
    1411           0 :               lvalue = (long)va_arg(args, void*);
    1412           0 :             fmtnum(S, lvalue, NULL, 16, -1, ljust, len, zpad);
    1413           0 :             break;
    1414             :           case 'x': /* not a signed conversion: print_(blank|plus) ignored */
    1415          14 :             if (with_sharp) { str_putc(S, '0'); str_putc(S, 'x'); }
    1416          14 :             get_num_arg();
    1417          14 :             fmtnum(S, lvalue, gvalue, 16, -1, ljust, len, zpad);
    1418          14 :             break;
    1419             :           case 'X': /* not a signed conversion: print_(blank|plus) ignored */
    1420          21 :             if (with_sharp) { str_putc(S, '0'); str_putc(S, 'X'); }
    1421          21 :             get_num_arg();
    1422          21 :             fmtnum(S, lvalue, gvalue,-16, -1, ljust, len, zpad);
    1423          21 :             break;
    1424             :           case 's':
    1425             :           {
    1426             :             char *strvalue;
    1427       80590 :             pari_sp av = avma;
    1428             : 
    1429       80590 :             if (arg_vector) {
    1430         126 :               gvalue = v_get_arg(arg_vector, &index, save_fmt);
    1431         126 :               strvalue = NULL;
    1432             :             } else {
    1433       80464 :               if (GENflag) {
    1434       18808 :                 gvalue = va_arg(args, GEN);
    1435       18808 :                 strvalue = NULL;
    1436             :               } else {
    1437       61656 :                 gvalue = NULL;
    1438       61656 :                 strvalue = va_arg(args, char *);
    1439             :               }
    1440             :             }
    1441       80590 :             if (gvalue) strvalue = GENtostr_unquoted(gvalue);
    1442       80590 :             fmtstr(S, strvalue, ljust, len, maxwidth);
    1443       80590 :             avma = av; break;
    1444             :           }
    1445             :           case 'c':
    1446          42 :             if (arg_vector) {
    1447          35 :               gvalue = v_get_arg(arg_vector, &index, save_fmt);
    1448          35 :               ch = (int)gtolong(gvalue);
    1449             :             } else {
    1450           7 :               if (GENflag)
    1451           0 :                 ch = (int)gtolong( va_arg(args,GEN) );
    1452             :               else
    1453           7 :                 ch = va_arg(args, int);
    1454             :             }
    1455          35 :             str_putc(S, ch);
    1456          35 :             break;
    1457             : 
    1458             :           case '%':
    1459         329 :             str_putc(S, ch);
    1460         329 :             continue;
    1461             :           case 'g':
    1462             :           case 'G':
    1463             :           case 'e':
    1464             :           case 'E':
    1465             :           case 'f':
    1466             :           case 'F':
    1467             :           {
    1468         504 :             pari_sp av = avma;
    1469         504 :             if (arg_vector)
    1470         343 :               gvalue = simplify_shallow( v_get_arg(arg_vector, &index, save_fmt) );
    1471             :             else {
    1472         161 :               if (GENflag)
    1473           0 :                 gvalue = simplify_shallow( va_arg(args, GEN) );
    1474             :               else
    1475         161 :                 gvalue = dbltor( va_arg(args, double) );
    1476             :             }
    1477         504 :             fmtreal(S, gvalue, GP_DATA->fmt->sp, dosign(print_blank,print_plus),
    1478             :                     ch, maxwidth, ljust, len, zpad);
    1479         504 :             avma = av; break;
    1480             :           }
    1481             :           default:
    1482           7 :             pari_err(e_MISC, "invalid conversion or specification %c in format `%s'", ch, save_fmt);
    1483             :         } /* second switch on ch */
    1484       85011 :         break;
    1485             :       default:
    1486      503393 :         str_putc(S, ch);
    1487      503393 :         break;
    1488             :     } /* first switch on ch */
    1489             :   } /* while loop on ch */
    1490       40972 :   *S->cur = 0;
    1491       40972 :   return S->string;
    1492             : }
    1493             : 
    1494             : void
    1495           0 : decode_color(long n, long *c)
    1496             : {
    1497           0 :   c[1] = n & 0xf; n >>= 4; /* foreground */
    1498           0 :   c[2] = n & 0xf; n >>= 4; /* background */
    1499           0 :   c[0] = n & 0xf; /* attribute */
    1500           0 : }
    1501             : 
    1502             : #define COLOR_LEN 16
    1503             : /* start printing in "color" c */
    1504             : /* terminal has to support ANSI color escape sequences */
    1505             : void
    1506       77745 : out_term_color(PariOUT *out, long c)
    1507             : {
    1508             :   static char s[COLOR_LEN];
    1509       77745 :   out->puts(term_get_color(s, c));
    1510       77745 : }
    1511             : void
    1512         532 : term_color(long c) { out_term_color(pariOut, c); }
    1513             : 
    1514             : /* s must be able to store 12 chars (including final \0) */
    1515             : char *
    1516       95843 : term_get_color(char *s, long n)
    1517             : {
    1518             :   long c[3], a;
    1519       95843 :   if (!s) s = stack_malloc(COLOR_LEN);
    1520             : 
    1521       95843 :   if (disable_color) { *s = 0; return s; }
    1522           0 :   if (n == c_NONE || (a = gp_colors[n]) == c_NONE)
    1523           0 :     sprintf(s, "%c[0m", esc); /* reset */
    1524             :   else
    1525             :   {
    1526           0 :     decode_color(a,c);
    1527           0 :     if (c[1]<8) c[1] += 30; else c[1] += 82;
    1528           0 :     if (a & (1L<<12)) /* transparent background */
    1529           0 :       sprintf(s, "%c[%ld;%ldm", esc, c[0], c[1]);
    1530             :     else
    1531             :     {
    1532           0 :       if (c[2]<8) c[2] += 40; else c[2] += 92;
    1533           0 :       sprintf(s, "%c[%ld;%ld;%ldm", esc, c[0], c[1], c[2]);
    1534             :     }
    1535             :   }
    1536           0 :   return s;
    1537             : }
    1538             : 
    1539             : static long
    1540      186886 : strlen_real(const char *s)
    1541             : {
    1542      186886 :   const char *t = s;
    1543      186886 :   long len = 0;
    1544     1593974 :   while (*t)
    1545             :   {
    1546     1220202 :     if (t[0] == esc && t[1] == '[')
    1547             :     { /* skip ANSI escape sequence */
    1548           0 :       t += 2;
    1549           0 :       while (*t && *t++ != 'm') /* empty */;
    1550           0 :       continue;
    1551             :     }
    1552     1220202 :     t++; len++;
    1553             :   }
    1554      186886 :   return len;
    1555             : }
    1556             : 
    1557             : #undef COLOR_LEN
    1558             : 
    1559             : /********************************************************************/
    1560             : /**                                                                **/
    1561             : /**                  PRINTING BASED ON SCREEN WIDTH                **/
    1562             : /**                                                                **/
    1563             : /********************************************************************/
    1564             : #undef larg /* problems with SCO Unix headers (ioctl_arg) */
    1565             : #ifdef HAS_TIOCGWINSZ
    1566             : #  ifdef __sun
    1567             : #    include <sys/termios.h>
    1568             : #  endif
    1569             : #  include <sys/ioctl.h>
    1570             : #endif
    1571             : 
    1572             : static int
    1573       23477 : term_width_intern(void)
    1574             : {
    1575             : #ifdef _WIN32
    1576             :   return win32_terminal_width();
    1577             : #endif
    1578             : #ifdef HAS_TIOCGWINSZ
    1579             :   {
    1580             :     struct winsize s;
    1581       23477 :     if (!(GP_DATA->flags & (gpd_EMACS|gpd_TEXMACS))
    1582       23477 :      && !ioctl(0, TIOCGWINSZ, &s)) return s.ws_col;
    1583             :   }
    1584             : #endif
    1585             :   {
    1586             :     char *str;
    1587       23477 :     if ((str = os_getenv("COLUMNS"))) return atoi(str);
    1588             :   }
    1589             : #ifdef __EMX__
    1590             :   {
    1591             :     int scrsize[2];
    1592             :     _scrsize(scrsize); return scrsize[0];
    1593             :   }
    1594             : #endif
    1595       23477 :   return 0;
    1596             : }
    1597             : 
    1598             : static int
    1599           7 : term_height_intern(void)
    1600             : {
    1601             : #ifdef _WIN32
    1602             :   return win32_terminal_height();
    1603             : #endif
    1604             : #ifdef HAS_TIOCGWINSZ
    1605             :   {
    1606             :     struct winsize s;
    1607           7 :     if (!(GP_DATA->flags & (gpd_EMACS|gpd_TEXMACS))
    1608           7 :      && !ioctl(0, TIOCGWINSZ, &s)) return s.ws_row;
    1609             :   }
    1610             : #endif
    1611             :   {
    1612             :     char *str;
    1613           7 :     if ((str = os_getenv("LINES"))) return atoi(str);
    1614             :   }
    1615             : #ifdef __EMX__
    1616             :   {
    1617             :     int scrsize[2];
    1618             :     _scrsize(scrsize); return scrsize[1];
    1619             :   }
    1620             : #endif
    1621           7 :   return 0;
    1622             : }
    1623             : 
    1624             : #define DFT_TERM_WIDTH  80
    1625             : #define DFT_TERM_HEIGHT 20
    1626             : 
    1627             : int
    1628       23477 : term_width(void)
    1629             : {
    1630       23477 :   int n = term_width_intern();
    1631       23477 :   return (n>1)? n: DFT_TERM_WIDTH;
    1632             : }
    1633             : 
    1634             : int
    1635           7 : term_height(void)
    1636             : {
    1637           7 :   int n = term_height_intern();
    1638           7 :   return (n>1)? n: DFT_TERM_HEIGHT;
    1639             : }
    1640             : 
    1641             : static ulong col_index;
    1642             : 
    1643             : /* output string wrapped after MAX_WIDTH characters (for gp -test) */
    1644             : static void
    1645     6712801 : putc_lw(char c)
    1646             : {
    1647     6712801 :   if (c == '\n') col_index = 0;
    1648     6594623 :   else if (col_index >= GP_DATA->linewrap) { normalOutC('\n'); col_index = 1; }
    1649     6538142 :   else col_index++;
    1650     6712801 :   normalOutC(c);
    1651     6712801 : }
    1652             : static void
    1653      184978 : puts_lw(const char *s) { while (*s) putc_lw(*s++); }
    1654             : 
    1655             : static PariOUT pariOut_lw= {putc_lw, puts_lw, normalOutF};
    1656             : 
    1657             : void
    1658       28323 : init_linewrap(long w) { col_index=0; GP_DATA->linewrap=w; pariOut=&pariOut_lw; }
    1659             : 
    1660             : /* output stopped after max_line have been printed, for default(lines,).
    1661             :  * n = length of prefix already printed (print up to max_lin lines) */
    1662             : void
    1663           0 : lim_lines_output(char *s, long n, long max_lin)
    1664             : {
    1665             :   long lin, col, width;
    1666             :   char c;
    1667           0 :   if (!*s) return;
    1668           0 :   width = term_width();
    1669           0 :   lin = 1;
    1670           0 :   col = n;
    1671             : 
    1672           0 :   if (lin > max_lin) return;
    1673           0 :   while ( (c = *s++) )
    1674             :   {
    1675           0 :     if (lin >= max_lin)
    1676           0 :       if (c == '\n' || col >= width-5)
    1677             :       {
    1678           0 :         pari_sp av = avma;
    1679           0 :         normalOutS(term_get_color(NULL, c_ERR)); avma = av;
    1680           0 :         normalOutS("[+++]"); return;
    1681             :       }
    1682           0 :     if (c == '\n')         { col = -1; lin++; }
    1683           0 :     else if (col == width) { col =  0; lin++; }
    1684           0 :     set_last_newline(c);
    1685           0 :     col++; normalOutC(c);
    1686             :   }
    1687             : }
    1688             : 
    1689             : static void
    1690        8120 : new_line(PariOUT *out, const char *prefix)
    1691             : {
    1692        8120 :   out_putc(out, '\n'); if (prefix) out_puts(out, prefix);
    1693        8120 : }
    1694             : 
    1695             : #define is_blank(c) ((c) == ' ' || (c) == '\n' || (c) == '\t')
    1696             : /* output: <prefix>< s wrapped at EOL >
    1697             :  *         <prefix>< ... > <str>
    1698             :  *                         ^---  (no \n at the end)
    1699             :  * If str is NULL, omit the arrow, end the text with '\n'.
    1700             :  * If prefix is NULL, use "" */
    1701             : void
    1702       21419 : print_prefixed_text(PariOUT *out, const char *s, const char *prefix,
    1703             :                     const char *str)
    1704             : {
    1705       21419 :   const long prelen = prefix? strlen_real(prefix): 0;
    1706       21419 :   const long W = term_width(), ls = strlen(s);
    1707       21419 :   long linelen = prelen;
    1708       21419 :   char *word = (char*)pari_malloc(ls + 3);
    1709             : 
    1710       21419 :   if (prefix) out_puts(out, prefix);
    1711             :   for(;;)
    1712             :   {
    1713             :     long len;
    1714      155031 :     int blank = 0;
    1715      155031 :     char *u = word;
    1716      155031 :     while (*s && !is_blank(*s)) *u++ = *s++;
    1717      155031 :     *u = 0; /* finish "word" */
    1718      155031 :     len = strlen_real(word);
    1719      155031 :     linelen += len;
    1720      155031 :     if (linelen >= W) { new_line(out, prefix); linelen = prelen + len; }
    1721      155031 :     out_puts(out, word);
    1722      457417 :     while (is_blank(*s)) {
    1723      147355 :       switch (*s) {
    1724      144660 :         case ' ': break;
    1725             :         case '\t':
    1726           0 :           linelen = (linelen & ~7UL) + 8; out_putc(out, '\t');
    1727           0 :           blank = 1; break;
    1728             :         case '\n':
    1729        2695 :           linelen = W;
    1730        2695 :           blank = 1; break;
    1731             :       }
    1732      147355 :       if (linelen >= W) { new_line(out, prefix); linelen = prelen; }
    1733      147355 :       s++;
    1734             :     }
    1735      155031 :     if (!*s) break;
    1736      133612 :     if (!blank) { out_putc(out, ' '); linelen++; }
    1737      133612 :   }
    1738       21419 :   if (!str)
    1739        5516 :     out_putc(out, '\n');
    1740             :   else
    1741             :   {
    1742       15903 :     long i,len = strlen_real(str);
    1743       15903 :     int space = (*str == ' ' && str[1]);
    1744       15903 :     if (linelen + len >= W)
    1745             :     {
    1746           7 :       new_line(out, prefix); linelen = prelen;
    1747           7 :       if (space) { str++; len--; space = 0; }
    1748             :     }
    1749       15903 :     out_term_color(out, c_OUTPUT);
    1750       15903 :     out_puts(out, str);
    1751       15903 :     if (!len || str[len-1] != '\n') out_putc(out, '\n');
    1752       15903 :     if (space) { linelen++; len--; }
    1753       15903 :     out_term_color(out, c_ERR);
    1754       15903 :     if (prefix) { out_puts(out, prefix); linelen -= prelen; }
    1755       15903 :     for (i=0; i<linelen; i++) out_putc(out, ' ');
    1756       15903 :     out_putc(out, '^');
    1757       15903 :     for (i=0; i<len; i++) out_putc(out, '-');
    1758             :   }
    1759       21419 :   pari_free(word);
    1760       21419 : }
    1761             : 
    1762             : #define STR_LEN 20
    1763             : #define MAX_TERM_COLOR 16
    1764             : /* Outputs a beautiful error message (not \n terminated)
    1765             :  *   msg is errmessage to print.
    1766             :  *   s points to the offending chars.
    1767             :  *   entry tells how much we can go back from s[0] */
    1768             : void
    1769       15952 : print_errcontext(PariOUT *out,
    1770             :                  const char *msg, const char *s, const char *entry)
    1771             : {
    1772       15952 :   const long MAX_PAST = 25;
    1773       15952 :   long past = s - entry, lmsg;
    1774             :   char str[STR_LEN + 1 + 1], pre[MAX_TERM_COLOR + 8 + 1];
    1775             :   char *buf, *t;
    1776             : 
    1777       31904 :   if (!s || !entry) { print_prefixed_text(out, msg,"  ***   ",NULL); return; }
    1778             : 
    1779             :   /* message + context */
    1780       15903 :   lmsg = strlen(msg);
    1781             :   /* msg + past + ': ' + '...' + term_get_color + \0 */
    1782       15903 :   t = buf = (char*)pari_malloc(lmsg + MAX_PAST + 2 + 3 + MAX_TERM_COLOR + 1);
    1783       15903 :   strncpy(t, msg, lmsg); t += lmsg;
    1784       15903 :   strcpy(t, ": "); t += 2;
    1785       15903 :   if (past <= 0) past = 0;
    1786             :   else
    1787             :   {
    1788        2195 :     if (past > MAX_PAST) { past = MAX_PAST; strcpy(t, "..."); t += 3; }
    1789        2195 :     term_get_color(t, c_OUTPUT);
    1790        2195 :     t += strlen(t);
    1791        2195 :     strncpy(t, s - past, past); t[past] = 0;
    1792             :   }
    1793             : 
    1794             :   /* suffix (past arrow) */
    1795       15903 :   t = str; if (!past) *t++ = ' ';
    1796       15903 :   strncpy(t, s, STR_LEN); t[STR_LEN] = 0;
    1797             :   /* prefix '***' */
    1798       15903 :   term_get_color(pre, c_ERR);
    1799       15903 :   strcat(pre, "  ***   ");
    1800             :   /* now print */
    1801       15903 :   print_prefixed_text(out, buf, pre, str);
    1802       15903 :   pari_free(buf);
    1803             : }
    1804             : 
    1805             : /********************************************************************/
    1806             : /**                                                                **/
    1807             : /**                    GEN <---> CHARACTER STRINGS                 **/
    1808             : /**                                                                **/
    1809             : /********************************************************************/
    1810             : static OUT_FUN
    1811      107111 : get_fun(long flag)
    1812             : {
    1813      107111 :   switch(flag) {
    1814       80040 :     case f_RAW : return bruti;
    1815           7 :     case f_TEX : return texi;
    1816       27064 :     default: return matbruti;
    1817             :   }
    1818             : }
    1819             : 
    1820             : char *
    1821        1295 : stack_strdup(const char *s)
    1822             : {
    1823        1295 :   long n = strlen(s)+1;
    1824        1295 :   char *t = stack_malloc(n);
    1825        1295 :   memcpy(t,s,n); return t;
    1826             : }
    1827             : char *
    1828        1176 : stack_strcat(const char *s, const char *t)
    1829             : {
    1830        1176 :   long ls = strlen(s), lt = strlen(t);
    1831        1176 :   long n = ls + lt + 1;
    1832        1176 :   char *u = stack_malloc(n);
    1833        1176 :   memcpy(u,     s, ls);
    1834        1176 :   memcpy(u + ls,t, lt+1); return u;
    1835             : }
    1836             : 
    1837             : char *
    1838       34450 : pari_strdup(const char *s)
    1839             : {
    1840       34450 :   long n = strlen(s)+1;
    1841       34450 :   char *t = (char*)pari_malloc(n);
    1842       34450 :   memcpy(t,s,n); return t;
    1843             : }
    1844             : 
    1845             : char *
    1846           0 : pari_strndup(const char *s, long n)
    1847             : {
    1848           0 :   char *t = (char*)pari_malloc(n+1);
    1849           0 :   memcpy(t,s,n); t[n] = 0; return t;
    1850             : }
    1851             : 
    1852             : /* returns a malloc-ed string, which should be freed after usage */
    1853             : /* Returns pari_malloc()ed string */
    1854             : char *
    1855           0 : GENtostr(GEN x)
    1856           0 : { return GENtostr_fun(x, GP_DATA->fmt, get_fun(GP_DATA->fmt->prettyp)); }
    1857             : char *
    1858           0 : GENtoTeXstr(GEN x) { return GENtostr_fun(x, GP_DATA->fmt, &texi); }
    1859             : char *
    1860       23047 : GENtostr_unquoted(GEN x)
    1861       23047 : { return stack_GENtostr_fun_unquoted(x, GP_DATA->fmt, &bruti); }
    1862             : char *
    1863        2359 : GENtostr_raw(GEN x) { return stack_GENtostr_fun(x,GP_DATA->fmt,&bruti); }
    1864             : 
    1865             : /* see print0(). Returns pari_malloc()ed string */
    1866             : static char *
    1867       10143 : RgV_to_str_fun(GEN g, OUT_FUN out) {
    1868       10143 :   pari_sp av = avma;
    1869             :   char *t, *t2;
    1870       10143 :   long i, tlen = 0, l = lg(g);
    1871       10143 :   GEN Ls = cgetg(l, t_VEC);
    1872       10143 :   GEN Ll = cgetg(l, t_VECSMALL);
    1873       10143 :   pariout_t *fmt = GP_DATA->fmt;
    1874       33586 :   for (i = 1; i < l; i++)
    1875             :   {
    1876       23443 :     char *s = stack_GENtostr_fun_unquoted(gel(g,i),fmt,out);
    1877       23443 :     gel(Ls,i) = (GEN)s;
    1878       23443 :     Ll[i] = strlen(s);
    1879       23443 :     tlen += Ll[i];
    1880             :   }
    1881       10143 :   t2 = t = (char*)pari_malloc(tlen + 1);
    1882       10143 :   *t = 0;
    1883       10143 :   for (i = 1; i < l; i++) { strcpy(t2, (char*)Ls[i]); t2 += Ll[i]; }
    1884       10143 :   avma = av; return t;
    1885             : }
    1886             : 
    1887             : char *
    1888           0 : RgV_to_str(GEN g, long flag) { return RgV_to_str_fun(g, get_fun(flag)); }
    1889             : 
    1890             : static GEN
    1891       10143 : Str_fun(GEN g, OUT_FUN out) {
    1892       10143 :   char *t = RgV_to_str_fun(g, out);
    1893       10143 :   GEN z = strtoGENstr(t);
    1894       10143 :   pari_free(t); return z;
    1895             : }
    1896       10129 : GEN Str(GEN g)    { return Str_fun(g, &bruti); }
    1897          14 : GEN Strtex(GEN g) { return Str_fun(g, &texi); }
    1898             : GEN
    1899           0 : Strexpand(GEN g) {
    1900           0 :   char *s = RgV_to_str_fun(g, &bruti), *t = path_expand(s);
    1901           0 :   GEN z = strtoGENstr(t);
    1902           0 :   pari_free(t); pari_free(s); return z;
    1903             : }
    1904             : 
    1905             : GEN
    1906         693 : GENtoGENstr(GEN x)
    1907             : {
    1908         693 :   char *s = GENtostr_fun(x, GP_DATA->fmt, &bruti);
    1909         693 :   GEN z = strtoGENstr(s); pari_free(s); return z;
    1910             : }
    1911             : GEN
    1912           0 : GENtoGENstr_nospace(GEN x)
    1913             : {
    1914           0 :   pariout_t T = *(GP_DATA->fmt);
    1915             :   char *s;
    1916             :   GEN z;
    1917           0 :   T.sp = 0;
    1918           0 :   s = GENtostr_fun(x, &T, &bruti);
    1919           0 :   z = strtoGENstr(s); pari_free(s); return z;
    1920             : }
    1921             : 
    1922             : static char
    1923          84 : ltoc(long n) {
    1924          84 :   if (n <= 0 || n > 255)
    1925           0 :     pari_err(e_MISC, "out of range in integer -> character conversion (%ld)", n);
    1926          84 :   return (char)n;
    1927             : }
    1928             : static char
    1929           0 : itoc(GEN x) { return ltoc(gtos(x)); }
    1930             : 
    1931             : GEN
    1932           7 : Strchr(GEN g)
    1933             : {
    1934           7 :   long i, l, len, t = typ(g);
    1935             :   char *s;
    1936             :   GEN x;
    1937           7 :   if (is_vec_t(t)) {
    1938           0 :     l = lg(g); len = nchar2nlong(l);
    1939           0 :     x = cgetg(len+1, t_STR); s = GSTR(x);
    1940           0 :     for (i=1; i<l; i++) *s++ = itoc(gel(g,i));
    1941             :   }
    1942           7 :   else if (t == t_VECSMALL)
    1943             :   {
    1944           7 :     l = lg(g); len = nchar2nlong(l);
    1945           7 :     x = cgetg(len+1, t_STR); s = GSTR(x);
    1946           7 :     for (i=1; i<l; i++) *s++ = ltoc(g[i]);
    1947             :   }
    1948             :   else
    1949           0 :     return chartoGENstr(itoc(g));
    1950           7 :   *s = 0; return x;
    1951             : }
    1952             : 
    1953             : /********************************************************************/
    1954             : /**                                                                **/
    1955             : /**                         WRITE AN INTEGER                       **/
    1956             : /**                                                                **/
    1957             : /********************************************************************/
    1958             : char *
    1959      353903 : itostr(GEN x) {
    1960      353903 :   long sx = signe(x), l;
    1961      353903 :   return sx? itostr_sign(x, sx, &l): zerotostr();
    1962             : }
    1963             : 
    1964             : /* x != 0 t_INT, write abs(x) to S */
    1965             : static void
    1966      348390 : str_absint(outString *S, GEN x)
    1967             : {
    1968             :   pari_sp av;
    1969             :   long l;
    1970      348390 :   str_alloc(S, lgefint(x)); /* careful ! */
    1971      348390 :   av = avma;
    1972      348390 :   str_puts(S, itostr_sign(x, 1, &l)); avma = av;
    1973      348390 : }
    1974             : 
    1975             : #define putsigne_nosp(S, x) str_putc(S, (x>0)? '+' : '-')
    1976             : #define putsigne(S, x) str_puts(S, (x>0)? " + " : " - ")
    1977             : #define sp_sign_sp(T,S, x) ((T)->sp? putsigne(S,x): putsigne_nosp(S,x))
    1978             : #define semicolon_sp(T,S)  ((T)->sp? str_puts(S, "; "): str_putc(S, ';'))
    1979             : #define comma_sp(T,S)      ((T)->sp? str_puts(S, ", "): str_putc(S, ','))
    1980             : 
    1981             : /* print e to S (more efficient than sprintf) */
    1982             : static void
    1983      108485 : str_ulong(outString *S, ulong e)
    1984             : {
    1985      108485 :   if (e == 0) str_putc(S, '0');
    1986             :   else
    1987             :   {
    1988      107715 :     char buf[21], *p = buf + numberof(buf);
    1989      107715 :     *--p = 0;
    1990      107715 :     if (e > 9) {
    1991             :       do
    1992       30273 :         *--p = "0123456789"[e % 10];
    1993       30273 :       while ((e /= 10) > 9);
    1994             :     }
    1995      107715 :     *--p = "0123456789"[e];
    1996      107715 :     str_puts(S, p);
    1997             :   }
    1998      108485 : }
    1999             : static void
    2000      108485 : str_long(outString *S, long e)
    2001             : {
    2002      108485 :   if (e >= 0) str_ulong(S, (ulong)e);
    2003        1316 :   else { str_putc(S, '-'); str_ulong(S, (ulong)(-e)); }
    2004      108485 : }
    2005             : 
    2006             : static void
    2007        2270 : wr_vecsmall(pariout_t *T, outString *S, GEN g)
    2008             : {
    2009             :   long i, l;
    2010        2270 :   str_puts(S, "Vecsmall(["); l = lg(g);
    2011        9311 :   for (i=1; i<l; i++)
    2012             :   {
    2013        7041 :     str_long(S, g[i]);
    2014        7041 :     if (i<l-1) comma_sp(T,S);
    2015             :   }
    2016        2270 :   str_puts(S, "])");
    2017        2270 : }
    2018             : 
    2019             : /********************************************************************/
    2020             : /**                                                                **/
    2021             : /**                       HEXADECIMAL OUTPUT                       **/
    2022             : /**                                                                **/
    2023             : /********************************************************************/
    2024             : /* English ordinal numbers -- GN1998Apr17 */
    2025             : static const char *ordsuff[4] = {"st","nd","rd","th"};
    2026             : const char*
    2027           0 : eng_ord(long i)                        /* i > 0 assumed */
    2028             : {
    2029           0 :   switch (i%10)
    2030             :   {
    2031             :     case 1:
    2032           0 :       if (i%100==11) return ordsuff[3]; /* xxx11-th */
    2033           0 :       return ordsuff[0];         /* xxx01-st, xxx21-st,... */
    2034             :     case 2:
    2035           0 :       if (i%100==12) return ordsuff[3]; /* xxx12-th */
    2036           0 :       return ordsuff[1];         /* xxx02-nd, xxx22-nd,... */
    2037             :     case 3:
    2038           0 :       if (i%100==13) return ordsuff[3]; /* xxx13-th */
    2039           0 :       return ordsuff[2];         /* xxx03-rd, xxx23-rd,... */
    2040             :     default:
    2041           0 :       return ordsuff[3];         /* xxxx4-th,... */
    2042             :   }
    2043             : }
    2044             : 
    2045             : const char *
    2046       34801 : type_name(long t)
    2047             : {
    2048             :   const char *s;
    2049       34801 :   switch(t)
    2050             :   {
    2051       10602 :     case t_INT    : s="t_INT";     break;
    2052        1666 :     case t_REAL   : s="t_REAL";    break;
    2053        2436 :     case t_INTMOD : s="t_INTMOD";  break;
    2054         336 :     case t_FRAC   : s="t_FRAC";    break;
    2055        2429 :     case t_FFELT  : s="t_FFELT";   break;
    2056         798 :     case t_COMPLEX: s="t_COMPLEX"; break;
    2057         714 :     case t_PADIC  : s="t_PADIC";   break;
    2058         693 :     case t_QUAD   : s="t_QUAD";    break;
    2059         812 :     case t_POLMOD : s="t_POLMOD";  break;
    2060         893 :     case t_POL    : s="t_POL";     break;
    2061         413 :     case t_SER    : s="t_SER";     break;
    2062          35 :     case t_RFRAC  : s="t_RFRAC";   break;
    2063          14 :     case t_QFR    : s="t_QFR";     break;
    2064          21 :     case t_QFI    : s="t_QFI";     break;
    2065        7176 :     case t_VEC    : s="t_VEC";     break;
    2066        3318 :     case t_COL    : s="t_COL";     break;
    2067        1876 :     case t_MAT    : s="t_MAT";     break;
    2068          56 :     case t_LIST   : s="t_LIST";    break;
    2069         357 :     case t_STR    : s="t_STR";     break;
    2070          49 :     case t_VECSMALL:s="t_VECSMALL";break;
    2071           7 :     case t_CLOSURE: s="t_CLOSURE"; break;
    2072         100 :     case t_ERROR:   s="t_ERROR";   break;
    2073           0 :     case t_INFINITY:s="t_INFINITY";break;
    2074           0 :     default: pari_err(e_MISC,"unknown type %ld",t);
    2075           0 :       s = NULL; /* not reached */
    2076             :   }
    2077       34801 :   return s;
    2078             : }
    2079             : 
    2080             : static char
    2081           0 : vsigne(GEN x)
    2082             : {
    2083           0 :   long s = signe(x);
    2084           0 :   if (!s) return '0';
    2085           0 :   return (s > 0) ? '+' : '-';
    2086             : }
    2087             : 
    2088             : static void
    2089           0 : blancs(long nb) { while (nb-- > 0) pari_putc(' '); }
    2090             : 
    2091             : /* write an "address" */
    2092             : static void
    2093           0 : str_addr(outString *S, ulong x)
    2094           0 : { char s[128]; sprintf(s,"%0*lx", BITS_IN_LONG/4, x); str_puts(S, s); }
    2095             : static void
    2096           0 : dbg_addr(ulong x) { pari_printf("[&=%0*lx] ", BITS_IN_LONG/4, x); }
    2097             : /* write a "word" */
    2098             : static void
    2099           0 : dbg_word(ulong x) { pari_printf("%0*lx ", BITS_IN_LONG/4, x); }
    2100             : 
    2101             : /* bl: indent level */
    2102             : static void
    2103           0 : dbg(GEN x, long nb, long bl)
    2104             : {
    2105             :   long tx,i,j,e,dx,lx;
    2106             : 
    2107           0 :   if (!x) { pari_puts("NULL\n"); return; }
    2108           0 :   tx = typ(x);
    2109           0 :   if (tx == t_INT && x == gen_0) { pari_puts("gen_0\n"); return; }
    2110           0 :   dbg_addr((ulong)x);
    2111             : 
    2112           0 :   lx = lg(x);
    2113           0 :   pari_printf("%s(lg=%ld%s):",type_name(tx)+2,lx,isclone(x)? ",CLONE" : "");
    2114           0 :   dbg_word(x[0]);
    2115           0 :   if (! is_recursive_t(tx)) /* t_INT, t_REAL, t_STR, t_VECSMALL */
    2116             :   {
    2117           0 :     if (tx == t_STR)
    2118           0 :       pari_puts("chars:");
    2119           0 :     else if (tx == t_INT)
    2120             :     {
    2121           0 :       lx = lgefint(x);
    2122           0 :       pari_printf("(%c,lgefint=%ld):", vsigne(x), lx);
    2123             :     }
    2124           0 :     else if (tx == t_REAL)
    2125           0 :       pari_printf("(%c,expo=%ld):", vsigne(x), expo(x));
    2126           0 :     if (nb < 0) nb = lx;
    2127           0 :     for (i=1; i < nb; i++) dbg_word(x[i]);
    2128           0 :     pari_putc('\n'); return;
    2129             :   }
    2130             : 
    2131           0 :   if (tx == t_PADIC)
    2132           0 :     pari_printf("(precp=%ld,valp=%ld):", precp(x), valp(x));
    2133           0 :   else if (tx == t_POL)
    2134           0 :     pari_printf("(%c,varn=%ld):", vsigne(x), varn(x));
    2135           0 :   else if (tx == t_SER)
    2136           0 :     pari_printf("(%c,varn=%ld,prec=%ld,valp=%ld):",
    2137           0 :                vsigne(x), varn(x), lg(x)-2, valp(x));
    2138           0 :   else if (tx == t_LIST)
    2139             :   {
    2140           0 :     pari_printf("(subtyp=%ld,lmax=%ld):", list_typ(x), list_nmax(x));
    2141           0 :     x = list_data(x); lx = x? lg(x): 1;
    2142           0 :     tx = t_VEC; /* print list_data as vec */
    2143           0 :   } else if (tx == t_CLOSURE)
    2144           0 :     pari_printf("(arity=%ld%s):", closure_arity(x),
    2145           0 :                                   closure_is_variadic(x)?"+":"");
    2146           0 :   for (i=1; i<lx; i++) dbg_word(x[i]);
    2147           0 :   bl+=2; pari_putc('\n');
    2148           0 :   switch(tx)
    2149             :   {
    2150             :     case t_INTMOD: case t_POLMOD:
    2151             :     {
    2152           0 :       const char *s = (tx==t_INTMOD)? "int = ": "pol = ";
    2153           0 :       blancs(bl); pari_puts("mod = "); dbg(gel(x,1),nb,bl);
    2154           0 :       blancs(bl); pari_puts(s);        dbg(gel(x,2),nb,bl);
    2155           0 :       break;
    2156             :     }
    2157             :     case t_FRAC: case t_RFRAC:
    2158           0 :       blancs(bl); pari_puts("num = "); dbg(gel(x,1),nb,bl);
    2159           0 :       blancs(bl); pari_puts("den = "); dbg(gel(x,2),nb,bl);
    2160           0 :       break;
    2161             : 
    2162             :     case t_FFELT:
    2163           0 :       blancs(bl); pari_puts("pol = "); dbg(gel(x,2),nb,bl);
    2164           0 :       blancs(bl); pari_puts("mod = "); dbg(gel(x,3),nb,bl);
    2165           0 :       blancs(bl); pari_puts("p   = "); dbg(gel(x,4),nb,bl);
    2166           0 :       break;
    2167             : 
    2168             :     case t_COMPLEX:
    2169           0 :       blancs(bl); pari_puts("real = "); dbg(gel(x,1),nb,bl);
    2170           0 :       blancs(bl); pari_puts("imag = "); dbg(gel(x,2),nb,bl);
    2171           0 :       break;
    2172             : 
    2173             :     case t_PADIC:
    2174           0 :       blancs(bl); pari_puts("  p : "); dbg(gel(x,2),nb,bl);
    2175           0 :       blancs(bl); pari_puts("p^l : "); dbg(gel(x,3),nb,bl);
    2176           0 :       blancs(bl); pari_puts("  I : "); dbg(gel(x,4),nb,bl);
    2177           0 :       break;
    2178             : 
    2179             :     case t_QUAD:
    2180           0 :       blancs(bl); pari_puts("pol = ");  dbg(gel(x,1),nb,bl);
    2181           0 :       blancs(bl); pari_puts("real = "); dbg(gel(x,2),nb,bl);
    2182           0 :       blancs(bl); pari_puts("imag = "); dbg(gel(x,3),nb,bl);
    2183           0 :       break;
    2184             : 
    2185             :     case t_POL: case t_SER:
    2186           0 :       e = (tx==t_SER)? valp(x): 0;
    2187           0 :       for (i=2; i<lx; i++)
    2188             :       {
    2189           0 :         blancs(bl); pari_printf("coef of degree %ld = ",e);
    2190           0 :         e++; dbg(gel(x,i),nb,bl);
    2191             :       }
    2192           0 :       break;
    2193             : 
    2194             :     case t_QFR: case t_QFI: case t_VEC: case t_COL:
    2195           0 :       for (i=1; i<lx; i++)
    2196             :       {
    2197           0 :         blancs(bl); pari_printf("%ld%s component = ",i,eng_ord(i));
    2198           0 :         dbg(gel(x,i),nb,bl);
    2199             :       }
    2200           0 :       break;
    2201             : 
    2202             :     case t_CLOSURE:
    2203           0 :       blancs(bl); pari_puts("code = "); dbg(closure_get_code(x),nb,bl);
    2204           0 :       blancs(bl); pari_puts("operand = "); dbg(closure_get_oper(x),nb,bl);
    2205           0 :       blancs(bl); pari_puts("data = "); dbg(closure_get_data(x),nb,bl);
    2206           0 :       blancs(bl); pari_puts("dbg/frpc/fram = "); dbg(closure_get_dbg(x),nb,bl);
    2207           0 :       if (lg(x)>=7)
    2208             :       {
    2209           0 :         blancs(bl); pari_puts("text = "); dbg(closure_get_text(x),nb,bl);
    2210           0 :         if (lg(x)>=8)
    2211             :         {
    2212           0 :           blancs(bl); pari_puts("frame = "); dbg(closure_get_frame(x),nb,bl);
    2213             :         }
    2214             :       }
    2215           0 :       break;
    2216             : 
    2217             :     case t_INFINITY:
    2218           0 :       blancs(bl); pari_printf("1st component = ");
    2219           0 :       dbg(gel(x,1),nb,bl);
    2220           0 :       break;
    2221             : 
    2222             :     case t_MAT:
    2223             :     {
    2224           0 :       GEN c = gel(x,1);
    2225           0 :       if (lx == 1) return;
    2226           0 :       if (typ(c) == t_VECSMALL)
    2227             :       {
    2228           0 :         for (i = 1; i < lx; i++)
    2229             :         {
    2230           0 :           blancs(bl); pari_printf("%ld%s column = ",i,eng_ord(i));
    2231           0 :           dbg(gel(x,i),nb,bl);
    2232             :         }
    2233             :       }
    2234             :       else
    2235             :       {
    2236           0 :         dx = lg(c);
    2237           0 :         for (i=1; i<dx; i++)
    2238           0 :           for (j=1; j<lx; j++)
    2239             :           {
    2240           0 :             blancs(bl); pari_printf("mat(%ld,%ld) = ",i,j);
    2241           0 :             dbg(gcoeff(x,i,j),nb,bl);
    2242             :           }
    2243             :       }
    2244             :     }
    2245             :   }
    2246             : }
    2247             : 
    2248             : void
    2249           0 : dbgGEN(GEN x, long nb) { dbg(x,nb,0); }
    2250             : 
    2251             : static void
    2252           0 : print_entree(entree *ep)
    2253             : {
    2254           0 :   pari_printf(" %s ",ep->name); dbg_addr((ulong)ep);
    2255           0 :   pari_printf(": hash = %ld [%ld]\n", ep->hash % functions_tblsz, ep->hash);
    2256           0 :   pari_printf("   menu = %2ld, code = %-10s",
    2257           0 :               ep->menu, ep->code? ep->code: "NULL");
    2258           0 :   if (ep->next)
    2259             :   {
    2260           0 :     pari_printf("next = %s ",(ep->next)->name);
    2261           0 :     dbg_addr((ulong)ep->next);
    2262             :   }
    2263           0 :   pari_puts("\n");
    2264           0 : }
    2265             : 
    2266             : /* s = digit n : list of entrees in functions_hash[n] (s = $: last entry)
    2267             :  *   = range m-n: functions_hash[m..n]
    2268             :  *   = identifier: entree for that identifier */
    2269             : void
    2270           0 : print_functions_hash(const char *s)
    2271             : {
    2272             :   long m, n, Max, Total;
    2273             :   entree *ep;
    2274             : 
    2275           0 :   if (isdigit((int)*s) || *s == '$')
    2276             :   {
    2277           0 :     m = functions_tblsz-1; n = atol(s);
    2278           0 :     if (*s=='$') n = m;
    2279           0 :     if (m<n) pari_err(e_MISC,"invalid range in print_functions_hash");
    2280           0 :     while (isdigit((int)*s)) s++;
    2281             : 
    2282           0 :     if (*s++ != '-') m = n;
    2283             :     else
    2284             :     {
    2285           0 :       if (*s !='$') m = minss(atol(s),m);
    2286           0 :       if (m<n) pari_err(e_MISC,"invalid range in print_functions_hash");
    2287             :     }
    2288             : 
    2289           0 :     for(; n<=m; n++)
    2290             :     {
    2291           0 :       pari_printf("*** hashcode = %lu\n",n);
    2292           0 :       for (ep=functions_hash[n]; ep; ep=ep->next) print_entree(ep);
    2293             :     }
    2294           0 :     return;
    2295             :   }
    2296           0 :   if (is_keyword_char((int)*s))
    2297             :   {
    2298           0 :     ep = is_entry(s);
    2299           0 :     if (!ep) pari_err(e_MISC,"no such function");
    2300           0 :     print_entree(ep); return;
    2301             :   }
    2302           0 :   if (*s=='-')
    2303             :   {
    2304           0 :     for (n=0; n<functions_tblsz; n++)
    2305             :     {
    2306           0 :       m=0;
    2307           0 :       for (ep=functions_hash[n]; ep; ep=ep->next) m++;
    2308           0 :       pari_printf("%3ld:%3ld ",n,m);
    2309           0 :       if (n%9 == 8) pari_putc('\n');
    2310             :     }
    2311           0 :     pari_putc('\n'); return;
    2312             :   }
    2313           0 :   Max = Total = 0;
    2314           0 :   for (n=0; n<functions_tblsz; n++)
    2315             :   {
    2316           0 :     long cnt = 0;
    2317           0 :     for (ep=functions_hash[n]; ep; ep=ep->next) { print_entree(ep); cnt++; }
    2318           0 :     Total += cnt;
    2319           0 :     if (cnt > Max) Max = cnt;
    2320             :   }
    2321           0 :   pari_printf("Total: %ld, Max: %ld\n", Total, Max);
    2322             : }
    2323             : 
    2324             : /********************************************************************/
    2325             : /**                                                                **/
    2326             : /**                        FORMATTED OUTPUT                        **/
    2327             : /**                                                                **/
    2328             : /********************************************************************/
    2329             : static const char *
    2330       59276 : get_var(long v, char *buf)
    2331             : {
    2332       59276 :   entree *ep = varentries[v];
    2333       59276 :   if (ep) return (char*)ep->name;
    2334           0 :   sprintf(buf,"t%d",(int)v); return buf;
    2335             : }
    2336             : 
    2337             : static void
    2338           0 : do_append(char **sp, char c, char *last, int count)
    2339             : {
    2340           0 :   if (*sp + count > last)
    2341           0 :     pari_err(e_MISC, "TeX variable name too long");
    2342           0 :   while (count--)
    2343           0 :     *(*sp)++ = c;
    2344           0 : }
    2345             : 
    2346             : static char *
    2347          98 : get_texvar(long v, char *buf, unsigned int len)
    2348             : {
    2349          98 :   entree *ep = varentries[v];
    2350          98 :   char *t = buf, *e = buf + len - 1;
    2351             :   const char *s;
    2352             : 
    2353          98 :   if (!ep) pari_err(e_MISC, "this object uses debugging variables");
    2354          98 :   s = ep->name;
    2355          98 :   if (strlen(s) >= len) pari_err(e_MISC, "TeX variable name too long");
    2356          98 :   while (isalpha((int)*s)) *t++ = *s++;
    2357          98 :   *t = 0;
    2358          98 :   if (isdigit((int)*s) || *s == '_') {
    2359           0 :     int seen1 = 0, seen = 0;
    2360             : 
    2361             :     /* Skip until the first non-underscore */
    2362           0 :     while (*s == '_') s++, seen++;
    2363             : 
    2364             :     /* Special-case integers and empty subscript */
    2365           0 :     if (*s == 0 || isdigit((unsigned char)*s))
    2366           0 :       seen++;
    2367             : 
    2368           0 :     do_append(&t, '_', e, 1);
    2369           0 :     do_append(&t, '{', e, 1);
    2370           0 :     do_append(&t, '[', e, seen - 1);
    2371             :     while (1) {
    2372           0 :       if (*s == '_')
    2373           0 :         seen1++, s++;
    2374             :       else {
    2375           0 :         if (seen1) {
    2376           0 :           do_append(&t, ']', e, (seen >= seen1 ? seen1 : seen) - 1);
    2377           0 :           do_append(&t, ',', e, 1);
    2378           0 :           do_append(&t, '[', e, seen1 - 1);
    2379           0 :           if (seen1 > seen)
    2380           0 :             seen = seen1;
    2381           0 :           seen1 = 0;
    2382             :         }
    2383           0 :         if (*s == 0)
    2384           0 :           break;
    2385           0 :         do_append(&t, *s++, e, 1);
    2386             :       }
    2387           0 :     }
    2388           0 :     do_append(&t, ']', e, seen - 1);
    2389           0 :     do_append(&t, '}', e, 1);
    2390           0 :     *t = 0;
    2391             :   }
    2392          98 :   return buf;
    2393             : }
    2394             : 
    2395             : void
    2396           0 : dbg_pari_heap(void)
    2397             : {
    2398             :   long nu, l, u, s;
    2399           0 :   pari_sp av = avma;
    2400           0 :   GEN adr = getheap();
    2401           0 :   pari_sp top = pari_mainstack->top, bot = pari_mainstack->bot;
    2402             : 
    2403           0 :   nu = (top-avma)/sizeof(long);
    2404           0 :   l = pari_mainstack->size/sizeof(long);
    2405           0 :   pari_printf("\n Top : %lx   Bottom : %lx   Current stack : %lx\n",
    2406             :               top, bot, avma);
    2407           0 :   pari_printf(" Used :                         %ld  long words  (%ld K)\n",
    2408           0 :               nu, nu/1024*sizeof(long));
    2409           0 :   pari_printf(" Available :                    %ld  long words  (%ld K)\n",
    2410           0 :               (l-nu), (l-nu)/1024*sizeof(long));
    2411           0 :   pari_printf(" Occupation of the PARI stack : %6.2f percent\n", 100.0*nu/l);
    2412           0 :   pari_printf(" %ld objects on heap occupy %ld long words\n\n",
    2413           0 :               itos(gel(adr,1)), itos(gel(adr,2)));
    2414           0 :   u = pari_var_next();
    2415           0 :   s = MAXVARN - pari_var_next_temp();
    2416           0 :   pari_printf(" %ld variable names used (%ld user + %ld private) out of %d\n\n",
    2417             :               u+s, u, s, MAXVARN);
    2418           0 :   avma = av;
    2419           0 : }
    2420             : 
    2421             : /* is to be printed as '0' */
    2422             : static long
    2423     2725415 : isnull(GEN g)
    2424             : {
    2425             :   long i;
    2426     2725415 :   switch (typ(g))
    2427             :   {
    2428             :     case t_INT:
    2429     2397380 :       return !signe(g);
    2430             :     case t_COMPLEX:
    2431        3843 :       return isnull(gel(g,1)) && isnull(gel(g,2));
    2432             :     case t_FFELT:
    2433        6090 :       return FF_equal0(g);
    2434             :     case t_QUAD:
    2435         973 :       return isnull(gel(g,2)) && isnull(gel(g,3));
    2436             :     case t_FRAC: case t_RFRAC:
    2437       85239 :       return isnull(gel(g,1));
    2438             :     case t_POL:
    2439       70616 :       for (i=lg(g)-1; i>1; i--)
    2440       69258 :         if (!isnull(gel(g,i))) return 0;
    2441        1358 :       return 1;
    2442             :   }
    2443      161274 :   return 0;
    2444             : }
    2445             : /* 0 coeff to be omitted in t_POL ? */
    2446             : static int
    2447     1601215 : isnull_for_pol(GEN g)
    2448             : {
    2449     1601215 :   switch(typ(g))
    2450             :   {
    2451        3962 :     case t_INTMOD: return !signe(gel(g,2));
    2452        2744 :     case t_POLMOD: return isnull(gel(g,2));
    2453     1594509 :     default:       return isnull(g);
    2454             :   }
    2455             : }
    2456             : 
    2457             : /* return 1 or -1 if g is 1 or -1, 0 otherwise*/
    2458             : static long
    2459      983260 : isone(GEN g)
    2460             : {
    2461             :   long i;
    2462      983260 :   switch (typ(g))
    2463             :   {
    2464             :     case t_INT:
    2465      685031 :       return (signe(g) && is_pm1(g))? signe(g): 0;
    2466             :     case t_FFELT:
    2467        4165 :       return FF_equal1(g);
    2468             :     case t_COMPLEX:
    2469        3934 :       return isnull(gel(g,2))? isone(gel(g,1)): 0;
    2470             :     case t_QUAD:
    2471         651 :       return isnull(gel(g,3))? isone(gel(g,2)): 0;
    2472             :     case t_FRAC: case t_RFRAC:
    2473       68698 :       return isone(gel(g,1)) * isone(gel(g,2));
    2474             :     case t_POL:
    2475       66192 :       if (!signe(g)) return 0;
    2476       66129 :       for (i=lg(g)-1; i>2; i--)
    2477       64855 :         if (!isnull(gel(g,i))) return 0;
    2478        1274 :       return isone(gel(g,2));
    2479             :   }
    2480      154589 :   return 0;
    2481             : }
    2482             : 
    2483             : /* if g is a "monomial", return its sign, 0 otherwise */
    2484             : static long
    2485      191800 : isfactor(GEN g)
    2486             : {
    2487             :   long i,deja,sig;
    2488      191800 :   switch(typ(g))
    2489             :   {
    2490             :     case t_INT: case t_REAL:
    2491      143486 :       return (signe(g)<0)? -1: 1;
    2492             :     case t_FRAC: case t_RFRAC:
    2493       30016 :       return isfactor(gel(g,1));
    2494             :     case t_FFELT:
    2495         819 :       return isfactor(FF_to_FpXQ_i(g));
    2496             :     case t_COMPLEX:
    2497         462 :       if (isnull(gel(g,1))) return isfactor(gel(g,2));
    2498         336 :       if (isnull(gel(g,2))) return isfactor(gel(g,1));
    2499         336 :       return 0;
    2500             :     case t_PADIC:
    2501        1127 :       return !signe(gel(g,4));
    2502             :     case t_QUAD:
    2503         245 :       if (isnull(gel(g,2))) return isfactor(gel(g,3));
    2504         231 :       if (isnull(gel(g,3))) return isfactor(gel(g,2));
    2505         231 :       return 0;
    2506        8736 :     case t_POL: deja = 0; sig = 1;
    2507       27699 :       for (i=lg(g)-1; i>1; i--)
    2508       25774 :         if (!isnull_for_pol(gel(g,i)))
    2509             :         {
    2510       15547 :           if (deja) return 0;
    2511        8736 :           sig=isfactor(gel(g,i)); deja=1;
    2512             :         }
    2513        1925 :       return sig? sig: 1;
    2514             :     case t_SER:
    2515         406 :       for (i=lg(g)-1; i>1; i--)
    2516         392 :         if (!isnull(gel(g,i))) return 0;
    2517             :   }
    2518        6860 :   return 1;
    2519             : }
    2520             : 
    2521             : /* return 1 if g is a "truc" (see anal.c) */
    2522             : static long
    2523       39963 : isdenom(GEN g)
    2524             : {
    2525             :   long i,deja;
    2526       39963 :   switch(typ(g))
    2527             :   {
    2528             :     case t_FRAC: case t_RFRAC:
    2529           0 :       return 0;
    2530           0 :     case t_COMPLEX: return isnull(gel(g,2));
    2531           0 :     case t_PADIC: return !signe(gel(g,4));
    2532           0 :     case t_QUAD: return isnull(gel(g,3));
    2533             : 
    2534         546 :     case t_POL: deja = 0;
    2535       15582 :       for (i=lg(g)-1; i>1; i--)
    2536       15337 :         if (!isnull(gel(g,i)))
    2537             :         {
    2538         742 :           if (deja) return 0;
    2539         546 :           if (i==2) return isdenom(gel(g,2));
    2540         546 :           if (!isone(gel(g,i))) return 0;
    2541         441 :           deja=1;
    2542             :         }
    2543         245 :       return 1;
    2544             :     case t_SER:
    2545           0 :       for (i=lg(g)-1; i>1; i--)
    2546           0 :         if (!isnull(gel(g,i))) return 0;
    2547             :   }
    2548       39417 :   return 1;
    2549             : }
    2550             : 
    2551             : /********************************************************************/
    2552             : /**                                                                **/
    2553             : /**                           RAW OUTPUT                           **/
    2554             : /**                                                                **/
    2555             : /********************************************************************/
    2556             : /* ^e */
    2557             : static void
    2558         140 : texexpo(outString *S, long e)
    2559             : {
    2560         140 :   if (e != 1) {
    2561          84 :     str_putc(S, '^');
    2562          84 :     if (e >= 0 && e < 10)
    2563          84 :     { str_putc(S, '0' + e); }
    2564             :     else
    2565             :     {
    2566           0 :       str_putc(S, '{'); str_long(S, e); str_putc(S, '}');
    2567             :     }
    2568             :   }
    2569         140 : }
    2570             : static void
    2571      153657 : wrexpo(outString *S, long e)
    2572      153657 : { if (e != 1) { str_putc(S, '^'); str_long(S, e); } }
    2573             : 
    2574             : /* v^e */
    2575             : static void
    2576      153657 : VpowE(outString *S, const char *v, long e) { str_puts(S, v); wrexpo(S,e); }
    2577             : static void
    2578         140 : texVpowE(outString *S, const char *v, long e) { str_puts(S, v); texexpo(S,e); }
    2579             : static void
    2580      135786 : monome(outString *S, const char *v, long e)
    2581      135786 : { if (e) VpowE(S, v, e); else str_putc(S, '1'); }
    2582             : static void
    2583         140 : texnome(outString *S, const char *v, long e)
    2584         140 : { if (e) texVpowE(S, v, e); else str_putc(S, '1'); }
    2585             : 
    2586             : /* ( a ) */
    2587             : static void
    2588        8001 : paren(pariout_t *T, outString *S, GEN a)
    2589        8001 : { str_putc(S, '('); bruti(a,T,S); str_putc(S, ')'); }
    2590             : static void
    2591           0 : texparen(pariout_t *T, outString *S, GEN a)
    2592             : {
    2593           0 :   if (T->TeXstyle & TEXSTYLE_PAREN)
    2594           0 :     str_puts(S, " (");
    2595             :   else
    2596           0 :     str_puts(S, " \\left(");
    2597           0 :   texi(a,T,S);
    2598           0 :   if (T->TeXstyle & TEXSTYLE_PAREN)
    2599           0 :     str_puts(S, ") ");
    2600             :   else
    2601           0 :     str_puts(S, "\\right) ");
    2602           0 : }
    2603             : 
    2604             : /* * v^d */
    2605             : static void
    2606         112 : times_texnome(outString *S, const char *v, long d)
    2607         112 : { if (d) { str_puts(S, "\\*"); texnome(S,v,d); } }
    2608             : static void
    2609      112007 : times_monome(outString *S, const char *v, long d)
    2610      112007 : { if (d) { str_putc(S, '*'); monome(S,v,d); } }
    2611             : 
    2612             : /* write a * v^d */
    2613             : static void
    2614      108339 : wr_monome(pariout_t *T, outString *S, GEN a, const char *v, long d)
    2615             : {
    2616      108339 :   long sig = isone(a);
    2617             : 
    2618      108339 :   if (sig) {
    2619       14112 :     sp_sign_sp(T,S,sig); monome(S,v,d);
    2620             :   } else {
    2621       94227 :     sig = isfactor(a);
    2622       94227 :     if (sig) { sp_sign_sp(T,S,sig); bruti_sign(a,T,S,0); }
    2623        7392 :     else { sp_sign_sp(T,S,1); paren(T,S, a); }
    2624       94227 :     times_monome(S, v, d);
    2625             :   }
    2626      108339 : }
    2627             : static void
    2628          70 : wr_texnome(pariout_t *T, outString *S, GEN a, const char *v, long d)
    2629             : {
    2630          70 :   long sig = isone(a);
    2631             : 
    2632          70 :   str_putc(S, '\n'); /* Avoid TeX buffer overflow */
    2633          70 :   if (T->TeXstyle & TEXSTYLE_BREAK) str_puts(S, "\\PARIbreak ");
    2634             : 
    2635          70 :   if (sig) {
    2636           0 :     putsigne(S,sig); texnome(S,v,d);
    2637             :   } else {
    2638          70 :     sig = isfactor(a);
    2639          70 :     if (sig) { putsigne(S,sig); texi_sign(a,T,S,0); }
    2640           0 :     else { str_puts(S, " +"); texparen(T,S, a); }
    2641          70 :     times_texnome(S, v, d);
    2642             :   }
    2643          70 : }
    2644             : 
    2645             : static void
    2646       59759 : wr_lead_monome(pariout_t *T, outString *S, GEN a,const char *v, long d, int addsign)
    2647             : {
    2648       59759 :   long sig = isone(a);
    2649       59759 :   if (sig) {
    2650       41979 :     if (addsign && sig<0) str_putc(S, '-');
    2651       41979 :     monome(S,v,d);
    2652             :   } else {
    2653       17780 :     if (isfactor(a)) bruti_sign(a,T,S,addsign);
    2654         609 :     else paren(T,S, a);
    2655       17780 :     times_monome(S, v, d);
    2656             :   }
    2657       59759 : }
    2658             : static void
    2659          98 : wr_lead_texnome(pariout_t *T, outString *S, GEN a,const char *v, long d, int addsign)
    2660             : {
    2661          98 :   long sig = isone(a);
    2662          98 :   if (sig) {
    2663          56 :     if (addsign && sig<0) str_putc(S, '-');
    2664          56 :     texnome(S,v,d);
    2665             :   } else {
    2666          42 :     if (isfactor(a)) texi_sign(a,T,S,addsign);
    2667           0 :     else texparen(T,S, a);
    2668          42 :     times_texnome(S, v, d);
    2669             :   }
    2670          98 : }
    2671             : 
    2672             : static void
    2673         490 : prints(GEN g, pariout_t *T, outString *S)
    2674         490 : { (void)T; str_long(S, (long)g); }
    2675             : 
    2676             : static void
    2677       10920 : quote_string(outString *S, char *s)
    2678             : {
    2679       10920 :   str_putc(S, '"');
    2680      394576 :   while (*s)
    2681             :   {
    2682      372736 :     char c=*s++;
    2683      372736 :     if (c=='\\' || c=='"' || c=='\033' || c=='\n' || c=='\t')
    2684             :     {
    2685        1841 :       str_putc(S, '\\');
    2686        1841 :       switch(c)
    2687             :       {
    2688        1785 :       case '\\': case '"': break;
    2689          56 :       case '\n':   c='n'; break;
    2690           0 :       case '\033': c='e'; break;
    2691           0 :       case '\t':   c='t'; break;
    2692             :       }
    2693             :     }
    2694      372736 :     str_putc(S, c);
    2695             :   }
    2696       10920 :   str_putc(S, '"');
    2697       10920 : }
    2698             : 
    2699             : static int
    2700      817488 : print_0_or_pm1(GEN g, outString *S, int addsign)
    2701             : {
    2702             :   long r;
    2703      817488 :   if (!g) { str_puts(S, "NULL"); return 1; }
    2704      817488 :   if (isnull(g)) { str_putc(S, '0'); return 1; }
    2705      675771 :   r = isone(g);
    2706      675771 :   if (r)
    2707             :   {
    2708       93664 :     if (addsign && r<0) str_putc(S, '-');
    2709       93664 :     str_putc(S, '1'); return 1;
    2710             :   }
    2711      582107 :   return 0;
    2712             : }
    2713             : 
    2714             : static void
    2715        1022 : print_precontext(GEN g, outString *S, long tex)
    2716             : {
    2717        2044 :   if (lg(g)<8 || lg(gel(g,7))==1) return;
    2718             :   else
    2719             :   {
    2720           0 :     long i, n  = closure_arity(g);
    2721           0 :     str_puts(S,"(");
    2722           0 :     for(i=1; i<=n; i++)
    2723             :     {
    2724           0 :       str_puts(S,"v");
    2725           0 :       if (tex) str_puts(S,"_{");
    2726           0 :       str_ulong(S,i);
    2727           0 :       if (tex) str_puts(S,"}");
    2728           0 :       if (i < n) str_puts(S,",");
    2729             :     }
    2730           0 :     str_puts(S,")->");
    2731             :   }
    2732             : }
    2733             : 
    2734             : static void
    2735        1393 : print_context(GEN g, pariout_t *T, outString *S, long tex)
    2736             : {
    2737        1393 :   GEN str = closure_get_text(g);
    2738        1393 :   if (lg(g)<8 || lg(gel(g,7))==1) return;
    2739          77 :   if (typ(str)==t_VEC && lg(gel(closure_get_dbg(g),3)) >= 2)
    2740          77 :   {
    2741          77 :     GEN v = closure_get_frame(g), d = gmael(closure_get_dbg(g),3,1);
    2742          77 :     long i, l = lg(v), n=0;
    2743         168 :     for(i=1; i<l; i++)
    2744          91 :       if (gel(d,i))
    2745          91 :         n++;
    2746          77 :     if (n==0) return;
    2747          77 :     str_puts(S,"my(");
    2748         168 :     for(i=1; i<l; i++)
    2749          91 :       if (gel(d,i))
    2750             :       {
    2751          91 :         entree *ep = (entree*) gel(d,i);
    2752          91 :         str_puts(S,ep->name);
    2753          91 :         str_putc(S,'=');
    2754          91 :         if (tex) texi(gel(v,l-i),T,S); else bruti(gel(v,l-i),T,S);
    2755          91 :         if (--n)
    2756          14 :           str_putc(S,',');
    2757             :       }
    2758          77 :     str_puts(S,");");
    2759             :   }
    2760             :   else
    2761             :   {
    2762           0 :     GEN v = closure_get_frame(g);
    2763           0 :     long i, l = lg(v), n  = closure_arity(g);
    2764           0 :     str_puts(S,"(");
    2765           0 :     for(i=1; i<=n; i++)
    2766             :     {
    2767           0 :       str_puts(S,"v");
    2768           0 :       if (tex) str_puts(S,"_{");
    2769           0 :       str_ulong(S,i);
    2770           0 :       if (tex) str_puts(S,"}");
    2771           0 :       str_puts(S,",");
    2772             :     }
    2773           0 :     for(i=1; i<l; i++)
    2774             :     {
    2775           0 :       if (tex) texi(gel(v,i),T,S); else bruti(gel(v,i),T,S);
    2776           0 :       if (i<l-1)
    2777           0 :         str_putc(S,',');
    2778             :     }
    2779           0 :     str_puts(S,")");
    2780             :   }
    2781             : }
    2782             : 
    2783             : static void
    2784      581981 : bruti_intern(GEN g, pariout_t *T, outString *S, int addsign)
    2785             : {
    2786      581981 :   long l,i,j,r, tg = typ(g);
    2787             :   GEN a,b;
    2788             :   const char *v;
    2789             :   char buf[32];
    2790             : 
    2791      581981 :   switch(tg)
    2792             :   {
    2793             :     case t_INT:
    2794      336546 :       if (addsign && signe(g) < 0) str_putc(S, '-');
    2795      336546 :       str_absint(S, g); break;
    2796             :     case t_REAL:
    2797             :     {
    2798             :       pari_sp av;
    2799       14943 :       str_alloc(S, lg(g)); /* careful! */
    2800       14943 :       av = avma;
    2801       14943 :       if (addsign && signe(g) < 0) str_putc(S, '-');
    2802       14943 :       str_puts(S, absrtostr(g, T->sp, (char)toupper((int)T->format), T->sigd) );
    2803       14943 :       avma = av; break;
    2804             :     }
    2805             : 
    2806             :     case t_INTMOD: case t_POLMOD:
    2807       16485 :       str_puts(S, "Mod(");
    2808       16485 :       bruti(gel(g,2),T,S); comma_sp(T,S);
    2809       16485 :       bruti(gel(g,1),T,S); str_putc(S, ')'); break;
    2810             : 
    2811             :     case t_FFELT:
    2812        2310 :       bruti_sign(FF_to_FpXQ_i(g),T,S,addsign);
    2813        2310 :       break;
    2814             : 
    2815             :     case t_FRAC: case t_RFRAC:
    2816       39963 :       r = isfactor(gel(g,1)); if (!r) str_putc(S, '(');
    2817       39963 :       bruti_sign(gel(g,1),T,S,addsign);
    2818       39963 :       if (!r) str_putc(S, ')');
    2819       39963 :       str_putc(S, '/');
    2820       39963 :       r = isdenom(gel(g,2)); if (!r) str_putc(S, '(');
    2821       39963 :       bruti(gel(g,2),T,S);
    2822       39963 :       if (!r) str_putc(S, ')');
    2823       39963 :       break;
    2824             : 
    2825        3892 :     case t_COMPLEX: case t_QUAD: r = (tg==t_QUAD);
    2826        3892 :       a = gel(g,r+1); b = gel(g,r+2); v = r? "w": "I";
    2827        3892 :       if (isnull(a))
    2828             :       {
    2829         735 :         wr_lead_monome(T,S,b,v,1,addsign);
    2830         735 :         return;
    2831             :       }
    2832        3157 :       bruti_sign(a,T,S,addsign);
    2833        3157 :       if (!isnull(b)) wr_monome(T,S,b,v,1);
    2834        3157 :       break;
    2835             : 
    2836       56931 :     case t_POL: v = get_var(varn(g), buf);
    2837             :       /* hack: we want g[i] = coeff of degree i. */
    2838       56931 :       i = degpol(g); g += 2; while (isnull(gel(g,i))) i--;
    2839       56931 :       wr_lead_monome(T,S,gel(g,i),v,i,addsign);
    2840     1676283 :       while (i--)
    2841             :       {
    2842     1562421 :         a = gel(g,i);
    2843     1562421 :         if (!isnull_for_pol(a)) wr_monome(T,S,a,v,i);
    2844             :       }
    2845       56931 :       break;
    2846             : 
    2847        2345 :     case t_SER: v = get_var(varn(g), buf);
    2848        2345 :       i = valp(g);
    2849        2345 :       l = lg(g)-2;
    2850        2345 :       if (l)
    2851             :       {
    2852             :         /* See normalize(): Mod(0,2)*x^i*(1+O(x)), has valp = i+1 */
    2853        2093 :         if (l == 1 && !signe(g) && isexactzero(gel(g,2))) i--;
    2854             :         /* hack: we want g[i] = coeff of degree i */
    2855        2093 :         l += i; g -= i-2;
    2856        2093 :         wr_lead_monome(T,S,gel(g,i),v,i,addsign);
    2857       17010 :         while (++i < l)
    2858             :         {
    2859       12824 :           a = gel(g,i);
    2860       12824 :           if (!isnull_for_pol(a)) wr_monome(T,S,a,v,i);
    2861             :         }
    2862        2093 :         sp_sign_sp(T,S,1);
    2863             :       }
    2864        2345 :       str_puts(S, "O("); VpowE(S, v, i); str_putc(S, ')'); break;
    2865             : 
    2866             :     case t_PADIC:
    2867             :     {
    2868        5649 :       GEN p = gel(g,2);
    2869             :       pari_sp av, av0;
    2870             :       char *ev;
    2871        5649 :       str_alloc(S, (precp(g)+1) * lgefint(p)); /* careful! */
    2872        5649 :       av0 = avma;
    2873        5649 :       ev = itostr(p);
    2874        5649 :       av = avma;
    2875        5649 :       i = valp(g); l = precp(g)+i;
    2876        5649 :       g = gel(g,4);
    2877       32718 :       for (; i<l; i++)
    2878             :       {
    2879       27069 :         g = dvmdii(g,p,&a);
    2880       27069 :         if (signe(a))
    2881             :         {
    2882       18865 :           if (!i || !is_pm1(a))
    2883             :           {
    2884       11844 :             str_absint(S, a); if (i) str_putc(S, '*');
    2885             :           }
    2886       18865 :           if (i) VpowE(S, ev,i);
    2887       18865 :           sp_sign_sp(T,S,1);
    2888             :         }
    2889       27069 :         if ((i & 0xff) == 0) g = gerepileuptoint(av,g);
    2890             :       }
    2891        5649 :       str_puts(S, "O("); VpowE(S, ev,i); str_putc(S, ')');
    2892        5649 :       avma = av0; break;
    2893             :     }
    2894             : 
    2895         280 :     case t_QFR: case t_QFI: r = (tg == t_QFR);
    2896         280 :       str_puts(S, "Qfb(");
    2897         280 :       bruti(gel(g,1),T,S); comma_sp(T,S);
    2898         280 :       bruti(gel(g,2),T,S); comma_sp(T,S);
    2899         280 :       bruti(gel(g,3),T,S);
    2900         280 :       if (r) { comma_sp(T,S); bruti(gel(g,4),T,S); }
    2901         280 :       str_putc(S, ')'); break;
    2902             : 
    2903             :     case t_VEC: case t_COL:
    2904       76345 :       str_putc(S, '['); l = lg(g);
    2905      314661 :       for (i=1; i<l; i++)
    2906             :       {
    2907      238316 :         bruti(gel(g,i),T,S);
    2908      238316 :         if (i<l-1) comma_sp(T,S);
    2909             :       }
    2910       76345 :       str_putc(S, ']'); if (tg==t_COL) str_putc(S, '~');
    2911       76345 :       break;
    2912        2270 :     case t_VECSMALL: wr_vecsmall(T,S,g); break;
    2913             : 
    2914             :     case t_LIST:
    2915         252 :       switch (list_typ(g))
    2916             :       {
    2917             :       case t_LIST_RAW:
    2918         217 :         str_puts(S, "List([");
    2919         217 :         g = list_data(g);
    2920         217 :         l = g? lg(g): 1;
    2921         854 :         for (i=1; i<l; i++)
    2922             :         {
    2923         637 :           bruti(gel(g,i),T,S);
    2924         637 :           if (i<l-1) comma_sp(T,S);
    2925             :         }
    2926         217 :         str_puts(S, "])"); break;
    2927             :       case t_LIST_MAP:
    2928             :         {
    2929             :           pari_sp av;
    2930          35 :           str_puts(S, "Map(");
    2931          35 :           av = avma;
    2932          35 :           bruti(maptomat_shallow(g),T,S);
    2933          35 :           avma = av;
    2934          35 :           str_puts(S, ")"); break;
    2935             :         }
    2936             :       }
    2937         252 :       break;
    2938             :     case t_STR:
    2939        3304 :       quote_string(S, GSTR(g)); break;
    2940             :     case t_ERROR:
    2941             :       {
    2942        7616 :         char *s = pari_err2str(g);
    2943        7616 :         str_puts(S, "error(");
    2944        7616 :         quote_string(S, s); pari_free(s);
    2945        7616 :         str_puts(S, ")"); break;
    2946             :       }
    2947             :     case t_CLOSURE:
    2948        1393 :       if (lg(g)>=7)
    2949             :       {
    2950        1393 :         GEN str = closure_get_text(g);
    2951        1393 :         if (typ(str)==t_STR)
    2952             :         {
    2953        1022 :           print_precontext(g, S, 0);
    2954        1022 :           str_puts(S, GSTR(str));
    2955        1022 :           print_context(g, T, S, 0);
    2956             :         }
    2957             :         else
    2958             :         {
    2959         371 :           str_putc(S,'(');   str_puts(S,GSTR(gel(str,1)));
    2960         371 :           str_puts(S,")->");
    2961         371 :           print_context(g, T, S, 0);
    2962         371 :           str_puts(S,GSTR(gel(str,2)));
    2963             :         }
    2964             :       }
    2965             :       else
    2966             :       {
    2967           0 :         str_puts(S,"{\""); str_puts(S,GSTR(closure_get_code(g)));
    2968           0 :         str_puts(S,"\","); wr_vecsmall(T,S,closure_get_oper(g));
    2969           0 :         str_putc(S,',');   bruti(gel(g,4),T,S);
    2970           0 :         str_putc(S,',');   bruti(gel(g,5),T,S);
    2971           0 :         str_putc(S,'}');
    2972             :       }
    2973        1393 :       break;
    2974         476 :     case t_INFINITY: str_puts(S, inf_get_sign(g) == 1? "+oo": "-oo");
    2975         476 :       break;
    2976             : 
    2977             :     case t_MAT:
    2978             :     {
    2979             :       OUT_FUN print;
    2980             : 
    2981       10981 :       r = lg(g); if (r==1) { str_puts(S, "[;]"); return; }
    2982       10211 :       l = lgcols(g);
    2983       10211 :       if (l==1)
    2984             :       {
    2985          91 :         str_puts(S, "matrix(0,");
    2986          91 :         str_long(S, r-1);
    2987          91 :         str_putc(S, ')');
    2988          91 :         return;
    2989             :       }
    2990       10120 :       print = (typ(gel(g,1)) == t_VECSMALL)? prints: bruti;
    2991       10120 :       if (l==2)
    2992             :       {
    2993        3255 :         str_puts(S, "Mat(");
    2994        3255 :         if (r == 2) { print(gcoeff(g,1,1),T,S); str_putc(S, ')'); return; }
    2995             :       }
    2996        8867 :       str_putc(S, '[');
    2997       42448 :       for (i=1; i<l; i++)
    2998             :       {
    2999      183497 :         for (j=1; j<r; j++)
    3000             :         {
    3001      149916 :           print(gcoeff(g,i,j),T,S);
    3002      149916 :           if (j<r-1) comma_sp(T,S);
    3003             :         }
    3004       33581 :         if (i<l-1) semicolon_sp(T,S);
    3005             :       }
    3006        8867 :       str_putc(S, ']'); if (l==2) str_putc(S, ')');
    3007        8867 :       break;
    3008             :     }
    3009             : 
    3010           0 :     default: str_addr(S, *g);
    3011             :   }
    3012             : }
    3013             : 
    3014             : static void
    3015      817306 : bruti_sign(GEN g, pariout_t *T, outString *S, int addsign)
    3016             : {
    3017      817306 :   if (!print_0_or_pm1(g, S, addsign))
    3018      581932 :     bruti_intern(g, T, S, addsign);
    3019      817306 : }
    3020             : 
    3021             : static void
    3022       27064 : matbruti(GEN g, pariout_t *T, outString *S)
    3023             : {
    3024       27064 :   long i, j, r, w, l, *pad = NULL;
    3025             :   pari_sp av;
    3026             :   OUT_FUN print;
    3027             : 
    3028       27064 :   if (typ(g) != t_MAT) { bruti(g,T,S); return; }
    3029             : 
    3030        2205 :   r=lg(g); if (r==1 || lgcols(g)==1) { str_puts(S, "[;]"); return; }
    3031        2051 :   l = lgcols(g); str_putc(S, '\n');
    3032        2051 :   print = (typ(gel(g,1)) == t_VECSMALL)? prints: bruti;
    3033        2051 :   av = avma;
    3034        2051 :   w = term_width();
    3035        2051 :   if (2*r < w)
    3036             :   {
    3037        2051 :     long lgall = 2; /* opening [ and closing ] */
    3038             :     pari_sp av2;
    3039             :     outString scratchstr;
    3040        2051 :     pad = cgetg(l*r+1, t_VECSMALL); /* left on stack if (S->use_stack)*/
    3041        2051 :     av2 = avma;
    3042        2051 :     str_init(&scratchstr, 1);
    3043        7588 :     for (j=1; j<r; j++)
    3044             :     {
    3045        5747 :       GEN col = gel(g,j);
    3046        5747 :       long maxc = 0;
    3047       28287 :       for (i=1; i<l; i++)
    3048             :       {
    3049             :         long lgs;
    3050       22540 :         scratchstr.cur = scratchstr.string;
    3051       22540 :         print(gel(col,i),T,&scratchstr);
    3052       22540 :         lgs = scratchstr.cur-scratchstr.string;
    3053       22540 :         pad[j*l+i] = -lgs;
    3054       22540 :         if (maxc < lgs) maxc = lgs;
    3055             :       }
    3056        5747 :       for (i=1; i<l; i++) pad[j*l+i] += maxc;
    3057        5747 :       lgall += maxc + 1; /* column width, including separating space */
    3058        5747 :       if (lgall > w) { pad = NULL; break; } /* doesn't fit, abort padding */
    3059             :     }
    3060        2051 :     avma = av2;
    3061             :   }
    3062        8568 :   for (i=1; i<l; i++)
    3063             :   {
    3064        6517 :     str_putc(S, '[');
    3065       29729 :     for (j=1; j<r; j++)
    3066             :     {
    3067       23212 :       if (pad) {
    3068       20713 :         long white = pad[j*l+i];
    3069       20713 :         while (white-- > 0) str_putc(S, ' ');
    3070             :       }
    3071       23212 :       print(gcoeff(g,i,j),T,S); if (j<r-1) str_putc(S, ' ');
    3072             :     }
    3073        6517 :     if (i<l-1) str_puts(S, "]\n\n"); else str_puts(S, "]\n");
    3074             :   }
    3075        2051 :   if (!S->use_stack) avma = av;
    3076             : }
    3077             : 
    3078             : /********************************************************************/
    3079             : /**                                                                **/
    3080             : /**                           TeX OUTPUT                           **/
    3081             : /**                                                                **/
    3082             : /********************************************************************/
    3083             : /* this follows bruti_sign */
    3084             : static void
    3085         182 : texi_sign(GEN g, pariout_t *T, outString *S, int addsign)
    3086             : {
    3087             :   long tg,i,j,l,r;
    3088             :   GEN a,b;
    3089             :   const char *v;
    3090             :   char buf[67];
    3091             : 
    3092         364 :   if (print_0_or_pm1(g, S, addsign)) return;
    3093             : 
    3094         175 :   tg = typ(g);
    3095         175 :   switch(tg)
    3096             :   {
    3097             :     case t_INT: case t_REAL: case t_QFR: case t_QFI:
    3098          49 :       bruti_intern(g, T, S, addsign); break;
    3099             : 
    3100             :     case t_INTMOD: case t_POLMOD:
    3101           0 :       texi(gel(g,2),T,S); str_puts(S, " mod ");
    3102           0 :       texi(gel(g,1),T,S); break;
    3103             : 
    3104             :     case t_FRAC:
    3105           7 :       if (addsign && isfactor(gel(g,1)) < 0) str_putc(S, '-');
    3106           7 :       str_puts(S, "\\frac{");
    3107           7 :       texi_sign(gel(g,1),T,S,0);
    3108           7 :       str_puts(S, "}{");
    3109           7 :       texi_sign(gel(g,2),T,S,0);
    3110           7 :       str_puts(S, "}"); break;
    3111             : 
    3112             :     case t_RFRAC:
    3113          14 :       str_puts(S, "\\frac{");
    3114          14 :       texi(gel(g,1),T,S); /* too complicated otherwise */
    3115          14 :       str_puts(S, "}{");
    3116          14 :       texi(gel(g,2),T,S);
    3117          14 :       str_puts(S, "}"); break;
    3118             : 
    3119             :     case t_FFELT:
    3120           0 :       bruti_sign(FF_to_FpXQ_i(g),T,S,addsign);
    3121           0 :       break;
    3122             : 
    3123           0 :     case t_COMPLEX: case t_QUAD: r = (tg==t_QUAD);
    3124           0 :       a = gel(g,r+1); b = gel(g,r+2); v = r? "w": "I";
    3125           0 :       if (isnull(a))
    3126             :       {
    3127           0 :         wr_lead_texnome(T,S,b,v,1,addsign);
    3128           0 :         break;
    3129             :       }
    3130           0 :       texi_sign(a,T,S,addsign);
    3131           0 :       if (!isnull(b)) wr_texnome(T,S,b,v,1);
    3132           0 :       break;
    3133             : 
    3134          98 :     case t_POL: v = get_texvar(varn(g), buf, sizeof(buf));
    3135             :       /* hack: we want g[i] = coeff of degree i. */
    3136          98 :       i = degpol(g); g += 2; while (isnull(gel(g,i))) i--;
    3137          98 :       wr_lead_texnome(T,S,gel(g,i),v,i,addsign);
    3138         392 :       while (i--)
    3139             :       {
    3140         196 :         a = gel(g,i);
    3141         196 :         if (!isnull_for_pol(a)) wr_texnome(T,S,a,v,i);
    3142             :       }
    3143          98 :       break;
    3144             : 
    3145           0 :     case t_SER: v = get_texvar(varn(g), buf, sizeof(buf));
    3146           0 :       i = valp(g);
    3147           0 :       if (lg(g)-2)
    3148             :       { /* hack: we want g[i] = coeff of degree i. */
    3149           0 :         l = i + lg(g)-2; g -= i-2;
    3150           0 :         wr_lead_texnome(T,S,gel(g,i),v,i,addsign);
    3151           0 :         while (++i < l)
    3152             :         {
    3153           0 :           a = gel(g,i);
    3154           0 :           if (!isnull_for_pol(a)) wr_texnome(T,S,a,v,i);
    3155             :         }
    3156           0 :         str_puts(S, "+ ");
    3157             :       }
    3158           0 :       str_puts(S, "O("); texnome(S,v,i); str_putc(S, ')'); break;
    3159             : 
    3160             :     case t_PADIC:
    3161             :     {
    3162           0 :       GEN p = gel(g,2);
    3163             :       pari_sp av;
    3164             :       char *ev;
    3165           0 :       str_alloc(S, (precp(g)+1) * lgefint(p)); /* careful! */
    3166           0 :       av = avma;
    3167           0 :       i = valp(g); l = precp(g)+i;
    3168           0 :       g = gel(g,4); ev = itostr(p);
    3169           0 :       for (; i<l; i++)
    3170             :       {
    3171           0 :         g = dvmdii(g,p,&a);
    3172           0 :         if (signe(a))
    3173             :         {
    3174           0 :           if (!i || !is_pm1(a))
    3175             :           {
    3176           0 :             str_absint(S, a); if (i) str_puts(S, "\\cdot");
    3177             :           }
    3178           0 :           if (i) texVpowE(S, ev,i);
    3179           0 :           str_putc(S, '+');
    3180             :         }
    3181             :       }
    3182           0 :       str_puts(S, "O("); texVpowE(S, ev,i); str_putc(S, ')');
    3183           0 :       avma = av; break;
    3184             :     }
    3185             : 
    3186             :     case t_VEC:
    3187           0 :       str_puts(S, "\\pmatrix{ "); l = lg(g);
    3188           0 :       for (i=1; i<l; i++)
    3189             :       {
    3190           0 :         texi(gel(g,i),T,S); if (i < l-1) str_putc(S, '&');
    3191             :       }
    3192           0 :       str_puts(S, "\\cr}\n"); break;
    3193             : 
    3194             :     case t_LIST:
    3195           0 :       switch(list_typ(g))
    3196             :       {
    3197             :       case t_LIST_RAW:
    3198           0 :         str_puts(S, "\\pmatrix{ ");
    3199           0 :         g = list_data(g);
    3200           0 :         l = g? lg(g): 1;
    3201           0 :         for (i=1; i<l; i++)
    3202             :         {
    3203           0 :           texi(gel(g,i),T,S); if (i < l-1) str_putc(S, '&');
    3204             :         }
    3205           0 :         str_puts(S, "\\cr}\n"); break;
    3206             :       case t_LIST_MAP:
    3207             :         {
    3208           0 :           pari_sp av = avma;
    3209           0 :           texi(maptomat_shallow(g),T,S);
    3210           0 :           avma = av;
    3211           0 :           break;
    3212             :         }
    3213             :       }
    3214           0 :       break;
    3215             :     case t_COL:
    3216           0 :       str_puts(S, "\\pmatrix{ "); l = lg(g);
    3217           0 :       for (i=1; i<l; i++)
    3218             :       {
    3219           0 :         texi(gel(g,i),T,S); str_puts(S, "\\cr\n");
    3220             :       }
    3221           0 :       str_putc(S, '}'); break;
    3222             : 
    3223             :     case t_VECSMALL:
    3224           0 :       str_puts(S, "\\pmatrix{ "); l = lg(g);
    3225           0 :       for (i=1; i<l; i++)
    3226             :       {
    3227           0 :         str_long(S, g[i]);
    3228           0 :         if (i < l-1) str_putc(S, '&');
    3229             :       }
    3230           0 :       str_puts(S, "\\cr}\n"); break;
    3231             : 
    3232             :     case t_STR:
    3233           0 :       str_puts(S, GSTR(g)); break;
    3234             : 
    3235             :     case t_CLOSURE:
    3236           0 :       if (lg(g)>=6)
    3237             :       {
    3238           0 :         GEN str = closure_get_text(g);
    3239           0 :         if (typ(str)==t_STR)
    3240             :         {
    3241           0 :           print_precontext(g, S, 1);
    3242           0 :           str_puts(S, GSTR(str));
    3243           0 :           print_context(g, T, S ,1);
    3244             :         }
    3245             :         else
    3246             :         {
    3247           0 :           str_putc(S,'(');          str_puts(S,GSTR(gel(str,1)));
    3248           0 :           str_puts(S,")\\mapsto ");
    3249           0 :           print_context(g, T, S ,1); str_puts(S,GSTR(gel(str,2)));
    3250             :         }
    3251             :       }
    3252             :       else
    3253             :       {
    3254           0 :         str_puts(S,"\\{\""); str_puts(S,GSTR(closure_get_code(g)));
    3255           0 :         str_puts(S,"\","); texi(gel(g,3),T,S);
    3256           0 :         str_putc(S,',');   texi(gel(g,4),T,S);
    3257           0 :         str_putc(S,',');   texi(gel(g,5),T,S); str_puts(S,"\\}");
    3258             :       }
    3259           0 :       break;
    3260           0 :     case t_INFINITY: str_puts(S, inf_get_sign(g) == 1? "+\\infty": "-\\infty");
    3261           0 :       break;
    3262             : 
    3263             :     case t_MAT:
    3264             :     {
    3265           7 :       str_puts(S, "\\pmatrix{\n "); r = lg(g);
    3266           7 :       if (r>1)
    3267             :       {
    3268           7 :         OUT_FUN print = (typ(gel(g,1)) == t_VECSMALL)? prints: texi;
    3269             : 
    3270           7 :         l = lgcols(g);
    3271          14 :         for (i=1; i<l; i++)
    3272             :         {
    3273          14 :           for (j=1; j<r; j++)
    3274             :           {
    3275           7 :             print(gcoeff(g,i,j),T,S); if (j<r-1) str_putc(S, '&');
    3276             :           }
    3277           7 :           str_puts(S, "\\cr\n ");
    3278             :         }
    3279             :       }
    3280           7 :       str_putc(S, '}'); break;
    3281             :     }
    3282             :   }
    3283             : }
    3284             : 
    3285             : /*******************************************************************/
    3286             : /**                                                               **/
    3287             : /**                        USER OUTPUT FUNCTIONS                  **/
    3288             : /**                                                               **/
    3289             : /*******************************************************************/
    3290             : static void
    3291           0 : _initout(pariout_t *T, char f, long sigd, long sp)
    3292             : {
    3293           0 :   T->format = f;
    3294           0 :   T->sigd = sigd;
    3295           0 :   T->sp = sp;
    3296           0 : }
    3297             : 
    3298             : static void
    3299       27064 : gen_output_fun(GEN x, pariout_t *T, OUT_FUN out)
    3300       27064 : { pari_sp av = avma; pari_puts( stack_GENtostr_fun(x,T,out) ); avma = av; }
    3301             : 
    3302             : void
    3303           0 : fputGEN_pariout(GEN x, pariout_t *T, FILE *out)
    3304             : {
    3305           0 :   pari_sp av = avma;
    3306           0 :   char *s = stack_GENtostr_fun(x, T, get_fun(T->prettyp));
    3307           0 :   if (*s) { set_last_newline(s[strlen(s)-1]); fputs(s, out); }
    3308           0 :   avma = av;
    3309           0 : }
    3310             : 
    3311             : void
    3312       27064 : gen_output(GEN x, pariout_t *T)
    3313             : {
    3314       27064 :   if (!T) T = GP_DATA->fmt;
    3315       27064 :   gen_output_fun(x, T, get_fun(T->prettyp));
    3316       27064 : }
    3317             : void
    3318           0 : brute(GEN g, char f, long d)
    3319             : {
    3320           0 :   pariout_t T; _initout(&T,f,d,0);
    3321           0 :   gen_output_fun(g, &T, &bruti);
    3322           0 : }
    3323             : void
    3324           0 : matbrute(GEN g, char f, long d)
    3325             : {
    3326           0 :   pariout_t T; _initout(&T,f,d,1);
    3327           0 :   gen_output_fun(g, &T, &matbruti);
    3328           0 : }
    3329             : void
    3330           0 : texe(GEN g, char f, long d)
    3331             : {
    3332           0 :   pariout_t T; _initout(&T,f,d,0);
    3333           0 :   gen_output_fun(g, &T, &texi);
    3334           0 : }
    3335             : 
    3336             : void
    3337           0 : output(GEN x)
    3338           0 : { brute(x,'g',-1); pari_putc('\n'); pari_flush(); }
    3339             : void
    3340           0 : outmat(GEN x)
    3341           0 : { matbrute(x,'g',-1); pari_putc('\n'); pari_flush(); }
    3342             : 
    3343             : void
    3344         245 : err_printf(const char* fmt, ...)
    3345             : {
    3346         245 :   va_list args; va_start(args, fmt);
    3347         245 :   out_vprintf(pariErr,fmt,args); va_end(args);
    3348         245 : }
    3349             : 
    3350             : /*******************************************************************/
    3351             : /**                            FILES                              **/
    3352             : /*******************************************************************/
    3353             : /* to cache '~' expansion */
    3354             : static char *homedir;
    3355             : /* last file read successfully from try_name() */
    3356             : static THREAD char *last_filename;
    3357             : /* stack of temporary files (includes all infiles + some output) */
    3358             : static THREAD pariFILE *last_tmp_file;
    3359             : /* stack of "permanent" (output) files */
    3360             : static THREAD pariFILE *last_file;
    3361             : 
    3362             : pariFILE *
    3363       95116 : pari_last_tmp_file(void) { return last_tmp_file; }
    3364             : 
    3365             : #if defined(UNIX) || defined(__EMX__)
    3366             : #  include <fcntl.h>
    3367             : #  include <sys/stat.h> /* for open */
    3368             : #  ifdef __EMX__
    3369             : #    include <process.h>
    3370             : #  endif
    3371             : #  define HAVE_PIPES
    3372             : #endif
    3373             : #if defined(_WIN32)
    3374             : #  define HAVE_PIPES
    3375             : #endif
    3376             : #ifndef O_RDONLY
    3377             : #  define O_RDONLY 0
    3378             : #endif
    3379             : 
    3380             : pariFILE *
    3381       54390 : newfile(FILE *f, const char *name, int type)
    3382             : {
    3383       54390 :   pariFILE *file = (pariFILE*) pari_malloc(strlen(name) + 1 + sizeof(pariFILE));
    3384       54390 :   file->type = type;
    3385       54390 :   file->name = strcpy((char*)(file+1), name);
    3386       54390 :   file->file = f;
    3387       54390 :   file->next = NULL;
    3388       54390 :   if (type & mf_PERM)
    3389             :   {
    3390           0 :     file->prev = last_file;
    3391           0 :     last_file = file;
    3392             :   }
    3393             :   else
    3394             :   {
    3395       54390 :     file->prev = last_tmp_file;
    3396       54390 :     last_tmp_file = file;
    3397             :   }
    3398       54390 :   if (file->prev) (file->prev)->next = file;
    3399       54390 :   if (DEBUGFILES)
    3400           0 :     err_printf("I/O: new pariFILE %s (code %d) \n",name,type);
    3401       54390 :   return file;
    3402             : }
    3403             : 
    3404             : static void
    3405       54390 : pari_kill_file(pariFILE *f)
    3406             : {
    3407       54390 :   if ((f->type & mf_PIPE) == 0)
    3408             :   {
    3409       54390 :     if (f->file != stdin && fclose(f->file))
    3410           0 :       pari_warn(warnfile, "close", f->name);
    3411             :   }
    3412             : #ifdef HAVE_PIPES
    3413             :   else
    3414             :   {
    3415           0 :     if (f->type & mf_FALSE)
    3416             :     {
    3417           0 :       if (f->file != stdin && fclose(f->file))
    3418           0 :         pari_warn(warnfile, "close", f->name);
    3419           0 :       if (unlink(f->name)) pari_warn(warnfile, "delete", f->name);
    3420             :     }
    3421             :     else
    3422           0 :       if (pclose(f->file) < 0) pari_warn(warnfile, "close pipe", f->name);
    3423             :   }
    3424             : #endif
    3425       54390 :   if (DEBUGFILES)
    3426           0 :     err_printf("I/O: closing file %s (code %d) \n",f->name,f->type);
    3427       54390 :   pari_free(f);
    3428       54390 : }
    3429             : 
    3430             : void
    3431       54355 : pari_fclose(pariFILE *f)
    3432             : {
    3433       54355 :   if (f->next) (f->next)->prev = f->prev;
    3434       44645 :   else if (f == last_tmp_file) last_tmp_file = f->prev;
    3435           0 :   else if (f == last_file) last_file = f->prev;
    3436       54355 :   if (f->prev) (f->prev)->next = f->next;
    3437       54355 :   pari_kill_file(f);
    3438       54355 : }
    3439             : 
    3440             : static pariFILE *
    3441       32221 : pari_open_file(FILE *f, const char *s, const char *mode)
    3442             : {
    3443       32221 :   if (!f) pari_err_FILE("requested file", s);
    3444       32221 :   if (DEBUGFILES)
    3445           0 :     err_printf("I/O: opening file %s (mode %s)\n", s, mode);
    3446       32221 :   return newfile(f,s,0);
    3447             : }
    3448             : 
    3449             : pariFILE *
    3450       32221 : pari_fopen_or_fail(const char *s, const char *mode)
    3451             : {
    3452       32221 :   return pari_open_file(fopen(s, mode), s, mode);
    3453             : }
    3454             : pariFILE *
    3455           0 : pari_fopen(const char *s, const char *mode)
    3456             : {
    3457           0 :   FILE *f = fopen(s, mode);
    3458           0 :   return f? pari_open_file(f, s, mode): NULL;
    3459             : }
    3460             : 
    3461             : void
    3462       70931 : pari_fread_chars(void *b, size_t n, FILE *f)
    3463             : {
    3464       70931 :   if (fread(b, sizeof(char), n, f) < n)
    3465           0 :     pari_err_FILE("input file [fread]", "FILE*");
    3466       70931 : }
    3467             : 
    3468             : /* FIXME: HAS_FDOPEN & allow standard open() flags */
    3469             : #ifdef UNIX
    3470             : /* open tmpfile s (a priori for writing) avoiding symlink attacks */
    3471             : pariFILE *
    3472           0 : pari_safefopen(const char *s, const char *mode)
    3473             : {
    3474           0 :   long fd = open(s, O_CREAT|O_EXCL|O_RDWR, S_IRUSR|S_IWUSR);
    3475             : 
    3476           0 :   if (fd == -1) pari_err(e_MISC,"tempfile %s already exists",s);
    3477           0 :   return pari_open_file(fdopen(fd, mode), s, mode);
    3478             : }
    3479             : #else
    3480             : pariFILE *
    3481             : pari_safefopen(const char *s, const char *mode)
    3482             : {
    3483             :   return pari_fopen_or_fail(s, mode);
    3484             : }
    3485             : #endif
    3486             : 
    3487             : void
    3488        6582 : pari_unlink(const char *s)
    3489             : {
    3490        6582 :   if (unlink(s)) pari_warn(warner, "I/O: can\'t remove file %s", s);
    3491        6582 :   else if (DEBUGFILES)
    3492           0 :     err_printf("I/O: removed file %s\n", s);
    3493        6582 : }
    3494             : 
    3495             : /* Remove one INFILE from the stack. Reset pari_infile (to the most recent
    3496             :  * infile)
    3497             :  * Return -1, if we're trying to pop out stdin itself; 0 otherwise
    3498             :  * Check for leaked file handlers (temporary files) */
    3499             : int
    3500      204000 : popinfile(void)
    3501             : {
    3502      204000 :   pariFILE *f = last_tmp_file, *g;
    3503      408215 :   while (f)
    3504             :   {
    3505           0 :     if (f->type & mf_IN) break;
    3506           0 :     pari_warn(warner, "I/O: leaked file descriptor (%d): %s", f->type, f->name);
    3507           0 :     g = f; f = f->prev; pari_fclose(g);
    3508             :   }
    3509      204215 :   last_tmp_file = f; if (!f) return -1;
    3510           0 :   pari_fclose(last_tmp_file);
    3511           0 :   for (f = last_tmp_file; f; f = f->prev)
    3512           0 :     if (f->type & mf_IN) { pari_infile = f->file; return 0; }
    3513           0 :   pari_infile = stdin; return 0;
    3514             : }
    3515             : 
    3516             : /* delete all "temp" files open since last reference point F */
    3517             : void
    3518       15938 : filestate_restore(pariFILE *F)
    3519             : {
    3520       15938 :   pariFILE *f = pari_last_tmp_file();
    3521       15938 :   if (DEBUGFILES>1) err_printf("gp_context_restore: deleting open files...\n");
    3522       31897 :   while (f)
    3523             :   {
    3524          21 :     pariFILE *g = f->prev;
    3525          21 :     if (f == F) break;
    3526          21 :     pari_fclose(f); f = g;
    3527             :   }
    3528       15938 :   for (; f; f = f->prev) {
    3529           0 :     if (f->type & mf_IN) {
    3530           0 :       pari_infile = f->file;
    3531           0 :       if (DEBUGFILES>1)
    3532           0 :         err_printf("restoring pari_infile to %s\n", f->name);
    3533           0 :       break;
    3534             :     }
    3535             :   }
    3536       15938 :   if (!f) {
    3537       15938 :     pari_infile = stdin;
    3538       15938 :     if (DEBUGFILES>1)
    3539           0 :       err_printf("gp_context_restore: restoring pari_infile to stdin\n");
    3540             :   }
    3541       15938 :   if (DEBUGFILES>1) err_printf("done\n");
    3542       15938 : }
    3543             : 
    3544             : static void
    3545      404095 : kill_file_stack(pariFILE **s)
    3546             : {
    3547      404095 :   pariFILE *f = *s;
    3548      808225 :   while (f)
    3549             :   {
    3550          35 :     pariFILE *t = f->prev;
    3551          35 :     pari_kill_file(f);
    3552          35 :     *s = f = t; /* have to update *s in case of ^C */
    3553             :   }
    3554      404095 : }
    3555             : 
    3556             : void
    3557          35 : killallfiles(void)
    3558             : {
    3559          35 :   kill_file_stack(&last_tmp_file);
    3560          35 :   pari_infile = stdin;
    3561          35 : }
    3562             : 
    3563             : void
    3564        1328 : pari_init_homedir(void)
    3565             : {
    3566        1328 :   homedir = NULL;
    3567        1328 : }
    3568             : 
    3569             : void
    3570        1836 : pari_close_homedir(void)
    3571             : {
    3572        1836 :   if (homedir) pari_free(homedir);
    3573        1836 : }
    3574             : 
    3575             : void
    3576      201146 : pari_init_files(void)
    3577             : {
    3578      201146 :   last_filename = NULL;
    3579      201146 :   last_tmp_file = NULL;
    3580      201146 :   last_file=NULL;
    3581      201146 : }
    3582             : 
    3583             : void
    3584      202152 : pari_thread_close_files(void)
    3585             : {
    3586      202152 :   popinfile(); /* look for leaks */
    3587      202438 :   kill_file_stack(&last_file);
    3588      202182 :   if (last_filename) pari_free(last_filename);
    3589      202182 :   kill_file_stack(&last_tmp_file);
    3590      202324 : }
    3591             : 
    3592             : void
    3593        1836 : pari_close_files(void)
    3594             : {
    3595        1836 :   if (pari_logfile) { fclose(pari_logfile); pari_logfile = NULL; }
    3596        1836 :   pari_infile = stdin;
    3597        1836 : }
    3598             : 
    3599             : static int
    3600           0 : ok_pipe(FILE *f)
    3601             : {
    3602           0 :   if (DEBUGFILES) err_printf("I/O: checking output pipe...\n");
    3603           0 :   pari_CATCH(CATCH_ALL) {
    3604           0 :     return 0;
    3605             :   }
    3606             :   pari_TRY {
    3607             :     int i;
    3608           0 :     fprintf(f,"\n\n"); fflush(f);
    3609           0 :     for (i=1; i<1000; i++) fprintf(f,"                  \n");
    3610           0 :     fprintf(f,"\n"); fflush(f);
    3611           0 :   } pari_ENDCATCH;
    3612           0 :   return 1;
    3613             : }
    3614             : 
    3615             : pariFILE *
    3616           0 : try_pipe(const char *cmd, int fl)
    3617             : {
    3618             : #ifndef HAVE_PIPES
    3619             :   pari_err(e_ARCH,"pipes"); return NULL;
    3620             : #else
    3621             :   FILE *file;
    3622             :   const char *f;
    3623           0 :   VOLATILE int flag = fl;
    3624             : 
    3625             : #  ifdef __EMX__
    3626             :   if (_osmode == DOS_MODE) /* no pipes under DOS */
    3627             :   {
    3628             :     pari_sp av = avma;
    3629             :     char *s;
    3630             :     if (flag & mf_OUT) pari_err(e_ARCH,"pipes");
    3631             :     f = pari_unique_filename("pipe");
    3632             :     s = stack_malloc(strlen(cmd)+strlen(f)+4);
    3633             :     sprintf(s,"%s > %s",cmd,f);
    3634             :     file = system(s)? NULL: fopen(f,"r");
    3635             :     flag |= mf_FALSE; pari_free(f); avma = av;
    3636             :   }
    3637             :   else
    3638             : #  endif
    3639             :   {
    3640           0 :     file = (FILE *) popen(cmd, (flag & mf_OUT)? "w": "r");
    3641           0 :     if (flag & mf_OUT) {
    3642           0 :       if (!ok_pipe(file)) return NULL;
    3643           0 :       flag |= mf_PERM;
    3644             :     }
    3645           0 :     f = cmd;
    3646             :   }
    3647           0 :   if (!file) pari_err(e_MISC,"[pipe:] '%s' failed",cmd);
    3648           0 :   return newfile(file, f, mf_PIPE|flag);
    3649             : #endif
    3650             : }
    3651             : 
    3652             : typedef void (*pari_sighandler_t)(int);
    3653             : 
    3654             : pari_sighandler_t
    3655       17148 : os_signal(int sig, pari_sighandler_t f)
    3656             : {
    3657             : #ifdef HAS_SIGACTION
    3658             :   struct sigaction sa, oldsa;
    3659             : 
    3660       17148 :   sa.sa_handler = f;
    3661       17148 :   sigemptyset(&sa.sa_mask);
    3662       17148 :   sa.sa_flags = SA_NODEFER;
    3663             : 
    3664       17148 :   if (sigaction(sig, &sa, &oldsa)) return NULL;
    3665       17148 :   return oldsa.sa_handler;
    3666             : #else
    3667             :   return signal(sig,f);
    3668             : #endif
    3669             : }
    3670             : 
    3671             : #if 0
    3672             : void
    3673             : os_close(long fd)
    3674             : {
    3675             :   close(fd);
    3676             : }
    3677             : void
    3678             : os_read(long fd, char ch[], long s)
    3679             : {
    3680             :   (void)read(fd,ch,s);
    3681             : }
    3682             : long
    3683             : os_open(const char *s, int mode)
    3684             : {
    3685             :   long fd;
    3686             :   fd = open(s,mode);
    3687             :   return fd;
    3688             : }
    3689             : #endif
    3690             : 
    3691             : char *
    3692       26768 : os_getenv(const char *s)
    3693             : {
    3694             : #ifdef HAS_GETENV
    3695       26768 :   return getenv(s);
    3696             : #else
    3697             :   (void) s; return NULL;
    3698             : #endif
    3699             : }
    3700             : 
    3701             : GEN
    3702           0 : gp_getenv(const char *s)
    3703             : {
    3704           0 :   char *t = os_getenv(s);
    3705           0 :   return t?strtoGENstr(t):gen_0;
    3706             : }
    3707             : 
    3708             : /* FIXME: HAS_GETPWUID */
    3709             : #if defined(UNIX) || defined(__EMX__)
    3710             : #include <pwd.h>
    3711             : #include <sys/types.h>
    3712             : /* user = "": use current uid */
    3713             : char *
    3714        2656 : pari_get_homedir(const char *user)
    3715             : {
    3716             :   struct passwd *p;
    3717        2656 :   char *dir = NULL;
    3718             : 
    3719        2656 :   if (!*user)
    3720             :   {
    3721        2656 :     if (homedir) dir = homedir;
    3722             :     else
    3723             :     {
    3724        1328 :       p = getpwuid(geteuid());
    3725        1328 :       if (p)
    3726             :       {
    3727        1328 :         dir = p->pw_dir;
    3728        1328 :         homedir = pari_strdup(dir); /* cache result */
    3729             :       }
    3730             :     }
    3731             :   }
    3732             :   else
    3733             :   {
    3734           0 :     p = getpwnam(user);
    3735           0 :     if (p) dir = p->pw_dir;
    3736             :     /* warn, but don't kill session on startup (when expanding path) */
    3737           0 :     if (!dir) pari_warn(warner,"can't expand ~%s", user? user: "");
    3738             :   }
    3739        2656 :   return dir;
    3740             : }
    3741             : #else
    3742             : char *
    3743             : pari_get_homedir(const char *user) { (void) user; return NULL; }
    3744             : #endif
    3745             : 
    3746             : /*******************************************************************/
    3747             : /**                                                               **/
    3748             : /**                   GP STANDARD INPUT AND OUTPUT                **/
    3749             : /**                                                               **/
    3750             : /*******************************************************************/
    3751             : #ifdef HAS_OPENDIR
    3752             : /* slow, but more portable than stat + S_ISDIR */
    3753             : static int
    3754             : is_dir_opendir(const char *name)
    3755             : {
    3756             :   DIR *d = opendir(name);
    3757             :   if (d) { (void)closedir(d); return 1; }
    3758             :   return 0;
    3759             : }
    3760             : #endif
    3761             : 
    3762             : #ifdef HAS_STAT
    3763             : static int
    3764          63 : is_dir_stat(const char *name)
    3765             : {
    3766             :   struct stat buf;
    3767          63 :   if (stat(name, &buf)) return 0;
    3768          63 :   return S_ISDIR(buf.st_mode);
    3769             : }
    3770             : #endif
    3771             : 
    3772             : /* Does name point to a directory? */
    3773             : int
    3774          63 : pari_is_dir(const char *name)
    3775             : {
    3776             : #ifdef HAS_STAT
    3777          63 :   return is_dir_stat(name);
    3778             : #else
    3779             : #  ifdef HAS_OPENDIR
    3780             :   return is_dir_opendir(name);
    3781             : #  else
    3782             :   (void) name; return 0;
    3783             : #  endif
    3784             : #endif
    3785             : }
    3786             : 
    3787             : /* Does name point to a regular file? */
    3788             : /* If unknown, assume that it is indeed regular. */
    3789             : int
    3790           0 : pari_is_file(const char *name)
    3791             : {
    3792             : #ifdef HAS_STAT
    3793             :   struct stat buf;
    3794           0 :   if (stat(name, &buf)) return 1;
    3795           0 :   return S_ISREG(buf.st_mode);
    3796             : #else
    3797             :   (void) name; return 1;
    3798             : #endif
    3799             : }
    3800             : 
    3801             : int
    3802        1328 : pari_stdin_isatty(void)
    3803             : {
    3804             : #ifdef HAS_ISATTY
    3805        1328 :   return isatty( fileno(stdin) );
    3806             : #else
    3807             :   return 1;
    3808             : #endif
    3809             : }
    3810             : 
    3811             : /* expand tildes in filenames, return a malloc'ed buffer */
    3812             : static char *
    3813        3984 : _path_expand(const char *s)
    3814             : {
    3815             :   const char *t;
    3816        3984 :   char *ret, *dir = NULL;
    3817             : 
    3818        3984 :   if (*s != '~') return pari_strdup(s);
    3819        2656 :   s++; /* skip ~ */
    3820        2656 :   t = s; while (*t && *t != '/') t++;
    3821        2656 :   if (t == s)
    3822        2656 :     dir = pari_get_homedir("");
    3823             :   else
    3824             :   {
    3825           0 :     size_t len = t - s;
    3826           0 :     char *user = (char*)pari_malloc(len+1);
    3827           0 :     (void)strncpy(user,s,len); user[len] = 0;
    3828           0 :     dir = pari_get_homedir(user);
    3829           0 :     pari_free(user);
    3830             :   }
    3831        2656 :   if (!dir) return pari_strdup(s);
    3832        2656 :   ret = (char*)pari_malloc(strlen(dir) + strlen(t) + 1);
    3833        2656 :   sprintf(ret,"%s%s",dir,t); return ret;
    3834             : }
    3835             : 
    3836             : /* expand environment variables in str, return a malloc'ed buffer
    3837             :  * assume no \ remain and str can be freed */
    3838             : static char *
    3839        3984 : _expand_env(char *str)
    3840             : {
    3841        3984 :   long i, l, len = 0, xlen = 16, xnum = 0;
    3842        3984 :   char *s = str, *s0 = s, *env;
    3843        3984 :   char **x = (char **)pari_malloc(xlen * sizeof(char*));
    3844             : 
    3845       34528 :   while (*s)
    3846             :   {
    3847       26560 :     if (*s != '$') { s++; continue; }
    3848           0 :     l = s - s0;
    3849           0 :     if (l)
    3850             :     {
    3851           0 :       s0 = strncpy((char*)pari_malloc(l+1), s0, l); s0[l] = 0;
    3852           0 :       x[xnum++] = s0; len += l;
    3853             :     }
    3854           0 :     if (xnum > xlen - 3) /* need room for possibly two more elts */
    3855             :     {
    3856           0 :       xlen <<= 1;
    3857           0 :       x = (char **)pari_realloc((void*)x, xlen * sizeof(char*));
    3858             :     }
    3859             : 
    3860           0 :     s0 = ++s; /* skip $ */
    3861           0 :     while (is_keyword_char(*s)) s++;
    3862           0 :     l = s - s0;
    3863           0 :     env = strncpy((char*)pari_malloc(l+1), s0, l); env[l] = 0;
    3864           0 :     s0 = os_getenv(env);
    3865           0 :     if (!s0)
    3866             :     {
    3867           0 :       pari_warn(warner,"undefined environment variable: %s",env);
    3868           0 :       s0 = (char*)"";
    3869             :     }
    3870           0 :     l = strlen(s0);
    3871           0 :     if (l)
    3872             :     {
    3873           0 :       s0 = strncpy((char*)pari_malloc(l+1), s0, l); s0[l] = 0;
    3874           0 :       x[xnum++] = s0; len += l;
    3875             :     }
    3876           0 :     pari_free(env); s0 = s;
    3877             :   }
    3878        3984 :   l = s - s0;
    3879        3984 :   if (l)
    3880             :   {
    3881        3984 :     s0 = strncpy((char*)pari_malloc(l+1), s0, l); s0[l] = 0;
    3882        3984 :     x[xnum++] = s0; len += l;
    3883             :   }
    3884             : 
    3885        3984 :   s = (char*)pari_malloc(len+1); *s = 0;
    3886        3984 :   for (i = 0; i < xnum; i++) { (void)strcat(s, x[i]); pari_free(x[i]); }
    3887        3984 :   pari_free(str); pari_free(x); return s;
    3888             : }
    3889             : 
    3890             : char *
    3891        3984 : path_expand(const char *s)
    3892             : {
    3893             : #ifdef _WIN32
    3894             :   char *ss, *p;
    3895             :   ss = pari_strdup(s);
    3896             :   for (p = ss; *p != 0; ++p)
    3897             :     if (*p == '\\') *p = '/';
    3898             :   p = _expand_env(_path_expand(ss));
    3899             :   pari_free(ss);
    3900             :   return p;
    3901             : #else
    3902        3984 :   return _expand_env(_path_expand(s));
    3903             : #endif
    3904             : }
    3905             : 
    3906             : #ifdef HAS_STRFTIME
    3907             : #  include <time.h>
    3908             : void
    3909           0 : strftime_expand(const char *s, char *buf, long max)
    3910             : {
    3911             :   time_t t;
    3912           0 :   BLOCK_SIGINT_START
    3913           0 :   t = time(NULL);
    3914           0 :   (void)strftime(buf,max,s,localtime(&t));
    3915           0 :   BLOCK_SIGINT_END
    3916           0 : }
    3917             : #else
    3918             : void
    3919             : strftime_expand(const char *s, char *buf, long max)
    3920             : { strcpy(buf,s); }
    3921             : #endif
    3922             : 
    3923             : void
    3924        5000 : delete_dirs(gp_path *p)
    3925             : {
    3926        5000 :   char **v = p->dirs, **dirs;
    3927        5000 :   if (v)
    3928             :   {
    3929        1836 :     p->dirs = NULL; /* in case of error */
    3930        1836 :     for (dirs = v; *dirs; dirs++) pari_free(*dirs);
    3931        1836 :     pari_free(v);
    3932             :   }
    3933        5000 : }
    3934             : 
    3935             : #if defined(__EMX__) || defined(_WIN32) || defined(__CYGWIN32__)
    3936             : #  define PATH_SEPARATOR ';' /* beware DOSish 'C:' disk drives */
    3937             : #else
    3938             : #  define PATH_SEPARATOR ':'
    3939             : #endif
    3940             : 
    3941             : const char *
    3942        1328 : pari_default_path(void) {
    3943             : #if PATH_SEPARATOR == ';'
    3944             :   return ".;C:;C:/gp";
    3945             : #elif defined(UNIX)
    3946        1328 :   return ".:~:~/gp";
    3947             : #else
    3948             :   return ".";
    3949             : #endif
    3950             : }
    3951             : 
    3952             : void
    3953        1328 : gp_expand_path(gp_path *p)
    3954             : {
    3955        1328 :   char **dirs, *s, *v = p->PATH;
    3956        1328 :   int i, n = 0;
    3957             : 
    3958        1328 :   delete_dirs(p);
    3959        1328 :   v = pari_strdup(v);
    3960       11952 :   for (s=v; *s; s++)
    3961       10624 :     if (*s == PATH_SEPARATOR) {
    3962        2656 :       *s = 0;
    3963        2656 :       if (s == v || s[-1] != 0) n++; /* ignore empty path components */
    3964             :     }
    3965        1328 :   dirs = (char**) pari_malloc((n + 2)*sizeof(char *));
    3966             : 
    3967        5312 :   for (s=v, i=0; i<=n; i++)
    3968             :   {
    3969             :     char *end, *f;
    3970        3984 :     while (!*s) s++; /* skip empty path components */
    3971        3984 :     f = end = s + strlen(s);
    3972        3984 :     while (f > s && *--f == '/') *f = 0; /* skip trailing '/' */
    3973        3984 :     dirs[i] = path_expand(s);
    3974        3984 :     s = end + 1; /* next path component */
    3975             :   }
    3976        1328 :   pari_free((void*)v);
    3977        1328 :   dirs[i] = NULL; p->dirs = dirs;
    3978        1328 : }
    3979             : 
    3980             : /* name is a malloc'ed (existing) filename. Accept it as new pari_infile
    3981             :  * (unzip if needed). */
    3982             : static pariFILE *
    3983       22113 : pari_get_infile(const char *name, FILE *file)
    3984             : {
    3985             : #ifdef ZCAT
    3986       22113 :   long l = strlen(name);
    3987       22113 :   const char *end = name + l-1;
    3988             : 
    3989       22113 :   if (l > 2 && (!strncmp(end-1,".Z",2)
    3990             : #ifdef GNUZCAT
    3991       22113 :              || !strncmp(end-2,".gz",3)
    3992             : #endif
    3993             :   ))
    3994             :   { /* compressed file (compress or gzip) */
    3995           0 :     char *cmd = stack_malloc(strlen(ZCAT) + l + 4);
    3996           0 :     sprintf(cmd,"%s \"%s\"",ZCAT,name);
    3997           0 :     fclose(file);
    3998           0 :     return try_pipe(cmd, mf_IN);
    3999             :   }
    4000             : #endif
    4001       22113 :   return newfile(file, name, mf_IN);
    4002             : }
    4003             : 
    4004             : pariFILE *
    4005       22120 : pari_fopengz(const char *s)
    4006             : {
    4007       22120 :   pari_sp av = avma;
    4008             :   char *name;
    4009             :   long l;
    4010       22120 :   FILE *f = fopen(s, "r");
    4011             :   pariFILE *pf;
    4012             : 
    4013       22120 :   if (f) return pari_get_infile(s, f);
    4014             : 
    4015           7 :   l = strlen(s);
    4016           7 :   name = stack_malloc(l + 3 + 1);
    4017           7 :   strcpy(name, s); (void)sprintf(name + l, ".gz");
    4018           7 :   f = fopen(name, "r");
    4019           7 :   pf = f ? pari_get_infile(name, f): NULL;
    4020           7 :   avma = av; return pf;
    4021             : }
    4022             : 
    4023             : static FILE*
    4024           0 : try_open(char *s)
    4025             : {
    4026           0 :   if (!pari_is_dir(s)) return fopen(s, "r");
    4027           0 :   pari_warn(warner,"skipping directory %s",s);
    4028           0 :   return NULL;
    4029             : }
    4030             : 
    4031             : void
    4032           0 : forpath_init(forpath_t *T, gp_path *path, const char *s)
    4033             : {
    4034           0 :   T->s = s;
    4035           0 :   T->ls = strlen(s);
    4036           0 :   T->dir = path->dirs;
    4037           0 : }
    4038             : char *
    4039           0 : forpath_next(forpath_t *T)
    4040             : {
    4041           0 :   char *t, *dir = T->dir[0];
    4042             : 
    4043           0 :   if (!dir) return NULL; /* done */
    4044             :   /* room for dir + '/' + s + '\0' */
    4045           0 :   t = (char*)pari_malloc(strlen(dir) + T->ls + 2);
    4046           0 :   sprintf(t,"%s/%s", dir, T->s);
    4047           0 :   T->dir++; return t;
    4048             : }
    4049             : 
    4050             : /* If a file called "name" exists (possibly after appending ".gp")
    4051             :  * record it in the file_stack (as a pipe if compressed).
    4052             :  * name is malloc'ed, we free it before returning
    4053             :  */
    4054             : static FILE *
    4055           0 : try_name(char *name)
    4056             : {
    4057           0 :   pari_sp av = avma;
    4058           0 :   char *s = name;
    4059           0 :   FILE *file = try_open(name);
    4060             : 
    4061           0 :   if (!file)
    4062             :   { /* try appending ".gp" to name */
    4063           0 :     s = stack_malloc(strlen(name)+4);
    4064           0 :     sprintf(s, "%s.gp", name);
    4065           0 :     file = try_open(s);
    4066             :   }
    4067           0 :   if (file)
    4068             :   {
    4069           0 :     if (! last_tmp_file)
    4070             :     {  /* empty file stack, record this name */
    4071           0 :       if (last_filename) pari_free(last_filename);
    4072           0 :       last_filename = pari_strdup(s);
    4073             :     }
    4074           0 :     file = pari_infile = pari_get_infile(s,file)->file;
    4075             :   }
    4076           0 :   pari_free(name); avma = av;
    4077           0 :   return file;
    4078             : }
    4079             : static FILE *
    4080           7 : switchin_last(void)
    4081             : {
    4082           7 :   char *s = last_filename;
    4083             :   FILE *file;
    4084           7 :   if (!s) pari_err(e_MISC,"You never gave me anything to read!");
    4085           0 :   file = try_open(s);
    4086           0 :   if (!file) pari_err_FILE("input file",s);
    4087           0 :   return pari_infile = pari_get_infile(s,file)->file;
    4088             : }
    4089             : 
    4090             : /* return 1 if s starts by '/' or './' or '../' */
    4091             : int
    4092           0 : path_is_absolute(char *s)
    4093             : {
    4094             : #ifdef _WIN32
    4095             :   if( (*s >= 'A' && *s <= 'Z') ||
    4096             :       (*s >= 'a' && *s <= 'z') )
    4097             :   {
    4098             :       return *(s+1) == ':';
    4099             :   }
    4100             : #endif
    4101           0 :   if (*s == '/') return 1;
    4102           0 :   if (*s++ != '.') return 0;
    4103           0 :   if (*s == '/') return 1;
    4104           0 :   if (*s++ != '.') return 0;
    4105           0 :   return *s == '/';
    4106             : }
    4107             : 
    4108             : /* If name = "", re-read last file */
    4109             : FILE *
    4110           7 : switchin(const char *name)
    4111             : {
    4112             :   FILE *f;
    4113             :   char *s;
    4114             : 
    4115           7 :   if (!*name) return switchin_last();
    4116           0 :   s = path_expand(name);
    4117             :   /* if s is an absolute path, don't use dir_list */
    4118           0 :   if (path_is_absolute(s)) { if ((f = try_name(s))) return f; }
    4119             :   else
    4120             :   {
    4121             :     char *t;
    4122             :     forpath_t T;
    4123           0 :     forpath_init(&T, GP_DATA->path, s);
    4124           0 :     while ( (t = forpath_next(&T)) )
    4125           0 :       if ((f = try_name(t))) { pari_free(s); return f; }
    4126           0 :     pari_free(s);
    4127             :   }
    4128           0 :   pari_err_FILE("input file",name);
    4129           0 :   return NULL; /*not reached*/
    4130             : }
    4131             : 
    4132             : static int is_magic_ok(FILE *f);
    4133             : 
    4134             : static FILE *
    4135           0 : switchout_get_FILE(const char *name)
    4136             : {
    4137             :   FILE* f;
    4138             :   /* only for ordinary files (to avoid blocking on pipes). */
    4139           0 :   if (pari_is_file(name))
    4140             :   {
    4141           0 :     f = fopen(name, "r");
    4142           0 :     if (f)
    4143             :     {
    4144           0 :       int magic = is_magic_ok(f);
    4145           0 :       fclose(f);
    4146           0 :       if (magic) pari_err_FILE("binary output file [ use writebin ! ]", name);
    4147             :     }
    4148             :   }
    4149           0 :   f = fopen(name, "a");
    4150           0 :   if (!f) pari_err_FILE("output file",name);
    4151           0 :   return f;
    4152             : }
    4153             : 
    4154             : void
    4155           0 : switchout(const char *name)
    4156             : {
    4157           0 :   if (name)
    4158           0 :     pari_outfile = switchout_get_FILE(name);
    4159           0 :   else if (pari_outfile != stdout)
    4160             :   {
    4161           0 :     fclose(pari_outfile);
    4162           0 :     pari_outfile = stdout;
    4163             :   }
    4164           0 : }
    4165             : 
    4166             : /*******************************************************************/
    4167             : /**                                                               **/
    4168             : /**                SYSTEM, READSTR/EXTERNSTR/EXTERN               **/
    4169             : /**                                                               **/
    4170             : /*******************************************************************/
    4171             : static void
    4172           0 : check_secure(const char *s)
    4173             : {
    4174           0 :   if (GP_DATA->secure)
    4175           0 :     pari_err(e_MISC, "[secure mode]: system commands not allowed\nTried to run '%s'",s);
    4176           0 : }
    4177             : 
    4178             : void
    4179           0 : gpsystem(const char *s)
    4180             : {
    4181             : #ifdef HAS_SYSTEM
    4182           0 :   check_secure(s);
    4183           0 :   if (system(s) < 0)
    4184           0 :     pari_err(e_MISC, "system(\"%s\") failed", s);
    4185             : #else
    4186             :   pari_err(e_ARCH,"system");
    4187             : #endif
    4188           0 : }
    4189             : 
    4190             : static GEN
    4191           0 : get_lines(FILE *F)
    4192             : {
    4193           0 :   pari_sp av = avma;
    4194           0 :   long i, nz = 16;
    4195           0 :   GEN z = cgetg(nz + 1, t_VEC);
    4196           0 :   Buffer *b = new_buffer();
    4197             :   input_method IM;
    4198           0 :   IM.fgets = (fgets_t)&fgets;
    4199           0 :   IM.file = (void*)F;
    4200           0 :   for(i = 1;;)
    4201             :   {
    4202           0 :     char *s = b->buf, *e;
    4203           0 :     if (!file_getline(b, &s, &IM)) break;
    4204           0 :     if (i > nz) { nz <<= 1; z = vec_lengthen(z, nz); }
    4205           0 :     e = s + strlen(s)-1;
    4206           0 :     if (*e == '\n') *e = 0;
    4207           0 :     gel(z,i++) = strtoGENstr(s);
    4208           0 :   }
    4209           0 :   delete_buffer(b); setlg(z, i);
    4210           0 :   return gerepilecopy(av, z);
    4211             : }
    4212             : 
    4213             : GEN
    4214           0 : externstr(const char *s)
    4215             : {
    4216             :   pariFILE *F;
    4217             :   GEN z;
    4218           0 :   check_secure(s);
    4219           0 :   F = try_pipe(s, mf_IN);
    4220           0 :   z = get_lines(F->file);
    4221           0 :   pari_fclose(F); return z;
    4222             : }
    4223             : GEN
    4224           0 : gpextern(const char *s)
    4225             : {
    4226             :   pariFILE *F;
    4227             :   GEN z;
    4228           0 :   check_secure(s);
    4229           0 :   F = try_pipe(s, mf_IN);
    4230           0 :   z = gp_read_stream(F->file);
    4231           0 :   pari_fclose(F); return z;
    4232             : }
    4233             : 
    4234             : GEN
    4235           0 : readstr(const char *s)
    4236             : {
    4237           0 :   GEN z = get_lines(switchin(s));
    4238           0 :   popinfile(); return z;
    4239             : }
    4240             : 
    4241             : /*******************************************************************/
    4242             : /**                                                               **/
    4243             : /**                    I/O IN BINARY FORM                         **/
    4244             : /**                                                               **/
    4245             : /*******************************************************************/
    4246             : static void
    4247           0 : pari_fread_longs(void *a, size_t c, FILE *d)
    4248           0 : { if (fread(a,sizeof(long),c,d) < c)
    4249           0 :     pari_err_FILE("input file [fread]", "FILE*"); }
    4250             : 
    4251             : static void
    4252           0 : _fwrite(const void *a, size_t b, size_t c, FILE *d)
    4253           0 : { if (fwrite(a,b,c,d) < c) pari_err_FILE("output file [fwrite]", "FILE*"); }
    4254             : static void
    4255           0 : _lfwrite(const void *a, size_t b, FILE *c) { _fwrite(a,sizeof(long),b,c); }
    4256             : static void
    4257           0 : _cfwrite(const void *a, size_t b, FILE *c) { _fwrite(a,sizeof(char),b,c); }
    4258             : 
    4259             : enum { BIN_GEN, NAM_GEN, VAR_GEN, RELINK_TABLE };
    4260             : 
    4261             : static long
    4262           0 : rd_long(FILE *f) { long L; pari_fread_longs(&L, 1UL, f); return L; }
    4263             : static void
    4264           0 : wr_long(long L, FILE *f) { _lfwrite(&L, 1UL, f); }
    4265             : 
    4266             : /* append x to file f */
    4267             : static void
    4268           0 : wrGEN(GEN x, FILE *f)
    4269             : {
    4270           0 :   GENbin *p = copy_bin_canon(x);
    4271           0 :   size_t L = p->len;
    4272             : 
    4273           0 :   wr_long(L,f);
    4274           0 :   if (L)
    4275             :   {
    4276           0 :     wr_long((long)p->x,f);
    4277           0 :     wr_long((long)p->base,f);
    4278           0 :     _lfwrite(GENbinbase(p), L,f);
    4279             :   }
    4280           0 :   pari_free((void*)p);
    4281           0 : }
    4282             : 
    4283             : static void
    4284           0 : wrstr(const char *s, FILE *f)
    4285             : {
    4286           0 :   size_t L = strlen(s)+1;
    4287           0 :   wr_long(L,f);
    4288           0 :   _cfwrite(s, L, f);
    4289           0 : }
    4290             : 
    4291             : static char *
    4292           0 : rdstr(FILE *f)
    4293             : {
    4294           0 :   size_t L = (size_t)rd_long(f);
    4295             :   char *s;
    4296           0 :   if (!L) return NULL;
    4297           0 :   s = (char*)pari_malloc(L);
    4298           0 :   pari_fread_chars(s, L, f); return s;
    4299             : }
    4300             : 
    4301             : static void
    4302           0 : writeGEN(GEN x, FILE *f)
    4303             : {
    4304           0 :   fputc(BIN_GEN,f);
    4305           0 :   wrGEN(x, f);
    4306           0 : }
    4307             : 
    4308             : static void
    4309           0 : writenamedGEN(GEN x, const char *s, FILE *f)
    4310             : {
    4311           0 :   fputc(x ? NAM_GEN : VAR_GEN,f);
    4312           0 :   wrstr(s, f);
    4313           0 :   if (x) wrGEN(x, f);
    4314           0 : }
    4315             : 
    4316             : /* read a GEN from file f */
    4317             : static GEN
    4318           0 : rdGEN(FILE *f)
    4319             : {
    4320           0 :   size_t L = (size_t)rd_long(f);
    4321             :   GENbin *p;
    4322             : 
    4323           0 :   if (!L) return gen_0;
    4324           0 :   p = (GENbin*)pari_malloc(sizeof(GENbin) + L*sizeof(long));
    4325           0 :   p->len  = L;
    4326           0 :   p->x    = (GEN)rd_long(f);
    4327           0 :   p->base = (GEN)rd_long(f);
    4328           0 :   p->rebase = &shiftaddress_canon;
    4329           0 :   pari_fread_longs(GENbinbase(p), L,f);
    4330           0 :   return bin_copy(p);
    4331             : }
    4332             : 
    4333             : /* read a binary object in file f. Set *ptc to the object "type":
    4334             :  * BIN_GEN: an anonymous GEN x; return x.
    4335             :  * NAM_GEN: a named GEN x, with name v; set 'v to x (changevalue) and return x
    4336             :  * VAR_GEN: a name v; create the (unassigned) variable v and return gnil
    4337             :  * RELINK_TABLE: a relinking table for gen_relink(), to replace old adresses
    4338             :  * in * the original session by new incarnations in the current session.
    4339             :  * H is the current relinking table
    4340             :  * */
    4341             : static GEN
    4342           0 : readobj(FILE *f, int *ptc, hashtable *H)
    4343             : {
    4344           0 :   int c = fgetc(f);
    4345           0 :   GEN x = NULL;
    4346           0 :   switch(c)
    4347             :   {
    4348             :     case BIN_GEN:
    4349           0 :       x = rdGEN(f);
    4350           0 :       if (H) gen_relink(x, H);
    4351           0 :       break;
    4352             :     case NAM_GEN:
    4353             :     case VAR_GEN:
    4354             :     {
    4355           0 :       char *s = rdstr(f);
    4356           0 :       if (!s) pari_err(e_MISC,"malformed binary file (no name)");
    4357           0 :       if (c == NAM_GEN)
    4358             :       {
    4359           0 :         x = rdGEN(f);
    4360           0 :         if (H) gen_relink(x, H);
    4361           0 :         err_printf("setting %s\n",s);
    4362           0 :         changevalue(varentries[fetch_user_var(s)], x);
    4363             :       }
    4364             :       else
    4365             :       {
    4366           0 :         pari_var_create(fetch_entry(s));
    4367           0 :         x = gnil;
    4368             :       }
    4369           0 :       break;
    4370             :     }
    4371             :     case RELINK_TABLE:
    4372           0 :       x = rdGEN(f); break;
    4373           0 :     case EOF: break;
    4374           0 :     default: pari_err(e_MISC,"unknown code in readobj");
    4375             :   }
    4376           0 :   *ptc = c; return x;
    4377             : }
    4378             : 
    4379             : #define MAGIC "\020\001\022\011-\007\020" /* ^P^A^R^I-^G^P */
    4380             : #ifdef LONG_IS_64BIT
    4381             : #  define ENDIAN_CHECK 0x0102030405060708L
    4382             : #else
    4383             : #  define ENDIAN_CHECK 0x01020304L
    4384             : #endif
    4385             : static const long BINARY_VERSION = 1; /* since 2.2.9 */
    4386             : 
    4387             : static int
    4388           0 : is_magic_ok(FILE *f)
    4389             : {
    4390           0 :   pari_sp av = avma;
    4391           0 :   size_t L = strlen(MAGIC);
    4392           0 :   char *s = stack_malloc(L);
    4393           0 :   int r = (fread(s,1,L, f) == L && strncmp(s,MAGIC,L) == 0);
    4394           0 :   avma = av; return r;
    4395             : }
    4396             : 
    4397             : static int
    4398           0 : is_sizeoflong_ok(FILE *f)
    4399             : {
    4400             :   char c;
    4401           0 :   return (fread(&c,1,1, f) == 1 && c == (char)sizeof(long));
    4402             : }
    4403             : 
    4404             : static int
    4405           0 : is_long_ok(FILE *f, long L)
    4406             : {
    4407             :   long c;
    4408           0 :   return (fread(&c,sizeof(long),1, f) == 1 && c == L);
    4409             : }
    4410             : 
    4411             : /* return 1 if valid binary file */
    4412             : static int
    4413           0 : check_magic(const char *name, FILE *f)
    4414             : {
    4415           0 :   if (!is_magic_ok(f))
    4416           0 :     pari_warn(warner, "%s is not a GP binary file",name);
    4417           0 :   else if (!is_sizeoflong_ok(f))
    4418           0 :     pari_warn(warner, "%s not written for a %ld bit architecture",
    4419             :                name, sizeof(long)*8);
    4420           0 :   else if (!is_long_ok(f, ENDIAN_CHECK))
    4421           0 :     pari_warn(warner, "unexpected endianness in %s",name);
    4422           0 :   else if (!is_long_ok(f, BINARY_VERSION))
    4423           0 :     pari_warn(warner, "%s written by an incompatible version of GP",name);
    4424           0 :   else return 1;
    4425           0 :   return 0;
    4426             : }
    4427             : 
    4428             : static void
    4429           0 : write_magic(FILE *f)
    4430             : {
    4431           0 :   fprintf(f, MAGIC);
    4432           0 :   fprintf(f, "%c", (char)sizeof(long));
    4433           0 :   wr_long(ENDIAN_CHECK, f);
    4434           0 :   wr_long(BINARY_VERSION, f);
    4435           0 : }
    4436             : 
    4437             : int
    4438           0 : file_is_binary(FILE *f)
    4439             : {
    4440           0 :   int c = fgetc(f); ungetc(c,f);
    4441           0 :   return (c != EOF && isprint(c) == 0 && isspace(c) == 0);
    4442             : }
    4443             : 
    4444             : void
    4445           0 : writebin(const char *name, GEN x)
    4446             : {
    4447           0 :   FILE *f = fopen(name,"r");
    4448           0 :   pari_sp av = avma;
    4449             :   GEN V;
    4450           0 :   int already = f? 1: 0;
    4451             : 
    4452           0 :   if (f) {
    4453           0 :     int ok = check_magic(name,f);
    4454           0 :     fclose(f);
    4455           0 :     if (!ok) pari_err_FILE("binary output file",name);
    4456             :   }
    4457           0 :   f = fopen(name,"a");
    4458           0 :   if (!f) pari_err_FILE("binary output file",name);
    4459           0 :   if (!already) write_magic(f);
    4460             : 
    4461           0 :   V = copybin_unlink(x);
    4462           0 :   if (lg(gel(V,1)) > 1)
    4463             :   {
    4464           0 :     fputc(RELINK_TABLE,f);
    4465           0 :     wrGEN(V, f);
    4466             :   }
    4467           0 :   if (x) writeGEN(x,f);
    4468             :   else
    4469             :   {
    4470           0 :     long v, maxv = pari_var_next();
    4471           0 :     for (v=0; v<maxv; v++)
    4472             :     {
    4473           0 :       entree *ep = varentries[v];
    4474           0 :       if (!ep) continue;
    4475           0 :       writenamedGEN((GEN)ep->value,ep->name,f);
    4476             :     }
    4477             :   }
    4478           0 :   avma = av; fclose(f);
    4479           0 : }
    4480             : 
    4481             : /* read all objects in f. If f contains BIN_GEN that would be silently ignored
    4482             :  * [i.e f contains more than one objet, not all of them 'named GENs'], return
    4483             :  * them all in a vector and set 'vector'. */
    4484             : GEN
    4485           0 : readbin(const char *name, FILE *f, int *vector)
    4486             : {
    4487           0 :   pari_sp av = avma;
    4488           0 :   hashtable *H = NULL;
    4489             :   pari_stack s_obj;
    4490             :   GEN obj, x, y;
    4491             :   int cy;
    4492           0 :   if (vector) *vector = 0;
    4493           0 :   if (!check_magic(name,f)) return NULL;
    4494           0 :   pari_stack_init(&s_obj, sizeof(GEN), (void**)&obj);
    4495             :   /* HACK: push codeword so as to be able to treat s_obj.data as a t_VEC */
    4496           0 :   pari_stack_pushp(&s_obj, (void*) (evaltyp(t_VEC)|evallg(1)));
    4497           0 :   x = gnil;
    4498           0 :   while ((y = readobj(f, &cy, H)))
    4499             :   {
    4500           0 :     x = y;
    4501           0 :     switch(cy)
    4502             :     {
    4503             :       case BIN_GEN:
    4504           0 :         pari_stack_pushp(&s_obj, (void*)y); break;
    4505             :       case RELINK_TABLE:
    4506           0 :         if (H) hash_destroy(H);
    4507           0 :         H = hash_from_link(gel(y,1),gel(y,2), 0);
    4508             :     }
    4509             :   }
    4510           0 :   if (H) hash_destroy(H);
    4511           0 :   switch(s_obj.n) /* >= 1 */
    4512             :   {
    4513           0 :     case 1: break; /* nothing but the codeword */
    4514           0 :     case 2: x = gel(obj,1); break; /* read a single BIN_GEN */
    4515             :     default: /* more than one BIN_GEN */
    4516           0 :       setlg(obj, s_obj.n);
    4517           0 :       if (DEBUGLEVEL)
    4518           0 :         pari_warn(warner,"%ld unnamed objects read. Returning then in a vector",
    4519           0 :                   s_obj.n - 1);
    4520           0 :       x = gerepilecopy(av, obj);
    4521           0 :       if (vector) *vector = 1;
    4522             :   }
    4523           0 :   pari_stack_delete(&s_obj);
    4524           0 :   return x;
    4525             : }
    4526             : 
    4527             : /*******************************************************************/
    4528             : /**                                                               **/
    4529             : /**                             GP I/O                            **/
    4530             : /**                                                               **/
    4531             : /*******************************************************************/
    4532             : /* print a vector of GENs, in output context 'out', using 'sep' as a
    4533             :  * separator between sucessive entries [ NULL = no separator ]*/
    4534             : void
    4535       80033 : out_print0(PariOUT *out, const char *sep, GEN g, long flag)
    4536             : {
    4537       80033 :   pari_sp av = avma;
    4538       80033 :   OUT_FUN f = get_fun(flag);
    4539       80033 :   long i, l = lg(g);
    4540      232729 :   for (i = 1; i < l; i++, avma = av)
    4541             :   {
    4542      152696 :     out_puts(out, stack_GENtostr_fun_unquoted(gel(g,i), GP_DATA->fmt, f));
    4543      152696 :     if (sep && i+1 < l) out_puts(out, sep);
    4544             :   }
    4545       80033 : }
    4546             : static void
    4547          14 : str_print0(outString *S, GEN g, long flag)
    4548             : {
    4549          14 :   pari_sp av = avma;
    4550          14 :   OUT_FUN f = get_fun(flag);
    4551          14 :   long i, l = lg(g);
    4552          42 :   for (i = 1; i < l; i++, avma = av)
    4553          28 :     str_puts(S, stack_GENtostr_fun_unquoted(gel(g,i), GP_DATA->fmt, f));
    4554          14 :   *(S->cur) = 0;
    4555          14 : }
    4556             : 
    4557             : /* display s, followed by the element of g */
    4558             : char *
    4559          14 : pari_sprint0(const char *s, GEN g, long flag)
    4560             : {
    4561             :   outString S;
    4562          14 :   str_init(&S, 0);
    4563          14 :   str_puts(&S, s);
    4564          14 :   str_print0(&S, g, flag);
    4565          14 :   return S.string;
    4566             : }
    4567             : 
    4568             : static void
    4569           0 : print0_file(FILE *out, GEN g, long flag)
    4570             : {
    4571           0 :   pari_sp av = avma;
    4572             :   outString S;
    4573           0 :   str_init(&S, 1);
    4574           0 :   str_print0(&S, g, flag);
    4575           0 :   fputs(S.string, out);
    4576           0 :   avma = av;
    4577           0 : }
    4578             : 
    4579             : void
    4580       79298 : print0(GEN g, long flag) { out_print0(pariOut, NULL, g, flag); }
    4581             : void
    4582         707 : printsep(const char *s, GEN g)
    4583         707 : { out_print0(pariOut, s, g, f_RAW); pari_putc('\n'); pari_flush(); }
    4584             : void
    4585          21 : printsep1(const char *s, GEN g) { out_print0(pariOut, s, g, f_RAW); pari_flush(); }
    4586             : 
    4587             : /* dummy needed to pass a (empty!) va_list to sm_dopr */
    4588             : static char *
    4589        1218 : dopr_arg_vector(GEN arg_vector, const char* fmt, ...)
    4590             : {
    4591             :   va_list ap;
    4592             :   char *s;
    4593        1218 :   va_start(ap, fmt);
    4594        1218 :   s = sm_dopr(fmt, arg_vector, ap);
    4595        1197 :   va_end(ap); return s;
    4596             : }
    4597             : /* GP only */
    4598             : void
    4599         497 : printf0(const char *fmt, GEN args)
    4600         497 : { char *s = dopr_arg_vector(args, fmt);
    4601         476 :   pari_puts(s); pari_free(s); pari_flush(); }
    4602             : /* GP only */
    4603             : GEN
    4604         721 : Strprintf(const char *fmt, GEN args)
    4605         721 : { char *s = dopr_arg_vector(args, fmt);
    4606         721 :   GEN z = strtoGENstr(s); pari_free(s); return z; }
    4607             : 
    4608             : void
    4609       14964 : out_vprintf(PariOUT *out, const char *fmt, va_list ap)
    4610             : {
    4611       14964 :   char *s = sm_dopr(fmt, NULL, ap);
    4612       14964 :   out_puts(out, s); pari_free(s);
    4613       14964 : }
    4614             : void
    4615         489 : pari_vprintf(const char *fmt, va_list ap) { out_vprintf(pariOut, fmt, ap); }
    4616             : 
    4617             : /* variadic version of printf0 */
    4618             : void
    4619       13845 : out_printf(PariOUT *out, const char *fmt, ...)
    4620             : {
    4621       13845 :   va_list args; va_start(args,fmt);
    4622       13845 :   out_vprintf(out,fmt,args); va_end(args);
    4623       13845 : }
    4624             : void
    4625         489 : pari_printf(const char *fmt, ...) /* variadic version of printf0 */
    4626             : {
    4627         489 :   va_list args; va_start(args,fmt);
    4628         489 :   pari_vprintf(fmt,args); va_end(args);
    4629         489 : }
    4630             : 
    4631             : char *
    4632       22119 : pari_vsprintf(const char *fmt, va_list ap)
    4633       22119 : { return sm_dopr(fmt, NULL, ap); }
    4634             : 
    4635             : GEN
    4636        2692 : gvsprintf(const char *fmt, va_list ap)
    4637             : {
    4638        2692 :   char *s = sm_dopr(fmt, NULL, ap);
    4639        2692 :   GEN z = strtoGENstr(s);
    4640        2692 :   pari_free(s); return z;
    4641             : }
    4642             : 
    4643             : char *
    4644       20824 : pari_sprintf(const char *fmt, ...) /* variadic version of Strprintf */
    4645             : {
    4646             :   char *s;
    4647             :   va_list ap;
    4648       20824 :   va_start(ap, fmt);
    4649       20824 :   s = pari_vsprintf(fmt, ap);
    4650       20824 :   va_end(ap); return s;
    4651             : }
    4652             : 
    4653             : char *
    4654        1295 : stack_sprintf(const char *fmt, ...)
    4655             : {
    4656             :   char *s, *t;
    4657             :   va_list ap;
    4658        1295 :   va_start(ap, fmt);
    4659        1295 :   s = pari_vsprintf(fmt, ap);
    4660        1295 :   va_end(ap);
    4661        1295 :   t = stack_strdup(s);
    4662        1295 :   pari_free(s); return t;
    4663             : }
    4664             : 
    4665             : GEN
    4666          14 : gsprintf(const char *fmt, ...) /* variadic version of gvsprintf */
    4667             : {
    4668             :   GEN s;
    4669             :   va_list ap;
    4670          14 :   va_start(ap, fmt);
    4671          14 :   s = gvsprintf(fmt, ap);
    4672          14 :   va_end(ap); return s;
    4673             : }
    4674             : 
    4675             : /* variadic version of fprintf0. FIXME: fprintf0 not yet available */
    4676             : void
    4677           0 : pari_vfprintf(FILE *file, const char *fmt, va_list ap)
    4678             : {
    4679           0 :   char *s = sm_dopr(fmt, NULL, ap);
    4680           0 :   fputs(s, file); pari_free(s);
    4681           0 : }
    4682             : void
    4683           0 : pari_fprintf(FILE *file, const char *fmt, ...)
    4684             : {
    4685           0 :   va_list ap; va_start(ap, fmt);
    4686           0 :   pari_vfprintf(file, fmt, ap); va_end(ap);
    4687           0 : }
    4688             : 
    4689       74146 : void print   (GEN g) { print0(g, f_RAW);       pari_putc('\n'); pari_flush(); }
    4690           7 : void printtex(GEN g) { print0(g, f_TEX);       pari_putc('\n'); pari_flush(); }
    4691        5145 : void print1  (GEN g) { print0(g, f_RAW);       pari_flush(); }
    4692             : 
    4693             : void
    4694          14 : error0(GEN g)
    4695             : {
    4696          14 :   if (lg(g)==2 && typ(gel(g,1))==t_ERROR) pari_err(0, gel(g,1));
    4697          14 :   else pari_err(e_USER, g);
    4698           0 : }
    4699             : 
    4700           7 : void warning0(GEN g) { pari_warn(warnuser, g); }
    4701             : 
    4702             : static char *
    4703           0 : wr_check(const char *s) {
    4704           0 :   char *t = path_expand(s);
    4705           0 :   if (GP_DATA->secure)
    4706             :   {
    4707           0 :     char *msg = pari_sprintf("[secure mode]: about to write to '%s'",t);
    4708           0 :     pari_ask_confirm(msg);
    4709           0 :     pari_free(msg);
    4710             :   }
    4711           0 :   return t;
    4712             : }
    4713             : 
    4714             : /* write to file s */
    4715             : static void
    4716           0 : wr(const char *s, GEN g, long flag, int addnl)
    4717             : {
    4718           0 :   char *t = wr_check(s);
    4719           0 :   FILE *out = switchout_get_FILE(t);
    4720           0 :   pari_free(t);
    4721           0 :   print0_file(out, g, flag);
    4722           0 :   if (addnl) fputc('\n', out);
    4723           0 :   fflush(out);
    4724           0 :   if (fclose(out)) pari_warn(warnfile, "close", t);
    4725           0 : }
    4726           0 : void write0  (const char *s, GEN g) { wr(s, g, f_RAW, 1); }
    4727           0 : void writetex(const char *s, GEN g) { wr(s, g, f_TEX, 1); }
    4728           0 : void write1  (const char *s, GEN g) { wr(s, g, f_RAW, 0); }
    4729           0 : void gpwritebin(const char *s, GEN x) { char *t=wr_check(s); writebin(t, x); pari_free(t);}
    4730             : 
    4731             : /*******************************************************************/
    4732             : /**                                                               **/
    4733             : /**                       HISTORY HANDLING                        **/
    4734             : /**                                                               **/
    4735             : /*******************************************************************/
    4736             : /* history management function:
    4737             :  *   p > 0, called from %p or %#p
    4738             :  *   p <= 0, called from %` or %#` (|p| backquotes, possibly 0) */
    4739             : static gp_hist_cell *
    4740         112 : history(long p)
    4741             : {
    4742         112 :   gp_hist *H = GP_DATA->hist;
    4743         112 :   ulong t = H->total, s = H->size;
    4744             :   gp_hist_cell *c;
    4745             : 
    4746         112 :   if (!t) pari_err(e_MISC,"The result history is empty");
    4747             : 
    4748         112 :   if (p <= 0) p += t; /* count |p| entries starting from last */
    4749         112 :   if (p <= 0 || p <= (long)(t - s) || (ulong)p > t)
    4750             :   {
    4751          14 :     long pmin = (long)(t - s) + 1;
    4752          14 :     if (pmin <= 0) pmin = 1;
    4753          14 :     pari_err(e_MISC,"History result %%%ld not available [%%%ld-%%%lu]",
    4754             :              p,pmin,t);
    4755             :   }
    4756          98 :   c = H->v + ((p-1) % s);
    4757          98 :   if (!c->z)
    4758           7 :     pari_err(e_MISC,"History result %%%ld has been deleted (histsize changed)", p);
    4759          91 :   return c;
    4760             : }
    4761             : GEN
    4762          91 : pari_get_hist(long p) { return history(p)->z; }
    4763             : long
    4764          21 : pari_get_histtime(long p) { return history(p)->t; }
    4765             : 
    4766             : void
    4767       49956 : pari_add_hist(GEN x, long time)
    4768             : {
    4769       49956 :   gp_hist *H = GP_DATA->hist;
    4770       49956 :   ulong i = H->total % H->size;
    4771       49956 :   H->total++;
    4772       49956 :   if (H->v[i].z) gunclone(H->v[i].z);
    4773       49956 :   H->v[i].t = time;
    4774       49956 :   H->v[i].z = gclone(x);
    4775       49956 : }
    4776             : 
    4777             : ulong
    4778           0 : pari_nb_hist(void)
    4779             : {
    4780           0 :   return GP_DATA->hist->total;
    4781             : }
    4782             : 
    4783             : /*******************************************************************/
    4784             : /**                                                               **/
    4785             : /**                       TEMPORARY FILES                         **/
    4786             : /**                                                               **/
    4787             : /*******************************************************************/
    4788             : 
    4789             : #ifndef R_OK
    4790             : #  define R_OK 4
    4791             : #  define W_OK 2
    4792             : #  define X_OK 1
    4793             : #  define F_OK 0
    4794             : #endif
    4795             : 
    4796             : #ifdef __EMX__
    4797             : #include <io.h>
    4798             : static int
    4799             : unix_shell(void)
    4800             : {
    4801             :   char *base, *sh = getenv("EMXSHELL");
    4802             :   if (!sh) {
    4803             :     sh = getenv("COMSPEC");
    4804             :     if (!sh) return 0;
    4805             :   }
    4806             :   base = _getname(sh);
    4807             :   return (stricmp (base, "cmd.exe") && stricmp (base, "4os2.exe")
    4808             :        && stricmp (base, "command.com") && stricmp (base, "4dos.com"));
    4809             : }
    4810             : #endif
    4811             : 
    4812             : /* check if s has rwx permissions for us */
    4813             : static int
    4814         314 : pari_is_rwx(const char *s)
    4815             : {
    4816             : /* FIXME: HAS_ACCESS */
    4817             : #if defined(UNIX) || defined (__EMX__)
    4818         314 :   return access(s, R_OK | W_OK | X_OK) == 0;
    4819             : #else
    4820             :   (void) s; return 1;
    4821             : #endif
    4822             : }
    4823             : 
    4824             : #if defined(UNIX) || defined (__EMX__)
    4825             : #include <sys/types.h>
    4826             : #include <sys/stat.h>
    4827             : static int
    4828           0 : pari_file_exists(const char *s)
    4829             : {
    4830           0 :   int id = open(s, O_CREAT|O_EXCL|O_RDWR, S_IRUSR|S_IWUSR);
    4831           0 :   return id < 0 || close(id);
    4832             : }
    4833             : static int
    4834         314 : pari_dir_exists(const char *s) { return mkdir(s, 0777); }
    4835             : #elif defined(_WIN32)
    4836             : static int
    4837             : pari_file_exists(const char *s) { return GetFileAttributesA(s) != ~0UL; }
    4838             : static int
    4839             : pari_dir_exists(const char *s) { return mkdir(s); }
    4840             : #else
    4841             : static int
    4842             : pari_file_exists(const char *s) { return 0; }
    4843             : static int
    4844             : pari_dir_exists(const char *s) { return 0; }
    4845             : #endif
    4846             : 
    4847             : char *
    4848         628 : env_ok(const char *s)
    4849             : {
    4850         628 :   char *t = os_getenv(s);
    4851         628 :   if (t && !pari_is_rwx(t))
    4852             :   {
    4853           0 :     pari_warn(warner,"%s is set (%s), but is not writable", s,t);
    4854           0 :     t = NULL;
    4855             :   }
    4856         628 :   if (t && !pari_is_dir(t))
    4857             :   {
    4858           0 :     pari_warn(warner,"%s is set (%s), but is not a directory", s,t);
    4859           0 :     t = NULL;
    4860             :   }
    4861         628 :   return t;
    4862             : }
    4863             : 
    4864             : static const char*
    4865         314 : pari_tmp_dir(void)
    4866             : {
    4867             :   char *s;
    4868         314 :   s = env_ok("GPTMPDIR"); if (s) return s;
    4869         314 :   s = env_ok("TMPDIR"); if (s) return s;
    4870             : #if defined(_WIN32) || defined(__EMX__)
    4871             :   s = env_ok("TMP"); if (s) return s;
    4872             :   s = env_ok("TEMP"); if (s) return s;
    4873             : #endif
    4874             : #if defined(UNIX) || defined(__EMX__)
    4875         314 :   if (pari_is_rwx("/tmp")) return "/tmp";
    4876           0 :   if (pari_is_rwx("/var/tmp")) return "/var/tmp";
    4877             : #endif
    4878           0 :   return ".";
    4879             : }
    4880             : 
    4881             : /* loop through 26^2 variants [suffix 'aa' to 'zz'] */
    4882             : static int
    4883           0 : get_file(char *buf, int test(const char *))
    4884             : {
    4885           0 :   char c, d, *end = buf + strlen(buf) - 1;
    4886           0 :   for (d = 'a'; d <= 'z'; d++)
    4887             :   {
    4888           0 :     end[-1] = d;
    4889           0 :     for (c = 'a'; c <= 'z'; c++)
    4890             :     {
    4891           0 :       *end = c;
    4892           0 :       if (! test(buf)) return 1;
    4893           0 :       if (DEBUGFILES) err_printf("I/O: file %s exists!\n", buf);
    4894             :     }
    4895             :   }
    4896           0 :   return 0;
    4897             : }
    4898             : 
    4899             : #if defined(__EMX__) || defined(_WIN32)
    4900             : static void
    4901             : swap_slash(char *s)
    4902             : {
    4903             : #ifdef __EMX__
    4904             :   if (!unix_shell())
    4905             : #endif
    4906             :   {
    4907             :     char *t;
    4908             :     for (t=s; *t; t++)
    4909             :       if (*t == '/') *t = '\\';
    4910             :   }
    4911             : }
    4912             : #endif
    4913             : 
    4914             : static char *
    4915         314 : init_unique(const char *s)
    4916             : {
    4917         314 :   const char *pre = pari_tmp_dir();
    4918             :   char *buf, suf[64];
    4919             :   size_t lpre, lsuf;
    4920             : #ifdef UNIX
    4921         314 :   sprintf(suf,"-%ld-%ld", (long)getuid(), (long)getpid());
    4922             : #else
    4923             :   suf[0] = 0;
    4924             : #endif
    4925         314 :   lsuf = strlen(suf);
    4926         314 :   lpre = strlen(pre);
    4927             :   /* room for prefix + '/' + s + suffix '\0' */
    4928         314 :   buf = (char*) pari_malloc(lpre + 1 + 8 + lsuf + 1);
    4929         314 :   strcpy(buf, pre);
    4930         314 :   if (buf[lpre-1] != '/') { (void)strcat(buf, "/"); lpre++; }
    4931             : #if defined(__EMX__) || defined(_WIN32)
    4932             :   swap_slash(buf);
    4933             : #endif
    4934             : 
    4935         314 :   sprintf(buf + lpre, "%.8s%s", s, suf);
    4936         314 :   if (DEBUGFILES) err_printf("I/O: prefix for unique file/dir = %s\n", buf);
    4937         314 :   return buf;
    4938             : }
    4939             : 
    4940             : /* Return a "unique filename" built from the string s, possibly the user id
    4941             :  * and the process pid (on Unix systems). A "temporary" directory name is
    4942             :  * prepended. The name returned is pari_malloc'ed. It is DOS-safe
    4943             :  * (s truncated to 8 chars) */
    4944             : char*
    4945           0 : pari_unique_filename(const char *s)
    4946             : {
    4947           0 :   char *buf = init_unique(s);
    4948           0 :   if (pari_file_exists(buf) && !get_file(buf, pari_file_exists))
    4949           0 :     pari_err(e_MISC,"couldn't find a suitable name for a tempfile (%s)",s);
    4950           0 :   return buf;
    4951             : }
    4952             : 
    4953             : /* Create a "unique directory" and return its name built from the string
    4954             :  * s, the user id and process pid (on Unix systems). A "temporary"
    4955             :  * directory name is prepended. The name returned is pari_malloc'ed.
    4956             :  * It is DOS-safe (truncated to 8 chars) */
    4957             : char*
    4958         314 : pari_unique_dir(const char *s)
    4959             : {
    4960         314 :   char *buf = init_unique(s);
    4961         314 :   if (pari_dir_exists(buf) && !get_file(buf, pari_dir_exists))
    4962           0 :     pari_err(e_MISC,"couldn't find a suitable name for a tempdir (%s)",s);
    4963         314 :   return buf;
    4964             : }
    4965             : 
    4966             : /*******************************************************************/
    4967             : /**                                                               **/
    4968             : /**                             INSTALL                           **/
    4969             : /**                                                               **/
    4970             : /*******************************************************************/
    4971             : 
    4972             : #ifdef HAS_DLOPEN
    4973             : #include <dlfcn.h>
    4974             : 
    4975             : /* see try_name() */
    4976             : static void *
    4977           0 : try_dlopen(const char *s, int flag)
    4978           0 : { void *h = dlopen(s, flag); pari_free((void*)s); return h; }
    4979             : 
    4980             : /* like dlopen, but using default(sopath) */
    4981             : static void *
    4982           7 : gp_dlopen(const char *name, int flag)
    4983             : {
    4984             :   void *handle;
    4985             :   char *s;
    4986             : 
    4987           7 :   if (!name) return dlopen(NULL, flag);
    4988           0 :   s = path_expand(name);
    4989             : 
    4990             :   /* if sopath empty or path is absolute, use dlopen */
    4991           0 :   if (!GP_DATA || *(GP_DATA->sopath->PATH)==0 || path_is_absolute(s))
    4992           0 :     return try_dlopen(s, flag);
    4993             :   else
    4994             :   {
    4995             :     forpath_t T;
    4996             :     char *t;
    4997           0 :     forpath_init(&T, GP_DATA->sopath, s);
    4998           0 :     while ( (t = forpath_next(&T)) )
    4999             :     {
    5000           0 :       if ( (handle = try_dlopen(t,flag)) ) { pari_free(s); return handle; }
    5001           0 :       (void)dlerror(); /* clear error message */
    5002             :     }
    5003           0 :     pari_free(s);
    5004             :   }
    5005           0 :   return NULL;
    5006             : }
    5007             : 
    5008             : static void *
    5009           7 : install0(const char *name, const char *lib)
    5010             : {
    5011             :   void *handle;
    5012             : 
    5013             : #ifndef RTLD_GLOBAL /* OSF1 has dlopen but not RTLD_GLOBAL*/
    5014             : #  define RTLD_GLOBAL 0
    5015             : #endif
    5016           7 :   handle = gp_dlopen(lib, RTLD_LAZY|RTLD_GLOBAL);
    5017             : 
    5018           7 :   if (!handle)
    5019             :   {
    5020           0 :     const char *s = dlerror(); if (s) err_printf("%s\n\n",s);
    5021           0 :     if (lib) pari_err(e_MISC,"couldn't open dynamic library '%s'",lib);
    5022           0 :     pari_err(e_MISC,"couldn't open dynamic symbol table of process");
    5023             :   }
    5024           7 :   return dlsym(handle, name);
    5025             : }
    5026             : #else
    5027             : #  ifdef _WIN32
    5028             : static HMODULE
    5029             : try_LoadLibrary(const char *s)
    5030             : { void *h = LoadLibrary(s); pari_free((void*)s); return h; }
    5031             : 
    5032             : /* like LoadLibrary, but using default(sopath) */
    5033             : static HMODULE
    5034             : gp_LoadLibrary(const char *name)
    5035             : {
    5036             :   HMODULE handle;
    5037             :   char *s = path_expand(name);
    5038             : 
    5039             :   /* if sopath empty or path is absolute, use LoadLibrary */
    5040             :   if (!GP_DATA || *(GP_DATA->sopath->PATH)==0 || path_is_absolute(s))
    5041             :     return try_LoadLibrary(s);
    5042             :   else
    5043             :   {
    5044             :     forpath_t T;
    5045             :     char *t;
    5046             :     forpath_init(&T, GP_DATA->sopath, s);
    5047             :     while ( (t = forpath_next(&T)) )
    5048             :       if ( (handle = try_LoadLibrary(t)) ) { pari_free(s); return handle; }
    5049             :     pari_free(s);
    5050             :   }
    5051             :   return NULL;
    5052             : }
    5053             : static void *
    5054             : install0(const char *name, const char *lib)
    5055             : {
    5056             :   HMODULE handle;
    5057             : 
    5058             :   handle = gp_LoadLibrary(lib);
    5059             :   if (!handle)
    5060             :   {
    5061             :     if (lib) pari_err(e_MISC,"couldn't open dynamic library '%s'",lib);
    5062             :     pari_err(e_MISC,"couldn't open dynamic symbol table of process");
    5063             :   }
    5064             :   return (void *) GetProcAddress(handle,name);
    5065             : }
    5066             : #  else
    5067             : static void *
    5068             : install0(const char *name, const char *lib)
    5069             : { pari_err(e_ARCH,"install"); return NULL; }
    5070             : #endif
    5071             : #endif
    5072             : 
    5073             : static char *
    5074           7 : dft_help(const char *gp, const char *s, const char *code)
    5075           7 : { return stack_sprintf("%s: installed function\nlibrary name: %s\nprototype: %s" , gp, s, code); }
    5076             : 
    5077             : void
    5078           7 : gpinstall(const char *s, const char *code, const char *gpname, const char *lib)
    5079             : {
    5080           7 :   pari_sp av = avma;
    5081           7 :   const char *gp = *gpname? gpname: s;
    5082             :   void *f;
    5083             :   entree *ep;
    5084           7 :   if (GP_DATA->secure)
    5085             :   {
    5086           0 :     char *msg = pari_sprintf("[secure mode]: about to install '%s'", s);
    5087           0 :     pari_ask_confirm(msg);
    5088           0 :     pari_free(msg);
    5089             :   }
    5090           7 :   ep = is_entry(gp);
    5091           7 :   if (ep && ep->valence == EpINSTALL
    5092           0 :       && strcmp(ep->code, code)
    5093           0 :       && !strcmp(ep->help, dft_help(gp,s,ep->code)))
    5094             :   { /* help is the default AND prototype changes: delete help */
    5095           0 :     pari_free((void*)ep->help); ep->help = NULL;
    5096             :   }
    5097           7 :   f = install0(s, *lib ?lib :pari_library_path);
    5098           7 :   if (!f)
    5099             :   {
    5100           0 :     if (*lib) pari_err(e_MISC,"can't find symbol '%s' in library '%s'",s,lib);
    5101           0 :     pari_err(e_MISC,"can't find symbol '%s' in dynamic symbol table of process",s);
    5102             :   }
    5103           7 :   ep = install(f,gp,code);
    5104           7 :   if (ep && !ep->help) addhelp(gp, dft_help(gp,s,code));
    5105           7 :   mt_broadcast(strtoclosure("install",4,strtoGENstr(s),strtoGENstr(code),
    5106             :                                        strtoGENstr(gp),strtoGENstr(lib)));
    5107           7 :   avma = av;
    5108           7 : }

Generated by: LCOV version 1.11