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