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