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