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