Line data Source code
1 : /* Copyright (C) 2000 The PARI group.
2 :
3 : This file is part of the PARI/GP package.
4 :
5 : PARI/GP is free software; you can redistribute it and/or modify it under the
6 : terms of the GNU General Public License as published by the Free Software
7 : Foundation; either version 2 of the License, or (at your option) any later
8 : version. It is distributed in the hope that it will be useful, but WITHOUT
9 : ANY WARRANTY WHATSOEVER.
10 :
11 : Check the License for details. You should have received a copy of it, along
12 : with the package; see the file 'COPYING'. If not, write to the Free Software
13 : Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. */
14 :
15 : #include "pari.h"
16 : #include "paripriv.h"
17 : #include "anal.h"
18 : #include "parse.h"
19 :
20 : /***************************************************************************
21 : ** **
22 : ** Mnemonic codes parser **
23 : ** **
24 : ***************************************************************************/
25 :
26 : /* TEMPLATE is assumed to be ";"-separated list of items. Each item
27 : * may have one of the following forms: id=value id==value id|value id&~value.
28 : * Each id consists of alphanum characters, dashes and underscores.
29 : * IDs are case-sensitive.
30 :
31 : * ARG consists of several IDs separated by punctuation (and optional
32 : * whitespace). Each modifies the return value in a "natural" way: an
33 : * ID from id=value should be the first in the sequence and sets RETVAL to
34 : * VALUE (and cannot be negated), ID from id|value bit-ORs RETVAL with
35 : * VALUE (and bit-ANDs RETVAL with ~VALUE if negated), ID from
36 : * id&~value behaves as if it were noid|value, ID from
37 : * id==value behaves the same as id=value, but should come alone.
38 :
39 : * For items of the form id|value and id&~value negated forms are
40 : * allowed: either when arg looks like no[-_]id, or when id looks like
41 : * this, and arg is not-negated. */
42 :
43 : static int
44 380 : IS_ID(char c) { return isalnum((int)c) || c == '_'; }
45 : long
46 28 : eval_mnemonic(GEN str, const char *tmplate)
47 : {
48 : const char *arg, *etmplate;
49 28 : ulong retval = 0;
50 :
51 28 : if (typ(str)==t_INT) return itos(str);
52 28 : if (typ(str)!=t_STR) pari_err_TYPE("eval_mnemonic",str);
53 :
54 28 : arg = GSTR(str);
55 28 : etmplate = strchr(tmplate, '\n');
56 28 : if (!etmplate) etmplate = tmplate + strlen(tmplate);
57 :
58 : while (1)
59 36 : {
60 : long numarg;
61 64 : const char *e, *id, *negated = NULL;
62 64 : int negate = 0; /* Arg has 'no' prefix removed */
63 : ulong l;
64 : char *buf;
65 : static char b[80];
66 :
67 64 : while (isspace((int)*arg)) arg++;
68 64 : if (!*arg) break;
69 364 : e = arg; while (IS_ID(*e)) e++;
70 : /* Now the ID is whatever is between arg and e. */
71 36 : l = e - arg;
72 36 : if (l >= sizeof(b)) pari_err(e_MISC,"id too long in a mnemonic");
73 36 : if (!l) pari_err(e_MISC,"mnemonic does not start with an id");
74 36 : strncpy(b, arg, l); b[l] = 0;
75 36 : arg = e; e = buf = b;
76 36 : while ('0' <= *e && *e <= '9') e++;
77 36 : if (*e == 0) pari_err(e_MISC,"numeric id in a mnemonic");
78 36 : FIND:
79 36 : id = tmplate;
80 36 : while ((id = strstr(id, buf)) && id < etmplate)
81 : {
82 36 : const char *s = id;
83 36 : id += l; if (s[l] != '|') continue; /* False positive */
84 36 : if (s == tmplate || !IS_ID(s[-1])) break; /* Found as is */
85 : /* If we found "no_ID", negate */
86 0 : if (!negate && s >= tmplate+3 && (s == tmplate+3 || !IS_ID(s[-4]))
87 0 : && s[-3] == 'n' && s[-2] == 'o' && s[-1] == '_')
88 0 : { negated = id; break; }
89 : }
90 36 : if (!id && !negated && !negate && l > 3
91 0 : && buf[0] == 'n' && buf[1] == 'o' && buf[2] == '_')
92 : { /* Try to find the flag without the prefix "no_". */
93 0 : buf += 3; l -= 3; negate = 1;
94 0 : if (buf[0]) goto FIND;
95 : }
96 : /* Negated and AS_IS forms, prefer AS_IS otherwise use negated form */
97 36 : if (!id)
98 : {
99 0 : if (!negated) pari_err(e_MISC,"Unrecognized id '%s' in mnemonic", b);
100 0 : id = negated; negate = 1;
101 : }
102 36 : if (*id++ != '|') pari_err(e_MISC,"Missing | in mnemonic template");
103 36 : e = id;
104 88 : while (*e >= '0' && *e <= '9') e++;
105 36 : while (isspace((int)*e)) e++;
106 36 : if (*e && *e != ';' && *e != ',')
107 0 : pari_err(e_MISC, "Non-numeric argument in mnemonic template");
108 36 : numarg = atol(id);
109 36 : if (negate) retval &= ~numarg; else retval |= numarg;
110 36 : while (isspace((int)*arg)) arg++;
111 36 : if (*arg && !ispunct((int)*arg++)) /* skip punctuation */
112 0 : pari_err(e_MISC,"Junk after id in mnemonic");
113 : }
114 28 : return retval;
115 : }
116 :
117 : /********************************************************************/
118 : /** **/
119 : /** HASH TABLE MANIPULATIONS **/
120 : /** **/
121 : /********************************************************************/
122 : static void
123 2514216 : insertep(entree *ep, entree **table, ulong hash)
124 : {
125 2514216 : ep->hash = hash;
126 2514216 : hash %= functions_tblsz;
127 2514216 : ep->next = table[hash];
128 2514216 : table[hash] = ep;
129 2514216 : }
130 :
131 : static entree *
132 33033 : initep(const char *name, long len)
133 : {
134 33033 : const long add = 4*sizeof(long);
135 33033 : entree *ep = (entree *) pari_calloc(sizeof(entree) + add + len+1);
136 33033 : entree *ep1 = initial_value(ep);
137 33033 : char *u = (char *) ep1 + add;
138 33033 : ep->name = u; memcpy(u, name,len); u[len]=0;
139 33033 : ep->valence = EpNEW;
140 33033 : ep->value = NULL;
141 33033 : ep->menu = 0;
142 33033 : ep->code = NULL;
143 33033 : ep->help = NULL;
144 33033 : ep->pvalue = NULL;
145 33033 : ep->arity = 0;
146 33033 : return ep;
147 : }
148 :
149 : /* Look for s of length len in T; if 'insert', insert if missing */
150 : static entree *
151 60460659 : findentry(const char *s, long len, entree **T, int insert)
152 : {
153 60460659 : ulong hash = hash_str_len(s, len);
154 : entree *ep;
155 643352389 : for (ep = T[hash % functions_tblsz]; ep; ep = ep->next)
156 643319425 : if (ep->hash == hash)
157 : {
158 60427806 : const char *t = ep->name;
159 60427806 : if (!strncmp(t, s, len) && !t[len]) return ep;
160 : }
161 : /* not found */
162 32964 : if (insert) { ep = initep(s,len); insertep(ep, T, hash); }
163 32972 : return ep;
164 : }
165 : entree *
166 1651 : pari_is_default(const char *s)
167 1651 : { return findentry(s, strlen(s), defaults_hash, 0); }
168 : entree *
169 5449271 : is_entry(const char *s)
170 5449271 : { return findentry(s, strlen(s), functions_hash, 0); }
171 : entree *
172 55009738 : fetch_entry_raw(const char *s, long len)
173 55009738 : { return findentry(s, len, functions_hash, 1); }
174 : entree *
175 463332 : fetch_entry(const char *s) { return fetch_entry_raw(s, strlen(s)); }
176 :
177 : /*******************************************************************/
178 : /* */
179 : /* SYNTACTICAL ANALYZER FOR GP */
180 : /* */
181 : /*******************************************************************/
182 : static GEN
183 8994844 : readseq_i(char *t)
184 : {
185 8994844 : if (gp_meta(t,0)) return gnil;
186 8994844 : return closure_evalres(pari_compile_str(t));
187 : }
188 : GEN
189 8994844 : readseq(char *t)
190 8994844 : { pari_sp av = avma; return gerepileupto(av, readseq_i(t)); }
191 :
192 : /* filtered readseq = remove blanks and comments */
193 : GEN
194 0 : gp_read_str(const char *s)
195 0 : { pari_sp av = avma; return gerepileupto(av, readseq_i(gp_filter(s))); }
196 :
197 : GEN
198 10789 : compile_str(const char *s) { return pari_compile_str(gp_filter(s)); }
199 :
200 : GEN
201 0 : gp_read_str_bitprec(const char *s, long bitprec)
202 : {
203 : GEN x;
204 0 : push_localbitprec(bitprec);
205 0 : x = gp_read_str(s);
206 0 : pop_localprec();
207 0 : return x;
208 : }
209 :
210 : GEN
211 0 : gp_read_str_prec(const char *s, long prec)
212 0 : { return gp_read_str_bitprec(s, prec2nbits(prec)); }
213 :
214 : /* valid return type */
215 : static int
216 2457888 : isreturn(char c)
217 2457888 : { return c == 'l' || c == 'v' || c == 'i' || c == 'm' || c == 'u'; }
218 :
219 : /* if is known that 2 commas follow s; base-10 signed integer followed
220 : * by comma? */
221 : static int
222 484712 : is_long(const char *s)
223 : {
224 484712 : while (isspace(*s)) s++;
225 484712 : if (*s == '+' || *s == '-') s++;
226 971222 : while (isdigit(*s)) s++;
227 484712 : return *s == ',';
228 : }
229 : /* if is known that 2 commas follow s; base-10 unsigned integer followed
230 : * by comma? */
231 : static int
232 1814 : is_ulong(const char *s)
233 : {
234 1814 : while (isspace(*s)) s++;
235 1814 : if (*s == '+') s++;
236 3620 : while (isdigit(*s)) s++;
237 1814 : return *s == ',';
238 : }
239 : static long
240 2457888 : check_proto(const char *code)
241 : {
242 2457888 : long arity = 0;
243 2457888 : const char *s = code;
244 2457888 : if (isreturn(*s)) s++;
245 8303564 : while (*s && *s != '\n') switch (*s++)
246 : {
247 4285170 : case '&':
248 : case 'C':
249 : case 'G':
250 : case 'I':
251 : case 'J':
252 : case 'U':
253 : case 'L':
254 : case 'M':
255 : case 'P':
256 : case 'W':
257 : case 'f':
258 : case 'n':
259 : case 'p':
260 : case 'b':
261 : case 'r':
262 4285170 : arity++; break;
263 138754 : case 'E':
264 : case 's':
265 138754 : if (*s == '*') s++;
266 138754 : arity++; break;
267 1237960 : case 'D':
268 1237960 : switch(*s)
269 : {
270 708186 : case 'G': case '&': case 'n': case 'I': case 'E':
271 708186 : case 'P': case 's': case 'r': s++; arity++; break;
272 18020 : case 'V': s++; break;
273 0 : case 0:
274 0 : pari_err(e_SYNTAX,"function has incomplete prototype", s,code);
275 0 : break;
276 511754 : default:
277 : {
278 : const char *p;
279 : long i;
280 2591218 : for(i = 0, p = s; *p && i < 2; p++) i += *p==','; /* skip 2 commas */
281 511754 : if (i < 2) pari_err(e_SYNTAX,"missing comma",s,code);
282 511754 : arity++;
283 511754 : switch(p[-2])
284 : {
285 484712 : case 'L':
286 484712 : if (!is_long(s)) pari_err(e_SYNTAX,"not a long",s,code);
287 484708 : break;
288 1814 : case 'U':
289 1814 : if (!is_ulong(s)) pari_err(e_SYNTAX,"not an ulong",s,code);
290 1806 : break;
291 25228 : case 'G': case 'r': case 's': case 'M':
292 25228 : break;
293 0 : default: pari_err(e_SYNTAX,"incorrect type",s-2,code);
294 : }
295 511742 : s = p;
296 : }
297 : }
298 1237948 : break;
299 183804 : case 'V':
300 : case '=':
301 183804 : case ',': break;
302 0 : case '\n': break; /* Before the mnemonic */
303 0 : default:
304 0 : if (isreturn(s[-1]))
305 0 : pari_err(e_SYNTAX, "this code has to come first", s-1, code);
306 0 : pari_err(e_SYNTAX, "unknown parser code", s-1, code);
307 : }
308 2457876 : if (arity > 20) pari_err_IMPL("functions with more than 20 parameters");
309 2457876 : return arity;
310 : }
311 : static void
312 8 : check_name(const char *name)
313 : {
314 8 : const char *s = name;
315 8 : if (isalpha((int)*s))
316 40 : while (is_keyword_char(*++s)) /* empty */;
317 8 : if (*s) pari_err(e_SYNTAX,"not a valid identifier", s, name);
318 8 : }
319 :
320 : entree *
321 20 : install(void *f, const char *name, const char *code)
322 : {
323 20 : long arity = check_proto(code);
324 : entree *ep;
325 :
326 8 : check_name(name);
327 8 : ep = fetch_entry(name);
328 8 : if (ep->valence != EpNEW)
329 : {
330 0 : if (ep->valence != EpINSTALL)
331 0 : pari_err(e_MISC,"[install] identifier '%s' already in use", name);
332 0 : pari_warn(warner, "[install] updating '%s' prototype; module not reloaded", name);
333 0 : if (ep->code) pari_free((void*)ep->code);
334 : }
335 : else
336 : {
337 8 : ep->value = f;
338 8 : ep->valence = EpINSTALL;
339 : }
340 8 : ep->code = pari_strdup(code);
341 8 : ep->arity = arity; return ep;
342 : }
343 :
344 : static void
345 18 : killep(entree *ep)
346 : {
347 18 : GEN p = (GEN)initial_value(ep);
348 18 : freeep(ep);
349 18 : *p = 0; /* otherwise pari_var_create won't regenerate it */
350 18 : ep->valence = EpNEW;
351 18 : ep->value = NULL;
352 18 : ep->pvalue = NULL;
353 18 : }
354 : /* Kill ep, i.e free all memory it references, and reset to initial value */
355 : void
356 18 : kill0(const char *e)
357 : {
358 18 : entree *ep = is_entry(e);
359 18 : if (!ep || EpSTATIC(ep)) pari_err(e_MISC,"can't kill that");
360 18 : killep(ep);
361 18 : }
362 :
363 : void
364 50 : addhelp(const char *e, char *s)
365 : {
366 50 : entree *ep = fetch_entry(e);
367 50 : void *f = (void *) ep->help;
368 50 : ep->help = pari_strdup(s);
369 50 : if (f && !EpSTATIC(ep)) pari_free(f);
370 50 : }
371 :
372 : /*******************************************************************/
373 : /* */
374 : /* PARSER */
375 : /* */
376 : /*******************************************************************/
377 :
378 : #ifdef LONG_IS_64BIT
379 : static const long MAX_DIGITS = 19;
380 : #else
381 : static const long MAX_DIGITS = 9;
382 : #endif
383 :
384 : static const long MAX_XDIGITS = BITS_IN_LONG>>2;
385 : static const long MAX_BDIGITS = BITS_IN_LONG;
386 :
387 : static int
388 265966107 : ishex(const char **s)
389 : {
390 265966107 : if (**s == '0' && ((*s)[1] == 'x' || (*s)[1] == 'X' ))
391 : {
392 130 : *s += 2;
393 130 : return 1;
394 : }
395 : else
396 265965977 : return 0;
397 : }
398 :
399 : static int
400 265966163 : isbin(const char **s)
401 : {
402 265966163 : if (**s == '0' && ((*s)[1] == 'b' || (*s)[1] == 'B' ))
403 : {
404 56 : *s += 2;
405 56 : return 1;
406 : }
407 : else
408 265966107 : return 0;
409 : }
410 :
411 : static ulong
412 37 : bin_number_len(const char *s, long n)
413 : {
414 37 : ulong m = 0;
415 : long i;
416 1073 : for (i = 0; i < n; i++,s++)
417 1036 : m = 2*m + (*s - '0');
418 37 : return m;
419 : }
420 :
421 : static int
422 1064 : pari_isbdigit(int c)
423 : {
424 1064 : return c=='0' || c=='1';
425 : }
426 :
427 : static ulong
428 108 : hex_number_len(const char *s, long n)
429 : {
430 108 : ulong m = 0;
431 : long i;
432 1249 : for(i = 0; i < n; i++, s++)
433 : {
434 : ulong c;
435 1141 : if( *s >= '0' && *s <= '9')
436 566 : c = *s - '0';
437 575 : else if( *s >= 'A' && *s <= 'F')
438 42 : c = *s - 'A' + 10;
439 : else
440 533 : c = *s - 'a' + 10;
441 1141 : m = 16*m + c;
442 : }
443 108 : return m;
444 : }
445 :
446 : static GEN
447 102 : strtobin_len(const char *s, long n, long B, ulong num(const char *s, long n))
448 : {
449 102 : long i, l = (n+B-1)/B;
450 : GEN N, Np;
451 102 : N = cgetipos(l+2);
452 102 : Np = int_LSW(N);
453 145 : for (i=1; i<l; i++, Np = int_nextW(Np))
454 43 : uel(Np, 0) = num(s+n-i*B, B);
455 102 : uel(Np, 0) = num(s, n-(i-1)*B);
456 102 : return int_normalize(N, 0);
457 : }
458 :
459 : static GEN
460 102 : binary_read(const char **ps, long B, int is(int), ulong num(const char *s, long n))
461 : {
462 102 : const char *s = *ps;
463 2279 : while (is((int)**ps)) (*ps)++;
464 102 : return strtobin_len(s, *ps-s, B, num);
465 : }
466 :
467 : static GEN
468 28 : bin_read(const char **ps)
469 : {
470 28 : return binary_read(ps, MAX_BDIGITS, pari_isbdigit, bin_number_len);
471 : }
472 :
473 : static GEN
474 74 : hex_read(const char **ps)
475 : {
476 74 : return binary_read(ps, MAX_XDIGITS, isxdigit, hex_number_len);
477 : }
478 :
479 : static ulong
480 5212884 : dec_number_len(const char *s, long B)
481 : {
482 5212884 : ulong m = 0;
483 : long n;
484 68393099 : for (n = 0; n < B; n++,s++)
485 63180215 : m = 10*m + (*s - '0');
486 5212884 : return m;
487 : }
488 :
489 : static GEN
490 1654532 : dec_strtoi_len(const char *s, long n)
491 : {
492 1654532 : const long B = MAX_DIGITS;
493 1654532 : long i, l = (n+B-1)/B;
494 1654532 : GEN V = cgetg(l+1, t_VECSMALL);
495 5212884 : for (i=1; i<l; i++)
496 3558352 : uel(V,i) = dec_number_len(s+n-i*B, B);
497 1654532 : uel(V, i) = dec_number_len(s, n-(i-1)*B);
498 1654532 : return fromdigitsu(V, powuu(10, B));
499 : }
500 :
501 : static GEN
502 1654532 : dec_read_more(const char **ps)
503 : {
504 1654532 : pari_sp av = avma;
505 1654532 : const char *s = *ps;
506 64834747 : while (isdigit((int)**ps)) (*ps)++;
507 1654532 : return gerepileuptoint(av, dec_strtoi_len(s, *ps-s));
508 : }
509 :
510 : static ulong
511 68817827 : number(int *n, const char **s)
512 : {
513 68817827 : ulong m = 0;
514 317488169 : for (*n = 0; *n < MAX_DIGITS && isdigit((int)**s); (*n)++,(*s)++)
515 248670342 : m = 10*m + (**s - '0');
516 68817827 : return m;
517 : }
518 :
519 : static GEN
520 68742234 : dec_read(const char **s)
521 : {
522 : int nb;
523 68742234 : ulong y = number(&nb, s);
524 68742234 : if (nb < MAX_DIGITS)
525 67087702 : return utoi(y);
526 1654532 : *s -= MAX_DIGITS;
527 1654532 : return dec_read_more(s);
528 : }
529 :
530 : static GEN
531 4158 : real_read_more(GEN y, const char **ps)
532 : {
533 4158 : pari_sp av = avma;
534 4158 : const char *s = *ps;
535 4158 : GEN z = dec_read(ps);
536 4158 : long e = *ps-s;
537 4158 : return gerepileuptoint(av, addmulii(z, powuu(10, e), y));
538 : }
539 :
540 : static long
541 75593 : exponent(const char **pts)
542 : {
543 75593 : const char *s = *pts;
544 : long n;
545 : int nb;
546 75593 : switch(*++s)
547 : {
548 75439 : case '-': s++; n = -(long)number(&nb, &s); break;
549 0 : case '+': s++; /* Fall through */
550 154 : default: n = (long)number(&nb, &s);
551 : }
552 75593 : *pts = s; return n;
553 : }
554 :
555 : static GEN
556 175 : real_0_digits(long n) {
557 175 : long b = (n > 0)? (long)(n/LOG10_2): (long)-((-n)/LOG10_2 + 1);
558 175 : return real_0_bit(b);
559 : }
560 :
561 : static GEN
562 83540 : real_read(pari_sp av, const char **s, GEN y, long prec)
563 : {
564 83540 : long l, n = 0;
565 83540 : switch(**s)
566 : {
567 0 : default: return y; /* integer */
568 9186 : case '.':
569 : {
570 9186 : const char *old = ++*s;
571 9186 : if (isalpha((int)**s) || **s=='.')
572 : {
573 1232 : if (**s == 'E' || **s == 'e') {
574 1232 : n = exponent(s);
575 1232 : if (!signe(y)) { set_avma(av); return real_0_digits(n); }
576 1204 : break;
577 : }
578 0 : --*s; return y; /* member */
579 : }
580 7954 : if (isdigit((int)**s)) y = real_read_more(y, s);
581 7954 : n = old - *s;
582 7954 : if (**s != 'E' && **s != 'e')
583 : {
584 7947 : if (!signe(y)) { set_avma(av); return real_0(prec); }
585 6820 : break;
586 : }
587 : }
588 : /* Fall through */
589 : case 'E': case 'e':
590 74361 : n += exponent(s);
591 74361 : if (!signe(y)) { set_avma(av); return real_0_digits(n); }
592 : }
593 82238 : l = nbits2prec(bit_accuracy(lgefint(y)));
594 82238 : if (l < prec) l = prec; else prec = l;
595 82238 : if (!n) return itor(y, prec);
596 78862 : incrprec(l);
597 78862 : y = itor(y, l);
598 78862 : if (n > 0)
599 77 : y = mulrr(y, rpowuu(10UL, (ulong)n, l));
600 : else
601 78785 : y = divrr(y, rpowuu(10UL, (ulong)-n, l));
602 78862 : return gerepileuptoleaf(av, rtor(y, prec));
603 : }
604 :
605 : static GEN
606 68654638 : int_read(const char **s)
607 : {
608 : GEN y;
609 68654638 : if (isbin(s))
610 28 : y = bin_read(s);
611 68654610 : else if (ishex(s))
612 74 : y = hex_read(s);
613 : else
614 68654536 : y = dec_read(s);
615 68654638 : return y;
616 : }
617 :
618 : GEN
619 68654638 : strtoi(const char *s) { return int_read(&s); }
620 :
621 : GEN
622 83540 : strtor(const char *s, long prec)
623 : {
624 83540 : pari_sp av = avma;
625 83540 : GEN y = dec_read(&s);
626 83540 : y = real_read(av, &s, y, prec);
627 83540 : if (typ(y) == t_REAL) return y;
628 0 : return gerepileuptoleaf(av, itor(y, prec));
629 : }
630 :
631 : static void
632 68565113 : skipdigits(char **lex) {
633 356896163 : while (isdigit((int)**lex)) ++*lex;
634 68565113 : }
635 :
636 : static int
637 68559565 : skipexponent(char **lex)
638 : {
639 68559565 : char *old=*lex;
640 68559565 : if ((**lex=='e' || **lex=='E'))
641 : {
642 1057 : ++*lex;
643 1057 : if ( **lex=='+' || **lex=='-' ) ++*lex;
644 1057 : if (!isdigit((int)**lex))
645 : {
646 469 : *lex=old;
647 469 : return KINTEGER;
648 : }
649 588 : skipdigits(lex);
650 588 : return KREAL;
651 : }
652 68558508 : return KINTEGER;
653 : }
654 :
655 : static int
656 68560790 : skipconstante(char **lex)
657 : {
658 68560790 : skipdigits(lex);
659 68560790 : if (**lex=='.')
660 : {
661 16867 : char *old = ++*lex;
662 16867 : if (**lex == '.') { --*lex; return KINTEGER; }
663 15642 : if (isalpha((int)**lex))
664 : {
665 11907 : skipexponent(lex);
666 11907 : if (*lex == old)
667 : {
668 11851 : --*lex; /* member */
669 11851 : return KINTEGER;
670 : }
671 56 : return KREAL;
672 : }
673 3735 : skipdigits(lex);
674 3735 : skipexponent(lex);
675 3735 : return KREAL;
676 : }
677 68543923 : return skipexponent(lex);
678 : }
679 :
680 : static void
681 763670 : skipstring(char **lex)
682 : {
683 6195954 : while (**lex)
684 : {
685 6196511 : while (**lex == '\\') *lex+=2;
686 6195954 : if (**lex == '"')
687 : {
688 763670 : if ((*lex)[1] != '"') break;
689 0 : *lex += 2; continue;
690 : }
691 5432284 : (*lex)++;
692 : }
693 763670 : }
694 :
695 : int
696 207699951 : pari_lex(union token_value *yylval, struct node_loc *yylloc, char **lex)
697 : {
698 : (void) yylval;
699 207699951 : yylloc->start=*lex;
700 207699951 : if (!**lex)
701 : {
702 9109884 : yylloc->end=*lex;
703 9109884 : return 0;
704 : }
705 198590067 : if (isalpha((int)**lex))
706 : {
707 2233588 : while (is_keyword_char(**lex)) ++*lex;
708 501747 : yylloc->end=*lex;
709 501747 : return KENTRY;
710 : }
711 198088320 : if (**lex=='"')
712 : {
713 763670 : ++*lex;
714 763670 : skipstring(lex);
715 763670 : if (!**lex)
716 0 : compile_err("run-away string",*lex-1);
717 763670 : ++*lex;
718 763670 : yylloc->end=*lex;
719 763670 : return KSTRING;
720 : }
721 197324650 : if (**lex == '.')
722 : {
723 : int token;
724 13125 : if ((*lex)[1]== '.')
725 : {
726 1253 : *lex+=2; yylloc->end = *lex; return KDOTDOT;
727 : }
728 11872 : token=skipconstante(lex);
729 11872 : if (token==KREAL)
730 : {
731 21 : yylloc->end = *lex;
732 21 : return token;
733 : }
734 11851 : ++*lex;
735 11851 : yylloc->end=*lex;
736 11851 : return '.';
737 : }
738 197311525 : if (isbin((const char**)lex))
739 : {
740 1064 : while (**lex=='0' || **lex=='1') ++*lex;
741 28 : yylloc->end = *lex;
742 28 : return KINTEGER;
743 : }
744 197311497 : if (ishex((const char**)lex))
745 : {
746 903 : while (isxdigit((int)**lex)) ++*lex;
747 56 : yylloc->end = *lex;
748 56 : return KINTEGER;
749 : }
750 197311441 : if (isdigit((int)**lex))
751 : {
752 68548918 : int token=skipconstante(lex);
753 68548918 : yylloc->end = *lex;
754 68548918 : return token;
755 : }
756 128762523 : if ((*lex)[1]=='=')
757 23849 : switch (**lex)
758 : {
759 9046 : case '=':
760 9046 : if ((*lex)[2]=='=')
761 343 : { *lex+=3; yylloc->end = *lex; return KID; }
762 : else
763 8703 : { *lex+=2; yylloc->end = *lex; return KEQ; }
764 104 : case '>':
765 104 : *lex+=2; yylloc->end = *lex; return KGE;
766 202 : case '<':
767 202 : *lex+=2; yylloc->end = *lex; return KLE;
768 188 : case '*':
769 188 : *lex+=2; yylloc->end = *lex; return KME;
770 35 : case '/':
771 35 : *lex+=2; yylloc->end = *lex; return KDE;
772 7 : case '%':
773 7 : if ((*lex)[2]=='=') break;
774 7 : *lex+=2; yylloc->end = *lex; return KMODE;
775 1967 : case '!':
776 1967 : if ((*lex)[2]=='=') break;
777 1967 : *lex+=2; yylloc->end = *lex; return KNE;
778 7 : case '\\':
779 7 : *lex+=2; yylloc->end = *lex; return KEUCE;
780 197 : case '+':
781 197 : *lex+=2; yylloc->end = *lex; return KPE;
782 63 : case '-':
783 63 : *lex+=2; yylloc->end = *lex; return KSE;
784 : }
785 128750707 : if (**lex==')' && (*lex)[1]=='-' && (*lex)[2]=='>')
786 : {
787 4079 : *lex+=3; yylloc->end = *lex; return KPARROW;
788 : }
789 128746628 : if (**lex=='-' && (*lex)[1]=='>')
790 : {
791 1186 : *lex+=2; yylloc->end = *lex; return KARROW;
792 : }
793 128745442 : if (**lex=='<' && (*lex)[1]=='>')
794 : {
795 0 : *lex+=2; yylloc->end = *lex; return KNE;
796 : }
797 128745442 : if (**lex=='\\' && (*lex)[1]=='/')
798 35 : switch((*lex)[2])
799 : {
800 7 : case '=':
801 7 : *lex+=3; yylloc->end = *lex; return KDRE;
802 28 : default:
803 28 : *lex+=2; yylloc->end = *lex; return KDR;
804 : }
805 128745407 : if ((*lex)[1]==**lex)
806 10354857 : switch (**lex)
807 : {
808 725 : case '&':
809 725 : *lex+=2; yylloc->end = *lex; return KAND;
810 392 : case '|':
811 392 : *lex+=2; yylloc->end = *lex; return KOR;
812 148 : case '+':
813 148 : *lex+=2; yylloc->end = *lex; return KPP;
814 28 : case '-':
815 28 : *lex+=2; yylloc->end = *lex; return KSS;
816 28 : case '>':
817 28 : if ((*lex)[2]=='=') { *lex+=3; yylloc->end = *lex; return KSRE;}
818 21 : *lex+=2; yylloc->end = *lex; return KSR;
819 154 : case '<':
820 154 : if ((*lex)[2]=='=')
821 7 : { *lex+=3; yylloc->end = *lex; return KSLE; }
822 147 : *lex+=2; yylloc->end = *lex; return KSL;
823 : }
824 128743932 : yylloc->end = *lex+1;
825 128743932 : return (unsigned char) *(*lex)++;
826 : }
827 :
828 : /********************************************************************/
829 : /* */
830 : /* Formal variables management */
831 : /* */
832 : /********************************************************************/
833 : static THREAD long max_priority, min_priority;
834 : static THREAD long max_avail; /* max variable not yet used */
835 : static THREAD long nvar; /* first GP free variable */
836 : static hashtable *h_polvar;
837 :
838 : void
839 354735 : varstate_save(struct pari_varstate *s)
840 : {
841 354735 : s->nvar = nvar;
842 354735 : s->max_avail = max_avail;
843 354735 : s->max_priority = max_priority;
844 354735 : s->min_priority = min_priority;
845 354735 : }
846 :
847 : static void
848 9091 : varentries_set(long v, entree *ep)
849 : {
850 9091 : hash_insert(h_polvar, (void*)ep->name, (void*)v);
851 9091 : varentries[v] = ep;
852 9091 : }
853 : static int
854 2947 : _given_value(void *E, hashentry *e) { return e->val == E; }
855 :
856 : static void
857 14187 : varentries_unset(long v)
858 : {
859 14187 : entree *ep = varentries[v];
860 14187 : if (ep)
861 : {
862 2947 : hashentry *e = hash_remove_select(h_polvar, (void*)ep->name, (void*)v,
863 : _given_value);
864 2947 : if (!e) pari_err_BUG("varentries_unset [unknown var]");
865 2947 : varentries[v] = NULL;
866 2947 : pari_free(e);
867 2947 : if (v <= nvar && ep == is_entry(ep->name))
868 2940 : { /* known to the GP interpreter; entree in functions_hash is permanent */
869 2940 : GEN p = (GEN)initial_value(ep);
870 2940 : if (ep->value == p) { ep->value = NULL; ep->valence = EpNEW; }
871 2940 : *p = 0;
872 : }
873 : else /* from name_var() or a direct pari_var_create() */
874 7 : pari_free(ep);
875 : }
876 14187 : }
877 : static void
878 111 : varentries_reset(long v, entree *ep)
879 : {
880 111 : varentries_unset(v);
881 111 : varentries_set(v, ep);
882 111 : }
883 :
884 : static void
885 238172 : var_restore(struct pari_varstate *s)
886 : {
887 238172 : nvar = s->nvar;
888 238172 : max_avail = s->max_avail;
889 238172 : max_priority = s->max_priority;
890 238172 : min_priority = s->min_priority;
891 238172 : }
892 :
893 : void
894 11108 : varstate_restore(struct pari_varstate *s)
895 : {
896 : long i;
897 25163 : for (i = nvar; i >= s->nvar; i--)
898 : {
899 14055 : varentries_unset(i);
900 14055 : varpriority[i] = -i;
901 : }
902 11129 : for (i = max_avail+1; i <= s->max_avail; i++)
903 : {
904 21 : varentries_unset(i);
905 21 : varpriority[i] = -i;
906 : }
907 11108 : var_restore(s);
908 11108 : }
909 :
910 : void
911 227090 : pari_set_varstate(long *vp, struct pari_varstate *vs)
912 : {
913 227090 : var_restore(vs);
914 227021 : varpriority = (long*)newblock(MAXVARN+2) + 1;
915 226527 : memcpy(varpriority-1,vp-1,(MAXVARN+2)*sizeof(long));
916 226527 : }
917 :
918 : /* must come before destruction of functions_hash */
919 : void
920 1792 : pari_var_close(void)
921 : {
922 1792 : GEN h = hash_values(h_polvar);
923 1792 : long i, l = lg(h);
924 7916 : for (i = 1; i < l; i++)
925 : {
926 6124 : long v = h[i];
927 6124 : entree *ep = varentries[v];
928 6124 : if (ep && ep != is_entry(ep->name)) pari_free(ep);
929 : }
930 1792 : free((void*)varentries);
931 1792 : free((void*)(varpriority-1));
932 1792 : hash_destroy(h_polvar);
933 1792 : }
934 :
935 : void
936 1802 : pari_var_init(void)
937 : {
938 : long i;
939 1802 : varentries = (entree**) pari_calloc((MAXVARN+1)*sizeof(entree*));
940 1802 : varpriority = (long*)pari_malloc((MAXVARN+2)*sizeof(long)) + 1;
941 1802 : varpriority[-1] = 1-LONG_MAX;
942 1802 : h_polvar = hash_create_str(100, 0);
943 1802 : nvar = 0; max_avail = MAXVARN;
944 1802 : max_priority = min_priority = 0;
945 1802 : (void)fetch_user_var("x");
946 1802 : (void)fetch_user_var("y");
947 : /* initialize so that people can use pol_x(i) directly */
948 105904374 : for (i = 2; i <= (long)MAXVARN; i++) varpriority[i] = -i;
949 : /* reserve varnum 1..9 for static temps with predictable priority wrt x */
950 1802 : nvar = 10;
951 1802 : min_priority = -MAXVARN;
952 1802 : }
953 8 : long pari_var_next(void) { return nvar; }
954 0 : long pari_var_next_temp(void) { return max_avail; }
955 : long
956 33578 : pari_var_create(entree *ep)
957 : {
958 33578 : GEN p = (GEN)initial_value(ep);
959 : long v;
960 33578 : if (*p) return varn(p);
961 8980 : if (nvar == max_avail) pari_err(e_MISC,"no more variables available");
962 8980 : v = nvar++;
963 : /* set p = pol_x(v) */
964 8980 : p[0] = evaltyp(t_POL) | _evallg(4);
965 8980 : p[1] = evalsigne(1) | evalvarn(v);
966 8980 : gel(p,2) = gen_0;
967 8980 : gel(p,3) = gen_1;
968 8980 : varentries_set(v, ep);
969 8980 : varpriority[v]= min_priority--;
970 8980 : return v;
971 : }
972 :
973 : long
974 357232 : delete_var(void)
975 : { /* user wants to delete one of his/her/its variables */
976 357232 : if (max_avail == MAXVARN) return 0; /* nothing to delete */
977 357029 : max_avail++;
978 357029 : if (varpriority[max_avail] == min_priority) min_priority++;
979 357029 : else if (varpriority[max_avail] == max_priority) max_priority--;
980 357029 : return max_avail+1;
981 : }
982 : long
983 96750 : fetch_var(void)
984 : {
985 96750 : if (nvar == max_avail) pari_err(e_MISC,"no more variables available");
986 96750 : varpriority[max_avail] = min_priority--;
987 96750 : return max_avail--;
988 : }
989 : long
990 264158 : fetch_var_higher(void)
991 : {
992 264158 : if (nvar == max_avail) pari_err(e_MISC,"no more variables available");
993 264158 : varpriority[max_avail] = ++max_priority;
994 264158 : return max_avail--;
995 : }
996 :
997 : static int
998 49 : _higher(void *E, hashentry *e)
999 49 : { long v = (long)e->val; return (varncmp(v, (long)E) < 0); }
1000 : static int
1001 42 : _lower(void *E, hashentry *e)
1002 42 : { long v = (long)e->val; return (varncmp(v, (long)E) > 0); }
1003 :
1004 : static GEN
1005 111 : var_register(long v, const char *s)
1006 : {
1007 111 : varentries_reset(v, initep(s, strlen(s)));
1008 111 : return pol_x(v);
1009 : }
1010 : GEN
1011 98 : varhigher(const char *s, long w)
1012 : {
1013 : long v;
1014 98 : if (w >= 0)
1015 : {
1016 49 : hashentry *e = hash_select(h_polvar, (void*)s, (void*)w, _higher);
1017 49 : if (e) return pol_x((long)e->val);
1018 : }
1019 : /* no luck: need to create */
1020 84 : if (nvar == max_avail) pari_err(e_MISC,"no more variables available");
1021 84 : v = nvar++;
1022 84 : varpriority[v]= ++max_priority;
1023 84 : return var_register(v, s);
1024 : }
1025 : GEN
1026 34 : varlower(const char *s, long w)
1027 : {
1028 : long v;
1029 34 : if (w >= 0)
1030 : {
1031 21 : hashentry *e = hash_select(h_polvar, (void*)s, (void*)w, _lower);
1032 21 : if (e) return pol_x((long)e->val);
1033 : }
1034 : /* no luck: need to create */
1035 27 : v = fetch_var();
1036 27 : return var_register(v, s);
1037 : }
1038 :
1039 : long
1040 463218 : fetch_user_var(const char *s)
1041 : {
1042 463218 : entree *ep = fetch_entry(s);
1043 : long v;
1044 463218 : switch (EpVALENCE(ep))
1045 : {
1046 459411 : case EpVAR: return varn((GEN)initial_value(ep));
1047 3807 : case EpNEW: break;
1048 0 : default: pari_err(e_MISC, "%s already exists with incompatible valence", s);
1049 : }
1050 3807 : v = pari_var_create(ep);
1051 3807 : ep->valence = EpVAR;
1052 3807 : ep->value = initial_value(ep);
1053 3807 : return v;
1054 : }
1055 :
1056 : GEN
1057 7 : fetch_var_value(long v, GEN t)
1058 : {
1059 7 : entree *ep = varentries[v];
1060 7 : if (!ep) return NULL;
1061 7 : if (t)
1062 : {
1063 7 : long vn = localvars_find(t,ep);
1064 7 : if (vn) return get_lex(vn);
1065 : }
1066 7 : return (GEN)ep->value;
1067 : }
1068 :
1069 : void
1070 0 : name_var(long n, const char *s)
1071 : {
1072 : entree *ep;
1073 : char *u;
1074 :
1075 0 : if (n < pari_var_next())
1076 0 : pari_err(e_MISC, "renaming a GP variable is forbidden");
1077 0 : if (n > (long)MAXVARN)
1078 0 : pari_err_OVERFLOW("variable number");
1079 :
1080 0 : ep = (entree*)pari_malloc(sizeof(entree) + strlen(s) + 1);
1081 0 : u = (char *)initial_value(ep);
1082 0 : ep->valence = EpVAR;
1083 0 : ep->name = u; strcpy(u,s);
1084 0 : ep->value = gen_0; /* in case geval is called */
1085 0 : varentries_reset(n, ep);
1086 0 : }
1087 :
1088 : static int
1089 5150 : cmp_by_var(void *E,GEN x, GEN y)
1090 5150 : { (void)E; return varncmp((long)x,(long)y); }
1091 : GEN
1092 1183 : vars_sort_inplace(GEN z)
1093 1183 : { gen_sort_inplace(z,NULL,cmp_by_var,NULL); return z; }
1094 : GEN
1095 161 : vars_to_RgXV(GEN h)
1096 : {
1097 161 : long i, l = lg(h);
1098 161 : GEN z = cgetg(l, t_VEC);
1099 2065 : for (i = 1; i < l; i++) gel(z,i) = pol_x(h[i]);
1100 161 : return z;
1101 : }
1102 : GEN
1103 1183 : gpolvar(GEN x)
1104 : {
1105 : long v;
1106 1183 : if (!x) {
1107 140 : GEN h = hash_values(h_polvar);
1108 140 : return vars_to_RgXV(vars_sort_inplace(h));
1109 : }
1110 1043 : if (typ(x)==t_PADIC) return gcopy( gel(x,2) );
1111 1036 : v = gvar(x);
1112 1036 : if (v==NO_VARIABLE) return gen_0;
1113 980 : return pol_x(v);
1114 : }
1115 :
1116 : static void
1117 2481294 : fill_hashtable_single(entree **table, entree *ep)
1118 : {
1119 2481294 : EpSETSTATIC(ep);
1120 2481294 : insertep(ep, table, hash_str(ep->name));
1121 2481294 : if (ep->code) ep->arity = check_proto(ep->code);
1122 2481294 : ep->pvalue = NULL;
1123 2481294 : }
1124 :
1125 : void
1126 5396 : pari_fill_hashtable(entree **table, entree *ep)
1127 : {
1128 2486690 : for ( ; ep->name; ep++) fill_hashtable_single(table, ep);
1129 5396 : }
1130 :
1131 : void
1132 0 : pari_add_function(entree *ep)
1133 : {
1134 0 : fill_hashtable_single(functions_hash, ep);
1135 0 : }
1136 :
1137 : /********************************************************************/
1138 : /** **/
1139 : /** SIMPLE GP FUNCTIONS **/
1140 : /** **/
1141 : /********************************************************************/
1142 :
1143 : GEN
1144 28 : arity0(GEN C)
1145 : {
1146 28 : if (typ(C)!=t_CLOSURE) pari_err_TYPE("arity", C);
1147 28 : return utoi(closure_arity(C));
1148 : }
1149 :
1150 : #define ALIAS(ep) (entree *) ((GEN)ep->value)[1]
1151 :
1152 : entree *
1153 54579749 : do_alias(entree *ep)
1154 : {
1155 54579805 : while (ep->valence == EpALIAS) ep = ALIAS(ep);
1156 54579749 : return ep;
1157 : }
1158 :
1159 : void
1160 28 : alias0(const char *s, const char *old)
1161 : {
1162 : entree *ep, *e;
1163 : GEN x;
1164 :
1165 28 : ep = fetch_entry(old);
1166 28 : e = fetch_entry(s);
1167 28 : if (EpVALENCE(e) != EpALIAS && EpVALENCE(e) != EpNEW)
1168 0 : pari_err(e_MISC,"can't replace an existing symbol by an alias");
1169 28 : freeep(e);
1170 28 : x = cgetg_block(2, t_VECSMALL); gel(x,1) = (GEN)ep;
1171 28 : e->value=x; e->valence=EpALIAS;
1172 28 : }
1173 :
1174 : GEN
1175 12962839 : ifpari(GEN g, GEN a/*closure*/, GEN b/*closure*/)
1176 : {
1177 12962839 : if (gequal0(g)) /* false */
1178 9992989 : return b? closure_evalgen(b): gnil;
1179 : else /* true */
1180 2969850 : return a? closure_evalgen(a): gnil;
1181 : }
1182 :
1183 : void
1184 41027617 : ifpari_void(GEN g, GEN a/*closure*/, GEN b/*closure*/)
1185 : {
1186 41027617 : if (gequal0(g)) /* false */
1187 40237871 : { if (b) closure_evalvoid(b); }
1188 : else /* true */
1189 789746 : { if (a) closure_evalvoid(a); }
1190 41027596 : }
1191 :
1192 : GEN
1193 31325 : ifpari_multi(GEN g, GEN a/*closure*/)
1194 : {
1195 31325 : long i, nb = lg(a)-1;
1196 31325 : if (!gequal0(g)) /* false */
1197 6713 : return closure_evalgen(gel(a,1));
1198 42098 : for(i=2;i<nb;i+=2)
1199 : {
1200 24724 : GEN g = closure_evalgen(gel(a,i));
1201 24724 : if (!g) return g;
1202 24717 : if (!gequal0(g))
1203 7231 : return closure_evalgen(gel(a,i+1));
1204 : }
1205 17374 : return i<=nb? closure_evalgen(gel(a,i)): gnil;
1206 : }
1207 :
1208 : GEN
1209 53997514 : andpari(GEN a, GEN b/*closure*/)
1210 : {
1211 : GEN g;
1212 53997514 : if (gequal0(a))
1213 45831331 : return gen_0;
1214 8166183 : g=closure_evalgen(b);
1215 8166183 : if (!g) return g;
1216 8166183 : return gequal0(g)?gen_0:gen_1;
1217 : }
1218 :
1219 : GEN
1220 16517529 : orpari(GEN a, GEN b/*closure*/)
1221 : {
1222 : GEN g;
1223 16517529 : if (!gequal0(a))
1224 338828 : return gen_1;
1225 16178701 : g=closure_evalgen(b);
1226 16178701 : if (!g) return g;
1227 16178701 : return gequal0(g)?gen_0:gen_1;
1228 : }
1229 :
1230 178215 : GEN gmule(GEN *x, GEN y) { *x = gmul(*x,y); return *x; }
1231 56 : GEN gdive(GEN *x, GEN y) { *x = gdiv(*x,y); return *x; }
1232 7 : GEN gdivente(GEN *x, GEN y) { *x = gdivent(*x,y); return *x; }
1233 7 : GEN gdivrounde(GEN *x, GEN y) { *x = gdivround(*x,y); return *x; }
1234 7 : GEN gmode(GEN *x, GEN y) { *x = gmod(*x,y); return *x; }
1235 7 : GEN gshiftle(GEN *x, long n) { *x = gshift(*x,n); return *x; }
1236 7 : GEN gshiftre(GEN *x, long n) { *x = gshift(*x,-n); return *x; }
1237 532827 : GEN gadde(GEN *x, GEN y) { *x = gadd(*x,y); return *x; }
1238 25676788 : GEN gadd1e(GEN *x) { *x = typ(*x)==t_INT?addiu(*x,1):gaddgs(*x,1); return *x; }
1239 15455370 : GEN gsube(GEN *x, GEN y) { *x = gsub(*x,y); return *x; }
1240 28014 : GEN gsub1e(GEN *x) { *x = typ(*x)==t_INT?subiu(*x,1):gsubgs(*x,1); return *x; }
1241 :
1242 1392 : GEN gshift_right(GEN x, long n) { return gshift(x,-n); }
|
