Annotation of OpenXM_contrib/pari/src/language/es.c, Revision 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