=================================================================== RCS file: /home/cvs/OpenXM_contrib/pari-2.2/src/language/Attic/es.c,v retrieving revision 1.1.1.1 retrieving revision 1.2 diff -u -p -r1.1.1.1 -r1.2 --- OpenXM_contrib/pari-2.2/src/language/Attic/es.c 2001/10/02 11:17:10 1.1.1.1 +++ OpenXM_contrib/pari-2.2/src/language/Attic/es.c 2002/09/11 07:27:03 1.2 @@ -1,4 +1,4 @@ -/* $Id: es.c,v 1.1.1.1 2001/10/02 11:17:10 noro Exp $ +/* $Id: es.c,v 1.2 2002/09/11 07:27:03 noro Exp $ Copyright (C) 2000 The PARI group. @@ -22,21 +22,13 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, #include "anal.h" extern GEN confrac(GEN x); /* should be static here, but use hiremainder */ extern GEN convi(GEN x); -static void bruti(GEN g, long n); -static void texi(GEN g, long nosign); -static void sori(GEN g); char * type_name(long t); -static char format; -static long decimals, chmp, initial; -/* output a space or do nothing depending on original caller */ -static void (*sp)(); - void -hit_return() +hit_return(void) { int c; - if (under_texmacs || under_emacs) return; + if (GP_DATA && (GP_DATA->flags & (EMACS|TEXMACS))) return; pariputs("---- (type RETURN to continue) ----"); /* if called from a readline callback, may be in a funny TTY mode, */ do c = fgetc(stdin); while (c >= 0 && c != '\n' && c != '\r' && c != ' '); @@ -48,94 +40,120 @@ hit_return() /** INPUT FILTER **/ /** **/ /********************************************************************/ - #define ONE_LINE_COMMENT 2 #define MULTI_LINE_COMMENT 1 -/* Filter s into t. If flag is a query, return s (yes) / NULL (no) - * Otherwise, if t == NULL, allocate enough room, filter then return t. - * if not return pointer to ending '\0' in t. - */ +/* Filter F->s into F->t */ char * -filtre(char *s0, char *t0, int flag) +filtre0(filtre_t *F) { - static int in_string, in_comment = 0; - char c, *s, *t; - int downcase, return_end; + const int downcase = F->downcase; + char c, *s = F->s, *t; - if (flag & f_INIT) in_string = 0; - switch(flag) + if (!F->t) F->t = gpmalloc(strlen(s)+1); + t = F->t; + + if (F->more_input == 1) F->more_input = 0; + + if (! F->in_comment) { - case f_ENDFILE: - if (in_string) - { - err(warner,"run-away string. Closing it"); - in_string = 0; - } - if (in_comment) - { - err(warner,"run-away comment. Closing it"); - in_comment = 0; - } /* fall through */ - case f_INIT: case f_COMMENT: - return in_comment? s0: NULL; + while (isspace((int)*s)) s++; /* Skip space */ + if (*s == LBRACE) { s++; F->more_input = 2; F->wait_for_brace = 1; } } - downcase = ((flag & f_KEEPCASE) == 0 && compatible == OLDALL); - s = s0; return_end = (t0 != NULL); - if (!t0) t0 = gpmalloc(strlen(s)+1); - t = t0; - while ((c = *s++)) { - if (in_string) *t++ = c; /* copy verbatim */ - else if (in_comment) + if (F->in_string) { - if (in_comment == MULTI_LINE_COMMENT) + *t++ = c; /* copy verbatim */ + switch(c) { + case '\\': /* in strings, \ is the escape character */ + if (*s) *t++ = *s++; + break; + + case '"': F->in_string = 0; + } + continue; + } + + if (F->in_comment) + { /* look for comment's end */ + if (F->in_comment == MULTI_LINE_COMMENT) + { while (c != '*' || *s != '/') { - if (!*s) goto END; + if (!*s) + { + if (!F->more_input) F->more_input = 1; + goto END; + } c = *s++; } s++; } else - while (c != '\n') - { - if (!*s) { in_comment=0; goto END; } - c = *s++; - } - in_comment=0; continue; + while (c != '\n' && *s) c = *s++; + F->in_comment = 0; + continue; } - else - { /* weed out comments and spaces */ - if (c=='\\' && *s=='\\') { in_comment = ONE_LINE_COMMENT; continue; } - if (isspace((int)c)) continue; - *t++ = downcase? tolower(c): c; - } + + /* weed out comments and spaces */ + if (c=='\\' && *s=='\\') { F->in_comment = ONE_LINE_COMMENT; continue; } + if (isspace((int)c)) continue; + *t++ = downcase? tolower(c): c; + switch(c) { case '/': - if (*s != '*' || in_string) break; - /* start multi-line comment */ - t--; in_comment = MULTI_LINE_COMMENT; break; + if (*s == '*') { t--; F->in_comment = MULTI_LINE_COMMENT; } + break; case '\\': - if (!in_string) break; - if (!*s) goto END; /* this will result in an error */ - *t++ = *s++; break; /* in strings, \ is the escape character */ - /* \" does not end a string. But \\" does */ + if (!*s) { + if (t[-2] == '?') break; /* '?\' */ + t--; + if (!F->more_input) F->more_input = 1; + goto END; + } + if (*s == '\n') { + if (t[-2] == '?') break; /* '?\' */ + t--; s++; + if (!*s) + { + if (!F->more_input) F->more_input = 1; + goto END; + } + } /* skip \ */ + break; - case '"': - in_string = !in_string; + case '"': F->in_string = 1; } } + + if (t != F->t) /* non empty input */ + { + c = t[-1]; /* = last input char */ + if (c == '=') F->more_input = 2; + else if (! F->wait_for_brace) F->more_input = 0; + else if (c == RBRACE) { F->more_input = 0; t--; } + } + END: - *t = 0; return return_end? t: t0; + F->end = t; *t = 0; return F->t; } #undef ONE_LINE_COMMENT #undef MULTI_LINE_COMMENT +char * +filtre(char *s, int downcase) +{ + filtre_t T; + T.s = s; T.in_string = 0; T.more_input = 0; + T.t = NULL; T.in_comment= 0; T.wait_for_brace = 0; + T.downcase = downcase; + return filtre0(&T); +} + GEN lisGEN(FILE *fi) { @@ -149,7 +167,7 @@ lisGEN(FILE *fi) GEN x = flisexpr(buf); free(buf); return x; } - buf = gprealloc(buf, size<<1, size); + buf = gprealloc(buf, size<<1); s = buf + (size-1); n = size+1; size <<= 1; } #if defined(UNIX) || defined(__EMX__) @@ -227,13 +245,15 @@ pariflush(void) { pariOut->flush(); } void flusherr(void) { pariErr->flush(); } -/* format is standard printf format, except %Z is a GEN (cast to long) */ +/* format is standard printf format, except %Z is a GEN */ void vpariputs(char* format, va_list args) { - char buf[1024], str[1024], *f = format, *s = str; - long nb = 0; - + long nb = 0, bufsize = 1023; + char *buf, *str, *s, *f = format; + + /* replace each %Z (2 chars) by braced address format (8 chars) */ + s = str = gpmalloc(strlen(format)*4 + 1); while (*f) { if (*f != '%') *s++ = *f++; @@ -247,17 +267,36 @@ vpariputs(char* format, va_list args) } } } - *s = 0; vsprintf(buf,str,args); s = buf; + *s = 0; +#ifdef HAS_VSNPRINTF + for(;;) + { + int l; + buf = gpmalloc(bufsize); + l = vsnprintf(buf,bufsize,str,args); + if (l < 0) l = bufsize<<1; else if (l < bufsize) break; + free(buf); bufsize++; + } + buf[bufsize] = 0; /* just in case */ +#else + buf = gpmalloc(bufsize); + (void)vsprintf(buf,str,args); /* pray it does fit */ +#endif + f = s = buf; if (nb) - for (f=s; *f; f++) + while ( *f ) + { if (*f == '\003' && f[21] == '\003') { *f = 0; f[21] = 0; /* remove the bracing chars */ pariOut->puts(s); bruteall((GEN)atol(f+1),'g',-1,1); f += 22; s = f; - nb--; if (!nb) break; + if (!--nb) break; } - pariOut->puts(s); + else + f++; + } + pariOut->puts(s); free(buf); free(str); } void @@ -326,13 +365,13 @@ static int col_index, lin_index, max_width, max_lin; #endif static int -term_width_intern() +term_width_intern(void) { #ifdef HAS_TIOCGWINSZ { struct winsize s; - if (!under_emacs && !under_texmacs && !ioctl(0, TIOCGWINSZ, &s)) - return s.ws_col; + if (!(GP_DATA && (GP_DATA->flags & (EMACS|TEXMACS))) + && !ioctl(0, TIOCGWINSZ, &s)) return s.ws_col; } #endif #ifdef UNIX @@ -351,13 +390,13 @@ term_width_intern() } static int -term_height_intern() +term_height_intern(void) { #ifdef HAS_TIOCGWINSZ { struct winsize s; - if (!under_emacs && !under_texmacs && !ioctl(0, TIOCGWINSZ, &s)) - return s.ws_row; + if (!(GP_DATA && (GP_DATA->flags & (EMACS|TEXMACS))) + && !ioctl(0, TIOCGWINSZ, &s)) return s.ws_row; } #endif #ifdef UNIX @@ -379,14 +418,14 @@ term_height_intern() #define DFT_TERM_HEIGHT 20 int -term_width() +term_width(void) { int n = term_width_intern(); return (n>1)? n: DFT_TERM_WIDTH; } int -term_height() +term_height(void) { int n = term_height_intern(); return (n>1)? n: DFT_TERM_HEIGHT; @@ -410,7 +449,7 @@ puts80(char *s) } PariOUT pariOut80= {putc80, puts80, normalOutF, NULL}; -void +static void init80(long n) { col_index = n; pariOut = &pariOut80; @@ -448,16 +487,18 @@ puts_lim_lines(char *s) PariOUT pariOut_lim_lines= {putc_lim_lines, puts_lim_lines, normalOutF, NULL}; -/* s = prefix already printed (print up to max lines) */ +/* n = length of prefix already printed (print up to max lines) */ void -init_lim_lines(char *s, long max) +lim_lines_output(GEN z, pariout_t *fmt, long n, long max) { - if (!max) return; - if (!s) { pariOut = &defaultOut; return; } + PariOUT *tmp = pariOut; max_width = term_width(); max_lin = max; - lin_index = 1; col_index = strlen(s); + lin_index = 1; + col_index = n; pariOut = &pariOut_lim_lines; + gen_output(z, fmt); + pariOut = tmp; } #define is_blank_or_null(c) (!(c) || is_blank(c)) @@ -566,9 +607,8 @@ static outString *OutStr, *ErrStr = NULL; #define check_output_length(str,l) { \ const ulong s = str->size; \ if (str->len + l >= s) { \ - ulong t = s + l + STEPSIZE; \ - str->string = gprealloc(str->string, t, s); \ - str->size = t; \ + str->size = s + l + STEPSIZE; \ + str->string = gprealloc(str->string, str->size); \ } \ } @@ -608,35 +648,36 @@ pari_strdup(char *s) /* returns a malloc-ed string, which should be freed after usage */ char * -GENtostr0(GEN x, void(*do_out)(GEN)) +GENtostr0(GEN x, pariout_t *T, void (*do_out)(GEN, pariout_t*)) { PariOUT *tmp = pariOut; outString *tmps = OutStr, newStr; if (typ(x) == t_STR) return pari_strdup(GSTR(x)); - pariOut = &pariOut2Str; OutStr = &newStr; - OutStr->len = 0; OutStr->size=0; OutStr->string=NULL; - do_out(x); OutStr->string[OutStr->len] = 0; + pariOut = &pariOut2Str; + newStr.len = 0; + newStr.size = 0; + newStr.string= NULL; OutStr = &newStr; + do_out(x, T); + OutStr->string[OutStr->len] = 0; pariOut = tmp; OutStr = tmps; return newStr.string; } char * -GENtostr(GEN x) { return GENtostr0(x,outbrute); } +GENtostr(GEN x) { return GENtostr0(x, NULL, &gen_output); } /********************************************************************/ /** **/ /** WRITE AN INTEGER **/ /** **/ /********************************************************************/ +#define putsigne_nosp(x) pariputc((x>0)? '+' : '-') #define putsigne(x) pariputs((x>0)? " + " : " - ") -#define sp_sign_sp(x) sp(), pariputc(x>0? '+': '-'), sp() -#define sp_plus_sp() sp(), pariputc('+'), sp() -#define comma_sp() pariputc(','), sp() +#define sp_sign_sp(T,x) ((T)->sp? putsigne(x): putsigne_nosp(x)) +#define sp(T) do { if ((T)->sp) pariputc(' '); } while(0); +#define comma_sp(T) ((T)->sp? pariputs(", "): pariputc(',')) -static void wr_space() {pariputc(' ');} -static void no_space() {} - static void blancs(long nb) { while (nb-- > 0) pariputc(' '); } @@ -653,19 +694,21 @@ coinit(long x) pariputs(p); return 9 - (p - cha); } -/* as above, printing leading 0s, return # significant digits printed */ +/* as above, printing leading 0s, return # significant digits printed + * print at most dec significant digits */ static long -coinit2(long x) +coinit2(long x, long dec) { char cha[10], *p = cha + 9; int i = 0; for (*p = 0; p > cha; x /= 10) *--p = x%10 + '0'; while (cha[i] == '0') i++; - pariputs(cha); return 9 - i; + i = 9-i; /* # significant digits to print */ + if (i > dec) { i = dec; cha[dec] = 0; } + pariputs(cha); return i; } - static void comilieu(long x) { @@ -702,56 +745,67 @@ nbdch(long l) return 10; /* not reached */ } -/* write an int. fw = field width (pad with ' ') */ +/* write int x > 0 */ static void -wr_int(GEN x, long fw, long nosign) +wr_intpos(GEN x) { - long *res,*re,i, sx=signe(x); + long *res = convi(x); + (void)coinit(*--res); while (*--res >= 0) comilieu(*res); +} - if (!sx) { blancs(fw-1); pariputc('0'); return; } - setsigne(x,1); re = res = convi(x); - setsigne(x,sx); +/* write int. T->fieldw: field width (pad with ' ') */ +static void +wr_int(pariout_t *T, GEN x, int nosign) +{ + long *res,*re,i, sx = signe(x); + int minus; + + if (!sx) { blancs(T->fieldw - 1); pariputc('0'); return; } + re = res = convi(x); i = nbdch(*--re); while (*--re >= 0) i+=9; - if (nosign || sx>0) blancs(fw-i); - else - { i++; blancs(fw-i); pariputc('-'); } - coinit(*--res); while (*--res >= 0) comilieu(*res); + minus = (sx < 0 && !nosign); + if (minus) i++; + + blancs(T->fieldw - i); + if (minus) pariputc('-'); + (void)coinit(*--res); while (*--res >= 0) comilieu(*res); } static void -wr_vecsmall(GEN g) +wr_vecsmall(pariout_t *T, GEN g) { long i,l; - pariputc('['); l = lg(g); + pariputs("Vecsmall(["); l = lg(g); for (i=1; isigd; GEN p1; if (dec>0) /* round if needed */ { GEN arrondi = cgetr(3); - arrondi[1] = (long) (x[1]-((double)BITS_IN_LONG/pariK)*dec-2); + ex = expo(x) - (long)((((double)BITS_IN_LONG)/pariK)*dec+2); + arrondi[1] = evalsigne(1)|evalexpo(ex); arrondi[2] = x[2]; x = addrr(x,arrondi); } ex = expo(x); e = bit_accuracy(lg(x)); /* significant bits */ - if (ex >= e) { wr_exp(x); return; } + if (ex >= e) { wr_exp(T,x); return; } decmax = (long) (e * L2SL10); /* significant digits */ if ((ulong)decmax < (ulong)dec) dec = decmax; /* Hack: includes dec < 0 */ @@ -778,7 +832,7 @@ wr_float(GEN x) if (!s) { while (!*res) { res++; pariputs("000000000"); } - d = coinit2(*res++); + d = coinit2(*res++, dec); } /* d = # significant digits already printed */ @@ -789,38 +843,40 @@ wr_float(GEN x) /* as above in exponential format */ static void -wr_exp(GEN x) +wr_exp(pariout_t *T, GEN x) { - GEN dix = cgetr(lg(x)+1); - long ex = expo(x); + GEN dix = stor(10, lg(x)+1); + long e = expo(x); - ex = (ex>=0)? (long)(ex*L2SL10): (long)(-(-ex*L2SL10)-1); - affsr(10,dix); if (ex) x = mulrr(x,gpuigs(dix,-ex)); - if (absr_cmp(x, dix) >= 0) { x=divrr(x,dix); ex++; } - wr_float(x); sp(); pariputsf("E%ld",ex); + e = (e>=0)? (long)(e*L2SL10): (long)(-(-e*L2SL10)-1); + if (e) x = mulrr(x, gpowgs(dix,-e)); + if (absr_cmp(x, dix) >= 0) { x = divrr(x,dix); e++; } + wr_float(T,x); sp(T); pariputsf("E%ld",e); } /* Write real number x. * format: e (exponential), f (floating point), g (as f unless x too small) * if format isn't correct (one of the above) act as e. - * decimals: number of decimals to print (all if <0). + * sigd: number of sigd to print (all if <0). */ static void -wr_real(GEN x, long nosign) +wr_real(pariout_t *T, GEN x, int nosign) { - long ltop, sx = signe(x), ex = expo(x); + gpmem_t ltop; + long sx = signe(x), ex = expo(x); if (!sx) /* real 0 */ { - if (format == 'f') + if (T->format == 'f') { - if (decimals<0) + long d, dec = T->sigd; + if (dec < 0) { - long d = 1+((-ex)>>TWOPOTBITS_IN_LONG); + d = 1+((-ex)>>TWOPOTBITS_IN_LONG); if (d < 0) d = 0; - decimals=(long)(pariK*d); + dec = (long)(pariK*d); } - pariputs("0."); zeros(decimals); + pariputs("0."); zeros(dec); } else { @@ -831,22 +887,11 @@ wr_real(GEN x, long nosign) } if (!nosign && sx < 0) pariputc('-'); /* print sign if needed */ ltop = avma; - if ((format == 'g' && ex>=-32) || format == 'f') wr_float(x); else wr_exp(x); + if ((T->format == 'g' && ex>=-32) + || T->format == 'f') wr_float(T,x); else wr_exp(T,x); avma = ltop; } -void -ecrire(GEN x, char f, long d, long fw) -{ - if (typ(x)==t_INT) - wr_int(x,fw,0); - else - { - sp = &wr_space; format = f; decimals = d; - wr_real(x,0); - } -} - /********************************************************************/ /** **/ /** HEXADECIMAL OUTPUT **/ @@ -896,8 +941,10 @@ vsigne(GEN x) static void voir2(GEN x, long nb, long bl) { - long tx=typ(x),i,j,e,dx,lx=lg(x); + long tx,i,j,e,dx,lx; + if (!x) { pariputs("NULL\n"); return; } + tx = typ(x); if (tx == t_INT && x == gzero) { pariputs("gzero\n"); return; } if (tx == t_SMALL) { pariputs("[SMALL "); @@ -906,16 +953,17 @@ voir2(GEN x, long nb, long bl) } sorstring(VOIR_STRING1,(ulong)x); + lx = lg(x); pariputsf("%s(lg=%ld%s):",type_name(tx)+2,lx,isclone(x)? ",CLONE" : ""); sorstring(VOIR_STRING2,x[0]); if (! is_recursive_t(tx)) /* t_SMALL, t_INT, t_REAL, t_STR, t_VECSMALL */ { - if (tx == t_STR) - pariputs("chars:"); + if (tx == t_STR) + pariputs("chars:"); else if (tx == t_INT) - pariputsf("(%c,lgef=%ld):", vsigne(x), lgefint(x)); + pariputsf("(%c,lgef=%ld):", vsigne(x), lgefint(x)); else if (tx == t_REAL) - pariputsf("(%c,expo=%ld):", vsigne(x), expo(x)); + pariputsf("(%c,expo=%ld):", vsigne(x), expo(x)); if (nb<0) nb = (tx==t_INT)? lgefint(x): lx; if (tx == t_VECSMALL) nb = lx; for (i=1; i < nb; i++) sorstring(VOIR_STRING2,x[i]); @@ -1095,7 +1143,8 @@ texnome(char *v, long deg) void etatpile(unsigned int n) { - long av=avma,nu,i,l,m; + long nu, i, l, m; + gpmem_t av=avma; GEN adr,adr1; double r; @@ -1266,25 +1315,25 @@ isdenom(GEN g) /* write a * v^d */ static void -wr_monome(GEN a, char *v, long d) +wr_monome(pariout_t *T, GEN a, char *v, long d) { long sig = isone(a); - if (sig) { sp_sign_sp(sig); monome(v,d); } + if (sig) { sp_sign_sp(T,sig); monome(v,d); } else { sig = isfactor(a); - if (sig) { sp_sign_sp(sig); bruti(a,sig); } + if (sig) { sp_sign_sp(T,sig); bruti(a,T,sig); } else { - sp_plus_sp(); pariputc('('); bruti(a,sig); pariputc(')'); + sp_sign_sp(T,1); pariputc('('); bruti(a,T,sig); pariputc(')'); } if (d) { pariputc('*'); monome(v,d); } } } static void -wr_texnome(GEN a, char *v, long d) +wr_texnome(pariout_t *T, GEN a, char *v, long d) { long sig = isone(a); @@ -1292,21 +1341,21 @@ wr_texnome(GEN a, char *v, long d) else { sig = isfactor(a); - if (sig) { putsigne(sig); texi(a,sig); } + if (sig) { putsigne(sig); texi(a,T,sig); } else { - pariputs(" + \\left("); texi(a,sig); pariputs("\\right) "); + pariputs(" + \\left("); texi(a,T,sig); pariputs("\\right) "); } if (d) { - if (under_texmacs) pariputs("\\*"); + if (GP_DATA && (GP_DATA->flags & TEXMACS)) pariputs("\\*"); texnome(v,d); } } } static void -wr_lead_monome(GEN a, char *v, long d, long nosign) +wr_lead_monome(pariout_t *T, GEN a, char *v, long d, int nosign) { long sig = isone(a); if (sig) @@ -1316,17 +1365,17 @@ wr_lead_monome(GEN a, char *v, long d, long nosign) } else { - if (isfactor(a)) bruti(a,nosign); + if (isfactor(a)) bruti(a,T,nosign); else { - pariputc('('); bruti(a,0); pariputc(')'); + pariputc('('); bruti(a,T,0); pariputc(')'); } if (d) { pariputc('*'); monome(v,d); } } } static void -wr_lead_texnome(GEN a, char *v, long d, long nosign) +wr_lead_texnome(pariout_t *T, GEN a, char *v, long d, int nosign) { long sig = isone(a); if (sig) @@ -1336,21 +1385,21 @@ wr_lead_texnome(GEN a, char *v, long d, long nosign) } else { - if (isfactor(a)) texi(a,nosign); + if (isfactor(a)) texi(a,T,nosign); else { - pariputs(" \\left("); texi(a,0); pariputs("\\right) "); + pariputs(" \\left("); texi(a,T,0); pariputs("\\right) "); } if (d) { - if (under_texmacs) pariputs("\\*"); + if (GP_DATA && (GP_DATA->flags & TEXMACS)) pariputs("\\*"); texnome(v,d); } } } -static void -bruti(GEN g, long nosign) +void +bruti(GEN g, pariout_t *T, int nosign) { long tg,l,i,j,r; GEN a,b; @@ -1369,21 +1418,23 @@ bruti(GEN g, long nosign) switch(tg) { case t_SMALL: pariputsf("%ld",smalltos(g)); break; - case t_INT: wr_int(g,0,nosign); break; - case t_REAL: wr_real(g,nosign); break; + case t_INT: + if (!nosign && signe(g) < 0) pariputc('-'); + wr_intpos(g); break; + case t_REAL: wr_real(T,g,nosign); break; case t_INTMOD: case t_POLMOD: pariputs(new_fun_set? "Mod(": "mod("); - bruti((GEN)g[2],0); comma_sp(); - bruti((GEN)g[1],0); pariputc(')'); break; + bruti((GEN)g[2],T,0); comma_sp(T); + bruti((GEN)g[1],T,0); pariputc(')'); break; case t_FRAC: case t_FRACN: case t_RFRAC: case t_RFRACN: r = isfactor((GEN)g[1]); if (!r) pariputc('('); - bruti((GEN)g[1],nosign); + bruti((GEN)g[1],T,nosign); if (!r) pariputc(')'); pariputc('/'); r = isdenom((GEN)g[2]); if (!r) pariputc('('); - bruti((GEN)g[2],0); + bruti((GEN)g[2],T,0); if (!r) pariputc(')'); break; @@ -1391,21 +1442,21 @@ bruti(GEN g, long nosign) a = (GEN)g[r+1]; b = (GEN)g[r+2]; v = r? "w": "I"; if (isnull(a)) { - wr_lead_monome(b,v,1,nosign); + wr_lead_monome(T,b,v,1,nosign); return; } - bruti(a,nosign); - if (!isnull(b)) wr_monome(b,v,1); + bruti(a,T,nosign); + if (!isnull(b)) wr_monome(T,b,v,1); break; case t_POL: v = get_var(ordvar[varn(g)], buf); /* hack: we want g[i] = coeff of degree i. */ i = degpol(g); g += 2; while (isnull((GEN)g[i])) i--; - wr_lead_monome((GEN)g[i],v,i,nosign); + wr_lead_monome(T,(GEN)g[i],v,i,nosign); while (i--) { a = (GEN)g[i]; - if (!isnull_for_pol(a)) wr_monome(a,v,i); + if (!isnull_for_pol(a)) wr_monome(T,a,v,i); } break; @@ -1414,19 +1465,20 @@ bruti(GEN g, long nosign) if (signe(g)) { /* hack: we want g[i] = coeff of degree i. */ l = i + lg(g)-2; g += (2-i); - wr_lead_monome((GEN)g[i],v,i,nosign); + wr_lead_monome(T,(GEN)g[i],v,i,nosign); while (++i < l) { a = (GEN)g[i]; - if (!isnull_for_pol(a)) wr_monome(a,v,i); + if (!isnull_for_pol(a)) wr_monome(T,a,v,i); } - sp_plus_sp(); + sp_sign_sp(T,1); } pariputs("O("); monome(v,i); pariputc(')'); break; case t_PADIC: { GEN p = (GEN)g[2]; + gpmem_t av = avma; i = valp(g); l = precp(g)+i; g = (GEN)g[4]; v = GENtostr(p); for (; ifieldw = 0; switch (tg) { case t_SMALL: pariputsf("%ld",smalltos(g)); return; - case t_INT: wr_int(g,chmp,0); return; - case t_REAL: wr_real(g,0); return; + case t_REAL: wr_real(T,g,0); return; case t_STR: pariputc('"'); pariputs(GSTR(g)); pariputc('"'); return; case t_LIST: - chmp=0; pariputs("List("); + pariputs("List("); for (i=2; iinitial) { char *v1, *v2; long sd = 0, sn = 0, d,n; long wd = term_width(); - initial = 0; - v1 = GENtostr0((GEN)g[1], &sori); n = strlen(v1); - v2 = GENtostr0((GEN)g[2], &sori); d = strlen(v2); + T->initial = 0; + v1 = GENtostr0((GEN)g[1], T, &sori); n = strlen(v1); + v2 = GENtostr0((GEN)g[2], T, &sori); d = strlen(v2); pariputc('\n'); i = max(n,d)+2; @@ -1682,31 +1735,30 @@ sori(GEN g) blancs(sd+1); pariputs(v2); pariputc('\n'); return; } - pariputc('('); sori((GEN)g[1]); pariputs(" / "); sori((GEN)g[2]); + pariputc('('); sori((GEN)g[1],T); pariputs(" / "); sori((GEN)g[2],T); pariputc(')'); return; case t_QFR: case t_QFI: pariputc('{'); - sori((GEN)g[1]); pariputs(", "); - sori((GEN)g[2]); pariputs(", "); - sori((GEN)g[3]); - if (tg == t_QFR) { pariputs(", "); sori((GEN)g[4]); } + sori((GEN)g[1],T); pariputs(", "); + sori((GEN)g[2],T); pariputs(", "); + sori((GEN)g[3],T); + if (tg == t_QFR) { pariputs(", "); sori((GEN)g[4],T); } pariputs("}\n"); break; - case t_VEC: - chmp=0; pariputc('['); + case t_VEC: pariputc('['); for (i=1; ipp; + if (!pp->cmd) return 0; + if (!pp->file) + pp->file = try_pipe(pp->cmd, mf_OUT | mf_TEST); + if (pp->file) return 1; + + err(warner,"broken prettyprinter: '%s'",pp->cmd); + free(pp->cmd); pp->cmd = NULL; return 0; +} + +/* n = history number. if n = 0 no history */ +static int +tex2mail_output(GEN z, long n) +{ + pariout_t T = *(GP_DATA->fmt); /* copy */ + FILE *o_out; + + if (!prettyp_init()) return 0; + o_out = pari_outfile; /* save state */ + + /* Emit first: there may be lines before the prompt */ + if (n) term_color(c_OUTPUT); + pariflush(); + pari_outfile = GP_DATA->pp->file->file; + T.prettyp = f_TEX; + + /* history number */ + if (n) + { + char s[128]; + if (*term_get_color(c_HIST) || *term_get_color(c_OUTPUT)) + { + char col1[80]; + strcpy(col1, term_get_color(c_HIST)); + sprintf(s, "\\LITERALnoLENGTH{%s}\\%%%ld =\\LITERALnoLENGTH{%s} ", + col1, n, term_get_color(c_OUTPUT)); + } + else + sprintf(s, "\\%%%ld = ", n); + pariputs_opt(s); + } + /* output */ + gen_output(z, &T); + + /* flush and restore */ + prettyp_wait(); + pari_outfile = o_out; + if (n) term_color(c_NONE); + return 1; +} + +/* TEXMACS */ + +static void +texmacs_output(GEN z, long n) +{ + pariout_t T = *(GP_DATA->fmt); /* copy */ + char *sz; + + T.prettyp = f_TEX; + T.fieldw = 0; + sz = GENtostr0(z, &T, &gen_output); + printf("%clatex:", DATA_BEGIN); + if (n) + printf("\\magenta\\%%%ld = $\\blue ", n); + else + printf("$\\blue "); + printf("%s$%c", sz,DATA_END); free(sz); + fflush(stdout); +} + +/* REGULAR */ + +static void +normal_output(GEN z, long n) +{ + long l = 0; + /* history number */ + if (n) + { + char s[64]; + term_color(c_HIST); + sprintf(s, "%%%ld = ", n); + pariputs_opt(s); + l = strlen(s); + } + /* output */ + term_color(c_OUTPUT); + if (GP_DATA->lim_lines) + lim_lines_output(z, GP_DATA->fmt, l, GP_DATA->lim_lines); + else + gen_output(z, GP_DATA->fmt); + term_color(c_NONE); pariputc('\n'); +} + +void +gp_output(GEN z, gp_data *G) +{ + if (G->flags & TEST) { + init80(0); + gen_output(z, G->fmt); pariputc('\n'); + } + else if (G->flags & TEXMACS) + texmacs_output(z, G->hist->total); + else if (G->fmt->prettyp != f_PRETTY || !tex2mail_output(z, G->hist->total)) + normal_output(z, G->hist->total); + pariflush(); +} + +/*******************************************************************/ +/** **/ /** USER OUTPUT FUNCTIONS **/ /** **/ /*******************************************************************/ void -bruteall(GEN g, char f, long d, long flag) +gen_output(GEN x, pariout_t *T) { - long av = avma; - void (*oldsp)() = sp; + gpmem_t av = avma; + GEN y = changevar(x, polvar); + if (!T) T = &DFLT_OUTPUT; + T->initial = 1; + switch(T->prettyp) + { + case f_PRETTYMAT: matbruti(y, T); break; + case f_PRETTY: + case f_PRETTYOLD: sori (y, T); break; + case f_RAW : bruti(y, T, 0); break; + case f_TEX : texi (y, T, 0); break; + } + avma = av; +} - sp = flag? &wr_space: &no_space; - format = f; decimals = d; - bruti(changevar(g,polvar),0); - sp = oldsp; avma = av; +static void +_initout(pariout_t *T, char f, long sigd, long sp, long fieldw, int prettyp) +{ + T->format = f; + T->sigd = sigd; + T->sp = sp; + T->fieldw = fieldw; + T->initial = 1; + T->prettyp = prettyp; } void +bruteall(GEN g, char f, long d, long sp) +{ + pariout_t T; _initout(&T,f,d,sp,0, f_RAW); + gen_output(g, &T); +} + +void matbrute(GEN g, char f, long d) { - long av=avma; sp = &wr_space; - format = f; decimals = d; - matbruti(changevar(g,polvar),0); avma=av; + pariout_t T; _initout(&T,f,d,1,0, f_PRETTYMAT); + gen_output(g, &T); } void sor(GEN g, char f, long d, long c) { - long av=avma; sp = &wr_space; - format = f; decimals = d; chmp = c; initial = 1; - sori(changevar(g,polvar)); avma = av; + pariout_t T; _initout(&T,f,d,1,c, f_PRETTYOLD); + gen_output(g, &T); } void texe(GEN g, char f, long d) { - long av=avma; sp = &no_space; - format = f; decimals = d; - texi(changevar(g,polvar),0); avma=av; + pariout_t T; _initout(&T,f,d,0,0, f_TEX); + gen_output(g, &T); } void -brute(GEN g, char format, long decimals) { bruteall(g,format,decimals,1); } +brute(GEN g, char f, long d) { bruteall(g,f,d,1); } void outbrute(GEN g) { bruteall(g,'g',-1,1); } @@ -1968,10 +2179,10 @@ outbeauterr(GEN x) } void -bruterr(GEN x,char format,long decimals) +bruterr(GEN x,char format,long sigd) { PariOUT *out = pariOut; pariOut = pariErr; - bruteall(x,format,decimals,1); pariOut = out; + bruteall(x,format,sigd,1); pariOut = out; } void @@ -2103,6 +2314,21 @@ pari_unlink(char *s) fprintferr("I/O: removed file %s\n", s); } +void +check_filtre(filtre_t *T) +{ + if (T && T->in_string) + { + err(warner,"run-away string. Closing it"); + T->in_string = 0; + } + if (T && T->in_comment) + { + err(warner,"run-away comment. Closing it"); + T->in_comment = 0; + } +} + /* Remove one INFILE from the stack. Reset infile (to the most recent infile) * Return -1, if we're trying to pop out stdin itself; 0 otherwise * Check for leaked file handlers (temporary files) @@ -2111,8 +2337,6 @@ int popinfile() { pariFILE *f; - - filtre(NULL,NULL, f_ENDFILE); for (f = last_tmp_file; f; f = f->prev) { if (f->type & mf_IN) break; @@ -2159,7 +2383,7 @@ try_pipe(char *cmd, int fl) #else FILE *file; char *f; - VOLATILE int flag = fl; + int flag = fl; # ifdef __EMX__ if (_osmode == DOS_MODE) /* no pipes under DOS */ @@ -2179,17 +2403,15 @@ try_pipe(char *cmd, int fl) if (flag & mf_OUT) flag |= mf_PERM; if (flag & (mf_TEST | mf_OUT)) { - jmp_buf env; - void *c; - int i; if (DEBUGFILES) fprintferr("I/O: checking output pipe...\n"); - if (setjmp(env)) return NULL; - - c = err_catch(-1, env, NULL); - fprintf(file,"\n\n"); fflush(file); - for (i=1; i<1000; i++) fprintf(file," \n"); - fprintf(file,"\n"); fflush(file); - err_leave(&c); + CATCH(-1) { file = NULL; } + TRY { + int i; + fprintf(file,"\n\n"); fflush(file); + for (i=1; i<1000; i++) fprintf(file," \n"); + fprintf(file,"\n"); fflush(file); + } ENDCATCH; + if (!file) return NULL; } f = cmd; } @@ -2225,7 +2447,7 @@ os_read(long fd, char ch[], long s) DWORD chRead; ReadFile((HANDLE)fd, ch, s, &chRead, NULL); #else - read(fd,ch,s); + (void)read(fd,ch,s); #endif } @@ -2262,7 +2484,6 @@ os_getenv(char *s) /** **/ /*******************************************************************/ static char *last_filename = NULL; -static char **dir_list = NULL; #ifdef HAS_OPENDIR # include @@ -2339,10 +2560,8 @@ _expand_env(char *str) } if (xnum > xlen - 3) /* need room for possibly two more elts */ { - long xnew = xlen << 1; - x = (char **)gprealloc((void*)x, xlen * sizeof(char*), - xnew * sizeof(char*)); - xlen = xnew; + xlen <<= 1; + x = (char **)gprealloc((void*)x, xlen * sizeof(char*)); } s0 = ++s; /* skip $ */ @@ -2382,6 +2601,18 @@ expand_tilde(char *s) return _expand_env(_expand_tilde(s)); } +void +delete_dirs(gp_path *p) +{ + char **v = p->dirs, **dirs; + if (v) + { + p->dirs = NULL; /* in case of error */ + for (dirs = v; *dirs; dirs++) free(*dirs); + free(v); + } +} + #if defined __EMX__ || defined _WIN32 # define PATH_SEPARATOR ';' #else @@ -2389,29 +2620,26 @@ expand_tilde(char *s) #endif void -gp_expand_path(char *v) +gp_expand_path(gp_path *p) { - char **path, **old, *s; + char **dirs, *s, *v = p->PATH; int i, n = 0; + delete_dirs(p); v = pari_strdup(v); for (s=v; *s; s++) if (*s == PATH_SEPARATOR) { *s = 0; n++; } - path = (char**) gpmalloc((n + 2)*sizeof(char *)); + dirs = (char**) gpmalloc((n + 2)*sizeof(char *)); for (s=v, i=0; i<=n; i++) { char *end = s + strlen(s), *f = end; while (f > s && *--f == '/') *f = 0; - path[i] = expand_tilde(s); + dirs[i] = expand_tilde(s); s = end + 1; /* next path component */ } - path[i] = NULL; old = dir_list; dir_list = path; - if (old) - { - for (path=old; *path; path++) free(*path); - free(old); - } + free((void*)v); + dirs[i] = NULL; p->dirs = dirs; } /* name is a malloc'ed (existing) filename. Accept it as new infile @@ -2488,9 +2716,9 @@ switchin(char *name0) /* if name contains '/', don't use dir_list */ s=name; while (*s && *s != '/' && *s != '\\') s++; if (*s) { if (try_name(name)) return; } - else + else if (GP_DATA) { - char **tmp = dir_list; + char **tmp = GP_DATA->path->dirs; for ( ; *tmp; tmp++) { /* make room for '/' and '\0', try_name frees it */ s = gpmalloc(2 + strlen(*tmp) + strlen(name)); @@ -2501,12 +2729,21 @@ switchin(char *name0) err(openfiler,"input",name0); } +static int is_magic_ok(FILE *f); + void switchout(char *name) { if (name) { - FILE *f = fopen(name, "a"); + FILE *f = fopen(name, "r"); + if (f) + { + if (is_magic_ok(f)) + err(talker,"%s is a GP binary file. Please use writebin", name); + fclose(f); + } + f = fopen(name, "a"); if (!f) err(openfiler,"output",name); pari_outfile = f; } @@ -2532,7 +2769,7 @@ switchout(char *name) #define _cfwrite(a,b,c) _fwrite((a),sizeof(char),(b),(c)) #define BIN_GEN 0 -#define NAM_GEN 1 +#define NAM_GEN 1 static long rd_long(FILE *f) @@ -2610,7 +2847,7 @@ rdGEN(FILE *f) } GEN -readobj(FILE *f) +readobj(FILE *f, int *ptc) { int c = fgetc(f); GEN x = NULL; @@ -2633,7 +2870,7 @@ readobj(FILE *f) case EOF: break; default: err(talker,"unknown code in readobj"); } - return x; + *ptc = c; return x; } #define MAGIC "\020\001\022\011-\007\020" /* ^P^A^R^I-^G^P */ @@ -2657,7 +2894,7 @@ static int is_sizeoflong_ok(FILE *f) { char c; - return (fread(&c,1,1, f) == 1 && c == sizeof(long)); + return (fread(&c,1,1, f) == 1 && c == (char)sizeof(long)); } static int @@ -2685,7 +2922,7 @@ static void write_magic(FILE *f) { fprintf(f, MAGIC); - fprintf(f, "%c", sizeof(long)); + fprintf(f, "%c", (char)sizeof(long)); wr_long(ENDIAN_CHECK, f); wr_long(BINARY_VERSION, f); } @@ -2693,8 +2930,8 @@ write_magic(FILE *f) int file_is_binary(FILE *f) { - int c = fgetc(f), r = isprint(c); - ungetc(c,f); return (r == 0); + int c = fgetc(f); ungetc(c,f); + return (isprint(c) == 0 && isspace(c) == 0); } void @@ -2716,24 +2953,122 @@ writebin(char *name, GEN x) { entree *ep = varentries[v]; if (!ep) continue; - writenamedGEN(ep->value,ep->name,f); + writenamedGEN((GEN)ep->value,ep->name,f); } } fclose(f); } -/* read all objects in file and return last one */ +/* read all objects in f. If f contains BIN_GEN that would be silently ignored + * [i.e f contains more than one objet, not all of them 'named GENs'], return + * them all in a vector with clone bit set (special marker). */ GEN readbin(char *name, FILE *f) { - GEN y, x = NULL; - check_magic(name,f); - while ((y = readobj(f))) x = y; + gpmem_t av = avma; + GEN x,y,z; + int cx,cy; + check_magic(name,f); x = y = z = NULL; + cx = 0; /* gcc -Wall */ + while ((y = readobj(f, &cy))) + { + if (x && cx == BIN_GEN) z = z? concatsp(z, _vec(x)): _vec(x); + x = y; cx = cy; + } + if (z) + { + if (x && cx == BIN_GEN) z = z? concatsp(z, _vec(x)): _vec(x); + if (DEBUGLEVEL) + err(warner,"%ld unnamed objects read. Returning then in a vector", + lg(z)-1); + x = gerepilecopy(av, z); + setisclone(x); /* HACK */ + } return x; } /*******************************************************************/ /** **/ +/** GP I/O **/ +/** **/ +/*******************************************************************/ +/* print a sequence of (NULL terminated) GEN */ +void +print0(GEN *g, long flag) +{ + pariout_t T = GP_DATA? *(GP_DATA->fmt): DFLT_OUTPUT; /* copy */ + T.prettyp = flag; + for( ; *g; g++) + if (typ(*g)==t_STR) + pariputs(GSTR(*g)); /* text surrounded by "" otherwise */ + else + gen_output(*g, &T); +} + +#define PR_NL() {added_newline = 1; pariputc('\n'); pariflush(); } +#define PR_NO() {added_newline = 0; pariflush(); } +void print (GEN *g) { print0(g, f_RAW); PR_NL(); } +void printp (GEN *g) { print0(g, f_PRETTYOLD); PR_NL(); } +void printtex(GEN *g) { print0(g, f_TEX); PR_NL(); } +void print1 (GEN *g) { print0(g, f_RAW); PR_NO(); } +void printp1 (GEN *g) { print0(g, f_PRETTYOLD); PR_NO(); } + +void error0(GEN *g) { err(user, g); } + +static char * +wr_check(char *s) { + char *t = expand_tilde(s); + if (GP_DATA && GP_DATA->flags & SECURE) + { + fprintferr("[secure mode]: about to write to '%s'. OK ? (^C if not)\n",t); + hit_return(); + } + return t; +} + +static void wr_init(char *s) { char *t=wr_check(s); switchout(t); free(t);} +void gpwritebin(char *s, GEN x) { char *t=wr_check(s); writebin(t, x); free(t);} + +#define WR_NL() {pariputc('\n'); pariflush(); switchout(NULL); } +#define WR_NO() {pariflush(); switchout(NULL); } +void write0 (char *s, GEN *g) { wr_init(s); print0(g, f_RAW); WR_NL(); } +void writetex(char *s, GEN *g) { wr_init(s); print0(g, f_TEX); WR_NL(); } +void write1 (char *s, GEN *g) { wr_init(s); print0(g, f_RAW); WR_NO(); } + +/*******************************************************************/ +/** **/ +/** HISTORY HANDLING **/ +/** **/ +/*******************************************************************/ +/* history management function: + * p > 0, called from %p + * p <= 0, called from %` (p backquotes, possibly 0) */ +GEN +gp_history(gp_hist *H, long p, char *old, char *entry) +{ + GEN z; + + if (p <= 0) p += H->total; /* count |p| entries starting from last */ + if ((ulong)p > H->total) + err(talker2, "I can't see into the future", old, entry); + + z = H->res[ (p-1) % H->size ]; + if (!z || p <= 0 || p <= (long)(H->total - H->size)) + err(talker2, "I can't remember before the big bang", old, entry); + return z; +} + +GEN +set_hist_entry(gp_hist *H, GEN x) +{ + int i = H->total % H->size; + H->total++; + if (H->res[i]) gunclone(H->res[i]); + return H->res[i] = gclone(x); +} + +/*******************************************************************/ +/** **/ /** TEMPORARY FILES **/ /** **/ /*******************************************************************/ @@ -2804,7 +3139,7 @@ env_ok(char *s) } static char* -pari_tmp_dir() +pari_tmp_dir(void) { char *s; #ifdef WINCE