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