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