Annotation of OpenXM_contrib/pari-2.2/src/language/es.c, Revision 1.1.1.1
1.1 noro 1: /* $Id: es.c,v 1.59 2001/09/29 12:58:10 karim Exp $
2:
3: Copyright (C) 2000 The PARI group.
4:
5: This file is part of the PARI/GP package.
6:
7: PARI/GP is free software; you can redistribute it and/or modify it under the
8: terms of the GNU General Public License as published by the Free Software
9: Foundation. It is distributed in the hope that it will be useful, but WITHOUT
10: ANY WARRANTY WHATSOEVER.
11:
12: Check the License for details. You should have received a copy of it, along
13: with the package; see the file 'COPYING'. If not, write to the Free Software
14: Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */
15:
16: /*******************************************************************/
17: /** **/
18: /** INPUT/OUTPUT SUBROUTINES **/
19: /** **/
20: /*******************************************************************/
21: #include "pari.h"
22: #include "anal.h"
23: extern GEN confrac(GEN x); /* should be static here, but use hiremainder */
24: extern GEN convi(GEN x);
25: static void bruti(GEN g, long n);
26: static void texi(GEN g, long nosign);
27: static void sori(GEN g);
28: char * type_name(long t);
29: static char format;
30: static long decimals, chmp, initial;
31:
32: /* output a space or do nothing depending on original caller */
33: static void (*sp)();
34:
35: void
36: hit_return()
37: {
38: int c;
39: if (under_texmacs || under_emacs) return;
40: pariputs("---- (type RETURN to continue) ----");
41: /* if called from a readline callback, may be in a funny TTY mode, */
42: do c = fgetc(stdin); while (c >= 0 && c != '\n' && c != '\r' && c != ' ');
43: pariputc('\n');
44: }
45:
46: /********************************************************************/
47: /** **/
48: /** INPUT FILTER **/
49: /** **/
50: /********************************************************************/
51:
52: #define ONE_LINE_COMMENT 2
53: #define MULTI_LINE_COMMENT 1
54: /* Filter s into t. If flag is a query, return s (yes) / NULL (no)
55: * Otherwise, if t == NULL, allocate enough room, filter then return t.
56: * if not return pointer to ending '\0' in t.
57: */
58: char *
59: filtre(char *s0, char *t0, int flag)
60: {
61: static int in_string, in_comment = 0;
62: char c, *s, *t;
63: int downcase, return_end;
64:
65: if (flag & f_INIT) in_string = 0;
66: switch(flag)
67: {
68: case f_ENDFILE:
69: if (in_string)
70: {
71: err(warner,"run-away string. Closing it");
72: in_string = 0;
73: }
74: if (in_comment)
75: {
76: err(warner,"run-away comment. Closing it");
77: in_comment = 0;
78: } /* fall through */
79: case f_INIT: case f_COMMENT:
80: return in_comment? s0: NULL;
81: }
82:
83: downcase = ((flag & f_KEEPCASE) == 0 && compatible == OLDALL);
84: s = s0; return_end = (t0 != NULL);
85: if (!t0) t0 = gpmalloc(strlen(s)+1);
86: t = t0;
87:
88: while ((c = *s++))
89: {
90: if (in_string) *t++ = c; /* copy verbatim */
91: else if (in_comment)
92: {
93: if (in_comment == MULTI_LINE_COMMENT)
94: {
95: while (c != '*' || *s != '/')
96: {
97: if (!*s) goto END;
98: c = *s++;
99: }
100: s++;
101: }
102: else
103: while (c != '\n')
104: {
105: if (!*s) { in_comment=0; goto END; }
106: c = *s++;
107: }
108: in_comment=0; continue;
109: }
110: else
111: { /* weed out comments and spaces */
112: if (c=='\\' && *s=='\\') { in_comment = ONE_LINE_COMMENT; continue; }
113: if (isspace((int)c)) continue;
114: *t++ = downcase? tolower(c): c;
115: }
116: switch(c)
117: {
118: case '/':
119: if (*s != '*' || in_string) break;
120: /* start multi-line comment */
121: t--; in_comment = MULTI_LINE_COMMENT; break;
122:
123: case '\\':
124: if (!in_string) break;
125: if (!*s) goto END; /* this will result in an error */
126: *t++ = *s++; break; /* in strings, \ is the escape character */
127: /* \" does not end a string. But \\" does */
128:
129: case '"':
130: in_string = !in_string;
131: }
132: }
133: END:
134: *t = 0; return return_end? t: t0;
135: }
136: #undef ONE_LINE_COMMENT
137: #undef MULTI_LINE_COMMENT
138:
139: GEN
140: lisGEN(FILE *fi)
141: {
142: long size = 512, n = size;
143: char *buf = gpmalloc(n), *s = buf;
144:
145: while (fgets(s, n, fi))
146: {
147: if (s[strlen(s)-1] == '\n')
148: {
149: GEN x = flisexpr(buf);
150: free(buf); return x;
151: }
152: buf = gprealloc(buf, size<<1, size);
153: s = buf + (size-1); n = size+1; size <<= 1;
154: }
155: #if defined(UNIX) || defined(__EMX__)
156: if (!feof(fi))
157: #endif
158: err(talker, "failed read from file");
159: return NULL;
160: }
161:
162: /********************************************************************/
163: /** **/
164: /** GENERAL PURPOSE PRINTING **/
165: /** **/
166: /********************************************************************/
167: PariOUT *pariOut, *pariErr;
168:
169: static void
170: normalOutC(char c)
171: {
172: putc(c, pari_outfile);
173: if (logfile) putc(c, logfile);
174: }
175: static void
176: normalOutS(char *s)
177: {
178: fputs(s, pari_outfile);
179: if (logfile) { fputs(s, logfile); }
180: }
181: static void
182: normalOutF(void)
183: {
184: fflush(pari_outfile);
185: if (logfile) fflush(logfile);
186: }
187: PariOUT defaultOut = {normalOutC, normalOutS, normalOutF, NULL};
188:
189: static void
190: normalErrC(char c)
191: {
192: putc(c, errfile);
193: if (logfile) putc(c, logfile);
194: }
195: static void
196: normalErrS(char *s)
197: {
198: fputs(s, errfile);
199: if (logfile) fputs(s, logfile);
200: }
201: static void
202: normalErrF(void)
203: {
204: fflush(errfile);
205: if (logfile) fflush(logfile);
206: }
207: PariOUT defaultErr = {normalErrC, normalErrS, normalErrF, NULL};
208:
209: /** GENERIC PRINTING **/
210: void
211: initout(int initerr)
212: {
213: infile = stdin; pari_outfile = stdout; errfile = stderr;
214: pariOut = &defaultOut;
215: if (initerr) pariErr = &defaultErr;
216: }
217:
218: void
219: pariputc(char c) { pariOut->putch(c); }
220:
221: void
222: pariputs(char *s) { pariOut->puts(s); }
223:
224: void
225: pariflush(void) { pariOut->flush(); }
226:
227: void
228: flusherr(void) { pariErr->flush(); }
229:
230: /* format is standard printf format, except %Z is a GEN (cast to long) */
231: void
232: vpariputs(char* format, va_list args)
233: {
234: char buf[1024], str[1024], *f = format, *s = str;
235: long nb = 0;
236:
237: while (*f)
238: {
239: if (*f != '%') *s++ = *f++;
240: else
241: {
242: if (f[1] != 'Z') { *s++ = *f++; *s++ = *f++; }
243: else
244: {
245: strcpy(s,"\003%020ld\003"); /* brace with unprobable characters */
246: nb++; s += 8; f += 2; /* skip %Z */
247: }
248: }
249: }
250: *s = 0; vsprintf(buf,str,args); s = buf;
251: if (nb)
252: for (f=s; *f; f++)
253: if (*f == '\003' && f[21] == '\003')
254: {
255: *f = 0; f[21] = 0; /* remove the bracing chars */
256: pariOut->puts(s); bruteall((GEN)atol(f+1),'g',-1,1);
257: f += 22; s = f;
258: nb--; if (!nb) break;
259: }
260: pariOut->puts(s);
261: }
262:
263: void
264: pariputsf(char *format, ...)
265: {
266: va_list args;
267:
268: va_start(args,format); vpariputs(format,args);
269: va_end(args);
270: }
271:
272: /* start printing in "color" c */
273: /* terminal has to support ANSI color escape sequences */
274: #ifdef ESC
275: # undef ESC
276: #endif
277: #define ESC (0x1f & '[') /* C-[ = escape */
278:
279: void
280: term_color(int c)
281: {
282: pariputs(term_get_color(c));
283: }
284:
285: void
286: decode_color(int n, int *c)
287: {
288: c[1] = n & 0xf; n >>= 4; /* foreground */
289: c[2] = n & 0xf; n >>= 4; /* background */
290: c[0] = n & 0xf; /* attribute */
291: }
292:
293: char *
294: term_get_color(int n)
295: {
296: static char s[16];
297: int c[3], a;
298:
299: if (disable_color) return "";
300: if (n == c_NONE || (a = gp_colors[n]) == c_NONE)
301: sprintf(s, "%c[0m",ESC); /* reset */
302: else
303: {
304: decode_color(a,c);
305: if (c[1]<8) c[1] += 30; else c[1] += 82;
306: if (a & (1<<12)) /* transparent background */
307: sprintf(s, "%c[%d;%dm", ESC, c[0], c[1]);
308: else
309: {
310: if (c[2]<8) c[2] += 40; else c[2] += 92;
311: sprintf(s, "%c[%d;%d;%dm", ESC, c[0], c[1], c[2]);
312: }
313: }
314: return s;
315: }
316:
317: /********************************************************************/
318: /** **/
319: /** PRINTING BASED ON SCREEN WIDTH **/
320: /** **/
321: /********************************************************************/
322: static int col_index, lin_index, max_width, max_lin;
323: #ifdef HAS_TIOCGWINSZ
324: # include <sys/termios.h>
325: # include <sys/ioctl.h>
326: #endif
327:
328: static int
329: term_width_intern()
330: {
331: #ifdef HAS_TIOCGWINSZ
332: {
333: struct winsize s;
334: if (!under_emacs && !under_texmacs && !ioctl(0, TIOCGWINSZ, &s))
335: return s.ws_col;
336: }
337: #endif
338: #ifdef UNIX
339: {
340: char *str;
341: if ((str = getenv("COLUMNS"))) return atoi(str);
342: }
343: #endif
344: #ifdef __EMX__
345: {
346: int scrsize[2];
347: _scrsize(scrsize); return scrsize[0];
348: }
349: #endif
350: return 0;
351: }
352:
353: static int
354: term_height_intern()
355: {
356: #ifdef HAS_TIOCGWINSZ
357: {
358: struct winsize s;
359: if (!under_emacs && !under_texmacs && !ioctl(0, TIOCGWINSZ, &s))
360: return s.ws_row;
361: }
362: #endif
363: #ifdef UNIX
364: {
365: char *str;
366: if ((str = getenv("LINES"))) return atoi(str);
367: }
368: #endif
369: #ifdef __EMX__
370: {
371: int scrsize[2];
372: _scrsize(scrsize); return scrsize[1];
373: }
374: #endif
375: return 0;
376: }
377:
378: #define DFT_TERM_WIDTH 80
379: #define DFT_TERM_HEIGHT 20
380:
381: int
382: term_width()
383: {
384: int n = term_width_intern();
385: return (n>1)? n: DFT_TERM_WIDTH;
386: }
387:
388: int
389: term_height()
390: {
391: int n = term_height_intern();
392: return (n>1)? n: DFT_TERM_HEIGHT;
393: }
394:
395: #define MAX_WIDTH 76
396: /* output string wrapped after MAX_WIDTH characters (for gp -test) */
397: static void
398: putc80(char c)
399: {
400: if (c == '\n') col_index = -1;
401: else if (col_index == MAX_WIDTH)
402: { putc('\n',pari_outfile); col_index = 0; }
403: putc(c, pari_outfile); col_index++;
404: }
405: #undef MAX_WIDTH
406: static void
407: puts80(char *s)
408: {
409: while (*s) putc80(*s++);
410: }
411: PariOUT pariOut80= {putc80, puts80, normalOutF, NULL};
412:
413: void
414: init80(long n)
415: {
416: col_index = n; pariOut = &pariOut80;
417: }
418:
419: /* output stopped after max_line have been printed (for default(lines,)) */
420: static void
421: putc_lim_lines(char c)
422: {
423: if (lin_index > max_lin) return;
424: if (lin_index == max_lin)
425: if (c == '\n' || col_index >= max_width-5)
426: {
427: normalOutS(term_get_color(c_ERR));
428: normalOutS("[+++]"); lin_index++; return;
429: }
430: if (c == '\n')
431: {
432: col_index = -1; lin_index++;
433: }
434: else if (col_index == max_width)
435: {
436: col_index = 0; lin_index++;
437: }
438: col_index++; normalOutC(c);
439: }
440: static void
441: puts_lim_lines(char *s)
442: {
443: long i,len;
444: if (lin_index > max_lin) return;
445: len = strlen(s);
446: for(i=0; i<len; i++) putc_lim_lines(s[i]);
447: }
448:
449: PariOUT pariOut_lim_lines= {putc_lim_lines, puts_lim_lines, normalOutF, NULL};
450:
451: /* s = prefix already printed (print up to max lines) */
452: void
453: init_lim_lines(char *s, long max)
454: {
455: if (!max) return;
456: if (!s) { pariOut = &defaultOut; return; }
457: max_width = term_width();
458: max_lin = max;
459: lin_index = 1; col_index = strlen(s);
460: pariOut = &pariOut_lim_lines;
461: }
462:
463: #define is_blank_or_null(c) (!(c) || is_blank(c))
464: #define is_blank(c) ((c) == ' ' || (c) == '\n')
465: #define MAX_WORD_LEN 255
466:
467: static void
468: _new_line(char *prefix)
469: {
470: pariputc('\n'); if (prefix) pariputs(prefix);
471: }
472:
473: static long
474: strlen_real(char *s)
475: {
476: char *t = s, *t0;
477: long ctrl_len = 0;
478: while (*t)
479: {
480: t0 = t;
481: if (*t++ == ESC && *t++ == '[')
482: {
483: while (*t && *t++ != 'm') /* empty */;
484: ctrl_len += t - t0;
485: }
486: }
487: return strlen(s) - ctrl_len;
488: }
489:
490: /* output: <prefix>< s wrapped at EOL >
491: * <prefix>< ... > <str>
492: * ^--- (no \n at the end)
493: * If str is NULL, omit the arrow, assume the text doesn't contain ASCII
494: * escape sequences and end the text with '\n'. If prefix is NULL, use ""
495: */
496: void
497: print_prefixed_text(char *s, char *prefix, char *str)
498: {
499: long prelen = prefix? strlen_real(prefix): 0;
500: long oldwlen=0, linelen=prelen, w = term_width();
501: char word[MAX_WORD_LEN+1], oldword[MAX_WORD_LEN+1], *u=word;
502:
503: if (prefix) pariputs(prefix);
504: oldword[0]='\0';
505: while ((*u++ = *s++))
506: {
507: if (is_blank_or_null(*s))
508: {
509: while (is_blank(*s)) s++;
510: linelen += oldwlen;
511: if (linelen >= w)
512: {
513: _new_line(prefix);
514: linelen = oldwlen + prelen;
515: }
516: pariputs(oldword); *u++ = ' '; *u = 0;
517: /* u-word = strlen(word) */
518: oldwlen = str ? strlen_real(word): u - word;
519: if (*s) { strcpy(oldword,word); u = word; }
520: }
521: }
522: if (!str)
523: { /* add final period if needed */
524: u--; while (u > word && is_blank_or_null(*u)) u--;
525: if (u >= word && isalnum((int)*u)) { u[1] = '.'; u[2] = 0; }
526: }
527: else
528: { *(u-2) = 0; oldwlen--; }
529: linelen += oldwlen;
530: if (linelen >= w) { _new_line(prefix); linelen = prelen + oldwlen; }
531: pariputs(word);
532: if (str)
533: {
534: long i,len = strlen_real(str);
535: int space = (*str == ' ' && str[1]);
536: if (linelen + len >= w)
537: {
538: _new_line(prefix); linelen = prelen;
539: if (space) { str++; len--; space = 0; }
540: }
541: term_color(c_OUTPUT);
542: pariputs(str); if (!len || str[len-1] != '\n') pariputc('\n');
543: if (space) { linelen++; len--; }
544: term_color(c_ERR);
545: for (i=0; i<linelen; i++) pariputc(' ');
546: pariputc('^');
547: for (i=0; i<len; i++) pariputc('-');
548: }
549: else
550: pariputc('\n');
551: }
552:
553: /********************************************************************/
554: /** **/
555: /** GEN <---> CHARACTER STRINGS **/
556: /** **/
557: /********************************************************************/
558:
559: typedef struct outString {
560: char *string;
561: ulong len,size;
562: } outString;
563: static outString *OutStr, *ErrStr = NULL;
564:
565: #define STEPSIZE 1024
566: #define check_output_length(str,l) { \
567: const ulong s = str->size; \
568: if (str->len + l >= s) { \
569: ulong t = s + l + STEPSIZE; \
570: str->string = gprealloc(str->string, t, s); \
571: str->size = t; \
572: } \
573: }
574:
575: #define str_putc(str, c) { \
576: check_output_length(str,1); \
577: str->string[str->len++] = c; \
578: }
579: static void
580: outstr_putc(char c) { str_putc(OutStr, c); }
581: static void
582: errstr_putc(char c) { str_putc(ErrStr, c); }
583:
584: #define str_puts(str, s) {\
585: const long len=strlen(s); \
586: check_output_length(str,len); \
587: strcpy(str->string+str->len,s); \
588: str->len += len; \
589: }
590: static void
591: outstr_puts(char *s) { str_puts(OutStr, s); }
592: static void
593: errstr_puts(char *s) { str_puts(ErrStr, s); }
594:
595: static void
596: outstr_flush(void) { /* empty */ }
597: PariOUT pariOut2Str = {outstr_putc, outstr_puts, outstr_flush, NULL};
598: PariOUT pariErr2Str = {errstr_putc, errstr_puts, outstr_flush, NULL};
599: #undef STEPSIZE
600:
601: char *
602: pari_strdup(char *s)
603: {
604: int n = strlen(s)+1;
605: char *t = gpmalloc(n);
606: memcpy(t,s,n); return t;
607: }
608:
609: /* returns a malloc-ed string, which should be freed after usage */
610: char *
611: GENtostr0(GEN x, void(*do_out)(GEN))
612: {
613: PariOUT *tmp = pariOut;
614: outString *tmps = OutStr, newStr;
615:
616: if (typ(x) == t_STR) return pari_strdup(GSTR(x));
617: pariOut = &pariOut2Str; OutStr = &newStr;
618: OutStr->len = 0; OutStr->size=0; OutStr->string=NULL;
619: do_out(x); OutStr->string[OutStr->len] = 0;
620:
621: pariOut = tmp; OutStr = tmps; return newStr.string;
622: }
623:
624: char *
625: GENtostr(GEN x) { return GENtostr0(x,outbrute); }
626:
627: /********************************************************************/
628: /** **/
629: /** WRITE AN INTEGER **/
630: /** **/
631: /********************************************************************/
632: #define putsigne(x) pariputs((x>0)? " + " : " - ")
633: #define sp_sign_sp(x) sp(), pariputc(x>0? '+': '-'), sp()
634: #define sp_plus_sp() sp(), pariputc('+'), sp()
635: #define comma_sp() pariputc(','), sp()
636:
637: static void wr_space() {pariputc(' ');}
638: static void no_space() {}
639:
640: static void
641: blancs(long nb) { while (nb-- > 0) pariputc(' '); }
642:
643: static void
644: zeros(long nb) { while (nb-- > 0) pariputc('0'); }
645:
646: static long
647: coinit(long x)
648: {
649: char cha[10], *p = cha + 9;
650:
651: *p = 0;
652: do { *--p = x%10 + '0'; x /= 10; } while (x);
653: pariputs(p); return 9 - (p - cha);
654: }
655:
656: /* as above, printing leading 0s, return # significant digits printed */
657: static long
658: coinit2(long x)
659: {
660: char cha[10], *p = cha + 9;
661: int i = 0;
662:
663: for (*p = 0; p > cha; x /= 10) *--p = x%10 + '0';
664: while (cha[i] == '0') i++;
665: pariputs(cha); return 9 - i;
666: }
667:
668:
669: static void
670: comilieu(long x)
671: {
672: char cha[10], *p = cha + 9;
673:
674: for (*p = 0; p > cha; x /= 10) *--p = x%10 + '0';
675: pariputs(cha);
676: }
677:
678: static void
679: cofin(long x, long decim)
680: {
681: char cha[10], *p = cha + 9;
682:
683: for (; p > cha; x /= 10) *--p = x%10 + '0';
684: cha[decim] = 0; pariputs(cha);
685: }
686:
687: static long
688: nbdch(long l)
689: {
690: if (l<100000)
691: {
692: if (l<10) return 1;
693: if (l<100) return 2;
694: if (l<1000) return 3;
695: if (l<10000) return 4;
696: return 5;
697: }
698: if (l<1000000) return 6;
699: if (l<10000000) return 7;
700: if (l<100000000) return 8;
701: if (l<1000000000) return 9;
702: return 10; /* not reached */
703: }
704:
705: /* write an int. fw = field width (pad with ' ') */
706: static void
707: wr_int(GEN x, long fw, long nosign)
708: {
709: long *res,*re,i, sx=signe(x);
710:
711: if (!sx) { blancs(fw-1); pariputc('0'); return; }
712: setsigne(x,1); re = res = convi(x);
713: setsigne(x,sx);
714: i = nbdch(*--re); while (*--re >= 0) i+=9;
715: if (nosign || sx>0) blancs(fw-i);
716: else
717: { i++; blancs(fw-i); pariputc('-'); }
718: coinit(*--res); while (*--res >= 0) comilieu(*res);
719: }
720:
721: static void
722: wr_vecsmall(GEN g)
723: {
724: long i,l;
725: pariputc('['); l = lg(g);
726: for (i=1; i<l; i++)
727: {
728: pariputsf("%ld", g[i]);
729: if (i<l-1) comma_sp();
730: }
731: pariputc(']');
732: }
733: /********************************************************************/
734: /** **/
735: /** WRITE A REAL NUMBER **/
736: /** **/
737: /********************************************************************/
738: static void wr_exp(GEN x);
739:
740: /* assume x != 0 and print |x| in floating point format */
741: static void
742: wr_float(GEN x)
743: {
744: long *res, ex,s,d,e,decmax, dec = decimals;
745: GEN p1;
746:
747: if (dec>0) /* round if needed */
748: {
749: GEN arrondi = cgetr(3);
750: arrondi[1] = (long) (x[1]-((double)BITS_IN_LONG/pariK)*dec-2);
751: arrondi[2] = x[2]; x = addrr(x,arrondi);
752: }
753: ex = expo(x); e = bit_accuracy(lg(x)); /* significant bits */
754: if (ex >= e) { wr_exp(x); return; }
755: decmax = (long) (e * L2SL10); /* significant digits */
756: if ((ulong)decmax < (ulong)dec) dec = decmax; /* Hack: includes dec < 0 */
757:
758: /* integer part */
759: p1 = gcvtoi(x,&e); s = signe(p1);
760: if (e > 0) err(bugparier,"wr_float");
761: if (!s) { pariputc('0'); d=0; }
762: else
763: {
764: x = subri(x,p1); setsigne(p1,1);
765: res = convi(p1); d = coinit(*--res);
766: while (*(--res) >= 0) { d += 9; comilieu(*res); }
767: }
768: pariputc('.');
769:
770: /* fractional part: 0 < x < 1 */
771: if (!signe(x))
772: {
773: dec -= d; if (dec>0) zeros(dec);
774: return;
775: }
776:
777: res = confrac(x);
778: if (!s)
779: {
780: while (!*res) { res++; pariputs("000000000"); }
781: d = coinit2(*res++);
782: }
783:
784: /* d = # significant digits already printed */
785: dec -= d;
786: while (dec>8) { comilieu(*res++); dec -= 9; }
787: if (dec>0) cofin(*res,dec);
788: }
789:
790: /* as above in exponential format */
791: static void
792: wr_exp(GEN x)
793: {
794: GEN dix = cgetr(lg(x)+1);
795: long ex = expo(x);
796:
797: ex = (ex>=0)? (long)(ex*L2SL10): (long)(-(-ex*L2SL10)-1);
798: affsr(10,dix); if (ex) x = mulrr(x,gpuigs(dix,-ex));
799: if (absr_cmp(x, dix) >= 0) { x=divrr(x,dix); ex++; }
800: wr_float(x); sp(); pariputsf("E%ld",ex);
801: }
802:
803: /* Write real number x.
804: * format: e (exponential), f (floating point), g (as f unless x too small)
805: * if format isn't correct (one of the above) act as e.
806: * decimals: number of decimals to print (all if <0).
807: */
808: static void
809: wr_real(GEN x, long nosign)
810: {
811: long ltop, sx = signe(x), ex = expo(x);
812:
813: if (!sx) /* real 0 */
814: {
815: if (format == 'f')
816: {
817: if (decimals<0)
818: {
819: long d = 1+((-ex)>>TWOPOTBITS_IN_LONG);
820: if (d < 0) d = 0;
821: decimals=(long)(pariK*d);
822: }
823: pariputs("0."); zeros(decimals);
824: }
825: else
826: {
827: ex = (ex>=0)? (long)(ex*L2SL10): (long)(-(-ex*L2SL10)-1);
828: pariputsf("0.E%ld", ex+1);
829: }
830: return;
831: }
832: if (!nosign && sx < 0) pariputc('-'); /* print sign if needed */
833: ltop = avma;
834: if ((format == 'g' && ex>=-32) || format == 'f') wr_float(x); else wr_exp(x);
835: avma = ltop;
836: }
837:
838: void
839: ecrire(GEN x, char f, long d, long fw)
840: {
841: if (typ(x)==t_INT)
842: wr_int(x,fw,0);
843: else
844: {
845: sp = &wr_space; format = f; decimals = d;
846: wr_real(x,0);
847: }
848: }
849:
850: /********************************************************************/
851: /** **/
852: /** HEXADECIMAL OUTPUT **/
853: /** **/
854: /********************************************************************/
855:
856: static void
857: sorstring(char* b, long x)
858: {
859: #ifdef LONG_IS_64BIT
860: pariputsf(b,(ulong)x>>32,x & MAXHALFULONG);
861: #else
862: pariputsf(b,x);
863: #endif
864: }
865:
866: /* English ordinal numbers -- GN1998Apr17 */
867: static const char *ordsuff[4] = {"st","nd","rd","th"};
868:
869: const char*
870: eng_ord(long i) /* i > 0 assumed */
871: {
872: switch (i%10)
873: {
874: case 1:
875: if (i%100==11) return ordsuff[3]; /* xxx11-th */
876: return ordsuff[0]; /* xxx01-st, xxx21-st,... */
877: case 2:
878: if (i%100==12) return ordsuff[3]; /* xxx12-th */
879: return ordsuff[1]; /* xxx02-nd, xxx22-nd,... */
880: case 3:
881: if (i%100==13) return ordsuff[3]; /* xxx13-th */
882: return ordsuff[2]; /* xxx03-rd, xxx23-rd,... */
883: default:
884: return ordsuff[3]; /* xxxx4-th,... */
885: }
886: }
887:
888: static char
889: vsigne(GEN x)
890: {
891: long s = signe(x);
892: if (!s) return '0';
893: return (s > 0) ? '+' : '-';
894: }
895:
896: static void
897: voir2(GEN x, long nb, long bl)
898: {
899: long tx=typ(x),i,j,e,dx,lx=lg(x);
900:
901: if (tx == t_INT && x == gzero) { pariputs("gzero\n"); return; }
902: if (tx == t_SMALL) {
903: pariputs("[SMALL ");
904: sorstring(VOIR_STRING2,(long)x);
905: pariputs("]\n"); return;
906: }
907: sorstring(VOIR_STRING1,(ulong)x);
908:
909: pariputsf("%s(lg=%ld%s):",type_name(tx)+2,lx,isclone(x)? ",CLONE" : "");
910: sorstring(VOIR_STRING2,x[0]);
911: if (! is_recursive_t(tx)) /* t_SMALL, t_INT, t_REAL, t_STR, t_VECSMALL */
912: {
913: if (tx == t_STR)
914: pariputs("chars:");
915: else if (tx == t_INT)
916: pariputsf("(%c,lgef=%ld):", vsigne(x), lgefint(x));
917: else if (tx == t_REAL)
918: pariputsf("(%c,expo=%ld):", vsigne(x), expo(x));
919: if (nb<0) nb = (tx==t_INT)? lgefint(x): lx;
920: if (tx == t_VECSMALL) nb = lx;
921: for (i=1; i < nb; i++) sorstring(VOIR_STRING2,x[i]);
922: pariputc('\n'); return;
923: }
924:
925: if (tx == t_PADIC)
926: pariputsf("(precp=%ld,valp=%ld):", precp(x), valp(x));
927: else if (tx == t_POL)
928: pariputsf("(%c,varn=%ld,lgef=%ld):", vsigne(x), varn(x), lgef(x));
929: else if (tx == t_SER)
930: pariputsf("(%c,varn=%ld,prec=%ld,valp=%ld):",
931: vsigne(x), varn(x),lg(x)-2, valp(x));
932: else if (tx == t_LIST)
933: pariputsf("(lgef=%ld):", lgef(x));
934:
935: if (tx == t_POL || tx == t_LIST) lx = lgef(x);
936: for (i=1; i<lx; i++) sorstring(VOIR_STRING2,x[i]);
937: bl+=2; pariputc('\n');
938: switch(tx)
939: {
940: case t_INTMOD: case t_POLMOD:
941: {
942: char *s = (tx==t_INTMOD)? "int = ": "pol = ";
943: if (isonstack(x[1])) blancs(bl); else { blancs(bl-2); pariputs("* "); }
944: pariputs("mod = "); voir2((GEN)x[1],nb,bl);
945: blancs(bl); pariputs(s); voir2((GEN)x[2],nb,bl);
946: break;
947: }
948: case t_FRAC: case t_FRACN: case t_RFRAC: case t_RFRACN:
949: blancs(bl); pariputs("num = "); voir2((GEN)x[1],nb,bl);
950: blancs(bl); pariputs("den = "); voir2((GEN)x[2],nb,bl);
951: break;
952:
953: case t_COMPLEX:
954: blancs(bl); pariputs("real = "); voir2((GEN)x[1],nb,bl);
955: blancs(bl); pariputs("imag = "); voir2((GEN)x[2],nb,bl);
956: break;
957:
958: case t_PADIC:
959: if (isonstack(x[2])) blancs(bl); else { blancs(bl-2); pariputs("* "); }
960: pariputs(" p : "); voir2((GEN)x[2],nb,bl);
961: blancs(bl); pariputs("p^l : "); voir2((GEN)x[3],nb,bl);
962: blancs(bl); pariputs(" I : "); voir2((GEN)x[4],nb,bl);
963: break;
964:
965: case t_QUAD:
966: blancs(bl); pariputs("pol = "); voir2((GEN)x[1],nb,bl);
967: blancs(bl); pariputs("real = "); voir2((GEN)x[2],nb,bl);
968: blancs(bl); pariputs("imag = "); voir2((GEN)x[3],nb,bl);
969: break;
970:
971: case t_POL: case t_SER:
972: e = (tx==t_SER)? valp(x): 0;
973: for (i=2; i<lx; i++)
974: {
975: blancs(bl); pariputsf("coef of degree %ld = ",e);
976: e++; voir2((GEN)x[i],nb,bl);
977: }
978: break;
979:
980: case t_LIST: case t_QFR: case t_QFI: case t_VEC: case t_COL:
981: i = (tx==t_LIST)? 2: 1;
982: for ( ; i<lx; i++)
983: {
984: blancs(bl); pariputsf("%ld%s component = ",i,eng_ord(i));
985: voir2((GEN)x[i],nb,bl);
986: }
987: break;
988:
989: case t_MAT:
990: if (lx==1) return;
991: dx=lg((GEN)x[1]);
992: for (i=1; i<dx; i++)
993: for (j=1; j<lx; j++)
994: {
995: blancs(bl); pariputsf("mat(%ld,%ld) = ",i,j);
996: voir2(gcoeff(x,i,j),nb,bl);
997: }
998: }
999: }
1000:
1001: void
1002: voir(GEN x, long nb)
1003: {
1004: voir2(x,nb,0);
1005: }
1006:
1007: char *
1008: type_name(long t)
1009: {
1010: char *s;
1011: switch(t)
1012: {
1013: case t_SMALL : s="t_SMALL"; break;
1014: case t_INT : s="t_INT"; break;
1015: case t_REAL : s="t_REAL"; break;
1016: case t_INTMOD : s="t_INTMOD"; break;
1017: case t_FRAC : s="t_FRAC"; break;
1018: case t_FRACN : s="t_FRACN"; break;
1019: case t_COMPLEX: s="t_COMPLEX"; break;
1020: case t_PADIC : s="t_PADIC"; break;
1021: case t_QUAD : s="t_QUAD"; break;
1022: case t_POLMOD : s="t_POLMOD"; break;
1023: case t_POL : s="t_POL"; break;
1024: case t_SER : s="t_SER"; break;
1025: case t_RFRAC : s="t_RFRAC"; break;
1026: case t_RFRACN : s="t_RFRACN"; break;
1027: case t_QFR : s="t_QFR"; break;
1028: case t_QFI : s="t_QFI"; break;
1029: case t_VEC : s="t_VEC"; break;
1030: case t_COL : s="t_COL"; break;
1031: case t_MAT : s="t_MAT"; break;
1032: case t_LIST : s="t_LIST"; break;
1033: case t_STR : s="t_STR"; break;
1034: case t_VECSMALL:s="t_VECSMALL";break;
1035: default: err(talker,"unknown type %ld",t);
1036: s = NULL; /* not reached */
1037: }
1038: return s;
1039: }
1040:
1041: /********************************************************************/
1042: /** **/
1043: /** FORMATTED OUTPUT **/
1044: /** **/
1045: /********************************************************************/
1046: static char *
1047: get_var(long v, char *buf)
1048: {
1049: entree *ep = varentries[v];
1050:
1051: if (ep) return ep->name;
1052: if (v==MAXVARN) return "#";
1053: sprintf(buf,"#<%d>",(int)v); return buf;
1054: }
1055:
1056: static char *
1057: get_texvar(long v, char *buf)
1058: {
1059: entree *ep = varentries[v];
1060: char *s, *t = buf;
1061:
1062: if (!ep) err(talker, "this object uses debugging variables");
1063: s = ep->name;
1064: if (strlen(s)>=64) err(talker, "TeX variable name too long");
1065: while(isalpha((int)*s)) *t++ = *s++;
1066: *t = 0; if (isdigit((int)*s) || *s++ == '_') sprintf(t,"_{%s}",s);
1067: return buf;
1068: }
1069:
1070: static void
1071: monome(char *v, long deg)
1072: {
1073: if (deg)
1074: {
1075: pariputs(v);
1076: if (deg!=1) pariputsf("^%ld",deg);
1077: }
1078: else pariputc('1');
1079: }
1080:
1081: static void
1082: texnome(char *v, long deg)
1083: {
1084: if (deg)
1085: {
1086: pariputs(v);
1087: if (deg!=1) pariputsf("^{%ld}",deg);
1088: }
1089: else pariputc('1');
1090: }
1091:
1092: #define padic_nome(p,e) {pariputs(p); if (e != 1) pariputsf("^%ld",e);}
1093: #define padic_texnome(p,e) {pariputs(p); if (e != 1) pariputsf("^{%ld}",e);}
1094:
1095: void
1096: etatpile(unsigned int n)
1097: {
1098: long av=avma,nu,i,l,m;
1099: GEN adr,adr1;
1100: double r;
1101:
1102: nu = (top-avma)/BYTES_IN_LONG;
1103: l = (top-bot)/BYTES_IN_LONG;
1104: r = 100.0*nu/l;
1105: pariputsf("\n Top : %lx Bottom : %lx Current stack : %lx\n",
1106: top, bot, avma);
1107:
1108: pariputsf(" Used : %ld long words (%ld K)\n",
1109: nu, nu/1024*BYTES_IN_LONG);
1110:
1111: pariputsf(" Available : %ld long words (%ld K)\n",
1112: (l-nu), (l-nu)/1024*BYTES_IN_LONG);
1113:
1114: pariputsf(" Occupation of the PARI stack : %6.2f percent\n",r);
1115:
1116: adr=getheap();
1117: pariputsf(" %ld objects on heap occupy %ld long words\n\n",
1118: itos((GEN)adr[1]), itos((GEN)adr[2]));
1119: avma=av;
1120:
1121: pariputsf(" %ld variable names used out of %d\n\n",manage_var(3,NULL),MAXVARN);
1122: if (!n) return;
1123:
1124: if (n > (ulong)nu) n = nu;
1125: adr = (GEN)avma; adr1 = adr+n;
1126: while (adr<adr1)
1127: {
1128: sorstring(VOIR_STRING3,(ulong)adr);
1129: l=lg(adr); m = (adr==polvar) ? MAXVARN : 0;
1130: for (i=0; i<l && adr<adr1; i++,adr++) sorstring(VOIR_STRING2,*adr);
1131: pariputc('\n'); adr=polvar+m;
1132: }
1133: pariputc('\n');
1134: }
1135:
1136: /********************************************************************/
1137: /** **/
1138: /** RAW OUTPUT **/
1139: /** **/
1140: /********************************************************************/
1141: #define isnull_for_pol(g) ((typ(g)==t_INTMOD)? !signe(g[2]): isnull(g))
1142:
1143: /* is to be printed as '0' */
1144: static long
1145: isnull(GEN g)
1146: {
1147: long i;
1148: switch (typ(g))
1149: {
1150: case t_SMALL:
1151: return !smalltos(g);
1152: case t_INT:
1153: return !signe(g);
1154: case t_COMPLEX:
1155: return isnull((GEN)g[1]) && isnull((GEN)g[2]);
1156: case t_QUAD:
1157: return isnull((GEN)g[2]) && isnull((GEN)g[3]);
1158: case t_FRAC: case t_FRACN: case t_RFRAC: case t_RFRACN:
1159: return isnull((GEN)g[1]);
1160: case t_POLMOD:
1161: return isnull((GEN)g[2]);
1162: case t_POL:
1163: for (i=lgef(g)-1; i>1; i--)
1164: if (!isnull((GEN)g[i])) return 0;
1165: return 1;
1166: }
1167: return 0;
1168: }
1169:
1170: /* return 1 or -1 if g is 1 or -1, 0 otherwise*/
1171: static long
1172: isone(GEN g)
1173: {
1174: long i;
1175: switch (typ(g))
1176: {
1177: case t_SMALL:
1178: switch(smalltos(g))
1179: {
1180: case 1: return 1;
1181: case -1: return -1;
1182: }
1183: break;
1184: case t_INT:
1185: return (signe(g) && is_pm1(g))? signe(g): 0;
1186: case t_COMPLEX:
1187: return isnull((GEN)g[2])? isone((GEN)g[1]): 0;
1188: case t_QUAD:
1189: return isnull((GEN)g[3])? isone((GEN)g[2]): 0;
1190: case t_FRAC: case t_FRACN: case t_RFRAC: case t_RFRACN:
1191: return isone((GEN)g[1]) * isone((GEN)g[2]);
1192: case t_POL:
1193: if (!signe(g)) return 0;
1194: for (i=lgef(g)-1; i>2; i--)
1195: if (!isnull((GEN)g[i])) return 0;
1196: return isone((GEN)g[2]);
1197: }
1198: return 0;
1199: }
1200:
1201: /* if g is a "monomial", return its sign, 0 otherwise */
1202: static long
1203: isfactor(GEN g)
1204: {
1205: long i,deja,sig;
1206: switch(typ(g))
1207: {
1208: case t_INT: case t_REAL:
1209: return (signe(g)<0)? -1: 1;
1210: case t_FRAC: case t_FRACN: case t_RFRAC: case t_RFRACN:
1211: return isfactor((GEN)g[1]);
1212: case t_COMPLEX:
1213: if (isnull((GEN)g[1])) return isfactor((GEN)g[2]);
1214: if (isnull((GEN)g[2])) return isfactor((GEN)g[1]);
1215: return 0;
1216: case t_PADIC:
1217: return !signe((GEN)g[4]);
1218: case t_QUAD:
1219: if (isnull((GEN)g[2])) return isfactor((GEN)g[3]);
1220: if (isnull((GEN)g[3])) return isfactor((GEN)g[2]);
1221: return 0;
1222: case t_POL: deja = 0; sig = 1;
1223: for (i=lgef(g)-1; i>1; i--)
1224: if (!isnull((GEN)g[i]))
1225: {
1226: if (deja) return 0;
1227: sig=isfactor((GEN)g[i]); deja=1;
1228: }
1229: return sig? sig: 1;
1230: case t_SER:
1231: for (i=lg(g)-1; i>1; i--)
1232: if (!isnull((GEN)g[i])) return 0;
1233: }
1234: return 1;
1235: }
1236:
1237: /* return 1 if g is a "truc" (see anal.c) */
1238: static long
1239: isdenom(GEN g)
1240: {
1241: long i,deja;
1242: switch(typ(g))
1243: {
1244: case t_FRAC: case t_FRACN: case t_RFRAC: case t_RFRACN:
1245: return 0;
1246: case t_COMPLEX: return isnull((GEN)g[2]);
1247: case t_PADIC: return !signe((GEN)g[4]);
1248: case t_QUAD: return isnull((GEN)g[3]);
1249:
1250: case t_POL: deja = 0;
1251: for (i=lgef(g)-1; i>1; i--)
1252: if (!isnull((GEN)g[i]))
1253: {
1254: if (deja) return 0;
1255: if (i==2) return isdenom((GEN)g[2]);
1256: if (!isone((GEN)g[i])) return 0;
1257: deja=1;
1258: }
1259: return 1;
1260: case t_SER:
1261: for (i=lg(g)-1; i>1; i--)
1262: if (!isnull((GEN)g[i])) return 0;
1263: }
1264: return 1;
1265: }
1266:
1267: /* write a * v^d */
1268: static void
1269: wr_monome(GEN a, char *v, long d)
1270: {
1271: long sig = isone(a);
1272:
1273: if (sig) { sp_sign_sp(sig); monome(v,d); }
1274: else
1275: {
1276: sig = isfactor(a);
1277: if (sig) { sp_sign_sp(sig); bruti(a,sig); }
1278: else
1279: {
1280: sp_plus_sp(); pariputc('('); bruti(a,sig); pariputc(')');
1281: }
1282: if (d) { pariputc('*'); monome(v,d); }
1283: }
1284: }
1285:
1286: static void
1287: wr_texnome(GEN a, char *v, long d)
1288: {
1289: long sig = isone(a);
1290:
1291: if (sig) { putsigne(sig); texnome(v,d); }
1292: else
1293: {
1294: sig = isfactor(a);
1295: if (sig) { putsigne(sig); texi(a,sig); }
1296: else
1297: {
1298: pariputs(" + \\left("); texi(a,sig); pariputs("\\right) ");
1299: }
1300: if (d)
1301: {
1302: if (under_texmacs) pariputs("\\*");
1303: texnome(v,d);
1304: }
1305: }
1306: }
1307:
1308: static void
1309: wr_lead_monome(GEN a, char *v, long d, long nosign)
1310: {
1311: long sig = isone(a);
1312: if (sig)
1313: {
1314: if (!nosign && sig<0) pariputc('-');
1315: monome(v,d);
1316: }
1317: else
1318: {
1319: if (isfactor(a)) bruti(a,nosign);
1320: else
1321: {
1322: pariputc('('); bruti(a,0); pariputc(')');
1323: }
1324: if (d) { pariputc('*'); monome(v,d); }
1325: }
1326: }
1327:
1328: static void
1329: wr_lead_texnome(GEN a, char *v, long d, long nosign)
1330: {
1331: long sig = isone(a);
1332: if (sig)
1333: {
1334: if (!nosign && sig<0) pariputc('-');
1335: texnome(v,d);
1336: }
1337: else
1338: {
1339: if (isfactor(a)) texi(a,nosign);
1340: else
1341: {
1342: pariputs(" \\left("); texi(a,0); pariputs("\\right) ");
1343: }
1344: if (d)
1345: {
1346: if (under_texmacs) pariputs("\\*");
1347: texnome(v,d);
1348: }
1349: }
1350: }
1351:
1352: static void
1353: bruti(GEN g, long nosign)
1354: {
1355: long tg,l,i,j,r;
1356: GEN a,b;
1357: char *v, buf[32];
1358:
1359: if (!g) { pariputs("NULL"); return; }
1360: if (isnull(g)) { pariputc('0'); return; }
1361: r = isone(g);
1362: if (r)
1363: {
1364: if (!nosign && r<0) pariputc('-');
1365: pariputc('1'); return;
1366: }
1367:
1368: tg = typ(g);
1369: switch(tg)
1370: {
1371: case t_SMALL: pariputsf("%ld",smalltos(g)); break;
1372: case t_INT: wr_int(g,0,nosign); break;
1373: case t_REAL: wr_real(g,nosign); break;
1374:
1375: case t_INTMOD: case t_POLMOD:
1376: pariputs(new_fun_set? "Mod(": "mod(");
1377: bruti((GEN)g[2],0); comma_sp();
1378: bruti((GEN)g[1],0); pariputc(')'); break;
1379:
1380: case t_FRAC: case t_FRACN: case t_RFRAC: case t_RFRACN:
1381: r = isfactor((GEN)g[1]); if (!r) pariputc('(');
1382: bruti((GEN)g[1],nosign);
1383: if (!r) pariputc(')');
1384: pariputc('/');
1385: r = isdenom((GEN)g[2]); if (!r) pariputc('(');
1386: bruti((GEN)g[2],0);
1387: if (!r) pariputc(')');
1388: break;
1389:
1390: case t_COMPLEX: case t_QUAD: r = (tg==t_QUAD);
1391: a = (GEN)g[r+1]; b = (GEN)g[r+2]; v = r? "w": "I";
1392: if (isnull(a))
1393: {
1394: wr_lead_monome(b,v,1,nosign);
1395: return;
1396: }
1397: bruti(a,nosign);
1398: if (!isnull(b)) wr_monome(b,v,1);
1399: break;
1400:
1401: case t_POL: v = get_var(ordvar[varn(g)], buf);
1402: /* hack: we want g[i] = coeff of degree i. */
1403: i = degpol(g); g += 2; while (isnull((GEN)g[i])) i--;
1404: wr_lead_monome((GEN)g[i],v,i,nosign);
1405: while (i--)
1406: {
1407: a = (GEN)g[i];
1408: if (!isnull_for_pol(a)) wr_monome(a,v,i);
1409: }
1410: break;
1411:
1412: case t_SER: v = get_var(ordvar[varn(g)], buf);
1413: i = valp(g);
1414: if (signe(g))
1415: { /* hack: we want g[i] = coeff of degree i. */
1416: l = i + lg(g)-2; g += (2-i);
1417: wr_lead_monome((GEN)g[i],v,i,nosign);
1418: while (++i < l)
1419: {
1420: a = (GEN)g[i];
1421: if (!isnull_for_pol(a)) wr_monome(a,v,i);
1422: }
1423: sp_plus_sp();
1424: }
1425: pariputs("O("); monome(v,i); pariputc(')'); break;
1426:
1427: case t_PADIC:
1428: {
1429: GEN p = (GEN)g[2];
1430: i = valp(g); l = precp(g)+i;
1431: g = (GEN)g[4]; v = GENtostr(p);
1432: for (; i<l; i++)
1433: {
1434: g = dvmdii(g,p,&a);
1435: if (signe(a))
1436: {
1437: if (!i || !is_pm1(a))
1438: {
1439: wr_int(a,0,1); if (i) pariputc('*');
1440: }
1441: if (i) padic_nome(v,i);
1442: sp_plus_sp();
1443: }
1444: }
1445: pariputs("O("); padic_nome(v,i); pariputc(')');
1446: free(v); break;
1447: }
1448:
1449: case t_QFR: case t_QFI: r = (tg == t_QFR);
1450: if (new_fun_set) pariputs("Qfb("); else pariputs(r? "qfr(": "qfi(");
1451: bruti((GEN)g[1],0); comma_sp();
1452: bruti((GEN)g[2],0); comma_sp();
1453: bruti((GEN)g[3],0);
1454: if (r) { comma_sp(); bruti((GEN)g[4],0); }
1455: pariputc(')'); break;
1456:
1457: case t_VEC: case t_COL:
1458: pariputc('['); l = lg(g);
1459: for (i=1; i<l; i++)
1460: {
1461: bruti((GEN)g[i],0);
1462: if (i<l-1) comma_sp();
1463: }
1464: pariputc(']'); if (tg==t_COL) pariputc('~');
1465: break;
1466: case t_VECSMALL: wr_vecsmall(g); break;
1467:
1468: case t_LIST:
1469: pariputs("List(["); l = lgef(g);
1470: for (i=2; i<l; i++)
1471: {
1472: bruti((GEN)g[i],0);
1473: if (i<l-1) comma_sp();
1474: }
1475: pariputs("])"); break;
1476:
1477: case t_STR:
1478: pariputc('"'); pariputs(GSTR(g)); pariputc('"');
1479: return;
1480:
1481: case t_MAT:
1482: r = lg(g); if (r==1) { pariputs("[;]"); return; }
1483: l = lg(g[1]);
1484: if (l==1)
1485: {
1486: pariputsf(new_fun_set? "matrix(0,%ld)":"matrix(0,%ld,j,k,0)", r-1);
1487: return;
1488: }
1489: if (l==2)
1490: {
1491: pariputs(new_fun_set? "Mat(": "mat(");
1492: if (r == 2) { bruti(gcoeff(g,1,1),0); pariputc(')'); return; }
1493: }
1494: pariputc('[');
1495: for (i=1; i<l; i++)
1496: {
1497: for (j=1; j<r; j++)
1498: {
1499: bruti(gcoeff(g,i,j),0);
1500: if (j<r-1) comma_sp();
1501: }
1502: if (i<l-1) { pariputc(';'); sp(); }
1503: }
1504: pariputc(']'); if (l==2) pariputc(')');
1505: break;
1506:
1507: default: sorstring(VOIR_STRING2,*g);
1508: }
1509: }
1510:
1511: static void
1512: matbruti(GEN g, long flag)
1513: {
1514: long i,j,r,l;
1515:
1516: if (typ(g) != t_MAT) { bruti(g,flag); return; }
1517:
1518: r=lg(g); if (r==1 || lg(g[1])==1) { pariputs("[;]\n"); return; }
1519: pariputc('\n'); l = lg(g[1]);
1520: for (i=1; i<l; i++)
1521: {
1522: pariputc('[');
1523: for (j=1; j<r; j++)
1524: {
1525: bruti(gcoeff(g,i,j),0); if (j<r-1) pariputc(' ');
1526: }
1527: if (i<l-1) pariputs("]\n\n"); else pariputs("]\n");
1528: }
1529: }
1530:
1531: static void
1532: sor_monome(GEN a, char *v, long d)
1533: {
1534: long sig = isone(a);
1535: if (sig) { putsigne(sig); monome(v,d); }
1536: else
1537: {
1538: sig = isfactor(a);
1539: if (sig) { putsigne(sig); if (sig < 0) a = gneg(a); }
1540: else pariputs(" + ");
1541: sori(a); if (d) { pariputc(' '); monome(v,d);}
1542: }
1543: }
1544:
1545: static void
1546: sor_lead_monome(GEN a, char *v, long d)
1547: {
1548: long sig = isone(a);
1549: if (sig)
1550: {
1551: if (sig < 0) pariputc('-');
1552: monome(v,d);
1553: }
1554: else
1555: {
1556: sori(a);
1557: if (d) { pariputc(' '); monome(v,d); }
1558: }
1559: }
1560:
1561: static void
1562: sori(GEN g)
1563: {
1564: long tg=typ(g), i,j,r,l,close_paren;
1565: GEN a,b;
1566: char *v, buf[32];
1567:
1568: switch (tg)
1569: {
1570: case t_SMALL: pariputsf("%ld",smalltos(g)); return;
1571: case t_INT: wr_int(g,chmp,0); return;
1572: case t_REAL: wr_real(g,0); return;
1573: case t_STR:
1574: pariputc('"'); pariputs(GSTR(g)); pariputc('"'); return;
1575: case t_LIST:
1576: chmp=0; pariputs("List(");
1577: for (i=2; i<lgef(g); i++)
1578: {
1579: sori((GEN)g[i]); if (i<lgef(g)-1) pariputs(", ");
1580: }
1581: pariputs(")\n"); return;
1582: }
1583: close_paren=0;
1584: if (!is_matvec_t(tg)) chmp = 0;
1585: if (!is_graphicvec_t(tg))
1586: {
1587: if (is_frac_t(tg) && gsigne(g) < 0) pariputc('-');
1588: if (! is_rfrac_t(tg)) { pariputc('('); close_paren=1; }
1589: }
1590: switch(tg)
1591: {
1592: case t_INTMOD: case t_POLMOD:
1593: a = (GEN)g[2]; b = (GEN)g[1];
1594: if (tg == t_INTMOD && signe(a) < 0) a = addii(a,b);
1595: sori(a); pariputs(" mod "); sori(b); break;
1596:
1597: case t_FRAC: case t_FRACN:
1598: a=(GEN)g[1]; wr_int(a,chmp,1); pariputs(" /");
1599: b=(GEN)g[2]; wr_int(b,chmp,1); break;
1600:
1601: case t_COMPLEX: case t_QUAD: r = (tg==t_QUAD);
1602: a = (GEN)g[r+1]; b = (GEN)g[r+2]; v = r? "w": "I";
1603: if (isnull(a)) { sor_lead_monome(b,v,1); break; }
1604: sori(a); if (!isnull(b)) sor_monome(b,v,1);
1605: break;
1606:
1607: case t_PADIC:
1608: {
1609: GEN p = (GEN)g[2];
1610: i = valp(g); l = precp(g)+i;
1611: g = (GEN)g[4]; v = GENtostr(p);
1612: for (; i<l; i++)
1613: {
1614: g = dvmdii(g,p,&a);
1615: if (signe(a))
1616: {
1617: if (!i || !is_pm1(a))
1618: {
1619: wr_int(a,chmp,1); pariputc(i? '*': ' ');
1620: }
1621: if (i) { padic_nome(v,i); pariputc(' '); }
1622: pariputs("+ ");
1623: }
1624: }
1625: pariputs("O(");
1626: if (!i) pariputs(" 1)"); else padic_nome(v,i);
1627: pariputc(')'); free(v); break;
1628: }
1629:
1630: case t_POL:
1631: if (!signe(g)) { pariputc('0'); break; }
1632: v = get_var(ordvar[varn(g)],buf);
1633: i = degpol(g); g += 2; while (isnull((GEN)g[i])) i--;
1634: sor_lead_monome((GEN)g[i],v,i);
1635: while (i--)
1636: {
1637: a = (GEN)g[i]; if (!isnull_for_pol(a)) sor_monome(a,v,i);
1638: }
1639: break;
1640:
1641: case t_SER: v = get_var(ordvar[varn(g)],buf);
1642: i = valp(g);
1643: if (signe(g))
1644: { /* hack: we want g[i] = coeff of degree i. */
1645: l = i + lg(g)-2; g += (2-i);
1646: sor_lead_monome((GEN)g[i],v,i);
1647: while (++i < l)
1648: {
1649: a = (GEN)g[i]; if (!isnull_for_pol(a)) sor_monome(a,v,i);
1650: }
1651: pariputs(" + ");
1652: }
1653: pariputs("O(");
1654: if (!i) pariputs(" 1)"); else monome(v,i);
1655: pariputc(')'); break;
1656:
1657: case t_RFRAC: case t_RFRACN:
1658: if (initial)
1659: {
1660: char *v1, *v2;
1661: long sd = 0, sn = 0, d,n;
1662: long wd = term_width();
1663:
1664: initial = 0;
1665: v1 = GENtostr0((GEN)g[1], &sori); n = strlen(v1);
1666: v2 = GENtostr0((GEN)g[2], &sori); d = strlen(v2);
1667:
1668: pariputc('\n');
1669: i = max(n,d)+2;
1670: if (i > wd)
1671: {
1672: pariputs(v1); pariputs("\n\n");
1673: for (j=0; j<wd; j++) pariputc('-');
1674: pariputs("\n\n");
1675: pariputs(v2);
1676: pariputc('\n'); return;
1677: }
1678: if (n < d) sn = (d-n) >> 1; else sd = (n-d) >> 1;
1679: blancs(sn+1); pariputs(v1);
1680: pariputs("\n\n"); for (j=0; j<i; j++) pariputc('-');
1681: pariputs("\n\n");
1682: blancs(sd+1); pariputs(v2);
1683: pariputc('\n'); return;
1684: }
1685: pariputc('('); sori((GEN)g[1]); pariputs(" / "); sori((GEN)g[2]);
1686: pariputc(')'); return;
1687:
1688: case t_QFR: case t_QFI: pariputc('{');
1689: sori((GEN)g[1]); pariputs(", ");
1690: sori((GEN)g[2]); pariputs(", ");
1691: sori((GEN)g[3]);
1692: if (tg == t_QFR) { pariputs(", "); sori((GEN)g[4]); }
1693: pariputs("}\n"); break;
1694:
1695: case t_VEC:
1696: chmp=0; pariputc('[');
1697: for (i=1; i<lg(g); i++)
1698: {
1699: sori((GEN)g[i]); if (i<lg(g)-1) pariputs(", ");
1700: }
1701: pariputc(']'); break;
1702: case t_VECSMALL: wr_vecsmall(g); break;
1703:
1704: case t_COL:
1705: if (lg(g)==1) { pariputs("[]\n"); return; }
1706: pariputc('\n');
1707: for (i=1; i<lg(g); i++)
1708: {
1709: pariputc('['); sori((GEN)g[i]); pariputs("]\n");
1710: }
1711: break;
1712:
1713: case t_MAT:
1714: {
1715: long lx = lg(g);
1716:
1717: if (lx==1) { pariputs("[;]\n"); return; }
1718: pariputc('\n'); l=lg((GEN)g[1]);
1719: for (i=1; i<l; i++)
1720: {
1721: pariputc('[');
1722: for (j=1; j<lx; j++)
1723: {
1724: sori(gcoeff(g,i,j)); if (j<lx-1) pariputc(' ');
1725: }
1726: pariputs("]\n"); if (i<l-1) pariputc('\n');
1727: }
1728: break;
1729: }
1730: default: sorstring(VOIR_STRING2,*g);
1731: }
1732: if (close_paren) pariputc(')');
1733: }
1734:
1735: /********************************************************************/
1736: /** **/
1737: /** TeX OUTPUT **/
1738: /** **/
1739: /********************************************************************/
1740:
1741: /* this follows bruti exactly */
1742: static void
1743: texi(GEN g, long nosign)
1744: {
1745: long tg,i,j,l,r;
1746: GEN a,b;
1747: char *v, buf[67];
1748:
1749: if (isnull(g)) { pariputs("{0}"); return; }
1750: r = isone(g); pariputc('{');
1751: if (r)
1752: {
1753: if (!nosign && r<0) pariputc('-');
1754: pariputs("1}"); return;
1755: }
1756:
1757: tg = typ(g);
1758: switch(tg)
1759: {
1760: case t_INT: wr_int(g,0,nosign); break;
1761: case t_REAL: wr_real(g,nosign); break;
1762:
1763: case t_INTMOD: case t_POLMOD:
1764: texi((GEN)g[2],0); pariputs(" mod ");
1765: texi((GEN)g[1],0); break;
1766:
1767: case t_FRAC: case t_FRACN: case t_RFRAC: case t_RFRACN:
1768: texi((GEN)g[1],nosign); pariputs("\\over");
1769: texi((GEN)g[2],0); break;
1770:
1771: case t_COMPLEX: case t_QUAD: r = (tg==t_QUAD);
1772: a = (GEN)g[r+1]; b = (GEN)g[r+2]; v = r? "w": "I";
1773: if (isnull(a))
1774: {
1775: wr_lead_texnome(b,v,1,nosign);
1776: break;
1777: }
1778: texi(a,nosign);
1779: if (!isnull(b)) wr_texnome(b,v,1);
1780: break;
1781:
1782: case t_POL: v = get_texvar(ordvar[varn(g)],buf);
1783: /* hack: we want g[i] = coeff of degree i. */
1784: i = degpol(g); g += 2; while (isnull((GEN)g[i])) i--;
1785: wr_lead_texnome((GEN)g[i],v,i,nosign);
1786: while (i--)
1787: {
1788: a = (GEN)g[i];
1789: if (!isnull_for_pol(a)) wr_texnome(a,v,i);
1790: }
1791: break;
1792:
1793: case t_SER: v = get_texvar(ordvar[varn(g)],buf);
1794: i = valp(g);
1795: if (signe(g))
1796: { /* hack: we want g[i] = coeff of degree i. */
1797: l = i + lg(g)-2; g += (2-i);
1798: wr_lead_texnome((GEN)g[i],v,i,nosign);
1799: while (++i < l)
1800: {
1801: a = (GEN)g[i];
1802: if (!isnull_for_pol(a)) wr_texnome(a,v,i);
1803: }
1804: pariputs("+ ");
1805: }
1806: pariputs("O("); texnome(v,i); pariputc(')'); break;
1807:
1808: case t_PADIC:
1809: {
1810: GEN p = (GEN)g[2];
1811: i = valp(g); l = precp(g)+i;
1812: g = (GEN)g[4]; v = GENtostr(p);
1813: for (; i<l; i++)
1814: {
1815: g = dvmdii(g,p,&a);
1816: if (signe(a))
1817: {
1818: if (!i || !is_pm1(a))
1819: {
1820: wr_int(a,0,1); if (i) pariputs("\\cdot");
1821: }
1822: if (i) padic_texnome(v,i);
1823: pariputc('+');
1824: }
1825: }
1826: pariputs("O("); padic_texnome(v,i); pariputc(')');
1827: free(v); break;
1828: }
1829: case t_QFR: case t_QFI: r = (tg == t_QFR);
1830: if (new_fun_set) pariputs("Qfb("); else pariputs(r? "qfr(": "qfi(");
1831: texi((GEN)g[1],0); pariputs(", ");
1832: texi((GEN)g[2],0); pariputs(", ");
1833: texi((GEN)g[3],0);
1834: if (r) { pariputs(", "); texi((GEN)g[4],0); }
1835: pariputc(')'); break;
1836:
1837: case t_VEC:
1838: pariputs("\\pmatrix{ "); l = lg(g);
1839: for (i=1; i<l; i++)
1840: {
1841: texi((GEN)g[i],0); if (i<lg(g)-1) pariputc('&');
1842: }
1843: pariputs("\\cr}\n"); break;
1844:
1845: case t_LIST:
1846: pariputs("\\pmatrix{ "); l = lgef(g);
1847: for (i=2; i<l; i++)
1848: {
1849: texi((GEN)g[i],0); if (i<lgef(g)-1) pariputc('&');
1850: }
1851: pariputs("\\cr}\n"); break;
1852:
1853: case t_COL:
1854: pariputs("\\pmatrix{ "); l = lg(g);
1855: for (i=1; i<l; i++)
1856: {
1857: texi((GEN)g[i],0); pariputs("\\cr\n");
1858: }
1859: pariputc('}'); break;
1860:
1861: case t_STR:
1862: pariputs("\\mbox{"); pariputs(GSTR(g));
1863: pariputc('}'); break;
1864:
1865: case t_MAT:
1866: pariputs("\\pmatrix{\n "); r = lg(g);
1867: if (r>1)
1868: {
1869: l = lg(g[1]);
1870: for (i=1; i<l; i++)
1871: {
1872: for (j=1; j<r; j++)
1873: {
1874: texi(gcoeff(g,i,j),0); if (j<r-1) pariputc('&');
1875: }
1876: pariputs("\\cr\n ");
1877: }
1878: }
1879: pariputc('}'); break;
1880: }
1881: pariputc('}');
1882: }
1883:
1884: /*******************************************************************/
1885: /** **/
1886: /** USER OUTPUT FUNCTIONS **/
1887: /** **/
1888: /*******************************************************************/
1889:
1890: void
1891: bruteall(GEN g, char f, long d, long flag)
1892: {
1893: long av = avma;
1894: void (*oldsp)() = sp;
1895:
1896: sp = flag? &wr_space: &no_space;
1897: format = f; decimals = d;
1898: bruti(changevar(g,polvar),0);
1899: sp = oldsp; avma = av;
1900: }
1901:
1902: void
1903: matbrute(GEN g, char f, long d)
1904: {
1905: long av=avma; sp = &wr_space;
1906: format = f; decimals = d;
1907: matbruti(changevar(g,polvar),0); avma=av;
1908: }
1909:
1910: void
1911: sor(GEN g, char f, long d, long c)
1912: {
1913: long av=avma; sp = &wr_space;
1914: format = f; decimals = d; chmp = c; initial = 1;
1915: sori(changevar(g,polvar)); avma = av;
1916: }
1917:
1918: void
1919: texe(GEN g, char f, long d)
1920: {
1921: long av=avma; sp = &no_space;
1922: format = f; decimals = d;
1923: texi(changevar(g,polvar),0); avma=av;
1924: }
1925:
1926: void
1927: brute(GEN g, char format, long decimals) { bruteall(g,format,decimals,1); }
1928:
1929: void
1930: outbrute(GEN g) { bruteall(g,'g',-1,1); }
1931:
1932: void
1933: outsor(GEN g) { sor(g,'g',-1,1); }
1934:
1935: void
1936: outtex(GEN g) { texe(g,'g',-1); }
1937:
1938: void
1939: output(GEN x)
1940: {
1941: outbrute(x); pariputc('\n'); pariflush();
1942: }
1943:
1944: void
1945: outmat(GEN x)
1946: {
1947: matbrute(x,'g',-1); pariputc('\n'); pariflush();
1948: }
1949:
1950: void
1951: outbeaut(GEN x)
1952: {
1953: outsor(x); pariputc('\n'); pariflush();
1954: }
1955:
1956: void
1957: outerr(GEN x)
1958: {
1959: PariOUT *out = pariOut; pariOut = pariErr;
1960: output(x); pariOut = out;
1961: }
1962:
1963: void
1964: outbeauterr(GEN x)
1965: {
1966: PariOUT *out = pariOut; pariOut = pariErr;
1967: outbeaut(x); pariOut = out;
1968: }
1969:
1970: void
1971: bruterr(GEN x,char format,long decimals)
1972: {
1973: PariOUT *out = pariOut; pariOut = pariErr;
1974: bruteall(x,format,decimals,1); pariOut = out;
1975: }
1976:
1977: void
1978: fprintferr(char* format, ...)
1979: {
1980: va_list args;
1981: PariOUT *out = pariOut; pariOut = pariErr;
1982:
1983: va_start(args, format); vpariputs(format,args);
1984: va_end(args); pariOut = out;
1985: }
1986:
1987: /*******************************************************************/
1988: /** FILES **/
1989: /*******************************************************************/
1990: /* stack of temporary files (includes all infiles + some output) */
1991: static pariFILE *last_tmp_file = NULL;
1992: /* stack of "permanent" (output) files */
1993: static pariFILE *last_file = NULL;
1994: #if defined(UNIX) || defined(__EMX__)
1995: # include <fcntl.h>
1996: # include <sys/stat.h>
1997: # include <pwd.h>
1998: # ifdef __EMX__
1999: # include <process.h>
2000: # endif
2001: # define HAVE_PIPES
2002: #endif
2003: #ifndef O_RDONLY
2004: # define O_RDONLY 0
2005: #endif
2006:
2007: pariFILE *
2008: newfile(FILE *f, char *name, int type)
2009: {
2010: pariFILE *file = (pariFILE*) gpmalloc(strlen(name) + 1 + sizeof(pariFILE));
2011: file->type = type;
2012: file->name = strcpy((char*)(file+1), name);
2013: file->file = f;
2014: file->next = NULL;
2015: if (type & mf_PERM)
2016: {
2017: file->prev = last_file;
2018: last_file = file;
2019: }
2020: else
2021: {
2022: file->prev = last_tmp_file;
2023: last_tmp_file = file;
2024: }
2025: if (file->prev) (file->prev)->next = file;
2026: if (DEBUGFILES)
2027: fprintferr("I/O: opening file %s (code %d) \n",name,type);
2028: return file;
2029: }
2030:
2031: static void
2032: pari_kill_file(pariFILE *f)
2033: {
2034: if ((f->type & mf_PIPE) == 0)
2035: {
2036: if (fclose(f->file)) err(warnfile, "close", f->name);
2037: }
2038: #ifdef HAVE_PIPES
2039: else
2040: {
2041: if (f->type & mf_FALSE)
2042: {
2043: if (fclose(f->file)) err(warnfile, "close", f->name);
2044: if (unlink(f->name)) err(warnfile, "delete", f->name);
2045: }
2046: else
2047: if (pclose(f->file) < 0) err(warnfile, "close pipe", f->name);
2048: }
2049: #endif
2050: if (DEBUGFILES)
2051: fprintferr("I/O: closing file %s (code %d) \n",f->name,f->type);
2052: free(f);
2053: }
2054:
2055: void
2056: pari_fclose(pariFILE *f)
2057: {
2058: if (f->next) (f->next)->prev = f->prev;
2059: else if (f == last_tmp_file) last_tmp_file = f->prev;
2060: else if (f == last_file) last_file = f->prev;
2061: if (f->prev) (f->prev)->next = f->next;
2062: pari_kill_file(f);
2063: }
2064:
2065: static pariFILE *
2066: pari_open_file(FILE *f, char *s, char *mode)
2067: {
2068: if (!f) err(talker, "could not open requested file %s", s);
2069: if (DEBUGFILES)
2070: fprintferr("I/O: opening file %s (mode %s)\n", s, mode);
2071: return newfile(f,s,0);
2072: }
2073:
2074: pariFILE *
2075: pari_fopen(char *s, char *mode)
2076: {
2077: return pari_open_file(fopen(s, mode), s, mode);
2078: }
2079:
2080: #ifdef UNIX
2081: /* open tmpfile s (a priori for writing) avoiding symlink attacks */
2082: pariFILE *
2083: pari_safefopen(char *s, char *mode)
2084: {
2085: long fd = open(s, O_CREAT|O_EXCL|O_RDWR, S_IRUSR|S_IWUSR);
2086:
2087: if (fd == -1) err(talker,"tempfile %s already exists",s);
2088: return pari_open_file(fdopen(fd, mode), s, mode);
2089: }
2090: #else
2091: pariFILE *
2092: pari_safefopen(char *s, char *mode)
2093: {
2094: return pari_fopen(s, mode);
2095: }
2096: #endif
2097:
2098: void
2099: pari_unlink(char *s)
2100: {
2101: if (unlink(s)) err(warner, "I/O: can\'t remove file %s", s);
2102: else if (DEBUGFILES)
2103: fprintferr("I/O: removed file %s\n", s);
2104: }
2105:
2106: /* Remove one INFILE from the stack. Reset infile (to the most recent infile)
2107: * Return -1, if we're trying to pop out stdin itself; 0 otherwise
2108: * Check for leaked file handlers (temporary files)
2109: */
2110: int
2111: popinfile()
2112: {
2113: pariFILE *f;
2114:
2115: filtre(NULL,NULL, f_ENDFILE);
2116: for (f = last_tmp_file; f; f = f->prev)
2117: {
2118: if (f->type & mf_IN) break;
2119: err(warner, "I/O: leaked file descriptor (%d): %s",
2120: f->type, f->name);
2121: pari_fclose(f);
2122: }
2123: last_tmp_file = f; if (!last_tmp_file) return -1;
2124: pari_fclose(last_tmp_file);
2125: for (f = last_tmp_file; f; f = f->prev)
2126: if (f->type & mf_IN) { infile = f->file; return 0; }
2127: infile = stdin; return 0;
2128: }
2129:
2130: static void
2131: kill_file_stack(pariFILE **s)
2132: {
2133: pariFILE *f = *s;
2134: while (f)
2135: {
2136: pariFILE *t = f->prev;
2137: pari_kill_file(f);
2138: *s = f = t; /* have to update *s in case of ^C */
2139: }
2140: }
2141:
2142: void
2143: killallfiles(int leaving)
2144: {
2145: if (leaving)
2146: {
2147: popinfile(); /* look for leaks */
2148: kill_file_stack(&last_file);
2149: }
2150: kill_file_stack(&last_tmp_file);
2151: infile = stdin;
2152: }
2153:
2154: pariFILE *
2155: try_pipe(char *cmd, int fl)
2156: {
2157: #ifndef HAVE_PIPES
2158: err(archer); return NULL;
2159: #else
2160: FILE *file;
2161: char *f;
2162: VOLATILE int flag = fl;
2163:
2164: # ifdef __EMX__
2165: if (_osmode == DOS_MODE) /* no pipes under DOS */
2166: {
2167: char *s;
2168: if (flag & mf_OUT) err(archer);
2169: f = pari_unique_filename("pipe");
2170: s = gpmalloc(strlen(cmd)+strlen(f)+4);
2171: sprintf(s,"%s > %s",cmd,f);
2172: file = system(s)? NULL: (FILE *) fopen(f,"r");
2173: flag |= mf_FALSE; free(s);
2174: }
2175: else
2176: # endif
2177: {
2178: file = (FILE *) popen(cmd, (flag & mf_OUT)? "w": "r");
2179: if (flag & mf_OUT) flag |= mf_PERM;
2180: if (flag & (mf_TEST | mf_OUT))
2181: {
2182: jmp_buf env;
2183: void *c;
2184: int i;
2185: if (DEBUGFILES) fprintferr("I/O: checking output pipe...\n");
2186: if (setjmp(env)) return NULL;
2187:
2188: c = err_catch(-1, env, NULL);
2189: fprintf(file,"\n\n"); fflush(file);
2190: for (i=1; i<1000; i++) fprintf(file," \n");
2191: fprintf(file,"\n"); fflush(file);
2192: err_leave(&c);
2193: }
2194: f = cmd;
2195: }
2196: if (!file) err(talker,"[pipe:] '%s' failed",cmd);
2197: return newfile(file, f, mf_PIPE|flag);
2198: #endif
2199: }
2200:
2201: void
2202: os_close(long fd)
2203: {
2204: #ifdef WINCE
2205: CloseHandle((HANDLE)fd);
2206: #else
2207: close(fd);
2208: #endif
2209: }
2210:
2211: void
2212: (*os_signal(int sig, void (*f)(int)))(int)
2213: {
2214: #ifdef WINCE
2215: return SIG_IGN;
2216: #else
2217: return signal(sig,f);
2218: #endif
2219: }
2220:
2221: void
2222: os_read(long fd, char ch[], long s)
2223: {
2224: #ifdef WINCE
2225: DWORD chRead;
2226: ReadFile((HANDLE)fd, ch, s, &chRead, NULL);
2227: #else
2228: read(fd,ch,s);
2229: #endif
2230: }
2231:
2232: long
2233: os_open(char *s, int mode)
2234: {
2235: long fd;
2236: #ifdef WINCE
2237: HANDLE h;
2238: short ws[256];
2239: if (mode != O_RDONLY) err(impl,"generic open for Windows");
2240: MultiByteToWideChar(CP_ACP, 0, s, strlen(s)+1, ws, 256);
2241: h = CreateFile(ws,GENERIC_READ,FILE_SHARE_READ,NULL,OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,NULL);
2242: fd = (h == INVALID_HANDLE_VALUE)? (long)-1: (long)h;
2243: #else
2244: fd = open(s,mode);
2245: #endif
2246: return fd;
2247: }
2248:
2249: char *
2250: os_getenv(char *s)
2251: {
2252: #if defined(WINCE) || defined(macintosh)
2253: return NULL;
2254: #else
2255: return getenv(s);
2256: #endif
2257: }
2258:
2259: /*******************************************************************/
2260: /** **/
2261: /** GP STANDARD INPUT AND OUTPUT **/
2262: /** **/
2263: /*******************************************************************/
2264: static char *last_filename = NULL;
2265: static char **dir_list = NULL;
2266:
2267: #ifdef HAS_OPENDIR
2268: # include <dirent.h>
2269: #endif
2270: /* slow, but more portable than stat + S_I[FS]DIR */
2271: int
2272: pari_is_dir(char *name)
2273: {
2274: #ifdef HAS_OPENDIR
2275: DIR *d = opendir(name);
2276: if (d) { (void)closedir(d); return 1; }
2277: #endif
2278: return 0;
2279: }
2280:
2281: /* expand tildes in filenames, return a malloc'ed buffer */
2282: static char *
2283: _expand_tilde(char *s)
2284: {
2285: #if !defined(UNIX) && !defined(__EMX__)
2286: return pari_strdup(s);
2287: #else
2288: struct passwd *p;
2289: char *u;
2290: int len;
2291:
2292: if (*s != '~') return pari_strdup(s);
2293: s++; u = s; /* skip ~ */
2294: if (!*s || *s == '/')
2295: {
2296: p = getpwuid(geteuid());
2297: if (!p)
2298: { /* host badly configured, don't kill session on startup
2299: * (when expanding path) */
2300: err(warner,"can't expand ~");
2301: return pari_strdup(s);
2302: }
2303: }
2304: else
2305: {
2306: char *tmp;
2307: while (*u && *u != '/') u++;
2308: len = u-s;
2309: tmp = strncpy(gpmalloc(len+1),s,len);
2310: tmp[len] = 0;
2311: p = getpwnam(tmp); free(tmp);
2312: }
2313: if (!p) err(talker2,"unknown user ",s,s-1);
2314: s = gpmalloc(strlen(p->pw_dir) + strlen(u) + 1);
2315: sprintf(s,"%s%s",p->pw_dir,u); return s;
2316: #endif
2317: }
2318:
2319: /* expand environment variables in str, return a malloc'ed buffer
2320: * assume no \ remain and str can be freed */
2321: static char *
2322: _expand_env(char *str)
2323: {
2324: #if defined(WINCE) || defined(macintosh)
2325: return str;
2326: #else
2327: long i, l, len = 0, xlen = 16, xnum = 0;
2328: char *s = str, *s0 = s, *env;
2329: char **x = (char **)gpmalloc(xlen * sizeof(char*));
2330:
2331: while (*s)
2332: {
2333: if (*s != '$') { s++; continue; }
2334: l = s - s0;
2335: if (l)
2336: {
2337: s0 = strncpy(gpmalloc(l+1), s0, l); s0[l] = 0;
2338: x[xnum++] = s0; len += l;
2339: }
2340: if (xnum > xlen - 3) /* need room for possibly two more elts */
2341: {
2342: long xnew = xlen << 1;
2343: x = (char **)gprealloc((void*)x, xlen * sizeof(char*),
2344: xnew * sizeof(char*));
2345: xlen = xnew;
2346: }
2347:
2348: s0 = ++s; /* skip $ */
2349: while (is_keyword_char(*s)) s++;
2350: l = s - s0;
2351: env = strncpy(gpmalloc(l+1), s0, l); env[l] = 0;
2352: s0 = getenv(env);
2353: if (!s0)
2354: {
2355: err(warner,"undefined environment variable: %s",env);
2356: s0 = "";
2357: }
2358: l = strlen(s0);
2359: if (l)
2360: {
2361: s0 = strncpy(gpmalloc(l+1), s0, l); s0[l] = 0;
2362: x[xnum++] = s0; len += l;
2363: }
2364: free(env); s0 = s;
2365: }
2366: l = s - s0;
2367: if (l)
2368: {
2369: s0 = strncpy(gpmalloc(l+1), s0, l); s0[l] = 0;
2370: x[xnum++] = s0; len += l;
2371: }
2372:
2373: s = gpmalloc(len+1); *s = 0;
2374: for (i = 0; i < xnum; i++) { (void)strcat(s, x[i]); free(x[i]); }
2375: free(str); free(x); return s;
2376: #endif
2377: }
2378:
2379: char *
2380: expand_tilde(char *s)
2381: {
2382: return _expand_env(_expand_tilde(s));
2383: }
2384:
2385: #if defined __EMX__ || defined _WIN32
2386: # define PATH_SEPARATOR ';'
2387: #else
2388: # define PATH_SEPARATOR ':'
2389: #endif
2390:
2391: void
2392: gp_expand_path(char *v)
2393: {
2394: char **path, **old, *s;
2395: int i, n = 0;
2396:
2397: v = pari_strdup(v);
2398: for (s=v; *s; s++)
2399: if (*s == PATH_SEPARATOR) { *s = 0; n++; }
2400: path = (char**) gpmalloc((n + 2)*sizeof(char *));
2401:
2402: for (s=v, i=0; i<=n; i++)
2403: {
2404: char *end = s + strlen(s), *f = end;
2405: while (f > s && *--f == '/') *f = 0;
2406: path[i] = expand_tilde(s);
2407: s = end + 1; /* next path component */
2408: }
2409: path[i] = NULL; old = dir_list; dir_list = path;
2410: if (old)
2411: {
2412: for (path=old; *path; path++) free(*path);
2413: free(old);
2414: }
2415: }
2416:
2417: /* name is a malloc'ed (existing) filename. Accept it as new infile
2418: * (unzip if needed). */
2419: static FILE *
2420: accept_file(char *name, FILE *file)
2421: {
2422: if (pari_is_dir(name))
2423: {
2424: err(warner,"skipping directory %s",name);
2425: return NULL;
2426: }
2427: if (! last_tmp_file)
2428: { /* empty file stack, record this name */
2429: if (last_filename) free(last_filename);
2430: last_filename = pari_strdup(name);
2431: }
2432: #ifdef ZCAT
2433: {
2434: long l = strlen(name);
2435: char *end = name + l-1;
2436:
2437: if (l > 2 && (!strncmp(end-1,".Z",2)
2438: #ifdef GNUZCAT
2439: || !strncmp(end-2,".gz",3)
2440: #endif
2441: ))
2442: { /* compressed file (compress or gzip) */
2443: char *cmd = gpmalloc(strlen(ZCAT) + l + 2);
2444: sprintf(cmd,"%s %s",ZCAT,name);
2445: fclose(file); infile = try_pipe(cmd, mf_IN)->file;
2446: free(cmd); return infile;
2447: }
2448: }
2449: #endif
2450: return infile = newfile(file, name, mf_IN)->file;
2451: }
2452:
2453: /* If a file called "name" exists (possibly after appending ".gp")
2454: * record it in the file_stack (as a pipe if compressed).
2455: * name is malloc'ed, we free it before returning
2456: */
2457: static FILE *
2458: try_name(char *name)
2459: {
2460: FILE *file = fopen(name, "r");
2461: if (file) file = accept_file(name,file);
2462: if (!file)
2463: { /* try appending ".gp" to name */
2464: char *s = gpmalloc(strlen(name)+4);
2465: sprintf(s, "%s.gp", name);
2466: file = fopen(s, "r");
2467: if (file) file = accept_file(s,file);
2468: free(s);
2469: }
2470: free(name); return file;
2471: }
2472:
2473: /* If name = "", re-read last file */
2474: void
2475: switchin(char *name0)
2476: {
2477: char *s, *name;
2478:
2479: if (*name0)
2480: name = expand_tilde(name0);
2481: else
2482: {
2483: if (last_filename == NULL)
2484: err(talker,"You never gave me anything to read!");
2485: name0 = last_filename;
2486: name = pari_strdup(name0);
2487: }
2488: /* if name contains '/', don't use dir_list */
2489: s=name; while (*s && *s != '/' && *s != '\\') s++;
2490: if (*s) { if (try_name(name)) return; }
2491: else
2492: {
2493: char **tmp = dir_list;
2494: for ( ; *tmp; tmp++)
2495: { /* make room for '/' and '\0', try_name frees it */
2496: s = gpmalloc(2 + strlen(*tmp) + strlen(name));
2497: sprintf(s,"%s/%s",*tmp,name);
2498: if (try_name(s)) return;
2499: }
2500: }
2501: err(openfiler,"input",name0);
2502: }
2503:
2504: void
2505: switchout(char *name)
2506: {
2507: if (name)
2508: {
2509: FILE *f = fopen(name, "a");
2510: if (!f) err(openfiler,"output",name);
2511: pari_outfile = f;
2512: }
2513: else if (pari_outfile != stdout)
2514: {
2515: fclose(pari_outfile);
2516: pari_outfile = stdout;
2517: }
2518: }
2519:
2520: /*******************************************************************/
2521: /** **/
2522: /** I/O IN BINARY FORM **/
2523: /** **/
2524: /*******************************************************************/
2525: #define _fwrite(a,b,c,d) \
2526: if (fwrite((a),(b),(c),(d)) < (c)) err(talker,"write failed")
2527: #define _fread(a,b,c,d) \
2528: if (fread((a),(b),(c),(d)) < (c)) err(talker,"read failed")
2529: #define _lfread(a,b,c) _fread((a),sizeof(long),(b),(c))
2530: #define _cfread(a,b,c) _fread((a),sizeof(char),(b),(c))
2531: #define _lfwrite(a,b,c) _fwrite((a),sizeof(long),(b),(c))
2532: #define _cfwrite(a,b,c) _fwrite((a),sizeof(char),(b),(c))
2533:
2534: #define BIN_GEN 0
2535: #define NAM_GEN 1
2536:
2537: static long
2538: rd_long(FILE *f)
2539: {
2540: long L;
2541: _lfread(&L, 1, f); return L;
2542: }
2543: static void
2544: wr_long(long L, FILE *f)
2545: {
2546: _lfwrite(&L, 1, f);
2547: }
2548:
2549: /* append x to file f */
2550: static void
2551: wrGEN(GEN x, FILE *f)
2552: {
2553: GENbin *p = copy_bin(x);
2554: long L = p->len;
2555:
2556: wr_long(L,f);
2557: wr_long((long)p->x,f);
2558: wr_long((long)p->base,f);
2559: _lfwrite(GENbase(p), L,f);
2560: free((void*)p);
2561: }
2562:
2563: static void
2564: wrstr(char *s, FILE *f)
2565: {
2566: long L = strlen(s)+1;
2567: wr_long(L,f);
2568: _cfwrite(s, L, f);
2569: }
2570:
2571: static char *
2572: rdstr(FILE *f)
2573: {
2574: long L = rd_long(f);
2575: char *s;
2576: if (!L) return NULL;
2577: s = gpmalloc(L);
2578: _cfread(s, L, f); return s;
2579: }
2580:
2581: void
2582: writeGEN(GEN x, FILE *f)
2583: {
2584: fputc(BIN_GEN,f);
2585: wrGEN(x, f);
2586: }
2587:
2588: void
2589: writenamedGEN(GEN x, char *s, FILE *f)
2590: {
2591: fputc(NAM_GEN,f);
2592: wrstr(s, f);
2593: wrGEN(x, f);
2594: }
2595:
2596: /* read a GEN from file f */
2597: static GEN
2598: rdGEN(FILE *f)
2599: {
2600: long L = rd_long(f);
2601: GENbin *p;
2602:
2603: if (!L) return NULL;
2604: p = (GENbin*)gpmalloc(sizeof(GENbin) + L*sizeof(long));
2605: p->len = L;
2606: p->x = (GEN)rd_long(f);
2607: p->base = (GEN)rd_long(f);
2608: _lfread(GENbase(p), L,f);
2609: return bin_copy(p);
2610: }
2611:
2612: GEN
2613: readobj(FILE *f)
2614: {
2615: int c = fgetc(f);
2616: GEN x = NULL;
2617: switch(c)
2618: {
2619: case BIN_GEN:
2620: x = rdGEN(f);
2621: if (!x) err(talker,"malformed binary file (no GEN)");
2622: break;
2623: case NAM_GEN:
2624: {
2625: char *s = rdstr(f);
2626: if (!s) err(talker,"malformed binary file (no name)");
2627: x = rdGEN(f);
2628: if (!x) err(talker,"malformed binary file (no GEN)");
2629: fprintferr("setting %s\n",s);
2630: changevalue(fetch_named_var(s,0), x);
2631: break;
2632: }
2633: case EOF: break;
2634: default: err(talker,"unknown code in readobj");
2635: }
2636: return x;
2637: }
2638:
2639: #define MAGIC "\020\001\022\011-\007\020" /* ^P^A^R^I-^G^P */
2640: #ifdef LONG_IS_64BIT
2641: # define ENDIAN_CHECK 0x0102030405060708L
2642: #else
2643: # define ENDIAN_CHECK 0x01020304L
2644: #endif
2645: const long BINARY_VERSION = 0;
2646:
2647: static int
2648: is_magic_ok(FILE *f)
2649: {
2650: int L = strlen(MAGIC);
2651: char *s = gpmalloc(L);
2652: int r = (fread(s,1,L, f) == L && strncmp(s,MAGIC,L) == 0);
2653: free(s); return r;
2654: }
2655:
2656: static int
2657: is_sizeoflong_ok(FILE *f)
2658: {
2659: char c;
2660: return (fread(&c,1,1, f) == 1 && c == sizeof(long));
2661: }
2662:
2663: static int
2664: is_long_ok(FILE *f, long L)
2665: {
2666: long c;
2667: return (fread(&c,sizeof(long),1, f) == 1 && c == L);
2668: }
2669:
2670: static void
2671: check_magic(char *name, FILE *f)
2672: {
2673: if (!is_magic_ok(f))
2674: err(talker, "%s is not a GP binary file",name);
2675: if (!is_sizeoflong_ok(f))
2676: err(talker, "%s not written for a %ld bit architecture",
2677: name, sizeof(long)*8);
2678: if (!is_long_ok(f, ENDIAN_CHECK))
2679: err(talker, "unexpected endianness in %s",name);
2680: if (!is_long_ok(f, BINARY_VERSION))
2681: err(talker, "%s written by an incompatible version of GP",name);
2682: }
2683:
2684: static void
2685: write_magic(FILE *f)
2686: {
2687: fprintf(f, MAGIC);
2688: fprintf(f, "%c", sizeof(long));
2689: wr_long(ENDIAN_CHECK, f);
2690: wr_long(BINARY_VERSION, f);
2691: }
2692:
2693: int
2694: file_is_binary(FILE *f)
2695: {
2696: int c = fgetc(f), r = isprint(c);
2697: ungetc(c,f); return (r == 0);
2698: }
2699:
2700: void
2701: writebin(char *name, GEN x)
2702: {
2703: FILE *f = fopen(name,"r");
2704: int already = f? 1: 0;
2705:
2706: if (f) { check_magic(name,f); fclose(f); }
2707: f = fopen(name,"a");
2708: if (!f) err(openfiler,"binary output",name);
2709: if (!already) write_magic(f);
2710:
2711: if (x) writeGEN(x,f);
2712: else
2713: {
2714: long v, maxv = manage_var(3,NULL);
2715: for (v=0; v<maxv; v++)
2716: {
2717: entree *ep = varentries[v];
2718: if (!ep) continue;
2719: writenamedGEN(ep->value,ep->name,f);
2720: }
2721: }
2722: fclose(f);
2723: }
2724:
2725: /* read all objects in file and return last one */
2726: GEN
2727: readbin(char *name, FILE *f)
2728: {
2729: GEN y, x = NULL;
2730: check_magic(name,f);
2731: while ((y = readobj(f))) x = y;
2732: return x;
2733: }
2734:
2735: /*******************************************************************/
2736: /** **/
2737: /** TEMPORARY FILES **/
2738: /** **/
2739: /*******************************************************************/
2740: #ifdef __WIN32
2741: # include <process.h> /* for getpid */
2742: #endif
2743:
2744: #ifndef R_OK
2745: # define R_OK 4
2746: # define W_OK 2
2747: # define X_OK 1
2748: # define F_OK 0
2749: #endif
2750:
2751: #ifdef __EMX__
2752: #include <io.h>
2753: static int
2754: unix_shell()
2755: {
2756: char *base, *sh = getenv("EMXSHELL");
2757: if (sh == NULL) sh = getenv("COMSPEC");
2758: if (sh == NULL) return 0;
2759: base = _getname (sh);
2760: if (stricmp (base, "cmd.exe") == 0 || stricmp (base, "4os2.exe") == 0
2761: || stricmp (base, "command.com") == 0
2762: || stricmp (base, "4dos.com") == 0)
2763: return 0;
2764: return 1;
2765: }
2766: #endif
2767:
2768: /* check if s has rwx permissions for us */
2769: static int
2770: pari_is_rwx(char *s)
2771: {
2772: #if defined(UNIX) || defined (__EMX__) /* TODO: ok for macintosh? */
2773: return access(s, R_OK | W_OK | X_OK) == 0;
2774: #else
2775: return 1;
2776: #endif
2777: }
2778:
2779: static int
2780: pari_file_exists(char *s)
2781: {
2782: #if defined(UNIX) || defined (__EMX__)
2783: return access(s, F_OK) == 0;
2784: #else
2785: return 0;
2786: #endif
2787: }
2788:
2789: char *
2790: env_ok(char *s)
2791: {
2792: char *t = os_getenv(s);
2793: if (t && !pari_is_rwx(t))
2794: {
2795: err(warner,"%s is set (%s), but is not writeable", s,t);
2796: t = NULL;
2797: }
2798: if (t && !pari_is_dir(t))
2799: {
2800: err(warner,"%s is set (%s), but is not a directory", s,t);
2801: t = NULL;
2802: }
2803: return t;
2804: }
2805:
2806: static char*
2807: pari_tmp_dir()
2808: {
2809: char *s;
2810: #ifdef WINCE
2811: s = env_ok("TEMP"); if (s) return s;
2812: return "\\temp";
2813: #endif
2814: s = env_ok("GPTMPDIR"); if (s) return s;
2815: s = env_ok("TMPDIR"); if (s) return s;
2816: #ifdef __EMX__
2817: s = env_ok("TMP"); if (s) return s;
2818: s = env_ok("TEMP"); if (s) return s;
2819: #endif
2820: #if defined(UNIX) || defined(__EMX__)
2821: if (pari_is_rwx("/tmp")) return "/tmp";
2822: if (pari_is_rwx("/var/tmp")) return "/var/tmp";
2823: #endif
2824: return ".";
2825: }
2826:
2827: /* Return a "unique filename" built from the string s, possibly the user id
2828: * and the process pid (on Unix systems). A "temporary" directory name is
2829: * prepended. The name returned is stored in a static buffer (gpmalloc'ed
2830: * permanently). It is DOS-safe (s truncated to 8 chars)
2831: */
2832: char*
2833: pari_unique_filename(char *s)
2834: {
2835: static char *buf, *pre, *post = NULL;
2836:
2837: if (!post || !s) /* initialize */
2838: {
2839: char suf[64];
2840: int lpre, lsuf;
2841:
2842: if (post) free(post);
2843: pre = pari_tmp_dir();
2844: #ifdef UNIX
2845: sprintf(suf,".%ld.%ld", (long)getuid(), (long)getpid());
2846: #else
2847: sprintf(suf,".gpa");
2848: #endif
2849: lsuf = strlen(suf);
2850: lpre = strlen(pre);
2851: /* room for suffix + '\0 + prefix + '/' + s + suffix '\0' */
2852: /* ^- post ^- buf ^- pre */
2853: post = (char*) gpmalloc(lpre + 1 + 8 + 2*(lsuf + 1));
2854: strcpy(post, suf);
2855: buf = post + lsuf; *buf = 0; buf++;
2856: strcpy(buf, pre);
2857: if (buf[lpre-1] != '/') { (void)strcat(buf, "/"); lpre++; }
2858: #ifdef __EMX__
2859: if (!unix_shell())
2860: #endif
2861: #if defined(__EMX__) || defined(WINCE)
2862: for (pre=buf; *pre; pre++)
2863: if (*pre == '/') *pre = '\\';
2864: #endif
2865: pre = buf + lpre; if (!s) return s;
2866: }
2867: sprintf(pre, "%.8s%s", s, post);
2868: if (pari_file_exists(buf))
2869: {
2870: char c, *end = buf + strlen(buf) - 1;
2871: for (c='a'; c<='z'; c++)
2872: {
2873: *end = c;
2874: if (! pari_file_exists(buf)) break;
2875: }
2876: if (c > 'z')
2877: err(talker,"couldn't find a suitable name for a tempfile (%s)",s);
2878: }
2879: return buf;
2880: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to es.c CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib / pari-2.2 / src / language