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