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