/* $Id: anal.c,v 1.112 2002/09/08 20:50:02 karim Exp $ Copyright (C) 2000 The PARI group. This file is part of the PARI/GP package. PARI/GP is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation. It is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY WHATSOEVER. Check the License for details. You should have received a copy of it, along with the package; see the file 'COPYING'. If not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ /*******************************************************************/ /* */ /* SYNTACTICAL ANALYZER FOR GP */ /* */ /*******************************************************************/ #include "pari.h" #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); typedef GEN (*F1GEN)(GEN); static GEN constante(); static GEN expr(); static GEN facteur(); static GEN identifier(); 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(); static void skipidentifier(); static void skipseq(); static void skipstring(); static void skiptruc(); static GEN strtoGENstr_t(); static entree *entry(); static entree *installep(void *f,char *name,int l,int v,int add,entree **table); static entree *skipentry(void); extern void killbloc0(GEN x, int inspect); 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 { char *identifier, *symbol, *raw, *member, *start; } mark; /* 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 */ static char *redefine_fun = NULL; /* points to the part of the string that remains to be parsed */ static char *analyseur = NULL; /* when non-0, we are checking the syntax of a new function body */ static long skipping_fun_def; /* when non-NULL, points to the entree of a new user function (currently * 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. */ 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 * lexemes in the sequel. * * Definitions: The sequence * { a }* means any number (possibly 0) of object a. * * seq: only this one can be empty. * expr { [:;] expr }* { [:;] } * * expr: * expression = sequence of "facteurs" separated by binary operators * whose priority are: * 1: *, /, \, \/, %, >>, << (highest) * 2: +, - * 3: <, <=, >, >=, !=, ==, <> * 4: &, &&, |, || (lowest) * read from left to right. * * facteur: * { [+-] } followed by a "truc", then by any succession of the * following: * * ~, ', ! * or ^ facteur * or matrix_index { matrix_index }* * or .entry * * truc: * ! facteur * or # facteur * or ' entry * or identifier * or constante * or string {string}* * or matrix * or ( expr ) * or % { ` }* or %number * * identifier: * entry followed by optional * * matrix_assignment_block * or .entry { = seq } * or {'} ( arg_list ) * or ( arg_list ) = seq * * arg_list * { arg } { , arg }* * * arg: * expr or &entry * Note: &entry (pointer) not yet implemented for user functions * * matrix * [ A { ; A}* ] where A = { expr } { , { expr } }* * All A must share the same length. * * matrix_index: * [ expr {,} ] * or [ { expr } , expr ] * * matrix_assignment_block: * { matrix_index } followed by * = expr * or ++ or -- * or op= expr where op is one of the operators in expr 1: and 2: * * entry: * [A-Za-z][A-Za-z0-9_]* * * string: * " any succession of characters [^\]" * * constante: * number { . [0-9]* } { expo } * or .{number} { expo } * * expo: * [eE] {[+-]} { number } * * number: * [0-9]+ */ char* get_analyseur(void) { return analyseur; } void set_analyseur(char *s) { analyseur = s; } /* Do not modify (analyseur,mark.start) */ static GEN lisseq0(char *t, GEN (*f)(void)) { const gpmem_t av = avma; char *olds = analyseur, *olde = mark.start; GEN res; if (foreignExprHandler && *t == foreignExprSwitch) return (*foreignExprHandler)(t); redefine_fun = NULL; check_new_fun = NULL; skipping_fun_def = 0; mark.start = analyseur = t; br_status = br_NONE; if (br_res) { killbloc(br_res); br_res = NULL; } res = f(); analyseur = olds; mark.start = olde; if (br_status != br_NONE) { if (!br_res) { avma = av; return gnil; } 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); } /* filtered lisexpr = remove blanks and comments */ static GEN flisseq0(char *s, GEN (*f)(void)) { char *t = filtre(s, (compatible == OLDALL)); GEN x = lisseq0(t, f); free(t); return x; } GEN lisseq(char *t) { return lisseq0(t, seq); } GEN lisexpr(char *t) { return lisseq0(t, expr); } GEN flisseq(char *s) { return flisseq0(s, seq); } GEN flisexpr(char *s){ return flisseq0(s, expr);} /* check syntax, then execute */ GEN readseq(char *c, int strict) { GEN z; check_new_fun=NULL; skipping_fun_def=0; 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 * install(void *f, char *name, char *code) { long hash; entree *ep = is_entry_intern(name, functions_hash, &hash); if (ep) err(warner,"[install] '%s' already there. Not replaced", name); else { char *s = name; if (isalpha((int)*s)) while (is_keyword_char(*++s)) /* empty */; if (*s) err(talker2,"not a valid identifier", s, name); ep = installep(f, name, strlen(name), EpINSTALL, 0, functions_hash + hash); ep->code = pari_strdup(code); } return ep; } static void free_args(gp_args *f) { long i; GEN *y = f->arg; for (i = f->narg + f->nloc - 1; i>=0; i--) if (isclone(y[i])) gunclone(y[i]); } void freeep(entree *ep) { if (foreignFuncFree && ep->code && (*ep->code == 'x')) (*foreignFuncFree)(ep); /* function created by foreign interpreter */ if (EpSTATIC(ep)) return; /* gp function loaded at init time */ if (ep->help) free(ep->help); if (ep->code) free(ep->code); if (ep->args) { switch(EpVALENCE(ep)) { case EpVAR: case EpGVAR: break; default: free_args((gp_args*)ep->args); } free((void*)ep->args); } free(ep); } /*******************************************************************/ /* */ /* VARIABLES */ /* */ /*******************************************************************/ /* As a rule, ep->value is a clone (COPY). push_val and pop_val are private * functions for use in sumiter: we want a temporary ep->value, which is NOT * a clone (PUSH), to avoid unnecessary copies. */ /* ep->args is the stack of old values (INITIAL if initial value, from * installep) */ typedef struct var_cell { struct var_cell *prev; /* cell associated to previous value on stack */ GEN value; /* last value (not including current one, in ep->value) */ char flag; /* status of _current_ ep->value: PUSH or COPY ? */ } var_cell; #define INITIAL NULL #define PUSH_VAL 0 #define COPY_VAL 1 #define copyvalue(v,x) new_val_cell(get_ep(v), x, COPY_VAL) #define pushvalue(v,x) new_val_cell(get_ep(v), x, PUSH_VAL) #define killvalue(v) pop_val(get_ep(v)) /* Push x on value stack associated to ep. Assume EpVALENCE(ep)=EpVAR/EpGVAR */ static void new_val_cell(entree *ep, GEN x, char flag) { var_cell *v = (var_cell*) gpmalloc(sizeof(var_cell)); v->value = (GEN)ep->value; v->prev = (var_cell*) ep->args; v->flag = flag; ep->args = (void*) v; ep->value = (flag == COPY_VAL)? gclone(x): x; } void push_val(entree *ep, GEN a) { new_val_cell(ep,a,PUSH_VAL); } /* kill ep->value and replace by preceding one, poped from value stack */ void pop_val(entree *ep) { var_cell *v = (var_cell*) ep->args; if (v == INITIAL) return; if (v->flag == COPY_VAL) killbloc((GEN)ep->value); ep->value = v->value; ep->args = (void*) v->prev; free((void*)v); } /* as above IF ep->value was PUSHed, or was created after block number 'loc' return 0 if not deleted, 1 otherwise [for recover()] */ int pop_val_if_newer(entree *ep, long loc) { var_cell *v = (var_cell*) ep->args; if (v == INITIAL) return 0; if (v->flag == COPY_VAL) { GEN x = (GEN)ep->value; if (bl_num(x) < loc) return 0; /* older */ killbloc((GEN)ep->value); } ep->value = v->value; ep->args = (void*) v->prev; free((void*)v); return 1; } /* set new value of ep directly to val (COPY), do not save last value unless * it's INITIAL. */ void changevalue(entree *ep, GEN x) { var_cell *v = (var_cell*) ep->args; 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*)x; } } /* as above, but PUSH, notCOPY */ void changevalue_p(entree *ep, GEN x) { var_cell *v = (var_cell*) ep->args; if (v == INITIAL) new_val_cell(ep,x, PUSH_VAL); else { if (v->flag == COPY_VAL) { killbloc((GEN)ep->value); v->flag = PUSH_VAL; } ep->value = (void*)x; } } void kill_from_hashlist(entree *ep) { long hash = hashvalue(ep->name); entree *ep1; if (functions_hash[hash] == ep) { functions_hash[hash] = ep->next; freeep(ep); return; } for (ep1 = functions_hash[hash]; ep1; ep1 = ep1->next) if (ep1->next == ep) { ep1->next = ep->next; freeep(ep); return; } } static entree* get_ep(long v) { entree *ep = varentries[v]; if (!ep) err(talker2,"this function uses a killed variable", mark.identifier, mark.start); return ep; } /* Kill entree ep, i.e free all memory it occupies, remove it from hashtable. * If it's a variable set a "black hole" in polx[v], etc. x = 0-th variable * can NOT be killed (only the value), because we often use explicitly polx[0] */ void kill0(entree *ep) { long v; if (EpSTATIC(ep)) err(talker2,"can't kill that",mark.symbol,mark.start); switch(EpVALENCE(ep)) { case EpVAR: case EpGVAR: v = varn(initial_value(ep)); killvalue(v); if (!v) return; /* never kill x */ polx[v] = polun[v] = gnil; polvar[v+1] = (long)gnil; varentries[v] = NULL; break; case EpUSER: gunclone((GEN)ep->value); break; } kill_from_hashlist(ep); } /*******************************************************************/ /* */ /* PARSER */ /* */ /*******************************************************************/ static GEN seq(void) { const gpmem_t av = avma, lim = stack_lim(av,1); GEN res = gnil; for(;;) { while (separe(*analyseur)) analyseur++; if (!*analyseur || *analyseur == ')' || *analyseur == ',') return res; res = expr(); if (br_status || !separe(*analyseur)) return res; if (low_stack(lim, stack_lim(av,1))) { if(DEBUGMEM>1) err(warnmem,"seq"); if (is_universal_constant(res)) avma = av; else res = gerepilecopy(av, res); } } } static GEN gshift_l(GEN x, GEN n) { return gshift(x, itos(n)); } static GEN gshift_r(GEN x, GEN n) { return gshift(x,-itos(n)); } #define UNDEF (GEN)0x1 static GEN expr(void) { gpmem_t av = avma, lim = stack_lim(av, 2); GEN aux,e,e1,e2,e3; F2GEN F1,F2,F3; int F0 = 0; F1 = F2 = F3 = (F2GEN)NULL; e1 = e2 = e3 = UNDEF; L3: aux = facteur(); if (br_status) return NULL; e3 = F3? F3(e3,aux): aux; switch(*analyseur) { case '*': analyseur++; F3 = &gmul; goto L3; case '/': analyseur++; F3 = &gdiv; goto L3; case '%': analyseur++; F3 = &gmod; goto L3; case '\\': if (analyseur[1] != '/') { analyseur++; F3 = &gdivent; goto L3; } analyseur += 2; F3=&gdivround; goto L3; case '<': if (analyseur[1] != '<') break; analyseur += 2; F3 = &gshift_l; goto L3; case '>': if (analyseur[1] != '>') break; analyseur += 2; F3 = &gshift_r; goto L3; } F3 = (F2GEN)NULL; L2: if (e3 == UNDEF) goto L3; e2 = F2? F2(e2,e3): e3; e3 = UNDEF; if (low_stack(lim, stack_lim(av,2))) { GEN *gptr[2]; gptr[0]=&e2; gptr[1]=&e1; if(DEBUGMEM>1) err(warnmem,"expr"); gerepilemany(av,gptr,(e1==UNDEF)?1: 2); } switch(*analyseur) { case '+': analyseur++; F2=&gadd; goto L3; case '-': analyseur++; F2=&gsub; goto L3; } F2 = (F2GEN)NULL; L1: if (e2 == UNDEF) goto L2; e1 = F1? F1(e1,e2): e2; e2 = UNDEF; switch(*analyseur) { case '<': switch(*++analyseur) { case '=': analyseur++; F1=&gle; goto L2; case '>': analyseur++; F1=⪈ goto L2; } F1=&glt; goto L2; case '>': if (*++analyseur == '=') { analyseur++; F1=&gge; goto L2; } F1=&ggt; goto L2; case '=': if (analyseur[1] == '=') { analyseur+=2; F1=≥ goto L2; } goto L1; case '!': if (analyseur[1] == '=') { analyseur+=2; F1=⪈ goto L2; } goto L1; } F1 = (F2GEN)NULL; /* L0: */ if (e1 == UNDEF) goto L1; e = F0? (gcmp0(e1)? gzero: gun): e1; e1 = UNDEF; switch(*analyseur) { case '&': if (*++analyseur == '&') analyseur++; if (gcmp0(e)) { skipexpr(); return gzero; } F0=1; goto L1; case '|': if (*++analyseur == '|') analyseur++; if (!gcmp0(e)) { skipexpr(); return gun; } F0=1; goto L1; } return e; } #undef UNDEF /********************************************************************/ /** **/ /** CHECK FUNCTIONS **/ /** **/ /********************************************************************/ /* Should raise an error. If neighbouring identifier was a function in * 1.39.15, raise "obsolete" error instead. If check_new_fun doesn't help, * guess offending function was last identifier */ #define LEN 127 static void err_new_fun() { char s[LEN+1], *t; int n; if (check_new_fun == NOT_CREATED_YET) check_new_fun = NULL; t = check_new_fun? check_new_fun->name: mark.identifier; for (n=0; n < LEN; n++) if (!is_keyword_char(t[n])) break; (void)strncpy(s,t, n); s[n] = 0; if (check_new_fun) { kill0(check_new_fun); check_new_fun = NULL ; } if (compatible != NONE) return; if (whatnow_fun) n = whatnow_fun(s,1); else n = is_entry_intern(s,funct_old_hash,NULL)? 1: 0; if (n) err(obsoler,mark.identifier,mark.start, s,n); } #undef LEN static void err_match(char *s, char c) { char str[64]; if (check_new_fun && (c == '(' || c == '=' || c == ',')) err_new_fun(); sprintf(str,"expected character: '%c' instead of",c); err(talker2,str,s,mark.start); } #define match2(s,c) if (*s != c) err_match(s,c); #define match(c) \ STMT_START { match2(analyseur, c); analyseur++; } STMT_END static long readlong() { const gpmem_t av = avma; const char *old = analyseur; long m; GEN arg = expr(); if (br_status) err(breaker,"here (reading long)"); if (typ(arg) != t_INT) err(caseer,old,mark.start); m = itos(arg); avma=av; return m; } static long check_array_index(long max) { const char *old = analyseur; const long c = readlong(); if (c < 1 || c >= max) { char s[80]; sprintf(s,"array index (%ld) out of allowed range ",c); if (max == 1) strcat(s, "[none]"); else if (max == 2) strcat(s, "[1]"); else sprintf(s,"%s[1-%ld]",s,max-1); err(talker2,s,old,mark.start); } return c; } static long readvar() { const char *old = analyseur; const GEN x = expr(); if (typ(x) != t_POL || lgef(x) != 4 || !gcmp0((GEN)x[2]) || !gcmp1((GEN)x[3])) err(varer1,old,mark.start); return varn(x); } /* noparen = 1 means function was called without (). Do we need to insert a * default argument ? */ static int do_switch(int noparen, int matchcomma) { const char *s = analyseur; if (noparen || !*s || *s == ')' || separe(*s)) return 1; if (*s == ',') /* we just read an arg, or first arg */ { if (!matchcomma && s[-1] == '(') return 1; /* first arg */ if (s[1] == ',' || s[1] == ')') { analyseur++; return 1; } } return 0; } /********************************************************************/ /** **/ /** 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; GEN x,p1; int plus=1; switch(*analyseur) { case '-': plus=0; /* fall through */ case '+': analyseur++; break; } x = truc(); if (br_status) return NULL; for(;;) switch(*analyseur) { case '.': analyseur++; x = read_member(x); if (!x) err(talker2, "not a proper member definition", mark.member, mark.start); break; case '^': analyseur++; p1 = facteur(); if (br_status) err(breaker,"here (after ^)"); x = gpow(x,p1,prec); break; case '\'': analyseur++; x = deriv(x,gvar9(x)); break; case '~': analyseur++; x = gtrans(x); break; case '[': { matcomp c; x = matcell(x, &c); if (isonstack(x)) x = gcopy(x); break; } case '!': if (analyseur[1] != '=') { if (typ(x) != t_INT) err(caseer,old,mark.start); analyseur++; x=mpfact(itos(x)); break; } /* Fall through */ default: return (plus || x==gnil)? x: gneg(x); } } /* table array of length N+1, append one expr, growing array if necessary */ static void _append(GEN **table, long *n, long *N) { if (++(*n) == *N) { *N <<= 1; *table = (GEN*)gprealloc((void*)*table,(*N + 1)*sizeof(GEN)); } (*table)[*n] = expr(); if (br_status) err(breaker,"array context"); } #define check_var_name() \ if (!isalpha((int)*analyseur)) err(varer1,analyseur,mark.start); static GEN truc(void) { long N,i,j,m,n,p; GEN *table,p1; char *old; if (*analyseur == '!') /* NOT */ { analyseur++; p1 = facteur(); if (br_status) err(breaker,"here (after !)"); return gcmp0(p1)? gun: gzero; } if (*analyseur == '\'') /* QUOTE */ { const char* old; entree *ep; analyseur++; check_var_name(); old = analyseur; ep = entry(); switch(EpVALENCE(ep)) { case EpVAR: case EpGVAR: return (GEN)initial_value(ep); 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(); if (isdigit((int)*analyseur) || *analyseur == '.') return constante(); switch(*analyseur++) { case '(': p1=expr(); match(')'); return p1; case '[': /* constant array/vector */ if (*analyseur == ';' && analyseur[1] == ']') { analyseur += 2; return cgetg(1,t_MAT); } /* [;] */ n = 0; N = 1024; table = (GEN*) gpmalloc((N + 1)*sizeof(GEN)); if (*analyseur != ']') _append(&table, &n, &N); while (*analyseur == ',') { analyseur++; _append(&table, &n, &N); } switch (*analyseur++) { case ']': { long tx; if (*analyseur == '~') { analyseur++; tx=t_COL; } else tx=t_VEC; p1 = cgetg(n+1,tx); for (i=1; i<=n; i++) p1[i] = lcopy(table[i]); break; } case ';': m = n; do _append(&table, &n, &N); while (*analyseur++ != ']'); p1 = cgetg(m+1,t_MAT); p = n/m + 1; for (j=1; j<=m; j++) { GEN c = cgetg(p,t_COL); p1[j] = (long)c; for (i=j; i<=n; i+=m) *++c = lcopy(table[i]); } break; default: /* can only occur in library mode */ err(talker,"incorrect vector or matrix"); return NULL; /* not reached */ } free(table); return p1; case '%': 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(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++ */ static GEN double_op() { static long mun[] = { evaltyp(t_INT) | _evallg(3), evalsigne(-1)|evallgefint(3), 1 }; char c = *analyseur; 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() { if (!*analyseur) return (F2GEN)NULL; /* op= constructs ? */ if (analyseur[1] == '=') { switch(*analyseur) { case '+' : analyseur += 2; return &gadd; case '-' : analyseur += 2; return &gsub; case '*' : analyseur += 2; return &gmul; case '/' : analyseur += 2; return &gdiv; case '\\': analyseur += 2; return &gdivent; case '%' : analyseur += 2; return &gmod; } } else if (analyseur[2] == '=') { switch(*analyseur) { case '>' : if (analyseur[1]=='>') { analyseur += 3; return &gshift_r; } break; case '<' : if (analyseur[1]=='<') { analyseur += 3; return &gshift_l; } break; case '\\': if (analyseur[1]=='/') { analyseur += 3; return &gdivround; } break; } } return (F2GEN)NULL; } static GEN expr_ass() { GEN res = expr(); if (br_status) err(breaker,"assignment"); return res; } F2GEN affect_block(GEN *res) { F2GEN f; GEN r; if (*analyseur == '=') { r = NULL; f = NULL; if (analyseur[1] != '=') { analyseur++; r = expr_ass(); } } else if ((r = double_op())) f = &gadd; else if ((f = get_op_fun())) r = expr_ass(); *res = r; return f; } /* assign res at *pt in "simple array object" p */ static GEN change_compo(matcomp *c, GEN res) { GEN p = c->parent, *pt = c->ptcell; long i; int full_row = c->full_row, full_col = c->full_col; char *old = analyseur; if (typ(p) == t_VECSMALL) { 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) { if (typ(res) != t_VEC || lg(res) != lg(p)) err(caseer2,old,mark.start); for (i=1; i *ptlimit) bp = realloc_buf(bp, len, ptbuf,ptlimit); memcpy(bp,tmp,len); /* ignore trailing \0 */ if (alloc) free(tmp); return bp + len; } static char * translate(char **src, char *s, char **ptbuf, char **ptlim) { char *t = *src; while (*t) { while (*t == '\\') { switch(*++t) { case 'e': *s='\033'; break; /* escape */ case 'n': *s='\n'; break; case 't': *s='\t'; break; default: *s=*t; if (!*t) err(talker,"unfinished string"); } t++; s++; } if (*t == '"') { if (t[1] != '"') break; t += 2; continue; } if (ptlim && s >= *ptlim) s = realloc_buf(s,1, ptbuf,ptlim); *s++ = *t++; } *s=0; *src=t; return s; } static char * readstring_i(char *s, char **ptbuf, char **ptlim) { match('"'); s = translate(&analyseur,s, ptbuf,ptlim); match('"'); return s; } static GEN any_string() { long n = 0, len = 16; GEN res = new_chunk(len + 1); while (*analyseur) { if (*analyseur == ')' || *analyseur == ';') break; if (*analyseur == ',') analyseur++; else { res[n++] = (long)expr(); if (br_status) err(breaker,"here (print)"); } if (n == len) { long newlen = len << 1; GEN p1 = new_chunk(newlen + 1); for (n = 0; n < len; n++) p1[n] = res[n]; res = p1; len = newlen; } } res[n] = 0; /* end the sequence with NULL */ return res; } /* Read a "string" from src. Format then copy it, starting at s. Return * pointer to the \0 which terminates the string. */ char * readstring(char *src, char *s) { match2(src, '"'); src++; s = translate(&src, s, NULL,NULL); match2(src, '"'); return s; } static GEN strtoGENstr_t() { char *old = analyseur; long n; GEN x; skipstring(); n = analyseur-old - 1; /* don't count the enclosing '"' */ old++; /* skip '"' */ n = (n+BYTES_IN_LONG) >> TWOPOTBYTES_IN_LONG; x = cgetg(n+1, t_STR); (void)translate(&old, GSTR(x), NULL,NULL); return x; } /* return the first n0 chars of s as a GEN [s may not be 0­terminated] */ static GEN _strtoGENstr(char *s, long n0) { long n = (n0+1+BYTES_IN_LONG) >> TWOPOTBYTES_IN_LONG; GEN x = cgetg(n+1, t_STR); char *t = GSTR(x); strncpy(t, s, n0); t[n0] = 0; return x; } GEN strtoGENstr(char *s, long flag) { GEN x; if (flag) s = expand_tilde(s); x = _strtoGENstr(s, strlen(s)); if (flag) free(s); 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) { return (x==gzero)? x: geval(x); } static GEN fun_seq(char *p) { 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 */ static GEN call_fun(GEN p, GEN *arg, GEN *loc, int narg, int nloc) { GEN res; long i; p++; /* skip NULL */ /* push new values for formal parameters */ for (i=0; ivalence == EpALIAS) ep = (entree *) ((GEN)ep->value)[1]; return ep; } static GEN global0() { GEN res = gnil; long i,n; for (i=0,n=lg(polvar)-1; n>=0; n--) { entree *ep = varentries[n]; if (ep && EpVALENCE(ep) == EpGVAR) { res=new_chunk(1); res[0]=(long)polx[n]; i++; } } if (i) { res = cgetg(1,t_VEC); setlg(res, i+1); } return res; } static void check_pointers(unsigned int ptrs, matcomp *init[]) { unsigned int i; for (i=0; ptrs; i++,ptrs>>=1) if (ptrs & 1) { 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() \ STMT_START { if (matchcomma) match(','); else matchcomma = 1; } STMT_END static void skipdecl(void) { if (*analyseur == ':') { analyseur++; skipexpr(); } } static long check_args() { long nparam = 0, matchcomma = 0; entree *ep; char *old; GEN cell; while (*analyseur != ')') { old=analyseur; nparam++; match_comma(); cell = new_chunk(2); if (!isalpha((int)*analyseur)) { err_new_fun(); err(paramer1, mark.identifier, mark.start); } ep = entry(); if (EpVALENCE(ep) != EpVAR) { err_new_fun(); if (EpVALENCE(ep) == EpGVAR) err(talker2,"global variable: ",old , mark.start); err(paramer1, old, mark.start); } cell[0] = varn(initial_value(ep)); skipdecl(); if (*analyseur == '=') { char *old = ++analyseur; gpmem_t av = avma; skipexpr(); cell[1] = lclone(_strtoGENstr(old, analyseur-old)); avma = av; } else cell[1] = zero; } return nparam; } static GEN do_call(void *call, GEN x, GEN argvec[]) { return ((PFGEN)call)(x, argvec[1], argvec[2], argvec[3], argvec[4], argvec[5], argvec[6], argvec[7], argvec[8]); } static GEN fix(GEN x, long l) { GEN y; if (typ(x) == t_COMPLEX) { y = cgetg(3,t_COMPLEX); y[1] = (long)fix((GEN)x[1],l); y[2] = (long)fix((GEN)x[2],l); } else { y = cgetr(l); gaffect(x,y); } return y; } /* Rationale: (f(2^-e) - f(-2^-e) + O(2^-pr)) / (2 * 2^-e) = f'(0) + O(2^-2e) * since 2nd derivatives cancel. * prec(LHS) = pr - e * prec(RHS) = 2e, equal when pr = 3e = 3/2 fpr (fpr = required final prec) * * For f'(x), x far from 0: prec(LHS) = pr - e - expo(x) * --> pr = 3/2 fpr + expo(x) */ static GEN num_deriv(void *call, GEN argvec[]) { GEN eps,a,b, y, x = argvec[0]; long fpr, pr, l, e, ex; gpmem_t av = avma; if (!is_const_t(typ(x))) { a = do_call(call, x, argvec); return gerepileupto(av, deriv(a,gvar9(a))); } fpr = precision(x)-2; /* required final prec (in sig. words) */ if (fpr == -2) fpr = prec-2; ex = gexpo(x); if (ex < 0) ex = 0; /* at 0 */ pr = (long)ceil(fpr * 1.5 + (ex / BITS_IN_LONG)); l = 2+pr; e = fpr * BITS_IN_HALFULONG; /* 1/2 required prec (in sig. bits) */ 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); return gerepileupto(av, gmul(gsub(b,a), eps)); } /* as above, for user functions */ 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; gpmem_t av = avma; if (!is_const_t(typ(x))) { a = call_fun(p,arg,loc,narg,nloc); return gerepileupto(av, deriv(a,gvar9(a))); } fpr = precision(x)-2; /* required final prec (in sig. words) */ if (fpr == -2) fpr = prec-2; ex = gexpo(x); if (ex < 0) ex = 0; /* at 0 */ pr = (long)ceil(fpr * 1.5 + (ex / BITS_IN_LONG)); l = 2+pr; e = fpr * BITS_IN_HALFULONG; /* 1/2 required prec (in sig. bits) */ 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); return gerepileupto(av, gmul(gsub(b,a), eps)); } #define DFT_VAR (GEN)-1L #define DFT_GEN (GEN)NULL #define _ARGS_ argvec[0], argvec[1], argvec[2], argvec[3],\ argvec[4], argvec[5], argvec[6], argvec[7], argvec[8] static GEN identifier(void) { long m, i, matchcomma, deriv; gpmem_t av; char *ch1; entree *ep; GEN res, newfun, ptr; mark.identifier = analyseur; ep = entry(); if (EpVALENCE(ep)==EpVAR || EpVALENCE(ep)==EpGVAR) { /* optimized for simple variables */ switch (*analyseur) { case ')': case ',': return (GEN)ep->value; case '.': { long len, v; analyseur++; ch1 = analyseur; 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; analyseur++; /* skip = */ ep = installep(NULL,ch1,len,EpMEMBER,0, members_hash + hashvalue(ch1)); ch1 = analyseur; skipseq(); len = analyseur-ch1; newfun=ptr= (GEN) newbloc(1 + (len>>TWOPOTBYTES_IN_LONG) + 4); newfun++; /* this bloc is no GEN, leave the first cell alone ( = 0) */ *newfun++ = v; /* record text */ strncpy((char *)newfun, ch1, len); ((char *) newfun)[len] = 0; ep->value = (void *)ptr; return gnil; } } 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 if (PARI_stack_limit && (void*) &ptr <= PARI_stack_limit) err(talker2, "deep recursion", mark.identifier, mark.start); #endif if (ep->code) { char *s = ep->code, *oldanalyseur = NULL, *buf, *limit, *bp; unsigned int ret, noparen, has_pointer=0; long fake; void *call = ep->value; GEN argvec[9]; matcomp *init[9]; char *flags = NULL; deriv = (*analyseur == '\'' && analyseur[1] == '(') && analyseur++; if (*analyseur == '(') { analyseur++; noparen=0; /* expect matching ')' */ } else { /* if no mandatory argument, no () needed */ if (EpVALENCE(ep)) match('('); /* error */ if (!*s || (!s[1] && *s == 'p')) return ((GEN (*)(long))call)(prec); noparen=1; /* no argument, but valence is ok */ } /* return type */ if (*s == 'v') { ret = RET_VOID; s++; } else if (*s == 'l') { ret = RET_INT; s++; } else ret = RET_GEN; /* Optimized for G and p. */ i = 0; while (*s == 'G') { match_comma(); s++; argvec[i++] = expr(); if (br_status) err(breaker,"here (argument reading)"); } if (*s == 'p') { argvec[i++] = (GEN) prec; s++; } while (*s && *s != '\n') switch (*s++) { case 'G': /* GEN */ match_comma(); argvec[i++] = expr(); if (br_status) err(breaker,"here (argument reading)"); break; case 'L': /* long */ match_comma(); argvec[i++] = (GEN) readlong(); break; case 'n': /* var number */ match_comma(); argvec[i++] = (GEN) readvar(); break; case 'S': /* symbol */ match_comma(); mark.symbol=analyseur; argvec[i++] = (GEN)entry(); break; case 'V': /* variable */ match_comma(); mark.symbol=analyseur; { entree *e = entry(); long v = EpVALENCE(e); if (v != EpVAR && v != EpGVAR) err(talker2,"not a variable:",mark.symbol,mark.start); argvec[i++] = (GEN)e; break; } case '&': /* *GEN */ match_comma(); match('&'); mark.symbol=analyseur; { 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); init[i] = c; argvec[i++] = (GEN)c->ptcell; break; } /* Input position */ case 'E': /* expr */ case 'I': /* seq */ match_comma(); argvec[i++] = (GEN) analyseur; skipseq(); break; case 'r': /* raw */ match_comma(); mark.raw = analyseur; bp = init_buf(256, &buf,&limit); while (*analyseur) { if (*analyseur == ',' || *analyseur == ')') break; if (*analyseur == '"') bp = readstring_i(bp, &buf,&limit); else { if (bp > limit) bp = realloc_buf(bp,1, &buf,&limit); *bp++ = *analyseur++; } } *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 */ { argvec[i++] = any_string(); s++; break; } bp = init_buf(256, &buf,&limit); while (*analyseur) { if (*analyseur == ',' || *analyseur == ')') break; bp = expand_string(bp, &buf,&limit); } *bp++ = 0; argvec[i++] = (GEN)buf; break; case 'p': /* precision */ argvec[i++] = (GEN) prec; break; case '=': match('='); matchcomma = 0; break; case 'D': /* Has a default value */ if (do_switch(noparen,matchcomma)) switch (*s) { case 'G': case '&': case 'I': case 'V': argvec[i++]=DFT_GEN; s++; break; case 'n': argvec[i++]=DFT_VAR; s++; break; default: oldanalyseur = analyseur; analyseur = s; matchcomma = 0; while (*s++ != ','); } else switch (*s) { case 'G': case '&': case 'I': case 'V': case 'n': break; default: while (*s++ != ','); } break; case 'P': /* series precision */ argvec[i++] = (GEN) precdl; break; case 'f': /* Fake *long argument */ argvec[i++] = (GEN) &fake; break; case 'x': /* Foreign function */ argvec[i++] = (GEN) ep; call = foreignHandler; break; case ',': /* Clean up default */ if (oldanalyseur) { analyseur = oldanalyseur; oldanalyseur = NULL; matchcomma=1; } break; default: err(bugparier,"identifier (unknown code)"); } #if 0 /* uncomment if using purify: unitialized read otherwise */ for ( ; i<9; i++) argvec[i]=NULL; #endif if (deriv) { if (!i || (ep->code)[0] != 'G') err(talker2, "can't derive this", mark.identifier, mark.start); res = num_deriv(call, argvec); } else switch (ret) { default: /* case RET_GEN: */ res = ((PFGEN)call)(_ARGS_); break; case RET_INT: m = ((long (*)(ANYARG))call)(_ARGS_); res = stoi(m); break; case RET_VOID: ((void (*)(ANYARG))call)(_ARGS_); res = gnil; break; } if (has_pointer) check_pointers(has_pointer,init); if (!noparen) match(')'); return res; } if (EpPREDEFINED(ep)) { if (*analyseur != '(') { if (EpVALENCE(ep) == 88) return global0(); match('('); /* error */ } analyseur++; switch(EpVALENCE(ep)) { case 50: /* O */ res = truc(); if (br_status) err(breaker,"here (in O()))"); if (*analyseur=='^') { analyseur++; m = readlong(); } else m = 1; res = ggrando(res,m); break; case 80: /* if then else */ av = avma; res = expr(); if (br_status) err(breaker,"test expressions"); m = gcmp0(res); avma = av; match(','); if (m) /* false */ { skipseq(); if (*analyseur == ')') res = gnil; else { match(','); res = seq(); if (br_status) { res = NULL; skipseq(); } } } else /* true */ { res = seq(); if (br_status) { res = NULL; skipseq(); } if (*analyseur != ')') { match(','); skipseq(); } } break; case 81: /* while do */ av = avma; ch1 = analyseur; for(;;) { res = expr(); if (br_status) err(breaker,"test expressions"); if (gcmp0(res)) { match(','); break; } avma = av; match(','); (void)seq(); if (loop_break()) break; analyseur = ch1; } avma = av; skipseq(); res = gnil; break; case 82: /* repeat until */ av = avma; ch1 = analyseur; skipexpr(); for(;;) { avma = av; match(','); (void)seq(); if (loop_break()) break; analyseur = ch1; res = expr(); if (br_status) err(breaker,"test expressions"); if (!gcmp0(res)) { match(','); break; } } avma = av; skipseq(); res = gnil; break; case 88: /* global */ if (*analyseur == ')') return global0(); while (*analyseur != ')') { match_comma(); ch1=analyseur; check_var_name(); ep = skipentry(); 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); } analyseur=ch1; ep = entry(); if (*analyseur == '=') { gpmem_t av=avma; analyseur++; res = expr(); if (br_status) err(breaker,"here (defining global var)"); changevalue(ep, res); avma=av; } ep->valence = EpGVAR; } res = gnil; break; default: err(valencer1); return NULL; /* not reached */ } match(')'); return res; } switch (EpVALENCE(ep)) { GEN *defarg; /* = default args, and values for local variables */ int narg, nloc; gp_args *f; case EpUSER: /* user-defined functions */ f = (gp_args*)ep->args; defarg = f->arg; narg = f->narg; nloc = f->nloc; deriv = (*analyseur == '\'' && analyseur[1] == '(') && analyseur++; if (*analyseur != '(') /* no args */ { if (*analyseur != '=' || analyseur[1] == '=') { GEN *arglist = (GEN*) new_chunk(narg); for (i=0; ivalue, arglist, defarg+narg, narg, nloc); } match('('); /* ==> error */ } if (analyseur != redefine_fun) { GEN *arglist = (GEN*) new_chunk(narg); ch1 = analyseur; analyseur++; for (i=0; ivalue, arglist, defarg+narg, narg, nloc); } return call_fun((GEN)ep->value, arglist, defarg+narg, narg, nloc); } /* should happen only in cases like (f()= f()=); f (!!!) */ analyseur--; if (*analyseur != ',' && *analyseur != ')') skipexpr(); while (*analyseur == ',') { analyseur++; skipexpr(); } match(')'); if (*analyseur != '=' || analyseur[1] == '=') err(nparamer1,mark.identifier,mark.start); matchcomma=0; analyseur = ch1; } redefine_fun = NULL; free_args((gp_args*)ep->args); /* Fall through */ case EpNEW: /* new function */ { GEN tmpargs = (GEN)avma; char *start; long len; check_new_fun = ep; /* checking arguments */ match('('); ch1 = analyseur; narg = check_args(); nloc = 0; 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; } /* function is ok. record it */ newfun = ptr = (GEN) newbloc(narg+nloc + (len>>TWOPOTBYTES_IN_LONG) + 4); newfun++; /* this bloc is no GEN, leave the first cell alone ( = 0) */ /* record default args */ f = (gp_args*) gpmalloc((narg+nloc)*sizeof(GEN) + sizeof(gp_args)); ep->args = (void*) f; f->nloc = nloc; f->narg = narg; f->arg = defarg = (GEN*)(f + 1); narg += nloc; /* record default args and local variables */ for (i = 1; i <= narg; i++) { GEN cell = tmpargs-(i<<1); *newfun++ = cell[0]; *defarg++ = (GEN)cell[1]; } if (narg > 1) { /* check for duplicates */ GEN x = new_chunk(narg), v = ptr+1; long k; for (i=0; iname, polx[k]); } /* record text */ strncpy((char *)newfun, start, len); ((char *) newfun)[len] = 0; if (EpVALENCE(ep) == EpUSER) gunclone((GEN)ep->value); /* have to wait till here because of strncopy above. In pathological * cases, e.g. (f()=f()=x), new text is given by value of old one! */ ep->value = (void *)ptr; ep->valence = EpUSER; check_new_fun=NULL; avma = (gpmem_t)tmpargs; return gnil; } } err(valencer1); return NULL; /* not reached */ } static long number(long *nb) { long m = 0; for (*nb = 0; *nb < 9 && isdigit((int)*analyseur); (*nb)++) m = 10*m + (*analyseur++ - '0'); return m; } static GEN constante() { static long pw10[] = { 1, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000, 1000000000 }; long i, l, m, n = 0, nb; gpmem_t av = avma; GEN z,y; y = stoi(number(&nb)); i = 0; while (isdigit((int)*analyseur)) { if (++i == 4) { avma = av; i = 0; } /* HACK gerepile */ m = number(&nb); y = addsmulsi(m, pw10[nb], y); } switch(*analyseur) { 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)) { if (++i == 4) { avma = av; i = 0; } /* HACK gerepile */ m = number(&nb); n -= nb; y = addsmulsi(m, pw10[nb], y); } if (*analyseur != 'E' && *analyseur != 'e') { if (!signe(y)) { avma = av; return realzero(prec); } break; } /* Fall through */ case 'E': case 'e': { char *old = analyseur; switch(*++analyseur) { case '-': analyseur++; n -= number(&nb); break; case '+': analyseur++; /* Fall through */ default: n += number(&nb); } if (nb > 8) err(talker2,"exponent too large",old,mark.start); if (!signe(y)) { avma = av; y = cgetr(3); n = (n > 0)? (long)(n/L2SL10): (long)-((-n)/L2SL10 + 1); y[1] = evalsigne(0) | evalexpo(n); y[2] = 0; return y; } } } l=lgefint(y); if (l