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