=================================================================== RCS file: /home/cvs/OpenXM_contrib/pari-2.2/src/language/Attic/anal.c,v retrieving revision 1.1.1.1 retrieving revision 1.3 diff -u -p -r1.1.1.1 -r1.3 --- OpenXM_contrib/pari-2.2/src/language/Attic/anal.c 2001/10/02 11:17:10 1.1.1.1 +++ OpenXM_contrib/pari-2.2/src/language/Attic/anal.c 2002/09/11 07:27:02 1.3 @@ -1,4 +1,4 @@ -/* $Id: anal.c,v 1.1.1.1 2001/10/02 11:17:10 noro Exp $ +/* $Id: anal.c,v 1.3 2002/09/11 07:27:02 noro Exp $ Copyright (C) 2000 The PARI group. @@ -22,6 +22,9 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, #include "anal.h" #include "parinf.h" +/* slightly more efficient than is_keyword_char. Not worth a static array. */ +#define is_key(c) (isalnum((int)(c)) || (c)=='_') + #define separe(c) ((c)==';' || (c)==':') typedef GEN (*PFGEN)(ANYARG); typedef GEN (*F2GEN)(GEN,GEN); @@ -31,12 +34,12 @@ static GEN constante(); static GEN expr(); static GEN facteur(); static GEN identifier(); -static GEN matrix_block(GEN p, entree *ep); static GEN read_member(GEN x); static GEN seq(); static GEN truc(); static long number(long *nb); static void doskipseq(char *s, int strict); +static void skip_matrix_block(); static void skipconstante(); static void skipexpr(); static void skipfacteur(); @@ -50,7 +53,8 @@ static entree *installep(void *f,char *name,int l,int static entree *skipentry(void); extern void killbloc0(GEN x, int inspect); -extern char *GENtostr0(GEN x, void(*do_out)(GEN)); +extern int term_width(void); +extern GEN addsmulsi(long a, long b, GEN Y); /* last time we began parsing an object of specified type */ static struct @@ -61,8 +65,7 @@ static struct /* when skipidentifier() detects that user function f() is being redefined, * (f()= ... ) this is set pointing to the opening parenthesis. Checked in * identifier(). Otherwise definition like f(x=1)= would change the value of - * global variable x - */ + * global variable x */ static char *redefine_fun = NULL; /* points to the part of the string that remains to be parsed */ @@ -75,14 +78,195 @@ static long skipping_fun_def; * being checked). Used by the compatibility engine in the following way: * when user types in a function whose name has changed, it is understood * as EpNEW; first syntax error (missing = after function definition - * usually) triggers err_new_fun() if check_new_fun is set. - */ + * usually) triggers err_new_fun() if check_new_fun is set. */ static entree *check_new_fun; /* for control statements (check_break) */ static long br_status, br_count; static GEN br_res = NULL; +/* Mnemonic codes parser: + * + * TEMPLATE is assumed to be ";"-separated list of items. Each item + * may have one of the following forms: id=value id==value id|value id&~value. + * Each id consists of alphanum characters, dashes and underscores. + * IDs are case-sensitive. + + * ARG consists of several IDs separated by punctuation (and optional + * whitespace). Each modifies the return value in a "natural" way: an + * ID from id=value should be the first in the sequence and sets RETVAL to + * VALUE (and cannot be negated), ID from id|value bit-ORs RETVAL with + * VALUE (and bit-ANDs RETVAL with ~VALUE if negated), ID from + * id&~value behaves as if it were noid|value, ID from + * id==value behaves the same as id=value, but should come alone. + + * For items of the form id|value and id&~value negated forms are + * allowed: either when arg looks like no[-_]id, or when id looks like + * this, and arg is not-negated. */ + +enum { A_ACTION_ASSIGN, A_ACTION_SET, A_ACTION_UNSET }; +enum { PARSEMNU_TEMPL_TERM_NL, PARSEMNU_ARG_WHITESP }; +#define IS_ID(c) (isalnum((int)c) || ((c) == '_') || ((c) == '-')) +#define ERR(reason) STMT_START { \ + if (failure && first) { \ + *failure = reason; *failure_arg = NULL; return 0; \ + } else err(talker,reason); } STMT_END +#define ERR2(reason,s) STMT_START { \ + if (failure && first) { \ + *failure = reason; *failure_arg = s; return 0; \ + } else err(talker,reason,s); } STMT_END + +unsigned long +parse_option_string(char *arg, char *template, long flag, char **failure, char **failure_arg) +{ + unsigned long retval = 0; + char *etemplate = NULL; + + if (flag & PARSEMNU_TEMPL_TERM_NL) + etemplate = strchr(template, '\n'); + if (!etemplate) + etemplate = template + strlen(template); + + if (failure) + *failure = NULL; + while (1) { + long numarg; + char *e, *id; + char *negated; /* action found with 'no'-ID */ + int negate; /* Arg has 'no' prefix removed */ + int l, action = 0, first = 1, singleton = 0; + char b[80], *buf, *inibuf; + + if (flag & PARSEMNU_ARG_WHITESP) + while (isspace((int)*arg)) arg++; + if (!*arg) + break; + e = arg; + while (IS_ID(*e)) + e++; + /* Now the ID is whatever is between arg and e. */ + l = e - arg; + if (l >= sizeof(b)) + ERR("id too long in a stringified flag"); + if (!l) /* Garbage after whitespace? */ + ERR("a stringified flag does not start with an id"); + strncpy(b, arg, l); + b[l] = 0; + arg = e; + e = inibuf = buf = b; + while (('0' <= *e) && (*e <= '9')) + e++; + if (*e == 0) + ERR("numeric id in a stringified flag"); + negate = 0; + negated = NULL; + find: + id = template; + while ((id = strstr(id, buf)) && id < etemplate) { + if (IS_ID(id[l])) { /* We do not allow abbreviations yet */ + id = id + l; /* False positive */ + continue; + } + if ((id >= template + 2) && (IS_ID(id[-1]))) { + char *s = id; + + if ( !negate && s >= template+3 + && ((id[-1] == '_') || (id[-1] == '-')) ) + s--; + /* Check whether we are preceeded by "no" */ + if ( negate /* buf initially started with "no" */ + || (s < template+2) || (s[-1] != 'o') || (s[-2] != 'n') + || (s >= template+3 && IS_ID(s[-3]))) { + id = id + l; /* False positive */ + continue; + } + /* Found noID in the template! */ + negated = id + l; + id = id + l; + continue; /* Try to find without 'no'. */ + } + /* Found as is */ + id = id + l; + break; + } + if ( !id && !negated && !negate + && (l > 2) && buf[0] == 'n' && buf[1] == 'o' ) { + /* Try to find the flag without the prefix "no". */ + buf += 2; l -= 2; + if ((buf[0] == '_') || (buf[0] == '-')) { buf++; l--; } + negate = 1; + if (buf[0]) + goto find; + } + if (!id && negated) { /* Negated and AS_IS forms, prefer AS_IS */ + id = negated; /* Otherwise, use negated form */ + negate = 1; + } + if (!id) + ERR2("Unrecognized id '%s' in a stringified flag", inibuf); + if (singleton && !first) + ERR("Singleton id non-single in a stringified flag"); + if (id[0] == '=') { + if (negate) + ERR("Cannot negate id=value in a stringified flag"); + if (!first) + ERR("Assign action should be first in a stringified flag"); + action = A_ACTION_ASSIGN; + id++; + if (id[0] == '=') { + singleton = 1; + id++; + } + } else if (id[0] == '^') { + if (id[1] != '~') + err(talker, "Unrecognized action in a template"); + id += 2; + if (negate) + action = A_ACTION_SET; + else + action = A_ACTION_UNSET; + } else if (id[0] == '|') { + id++; + if (negate) + action = A_ACTION_UNSET; + else + action = A_ACTION_SET; + } + + e = id; + + while ((*e >= '0' && *e <= '9')) e++; + while (isspace((int)*e)) + e++; + if (*e && (*e != ';') && (*e != ',')) + err(talker, "Non-numeric argument of an action in a template"); + numarg = atol(id); /* Now it is safe to get it... */ + switch (action) { + case A_ACTION_SET: + retval |= numarg; + break; + case A_ACTION_UNSET: + retval &= ~numarg; + break; + case A_ACTION_ASSIGN: + retval = numarg; + break; + default: + ERR("error in parse_option_string"); + } + first = 0; + if (flag & PARSEMNU_ARG_WHITESP) + while (isspace((int)*arg)) + arg++; + if (*arg && !(ispunct((int)*arg) && *arg != '-')) + ERR("Junk after an id in a stringified flag"); + /* Skip punctuation */ + if (*arg) + arg++; + } + return retval; +} + /* Special characters: * ' ', '\t', '\n', '\\' are forbidden internally (suppressed by filtre). * { } are forbidden everywhere and will be used to denote optional @@ -113,7 +297,8 @@ static GEN br_res = NULL; * or .entry * * truc: - * ! truc + * ! facteur + * or # facteur * or ' entry * or identifier * or constante @@ -168,13 +353,13 @@ static GEN br_res = NULL; * [0-9]+ */ char* -_analyseur(void) +get_analyseur(void) { return analyseur; } void -_set_analyseur(char *s) +set_analyseur(char *s) { analyseur = s; } @@ -183,7 +368,7 @@ _set_analyseur(char *s) static GEN lisseq0(char *t, GEN (*f)(void)) { - const ulong av = avma; + const gpmem_t av = avma; char *olds = analyseur, *olde = mark.start; GEN res; @@ -205,6 +390,8 @@ lisseq0(char *t, GEN (*f)(void)) return gerepilecopy(av, br_res); } if (res == NULL) { avma = av; return polx[fetch_user_var("NULL")]; } + /* ep->value, beware: it may be killed anytime. */ + if (isclone(res)) { avma = av; return forcecopy(res); } return gerepileupto(av, res); } @@ -212,7 +399,7 @@ lisseq0(char *t, GEN (*f)(void)) static GEN flisseq0(char *s, GEN (*f)(void)) { - char *t = filtre(s,NULL, f_INIT | f_REG); + char *t = filtre(s, (compatible == OLDALL)); GEN x = lisseq0(t, f); free(t); return x; } @@ -226,8 +413,13 @@ GEN flisexpr(char *s){ return flisseq0(s, expr);} GEN readseq(char *c, int strict) { + GEN z; check_new_fun=NULL; skipping_fun_def=0; - doskipseq(c, strict); return lisseq(c); + added_newline = 1; + doskipseq(c, strict); + z = lisseq0(c, seq); /* not lisseq: don't reset redefine_fun */ + if (!added_newline) pariputc('\n'); /* last output was print1() */ + return z; } entree * @@ -359,8 +551,9 @@ changevalue(entree *ep, GEN x) if (v == INITIAL) new_val_cell(ep,x, COPY_VAL); else { + x = gclone(x); /* beware: killbloc may destroy old x */ if (v->flag == COPY_VAL) killbloc((GEN)ep->value); else v->flag = COPY_VAL; - ep->value = (void*)gclone(x); + ep->value = (void*)x; } } @@ -440,7 +633,7 @@ kill0(entree *ep) static GEN seq(void) { - const ulong av = avma, lim = stack_lim(av,1); + const gpmem_t av = avma, lim = stack_lim(av,1); GEN res = gnil; for(;;) @@ -470,7 +663,7 @@ gshift_r(GEN x, GEN n) { return gshift(x,-itos(n)); } static GEN expr(void) { - ulong av = avma, lim = stack_lim(av,2); + gpmem_t av = avma, lim = stack_lim(av, 2); GEN aux,e,e1,e2,e3; F2GEN F1,F2,F3; int F0 = 0; @@ -606,12 +799,13 @@ err_match(char *s, char c) } #define match2(s,c) if (*s != c) err_match(s,c); -#define match(c) ({match2(analyseur, c); analyseur++;}) +#define match(c) \ + STMT_START { match2(analyseur, c); analyseur++; } STMT_END static long readlong() { - const ulong av = avma; + const gpmem_t av = avma; const char *old = analyseur; long m; GEN arg = expr(); @@ -670,8 +864,104 @@ do_switch(int noparen, int matchcomma) /** READ FUNCTIONS **/ /** **/ /********************************************************************/ +typedef struct matcomp +{ + GEN *ptcell; + GEN parent; + int full_col, full_row; + void *extra; /* so far used by check_pointers only */ +} matcomp; +/* Return the content of the matrix cell and sets members of corresponding + * matrix component 'c'. Assume *analyseur = '[' */ static GEN +matcell(GEN p, matcomp *C) +{ + GEN *pt = &p; + long c,r, tx; + int full_col, full_row; + tx = full_col = full_row = 0; + do { + analyseur++; p = *pt; tx = typ(p); + switch(tx) + { + case t_LIST: + c = check_array_index(lgef(p)-1) + 1; + pt = (GEN*)(p + c); match(']'); break; + + case t_VEC: case t_COL: + c = check_array_index(lg(p)); + pt = (GEN*)(p + c); match(']'); break; + + case t_VECSMALL: + c = check_array_index(lg(p)); + pt = (GEN*)(p + c); match(']'); + if (*analyseur == '[') err(caracer1,analyseur,mark.start); + break; + + case t_MAT: + if (lg(p)==1) err(talker2,"a 0x0 matrix has no elements", + analyseur,mark.start); + full_col = full_row = 0; + if (*analyseur==',') /* whole column */ + { + analyseur++; + c = check_array_index(lg(p)); + match(']'); + if (*analyseur == '[') + { /* collapse [,c][r] into [r,c] */ + analyseur++; + r = check_array_index(lg(p)); + pt = (GEN*)(((GEN)p[c]) + r); /* &coeff(p,r,c) */ + match(']'); + } + else + { + full_col = 1; + pt = (GEN*)(p + c); + } + break; + } + + r = check_array_index(lg(p[1])); + match(','); + if (*analyseur == ']') /* whole row */ + { + analyseur++; + if (*analyseur == '[') + { /* collapse [r,][c] into [r,c] */ + analyseur++; + c = check_array_index(lg(p)); + pt = (GEN*)(((GEN)p[c]) + r); /* &coeff(p,r,c) */ + match(']'); + } + else + { + GEN p2 = cgetg(lg(p),t_VEC); + full_row = r; /* record row number */ + for (c=1; cfull_row = full_row; + C->full_col = full_col; + C->parent = p; C->ptcell = pt; + return (tx == t_VECSMALL)? stoi((long)*pt): *pt; +} + +static GEN facteur(void) { const char *old = analyseur; @@ -697,13 +987,18 @@ facteur(void) case '^': analyseur++; p1 = facteur(); if (br_status) err(breaker,"here (after ^)"); - x = gpui(x,p1,prec); break; + x = gpow(x,p1,prec); break; case '\'': analyseur++; x = deriv(x,gvar9(x)); break; case '~': analyseur++; x = gtrans(x); break; case '[': - x = matrix_block(x,NULL); break; + { + matcomp c; + x = matcell(x, &c); + if (isonstack(x)) x = gcopy(x); + break; + } case '!': if (analyseur[1] != '=') { @@ -722,9 +1017,8 @@ _append(GEN **table, long *n, long *N) { if (++(*n) == *N) { - long M = *N; *N <<= 1; - *table = (GEN*)gprealloc((void*)*table, (M + 1)*sizeof(GEN), - (*N + 1)*sizeof(GEN)); + *N <<= 1; + *table = (GEN*)gprealloc((void*)*table,(*N + 1)*sizeof(GEN)); } (*table)[*n] = expr(); if (br_status) err(breaker,"array context"); @@ -742,7 +1036,7 @@ truc(void) if (*analyseur == '!') /* NOT */ { - analyseur++; p1 = truc(); + analyseur++; p1 = facteur(); if (br_status) err(breaker,"here (after !)"); return gcmp0(p1)? gun: gzero; } @@ -759,6 +1053,12 @@ truc(void) default: err(varer1,old,mark.start); } } + if (*analyseur == '#') /* CARD */ + { + analyseur++; p1 = facteur(); + if (br_status) err(breaker,"here (after #)"); + return stoi(glength(p1)); + } if (isalpha((int)*analyseur)) return identifier(); if (*analyseur == '"') return strtoGENstr_t(); @@ -805,32 +1105,41 @@ truc(void) free(table); return p1; case '%': - old = analyseur-1; p = 0; - if (!gp_history_fun) err(talker2,"history not available",old,mark.start); + old = analyseur-1; + if (!GP_DATA) err(talker2,"history not available", old, mark.start); + else + { + gp_hist *H = GP_DATA->hist; + p = 0; while (*analyseur == '`') { analyseur++; p++; } - return p ? gp_history_fun(p ,1,old,mark.start) - : gp_history_fun(number(&n),0,old,mark.start); + return p ? gp_history(H, -p , old, mark.start) + : gp_history(H, number(&n), old, mark.start); + } } err(caracer1,analyseur-1,mark.start); return NULL; /* not reached */ } /* valid x opop, e.g x++ */ -#ifdef INLINE -INLINE -#endif -int -repeated_op() +static GEN +double_op() { + static long mun[] = { evaltyp(t_INT) | _evallg(3), + evalsigne(-1)|evallgefint(3), 1 }; char c = *analyseur; - return c == analyseur[1] && (c == '+' || c == '-'); + if (c == analyseur[1]) + switch(c) + { + case '+': analyseur+=2; return gun; /* ++ */ + case '-': analyseur+=2; return mun; /* -- */ + } + return NULL; } /* return op if op= detected */ static F2GEN get_op_fun() { - F2GEN f; if (!*analyseur) return (F2GEN)NULL; /* op= constructs ? */ @@ -865,127 +1174,83 @@ get_op_fun() } static GEN -matrix_block(GEN p, entree *ep) +expr_ass() { - long tx,full_col,full_row,c,r; - char *old; - GEN res, *pt, cpt; + GEN res = expr(); + if (br_status) err(breaker,"assignment"); + return res; +} - tx = full_col = full_row = 0; pt = &p; - while (*analyseur == '[') +F2GEN +affect_block(GEN *res) +{ + F2GEN f; + GEN r; + if (*analyseur == '=') { - analyseur++; p = *pt; tx = typ(p); - switch(tx) - { - case t_LIST: - c = check_array_index(lgef(p)-1) + 1; - pt = (GEN*)(p + c); match(']'); break; - - case t_VEC: case t_COL: case t_VECSMALL: - c = check_array_index(lg(p)); - pt = (GEN*)(p + c); match(']'); break; - - case t_MAT: - if (lg(p)==1) err(talker2,"a 0x0 matrix has no elements", - analyseur,mark.start); - full_col = full_row = 0; - if (*analyseur==',') /* whole column */ - { - analyseur++; full_col = 1; - c = check_array_index(lg(p)); - pt = (GEN*)(p + c); match(']'); break; - } - - r = check_array_index(lg(p[1])); - match(','); - if (*analyseur == ']') /* whole row */ - { - GEN p2 = cgetg(lg(p),t_VEC); - analyseur++; - if (*analyseur != '[') full_row = r; - for (c=1; cparent, *pt = c->ptcell; + long i; + int full_row = c->full_row, full_col = c->full_col; + char *old = analyseur; - old = analyseur; res = expr(); - if (br_status) err(breaker,"assignment"); - res = f(cpt, res); - } - - /* assignment */ - if (!ep) err(caracer1,analyseur,mark.start); - - if (!tx) /* simple variable */ + if (typ(p) == t_VECSMALL) { - changevalue(ep,res); - return (GEN) ep->value; + if (typ(res) != t_INT || is_bigint(res)) + err(talker2,"not a suitable VECSMALL component",old,mark.start); + *pt = (GEN)itos(res); return res; } - - if (full_row) /* whole row (index r) */ + if (full_row) { if (typ(res) != t_VEC || lg(res) != lg(p)) err(caseer2,old,mark.start); - for (c=1; c *ptlimit) bp = realloc_buf(bp, len, ptbuf,ptlimit); @@ -1078,28 +1348,22 @@ static GEN any_string() { long n = 0, len = 16; - GEN p1, res = new_chunk(len + 1); + GEN res = new_chunk(len + 1); while (*analyseur) { - if (*analyseur == '"') - { - res[n++] = (long) strtoGENstr_t(); - continue; - } if (*analyseur == ')' || *analyseur == ';') break; if (*analyseur == ',') analyseur++; else { - p1 = expr(); + res[n++] = (long)expr(); if (br_status) err(breaker,"here (print)"); - res[n++] = (long) p1; } if (n == len) { long newlen = len << 1; - p1 = new_chunk(newlen + 1); + GEN p1 = new_chunk(newlen + 1); for (n = 0; n < len; n++) p1[n] = res[n]; res = p1; len = newlen; } @@ -1129,7 +1393,7 @@ strtoGENstr_t() old++; /* skip '"' */ n = (n+BYTES_IN_LONG) >> TWOPOTBYTES_IN_LONG; x = cgetg(n+1, t_STR); - translate(&old, GSTR(x), NULL,NULL); + (void)translate(&old, GSTR(x), NULL,NULL); return x; } @@ -1154,10 +1418,21 @@ strtoGENstr(char *s, long flag) return x; } +/* x = gzero: no default value, otherwise a t_STR, formal expression for + * default argument. Evaluate and return. */ static GEN -make_arg(GEN x) +make_arg(GEN x) { return (x==gzero)? x: geval(x); } + +static GEN +fun_seq(char *p) { - return (x==gzero)? x : geval(x); + GEN res = lisseq(p); + if (br_status != br_NONE) + br_status = br_NONE; + else + if (! is_universal_constant(res)) /* important for gnil */ + res = forcecopy(res); /* make result safe */ + return res; } /* p = NULL + array of variable numbers (longs) + function text */ @@ -1172,19 +1447,27 @@ call_fun(GEN p, GEN *arg, GEN *loc, int narg, int nloc for (i=0; i>=1) if (ptrs & 1) { - entree *e = pointer[i]; - GEN x = (GEN)e->value; - pop_val(e); - changevalue(e, x); + matcomp *c = init[i]; + GEN *pt = c->ptcell, x = gclone(*pt); + if (c->parent == NULL) + { + if (isclone(c->extra)) killbloc((GEN)c->extra); + *pt = x; + } + else + (void)change_compo(c, x); + free((void*)c); } } -#define match_comma() if (matchcomma) match(','); else matchcomma = 1 +#define match_comma() \ + STMT_START { if (matchcomma) match(','); else matchcomma = 1; } STMT_END +static void +skipdecl(void) +{ + if (*analyseur == ':') { analyseur++; skipexpr(); } +} + static long check_args() { @@ -1253,10 +1549,11 @@ check_args() err(paramer1, old, mark.start); } cell[0] = varn(initial_value(ep)); + skipdecl(); if (*analyseur == '=') { char *old = ++analyseur; - ulong av = avma; + gpmem_t av = avma; skipexpr(); cell[1] = lclone(_strtoGENstr(old, analyseur-old)); avma = av; @@ -1301,7 +1598,8 @@ static GEN num_deriv(void *call, GEN argvec[]) { GEN eps,a,b, y, x = argvec[0]; - long fpr,pr,l,e,ex, av = avma; + long fpr, pr, l, e, ex; + gpmem_t av = avma; if (!is_const_t(typ(x))) { a = do_call(call, x, argvec); @@ -1315,7 +1613,7 @@ num_deriv(void *call, GEN argvec[]) l = 2+pr; e = fpr * BITS_IN_HALFULONG; /* 1/2 required prec (in sig. bits) */ - eps = realun(l); setexpo(eps, -e); + eps = real2n(-e, l); y = fix(gsub(x, eps), l); a = do_call(call, y, argvec); y = fix(gadd(x, eps), l); b = do_call(call, y, argvec); setexpo(eps, e-1); @@ -1327,7 +1625,8 @@ static GEN num_derivU(GEN p, GEN *arg, GEN *loc, int narg, int nloc) { GEN eps,a,b, x = *arg; - long fpr,pr,l,e,ex, av = avma; + long fpr, pr, l, e, ex; + gpmem_t av = avma; if (!is_const_t(typ(x))) { @@ -1342,7 +1641,7 @@ num_derivU(GEN p, GEN *arg, GEN *loc, int narg, int nl l = 2+pr; e = fpr * BITS_IN_HALFULONG; /* 1/2 required prec (in sig. bits) */ - eps = realun(l); setexpo(eps, -e); + eps = real2n(-e, l); *arg = fix(gsub(x, eps), l); a = call_fun(p,arg,loc,narg,nloc); *arg = fix(gadd(x, eps), l); b = call_fun(p,arg,loc,narg,nloc); setexpo(eps, e-1); @@ -1357,7 +1656,8 @@ num_derivU(GEN p, GEN *arg, GEN *loc, int narg, int nl static GEN identifier(void) { - long m,i,av,matchcomma, deriv; + long m, i, matchcomma, deriv; + gpmem_t av; char *ch1; entree *ep; GEN res, newfun, ptr; @@ -1373,8 +1673,15 @@ identifier(void) long len, v; analyseur++; ch1 = analyseur; - if ((res = read_member((GEN)ep->value))) return res; - + if ((res = read_member((GEN)ep->value))) + { + if (*analyseur == '[') + { + matcomp c; + res = matcell(res, &c); + } + return res; + } /* define a new member function */ v = varn(initial_value(ep)); len = analyseur - ch1; @@ -1392,7 +1699,17 @@ identifier(void) ep->value = (void *)ptr; return gnil; } } - return matrix_block((GEN) ep->value,ep); + if (*analyseur != '[') + { /* whole variable, no component */ + F2GEN fun = affect_block(&res); + if (res) + { + if (fun) res = fun((GEN)ep->value, res); + changevalue(ep,res); + } + return (GEN)ep->value; + } + return matrix_block((GEN)ep->value); } ep = do_alias(ep); matchcomma = 0; #ifdef STACK_CHECK @@ -1407,7 +1724,8 @@ identifier(void) long fake; void *call = ep->value; GEN argvec[9]; - entree *pointers[9]; + matcomp *init[9]; + char *flags = NULL; deriv = (*analyseur == '\'' && analyseur[1] == '(') && analyseur++; if (*analyseur == '(') @@ -1437,7 +1755,7 @@ identifier(void) } if (*s == 'p') { argvec[i++] = (GEN) prec; s++; } - while (*s) + while (*s && *s != '\n') switch (*s++) { case 'G': /* GEN */ @@ -1467,11 +1785,20 @@ identifier(void) case '&': /* *GEN */ match_comma(); match('&'); mark.symbol=analyseur; { - entree *e = entry(); - push_val(e, (GEN)e->value); + matcomp *c = (matcomp*)malloc(sizeof(matcomp)); + entree *ep = entry(); + + if (*analyseur == '[') + (void)matcell((GEN)ep->value, c); + else + { + c->parent = NULL; + c->ptcell = (GEN*)&ep->value; + c->extra = (GEN*)ep->value; + } has_pointer |= (1 << i); - pointers[i] = e; - argvec[i++] = (GEN) &(e->value); break; + init[i] = c; + argvec[i++] = (GEN)c->ptcell; break; } /* Input position */ case 'E': /* expr */ @@ -1498,6 +1825,24 @@ identifier(void) *bp++ = 0; argvec[i++] = (GEN) buf; break; + case 'M': /* Mnemonic flag */ + match_comma(); argvec[i] = expr(); + if (br_status) err(breaker,"here (argument reading)"); + if (typ(argvec[i]) == t_STR) { + if (!flags) + flags = ep->code; + flags = strchr(flags, '\n'); /* Skip to the following '\n' */ + if (!flags) + err(talker, "not enough flags in string function signature"); + flags++; + argvec[i] = (GEN) parse_option_string((char*)(argvec[i] + 1), + flags, PARSEMNU_ARG_WHITESP | PARSEMNU_TEMPL_TERM_NL, + NULL, NULL); + } else + argvec[i] = (GEN)itos(argvec[i]); + i++; + break; + case 's': /* expanded string; empty arg yields "" */ match_comma(); if (*s == '*') /* any number of string objects */ @@ -1510,10 +1855,7 @@ identifier(void) while (*analyseur) { if (*analyseur == ',' || *analyseur == ')') break; - if (*analyseur == '"') - bp = readstring_i(bp, &buf,&limit); - else - bp = expand_string(bp, &buf,&limit); + bp = expand_string(bp, &buf,&limit); } *bp++ = 0; argvec[i++] = (GEN)buf; break; @@ -1592,7 +1934,7 @@ identifier(void) ((void (*)(ANYARG))call)(_ARGS_); res = gnil; break; } - if (has_pointer) check_pointer(has_pointer,pointers); + if (has_pointer) check_pointers(has_pointer,init); if (!noparen) match(')'); return res; } @@ -1671,7 +2013,9 @@ identifier(void) switch(EpVALENCE(ep)) { case EpGVAR: +#if 0 err(warner,"%s already declared global", ep->name); +#endif /* fall through */ case EpVAR: break; default: err(talker2,"symbol already in use",ch1,mark.start); @@ -1679,7 +2023,7 @@ identifier(void) analyseur=ch1; ep = entry(); if (*analyseur == '=') { - long av=avma; analyseur++; + gpmem_t av=avma; analyseur++; res = expr(); if (br_status) err(breaker,"here (defining global var)"); changevalue(ep, res); avma=av; @@ -1732,6 +2076,7 @@ identifier(void) { /* user supplied */ match_comma(); arglist[i] = expr(); + skipdecl(); /* we'd be redefining fun, but don't know it yet */ if (br_status) err(breaker,"here (reading function args)"); } } @@ -1770,16 +2115,21 @@ identifier(void) /* checking arguments */ match('('); ch1 = analyseur; narg = check_args(); nloc = 0; - match(')'); match('='); - while (strncmp(analyseur,"local(",6) == 0) - { - analyseur += 6; - nloc += check_args(); - match(')'); while(separe(*analyseur)) analyseur++; - } + match(')'); + /* Dirty, but don't want to define a local() function */ + if (*analyseur != '=' && strcmp(ep->name, "local") == 0) + err(talker2, "local() bloc must appear before any other expression", + mark.identifier,mark.start); + match('='); { /* checking function definition */ char *oldredef = redefine_fun; skipping_fun_def++; + while (strncmp(analyseur,"local(",6) == 0) + { + analyseur += 6; + nloc += check_args(); + match(')'); while(separe(*analyseur)) analyseur++; + } start = analyseur; skipseq(); len = analyseur-start; skipping_fun_def--; redefine_fun = oldredef; } @@ -1821,7 +2171,7 @@ identifier(void) ep->value = (void *)ptr; ep->valence = EpUSER; check_new_fun=NULL; - avma = (long)tmpargs; return gnil; + avma = (gpmem_t)tmpargs; return gnil; } } err(valencer1); return NULL; /* not reached */ @@ -1836,14 +2186,13 @@ number(long *nb) return m; } -extern GEN addsmulsi(long a, long b, GEN Y); - static GEN constante() { static long pw10[] = { 1, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000, 1000000000 }; - long i,l,m,n = 0,nb, av = avma; + long i, l, m, n = 0, nb; + gpmem_t av = avma; GEN z,y; y = stoi(number(&nb)); i = 0; @@ -1857,6 +2206,9 @@ constante() { default: return y; /* integer */ case '.': + if (isalpha((int)analyseur[1]) + && analyseur[1] != 'e' && analyseur[1] != 'E') + return y; /* member function */ analyseur++; i = 0; while (isdigit((int)*analyseur)) { @@ -1892,13 +2244,13 @@ constante() l=lgefint(y); if (l