Annotation of OpenXM_contrib/pari/src/language/anal.c, Revision 1.1
1.1 ! maekawa 1: /*******************************************************************/
! 2: /* */
! 3: /* SYNTACTICAL ANALYZER FOR GP */
! 4: /* */
! 5: /*******************************************************************/
! 6: /* $Id: anal.c,v 1.1.1.1 1999/09/16 13:48:02 karim Exp $ */
! 7: #include "pari.h"
! 8: #include "anal.h"
! 9: #include "parinf.h"
! 10:
! 11: typedef struct var_cell {
! 12: struct var_cell *prev;
! 13: GEN value;
! 14: char flag;
! 15: } var_cell;
! 16: #define PUSH_VAL 0
! 17: #define COPY_VAL 1
! 18: #define copyvalue(v,x) new_val_cell(get_ep(v), gclone(x), COPY_VAL)
! 19: #define pushvalue(v,x) new_val_cell(get_ep(v), x, PUSH_VAL)
! 20: #define killvalue(v) pop_val(get_ep(v))
! 21:
! 22: #define separe(c) ((c)==';' || (c)==':')
! 23: typedef GEN (*PFGEN)(ANYARG);
! 24:
! 25: static GEN constante(void);
! 26: static GEN expr(void);
! 27: static GEN facteur(void);
! 28: static GEN identifier(void);
! 29: static GEN matrix_block(GEN p, entree *ep);
! 30: static GEN read_member(GEN x);
! 31: static GEN seq(void);
! 32: static GEN truc(void);
! 33: static long number(long *nb);
! 34: static void doskipseq(char *s, int strict);
! 35: static void skipconstante(void);
! 36: static void skipexpr(void);
! 37: static void skipfacteur(void);
! 38: static void skipidentifier(void);
! 39: static void skipseq(void);
! 40: static void skipstring(void);
! 41: static long skiptruc(void);
! 42: static GEN strtoGENstr_t();
! 43: static entree *entry(void);
! 44: static entree *installep(void *f,char *name,int l,int v,int add,entree **table);
! 45: static entree *skipentry(void);
! 46:
! 47: void killbloc0(GEN x, int inspect);
! 48:
! 49: /* last time we began parsing an object of specified type */
! 50: static struct
! 51: {
! 52: char *identifier, *symbol, *raw, *member, *start;
! 53: } mark;
! 54:
! 55: /* when skipidentifier() detects that user function f() is being redefined,
! 56: * (f()= ... ) this is set pointing to the opening parenthesis. Checked in
! 57: * identifier(). Otherwise definition like f(x=1)= would change the value of
! 58: * global variable x
! 59: */
! 60: static char *redefine_fun = NULL;
! 61:
! 62: /* points to the part of the string that remains to be parsed */
! 63: static char *analyseur;
! 64:
! 65: /* when non-0, we are checking the syntax of a new function body */
! 66: static long skipping_fun_def;
! 67:
! 68: /* when non-NULL, points to the entree of a new user function (currently
! 69: * being checked). Used by the compatibility engine in the following way:
! 70: * when user types in a function whose name has changed, it is understood
! 71: * as EpNEW; first syntax error (missing = after function definition
! 72: * usually) triggers err_new_fun() if check_new_fun is set.
! 73: */
! 74: static entree *check_new_fun;
! 75:
! 76: /* for control statements (check_break) */
! 77: static long br_status, br_count;
! 78: static GEN br_res = NULL;
! 79:
! 80: /* Special characters:
! 81: * ' ', '\t', '\n', '\\' are forbidden internally (suppressed by filtre).
! 82: * { } are forbidden everywhere and will be used to denote optional
! 83: * lexemes in the sequel.
! 84: *
! 85: * Definitions: The sequence
! 86: * { a }* means any number (possibly 0) of object a.
! 87: * { x|y } means an optional x or y.
! 88: *
! 89: * seq : only this one can be empty.
! 90: * sequence of { expr{ :|; } }*
! 91: *
! 92: * expr :
! 93: * expression = sequence of "facteurs" separated by binary operators
! 94: * whose priority are:
! 95: * 1: *, /, \, \/, %, >>, << (highest)
! 96: * 2: +, -
! 97: * 3: <, <=, >, >=, !=, ==, <>
! 98: * 4: &, &&, |, || (lowest)
! 99: * read from left to right.
! 100: *
! 101: * facteur :
! 102: * Optional leading sign (meaningfull only when "facteur" is enclosed
! 103: * in parentheses), followed by a "truc", then by any succession of the
! 104: * following:
! 105: *
! 106: * ~, _, ', !
! 107: * or ^ facteur
! 108: * or matrix_block
! 109: * or .member (see gp_member_list)
! 110: *
! 111: * truc:
! 112: * identifier
! 113: * or constante
! 114: * or ! truc
! 115: * or ' identifier
! 116: * or matrix_block (no_affect=1)
! 117: * or (expr)
! 118: * or %{ ` }* or %number
! 119: *
! 120: * identifier:
! 121: * entry ( { expr } { ,expr }* )
! 122: * The () are optional when arg list is void.
! 123: *
! 124: * matrix_block :
! 125: * [ A { { ; }A }*] where A = { expr } { { , }{ expr } }*
! 126: * All A must share the same length.
! 127: * If (no_affect=0 || ep !=NULL): follows an optional "= expr"
! 128: * or ++, --, op= where op is one of the operators in expr 1: and 2:
! 129: *
! 130: * entry :
! 131: * any succesion of alphanumeric characters, the first of which is not
! 132: * a digit.
! 133: *
! 134: * constante:
! 135: * number { . } { number } { e|E } { +|- } { number }.
! 136: *
! 137: * number:
! 138: * any non-negative integer.
! 139: */
! 140: char*
! 141: _analyseur(void)
! 142: {
! 143: return analyseur;
! 144: }
! 145:
! 146: /* Do not modify (analyseur,mark.start) */
! 147: static GEN
! 148: lisseq0(char *t, GEN (*f)(void))
! 149: {
! 150: const long av = avma;
! 151: char *olds = analyseur, *olde = mark.start;
! 152: GEN res;
! 153:
! 154: if (foreignExprHandler && *t == foreignExprSwitch)
! 155: return (*foreignExprHandler)(t);
! 156:
! 157: check_new_fun=NULL; skipping_fun_def=0;
! 158: mark.start = analyseur = t;
! 159:
! 160: br_status = br_NONE;
! 161: if (br_res) { killbloc(br_res); br_res = NULL; }
! 162: res = f();
! 163: analyseur = olds; mark.start = olde;
! 164:
! 165: if (br_status)
! 166: {
! 167: if (!br_res) { avma = av; return gnil; }
! 168: res = forcecopy(br_res);
! 169: }
! 170: return gerepileupto(av, res);
! 171: }
! 172:
! 173: GEN
! 174: lisseq(char *t)
! 175: {
! 176: return lisseq0(t, seq);
! 177: }
! 178:
! 179: GEN
! 180: lisexpr(char *t)
! 181: {
! 182: return lisseq0(t, expr);
! 183: }
! 184:
! 185: /* filtered lisexpr = remove blanks and comments */
! 186: GEN
! 187: flisexpr(char *t)
! 188: {
! 189: char *tmp = pari_strdup(t);
! 190: GEN x;
! 191:
! 192: filtre(tmp, f_INIT | f_REG);
! 193: x = lisseq0(tmp, expr);
! 194: free(tmp); return x;
! 195: }
! 196:
! 197: /* check syntax, then execute */
! 198: GEN
! 199: readseq(char *c, int strict)
! 200: {
! 201: check_new_fun=NULL; skipping_fun_def=0;
! 202: doskipseq(c, strict); return lisseq(c);
! 203: }
! 204:
! 205: entree *
! 206: install(void *f, char *name, char *code)
! 207: {
! 208: long hash;
! 209: entree *ep = is_entry_intern(name, functions_hash, &hash);
! 210:
! 211: if (ep) err(warner,"[install] '%s' already there. Not replaced", name);
! 212: else
! 213: {
! 214: ep = installep(f, name, strlen(name), EpINSTALL, 0, functions_hash + hash);
! 215: ep->code = pari_strdup(code);
! 216: }
! 217: return ep;
! 218: }
! 219:
! 220: static void
! 221: free_args(gp_args *f)
! 222: {
! 223: long i;
! 224: GEN *y = f->arg;
! 225: for (i = f->narg + f->nloc - 1; i>=0; i--)
! 226: if (isclone(y[i])) gunclone(y[i]);
! 227: }
! 228:
! 229: void
! 230: freeep(entree *ep)
! 231: {
! 232: if (foreignFuncFree && ep->code && (*ep->code == 'x'))
! 233: (*foreignFuncFree)(ep); /* function created by foreign interpreter */
! 234:
! 235: if (EpSTATIC(ep)) return; /* gp function loaded at init time */
! 236: if (ep->help) free(ep->help);
! 237: if (ep->code) free(ep->code);
! 238: if (ep->args)
! 239: {
! 240: switch(EpVALENCE(ep))
! 241: {
! 242: case EpVAR: case EpGVAR: break;
! 243: default: free_args((gp_args*)ep->args);
! 244: }
! 245: free((void*)ep->args);
! 246: }
! 247: free(ep);
! 248: }
! 249:
! 250: /*******************************************************************/
! 251: /* */
! 252: /* VARIABLES */
! 253: /* */
! 254: /*******************************************************************/
! 255: /* push_val and pop_val are private functions for use in sumiter and bibli2:
! 256: * we want a temporary value for ep, which is NOT a clone, to avoid
! 257: * unnecessary gaffect calls.
! 258: *
! 259: * Assumptions:
! 260: * EpVALENCE(ep) = EpVAR or EpGVAR
! 261: * ep->args initilized to NULL in installep()
! 262: */
! 263: static void
! 264: new_val_cell(entree *ep, GEN a, char flag)
! 265: {
! 266: var_cell *v = (var_cell*) gpmalloc(sizeof(var_cell));
! 267: v->value = (GEN)ep->value;
! 268: v->prev = (var_cell*) ep->args;
! 269: v->flag = flag;
! 270:
! 271: ep->args = (void*) v;
! 272: ep->value = a;
! 273: }
! 274:
! 275: void
! 276: push_val(entree *ep, GEN a)
! 277: {
! 278: new_val_cell(ep,a,PUSH_VAL);
! 279: }
! 280:
! 281: void
! 282: pop_val(entree *ep)
! 283: {
! 284: var_cell *v = (var_cell*) ep->args;
! 285:
! 286: if (!v) return; /* initial value */
! 287: if (v->flag == COPY_VAL) killbloc((GEN)ep->value);
! 288: ep->value = v->value;
! 289: ep->args = (void*) v->prev;
! 290: free((void*)v);
! 291: }
! 292:
! 293: int
! 294: pop_val_if_newer(entree *ep, long loc)
! 295: {
! 296: var_cell *v = (var_cell*) ep->args;
! 297:
! 298: if (!v) return 0; /* initial value */
! 299: if (v->flag == COPY_VAL)
! 300: {
! 301: GEN x = (GEN)ep->value;
! 302: if (bl_num(x) < loc) return 0; /* older */
! 303: killbloc((GEN)ep->value);
! 304: }
! 305: ep->value = v->value;
! 306: ep->args = (void*) v->prev;
! 307: free((void*)v); return 1;
! 308: }
! 309:
! 310: static void
! 311: changevalue(entree *ep, GEN val)
! 312: {
! 313: GEN x = gclone(val);
! 314: var_cell *v = (var_cell*) ep->args;
! 315:
! 316: if (!v) new_val_cell(ep,x, COPY_VAL);
! 317: else
! 318: {
! 319: if (v->flag == COPY_VAL) killbloc((GEN)ep->value); else v->flag = COPY_VAL;
! 320: ep->value = x;
! 321: }
! 322: }
! 323:
! 324: void
! 325: kill_from_hashlist(entree *ep)
! 326: {
! 327: long hash = hashvalue(ep->name);
! 328: entree *ep1;
! 329:
! 330: if (functions_hash[hash] == ep)
! 331: {
! 332: functions_hash[hash] = ep->next;
! 333: freeep(ep); return;
! 334: }
! 335: for (ep1 = functions_hash[hash]; ep1; ep1 = ep1->next)
! 336: if (ep1->next == ep)
! 337: {
! 338: ep1->next = ep->next;
! 339: freeep(ep); return;
! 340: }
! 341: }
! 342:
! 343: static entree*
! 344: get_ep(long v)
! 345: {
! 346: entree *ep = varentries[v];
! 347: if (!ep) err(talker2,"this function uses a killed variable",
! 348: mark.identifier, mark.start);
! 349: return ep;
! 350: }
! 351:
! 352: /* Kill entree ep, i.e free all memory it occupies, remove it from hashtable.
! 353: * If it's a variable set a "black hole" in polx[v], etc. x = 0-th variable
! 354: * can NOT be killed (only the value). That's because we use explicitly
! 355: * polx[0] at many places.
! 356: */
! 357: void
! 358: kill0(entree *ep)
! 359: {
! 360: long v;
! 361:
! 362: if (EpSTATIC(ep))
! 363: err(talker2,"can't kill that",mark.symbol,mark.start);
! 364: switch(EpVALENCE(ep))
! 365: {
! 366: case EpVAR:
! 367: case EpGVAR:
! 368: v = varn(initial_value(ep)); killvalue(v);
! 369: if (!v) return; /* never kill x */
! 370: polx[v] = polun[v] = gnil;
! 371: polvar[v+1] = (long)gnil;
! 372: varentries[v] = NULL; break;
! 373: case EpUSER:
! 374: gunclone((GEN)ep->value); break;
! 375: }
! 376: kill_from_hashlist(ep);
! 377: }
! 378:
! 379: /*******************************************************************/
! 380: /* */
! 381: /* PARSER */
! 382: /* */
! 383: /*******************************************************************/
! 384:
! 385: static GEN
! 386: seq(void)
! 387: {
! 388: const long av=avma, lim=stack_lim(av,1);
! 389: GEN res=gnil;
! 390:
! 391: for(;;)
! 392: {
! 393: while (separe(*analyseur)) analyseur++;
! 394: if (!*analyseur || *analyseur == ')' || *analyseur == ',') return res;
! 395: res = expr();
! 396: if (br_status || !separe(*analyseur)) return res;
! 397:
! 398: if (low_stack(lim, stack_lim(av,1)))
! 399: {
! 400: if(DEBUGMEM>1) err(warnmem,"seq");
! 401: if (is_universal_constant(res)) avma = av;
! 402: else
! 403: res = gerepileupto(av, gcopy(res));
! 404: }
! 405: }
! 406: }
! 407:
! 408: static GEN
! 409: gshift_l(GEN x, GEN n) { return gshift(x, itos(n)); }
! 410:
! 411: static GEN
! 412: gshift_r(GEN x, GEN n) { return gshift(x,-itos(n)); }
! 413:
! 414: static GEN
! 415: expr(void)
! 416: {
! 417: PFGEN f[] = { NULL,NULL,NULL,NULL };
! 418: GEN aux,e,e1,e2,e3;
! 419: long av = avma, lim = stack_lim(av,2);
! 420:
! 421: e1 = e2 = e3 = NULL;
! 422:
! 423: L3:
! 424: aux = facteur();
! 425: if (br_status) return NULL;
! 426: e3 = f[3]? f[3](e3,aux): aux;
! 427: switch(*analyseur)
! 428: {
! 429: case '*': analyseur++; f[3] = (PFGEN)&gmul; goto L3;
! 430: case '/': analyseur++; f[3] = (PFGEN)&gdiv; goto L3;
! 431: case '%': analyseur++; f[3] = (PFGEN)&gmod; goto L3;
! 432: case '\\':
! 433: if (*++analyseur == '/') { analyseur++; f[3]=(PFGEN)&gdivround; goto L3; }
! 434: f[3] = (PFGEN)&gdivent; goto L3;
! 435:
! 436: case '<': case '>':
! 437: if (analyseur[1] == *analyseur)
! 438: {
! 439: f[3] = (*analyseur == '<')? (PFGEN)&gshift_l
! 440: : (PFGEN)&gshift_r;
! 441: analyseur += 2; goto L3;
! 442: }
! 443: }
! 444: f[3] = NULL;
! 445:
! 446: L2:
! 447: if (!e3) goto L3;
! 448: e2 = f[2]? f[2](e2,e3): e3;
! 449: e3 = NULL;
! 450: if (low_stack(lim, stack_lim(av,2)))
! 451: {
! 452: GEN *gptr[2];
! 453: int n = 1; gptr[0]=&e2;
! 454: if (e1) gptr[n++]=&e1;
! 455: if(DEBUGMEM>1) err(warnmem,"expr");
! 456: gerepilemany(av,gptr,n);
! 457: }
! 458:
! 459: switch(*analyseur)
! 460: {
! 461: case '+': analyseur++; f[2]=(PFGEN)&gadd; goto L3;
! 462: case '-': analyseur++; f[2]=(PFGEN)&gsub; goto L3;
! 463: }
! 464: f[2] = NULL;
! 465:
! 466: L1:
! 467: if (!e2) goto L2;
! 468: e1 = f[1]? f[1](e1,e2): e2;
! 469: e2 = NULL;
! 470: switch(*analyseur)
! 471: {
! 472: case '<':
! 473: switch(*++analyseur)
! 474: {
! 475: case '=': analyseur++; f[1]=(PFGEN)&gle; goto L2;
! 476: case '>': analyseur++; f[1]=(PFGEN)⪈ goto L2;
! 477: }
! 478: f[1]=(PFGEN)&glt; goto L2;
! 479:
! 480: case '>':
! 481: if (*++analyseur == '=') { analyseur++; f[1]=(PFGEN)&gge; goto L2; }
! 482: f[1]=(PFGEN)&ggt; goto L2;
! 483:
! 484: case '=':
! 485: if (analyseur[1] == '=') { analyseur+=2; f[1]=(PFGEN)≥ goto L2; }
! 486: goto L1;
! 487:
! 488: case '!':
! 489: if (analyseur[1] == '=') { analyseur+=2; f[1]=(PFGEN)⪈ goto L2; }
! 490: goto L1;
! 491: }
! 492: f[1] = NULL;
! 493:
! 494: /* L0: */
! 495: if (!e1) goto L1;
! 496: e = f[0]? (gcmp0(e1)? gzero: gun): e1;
! 497: e1 = NULL;
! 498: switch(*analyseur)
! 499: {
! 500: case '&':
! 501: if (*++analyseur == '&') analyseur++;
! 502: if (gcmp0(e)) { skipexpr(); return gzero; }
! 503: f[0]=(PFGEN)1; goto L1;
! 504:
! 505: case '|':
! 506: if (*++analyseur == '|') analyseur++;
! 507: if (!gcmp0(e)) { skipexpr(); return gun; }
! 508: f[0]=(PFGEN)1; goto L1;
! 509: }
! 510: return e;
! 511: }
! 512:
! 513: /********************************************************************/
! 514: /** **/
! 515: /** CHECK FUNCTIONS **/
! 516: /** **/
! 517: /********************************************************************/
! 518:
! 519: /* if current identifier was a function in 1.39.15, raise "obsolete" error */
! 520: static void
! 521: err_new_fun()
! 522: {
! 523: char *s = NULL, str[128];
! 524:
! 525: if (check_new_fun)
! 526: {
! 527: if (check_new_fun != NOT_CREATED_YET)
! 528: {
! 529: s = strcpy(str,check_new_fun->name);
! 530: kill0(check_new_fun);
! 531: }
! 532: check_new_fun=NULL;
! 533: }
! 534: if (compatible == NONE)
! 535: {
! 536: char *v, *u = str, *lim = str + 127;
! 537: int n;
! 538:
! 539: if (!s)
! 540: { /* guess that the offending function was last identifier */
! 541: v = mark.identifier;
! 542: while (is_keyword_char(*v) && u < lim) *u++ = *v++;
! 543: *u = 0; s = str;
! 544: }
! 545: if (whatnow_fun)
! 546: n = whatnow_fun(s,1);
! 547: else
! 548: n = is_entry_intern(s,funct_old_hash,NULL)? 1: 0;
! 549: if (n) err(obsoler,mark.identifier,mark.start, s,n);
! 550: }
! 551: }
! 552:
! 553: #ifdef INLINE
! 554: INLINE
! 555: #endif
! 556: void
! 557: match2(char *s, char c)
! 558: {
! 559: if (*s != c)
! 560: {
! 561: char str[64];
! 562: if (check_new_fun && (c == '(' || c == '=' || c == ',')) err_new_fun();
! 563: sprintf(str,"expected character: '%c' instead of",c);
! 564: err(talker2,str,s,mark.start);
! 565: }
! 566: }
! 567:
! 568: #define match(c) match2(analyseur++, (c))
! 569:
! 570: static long
! 571: readlong()
! 572: {
! 573: const long av = avma;
! 574: const char *old = analyseur;
! 575: long m;
! 576: GEN arg = expr();
! 577:
! 578: if (br_status) err(breaker,"here (reading long)");
! 579: if (typ(arg) != t_INT) err(caseer,old,mark.start);
! 580: m = itos(arg); avma=av; return m;
! 581: }
! 582:
! 583: static long
! 584: check_array_index(long max)
! 585: {
! 586: const char *old = analyseur;
! 587: const long c = readlong();
! 588:
! 589: if (c < 1 || c >= max)
! 590: {
! 591: char s[80];
! 592: sprintf(s,"array index (%ld) out of allowed range ",c);
! 593: if (max == 1) strcat(s, "[none]");
! 594: else if (max == 2) strcat(s, "[1]");
! 595: else sprintf(s,"%s[1-%ld]",s,max-1);
! 596: err(talker2,s,old,mark.start);
! 597: }
! 598: return c;
! 599: }
! 600:
! 601: static long
! 602: readvar()
! 603: {
! 604: const char *old = analyseur;
! 605: const GEN x = expr();
! 606:
! 607: if (typ(x) != t_POL || lgef(x) != 4 ||
! 608: !gcmp0((GEN)x[2]) || !gcmp1((GEN)x[3])) err(varer1,old,mark.start);
! 609: return varn(x);
! 610: }
! 611:
! 612: /* alright !=0 means function was called without () */
! 613: static int
! 614: do_switch(int alright, int matchcomma)
! 615: {
! 616: if (alright || !*analyseur || *analyseur == ')' || separe(*analyseur))
! 617: return 1;
! 618: if (*analyseur == ',') /* we just read an arg, or first arg */
! 619: {
! 620: if (!matchcomma && analyseur[-1] == '(') return 1; /* first arg */
! 621: if (analyseur[1] == ',' || analyseur[1] == ')')
! 622: { analyseur++; return 1; }
! 623: }
! 624: return 0;
! 625: }
! 626:
! 627: /********************************************************************/
! 628: /** **/
! 629: /** READ FUNCTIONS **/
! 630: /** **/
! 631: /********************************************************************/
! 632:
! 633: static GEN
! 634: facteur(void)
! 635: {
! 636: const char *old = analyseur;
! 637: GEN x,p1;
! 638: int plus=1;
! 639:
! 640: switch(*analyseur)
! 641: {
! 642: case '-': plus=0; /* fall through */
! 643: case '+': analyseur++; break;
! 644: }
! 645: x = truc();
! 646: if (br_status) return NULL;
! 647:
! 648: for(;;)
! 649: switch(*analyseur)
! 650: {
! 651: case '.':
! 652: analyseur++; x = read_member(x);
! 653: if (!x) err(talker2, "not a proper member definition",
! 654: mark.member, mark.start);
! 655: break;
! 656: case '^':
! 657: analyseur++; p1 = facteur();
! 658: if (br_status) err(breaker,"here (after ^)");
! 659: x = gpui(x,p1,prec); break;
! 660: case '\'':
! 661: analyseur++; x = deriv(x,gvar9(x)); break;
! 662: case '~':
! 663: analyseur++; x = gtrans(x); break;
! 664: case '[':
! 665: x = matrix_block(x,NULL); break;
! 666: case '!':
! 667: if (analyseur[1] != '=')
! 668: {
! 669: if (typ(x) != t_INT) err(caseer,old,mark.start);
! 670: analyseur++; x=mpfact(itos(x)); break;
! 671: } /* Fall through */
! 672:
! 673: default:
! 674: return (plus || x==gnil)? x: gneg(x);
! 675: }
! 676: }
! 677:
! 678: #define check_var_name() \
! 679: if (!isalpha((int)*analyseur)) err(varer1,analyseur,mark.start);
! 680:
! 681: static GEN
! 682: truc(void)
! 683: {
! 684: long i,j, n=0, p=0, m=1, sizetab;
! 685: GEN *table,p1;
! 686: char *old;
! 687:
! 688: if (*analyseur == '!')
! 689: {
! 690: analyseur++; p1 = truc();
! 691: if (br_status) err(breaker,"here (after !)");
! 692: return gcmp0(p1)? gun: gzero;
! 693: }
! 694: if (*analyseur == '\'')
! 695: {
! 696: const char* old;
! 697: entree *ep;
! 698: analyseur++; check_var_name();
! 699: old = analyseur; ep = entry();
! 700: switch(EpVALENCE(ep))
! 701: {
! 702: case EpVAR: case EpGVAR:
! 703: return (GEN)initial_value(ep);
! 704: default: err(varer1,old,mark.start);
! 705: }
! 706: }
! 707: if (isalpha((int)*analyseur)) return identifier();
! 708:
! 709: if (*analyseur == '"') return strtoGENstr_t();
! 710: if (isdigit((int)*analyseur) || *analyseur == '.') return constante();
! 711: switch(*analyseur++)
! 712: {
! 713: case '(': p1=expr(); match(')'); return p1;
! 714:
! 715: case '[':
! 716: if (*analyseur == ';' && analyseur[1] == ']')
! 717: { analyseur+=2; return cgetg(1,t_MAT); }
! 718:
! 719: old=analyseur; analyseur--; sizetab=skiptruc(); analyseur=old;
! 720: table = (GEN*) gpmalloc((sizetab+1)*sizeof(GEN));
! 721:
! 722: if (*analyseur != ']')
! 723: {
! 724: table[++n] = expr();
! 725: if (br_status) err(breaker,"array context");
! 726: }
! 727: while (*analyseur == ',')
! 728: {
! 729: analyseur++;
! 730: table[++n] = expr();
! 731: if (br_status) err(breaker,"array context");
! 732: }
! 733: switch (*analyseur++)
! 734: {
! 735: case ']':
! 736: p1=cgetg(n+1,t_VEC);
! 737: for (i=1; i<=n; i++)
! 738: p1[i] = lcopy(table[i]);
! 739: break;
! 740:
! 741: case ';':
! 742: m = n;
! 743: do
! 744: {
! 745: table[++n] = expr();
! 746: if (br_status) err(breaker,"array context");
! 747: }
! 748: while (*analyseur++ != ']');
! 749: p = n/m + 1;
! 750: p1 = cgetg(m+1,t_MAT);
! 751: for (j=1; j<=m; j++)
! 752: {
! 753: p1[j] = lgetg(p,t_COL);
! 754: for (i=1; i<p; i++)
! 755: coeff(p1,i,j) = lcopy(table[(i-1)*m+j]);
! 756: }
! 757: break;
! 758:
! 759: default:
! 760: /* can only occur in library mode */
! 761: err(talker,"incorrect vector or matrix");
! 762: return NULL; /* not reached */
! 763: }
! 764: free(table); return p1;
! 765:
! 766: case '%':
! 767: old=analyseur-1; p=0;
! 768: if (! gp_history_fun)
! 769: err(talker2,"history not available in library mode",old,mark.start);
! 770: while (*analyseur == '`') { analyseur++; p++; }
! 771: return p ? gp_history_fun(p ,1,old,mark.start)
! 772: : gp_history_fun(number(&n),0,old,mark.start);
! 773: }
! 774: err(caracer1,analyseur-1,mark.start);
! 775: return NULL; /* not reached */
! 776: }
! 777:
! 778: /* valid x opop, e.g x++ */
! 779: #ifdef INLINE
! 780: INLINE
! 781: #endif
! 782: int
! 783: repeated_op()
! 784: {
! 785: char c = *analyseur;
! 786: return c == analyseur[1] && (c == '+' || c == '-');
! 787: }
! 788:
! 789: static GEN
! 790: matrix_block(GEN p, entree *ep)
! 791: {
! 792: long tx,full_col,full_row,c,r;
! 793: char *old;
! 794: GEN res, *pt, cpt;
! 795:
! 796: tx = full_col = full_row = 0; pt = &p;
! 797: while (*analyseur == '[')
! 798: {
! 799: analyseur++; p = *pt; tx = typ(p);
! 800: switch(tx)
! 801: {
! 802: case t_LIST:
! 803: c = check_array_index(lgef(p)-1) + 1;
! 804: pt = (GEN*)(p + c); match(']'); break;
! 805:
! 806: case t_VEC: case t_COL:
! 807: c = check_array_index(lg(p));
! 808: pt = (GEN*)(p + c); match(']'); break;
! 809:
! 810: case t_MAT:
! 811: if (lg(p)==1) err(talker2,"a 0x0 matrix has no elements",
! 812: analyseur,mark.start);
! 813: full_col = full_row = 0;
! 814: if (*analyseur==',') /* whole column */
! 815: {
! 816: analyseur++;
! 817: if (*analyseur != '[') full_col = 1;
! 818: c = check_array_index(lg(p));
! 819: pt = (GEN*)(p + c); match(']'); break;
! 820: }
! 821:
! 822: r = check_array_index(lg(p[1]));
! 823: match(',');
! 824: if (*analyseur == ']') /* whole row */
! 825: {
! 826: GEN p2 = cgetg(lg(p),t_VEC);
! 827: analyseur++;
! 828: if (*analyseur != '[') full_row = 1;
! 829: for (c=1; c<lg(p); c++) p2[c] = coeff(p,r,c);
! 830: pt = &p2;
! 831: }
! 832: else
! 833: {
! 834: c = check_array_index(lg(p));
! 835: pt = (GEN*)(((GEN)p[c]) + r); /* &coeff(p,r,c) */
! 836: match(']');
! 837: }
! 838: break;
! 839:
! 840: default:
! 841: err(caracer1,analyseur-1,mark.start);
! 842: }
! 843: }
! 844: old = analyseur;
! 845: cpt = *pt;
! 846:
! 847: if (*analyseur == '=') /* assignment or equality test */
! 848: {
! 849: if (analyseur[1] == '=') return cpt; /* test */
! 850:
! 851: analyseur++; old = analyseur; res = expr();
! 852: if (br_status) err(breaker,"assignment");
! 853: }
! 854: else if (repeated_op())
! 855: { /* a++, a-- */
! 856: res = gadd(cpt, (*analyseur == '+')? gun: negi(gun));
! 857: analyseur += 2;
! 858: }
! 859: else
! 860: {
! 861: GEN (*f)(GEN,GEN) = NULL;
! 862:
! 863: if (!*analyseur)
! 864: return (ep && !full_row)? cpt: gcopy(cpt);
! 865:
! 866: /* op= constructs ? */
! 867: if (analyseur[1] == '=')
! 868: {
! 869: switch(*analyseur)
! 870: {
! 871: case '+' : f = &gadd ; break;
! 872: case '-' : f = &gsub ; break;
! 873: case '*' : f = &gmul ; break;
! 874: case '/' : f = &gdiv ; break;
! 875: case '\\': f = &gdivent; break;
! 876: case '%' : f = &gmod ; break;
! 877: default:
! 878: return (ep && !full_row)? cpt: gcopy(cpt);
! 879: }
! 880: analyseur += 2;
! 881: }
! 882: else
! 883: {
! 884: if (analyseur[2] == '=')
! 885: switch(*analyseur)
! 886: {
! 887: case '>' :
! 888: if (analyseur[1]=='>') f = &gshift_r;
! 889: break;
! 890: case '<' :
! 891: if (analyseur[1]=='<') f = &gshift_l;
! 892: break;
! 893: case '\\':
! 894: if (analyseur[1]=='/') f = &gdivround;
! 895: break;
! 896: }
! 897: if (!f)
! 898: return (ep && !full_row)? cpt: gcopy(cpt);
! 899: analyseur += 3;
! 900: }
! 901: old = analyseur; res = expr();
! 902: if (br_status) err(breaker,"assignment");
! 903: res = f(cpt, res);
! 904: }
! 905:
! 906: /* assignment */
! 907: if (!ep) err(caracer1,analyseur,mark.start);
! 908:
! 909: if (!tx) /* simple variable */
! 910: {
! 911: changevalue(ep,res);
! 912: return (GEN) ep->value;
! 913: }
! 914:
! 915: if (full_row) /* whole row (index r) */
! 916: {
! 917: if (typ(res) != t_VEC || lg(res) != lg(p))
! 918: err(caseer2,old,mark.start);
! 919:
! 920: for (c=1; c<lg(p); c++)
! 921: {
! 922: GEN p2 = gcoeff(p,r,c); if (isclone(p2)) killbloc(p2);
! 923: coeff(p,r,c) = lclone((GEN)res[c]);
! 924: }
! 925: return res;
! 926: }
! 927:
! 928: res = gclone(res);
! 929: /* sanity check in case v[i] = f(), where f destroys v */
! 930: if (cpt != *pt)
! 931: 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);
! 932:
! 933: if (full_col) /* whole col */
! 934: {
! 935: if (typ(res) != t_COL || lg(res) != lg(cpt))
! 936: err(caseer2,old,mark.start);
! 937:
! 938: for (r=1; r<lg(cpt); r++)
! 939: if (isclone(cpt[r])) killbloc((GEN)cpt[r]);
! 940: }
! 941: /* no need to inspect if full_col (done above) */
! 942: if (isclone(cpt)) killbloc0(cpt, !full_col);
! 943: return *pt = res;
! 944: }
! 945:
! 946: static char*
! 947: init_buf(long len, char **ptbuf, char **ptlim)
! 948: {
! 949: char *buf = (char *)new_chunk(2 + len / sizeof(long));
! 950: *ptbuf = buf; *ptlim = buf + len; return buf;
! 951: }
! 952:
! 953: static char*
! 954: realloc_buf(char *bp, long len, char **ptbuf,char **ptlimit)
! 955: {
! 956: char *buf = *ptbuf;
! 957: long newlen = ((*ptlimit - buf) + len) << 1;
! 958: long oldlen = bp - buf;
! 959:
! 960: (void)init_buf(newlen, ptbuf, ptlimit);
! 961: memcpy(*ptbuf, buf, oldlen);
! 962: return *ptbuf + oldlen;
! 963: }
! 964:
! 965: static char *
! 966: expand_string(char *bp, char **ptbuf, char **ptlimit)
! 967: {
! 968: char *tmp, *s = analyseur;
! 969: long len, alloc = 1;
! 970:
! 971: while (is_keyword_char(*s)) s++;
! 972: if (*s == '"' || *s == ',' || *s == ')')
! 973: { /* Do not create new user variables */
! 974: entree *ep = is_entry_intern(analyseur, functions_hash,0);
! 975: if (!ep)
! 976: { /* consider as a literal */
! 977: tmp = analyseur;
! 978: len = s - analyseur;
! 979: analyseur = s; alloc = 0;
! 980: }
! 981: }
! 982: if (alloc)
! 983: {
! 984: long av = avma;
! 985: GEN p1 = expr();
! 986: if (br_status) err(breaker,"here (expanding string)");
! 987: tmp = GENtostr(p1);
! 988: len = strlen(tmp); avma = av;
! 989: }
! 990: if (ptlimit && bp + len > *ptlimit)
! 991: bp = realloc_buf(bp, len, ptbuf,ptlimit);
! 992: memcpy(bp,tmp,len); /* ignore trailing \0 */
! 993: if (alloc) free(tmp);
! 994: return bp + len;
! 995: }
! 996:
! 997: static char *
! 998: translate(char **src, char *s, char **ptbuf, char **ptlim)
! 999: {
! 1000: char *t = *src;
! 1001: while (*t)
! 1002: {
! 1003: while (*t == '\\')
! 1004: {
! 1005: switch(*++t)
! 1006: {
! 1007: case 'e': *s='\033'; break; /* escape */
! 1008: case 'n': *s='\n'; break;
! 1009: case 't': *s='\t'; break;
! 1010: default: *s=*t; if (!*t) err(talker,"unfinished string");
! 1011: }
! 1012: t++; s++;
! 1013: }
! 1014: if (*t == '"') break;
! 1015: if (ptlim && s >= *ptlim)
! 1016: s = realloc_buf(s,1, ptbuf,ptlim);
! 1017: *s++ = *t++;
! 1018: }
! 1019: *s=0; *src=t; return s;
! 1020: }
! 1021:
! 1022: static char *
! 1023: readstring_i(char *s, char **ptbuf, char **ptlim)
! 1024: {
! 1025: match('"'); s = translate(&analyseur,s, ptbuf,ptlim); match('"');
! 1026: return s;
! 1027: }
! 1028:
! 1029: static GEN
! 1030: any_string()
! 1031: {
! 1032: long n = 0, len = 16;
! 1033: GEN p1, res = new_chunk(len + 1);
! 1034:
! 1035: while (*analyseur)
! 1036: {
! 1037: if (*analyseur == '"')
! 1038: {
! 1039: res[n++] = (long) strtoGENstr_t();
! 1040: continue;
! 1041: }
! 1042: if (*analyseur == ')' || *analyseur == ';') break;
! 1043: if (*analyseur == ',')
! 1044: analyseur++;
! 1045: else
! 1046: {
! 1047: p1 = expr();
! 1048: if (br_status) err(breaker,"here (print)");
! 1049: res[n++] = (long) p1;
! 1050: }
! 1051: if (n == len)
! 1052: {
! 1053: long newlen = len << 1;
! 1054: p1 = new_chunk(newlen + 1);
! 1055: for (n = 0; n < len; n++) p1[n] = res[n];
! 1056: res = p1; len = newlen;
! 1057: }
! 1058: }
! 1059: res[n] = 0; /* end the sequence with NULL */
! 1060: return res;
! 1061: }
! 1062:
! 1063: /* Read a "string" from src. Format then copy it, starting at s. Return
! 1064: * pointer to the \0 which terminates the string.
! 1065: */
! 1066: char *
! 1067: readstring(char *src, char *s)
! 1068: {
! 1069: match2(src++, '"'); s = translate(&src, s, NULL,NULL);
! 1070: match2(src, '"'); return s;
! 1071: }
! 1072:
! 1073: static GEN
! 1074: strtoGENstr_t()
! 1075: {
! 1076: char *old = analyseur;
! 1077: long n;
! 1078: GEN x;
! 1079:
! 1080: skipstring(); n = analyseur-old - 1; /* don't count the enclosing '"' */
! 1081: old++; /* skip '"' */
! 1082: n = (n+BYTES_IN_LONG) >> TWOPOTBYTES_IN_LONG;
! 1083: x = cgetg(n+1, t_STR);
! 1084: translate(&old, GSTR(x), NULL,NULL);
! 1085: return x;
! 1086: }
! 1087:
! 1088: GEN
! 1089: strtoGENstr(char *s, long flag)
! 1090: {
! 1091: long n;
! 1092: GEN x;
! 1093:
! 1094: if (flag) s = expand_tilde(s);
! 1095: n = strlen(s)+1;
! 1096: n = (n+BYTES_IN_LONG) >> TWOPOTBYTES_IN_LONG;
! 1097: x = cgetg(n+1, t_STR);
! 1098: strcpy(GSTR(x), s);
! 1099: if (flag) free(s);
! 1100: return x;
! 1101: }
! 1102:
! 1103: /* p = NULL + array of variable numbers (longs) + function text */
! 1104: static GEN
! 1105: call_fun(GEN p, GEN *arg, GEN *loc, int narg, int nloc)
! 1106: {
! 1107: GEN res;
! 1108: long i;
! 1109:
! 1110: p++; /* skip NULL */
! 1111: /* push new values for formal parameters */
! 1112: for (i=0; i<narg; i++) copyvalue(*p++, *arg++);
! 1113: for (i=0; i<nloc; i++) pushvalue(*p++, *loc++);
! 1114: /* dumps the false GEN arglist from identifier() to the garbage zone */
! 1115: res = lisseq((char *)p);
! 1116: if (br_status != br_NONE)
! 1117: br_status = br_NONE;
! 1118: else
! 1119: if (! is_universal_constant(res)) /* important for gnil */
! 1120: res = forcecopy(res); /* make result safe */
! 1121:
! 1122: /* pop ancient values for formal parameters */
! 1123: for (i=0; i<nloc; i++) killvalue(*--p);
! 1124: for (i=0; i<narg; i++) killvalue(*--p);
! 1125: return res;
! 1126: }
! 1127:
! 1128: entree *
! 1129: do_alias(entree *ep)
! 1130: {
! 1131: while (ep->valence == EpALIAS) ep = (entree *) ((GEN)ep->value)[1];
! 1132: return ep;
! 1133: }
! 1134:
! 1135: static GEN
! 1136: global0()
! 1137: {
! 1138: GEN res = gnil;
! 1139: long i,n;
! 1140:
! 1141: for (i=0,n=lg(polvar)-1; n>=0; n--)
! 1142: {
! 1143: entree *ep = varentries[n];
! 1144: if (ep && EpVALENCE(ep) == EpGVAR)
! 1145: {
! 1146: res=new_chunk(1);
! 1147: res[0]=(long)polx[n]; i++;
! 1148: }
! 1149: }
! 1150: if (i) { res = cgetg(1,t_VEC); setlg(res, i+1); }
! 1151: return res;
! 1152: }
! 1153:
! 1154: static void
! 1155: check_pointer(unsigned int ptrs, GEN argvec[])
! 1156: {
! 1157: unsigned int i;
! 1158: for (i=0; ptrs; i++,ptrs>>=1)
! 1159: if (ptrs & 1) *((GEN*)argvec[i]) = gclone(*((GEN*)argvec[i]));
! 1160: }
! 1161:
! 1162: #define match_comma() if (matchcomma) match(','); else matchcomma = 1
! 1163:
! 1164: long
! 1165: check_args()
! 1166: {
! 1167: long nparam = 0, matchcomma = 0;
! 1168: entree *ep;
! 1169: char *old;
! 1170: GEN cell;
! 1171:
! 1172: while (*analyseur != ')')
! 1173: {
! 1174: old=analyseur; nparam++; match_comma();
! 1175: cell = new_chunk(2);
! 1176: if (!isalpha((int)*analyseur))
! 1177: {
! 1178: err_new_fun();
! 1179: err(paramer1, mark.identifier, mark.start);
! 1180: }
! 1181: ep = entry();
! 1182: if (EpVALENCE(ep) != EpVAR)
! 1183: {
! 1184: err_new_fun();
! 1185: if (EpVALENCE(ep) == EpGVAR)
! 1186: err(talker2,"global variable: ",old , mark.start);
! 1187: err(paramer1, old, mark.start);
! 1188: }
! 1189: cell[0] = varn(initial_value(ep));
! 1190: if (*analyseur == '=')
! 1191: {
! 1192: long av = avma;
! 1193: GEN p1;
! 1194: analyseur++; p1 = expr();
! 1195: if (br_status) err(breaker,"here (default args)");
! 1196: cell[1] = lclone(p1);
! 1197: avma = av;
! 1198: }
! 1199: else cell[1] = zero;
! 1200: }
! 1201: return nparam;
! 1202: }
! 1203:
! 1204: #define DFT_VAR (GEN)-1
! 1205: #define DFT_GEN (GEN)NULL
! 1206:
! 1207: static GEN
! 1208: identifier(void)
! 1209: {
! 1210: long m,i,av,matchcomma;
! 1211: char *ch1;
! 1212: entree *ep;
! 1213: GEN res, newfun, ptr;
! 1214:
! 1215: mark.identifier = analyseur; ep = entry();
! 1216: if (EpVALENCE(ep)==EpVAR || EpVALENCE(ep)==EpGVAR)
! 1217: { /* optimized for simple variables */
! 1218: switch (*analyseur)
! 1219: {
! 1220: case ')': case ',': return (GEN)ep->value;
! 1221: case '.':
! 1222: {
! 1223: long len, v;
! 1224:
! 1225: analyseur++; ch1 = analyseur;
! 1226: if ((res = read_member((GEN)ep->value))) return res;
! 1227:
! 1228: /* define a new member function */
! 1229: v = varn(initial_value(ep));
! 1230: len = analyseur - ch1;
! 1231: analyseur++; /* skip = */
! 1232: ep = installep(NULL,ch1,len,EpMEMBER,0, members_hash + hashvalue(ch1));
! 1233: ch1 = analyseur; skipseq(); len = analyseur-ch1;
! 1234:
! 1235: newfun=ptr= (GEN) newbloc(1 + (len>>TWOPOTBYTES_IN_LONG) + 4);
! 1236: newfun++; /* this bloc is no GEN, leave the first cell alone ( = 0) */
! 1237: *newfun++ = v;
! 1238:
! 1239: /* record text */
! 1240: strncpy((char *)newfun, ch1, len);
! 1241: ((char *) newfun)[len] = 0;
! 1242: ep->value = (void *)ptr; return gnil;
! 1243: }
! 1244: }
! 1245: return matrix_block((GEN) ep->value,ep);
! 1246: }
! 1247: ep = do_alias(ep); matchcomma = 0;
! 1248: if (ep->code)
! 1249: {
! 1250: char *s = ep->code, *oldanalyseur = NULL, *buf, *limit, *bp;
! 1251: unsigned int ret = RET_GEN, alright=0, has_pointer=0;
! 1252: long fake;
! 1253: void *call = ep->value;
! 1254: GEN argvec[9];
! 1255:
! 1256: if (*analyseur == '(') analyseur++;
! 1257: else
! 1258: { /* if no mandatory argument, no () needed */
! 1259: if (EpVALENCE(ep)) match('('); /* error */
! 1260:
! 1261: if (!*s || (!s[1] && *s == 'p'))
! 1262: return ((GEN (*)(long))ep->value)(prec);
! 1263: alright=1; /* no arg was given, but valence is ok */
! 1264: }
! 1265: i = 0;
! 1266: /* Optimized for G and p. */
! 1267: while (*s == 'G')
! 1268: {
! 1269: match_comma(); s++;
! 1270: argvec[i++] = expr();
! 1271: if (br_status) err(breaker,"here (argument reading)");
! 1272: }
! 1273: if (*s == 'p') { argvec[i++] = (GEN) prec; s++; }
! 1274:
! 1275: while (*s)
! 1276: switch (*s++)
! 1277: {
! 1278: case 'G': /* GEN */
! 1279: match_comma(); argvec[i++] = expr();
! 1280: if (br_status) err(breaker,"here (argument reading)");
! 1281: break;
! 1282:
! 1283: case 'L': /* long */
! 1284: match_comma(); argvec[i++] = (GEN) readlong(); break;
! 1285:
! 1286: case 'n': /* var number */
! 1287: match_comma(); argvec[i++] = (GEN) readvar(); break;
! 1288:
! 1289: case 'V': case 'S': /* variable or symbol */
! 1290: match_comma(); mark.symbol=analyseur;
! 1291: argvec[i++] = (GEN)entry(); break;
! 1292: case '&': /* *GEN */
! 1293: match_comma(); match('&'); mark.symbol=analyseur;
! 1294: {
! 1295: entree *e = entry();
! 1296: if (e->value == (void*)initial_value(e))
! 1297: changevalue(e, gzero); /* don't overwrite initial value */
! 1298: has_pointer |= (1 << i);
! 1299: argvec[i++] = (GEN) &(e->value); break;
! 1300: }
! 1301: case 'I': /* Input position */
! 1302: match_comma();
! 1303: argvec[i++] = (GEN) analyseur;
! 1304: skipseq(); break;
! 1305:
! 1306: case 'r': /* raw */
! 1307: match_comma(); mark.raw = analyseur;
! 1308: bp = init_buf(256, &buf,&limit);
! 1309: while (*analyseur)
! 1310: {
! 1311: if (*analyseur == ',' || *analyseur == ')') break;
! 1312: if (*analyseur == '"')
! 1313: bp = readstring_i(bp, &buf,&limit);
! 1314: else
! 1315: {
! 1316: if (bp > limit)
! 1317: bp = realloc_buf(bp,1, &buf,&limit);
! 1318: *bp++ = *analyseur++;
! 1319: }
! 1320: }
! 1321: *bp++ = 0; argvec[i++] = (GEN) buf;
! 1322: break;
! 1323:
! 1324: case 's': /* expanded string; empty arg yields "" */
! 1325: match_comma();
! 1326: if (*s == '*') /* any number of string objects */
! 1327: {
! 1328: argvec[i++] = any_string();
! 1329: s++; break;
! 1330: }
! 1331:
! 1332: bp = init_buf(256, &buf,&limit);
! 1333: while (*analyseur)
! 1334: {
! 1335: if (*analyseur == ',' || *analyseur == ')') break;
! 1336: if (*analyseur == '"')
! 1337: bp = readstring_i(bp, &buf,&limit);
! 1338: else
! 1339: bp = expand_string(bp, &buf,&limit);
! 1340: }
! 1341: *bp++ = 0; argvec[i++] = (GEN)buf;
! 1342: break;
! 1343:
! 1344: case 'p': /* precision */
! 1345: argvec[i++] = (GEN) prec; break;
! 1346:
! 1347: case '=':
! 1348: match('='); matchcomma = 0; break;
! 1349:
! 1350: case 'D': /* Has a default value */
! 1351: if (do_switch(alright,matchcomma))
! 1352: switch (*s)
! 1353: {
! 1354: case 'G':
! 1355: case '&':
! 1356: case 'I':
! 1357: case 'V': argvec[i++]=DFT_GEN; s++; break;
! 1358: case 'n': argvec[i++]=DFT_VAR; s++; break;
! 1359: default:
! 1360: oldanalyseur = analyseur;
! 1361: analyseur = s; matchcomma = 0;
! 1362: while (*s++ != ',');
! 1363: }
! 1364: else
! 1365: switch (*s)
! 1366: {
! 1367: case 'G':
! 1368: case '&':
! 1369: case 'I':
! 1370: case 'V':
! 1371: case 'n': break;
! 1372: default:
! 1373: while (*s++ != ',');
! 1374: }
! 1375: break;
! 1376:
! 1377: case 'P': /* series precision */
! 1378: argvec[i++] = (GEN) precdl; break;
! 1379:
! 1380: case 'f': /* Fake *long argument */
! 1381: argvec[i++] = (GEN) &fake; break;
! 1382:
! 1383: case 'x': /* Foreign function */
! 1384: argvec[i++] = (GEN) ep; call = foreignHandler; break;
! 1385:
! 1386: case 'l': /* Return long */
! 1387: ret = RET_INT; break;
! 1388:
! 1389: case 'v': /* Return void */
! 1390: ret = RET_VOID; break;
! 1391:
! 1392: case ',': /* Clean up default */
! 1393: if (oldanalyseur)
! 1394: {
! 1395: analyseur = oldanalyseur;
! 1396: oldanalyseur = NULL; matchcomma=1;
! 1397: }
! 1398: break;
! 1399: default: err(bugparier,"identifier (unknown code)");
! 1400: }
! 1401: #if 0 /* uncomment if using purify: unitialized read otherwise */
! 1402: for ( ; i<9; i++) argvec[i]=NULL;
! 1403: #endif
! 1404: switch (ret)
! 1405: {
! 1406: case RET_GEN:
! 1407: res = ((PFGEN)call)(argvec[0], argvec[1], argvec[2], argvec[3],
! 1408: argvec[4], argvec[5], argvec[6], argvec[7], argvec[8]);
! 1409: break;
! 1410:
! 1411: case RET_INT:
! 1412: m = ((long (*)(ANYARG))call)(argvec[0], argvec[1], argvec[2], argvec[3],
! 1413: argvec[4], argvec[5], argvec[6], argvec[7], argvec[8]);
! 1414: res = stoi(m); break;
! 1415:
! 1416: case RET_VOID:
! 1417: ((void (*)(ANYARG))call)(argvec[0], argvec[1], argvec[2], argvec[3],
! 1418: argvec[4], argvec[5], argvec[6], argvec[7], argvec[8]);
! 1419: res = gnil; break;
! 1420: }
! 1421: if (has_pointer) check_pointer(has_pointer,argvec);
! 1422: if (!alright) match(')');
! 1423: return res;
! 1424: }
! 1425:
! 1426: if (EpPREDEFINED(ep))
! 1427: {
! 1428: if (*analyseur != '(')
! 1429: {
! 1430: if (EpVALENCE(ep) == 88) return global0();
! 1431: match('('); /* error */
! 1432: }
! 1433: analyseur++;
! 1434: switch(EpVALENCE(ep))
! 1435: {
! 1436: case 50: /* O */
! 1437: res = truc();
! 1438: if (br_status) err(breaker,"here (in O()))");
! 1439: if (*analyseur=='^') { analyseur++; m = readlong(); } else m = 1;
! 1440: res = ggrando(res,m); break;
! 1441:
! 1442: case 80: /* if then else */
! 1443: av = avma; res = expr();
! 1444: if (br_status) err(breaker,"test expressions");
! 1445: m = gcmp0(res); avma = av; match(',');
! 1446: if (m) /* false */
! 1447: {
! 1448: skipseq();
! 1449: if (*analyseur == ')') res = gnil;
! 1450: else
! 1451: {
! 1452: match(',');
! 1453: res = seq(); if (br_status) { res = NULL; skipseq(); }
! 1454: }
! 1455: }
! 1456: else /* true */
! 1457: {
! 1458: res = seq(); if (br_status) { res = NULL; skipseq(); }
! 1459: if (*analyseur != ')') { match(','); skipseq(); }
! 1460: }
! 1461: break;
! 1462:
! 1463: case 81: /* while do */
! 1464: av = avma; ch1 = analyseur;
! 1465: for(;;)
! 1466: {
! 1467: res = expr();
! 1468: if (br_status) err(breaker,"test expressions");
! 1469: if (gcmp0(res)) { match(','); break; }
! 1470:
! 1471: avma = av; match(','); (void)seq();
! 1472: if (loop_break()) break;
! 1473: analyseur = ch1;
! 1474: }
! 1475: avma = av; skipseq(); res = gnil; break;
! 1476:
! 1477: case 82: /* repeat until */
! 1478: av = avma; ch1 = analyseur; skipexpr();
! 1479: for(;;)
! 1480: {
! 1481: avma = av; match(','); (void)seq();
! 1482: if (loop_break()) break;
! 1483: analyseur = ch1;
! 1484: res = expr();
! 1485: if (br_status) err(breaker,"test expressions");
! 1486: if (!gcmp0(res)) { match(','); break; }
! 1487: }
! 1488: avma = av; skipseq(); res = gnil; break;
! 1489:
! 1490: case 88: /* global */
! 1491: if (*analyseur == ')') return global0();
! 1492: while (*analyseur != ')')
! 1493: {
! 1494: match_comma(); ch1=analyseur;
! 1495: ep = skipentry();
! 1496: switch(EpVALENCE(ep))
! 1497: {
! 1498: case EpGVAR:
! 1499: err(warner,"%s already declared global", ep->name);
! 1500: /* fall through */
! 1501: case EpVAR: break;
! 1502: default: err(talker2,"symbol already in use",ch1,mark.start);
! 1503: }
! 1504: analyseur=ch1; ep = entry();
! 1505: if (*analyseur == '=')
! 1506: {
! 1507: long av=avma; analyseur++;
! 1508: res = expr();
! 1509: if (br_status) err(breaker,"here (defining global var)");
! 1510: changevalue(ep, res); avma=av;
! 1511: }
! 1512: ep->valence = EpGVAR;
! 1513: }
! 1514: res = gnil; break;
! 1515:
! 1516: default: err(valencer1);
! 1517: }
! 1518: match(')'); return res;
! 1519: }
! 1520:
! 1521: switch (EpVALENCE(ep))
! 1522: {
! 1523: GEN *defarg; /* = default args, and values for local variables */
! 1524: int narg, nloc;
! 1525: gp_args *f;
! 1526:
! 1527: case EpUSER: /* user-defined functions */
! 1528: f = (gp_args*)ep->args;
! 1529: defarg = f->arg;
! 1530: narg = f->narg;
! 1531: nloc = f->nloc;
! 1532: if (*analyseur != '(') /* no args */
! 1533: {
! 1534: if (*analyseur != '=' || analyseur[1] == '=')
! 1535: return call_fun((GEN)ep->value, defarg, defarg+narg, narg, nloc);
! 1536: match('('); /* ==> error */
! 1537: }
! 1538: if (analyseur != redefine_fun)
! 1539: {
! 1540: GEN *arglist = (GEN*) new_chunk(narg);
! 1541: ch1 = analyseur; analyseur++;
! 1542: for (i=0; i<narg; i++)
! 1543: {
! 1544: if (do_switch(0,matchcomma))
! 1545: { matchcomma=1 ; arglist[i] = defarg[i]; } /* default arg */
! 1546: else
! 1547: { /* user supplied */
! 1548: match_comma(); res = expr();
! 1549: if (br_status) err(breaker,"here (reading function args)");
! 1550: arglist[i] = res;
! 1551: }
! 1552: }
! 1553: if (*analyseur++ == ')' && (*analyseur != '=' || analyseur[1] == '='))
! 1554: return call_fun((GEN)ep->value, arglist, defarg+narg, narg, nloc);
! 1555:
! 1556: /* should happen only in cases like (f()= f()=); f (!!!) */
! 1557: analyseur--;
! 1558: if (*analyseur != ',' && *analyseur != ')') skipexpr();
! 1559: while (*analyseur == ',') { analyseur++; skipexpr(); }
! 1560: match(')');
! 1561: if (*analyseur != '=' || analyseur[1] == '=')
! 1562: err(nparamer1,mark.identifier,mark.start);
! 1563: matchcomma=0; analyseur = ch1;
! 1564: }
! 1565: redefine_fun = NULL;
! 1566: free_args((gp_args*)ep->args);
! 1567: /* Fall through */
! 1568:
! 1569: case EpNEW: /* new function */
! 1570: {
! 1571: GEN tmpargs = (GEN)avma;
! 1572: char *start;
! 1573: long len;
! 1574:
! 1575: check_new_fun = ep;
! 1576:
! 1577: /* checking arguments */
! 1578: match('('); ch1 = analyseur;
! 1579: narg = check_args(); nloc = 0;
! 1580: match(')'); match('=');
! 1581: while (strncmp(analyseur,"local(",6) == 0)
! 1582: {
! 1583: analyseur += 6;
! 1584: nloc += check_args();
! 1585: match(')'); while(separe(*analyseur)) analyseur++;
! 1586: }
! 1587: { /* checking function definition */
! 1588: char *oldredef = redefine_fun;
! 1589: skipping_fun_def++;
! 1590: start = analyseur; skipseq(); len = analyseur-start;
! 1591: skipping_fun_def--; redefine_fun = oldredef;
! 1592: }
! 1593: /* function is ok. record it */
! 1594: newfun = ptr = (GEN) newbloc(narg+nloc + (len>>TWOPOTBYTES_IN_LONG) + 4);
! 1595: newfun++; /* this bloc is no GEN, leave the first cell alone ( = 0) */
! 1596:
! 1597: /* record default args */
! 1598: f = (gp_args*) gpmalloc((narg+nloc)*sizeof(GEN) + sizeof(gp_args));
! 1599: ep->args = (void*) f;
! 1600: f->nloc = nloc;
! 1601: f->narg = narg;
! 1602: f->arg = defarg = (GEN*)(f + 1);
! 1603: narg += nloc; /* record default args and local variables */
! 1604: for (i = 1; i <= narg; i++)
! 1605: {
! 1606: GEN cell = tmpargs-(i<<1);
! 1607: *newfun++ = cell[0];
! 1608: *defarg++ = (GEN)cell[1];
! 1609: }
! 1610: if (narg > 1)
! 1611: { /* check for duplicates */
! 1612: GEN x = new_chunk(narg), v = ptr+1;
! 1613: long k;
! 1614: for (i=0; i<narg; i++) x[i] = v[i];
! 1615: qsort(x,narg,sizeof(long),(QSCOMP)pari_compare_long);
! 1616: for (k=x[0],i=1; i<narg; k=x[i],i++)
! 1617: if (x[i] == k)
! 1618: err(talker,"user function %s: variable %Z declared twice",
! 1619: ep->name, polx[k]);
! 1620: }
! 1621:
! 1622: /* record text */
! 1623: strncpy((char *)newfun, start, len);
! 1624: ((char *) newfun)[len] = 0;
! 1625: if (EpVALENCE(ep) == EpUSER) gunclone((GEN)ep->value);
! 1626: /* have to wait till here because of the above line. (f()=f()=x). Text
! 1627: * of new fun is given by value of the old one, which had to be kept
! 1628: */
! 1629: ep->value = (void *)ptr;
! 1630: ep->valence = EpUSER;
! 1631: check_new_fun=NULL;
! 1632: avma = (long)tmpargs; return gnil;
! 1633: }
! 1634: }
! 1635: err(valencer1); return NULL; /* not reached */
! 1636: }
! 1637:
! 1638: static long
! 1639: number(long *nb)
! 1640: {
! 1641: long m = 0;
! 1642: for (*nb = 0; *nb < 9 && isdigit((int)*analyseur); (*nb)++)
! 1643: m = 10*m + (*analyseur++ - '0');
! 1644: return m;
! 1645: }
! 1646:
! 1647: static GEN
! 1648: constante()
! 1649: {
! 1650: static long pw10[] = { 1, 10, 100, 1000, 10000, 100000, 1000000,
! 1651: 10000000, 100000000, 1000000000 };
! 1652: long l,m,n = 0,nb, av = avma, limite = stack_lim(av,1);
! 1653: GEN z,y;
! 1654:
! 1655: y = stoi(number(&nb));
! 1656: while (isdigit((int)*analyseur))
! 1657: {
! 1658: m = number(&nb);
! 1659: y = addsi(m, mulsi(pw10[nb],y));
! 1660: if (low_stack(limite, stack_lim(av,1))) y = gerepileupto(av,y);
! 1661: }
! 1662: switch(*analyseur)
! 1663: {
! 1664: default: return y; /* integer */
! 1665: case '.':
! 1666: analyseur++;
! 1667: while (isdigit((int)*analyseur))
! 1668: {
! 1669: m = number(&nb); n -= nb;
! 1670: y = addsi(m, mulsi(pw10[nb],y));
! 1671: if (low_stack(limite, stack_lim(av,1))) y = gerepileupto(av,y);
! 1672: }
! 1673: if (*analyseur != 'E' && *analyseur != 'e') break;
! 1674: /* Fall through */
! 1675: case 'E': case 'e':
! 1676: {
! 1677: char *old = analyseur;
! 1678: switch(*++analyseur)
! 1679: {
! 1680: case '-': analyseur++; n -= number(&nb); break;
! 1681: case '+': analyseur++; /* Fall through */
! 1682: default: n += number(&nb);
! 1683: }
! 1684: if (nb > 8) err(talker2,"exponent too large: ",old,mark.start);
! 1685: }
! 1686: }
! 1687: l=lgefint(y); if (l<prec) l=prec;
! 1688: if (n)
! 1689: {
! 1690: new_chunk(l); /* hack: mulrr and divrr need exactly l words */
! 1691: z=cgetr(l); affir(y,z);
! 1692: y=cgetr(l); affsr(10,y); y = gpuigs(y, labs(n));
! 1693: avma = av; /* hidden gerepile */
! 1694: return n > 0 ? mulrr(z,y) : divrr(z,y);
! 1695: }
! 1696: z=cgetr(l); affir(y,z); return z;
! 1697: }
! 1698:
! 1699: /********************************************************************/
! 1700: /** **/
! 1701: /** HASH TABLE MANIPULATIONS **/
! 1702: /** **/
! 1703: /********************************************************************/
! 1704: /* slighlty more efficient than is_keyword_char. Not worth a static array. */
! 1705: #define is_key(c) (isalnum((int)(c)) || (c)=='_')
! 1706:
! 1707: long
! 1708: is_keyword_char(char c) { return is_key(c); }
! 1709:
! 1710: /* return hashing value for identifier s (analyseur is s = NULL) */
! 1711: long
! 1712: hashvalue(char *s)
! 1713: {
! 1714: long update, n = 0;
! 1715:
! 1716: if (!s) { s = analyseur; update = 1; } else update = 0;
! 1717: while (is_key(*s)) { n = (n<<1) ^ *s; s++; }
! 1718: if (update) analyseur = s;
! 1719: if (n < 0) n = -n;
! 1720: return n % functions_tblsz;
! 1721: }
! 1722:
! 1723: /* Looking for entry in hashtable. ep1 is the cell's first element */
! 1724: static entree *
! 1725: findentry(char *name, long len, entree *ep1)
! 1726: {
! 1727: entree *ep;
! 1728:
! 1729: for (ep = ep1; ep; ep = ep->next)
! 1730: if (!strncmp(ep->name, name, len) && !(ep->name)[len]) return ep;
! 1731:
! 1732: if (foreignAutoload) /* Try to autoload. */
! 1733: return foreignAutoload(name, len);
! 1734: return NULL; /* not found */
! 1735: }
! 1736:
! 1737: entree *
! 1738: is_entry_intern(char *s, entree **table, long *pthash)
! 1739: {
! 1740: char *old = analyseur;
! 1741: long hash, len;
! 1742:
! 1743: analyseur = s; hash = hashvalue(NULL);
! 1744: len = analyseur - s; analyseur = old;
! 1745: if (pthash) *pthash = hash;
! 1746: return findentry(s,len,table[hash]);
! 1747: }
! 1748:
! 1749: int
! 1750: is_identifier(char *s)
! 1751: {
! 1752: while (*s && is_keyword_char(*s)) s++;
! 1753: return *s? 0: 1;
! 1754: }
! 1755:
! 1756: static entree *
! 1757: installep(void *f, char *name, int len, int valence, int add, entree **table)
! 1758: {
! 1759: entree *ep = (entree *) gpmalloc(sizeof(entree) + add + len+1);
! 1760: const entree *ep1 = initial_value(ep);
! 1761: char *u = (char *) ep1 + add;
! 1762:
! 1763: ep->name = u; strncpy(u, name,len); u[len]=0;
! 1764: ep->args = NULL; ep->help = NULL; ep->code = NULL;
! 1765: ep->value = f? f: (void *) ep1;
! 1766: ep->next = *table;
! 1767: ep->valence = valence;
! 1768: ep->menu = 0;
! 1769: return *table = ep;
! 1770: }
! 1771:
! 1772: long
! 1773: manage_var(long n, entree *ep)
! 1774: {
! 1775: static long max_avail = MAXVARN; /* first user variable not yet used */
! 1776: static long nvar; /* first GP free variable */
! 1777: long var;
! 1778: GEN p;
! 1779:
! 1780: if (n) /* special behaviour */
! 1781: {
! 1782: switch(n)
! 1783: {
! 1784: case 2: return nvar=0;
! 1785: case 3: return nvar;
! 1786: case 4: return max_avail;
! 1787: case 5:
! 1788: {
! 1789: long v = (long)ep;
! 1790: if (v != nvar-1) err(talker,"can't pop gp variable");
! 1791: setlg(polvar, nvar);
! 1792: return --nvar;
! 1793: }
! 1794: }
! 1795:
! 1796: /* user wants to delete one of his/her/its variables */
! 1797: if (max_avail == MAXVARN-1) return 0; /* nothing to delete */
! 1798: free(polx[++max_avail]); /* frees both polun and polx */
! 1799: return max_avail+1;
! 1800: }
! 1801:
! 1802: if (nvar == max_avail) err(talker2,"no more variables available",
! 1803: mark.identifier, mark.start);
! 1804: if (ep)
! 1805: {
! 1806: p = (GEN)ep->value;
! 1807: var=nvar++;
! 1808: }
! 1809: else
! 1810: {
! 1811: p = (GEN) gpmalloc(7*sizeof(long));
! 1812: var=max_avail--;
! 1813: }
! 1814:
! 1815: /* create polx[var] */
! 1816: p[0] = evaltyp(t_POL) | evallg(4);
! 1817: p[1] = evalsigne(1) | evallgef(4) | evalvarn(var);
! 1818: p[2] = zero; p[3] = un;
! 1819: polx[var] = p;
! 1820:
! 1821: /* create polun[nvar] */
! 1822: p += 4;
! 1823: p[0] = evaltyp(t_POL) | evallg(3);
! 1824: p[1] = evalsigne(1) | evallgef(3) | evalvarn(var);
! 1825: p[2] = un;
! 1826: polun[var] = p;
! 1827:
! 1828: varentries[var] = ep;
! 1829: if (ep) { polvar[nvar] = (long) ep->value; setlg(polvar, nvar+1); }
! 1830: return var;
! 1831: }
! 1832:
! 1833: long
! 1834: fetch_var()
! 1835: {
! 1836: return manage_var(0,NULL);
! 1837: }
! 1838:
! 1839: entree *
! 1840: fetch_named_var(char *s, int doerr)
! 1841: {
! 1842: entree *ep = is_entry(s);
! 1843: if (ep)
! 1844: {
! 1845: if (doerr) err(talker,"identifier already in use: %s", s);
! 1846: return ep;
! 1847: }
! 1848: ep = installep(NULL,s,strlen(s),EpVAR, 7*sizeof(long),
! 1849: functions_hash + hashvalue(s));
! 1850: manage_var(0,ep); return ep;
! 1851: }
! 1852:
! 1853: long
! 1854: fetch_user_var(char *s)
! 1855: {
! 1856: entree *ep = is_entry(s);
! 1857: long av;
! 1858: GEN p1;
! 1859:
! 1860: if (ep)
! 1861: {
! 1862: switch (EpVALENCE(ep))
! 1863: {
! 1864: case EpVAR: case EpGVAR:
! 1865: return varn(initial_value(ep));
! 1866: }
! 1867: err(talker, "%s already exists with incompatible valence", s);
! 1868: }
! 1869: av=avma; p1 = lisexpr(s); avma=av;
! 1870: return varn(p1);
! 1871: }
! 1872:
! 1873: void
! 1874: delete_named_var(entree *ep)
! 1875: {
! 1876: manage_var(5, (entree*)varn(initial_value(ep)));
! 1877: kill0(ep);
! 1878: }
! 1879:
! 1880: long
! 1881: delete_var()
! 1882: {
! 1883: return manage_var(1,NULL);
! 1884: }
! 1885:
! 1886: void
! 1887: name_var(long n, char *s)
! 1888: {
! 1889: entree *ep;
! 1890: char *u;
! 1891:
! 1892: if (n < manage_var(3,NULL))
! 1893: err(talker, "renaming a GP variable is forbidden");
! 1894: if (n > MAXVARN)
! 1895: err(talker, "variable number too big");
! 1896:
! 1897: ep = (entree*)gpmalloc(sizeof(entree) + strlen(s) + 1);
! 1898: u = (char *)initial_value(ep);
! 1899: ep->valence = EpVAR;
! 1900: ep->name = u; strcpy(u,s);
! 1901: ep->value = gzero; /* in case geval would be called */
! 1902: if (varentries[n]) free(varentries[n]);
! 1903: varentries[n] = ep;
! 1904: }
! 1905:
! 1906: /* Find entry or create it */
! 1907: static entree *
! 1908: entry(void)
! 1909: {
! 1910: char *old = analyseur;
! 1911: const long hash = hashvalue(NULL), len = analyseur - old;
! 1912: entree *ep = findentry(old,len,functions_hash[hash]);
! 1913: long val,n;
! 1914:
! 1915: if (ep) return ep;
! 1916: if (compatible == WARN)
! 1917: {
! 1918: ep = findentry(old,len,funct_old_hash[hash]);
! 1919: if (ep) return ep; /* the warning was done in skipentry() */
! 1920: }
! 1921: /* ep does not exist. Create it */
! 1922: if (*analyseur == '(')
! 1923: { n=0; val=EpNEW; }
! 1924: else
! 1925: { n=7*sizeof(long); val=EpVAR; }
! 1926: ep = installep(NULL,old,len,val,n, functions_hash + hash);
! 1927:
! 1928: if (n) manage_var(0,ep); /* Variable */
! 1929: return ep;
! 1930: }
! 1931:
! 1932: /********************************************************************/
! 1933: /** **/
! 1934: /** SKIP FUNCTIONS **/
! 1935: /** **/
! 1936: /********************************************************************/
! 1937:
! 1938: /* as skipseq without modifying analyseur && al */
! 1939: static void
! 1940: doskipseq(char *c, int strict)
! 1941: {
! 1942: char *olds = analyseur;
! 1943:
! 1944: mark.start = c; analyseur = c; skipseq();
! 1945: if (*analyseur)
! 1946: {
! 1947: if (strict) err(talker2,"unused characters", analyseur, c);
! 1948: err(warner, "unused characters: %s", analyseur);
! 1949: }
! 1950: analyseur = olds;
! 1951: }
! 1952:
! 1953: static void
! 1954: skipstring()
! 1955: {
! 1956: match('"');
! 1957: while (*analyseur)
! 1958: switch (*analyseur++)
! 1959: {
! 1960: case '"': return;
! 1961: case '\\': analyseur++;
! 1962: }
! 1963: match('"');
! 1964: }
! 1965:
! 1966: static void
! 1967: skip_matrix_block(int no_affect)
! 1968: {
! 1969: while (*analyseur == '[')
! 1970: {
! 1971: analyseur++;
! 1972: if (*analyseur == ',') { analyseur++; skipexpr(); }
! 1973: else
! 1974: {
! 1975: skipexpr();
! 1976: if (*analyseur == ',')
! 1977: if (*++analyseur != ']') skipexpr();
! 1978: }
! 1979: match(']');
! 1980: }
! 1981:
! 1982: if (*analyseur == '=' && analyseur[1] != '=')
! 1983: {
! 1984: if (no_affect) err(caracer1,analyseur,mark.start);
! 1985: analyseur++; skipexpr(); return;
! 1986: }
! 1987: if (repeated_op())
! 1988: {
! 1989: if (no_affect) err(caracer1,analyseur,mark.start);
! 1990: analyseur+=2; return;
! 1991: }
! 1992: if (!*analyseur) return;
! 1993: if (analyseur[1] != '=')
! 1994: {
! 1995: switch(*analyseur)
! 1996: {
! 1997: case '>': case '<':
! 1998: if (analyseur[1] != *analyseur || analyseur[2] != '=') return;
! 1999: if (no_affect) err(caracer1,analyseur,mark.start);
! 2000: analyseur+=3; skipexpr(); return;
! 2001: case '\\':
! 2002: if (analyseur[1] != '/' || analyseur[2] != '=') return;
! 2003: if (no_affect) err(caracer1,analyseur,mark.start);
! 2004: analyseur+=3; skipexpr(); return;
! 2005: }
! 2006: return;
! 2007: }
! 2008:
! 2009: switch(*analyseur)
! 2010: {
! 2011: case '+': case '-': case '*': case '/': case '\\': case '%':
! 2012: if (no_affect) err(caracer1,analyseur,mark.start);
! 2013: analyseur+=2; skipexpr(); return;
! 2014: }
! 2015: }
! 2016:
! 2017: static void
! 2018: skipseq(void)
! 2019: {
! 2020: for(;;)
! 2021: {
! 2022: while (separe(*analyseur)) analyseur++;
! 2023: if (*analyseur == ',' || *analyseur == ')' || !*analyseur) return;
! 2024: skipexpr(); if (!separe(*analyseur)) return;
! 2025: }
! 2026: }
! 2027:
! 2028: static void
! 2029: skipexpr(void)
! 2030: {
! 2031: int e1 = 0, e2 = 0, e3;
! 2032:
! 2033: L3:
! 2034: e3=1; skipfacteur();
! 2035: switch(*analyseur)
! 2036: {
! 2037: case '*': case '/': case '%':
! 2038: analyseur++; goto L3;
! 2039: case '\\':
! 2040: if (*++analyseur == '/') analyseur++;
! 2041: goto L3;
! 2042: case '<': case '>':
! 2043: if (analyseur[1]==*analyseur) { analyseur +=2; goto L3; }
! 2044: }
! 2045:
! 2046: L2:
! 2047: if (!e3) goto L3;
! 2048: e3=0; e2=1;
! 2049: switch(*analyseur)
! 2050: {
! 2051: case '+': case '-':
! 2052: analyseur++; goto L3;
! 2053: }
! 2054:
! 2055: L1:
! 2056: if (!e2) goto L2;
! 2057: e2=0; e1=1;
! 2058: switch(*analyseur)
! 2059: {
! 2060: case '<':
! 2061: switch(*++analyseur)
! 2062: {
! 2063: case '=': case '>': analyseur++;
! 2064: }
! 2065: goto L2;
! 2066:
! 2067: case '>':
! 2068: if (*++analyseur == '=') analyseur++;
! 2069: goto L2;
! 2070:
! 2071: case '=': case '!':
! 2072: if (analyseur[1] == '=') { analyseur+=2; goto L2; }
! 2073: goto L1;
! 2074: }
! 2075:
! 2076: /* L0: */
! 2077: if (!e1) goto L1;
! 2078: e1=0;
! 2079: switch(*analyseur)
! 2080: {
! 2081: case '&':
! 2082: if (*++analyseur == '&') analyseur++;
! 2083: goto L1;
! 2084: case '|':
! 2085: if (*++analyseur == '|') analyseur++;
! 2086: goto L1;
! 2087: }
! 2088: }
! 2089:
! 2090: static void
! 2091: skipfacteur(void)
! 2092: {
! 2093: if (*analyseur == '+' || *analyseur == '-') analyseur++;
! 2094: skiptruc();
! 2095: for(;;)
! 2096: switch(*analyseur)
! 2097: {
! 2098: case '.':
! 2099: analyseur++; while (isalnum((int)*analyseur)) analyseur++;
! 2100: if (*analyseur == '=' && analyseur[1] != '=')
! 2101: { analyseur++; skipseq(); }
! 2102: break;
! 2103: case '^':
! 2104: analyseur++; skipfacteur(); break;
! 2105: case '~': case '\'':
! 2106: analyseur++; break;
! 2107: case '[':
! 2108: skip_matrix_block(1); break;
! 2109: case '!':
! 2110: if (analyseur[1] != '=') { analyseur++; break; }
! 2111: default: return;
! 2112: }
! 2113: }
! 2114:
! 2115: /* return the number of elements we need to read if array/matrix */
! 2116: static long
! 2117: skiptruc(void)
! 2118: {
! 2119: long n=0;
! 2120: char *old;
! 2121:
! 2122: if (*analyseur == '"') { skipstring(); return 0; }
! 2123: if (*analyseur == '!') { analyseur++; skiptruc(); return 0; }
! 2124: if (*analyseur == '\'')
! 2125: {
! 2126: analyseur++; check_var_name();
! 2127: skipentry(); return 0;
! 2128: }
! 2129: if (isalpha((int)*analyseur))
! 2130: { skipidentifier(); return 0; }
! 2131: if (isdigit((int)*analyseur) || *analyseur== '.')
! 2132: { skipconstante(); return 0; }
! 2133: switch(*analyseur++)
! 2134: {
! 2135: case '(':
! 2136: skipexpr(); match(')'); return 0;
! 2137: case '[':
! 2138: old = analyseur-1;
! 2139: if (*analyseur == ';' && analyseur[1] == ']') /* 0 x 0 matrix */
! 2140: { analyseur+=2; return 0; }
! 2141: if (*analyseur != ']')
! 2142: {
! 2143: do { n++; skipexpr(); old=analyseur; }
! 2144: while (*analyseur++ == ',');
! 2145: analyseur--;
! 2146: }
! 2147: switch (*analyseur)
! 2148: {
! 2149: case ']': analyseur++; return n;
! 2150: case ';':
! 2151: {
! 2152: long m, norig=n; /* number of elts in first line */
! 2153: old=analyseur;
! 2154: do {
! 2155: m=n;
! 2156: do { n++; analyseur++; skipexpr(); }
! 2157: while (*analyseur != ';' && *analyseur != ']');
! 2158: if (n-m != norig)
! 2159: err(talker2,"non rectangular matrix",old,mark.start);
! 2160: } while (*analyseur != ']');
! 2161: analyseur++; return n;
! 2162: }
! 2163: default:
! 2164: err(talker2,"; or ] expected",old,mark.start);
! 2165: return 0; /* not reached */
! 2166: }
! 2167: case '%':
! 2168: if (*analyseur == '`') { while (*++analyseur == '`'); return 0; }
! 2169: number(&n); return 0;
! 2170: }
! 2171: err(caracer1,analyseur-1,mark.start);
! 2172: return 0; /* not reached */
! 2173: }
! 2174:
! 2175: static void
! 2176: check_var()
! 2177: {
! 2178: char *old = analyseur;
! 2179: check_var_name();
! 2180: switch(EpVALENCE(skipentry()))
! 2181: {
! 2182: case EpVAR: break;
! 2183: case EpGVAR:
! 2184: err(talker2,"global variable not allowed", old,mark.start);
! 2185: default: err(varer1,old,mark.start);
! 2186: }
! 2187: }
! 2188:
! 2189: static void
! 2190: skipidentifier(void)
! 2191: {
! 2192: int matchcomma=0;
! 2193: entree *ep;
! 2194: char *old;
! 2195:
! 2196: mark.identifier = analyseur; ep = do_alias(skipentry());
! 2197: if (ep->code)
! 2198: {
! 2199: char *s = ep->code;
! 2200:
! 2201: if (*analyseur != '(')
! 2202: {
! 2203: if (EpVALENCE(ep) == 0) return; /* no mandatory argument */
! 2204: match('('); /* ==> error */
! 2205: }
! 2206: analyseur++;
! 2207:
! 2208: /* Optimized for G and p. */
! 2209: while (*s == 'G') { match_comma(); skipexpr(); s++; }
! 2210: if (*s == 'p') s++;
! 2211: while (*s) switch (*s++)
! 2212: {
! 2213: case 'G': case 'n': case 'L':
! 2214: match_comma();
! 2215: if (*analyseur == ',' || *analyseur == ')') break;
! 2216: skipexpr(); break;
! 2217: case 'I':
! 2218: match_comma(); skipseq(); break;
! 2219: case 'r':
! 2220: match_comma();
! 2221: while (*analyseur)
! 2222: {
! 2223: while (*analyseur == '"') skipstring();
! 2224: if (*analyseur == ',' || *analyseur == ')') break;
! 2225: analyseur++;
! 2226: }
! 2227: break;
! 2228: case 's':
! 2229: match_comma();
! 2230: if (*s == '*')
! 2231: {
! 2232: while (*analyseur)
! 2233: {
! 2234: while (*analyseur == '"') skipstring();
! 2235: if (*analyseur == ')') break;
! 2236: if (*analyseur == ',') analyseur++;
! 2237: else skipexpr();
! 2238: }
! 2239: s++; if (*s == 'p' || *s == 't') s++;
! 2240: break;
! 2241: }
! 2242:
! 2243: while (*analyseur)
! 2244: {
! 2245: while (*analyseur == '"') skipstring();
! 2246: if (*analyseur == ')' || *analyseur == ',') break;
! 2247: skipexpr();
! 2248: }
! 2249: break;
! 2250:
! 2251: case 'S': match_comma();
! 2252: check_var_name(); skipentry(); break;
! 2253: case '&': match_comma(); match('&'); check_var(); break;
! 2254: case 'V': match_comma(); check_var(); break;
! 2255:
! 2256: case 'p': case 'P': case 'l': case 'v': case 'f': case 'x':
! 2257: break;
! 2258:
! 2259: case 'D':
! 2260: if ( *analyseur == ')' ) { analyseur++; return; }
! 2261: if (*s == 'G' || *s == '&' || *s == 'n' || *s == 'I' || *s == 'V')
! 2262: break;
! 2263: while (*s++ != ',');
! 2264: break;
! 2265: case '=':
! 2266: match('='); matchcomma = 0; break;
! 2267: case ',':
! 2268: matchcomma=1; break;
! 2269: default:
! 2270: err(bugparier,"skipidentifier (unknown code)");
! 2271: }
! 2272: match(')');
! 2273: return;
! 2274: }
! 2275: if (EpPREDEFINED(ep))
! 2276: {
! 2277: if (*analyseur != '(')
! 2278: {
! 2279: switch(EpVALENCE(ep))
! 2280: {
! 2281: case 0:
! 2282: case 88: return;
! 2283: }
! 2284: match('('); /* error */
! 2285: }
! 2286: analyseur++;
! 2287: switch(EpVALENCE(ep))
! 2288: {
! 2289: case 50: skiptruc();
! 2290: if (*analyseur == '^') { analyseur++; skipfacteur(); };
! 2291: break;
! 2292: case 80: skipexpr(); match(','); skipseq();
! 2293: if (*analyseur != ')') { match(','); skipseq(); }
! 2294: break;
! 2295: case 81: case 82: skipexpr(); match(','); skipseq(); break;
! 2296: case 88:
! 2297: while (*analyseur != ')') { match_comma(); skipexpr(); };
! 2298: break;
! 2299: default: err(valencer1);
! 2300: }
! 2301: match(')'); return;
! 2302: }
! 2303: switch (EpVALENCE(ep))
! 2304: {
! 2305: case EpGVAR:
! 2306: case EpVAR: /* variables */
! 2307: skip_matrix_block(0); return;
! 2308:
! 2309: case EpUSER: /* fonctions utilisateur */
! 2310: {
! 2311: char *ch1 = analyseur;
! 2312: gp_args *f;
! 2313: int i;
! 2314:
! 2315: if (*analyseur != '(')
! 2316: {
! 2317: if ( *analyseur != '=' || analyseur[1] == '=' ) return;
! 2318: match('('); /* error */
! 2319: }
! 2320: f = (gp_args*)ep->args;
! 2321: analyseur++; /* skip '(' */
! 2322: for (i = f->nloc + f->narg; i; i--)
! 2323: {
! 2324: if (do_switch(0,matchcomma)) matchcomma=1;
! 2325: else { match_comma(); skipexpr(); }
! 2326: }
! 2327:
! 2328: if (*analyseur == ')')
! 2329: if ( analyseur[1] != '=' || analyseur[2] == '=' )
! 2330: { analyseur++; return; }
! 2331:
! 2332: /* here we are redefining a user function */
! 2333: old = analyseur;
! 2334: if (*analyseur != ',' && *analyseur != ')') skipexpr();
! 2335: while (*analyseur == ',') { analyseur++; skipexpr(); }
! 2336: match(')');
! 2337:
! 2338: if (*analyseur != '=' || analyseur[1] == '=')
! 2339: {
! 2340: if (skipping_fun_def) return;
! 2341: err(nparamer1,old,mark.start);
! 2342: }
! 2343: analyseur = ch1; matchcomma = 0;
! 2344: if (!redefine_fun) redefine_fun = analyseur;
! 2345: } /* fall through */
! 2346:
! 2347: case EpNEW: /* new function */
! 2348: if (check_new_fun && ! skipping_fun_def)
! 2349: {
! 2350: err_new_fun(); /* ep not created yet: no need to kill it */
! 2351: err(paramer1, mark.identifier, mark.start);
! 2352: }
! 2353: check_new_fun = NOT_CREATED_YET; match('(');
! 2354: while (*analyseur != ')') { match_comma(); skipexpr(); };
! 2355: match(')');
! 2356: if (*analyseur == '=')
! 2357: {
! 2358: skipping_fun_def++;
! 2359: analyseur++; skipseq();
! 2360: skipping_fun_def--;
! 2361: }
! 2362: check_new_fun=NULL; return;
! 2363:
! 2364: default: err(valencer1);
! 2365: }
! 2366: }
! 2367:
! 2368: static void
! 2369: skipconstante(void)
! 2370: {
! 2371: while (isdigit((int)*analyseur)) analyseur++;
! 2372: if ( *analyseur!='.' && *analyseur!='e' && *analyseur!='E' ) return;
! 2373: if (*analyseur=='.') analyseur++;
! 2374: while (isdigit((int)*analyseur)) analyseur++;
! 2375: if ( *analyseur=='e' || *analyseur=='E' )
! 2376: {
! 2377: analyseur++;
! 2378: if ( *analyseur=='+' || *analyseur=='-' ) analyseur++;
! 2379: while (isdigit((int)*analyseur)) analyseur++;
! 2380: }
! 2381: }
! 2382:
! 2383: static entree *
! 2384: skipentry(void)
! 2385: {
! 2386: static entree fakeEpNEW = { "",EpNEW };
! 2387: static entree fakeEpVAR = { "",EpVAR };
! 2388: char *old = analyseur;
! 2389: const long hash = hashvalue(NULL), len = analyseur - old;
! 2390: entree *ep = findentry(old,len,functions_hash[hash]);
! 2391:
! 2392: if (ep) return ep;
! 2393: if (compatible == WARN)
! 2394: {
! 2395: ep = findentry(old,len,funct_old_hash[hash]);
! 2396: if (ep)
! 2397: {
! 2398: err(warner,"using obsolete function %s",ep->name);
! 2399: return ep;
! 2400: }
! 2401: }
! 2402: return (*analyseur == '(') ? &fakeEpNEW : &fakeEpVAR;
! 2403: }
! 2404:
! 2405: /********************************************************************/
! 2406: /** **/
! 2407: /** MEMBER FUNCTIONS **/
! 2408: /** **/
! 2409: /********************************************************************/
! 2410: static GEN
! 2411: e(GEN x)
! 2412: {
! 2413: x = get_primeid(x);
! 2414: if (!x) err(member,"e",mark.member,mark.start);
! 2415: return (GEN)x[3];
! 2416: }
! 2417:
! 2418: static GEN
! 2419: f(GEN x)
! 2420: {
! 2421: x = get_primeid(x);
! 2422: if (!x) err(member,"f",mark.member,mark.start);
! 2423: return (GEN)x[4];
! 2424: }
! 2425:
! 2426: static GEN
! 2427: p(GEN x)
! 2428: {
! 2429: x = get_primeid(x);
! 2430: if (!x) err(member,"p",mark.member,mark.start);
! 2431: return (GEN)x[1];
! 2432: }
! 2433:
! 2434: static GEN
! 2435: bnf(GEN x)
! 2436: {
! 2437: int t; x = get_bnf(x,&t);
! 2438: if (!x) err(member,"bnf",mark.member,mark.start);
! 2439: return x;
! 2440: }
! 2441:
! 2442: static GEN
! 2443: nf(GEN x)
! 2444: {
! 2445: int t; x = get_nf(x,&t);
! 2446: if (!x) err(member,"nf",mark.member,mark.start);
! 2447: return x;
! 2448: }
! 2449:
! 2450: /* integral basis */
! 2451: static GEN
! 2452: zk(GEN x)
! 2453: {
! 2454: int t; GEN y = get_nf(x,&t);
! 2455: if (!y)
! 2456: {
! 2457: switch(t)
! 2458: {
! 2459: case typ_CLA: return gmael(x,1,4);
! 2460: case typ_Q: y = cgetg(3,t_VEC);
! 2461: y[1]=un; y[2]=lpolx[varn(x[1])]; return y;
! 2462: }
! 2463: err(member,"zk",mark.member,mark.start);
! 2464: }
! 2465: return (GEN)y[7];
! 2466: }
! 2467:
! 2468: static GEN
! 2469: disc(GEN x) /* discriminant */
! 2470: {
! 2471: int t; GEN y = get_nf(x,&t);
! 2472: if (!y)
! 2473: {
! 2474: switch(t)
! 2475: {
! 2476: case typ_Q : return discsr((GEN)x[1]);
! 2477: case typ_CLA: return gmael3(x,1,3,1);
! 2478: case typ_ELL: return (GEN)x[12];
! 2479: }
! 2480: err(member,"disc",mark.member,mark.start);
! 2481: }
! 2482: return (GEN)y[3];
! 2483: }
! 2484:
! 2485: static GEN
! 2486: pol(GEN x) /* polynomial */
! 2487: {
! 2488: int t; GEN y = get_nf(x,&t);
! 2489: if (!y)
! 2490: {
! 2491: switch(t)
! 2492: {
! 2493: case typ_CLA: return gmael(x,1,1);
! 2494: case typ_POL: return x;
! 2495: case typ_Q : return (GEN)x[1];
! 2496: }
! 2497: if (typ(x)==t_POLMOD) return (GEN)x[2];
! 2498: err(member,"pol",mark.member,mark.start);
! 2499: }
! 2500: return (GEN)y[1];
! 2501: }
! 2502:
! 2503: static GEN
! 2504: mod(GEN x) /* modulus */
! 2505: {
! 2506: switch(typ(x))
! 2507: {
! 2508: case t_INTMOD: case t_POLMOD: case t_QUAD: break;
! 2509: default: err(member,"mod",mark.member,mark.start);
! 2510: }
! 2511: return (GEN)x[1];
! 2512: }
! 2513:
! 2514: static GEN
! 2515: sign(GEN x) /* signature */
! 2516: {
! 2517: int t; GEN y = get_nf(x,&t);
! 2518: if (!y)
! 2519: {
! 2520: if (t == typ_CLA) return gmael(x,1,2);
! 2521: err(member,"sign",mark.member,mark.start);
! 2522: }
! 2523: return (GEN)y[2];
! 2524: }
! 2525:
! 2526: static GEN
! 2527: t2(GEN x) /* T2 matrix */
! 2528: {
! 2529: int t; x = get_nf(x,&t);
! 2530: if (!x) err(member,"t2",mark.member,mark.start);
! 2531: return gmael(x,5,3);
! 2532: }
! 2533:
! 2534: static GEN
! 2535: diff(GEN x) /* different */
! 2536: {
! 2537: int t; x = get_nf(x,&t);
! 2538: if (!x) err(member,"diff",mark.member,mark.start);
! 2539: return gmael(x,5,5);
! 2540: }
! 2541:
! 2542: static GEN
! 2543: codiff(GEN x) /* codifferent */
! 2544: {
! 2545: int t; x = get_nf(x,&t);
! 2546: if (!x) err(member,"codiff",mark.member,mark.start);
! 2547: return gdiv(gmael(x,5,7), absi((GEN) x[3]));
! 2548: }
! 2549:
! 2550: static GEN
! 2551: mroots(GEN x) /* roots */
! 2552: {
! 2553: int t; GEN y = get_nf(x,&t);
! 2554: if (!y)
! 2555: {
! 2556: if (t == typ_ELL) return (GEN)x[14];
! 2557: err(member,"roots",mark.member,mark.start);
! 2558: }
! 2559: return (GEN)y[6];
! 2560: }
! 2561:
! 2562: static GEN
! 2563: clgp(GEN x) /* class group (3-component row vector) */
! 2564: {
! 2565: int t; GEN y = get_bnf(x,&t);
! 2566: if (!y)
! 2567: {
! 2568: switch(t)
! 2569: {
! 2570: case typ_QUA:
! 2571: y = cgetg(4,t_VEC);
! 2572: for(t=1; t<4; t++) y[t] = x[t];
! 2573: return y;
! 2574: case typ_CLA: return gmael(x,1,5);
! 2575: }
! 2576: if (typ(x)==t_VEC)
! 2577: switch(lg(x))
! 2578: {
! 2579: case 3: /* no gen */
! 2580: case 4: return x;
! 2581: }
! 2582: err(member,"clgp",mark.member,mark.start);
! 2583: }
! 2584: if (t==typ_BNR) return (GEN)x[5];
! 2585: return gmael(y,8,1);
! 2586: }
! 2587:
! 2588: static GEN
! 2589: reg(GEN x) /* regulator */
! 2590: {
! 2591: int t; GEN y = get_bnf(x,&t);
! 2592: if (!y)
! 2593: {
! 2594: switch(t)
! 2595: {
! 2596: case typ_CLA: return gmael(x,1,6);
! 2597: case typ_QUA: return (GEN)x[4];
! 2598: }
! 2599: err(member,"reg",mark.member,mark.start);
! 2600: }
! 2601: if (t == typ_BNR) err(impl,"ray regulator");
! 2602: return gmael(x,8,2);
! 2603: }
! 2604:
! 2605: static GEN
! 2606: fu(GEN x) /* fundamental units */
! 2607: {
! 2608: int t; GEN y = get_bnf(x,&t);
! 2609: if (!y)
! 2610: {
! 2611: switch(t)
! 2612: {
! 2613: case typ_CLA: x = (GEN)x[1]; if (lg(x)<11) break;
! 2614: return (GEN)x[9];
! 2615: case typ_Q:
! 2616: x = discsr((GEN)x[1]);
! 2617: return (signe(x)<0)? cgetg(1,t_VEC): fundunit(x);
! 2618: }
! 2619: err(member,"fu",mark.member,mark.start);
! 2620: }
! 2621: if (t == typ_BNR) err(impl,"ray units");
! 2622: return check_units(y,".fu");
! 2623: }
! 2624:
! 2625: /* torsion units. return [w,e] where w is the number of roots of 1, and e a
! 2626: * polymod generator */
! 2627: static GEN
! 2628: tu(GEN x)
! 2629: {
! 2630: int t; GEN y = get_bnf(x,&t), res = cgetg(3,t_VEC);
! 2631: if (!y)
! 2632: {
! 2633: switch(t)
! 2634: {
! 2635: case typ_Q:
! 2636: y = discsr((GEN)x[1]);
! 2637: if (signe(y)<0 && cmpis(y,-4)>=0)
! 2638: y = stoi((itos(y) == -4)? 4: 6);
! 2639: else
! 2640: { y = gdeux; x=negi(gun); }
! 2641: res[1] = (long)y;
! 2642: res[2] = (long)x; return res;
! 2643: case typ_CLA:
! 2644: if (lg(x[1])==11) break;
! 2645: default: err(member,"tu",mark.member,mark.start);
! 2646: }
! 2647: x = (GEN) x[1]; y=(GEN)x[8];
! 2648: }
! 2649: else
! 2650: {
! 2651: if (t == typ_BNR) err(impl,"ray torsion units");
! 2652: x = (GEN)y[7]; y=(GEN)y[8];
! 2653: if (lg(y) > 5) y = (GEN)y[4];
! 2654: else
! 2655: {
! 2656: y = rootsof1(x);
! 2657: y[2] = lmul((GEN)x[7], (GEN)y[2]);
! 2658: }
! 2659: }
! 2660: res[2] = y[2];
! 2661: res[1] = y[1]; return res;
! 2662: }
! 2663:
! 2664: static GEN
! 2665: futu(GEN x) /* concatenation of fu and tu, w is lost */
! 2666: {
! 2667: GEN fuc = fu(x);
! 2668: return concat(fuc, (GEN)tu(x)[2]);
! 2669: }
! 2670:
! 2671: static GEN
! 2672: tufu(GEN x) /* concatenation of tu and fu, w is lost */
! 2673: {
! 2674: GEN fuc = fu(x);
! 2675: return concat((GEN) tu(x)[2], fuc);
! 2676: }
! 2677:
! 2678: static GEN
! 2679: zkst(GEN bid)
! 2680: /* structure of (Z_K/m)^*, where bid is an idealstarinit (with or without gen)
! 2681: or a bnrinit (with or without gen) */
! 2682: {
! 2683: if (typ(bid)==t_VEC)
! 2684: switch(lg(bid))
! 2685: {
! 2686: case 6: return (GEN) bid[2]; /* idealstarinit */
! 2687: case 7: return gmael(bid,2,2); /* bnrinit */
! 2688: }
! 2689: err(member,"zkst",mark.member,mark.start);
! 2690: return NULL; /* not reached */
! 2691: }
! 2692:
! 2693: static GEN
! 2694: no(GEN clg) /* number of elements of a group (of type clgp) */
! 2695: {
! 2696: clg = clgp(clg);
! 2697: if (typ(clg)!=t_VEC || (lg(clg)!=3 && lg(clg)!=4))
! 2698: err(member,"no",mark.member,mark.start);
! 2699: return (GEN) clg[1];
! 2700: }
! 2701:
! 2702: static GEN
! 2703: cyc(GEN clg) /* cyclic decomposition (SNF) of a group (of type clgp) */
! 2704: {
! 2705: clg = clgp(clg);
! 2706: if (typ(clg)!=t_VEC || (lg(clg)!=3 && lg(clg)!=4))
! 2707: err(member,"cyc",mark.member,mark.start);
! 2708: return (GEN) clg[2];
! 2709: }
! 2710:
! 2711: /* SNF generators of a group (of type clgp), or generators of a prime
! 2712: * ideal
! 2713: */
! 2714: static GEN
! 2715: gen(GEN x)
! 2716: {
! 2717: GEN y = get_primeid(x);
! 2718: if (y)
! 2719: {
! 2720: x = cgetg(3,t_VEC);
! 2721: x[1] = lcopy((GEN)y[1]);
! 2722: x[2] = lcopy((GEN)y[2]);
! 2723: return x;
! 2724: }
! 2725: x = clgp(x);
! 2726: if (typ(x)!=t_VEC || lg(x)!=4)
! 2727: err(member,"gen",mark.member,mark.start);
! 2728: if (typ(x[1]) == t_COL) return (GEN)x[2]; /* from bnfisprincipal */
! 2729: return (GEN) x[3];
! 2730: }
! 2731:
! 2732: #define is_ell(x) (typ(x) == t_VEC && lg(x)>=14)
! 2733: #define is_bigell(x) (typ(x) == t_VEC && lg(x)>=20)
! 2734:
! 2735: static GEN
! 2736: a1(GEN x)
! 2737: {
! 2738: if (!is_ell(x)) err(member,"a1",mark.member,mark.start);
! 2739: return (GEN)x[1];
! 2740: }
! 2741:
! 2742: static GEN
! 2743: a2(GEN x)
! 2744: {
! 2745: if (!is_ell(x)) err(member,"a2",mark.member,mark.start);
! 2746: return (GEN)x[2];
! 2747: }
! 2748:
! 2749: static GEN
! 2750: a3(GEN x)
! 2751: {
! 2752: if (!is_ell(x)) err(member,"a3",mark.member,mark.start);
! 2753: return (GEN)x[3];
! 2754: }
! 2755:
! 2756: static GEN
! 2757: a4(GEN x)
! 2758: {
! 2759: if (!is_ell(x)) err(member,"a4",mark.member,mark.start);
! 2760: return (GEN)x[4];
! 2761: }
! 2762:
! 2763: static GEN
! 2764: a6(GEN x)
! 2765: {
! 2766: if (!is_ell(x)) err(member,"a6",mark.member,mark.start);
! 2767: return (GEN)x[5];
! 2768: }
! 2769:
! 2770: static GEN
! 2771: b2(GEN x)
! 2772: {
! 2773: if (!is_ell(x)) err(member,"b2",mark.member,mark.start);
! 2774: return (GEN)x[6];
! 2775: }
! 2776:
! 2777: static GEN
! 2778: b4(GEN x)
! 2779: {
! 2780: if (!is_ell(x)) err(member,"b4",mark.member,mark.start);
! 2781: return (GEN)x[7];
! 2782: }
! 2783:
! 2784: static GEN
! 2785: b6(GEN x)
! 2786: {
! 2787: if (!is_ell(x)) err(member,"b6",mark.member,mark.start);
! 2788: return (GEN)x[8];
! 2789: }
! 2790:
! 2791: static GEN
! 2792: b8(GEN x)
! 2793: {
! 2794: if (!is_ell(x)) err(member,"b8",mark.member,mark.start);
! 2795: return (GEN)x[9];
! 2796: }
! 2797:
! 2798: static GEN
! 2799: c4(GEN x)
! 2800: {
! 2801: if (!is_ell(x)) err(member,"c4",mark.member,mark.start);
! 2802: return (GEN)x[10];
! 2803: }
! 2804:
! 2805: static GEN
! 2806: c6(GEN x)
! 2807: {
! 2808: if (!is_ell(x)) err(member,"c6",mark.member,mark.start);
! 2809: return (GEN)x[11];
! 2810: }
! 2811:
! 2812: static GEN
! 2813: j(GEN x)
! 2814: {
! 2815: if (!is_ell(x)) err(member,"j",mark.member,mark.start);
! 2816: return (GEN)x[13];
! 2817: }
! 2818:
! 2819: static GEN
! 2820: momega(GEN x)
! 2821: {
! 2822: GEN y;
! 2823:
! 2824: if (!is_bigell(x)) err(member,"omega",mark.member,mark.start);
! 2825: if (gcmp0((GEN)x[19])) err(talker,"curve not defined over R");
! 2826: y=cgetg(3,t_VEC); y[1]=x[15]; y[2]=x[16];
! 2827: return y;
! 2828: }
! 2829:
! 2830: static GEN
! 2831: meta(GEN x)
! 2832: {
! 2833: GEN y;
! 2834:
! 2835: if (!is_bigell(x)) err(member,"eta",mark.member,mark.start);
! 2836: if (gcmp0((GEN)x[19])) err(talker,"curve not defined over R");
! 2837: y=cgetg(3,t_VEC); y[1]=x[17]; y[2]=x[18];
! 2838: return y;
! 2839: }
! 2840:
! 2841: static GEN
! 2842: area(GEN x)
! 2843: {
! 2844: if (!is_bigell(x)) err(member,"area",mark.member,mark.start);
! 2845: if (gcmp0((GEN)x[19])) err(talker,"curve not defined over R");
! 2846: return (GEN)x[19];
! 2847: }
! 2848:
! 2849: static GEN
! 2850: tate(GEN x)
! 2851: {
! 2852: GEN z = cgetg(3,t_VEC);
! 2853: if (!is_bigell(x)) err(member,"tate",mark.member,mark.start);
! 2854: if (!gcmp0((GEN)x[19])) err(talker,"curve not defined over a p-adic field");
! 2855: z[1]=x[15];
! 2856: z[2]=x[16];
! 2857: z[3]=x[17]; return z;
! 2858: }
! 2859:
! 2860: static GEN
! 2861: w(GEN x)
! 2862: {
! 2863: if (!is_bigell(x)) err(member,"tate",mark.member,mark.start);
! 2864: if (!gcmp0((GEN)x[19])) err(talker,"curve not defined over a p-adic field");
! 2865: return (GEN)x[18];
! 2866: }
! 2867:
! 2868: /*
! 2869: * Only letters and digits in member names. AT MOST 8 of THEM
! 2870: * (or modify gp_rl.c::pari_completion)
! 2871: */
! 2872: entree gp_member_list[] = {
! 2873: {"a1",0,(void*)a1},
! 2874: {"a2",0,(void*)a2},
! 2875: {"a3",0,(void*)a3},
! 2876: {"a4",0,(void*)a4},
! 2877: {"a6",0,(void*)a6},
! 2878: {"area",0,(void*)area},
! 2879: {"b2",0,(void*)b2},
! 2880: {"b4",0,(void*)b4},
! 2881: {"b6",0,(void*)b6},
! 2882: {"b8",0,(void*)b8},
! 2883: {"bnf",0,(void*)bnf},
! 2884: {"c4",0,(void*)c4},
! 2885: {"c6",0,(void*)c6},
! 2886: {"clgp",0,(void*)clgp},
! 2887: {"codiff",0,(void*)codiff},
! 2888: {"cyc",0,(void*)cyc},
! 2889: {"diff",0,(void*)diff},
! 2890: {"disc",0,(void*)disc},
! 2891: {"e",0,(void*)e},
! 2892: {"eta",0,(void*)meta},
! 2893: {"f",0,(void*)f},
! 2894: {"fu",0,(void*)fu},
! 2895: {"futu",0,(void*)futu},
! 2896: {"gen",0,(void*)gen},
! 2897: {"j",0,(void*)j},
! 2898: {"mod",0,(void*)mod},
! 2899: {"nf",0,(void*)nf},
! 2900: {"no",0,(void*)no},
! 2901: {"omega",0,(void*)momega},
! 2902: {"p",0,(void*)p},
! 2903: {"pol",0,(void*)pol},
! 2904: {"reg",0,(void*)reg},
! 2905: {"roots",0,(void*)mroots},
! 2906: {"sign",0,(void*)sign},
! 2907: {"tate",0,(void*)tate},
! 2908: {"t2",0,(void*)t2},
! 2909: {"tu",0,(void*)tu},
! 2910: {"tufu",0,(void*)tufu},
! 2911: {"w",0,(void*)w},
! 2912: {"zk",0,(void*)zk},
! 2913: {"zkst",0,(void*)zkst},
! 2914: {NULL,0,NULL}
! 2915: };
! 2916:
! 2917: static entree*
! 2918: find_member()
! 2919: {
! 2920: char *old = analyseur;
! 2921: const long hash = hashvalue(NULL), len = analyseur - old;
! 2922: return findentry(old,len,members_hash[hash]);
! 2923: }
! 2924:
! 2925: static GEN
! 2926: read_member(GEN x)
! 2927: {
! 2928: entree *ep;
! 2929:
! 2930: mark.member = analyseur;
! 2931: ep = find_member();
! 2932: if (ep)
! 2933: {
! 2934: if (*analyseur == '=' && analyseur[1] != '=')
! 2935: {
! 2936: if (EpPREDEFINED(ep))
! 2937: err(talker2,"can't modify a pre-defined member: ",
! 2938: mark.member,mark.start);
! 2939: gunclone((GEN)ep->value); return NULL;
! 2940: }
! 2941: if (EpVALENCE(ep) == EpMEMBER)
! 2942: return call_fun((GEN)ep->value, NULL, &x, 0, 1);
! 2943: else
! 2944: return ((GEN (*)(ANYARG))ep->value)(x);
! 2945: }
! 2946: if (*analyseur != '=' || analyseur[1] == '=')
! 2947: err(talker2,"unknown member function",mark.member,mark.start);
! 2948: return NULL; /* to be redefined */
! 2949: }
! 2950:
! 2951: /********************************************************************/
! 2952: /** **/
! 2953: /** SIMPLE GP FUNCTIONS **/
! 2954: /** **/
! 2955: /********************************************************************/
! 2956:
! 2957: long
! 2958: loop_break()
! 2959: {
! 2960: switch(br_status)
! 2961: {
! 2962: case br_BREAK : if (! --br_count) br_status = br_NONE; /* fall through */
! 2963: case br_RETURN: return 1;
! 2964:
! 2965: case br_NEXT: br_status = br_NONE; /* fall through */
! 2966: }
! 2967: return 0;
! 2968: }
! 2969:
! 2970: long
! 2971: did_break() { return br_status; }
! 2972:
! 2973: GEN
! 2974: return0(GEN x)
! 2975: {
! 2976: br_res = x? gclone(x): NULL;
! 2977: br_status = br_RETURN; return NULL;
! 2978: }
! 2979:
! 2980: GEN
! 2981: next0(long n)
! 2982: {
! 2983: if (n < 1)
! 2984: err(talker2,"positive integer expected",mark.identifier,mark.start);
! 2985: if (n == 1) br_status = br_NEXT;
! 2986: else
! 2987: {
! 2988: br_count = n-1;
! 2989: br_status = br_BREAK;
! 2990: }
! 2991: return NULL;
! 2992: }
! 2993:
! 2994: GEN
! 2995: break0(long n)
! 2996: {
! 2997: if (n < 1)
! 2998: err(talker2,"positive integer expected",mark.identifier,mark.start);
! 2999: br_count = n;
! 3000: br_status = br_BREAK; return NULL;
! 3001: }
! 3002:
! 3003: void
! 3004: alias0(char *s, char *old)
! 3005: {
! 3006: entree *ep, *e;
! 3007: long hash;
! 3008: GEN x;
! 3009:
! 3010: ep = is_entry(old);
! 3011: if (!ep) err(talker2,"unknown function",mark.raw,mark.start);
! 3012: switch(EpVALENCE(ep))
! 3013: {
! 3014: case EpVAR: case EpGVAR:
! 3015: err(talker2,"only functions can be aliased",mark.raw,mark.start);
! 3016: }
! 3017:
! 3018: if ( (e = is_entry_intern(s, functions_hash, &hash)) )
! 3019: {
! 3020: if (EpVALENCE(e) != EpALIAS)
! 3021: err(talker2,"can't replace an existing symbol by an alias",
! 3022: mark.raw, mark.start);
! 3023: kill0(e);
! 3024: }
! 3025: ep = do_alias(ep); x = newbloc(2);
! 3026: x[0] = evaltyp(t_STR)|evallg(2); /* for getheap */
! 3027: x[1] = (long)ep;
! 3028: installep(x, s, strlen(s), EpALIAS, 0, functions_hash + hash);
! 3029: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[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