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