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