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