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