/*******************************************************************/
/* */
/* SYNTACTICAL ANALYZER FOR GP */
/* */
/*******************************************************************/
/* $Id: anal.c,v 1.1.1.1 1999/09/16 13:48:02 karim Exp $ */
#include "pari.h"
#include "anal.h"
#include "parinf.h"
typedef struct var_cell {
struct var_cell *prev;
GEN value;
char flag;
} var_cell;
#define PUSH_VAL 0
#define COPY_VAL 1
#define copyvalue(v,x) new_val_cell(get_ep(v), gclone(x), COPY_VAL)
#define pushvalue(v,x) new_val_cell(get_ep(v), x, PUSH_VAL)
#define killvalue(v) pop_val(get_ep(v))
#define separe(c) ((c)==';' || (c)==':')
typedef GEN (*PFGEN)(ANYARG);
static GEN constante(void);
static GEN expr(void);
static GEN facteur(void);
static GEN identifier(void);
static GEN matrix_block(GEN p, entree *ep);
static GEN read_member(GEN x);
static GEN seq(void);
static GEN truc(void);
static long number(long *nb);
static void doskipseq(char *s, int strict);
static void skipconstante(void);
static void skipexpr(void);
static void skipfacteur(void);
static void skipidentifier(void);
static void skipseq(void);
static void skipstring(void);
static long skiptruc(void);
static GEN strtoGENstr_t();
static entree *entry(void);
static entree *installep(void *f,char *name,int l,int v,int add,entree **table);
static entree *skipentry(void);
void killbloc0(GEN x, int inspect);
/* 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;
/* 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;
/* 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.
* { x|y } means an optional x or y.
*
* seq : only this one can be empty.
* sequence of { 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 :
* Optional leading sign (meaningfull only when "facteur" is enclosed
* in parentheses), followed by a "truc", then by any succession of the
* following:
*
* ~, _, ', !
* or ^ facteur
* or matrix_block
* or .member (see gp_member_list)
*
* truc:
* identifier
* or constante
* or ! truc
* or ' identifier
* or matrix_block (no_affect=1)
* or (expr)
* or %{ ` }* or %number
*
* identifier:
* entry ( { expr } { ,expr }* )
* The () are optional when arg list is void.
*
* matrix_block :
* [ A { { ; }A }*] where A = { expr } { { , }{ expr } }*
* All A must share the same length.
* If (no_affect=0 || ep !=NULL): follows an optional "= expr"
* or ++, --, op= where op is one of the operators in expr 1: and 2:
*
* entry :
* any succesion of alphanumeric characters, the first of which is not
* a digit.
*
* constante:
* number { . } { number } { e|E } { +|- } { number }.
*
* number:
* any non-negative integer.
*/
char*
_analyseur(void)
{
return analyseur;
}
/* Do not modify (analyseur,mark.start) */
static GEN
lisseq0(char *t, GEN (*f)(void))
{
const long av = avma;
char *olds = analyseur, *olde = mark.start;
GEN res;
if (foreignExprHandler && *t == foreignExprSwitch)
return (*foreignExprHandler)(t);
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)
{
if (!br_res) { avma = av; return gnil; }
res = forcecopy(br_res);
}
return gerepileupto(av, res);
}
GEN
lisseq(char *t)
{
return lisseq0(t, seq);
}
GEN
lisexpr(char *t)
{
return lisseq0(t, expr);
}
/* filtered lisexpr = remove blanks and comments */
GEN
flisexpr(char *t)
{
char *tmp = pari_strdup(t);
GEN x;
filtre(tmp, f_INIT | f_REG);
x = lisseq0(tmp, expr);
free(tmp); return x;
}
/* check syntax, then execute */
GEN
readseq(char *c, int strict)
{
check_new_fun=NULL; skipping_fun_def=0;
doskipseq(c, strict); return lisseq(c);
}
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
{
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 */
/* */
/*******************************************************************/
/* push_val and pop_val are private functions for use in sumiter and bibli2:
* we want a temporary value for ep, which is NOT a clone, to avoid
* unnecessary gaffect calls.
*
* Assumptions:
* EpVALENCE(ep) = EpVAR or EpGVAR
* ep->args initilized to NULL in installep()
*/
static void
new_val_cell(entree *ep, GEN a, 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 = a;
}
void
push_val(entree *ep, GEN a)
{
new_val_cell(ep,a,PUSH_VAL);
}
void
pop_val(entree *ep)
{
var_cell *v = (var_cell*) ep->args;
if (!v) return; /* initial value */
if (v->flag == COPY_VAL) killbloc((GEN)ep->value);
ep->value = v->value;
ep->args = (void*) v->prev;
free((void*)v);
}
int
pop_val_if_newer(entree *ep, long loc)
{
var_cell *v = (var_cell*) ep->args;
if (!v) return 0; /* initial value */
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;
}
static void
changevalue(entree *ep, GEN val)
{
GEN x = gclone(val);
var_cell *v = (var_cell*) ep->args;
if (!v) new_val_cell(ep,x, COPY_VAL);
else
{
if (v->flag == COPY_VAL) killbloc((GEN)ep->value); else v->flag = COPY_VAL;
ep->value = 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). That's because we use explicitly
* polx[0] at many places.
*/
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 long 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 = gerepileupto(av, gcopy(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)); }
static GEN
expr(void)
{
PFGEN f[] = { NULL,NULL,NULL,NULL };
GEN aux,e,e1,e2,e3;
long av = avma, lim = stack_lim(av,2);
e1 = e2 = e3 = NULL;
L3:
aux = facteur();
if (br_status) return NULL;
e3 = f[3]? f[3](e3,aux): aux;
switch(*analyseur)
{
case '*': analyseur++; f[3] = (PFGEN)&gmul; goto L3;
case '/': analyseur++; f[3] = (PFGEN)&gdiv; goto L3;
case '%': analyseur++; f[3] = (PFGEN)&gmod; goto L3;
case '\\':
if (*++analyseur == '/') { analyseur++; f[3]=(PFGEN)&gdivround; goto L3; }
f[3] = (PFGEN)&gdivent; goto L3;
case '<': case '>':
if (analyseur[1] == *analyseur)
{
f[3] = (*analyseur == '<')? (PFGEN)&gshift_l
: (PFGEN)&gshift_r;
analyseur += 2; goto L3;
}
}
f[3] = NULL;
L2:
if (!e3) goto L3;
e2 = f[2]? f[2](e2,e3): e3;
e3 = NULL;
if (low_stack(lim, stack_lim(av,2)))
{
GEN *gptr[2];
int n = 1; gptr[0]=&e2;
if (e1) gptr[n++]=&e1;
if(DEBUGMEM>1) err(warnmem,"expr");
gerepilemany(av,gptr,n);
}
switch(*analyseur)
{
case '+': analyseur++; f[2]=(PFGEN)&gadd; goto L3;
case '-': analyseur++; f[2]=(PFGEN)&gsub; goto L3;
}
f[2] = NULL;
L1:
if (!e2) goto L2;
e1 = f[1]? f[1](e1,e2): e2;
e2 = NULL;
switch(*analyseur)
{
case '<':
switch(*++analyseur)
{
case '=': analyseur++; f[1]=(PFGEN)&gle; goto L2;
case '>': analyseur++; f[1]=(PFGEN)⪈ goto L2;
}
f[1]=(PFGEN)&glt; goto L2;
case '>':
if (*++analyseur == '=') { analyseur++; f[1]=(PFGEN)&gge; goto L2; }
f[1]=(PFGEN)&ggt; goto L2;
case '=':
if (analyseur[1] == '=') { analyseur+=2; f[1]=(PFGEN)≥ goto L2; }
goto L1;
case '!':
if (analyseur[1] == '=') { analyseur+=2; f[1]=(PFGEN)⪈ goto L2; }
goto L1;
}
f[1] = NULL;
/* L0: */
if (!e1) goto L1;
e = f[0]? (gcmp0(e1)? gzero: gun): e1;
e1 = NULL;
switch(*analyseur)
{
case '&':
if (*++analyseur == '&') analyseur++;
if (gcmp0(e)) { skipexpr(); return gzero; }
f[0]=(PFGEN)1; goto L1;
case '|':
if (*++analyseur == '|') analyseur++;
if (!gcmp0(e)) { skipexpr(); return gun; }
f[0]=(PFGEN)1; goto L1;
}
return e;
}
/********************************************************************/
/** **/
/** CHECK FUNCTIONS **/
/** **/
/********************************************************************/
/* if current identifier was a function in 1.39.15, raise "obsolete" error */
static void
err_new_fun()
{
char *s = NULL, str[128];
if (check_new_fun)
{
if (check_new_fun != NOT_CREATED_YET)
{
s = strcpy(str,check_new_fun->name);
kill0(check_new_fun);
}
check_new_fun=NULL;
}
if (compatible == NONE)
{
char *v, *u = str, *lim = str + 127;
int n;
if (!s)
{ /* guess that the offending function was last identifier */
v = mark.identifier;
while (is_keyword_char(*v) && u < lim) *u++ = *v++;
*u = 0; s = str;
}
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);
}
}
#ifdef INLINE
INLINE
#endif
void
match2(char *s, char c)
{
if (*s != 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 match(c) match2(analyseur++, (c))
static long
readlong()
{
const long 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);
}
/* alright !=0 means function was called without () */
static int
do_switch(int alright, int matchcomma)
{
if (alright || !*analyseur || *analyseur == ')' || separe(*analyseur))
return 1;
if (*analyseur == ',') /* we just read an arg, or first arg */
{
if (!matchcomma && analyseur[-1] == '(') return 1; /* first arg */
if (analyseur[1] == ',' || analyseur[1] == ')')
{ analyseur++; return 1; }
}
return 0;
}
/********************************************************************/
/** **/
/** READ FUNCTIONS **/
/** **/
/********************************************************************/
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 = gpui(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;
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);
}
}
#define check_var_name() \
if (!isalpha((int)*analyseur)) err(varer1,analyseur,mark.start);
static GEN
truc(void)
{
long i,j, n=0, p=0, m=1, sizetab;
GEN *table,p1;
char *old;
if (*analyseur == '!')
{
analyseur++; p1 = truc();
if (br_status) err(breaker,"here (after !)");
return gcmp0(p1)? gun: gzero;
}
if (*analyseur == '\'')
{
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 (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 '[':
if (*analyseur == ';' && analyseur[1] == ']')
{ analyseur+=2; return cgetg(1,t_MAT); }
old=analyseur; analyseur--; sizetab=skiptruc(); analyseur=old;
table = (GEN*) gpmalloc((sizetab+1)*sizeof(GEN));
if (*analyseur != ']')
{
table[++n] = expr();
if (br_status) err(breaker,"array context");
}
while (*analyseur == ',')
{
analyseur++;
table[++n] = expr();
if (br_status) err(breaker,"array context");
}
switch (*analyseur++)
{
case ']':
p1=cgetg(n+1,t_VEC);
for (i=1; i<=n; i++)
p1[i] = lcopy(table[i]);
break;
case ';':
m = n;
do
{
table[++n] = expr();
if (br_status) err(breaker,"array context");
}
while (*analyseur++ != ']');
p = n/m + 1;
p1 = cgetg(m+1,t_MAT);
for (j=1; j<=m; j++)
{
p1[j] = lgetg(p,t_COL);
for (i=1; i<p; i++)
coeff(p1,i,j) = lcopy(table[(i-1)*m+j]);
}
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; p=0;
if (! gp_history_fun)
err(talker2,"history not available in library mode",old,mark.start);
while (*analyseur == '`') { analyseur++; p++; }
return p ? gp_history_fun(p ,1,old,mark.start)
: gp_history_fun(number(&n),0,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()
{
char c = *analyseur;
return c == analyseur[1] && (c == '+' || c == '-');
}
static GEN
matrix_block(GEN p, entree *ep)
{
long tx,full_col,full_row,c,r;
char *old;
GEN res, *pt, cpt;
tx = full_col = full_row = 0; pt = &p;
while (*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:
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++;
if (*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 = 1;
for (c=1; c<lg(p); c++) p2[c] = coeff(p,r,c);
pt = &p2;
}
else
{
c = check_array_index(lg(p));
pt = (GEN*)(((GEN)p[c]) + r); /* &coeff(p,r,c) */
match(']');
}
break;
default:
err(caracer1,analyseur-1,mark.start);
}
}
old = analyseur;
cpt = *pt;
if (*analyseur == '=') /* assignment or equality test */
{
if (analyseur[1] == '=') return cpt; /* test */
analyseur++; old = analyseur; res = expr();
if (br_status) err(breaker,"assignment");
}
else if (repeated_op())
{ /* a++, a-- */
res = gadd(cpt, (*analyseur == '+')? gun: negi(gun));
analyseur += 2;
}
else
{
GEN (*f)(GEN,GEN) = NULL;
if (!*analyseur)
return (ep && !full_row)? cpt: gcopy(cpt);
/* op= constructs ? */
if (analyseur[1] == '=')
{
switch(*analyseur)
{
case '+' : f = &gadd ; break;
case '-' : f = &gsub ; break;
case '*' : f = &gmul ; break;
case '/' : f = &gdiv ; break;
case '\\': f = &gdivent; break;
case '%' : f = &gmod ; break;
default:
return (ep && !full_row)? cpt: gcopy(cpt);
}
analyseur += 2;
}
else
{
if (analyseur[2] == '=')
switch(*analyseur)
{
case '>' :
if (analyseur[1]=='>') f = &gshift_r;
break;
case '<' :
if (analyseur[1]=='<') f = &gshift_l;
break;
case '\\':
if (analyseur[1]=='/') f = &gdivround;
break;
}
if (!f)
return (ep && !full_row)? cpt: gcopy(cpt);
analyseur += 3;
}
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 */
{
changevalue(ep,res);
return (GEN) ep->value;
}
if (full_row) /* whole row (index r) */
{
if (typ(res) != t_VEC || lg(res) != lg(p))
err(caseer2,old,mark.start);
for (c=1; c<lg(p); c++)
{
GEN p2 = gcoeff(p,r,c); if (isclone(p2)) killbloc(p2);
coeff(p,r,c) = lclone((GEN)res[c]);
}
return res;
}
res = gclone(res);
/* sanity check in case v[i] = f(), where f destroys v */
if (cpt != *pt)
err(talker2,"variable on the left-hand side was affected during this function call. Check whether it is modified as a side effect there", old, mark.start);
if (full_col) /* whole col */
{
if (typ(res) != t_COL || lg(res) != lg(cpt))
err(caseer2,old,mark.start);
for (r=1; r<lg(cpt); r++)
if (isclone(cpt[r])) killbloc((GEN)cpt[r]);
}
/* no need to inspect if full_col (done above) */
if (isclone(cpt)) killbloc0(cpt, !full_col);
return *pt = res;
}
static char*
init_buf(long len, char **ptbuf, char **ptlim)
{
char *buf = (char *)new_chunk(2 + len / sizeof(long));
*ptbuf = buf; *ptlim = buf + len; return buf;
}
static char*
realloc_buf(char *bp, long len, char **ptbuf,char **ptlimit)
{
char *buf = *ptbuf;
long newlen = ((*ptlimit - buf) + len) << 1;
long oldlen = bp - buf;
(void)init_buf(newlen, ptbuf, ptlimit);
memcpy(*ptbuf, buf, oldlen);
return *ptbuf + oldlen;
}
static char *
expand_string(char *bp, char **ptbuf, char **ptlimit)
{
char *tmp, *s = analyseur;
long len, alloc = 1;
while (is_keyword_char(*s)) s++;
if (*s == '"' || *s == ',' || *s == ')')
{ /* Do not create new user variables */
entree *ep = is_entry_intern(analyseur, functions_hash,0);
if (!ep)
{ /* consider as a literal */
tmp = analyseur;
len = s - analyseur;
analyseur = s; alloc = 0;
}
}
if (alloc)
{
long av = avma;
GEN p1 = expr();
if (br_status) err(breaker,"here (expanding string)");
tmp = GENtostr(p1);
len = strlen(tmp); avma = av;
}
if (ptlimit && bp + len > *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 == '"') break;
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 p1, 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();
if (br_status) err(breaker,"here (print)");
res[n++] = (long) p1;
}
if (n == len)
{
long newlen = len << 1;
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++, '"'); 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);
translate(&old, GSTR(x), NULL,NULL);
return x;
}
GEN
strtoGENstr(char *s, long flag)
{
long n;
GEN x;
if (flag) s = expand_tilde(s);
n = strlen(s)+1;
n = (n+BYTES_IN_LONG) >> TWOPOTBYTES_IN_LONG;
x = cgetg(n+1, t_STR);
strcpy(GSTR(x), s);
if (flag) free(s);
return x;
}
/* 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; i<narg; i++) copyvalue(*p++, *arg++);
for (i=0; i<nloc; i++) pushvalue(*p++, *loc++);
/* dumps the false GEN arglist from identifier() to the garbage zone */
res = lisseq((char *)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 */
/* pop ancient values for formal parameters */
for (i=0; i<nloc; i++) killvalue(*--p);
for (i=0; i<narg; i++) killvalue(*--p);
return res;
}
entree *
do_alias(entree *ep)
{
while (ep->valence == 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_pointer(unsigned int ptrs, GEN argvec[])
{
unsigned int i;
for (i=0; ptrs; i++,ptrs>>=1)
if (ptrs & 1) *((GEN*)argvec[i]) = gclone(*((GEN*)argvec[i]));
}
#define match_comma() if (matchcomma) match(','); else matchcomma = 1
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));
if (*analyseur == '=')
{
long av = avma;
GEN p1;
analyseur++; p1 = expr();
if (br_status) err(breaker,"here (default args)");
cell[1] = lclone(p1);
avma = av;
}
else cell[1] = zero;
}
return nparam;
}
#define DFT_VAR (GEN)-1
#define DFT_GEN (GEN)NULL
static GEN
identifier(void)
{
long m,i,av,matchcomma;
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))) 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;
}
}
return matrix_block((GEN) ep->value,ep);
}
ep = do_alias(ep); matchcomma = 0;
if (ep->code)
{
char *s = ep->code, *oldanalyseur = NULL, *buf, *limit, *bp;
unsigned int ret = RET_GEN, alright=0, has_pointer=0;
long fake;
void *call = ep->value;
GEN argvec[9];
if (*analyseur == '(') analyseur++;
else
{ /* if no mandatory argument, no () needed */
if (EpVALENCE(ep)) match('('); /* error */
if (!*s || (!s[1] && *s == 'p'))
return ((GEN (*)(long))ep->value)(prec);
alright=1; /* no arg was given, but valence is ok */
}
i = 0;
/* Optimized for G and p. */
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)
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 'V': case 'S': /* variable or symbol */
match_comma(); mark.symbol=analyseur;
argvec[i++] = (GEN)entry(); break;
case '&': /* *GEN */
match_comma(); match('&'); mark.symbol=analyseur;
{
entree *e = entry();
if (e->value == (void*)initial_value(e))
changevalue(e, gzero); /* don't overwrite initial value */
has_pointer |= (1 << i);
argvec[i++] = (GEN) &(e->value); break;
}
case 'I': /* Input position */
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 '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;
if (*analyseur == '"')
bp = readstring_i(bp, &buf,&limit);
else
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(alright,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 'l': /* Return long */
ret = RET_INT; break;
case 'v': /* Return void */
ret = RET_VOID; 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
switch (ret)
{
case RET_GEN:
res = ((PFGEN)call)(argvec[0], argvec[1], argvec[2], argvec[3],
argvec[4], argvec[5], argvec[6], argvec[7], argvec[8]);
break;
case RET_INT:
m = ((long (*)(ANYARG))call)(argvec[0], argvec[1], argvec[2], argvec[3],
argvec[4], argvec[5], argvec[6], argvec[7], argvec[8]);
res = stoi(m); break;
case RET_VOID:
((void (*)(ANYARG))call)(argvec[0], argvec[1], argvec[2], argvec[3],
argvec[4], argvec[5], argvec[6], argvec[7], argvec[8]);
res = gnil; break;
}
if (has_pointer) check_pointer(has_pointer,argvec);
if (!alright) 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;
ep = skipentry();
switch(EpVALENCE(ep))
{
case EpGVAR:
err(warner,"%s already declared global", ep->name);
/* fall through */
case EpVAR: break;
default: err(talker2,"symbol already in use",ch1,mark.start);
}
analyseur=ch1; ep = entry();
if (*analyseur == '=')
{
long 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);
}
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;
if (*analyseur != '(') /* no args */
{
if (*analyseur != '=' || analyseur[1] == '=')
return call_fun((GEN)ep->value, defarg, defarg+narg, narg, nloc);
match('('); /* ==> error */
}
if (analyseur != redefine_fun)
{
GEN *arglist = (GEN*) new_chunk(narg);
ch1 = analyseur; analyseur++;
for (i=0; i<narg; i++)
{
if (do_switch(0,matchcomma))
{ matchcomma=1 ; arglist[i] = defarg[i]; } /* default arg */
else
{ /* user supplied */
match_comma(); res = expr();
if (br_status) err(breaker,"here (reading function args)");
arglist[i] = res;
}
}
if (*analyseur++ == ')' && (*analyseur != '=' || analyseur[1] == '='))
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(')'); match('=');
while (strncmp(analyseur,"local(",6) == 0)
{
analyseur += 6;
nloc += check_args();
match(')'); while(separe(*analyseur)) analyseur++;
}
{ /* checking function definition */
char *oldredef = redefine_fun;
skipping_fun_def++;
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; i<narg; i++) x[i] = v[i];
qsort(x,narg,sizeof(long),(QSCOMP)pari_compare_long);
for (k=x[0],i=1; i<narg; k=x[i],i++)
if (x[i] == k)
err(talker,"user function %s: variable %Z declared twice",
ep->name, 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 the above line. (f()=f()=x). Text
* of new fun is given by value of the old one, which had to be kept
*/
ep->value = (void *)ptr;
ep->valence = EpUSER;
check_new_fun=NULL;
avma = (long)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 l,m,n = 0,nb, av = avma, limite = stack_lim(av,1);
GEN z,y;
y = stoi(number(&nb));
while (isdigit((int)*analyseur))
{
m = number(&nb);
y = addsi(m, mulsi(pw10[nb],y));
if (low_stack(limite, stack_lim(av,1))) y = gerepileupto(av,y);
}
switch(*analyseur)
{
default: return y; /* integer */
case '.':
analyseur++;
while (isdigit((int)*analyseur))
{
m = number(&nb); n -= nb;
y = addsi(m, mulsi(pw10[nb],y));
if (low_stack(limite, stack_lim(av,1))) y = gerepileupto(av,y);
}
if (*analyseur != 'E' && *analyseur != 'e') 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);
}
}
l=lgefint(y); if (l<prec) l=prec;
if (n)
{
new_chunk(l); /* hack: mulrr and divrr need exactly l words */
z=cgetr(l); affir(y,z);
y=cgetr(l); affsr(10,y); y = gpuigs(y, labs(n));
avma = av; /* hidden gerepile */
return n > 0 ? mulrr(z,y) : divrr(z,y);
}
z=cgetr(l); affir(y,z); return z;
}
/********************************************************************/
/** **/
/** HASH TABLE MANIPULATIONS **/
/** **/
/********************************************************************/
/* slighlty more efficient than is_keyword_char. Not worth a static array. */
#define is_key(c) (isalnum((int)(c)) || (c)=='_')
long
is_keyword_char(char c) { return is_key(c); }
/* return hashing value for identifier s (analyseur is s = NULL) */
long
hashvalue(char *s)
{
long update, n = 0;
if (!s) { s = analyseur; update = 1; } else update = 0;
while (is_key(*s)) { n = (n<<1) ^ *s; s++; }
if (update) analyseur = s;
if (n < 0) n = -n;
return n % functions_tblsz;
}
/* Looking for entry in hashtable. ep1 is the cell's first element */
static entree *
findentry(char *name, long len, entree *ep1)
{
entree *ep;
for (ep = ep1; ep; ep = ep->next)
if (!strncmp(ep->name, name, len) && !(ep->name)[len]) return ep;
if (foreignAutoload) /* Try to autoload. */
return foreignAutoload(name, len);
return NULL; /* not found */
}
entree *
is_entry_intern(char *s, entree **table, long *pthash)
{
char *old = analyseur;
long hash, len;
analyseur = s; hash = hashvalue(NULL);
len = analyseur - s; analyseur = old;
if (pthash) *pthash = hash;
return findentry(s,len,table[hash]);
}
int
is_identifier(char *s)
{
while (*s && is_keyword_char(*s)) s++;
return *s? 0: 1;
}
static entree *
installep(void *f, char *name, int len, int valence, int add, entree **table)
{
entree *ep = (entree *) gpmalloc(sizeof(entree) + add + len+1);
const entree *ep1 = initial_value(ep);
char *u = (char *) ep1 + add;
ep->name = u; strncpy(u, name,len); u[len]=0;
ep->args = NULL; ep->help = NULL; ep->code = NULL;
ep->value = f? f: (void *) ep1;
ep->next = *table;
ep->valence = valence;
ep->menu = 0;
return *table = ep;
}
long
manage_var(long n, entree *ep)
{
static long max_avail = MAXVARN; /* first user variable not yet used */
static long nvar; /* first GP free variable */
long var;
GEN p;
if (n) /* special behaviour */
{
switch(n)
{
case 2: return nvar=0;
case 3: return nvar;
case 4: return max_avail;
case 5:
{
long v = (long)ep;
if (v != nvar-1) err(talker,"can't pop gp variable");
setlg(polvar, nvar);
return --nvar;
}
}
/* user wants to delete one of his/her/its variables */
if (max_avail == MAXVARN-1) return 0; /* nothing to delete */
free(polx[++max_avail]); /* frees both polun and polx */
return max_avail+1;
}
if (nvar == max_avail) err(talker2,"no more variables available",
mark.identifier, mark.start);
if (ep)
{
p = (GEN)ep->value;
var=nvar++;
}
else
{
p = (GEN) gpmalloc(7*sizeof(long));
var=max_avail--;
}
/* create polx[var] */
p[0] = evaltyp(t_POL) | evallg(4);
p[1] = evalsigne(1) | evallgef(4) | evalvarn(var);
p[2] = zero; p[3] = un;
polx[var] = p;
/* create polun[nvar] */
p += 4;
p[0] = evaltyp(t_POL) | evallg(3);
p[1] = evalsigne(1) | evallgef(3) | evalvarn(var);
p[2] = un;
polun[var] = p;
varentries[var] = ep;
if (ep) { polvar[nvar] = (long) ep->value; setlg(polvar, nvar+1); }
return var;
}
long
fetch_var()
{
return manage_var(0,NULL);
}
entree *
fetch_named_var(char *s, int doerr)
{
entree *ep = is_entry(s);
if (ep)
{
if (doerr) err(talker,"identifier already in use: %s", s);
return ep;
}
ep = installep(NULL,s,strlen(s),EpVAR, 7*sizeof(long),
functions_hash + hashvalue(s));
manage_var(0,ep); return ep;
}
long
fetch_user_var(char *s)
{
entree *ep = is_entry(s);
long av;
GEN p1;
if (ep)
{
switch (EpVALENCE(ep))
{
case EpVAR: case EpGVAR:
return varn(initial_value(ep));
}
err(talker, "%s already exists with incompatible valence", s);
}
av=avma; p1 = lisexpr(s); avma=av;
return varn(p1);
}
void
delete_named_var(entree *ep)
{
manage_var(5, (entree*)varn(initial_value(ep)));
kill0(ep);
}
long
delete_var()
{
return manage_var(1,NULL);
}
void
name_var(long n, char *s)
{
entree *ep;
char *u;
if (n < manage_var(3,NULL))
err(talker, "renaming a GP variable is forbidden");
if (n > MAXVARN)
err(talker, "variable number too big");
ep = (entree*)gpmalloc(sizeof(entree) + strlen(s) + 1);
u = (char *)initial_value(ep);
ep->valence = EpVAR;
ep->name = u; strcpy(u,s);
ep->value = gzero; /* in case geval would be called */
if (varentries[n]) free(varentries[n]);
varentries[n] = ep;
}
/* Find entry or create it */
static entree *
entry(void)
{
char *old = analyseur;
const long hash = hashvalue(NULL), len = analyseur - old;
entree *ep = findentry(old,len,functions_hash[hash]);
long val,n;
if (ep) return ep;
if (compatible == WARN)
{
ep = findentry(old,len,funct_old_hash[hash]);
if (ep) return ep; /* the warning was done in skipentry() */
}
/* ep does not exist. Create it */
if (*analyseur == '(')
{ n=0; val=EpNEW; }
else
{ n=7*sizeof(long); val=EpVAR; }
ep = installep(NULL,old,len,val,n, functions_hash + hash);
if (n) manage_var(0,ep); /* Variable */
return ep;
}
/********************************************************************/
/** **/
/** SKIP FUNCTIONS **/
/** **/
/********************************************************************/
/* as skipseq without modifying analyseur && al */
static void
doskipseq(char *c, int strict)
{
char *olds = analyseur;
mark.start = c; analyseur = c; skipseq();
if (*analyseur)
{
if (strict) err(talker2,"unused characters", analyseur, c);
err(warner, "unused characters: %s", analyseur);
}
analyseur = olds;
}
static void
skipstring()
{
match('"');
while (*analyseur)
switch (*analyseur++)
{
case '"': return;
case '\\': analyseur++;
}
match('"');
}
static void
skip_matrix_block(int no_affect)
{
while (*analyseur == '[')
{
analyseur++;
if (*analyseur == ',') { analyseur++; skipexpr(); }
else
{
skipexpr();
if (*analyseur == ',')
if (*++analyseur != ']') skipexpr();
}
match(']');
}
if (*analyseur == '=' && analyseur[1] != '=')
{
if (no_affect) err(caracer1,analyseur,mark.start);
analyseur++; skipexpr(); return;
}
if (repeated_op())
{
if (no_affect) err(caracer1,analyseur,mark.start);
analyseur+=2; return;
}
if (!*analyseur) return;
if (analyseur[1] != '=')
{
switch(*analyseur)
{
case '>': case '<':
if (analyseur[1] != *analyseur || analyseur[2] != '=') return;
if (no_affect) err(caracer1,analyseur,mark.start);
analyseur+=3; skipexpr(); return;
case '\\':
if (analyseur[1] != '/' || analyseur[2] != '=') return;
if (no_affect) err(caracer1,analyseur,mark.start);
analyseur+=3; skipexpr(); return;
}
return;
}
switch(*analyseur)
{
case '+': case '-': case '*': case '/': case '\\': case '%':
if (no_affect) err(caracer1,analyseur,mark.start);
analyseur+=2; skipexpr(); return;
}
}
static void
skipseq(void)
{
for(;;)
{
while (separe(*analyseur)) analyseur++;
if (*analyseur == ',' || *analyseur == ')' || !*analyseur) return;
skipexpr(); if (!separe(*analyseur)) return;
}
}
static void
skipexpr(void)
{
int e1 = 0, e2 = 0, e3;
L3:
e3=1; skipfacteur();
switch(*analyseur)
{
case '*': case '/': case '%':
analyseur++; goto L3;
case '\\':
if (*++analyseur == '/') analyseur++;
goto L3;
case '<': case '>':
if (analyseur[1]==*analyseur) { analyseur +=2; goto L3; }
}
L2:
if (!e3) goto L3;
e3=0; e2=1;
switch(*analyseur)
{
case '+': case '-':
analyseur++; goto L3;
}
L1:
if (!e2) goto L2;
e2=0; e1=1;
switch(*analyseur)
{
case '<':
switch(*++analyseur)
{
case '=': case '>': analyseur++;
}
goto L2;
case '>':
if (*++analyseur == '=') analyseur++;
goto L2;
case '=': case '!':
if (analyseur[1] == '=') { analyseur+=2; goto L2; }
goto L1;
}
/* L0: */
if (!e1) goto L1;
e1=0;
switch(*analyseur)
{
case '&':
if (*++analyseur == '&') analyseur++;
goto L1;
case '|':
if (*++analyseur == '|') analyseur++;
goto L1;
}
}
static void
skipfacteur(void)
{
if (*analyseur == '+' || *analyseur == '-') analyseur++;
skiptruc();
for(;;)
switch(*analyseur)
{
case '.':
analyseur++; while (isalnum((int)*analyseur)) analyseur++;
if (*analyseur == '=' && analyseur[1] != '=')
{ analyseur++; skipseq(); }
break;
case '^':
analyseur++; skipfacteur(); break;
case '~': case '\'':
analyseur++; break;
case '[':
skip_matrix_block(1); break;
case '!':
if (analyseur[1] != '=') { analyseur++; break; }
default: return;
}
}
/* return the number of elements we need to read if array/matrix */
static long
skiptruc(void)
{
long n=0;
char *old;
if (*analyseur == '"') { skipstring(); return 0; }
if (*analyseur == '!') { analyseur++; skiptruc(); return 0; }
if (*analyseur == '\'')
{
analyseur++; check_var_name();
skipentry(); return 0;
}
if (isalpha((int)*analyseur))
{ skipidentifier(); return 0; }
if (isdigit((int)*analyseur) || *analyseur== '.')
{ skipconstante(); return 0; }
switch(*analyseur++)
{
case '(':
skipexpr(); match(')'); return 0;
case '[':
old = analyseur-1;
if (*analyseur == ';' && analyseur[1] == ']') /* 0 x 0 matrix */
{ analyseur+=2; return 0; }
if (*analyseur != ']')
{
do { n++; skipexpr(); old=analyseur; }
while (*analyseur++ == ',');
analyseur--;
}
switch (*analyseur)
{
case ']': analyseur++; return n;
case ';':
{
long m, norig=n; /* number of elts in first line */
old=analyseur;
do {
m=n;
do { n++; analyseur++; skipexpr(); }
while (*analyseur != ';' && *analyseur != ']');
if (n-m != norig)
err(talker2,"non rectangular matrix",old,mark.start);
} while (*analyseur != ']');
analyseur++; return n;
}
default:
err(talker2,"; or ] expected",old,mark.start);
return 0; /* not reached */
}
case '%':
if (*analyseur == '`') { while (*++analyseur == '`'); return 0; }
number(&n); return 0;
}
err(caracer1,analyseur-1,mark.start);
return 0; /* not reached */
}
static void
check_var()
{
char *old = analyseur;
check_var_name();
switch(EpVALENCE(skipentry()))
{
case EpVAR: break;
case EpGVAR:
err(talker2,"global variable not allowed", old,mark.start);
default: err(varer1,old,mark.start);
}
}
static void
skipidentifier(void)
{
int matchcomma=0;
entree *ep;
char *old;
mark.identifier = analyseur; ep = do_alias(skipentry());
if (ep->code)
{
char *s = ep->code;
if (*analyseur != '(')
{
if (EpVALENCE(ep) == 0) return; /* no mandatory argument */
match('('); /* ==> error */
}
analyseur++;
/* Optimized for G and p. */
while (*s == 'G') { match_comma(); skipexpr(); s++; }
if (*s == 'p') s++;
while (*s) switch (*s++)
{
case 'G': case 'n': case 'L':
match_comma();
if (*analyseur == ',' || *analyseur == ')') break;
skipexpr(); break;
case 'I':
match_comma(); skipseq(); break;
case 'r':
match_comma();
while (*analyseur)
{
while (*analyseur == '"') skipstring();
if (*analyseur == ',' || *analyseur == ')') break;
analyseur++;
}
break;
case 's':
match_comma();
if (*s == '*')
{
while (*analyseur)
{
while (*analyseur == '"') skipstring();
if (*analyseur == ')') break;
if (*analyseur == ',') analyseur++;
else skipexpr();
}
s++; if (*s == 'p' || *s == 't') s++;
break;
}
while (*analyseur)
{
while (*analyseur == '"') skipstring();
if (*analyseur == ')' || *analyseur == ',') break;
skipexpr();
}
break;
case 'S': match_comma();
check_var_name(); skipentry(); break;
case '&': match_comma(); match('&'); check_var(); break;
case 'V': match_comma(); check_var(); break;
case 'p': case 'P': case 'l': case 'v': case 'f': case 'x':
break;
case 'D':
if ( *analyseur == ')' ) { analyseur++; return; }
if (*s == 'G' || *s == '&' || *s == 'n' || *s == 'I' || *s == 'V')
break;
while (*s++ != ',');
break;
case '=':
match('='); matchcomma = 0; break;
case ',':
matchcomma=1; break;
default:
err(bugparier,"skipidentifier (unknown code)");
}
match(')');
return;
}
if (EpPREDEFINED(ep))
{
if (*analyseur != '(')
{
switch(EpVALENCE(ep))
{
case 0:
case 88: return;
}
match('('); /* error */
}
analyseur++;
switch(EpVALENCE(ep))
{
case 50: skiptruc();
if (*analyseur == '^') { analyseur++; skipfacteur(); };
break;
case 80: skipexpr(); match(','); skipseq();
if (*analyseur != ')') { match(','); skipseq(); }
break;
case 81: case 82: skipexpr(); match(','); skipseq(); break;
case 88:
while (*analyseur != ')') { match_comma(); skipexpr(); };
break;
default: err(valencer1);
}
match(')'); return;
}
switch (EpVALENCE(ep))
{
case EpGVAR:
case EpVAR: /* variables */
skip_matrix_block(0); return;
case EpUSER: /* fonctions utilisateur */
{
char *ch1 = analyseur;
gp_args *f;
int i;
if (*analyseur != '(')
{
if ( *analyseur != '=' || analyseur[1] == '=' ) return;
match('('); /* error */
}
f = (gp_args*)ep->args;
analyseur++; /* skip '(' */
for (i = f->nloc + f->narg; i; i--)
{
if (do_switch(0,matchcomma)) matchcomma=1;
else { match_comma(); skipexpr(); }
}
if (*analyseur == ')')
if ( analyseur[1] != '=' || analyseur[2] == '=' )
{ analyseur++; return; }
/* here we are redefining a user function */
old = analyseur;
if (*analyseur != ',' && *analyseur != ')') skipexpr();
while (*analyseur == ',') { analyseur++; skipexpr(); }
match(')');
if (*analyseur != '=' || analyseur[1] == '=')
{
if (skipping_fun_def) return;
err(nparamer1,old,mark.start);
}
analyseur = ch1; matchcomma = 0;
if (!redefine_fun) redefine_fun = analyseur;
} /* fall through */
case EpNEW: /* new function */
if (check_new_fun && ! skipping_fun_def)
{
err_new_fun(); /* ep not created yet: no need to kill it */
err(paramer1, mark.identifier, mark.start);
}
check_new_fun = NOT_CREATED_YET; match('(');
while (*analyseur != ')') { match_comma(); skipexpr(); };
match(')');
if (*analyseur == '=')
{
skipping_fun_def++;
analyseur++; skipseq();
skipping_fun_def--;
}
check_new_fun=NULL; return;
default: err(valencer1);
}
}
static void
skipconstante(void)
{
while (isdigit((int)*analyseur)) analyseur++;
if ( *analyseur!='.' && *analyseur!='e' && *analyseur!='E' ) return;
if (*analyseur=='.') analyseur++;
while (isdigit((int)*analyseur)) analyseur++;
if ( *analyseur=='e' || *analyseur=='E' )
{
analyseur++;
if ( *analyseur=='+' || *analyseur=='-' ) analyseur++;
while (isdigit((int)*analyseur)) analyseur++;
}
}
static entree *
skipentry(void)
{
static entree fakeEpNEW = { "",EpNEW };
static entree fakeEpVAR = { "",EpVAR };
char *old = analyseur;
const long hash = hashvalue(NULL), len = analyseur - old;
entree *ep = findentry(old,len,functions_hash[hash]);
if (ep) return ep;
if (compatible == WARN)
{
ep = findentry(old,len,funct_old_hash[hash]);
if (ep)
{
err(warner,"using obsolete function %s",ep->name);
return ep;
}
}
return (*analyseur == '(') ? &fakeEpNEW : &fakeEpVAR;
}
/********************************************************************/
/** **/
/** MEMBER FUNCTIONS **/
/** **/
/********************************************************************/
static GEN
e(GEN x)
{
x = get_primeid(x);
if (!x) err(member,"e",mark.member,mark.start);
return (GEN)x[3];
}
static GEN
f(GEN x)
{
x = get_primeid(x);
if (!x) err(member,"f",mark.member,mark.start);
return (GEN)x[4];
}
static GEN
p(GEN x)
{
x = get_primeid(x);
if (!x) err(member,"p",mark.member,mark.start);
return (GEN)x[1];
}
static GEN
bnf(GEN x)
{
int t; x = get_bnf(x,&t);
if (!x) err(member,"bnf",mark.member,mark.start);
return x;
}
static GEN
nf(GEN x)
{
int t; x = get_nf(x,&t);
if (!x) err(member,"nf",mark.member,mark.start);
return x;
}
/* integral basis */
static GEN
zk(GEN x)
{
int t; GEN y = get_nf(x,&t);
if (!y)
{
switch(t)
{
case typ_CLA: return gmael(x,1,4);
case typ_Q: y = cgetg(3,t_VEC);
y[1]=un; y[2]=lpolx[varn(x[1])]; return y;
}
err(member,"zk",mark.member,mark.start);
}
return (GEN)y[7];
}
static GEN
disc(GEN x) /* discriminant */
{
int t; GEN y = get_nf(x,&t);
if (!y)
{
switch(t)
{
case typ_Q : return discsr((GEN)x[1]);
case typ_CLA: return gmael3(x,1,3,1);
case typ_ELL: return (GEN)x[12];
}
err(member,"disc",mark.member,mark.start);
}
return (GEN)y[3];
}
static GEN
pol(GEN x) /* polynomial */
{
int t; GEN y = get_nf(x,&t);
if (!y)
{
switch(t)
{
case typ_CLA: return gmael(x,1,1);
case typ_POL: return x;
case typ_Q : return (GEN)x[1];
}
if (typ(x)==t_POLMOD) return (GEN)x[2];
err(member,"pol",mark.member,mark.start);
}
return (GEN)y[1];
}
static GEN
mod(GEN x) /* modulus */
{
switch(typ(x))
{
case t_INTMOD: case t_POLMOD: case t_QUAD: break;
default: err(member,"mod",mark.member,mark.start);
}
return (GEN)x[1];
}
static GEN
sign(GEN x) /* signature */
{
int t; GEN y = get_nf(x,&t);
if (!y)
{
if (t == typ_CLA) return gmael(x,1,2);
err(member,"sign",mark.member,mark.start);
}
return (GEN)y[2];
}
static GEN
t2(GEN x) /* T2 matrix */
{
int t; x = get_nf(x,&t);
if (!x) err(member,"t2",mark.member,mark.start);
return gmael(x,5,3);
}
static GEN
diff(GEN x) /* different */
{
int t; x = get_nf(x,&t);
if (!x) err(member,"diff",mark.member,mark.start);
return gmael(x,5,5);
}
static GEN
codiff(GEN x) /* codifferent */
{
int t; x = get_nf(x,&t);
if (!x) err(member,"codiff",mark.member,mark.start);
return gdiv(gmael(x,5,7), absi((GEN) x[3]));
}
static GEN
mroots(GEN x) /* roots */
{
int t; GEN y = get_nf(x,&t);
if (!y)
{
if (t == typ_ELL) return (GEN)x[14];
err(member,"roots",mark.member,mark.start);
}
return (GEN)y[6];
}
static GEN
clgp(GEN x) /* class group (3-component row vector) */
{
int t; GEN y = get_bnf(x,&t);
if (!y)
{
switch(t)
{
case typ_QUA:
y = cgetg(4,t_VEC);
for(t=1; t<4; t++) y[t] = x[t];
return y;
case typ_CLA: return gmael(x,1,5);
}
if (typ(x)==t_VEC)
switch(lg(x))
{
case 3: /* no gen */
case 4: return x;
}
err(member,"clgp",mark.member,mark.start);
}
if (t==typ_BNR) return (GEN)x[5];
return gmael(y,8,1);
}
static GEN
reg(GEN x) /* regulator */
{
int t; GEN y = get_bnf(x,&t);
if (!y)
{
switch(t)
{
case typ_CLA: return gmael(x,1,6);
case typ_QUA: return (GEN)x[4];
}
err(member,"reg",mark.member,mark.start);
}
if (t == typ_BNR) err(impl,"ray regulator");
return gmael(x,8,2);
}
static GEN
fu(GEN x) /* fundamental units */
{
int t; GEN y = get_bnf(x,&t);
if (!y)
{
switch(t)
{
case typ_CLA: x = (GEN)x[1]; if (lg(x)<11) break;
return (GEN)x[9];
case typ_Q:
x = discsr((GEN)x[1]);
return (signe(x)<0)? cgetg(1,t_VEC): fundunit(x);
}
err(member,"fu",mark.member,mark.start);
}
if (t == typ_BNR) err(impl,"ray units");
return check_units(y,".fu");
}
/* torsion units. return [w,e] where w is the number of roots of 1, and e a
* polymod generator */
static GEN
tu(GEN x)
{
int t; GEN y = get_bnf(x,&t), res = cgetg(3,t_VEC);
if (!y)
{
switch(t)
{
case typ_Q:
y = discsr((GEN)x[1]);
if (signe(y)<0 && cmpis(y,-4)>=0)
y = stoi((itos(y) == -4)? 4: 6);
else
{ y = gdeux; x=negi(gun); }
res[1] = (long)y;
res[2] = (long)x; return res;
case typ_CLA:
if (lg(x[1])==11) break;
default: err(member,"tu",mark.member,mark.start);
}
x = (GEN) x[1]; y=(GEN)x[8];
}
else
{
if (t == typ_BNR) err(impl,"ray torsion units");
x = (GEN)y[7]; y=(GEN)y[8];
if (lg(y) > 5) y = (GEN)y[4];
else
{
y = rootsof1(x);
y[2] = lmul((GEN)x[7], (GEN)y[2]);
}
}
res[2] = y[2];
res[1] = y[1]; return res;
}
static GEN
futu(GEN x) /* concatenation of fu and tu, w is lost */
{
GEN fuc = fu(x);
return concat(fuc, (GEN)tu(x)[2]);
}
static GEN
tufu(GEN x) /* concatenation of tu and fu, w is lost */
{
GEN fuc = fu(x);
return concat((GEN) tu(x)[2], fuc);
}
static GEN
zkst(GEN bid)
/* structure of (Z_K/m)^*, where bid is an idealstarinit (with or without gen)
or a bnrinit (with or without gen) */
{
if (typ(bid)==t_VEC)
switch(lg(bid))
{
case 6: return (GEN) bid[2]; /* idealstarinit */
case 7: return gmael(bid,2,2); /* bnrinit */
}
err(member,"zkst",mark.member,mark.start);
return NULL; /* not reached */
}
static GEN
no(GEN clg) /* number of elements of a group (of type clgp) */
{
clg = clgp(clg);
if (typ(clg)!=t_VEC || (lg(clg)!=3 && lg(clg)!=4))
err(member,"no",mark.member,mark.start);
return (GEN) clg[1];
}
static GEN
cyc(GEN clg) /* cyclic decomposition (SNF) of a group (of type clgp) */
{
clg = clgp(clg);
if (typ(clg)!=t_VEC || (lg(clg)!=3 && lg(clg)!=4))
err(member,"cyc",mark.member,mark.start);
return (GEN) clg[2];
}
/* SNF generators of a group (of type clgp), or generators of a prime
* ideal
*/
static GEN
gen(GEN x)
{
GEN y = get_primeid(x);
if (y)
{
x = cgetg(3,t_VEC);
x[1] = lcopy((GEN)y[1]);
x[2] = lcopy((GEN)y[2]);
return x;
}
x = clgp(x);
if (typ(x)!=t_VEC || lg(x)!=4)
err(member,"gen",mark.member,mark.start);
if (typ(x[1]) == t_COL) return (GEN)x[2]; /* from bnfisprincipal */
return (GEN) x[3];
}
#define is_ell(x) (typ(x) == t_VEC && lg(x)>=14)
#define is_bigell(x) (typ(x) == t_VEC && lg(x)>=20)
static GEN
a1(GEN x)
{
if (!is_ell(x)) err(member,"a1",mark.member,mark.start);
return (GEN)x[1];
}
static GEN
a2(GEN x)
{
if (!is_ell(x)) err(member,"a2",mark.member,mark.start);
return (GEN)x[2];
}
static GEN
a3(GEN x)
{
if (!is_ell(x)) err(member,"a3",mark.member,mark.start);
return (GEN)x[3];
}
static GEN
a4(GEN x)
{
if (!is_ell(x)) err(member,"a4",mark.member,mark.start);
return (GEN)x[4];
}
static GEN
a6(GEN x)
{
if (!is_ell(x)) err(member,"a6",mark.member,mark.start);
return (GEN)x[5];
}
static GEN
b2(GEN x)
{
if (!is_ell(x)) err(member,"b2",mark.member,mark.start);
return (GEN)x[6];
}
static GEN
b4(GEN x)
{
if (!is_ell(x)) err(member,"b4",mark.member,mark.start);
return (GEN)x[7];
}
static GEN
b6(GEN x)
{
if (!is_ell(x)) err(member,"b6",mark.member,mark.start);
return (GEN)x[8];
}
static GEN
b8(GEN x)
{
if (!is_ell(x)) err(member,"b8",mark.member,mark.start);
return (GEN)x[9];
}
static GEN
c4(GEN x)
{
if (!is_ell(x)) err(member,"c4",mark.member,mark.start);
return (GEN)x[10];
}
static GEN
c6(GEN x)
{
if (!is_ell(x)) err(member,"c6",mark.member,mark.start);
return (GEN)x[11];
}
static GEN
j(GEN x)
{
if (!is_ell(x)) err(member,"j",mark.member,mark.start);
return (GEN)x[13];
}
static GEN
momega(GEN x)
{
GEN y;
if (!is_bigell(x)) err(member,"omega",mark.member,mark.start);
if (gcmp0((GEN)x[19])) err(talker,"curve not defined over R");
y=cgetg(3,t_VEC); y[1]=x[15]; y[2]=x[16];
return y;
}
static GEN
meta(GEN x)
{
GEN y;
if (!is_bigell(x)) err(member,"eta",mark.member,mark.start);
if (gcmp0((GEN)x[19])) err(talker,"curve not defined over R");
y=cgetg(3,t_VEC); y[1]=x[17]; y[2]=x[18];
return y;
}
static GEN
area(GEN x)
{
if (!is_bigell(x)) err(member,"area",mark.member,mark.start);
if (gcmp0((GEN)x[19])) err(talker,"curve not defined over R");
return (GEN)x[19];
}
static GEN
tate(GEN x)
{
GEN z = cgetg(3,t_VEC);
if (!is_bigell(x)) err(member,"tate",mark.member,mark.start);
if (!gcmp0((GEN)x[19])) err(talker,"curve not defined over a p-adic field");
z[1]=x[15];
z[2]=x[16];
z[3]=x[17]; return z;
}
static GEN
w(GEN x)
{
if (!is_bigell(x)) err(member,"tate",mark.member,mark.start);
if (!gcmp0((GEN)x[19])) err(talker,"curve not defined over a p-adic field");
return (GEN)x[18];
}
/*
* Only letters and digits in member names. AT MOST 8 of THEM
* (or modify gp_rl.c::pari_completion)
*/
entree gp_member_list[] = {
{"a1",0,(void*)a1},
{"a2",0,(void*)a2},
{"a3",0,(void*)a3},
{"a4",0,(void*)a4},
{"a6",0,(void*)a6},
{"area",0,(void*)area},
{"b2",0,(void*)b2},
{"b4",0,(void*)b4},
{"b6",0,(void*)b6},
{"b8",0,(void*)b8},
{"bnf",0,(void*)bnf},
{"c4",0,(void*)c4},
{"c6",0,(void*)c6},
{"clgp",0,(void*)clgp},
{"codiff",0,(void*)codiff},
{"cyc",0,(void*)cyc},
{"diff",0,(void*)diff},
{"disc",0,(void*)disc},
{"e",0,(void*)e},
{"eta",0,(void*)meta},
{"f",0,(void*)f},
{"fu",0,(void*)fu},
{"futu",0,(void*)futu},
{"gen",0,(void*)gen},
{"j",0,(void*)j},
{"mod",0,(void*)mod},
{"nf",0,(void*)nf},
{"no",0,(void*)no},
{"omega",0,(void*)momega},
{"p",0,(void*)p},
{"pol",0,(void*)pol},
{"reg",0,(void*)reg},
{"roots",0,(void*)mroots},
{"sign",0,(void*)sign},
{"tate",0,(void*)tate},
{"t2",0,(void*)t2},
{"tu",0,(void*)tu},
{"tufu",0,(void*)tufu},
{"w",0,(void*)w},
{"zk",0,(void*)zk},
{"zkst",0,(void*)zkst},
{NULL,0,NULL}
};
static entree*
find_member()
{
char *old = analyseur;
const long hash = hashvalue(NULL), len = analyseur - old;
return findentry(old,len,members_hash[hash]);
}
static GEN
read_member(GEN x)
{
entree *ep;
mark.member = analyseur;
ep = find_member();
if (ep)
{
if (*analyseur == '=' && analyseur[1] != '=')
{
if (EpPREDEFINED(ep))
err(talker2,"can't modify a pre-defined member: ",
mark.member,mark.start);
gunclone((GEN)ep->value); return NULL;
}
if (EpVALENCE(ep) == EpMEMBER)
return call_fun((GEN)ep->value, NULL, &x, 0, 1);
else
return ((GEN (*)(ANYARG))ep->value)(x);
}
if (*analyseur != '=' || analyseur[1] == '=')
err(talker2,"unknown member function",mark.member,mark.start);
return NULL; /* to be redefined */
}
/********************************************************************/
/** **/
/** SIMPLE GP FUNCTIONS **/
/** **/
/********************************************************************/
long
loop_break()
{
switch(br_status)
{
case br_BREAK : if (! --br_count) br_status = br_NONE; /* fall through */
case br_RETURN: return 1;
case br_NEXT: br_status = br_NONE; /* fall through */
}
return 0;
}
long
did_break() { return br_status; }
GEN
return0(GEN x)
{
br_res = x? gclone(x): NULL;
br_status = br_RETURN; return NULL;
}
GEN
next0(long n)
{
if (n < 1)
err(talker2,"positive integer expected",mark.identifier,mark.start);
if (n == 1) br_status = br_NEXT;
else
{
br_count = n-1;
br_status = br_BREAK;
}
return NULL;
}
GEN
break0(long n)
{
if (n < 1)
err(talker2,"positive integer expected",mark.identifier,mark.start);
br_count = n;
br_status = br_BREAK; return NULL;
}
void
alias0(char *s, char *old)
{
entree *ep, *e;
long hash;
GEN x;
ep = is_entry(old);
if (!ep) err(talker2,"unknown function",mark.raw,mark.start);
switch(EpVALENCE(ep))
{
case EpVAR: case EpGVAR:
err(talker2,"only functions can be aliased",mark.raw,mark.start);
}
if ( (e = is_entry_intern(s, functions_hash, &hash)) )
{
if (EpVALENCE(e) != EpALIAS)
err(talker2,"can't replace an existing symbol by an alias",
mark.raw, mark.start);
kill0(e);
}
ep = do_alias(ep); x = newbloc(2);
x[0] = evaltyp(t_STR)|evallg(2); /* for getheap */
x[1] = (long)ep;
installep(x, s, strlen(s), EpALIAS, 0, functions_hash + hash);
}
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to anal.c CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib / pari / src / language