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((unsigned char)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((unsigned char)*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((unsigned char)*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((unsigned char)*arg)) arg++;
111 36 : if (*arg && !ispunct((unsigned char)*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 2563278 : insertep(entree *ep, entree **table, ulong hash)
124 : {
125 2563278 : ep->hash = hash;
126 2563278 : hash %= functions_tblsz;
127 2563278 : ep->next = table[hash];
128 2563278 : table[hash] = ep;
129 2563278 : }
130 :
131 : static entree *
132 33761 : initep(const char *name, long len)
133 : {
134 33761 : const long add = 4*sizeof(long);
135 33761 : entree *ep = (entree *) pari_calloc(sizeof(entree) + add + len+1);
136 33761 : entree *ep1 = initial_value(ep);
137 33761 : char *u = (char *) ep1 + add;
138 33761 : ep->name = u; memcpy(u, name,len); u[len]=0;
139 33761 : ep->valence = EpNEW;
140 33761 : ep->value = NULL;
141 33761 : ep->menu = 0;
142 33761 : ep->code = NULL;
143 33761 : ep->help = NULL;
144 33761 : ep->pvalue = NULL;
145 33761 : ep->arity = 0;
146 33761 : return ep;
147 : }
148 :
149 : /* Look for s of length len in T; if 'insert', insert if missing */
150 : static entree *
151 17566935 : findentry(const char *s, long len, entree **T, int insert)
152 : {
153 17566935 : ulong hash = hash_str_len(s, len);
154 : entree *ep;
155 165832405 : for (ep = T[hash % functions_tblsz]; ep; ep = ep->next)
156 165798718 : if (ep->hash == hash)
157 : {
158 17533354 : const char *t = ep->name;
159 17533354 : if (!strncmp(t, s, len) && !t[len]) return ep;
160 : }
161 : /* not found */
162 33687 : if (insert) { ep = initep(s,len); insertep(ep, T, hash); }
163 33700 : return ep;
164 : }
165 : entree *
166 867 : pari_is_default(const char *s)
167 867 : { return findentry(s, strlen(s), defaults_hash, 0); }
168 : entree *
169 7877751 : is_entry(const char *s)
170 7877751 : { return findentry(s, strlen(s), functions_hash, 0); }
171 : entree *
172 9688307 : fetch_entry_raw(const char *s, long len)
173 9688307 : { return findentry(s, len, functions_hash, 1); }
174 : entree *
175 448779 : 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 803766 : readseq_i(char *t)
184 : {
185 803766 : if (gp_meta(t,0)) return gnil;
186 803766 : return closure_evalres(pari_compile_str(t));
187 : }
188 : GEN
189 803766 : readseq(char *t)
190 803766 : { 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 10992 : 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 2506040 : isreturn(char c)
217 2506040 : { 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 497558 : is_long(const char *s)
223 : {
224 497558 : while (isspace((unsigned char)*s)) s++;
225 497558 : if (*s == '+' || *s == '-') s++;
226 996928 : while (isdigit((unsigned char)*s)) s++;
227 497558 : return *s == ',';
228 : }
229 : /* if is known that 2 commas follow s; base-10 unsigned integer followed
230 : * by comma? */
231 : static int
232 1828 : is_ulong(const char *s)
233 : {
234 1828 : while (isspace((unsigned char)*s)) s++;
235 1828 : if (*s == '+') s++;
236 3648 : while (isdigit((unsigned char)*s)) s++;
237 1828 : return *s == ',';
238 : }
239 : static long
240 2506040 : check_proto(const char *code)
241 : {
242 2506040 : long arity = 0;
243 2506040 : const char *s = code;
244 2506040 : if (isreturn(*s)) s++;
245 8467956 : while (*s && *s != '\n') switch (*s++)
246 : {
247 4332990 : 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 4332990 : arity++; break;
263 139832 : case 'E':
264 : case 's':
265 139832 : if (*s == '*') s++;
266 139832 : arity++; break;
267 1300242 : case 'D':
268 1300242 : switch(*s)
269 : {
270 755456 : case 'G': case '&': case 'n': case 'I': case 'E':
271 755456 : case 'P': case 's': case 'r': s++; arity++; break;
272 19976 : case 'V': s++; break;
273 0 : case 0:
274 0 : pari_err(e_SYNTAX,"function has incomplete prototype", s,code);
275 0 : break;
276 524810 : default:
277 : {
278 : const char *p;
279 : long i;
280 2656750 : for(i = 0, p = s; *p && i < 2; p++) i += *p==','; /* skip 2 commas */
281 524810 : if (i < 2) pari_err(e_SYNTAX,"missing comma",s,code);
282 524810 : arity++;
283 524810 : switch(p[-2])
284 : {
285 497558 : case 'L':
286 497558 : if (!is_long(s)) pari_err(e_SYNTAX,"not a long",s,code);
287 497554 : break;
288 1828 : case 'U':
289 1828 : if (!is_ulong(s)) pari_err(e_SYNTAX,"not an ulong",s,code);
290 1820 : break;
291 25424 : case 'G': case 'r': case 's': case 'M':
292 25424 : break;
293 0 : default: pari_err(e_SYNTAX,"incorrect type",s-2,code);
294 : }
295 524798 : s = p;
296 : }
297 : }
298 1300230 : break;
299 188864 : case 'V':
300 : case '=':
301 188864 : 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 2506028 : if (arity > 20) pari_err_IMPL("functions with more than 20 parameters");
309 2506028 : return arity;
310 : }
311 : static void
312 8 : check_name(const char *name)
313 : {
314 8 : const char *s = name;
315 8 : if (isalpha((unsigned char)*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 46731415 : ishex(const char **s)
389 : {
390 46731415 : if (**s == '0' && ((*s)[1] == 'x' || (*s)[1] == 'X' ))
391 : {
392 130 : *s += 2;
393 130 : return 1;
394 : }
395 : else
396 46731285 : return 0;
397 : }
398 :
399 : static int
400 46731471 : isbin(const char **s)
401 : {
402 46731471 : if (**s == '0' && ((*s)[1] == 'b' || (*s)[1] == 'B' ))
403 : {
404 56 : *s += 2;
405 56 : return 1;
406 : }
407 : else
408 46731415 : 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((unsigned char)**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 3788170 : dec_number_len(const char *s, long B)
481 : {
482 3788170 : ulong m = 0;
483 : long n;
484 58676323 : for (n = 0; n < B; n++,s++)
485 54888153 : m = 10*m + (*s - '0');
486 3788170 : return m;
487 : }
488 :
489 : static GEN
490 871866 : dec_strtoi_len(const char *s, long n)
491 : {
492 871866 : const long B = MAX_DIGITS;
493 871866 : long i, l = (n+B-1)/B;
494 871866 : GEN V = cgetg(l+1, t_VECSMALL);
495 3788170 : for (i=1; i<l; i++)
496 2916304 : uel(V,i) = dec_number_len(s+n-i*B, B);
497 871866 : uel(V, i) = dec_number_len(s, n-(i-1)*B);
498 871866 : return fromdigitsu(V, powuu(10, B));
499 : }
500 :
501 : static GEN
502 871866 : dec_read_more(const char **ps)
503 : {
504 871866 : pari_sp av = avma;
505 871866 : const char *s = *ps;
506 55760019 : while (isdigit((unsigned char)**ps)) (*ps)++;
507 871866 : return gerepileuptoint(av, dec_strtoi_len(s, *ps-s));
508 : }
509 :
510 : static ulong
511 11414720 : number(int *n, const char **s)
512 : {
513 11414720 : ulong m = 0;
514 52327956 : for (*n = 0; *n < MAX_DIGITS && isdigit((unsigned char)**s); (*n)++,(*s)++)
515 40913236 : m = 10*m + (**s - '0');
516 11414720 : return m;
517 : }
518 :
519 : static GEN
520 11339141 : dec_read(const char **s)
521 : {
522 : int nb;
523 11339141 : ulong y = number(&nb, s);
524 11339141 : if (nb < MAX_DIGITS)
525 10467275 : return utoi(y);
526 871866 : *s -= MAX_DIGITS;
527 871866 : return dec_read_more(s);
528 : }
529 :
530 : static GEN
531 4507 : real_read_more(GEN y, const char **ps)
532 : {
533 4507 : pari_sp av = avma;
534 4507 : const char *s = *ps;
535 4507 : GEN z = dec_read(ps);
536 4507 : long e = *ps-s;
537 4507 : return gerepileuptoint(av, addmulii(z, powuu(10, e), y));
538 : }
539 :
540 : static long
541 75579 : exponent(const char **pts)
542 : {
543 75579 : const char *s = *pts;
544 : long n;
545 : int nb;
546 75579 : switch(*++s)
547 : {
548 75425 : case '-': s++; n = -(long)number(&nb, &s); break;
549 0 : case '+': s++; /* Fall through */
550 154 : default: n = (long)number(&nb, &s);
551 : }
552 75579 : *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 85408 : real_read(pari_sp av, const char **s, GEN y, long prec)
563 : {
564 85408 : long l, n = 0;
565 85408 : switch(**s)
566 : {
567 0 : default: return y; /* integer */
568 11089 : case '.':
569 : {
570 11089 : const char *old = ++*s;
571 11089 : if (isalpha((unsigned char)**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 9857 : if (isdigit((unsigned char)**s)) y = real_read_more(y, s);
581 9857 : n = old - *s;
582 9857 : if (**s != 'E' && **s != 'e')
583 : {
584 9829 : if (!signe(y)) { set_avma(av); return real_0(prec); }
585 8583 : break;
586 : }
587 : }
588 : /* Fall through */
589 : case 'E': case 'e':
590 74347 : n += exponent(s);
591 74347 : if (!signe(y)) { set_avma(av); return real_0_digits(n); }
592 : }
593 83987 : l = nbits2prec(bit_accuracy(lgefint(y)));
594 83987 : if (l < prec) l = prec; else prec = l;
595 83987 : if (!n) return itor(y, prec);
596 79176 : incrprec(l);
597 79176 : y = itor(y, l);
598 79176 : if (n > 0)
599 77 : y = mulrr(y, rpowuu(10UL, (ulong)n, l));
600 : else
601 79099 : y = divrr(y, rpowuu(10UL, (ulong)-n, l));
602 79176 : return gerepileuptoleaf(av, rtor(y, prec));
603 : }
604 :
605 : static GEN
606 11249328 : int_read(const char **s)
607 : {
608 : GEN y;
609 11249328 : if (isbin(s))
610 28 : y = bin_read(s);
611 11249300 : else if (ishex(s))
612 74 : y = hex_read(s);
613 : else
614 11249226 : y = dec_read(s);
615 11249328 : return y;
616 : }
617 :
618 : GEN
619 11249328 : strtoi(const char *s) { return int_read(&s); }
620 :
621 : GEN
622 85408 : strtor(const char *s, long prec)
623 : {
624 85408 : pari_sp av = avma;
625 85408 : GEN y = dec_read(&s);
626 85408 : y = real_read(av, &s, y, prec);
627 85408 : if (typ(y) == t_REAL) return y;
628 0 : return gerepileuptoleaf(av, itor(y, prec));
629 : }
630 :
631 : static void
632 11257539 : skipdigits(char **lex) {
633 91532142 : while (isdigit((unsigned char)**lex)) ++*lex;
634 11257539 : }
635 :
636 : static int
637 11250977 : skipexponent(char **lex)
638 : {
639 11250977 : char *old=*lex;
640 11250977 : if ((**lex=='e' || **lex=='E'))
641 : {
642 1071 : ++*lex;
643 1071 : if ( **lex=='+' || **lex=='-' ) ++*lex;
644 1071 : if (!isdigit((unsigned char)**lex))
645 : {
646 469 : *lex=old;
647 469 : return KINTEGER;
648 : }
649 602 : skipdigits(lex);
650 602 : return KREAL;
651 : }
652 11249906 : return KINTEGER;
653 : }
654 :
655 : static int
656 11252397 : skipconstante(char **lex)
657 : {
658 11252397 : skipdigits(lex);
659 11252397 : if (**lex=='.')
660 : {
661 18399 : char *old = ++*lex;
662 18399 : if (**lex == '.') { --*lex; return KINTEGER; }
663 16979 : if (isalpha((unsigned char)**lex))
664 : {
665 12439 : skipexponent(lex);
666 12439 : if (*lex == old)
667 : {
668 12383 : --*lex; /* member */
669 12383 : return KINTEGER;
670 : }
671 56 : return KREAL;
672 : }
673 4540 : skipdigits(lex);
674 4540 : skipexponent(lex);
675 4540 : return KREAL;
676 : }
677 11233998 : return skipexponent(lex);
678 : }
679 :
680 : static void
681 764419 : skipstring(char **lex)
682 : {
683 6202156 : while (**lex)
684 : {
685 6202804 : while (**lex == '\\') *lex+=2;
686 6202156 : if (**lex == '"')
687 : {
688 764419 : if ((*lex)[1] != '"') break;
689 0 : *lex += 2; continue;
690 : }
691 5437737 : (*lex)++;
692 : }
693 764419 : }
694 :
695 : int
696 37723423 : pari_lex(union token_value *yylval, struct node_loc *yylloc, char **lex)
697 : {
698 : (void) yylval;
699 37723423 : yylloc->start=*lex;
700 37723423 : if (!**lex)
701 : {
702 926551 : yylloc->end=*lex;
703 926551 : return 0;
704 : }
705 36796872 : if (isalpha((unsigned char)**lex))
706 : {
707 2391681 : while (is_keyword_char(**lex)) ++*lex;
708 536458 : yylloc->end=*lex;
709 536458 : return KENTRY;
710 : }
711 36260414 : if (**lex=='"')
712 : {
713 764419 : ++*lex;
714 764419 : skipstring(lex);
715 764419 : if (!**lex)
716 0 : compile_err("run-away string",*lex-1);
717 764419 : ++*lex;
718 764419 : yylloc->end=*lex;
719 764419 : return KSTRING;
720 : }
721 35495995 : if (**lex == '.')
722 : {
723 : int token;
724 13852 : if ((*lex)[1]== '.')
725 : {
726 1448 : *lex+=2; yylloc->end = *lex; return KDOTDOT;
727 : }
728 12404 : token=skipconstante(lex);
729 12404 : if (token==KREAL)
730 : {
731 21 : yylloc->end = *lex;
732 21 : return token;
733 : }
734 12383 : ++*lex;
735 12383 : yylloc->end=*lex;
736 12383 : return '.';
737 : }
738 35482143 : 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 35482115 : if (ishex((const char**)lex))
745 : {
746 903 : while (isxdigit((unsigned int)**lex)) ++*lex;
747 56 : yylloc->end = *lex;
748 56 : return KINTEGER;
749 : }
750 35482059 : if (isdigit((unsigned char)**lex))
751 : {
752 11239993 : int token=skipconstante(lex);
753 11239993 : yylloc->end = *lex;
754 11239993 : return token;
755 : }
756 24242066 : if ((*lex)[1]=='=')
757 27434 : switch (**lex)
758 : {
759 10676 : case '=':
760 10676 : if ((*lex)[2]=='=')
761 343 : { *lex+=3; yylloc->end = *lex; return KID; }
762 : else
763 10333 : { *lex+=2; yylloc->end = *lex; return KEQ; }
764 111 : case '>':
765 111 : *lex+=2; yylloc->end = *lex; return KGE;
766 237 : case '<':
767 237 : *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 2093 : case '!':
776 2093 : if ((*lex)[2]=='=') break;
777 2093 : *lex+=2; yylloc->end = *lex; return KNE;
778 7 : case '\\':
779 7 : *lex+=2; yylloc->end = *lex; return KEUCE;
780 222 : case '+':
781 222 : *lex+=2; yylloc->end = *lex; return KPE;
782 63 : case '-':
783 63 : *lex+=2; yylloc->end = *lex; return KSE;
784 : }
785 24228427 : if (**lex==')' && (*lex)[1]=='-' && (*lex)[2]=='>')
786 : {
787 4079 : *lex+=3; yylloc->end = *lex; return KPARROW;
788 : }
789 24224348 : if (**lex=='-' && (*lex)[1]=='>')
790 : {
791 1276 : *lex+=2; yylloc->end = *lex; return KARROW;
792 : }
793 24223072 : if (**lex=='<' && (*lex)[1]=='>')
794 : {
795 0 : *lex+=2; yylloc->end = *lex; return KNE;
796 : }
797 24223072 : 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 24223037 : if ((*lex)[1]==**lex)
806 2167131 : switch (**lex)
807 : {
808 760 : case '&':
809 760 : *lex+=2; yylloc->end = *lex; return KAND;
810 399 : case '|':
811 399 : *lex+=2; yylloc->end = *lex; return KOR;
812 183 : case '+':
813 183 : *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 24221485 : yylloc->end = *lex+1;
825 24221485 : 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 480236 : varstate_save(struct pari_varstate *s)
840 : {
841 480236 : s->nvar = nvar;
842 480236 : s->max_avail = max_avail;
843 480236 : s->max_priority = max_priority;
844 480236 : s->min_priority = min_priority;
845 480236 : }
846 :
847 : static void
848 8902 : varentries_set(long v, entree *ep)
849 : {
850 8902 : hash_insert(h_polvar, (void*)ep->name, (void*)v);
851 8902 : varentries[v] = ep;
852 8902 : }
853 : static int
854 2954 : _given_value(void *E, hashentry *e) { return e->val == E; }
855 :
856 : static void
857 15244 : varentries_unset(long v)
858 : {
859 15244 : entree *ep = varentries[v];
860 15244 : if (ep)
861 : {
862 2954 : hashentry *e = hash_remove_select(h_polvar, (void*)ep->name, (void*)v,
863 : _given_value);
864 2954 : if (!e) pari_err_BUG("varentries_unset [unknown var]");
865 2954 : varentries[v] = NULL;
866 2954 : pari_free(e);
867 2954 : if (v <= nvar && ep == is_entry(ep->name))
868 2947 : { /* known to the GP interpreter; entree in functions_hash is permanent */
869 2947 : GEN p = (GEN)initial_value(ep);
870 2947 : if (ep->value == p) { ep->value = NULL; ep->valence = EpNEW; }
871 2947 : *p = 0;
872 : }
873 : else /* from name_var() or a direct pari_var_create() */
874 7 : pari_free(ep);
875 : }
876 15244 : }
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 357572 : var_restore(struct pari_varstate *s)
886 : {
887 357572 : nvar = s->nvar;
888 357572 : max_avail = s->max_avail;
889 357572 : max_priority = s->max_priority;
890 357572 : min_priority = s->min_priority;
891 357572 : }
892 :
893 : void
894 12158 : varstate_restore(struct pari_varstate *s)
895 : {
896 : long i;
897 27270 : for (i = nvar; i >= s->nvar; i--)
898 : {
899 15112 : varentries_unset(i);
900 15112 : varpriority[i] = -i;
901 : }
902 12179 : for (i = max_avail+1; i <= s->max_avail; i++)
903 : {
904 21 : varentries_unset(i);
905 21 : varpriority[i] = -i;
906 : }
907 12158 : var_restore(s);
908 12158 : }
909 :
910 : void
911 345431 : pari_set_varstate(long *vp, struct pari_varstate *vs)
912 : {
913 345431 : var_restore(vs);
914 345381 : varpriority = (long*)newblock(MAXVARN+2) + 1;
915 345290 : memcpy(varpriority-1,vp-1,(MAXVARN+2)*sizeof(long));
916 345290 : }
917 :
918 : /* must come before destruction of functions_hash */
919 : void
920 1806 : pari_var_close(void)
921 : {
922 1806 : GEN h = hash_values(h_polvar);
923 1806 : long i, l = lg(h);
924 7734 : for (i = 1; i < l; i++)
925 : {
926 5928 : long v = h[i];
927 5928 : entree *ep = varentries[v];
928 5928 : if (ep && ep != is_entry(ep->name)) pari_free(ep);
929 : }
930 1806 : free((void*)varentries);
931 1806 : free((void*)(varpriority-1));
932 1806 : hash_destroy(h_polvar);
933 1806 : }
934 :
935 : void
936 1816 : pari_var_init(void)
937 : {
938 : long i;
939 1816 : varentries = (entree**) pari_calloc((MAXVARN+1)*sizeof(entree*));
940 1816 : varpriority = (long*)pari_malloc((MAXVARN+2)*sizeof(long)) + 1;
941 1816 : varpriority[-1] = 1-LONG_MAX;
942 1816 : h_polvar = hash_create_str(100, 0);
943 1816 : nvar = 0; max_avail = MAXVARN;
944 1816 : max_priority = min_priority = 0;
945 1816 : (void)fetch_user_var("x");
946 1816 : (void)fetch_user_var("y");
947 : /* initialize so that people can use pol_x(i) directly */
948 106723560 : for (i = 2; i <= (long)MAXVARN; i++) varpriority[i] = -i;
949 : /* reserve varnum 1..9 for static temps with predictable priority wrt x */
950 1816 : nvar = 10;
951 1816 : min_priority = -MAXVARN;
952 1816 : }
953 8 : long pari_var_next(void) { return nvar; }
954 0 : long pari_var_next_temp(void) { return max_avail; }
955 : long
956 478646 : pari_var_create(entree *ep)
957 : {
958 478646 : GEN p = (GEN)initial_value(ep);
959 : long v;
960 478646 : if (*p) return varn(p);
961 8791 : if (nvar == max_avail) pari_err(e_MISC,"no more variables available");
962 8791 : v = nvar++;
963 : /* set p = pol_x(v) */
964 8791 : p[0] = evaltyp(t_POL) | _evallg(4);
965 8791 : p[1] = evalsigne(1) | evalvarn(v);
966 8791 : gel(p,2) = gen_0;
967 8791 : gel(p,3) = gen_1;
968 8791 : varentries_set(v, ep);
969 8791 : varpriority[v]= min_priority--;
970 8791 : return v;
971 : }
972 :
973 : long
974 383351 : delete_var(void)
975 : { /* user wants to delete one of his/her/its variables */
976 383351 : if (max_avail == MAXVARN) return 0; /* nothing to delete */
977 382735 : max_avail++;
978 382735 : if (varpriority[max_avail] == min_priority) min_priority++;
979 382735 : else if (varpriority[max_avail] == max_priority) max_priority--;
980 382735 : return max_avail+1;
981 : }
982 : long
983 100681 : fetch_var(void)
984 : {
985 100681 : if (nvar == max_avail) pari_err(e_MISC,"no more variables available");
986 100681 : varpriority[max_avail] = min_priority--;
987 100681 : return max_avail--;
988 : }
989 : long
990 285981 : fetch_var_higher(void)
991 : {
992 285981 : if (nvar == max_avail) pari_err(e_MISC,"no more variables available");
993 285982 : varpriority[max_avail] = ++max_priority;
994 285982 : 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 448665 : fetch_user_var(const char *s)
1041 : {
1042 448665 : entree *ep = fetch_entry(s);
1043 : long v;
1044 448665 : switch (EpVALENCE(ep))
1045 : {
1046 444830 : case EpVAR: return pari_var_create(ep);
1047 3835 : case EpNEW: break;
1048 0 : default: pari_err(e_MISC, "%s already exists with incompatible valence", s);
1049 : }
1050 3835 : v = pari_var_create(ep);
1051 3835 : ep->valence = EpVAR;
1052 3835 : ep->value = initial_value(ep);
1053 3835 : 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 1197 : vars_sort_inplace(GEN z)
1093 1197 : { gen_sort_inplace(z,NULL,cmp_by_var,NULL); return z; }
1094 : GEN
1095 175 : vars_to_RgXV(GEN h)
1096 : {
1097 175 : long i, l = lg(h);
1098 175 : GEN z = cgetg(l, t_VEC);
1099 2086 : for (i = 1; i < l; i++) gel(z,i) = pol_x(h[i]);
1100 175 : 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 2529628 : fill_hashtable_single(entree **table, entree *ep)
1118 : {
1119 2529628 : EpSETSTATIC(ep);
1120 2529628 : insertep(ep, table, hash_str(ep->name));
1121 2529628 : if (ep->code) ep->arity = check_proto(ep->code);
1122 2529628 : ep->pvalue = NULL;
1123 2529628 : }
1124 :
1125 : void
1126 5438 : pari_fill_hashtable(entree **table, entree *ep)
1127 : {
1128 2535066 : for ( ; ep->name; ep++) fill_hashtable_single(table, ep);
1129 5438 : }
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 9275048 : do_alias(entree *ep)
1154 : {
1155 9275104 : while (ep->valence == EpALIAS) ep = ALIAS(ep);
1156 9275048 : 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 13075520 : ifpari(GEN g, GEN a/*closure*/, GEN b/*closure*/)
1176 : {
1177 13075520 : if (gequal0(g)) /* false */
1178 10049587 : return b? closure_evalgen(b): gnil;
1179 : else /* true */
1180 3025933 : return a? closure_evalgen(a): gnil;
1181 : }
1182 :
1183 : void
1184 41393588 : ifpari_void(GEN g, GEN a/*closure*/, GEN b/*closure*/)
1185 : {
1186 41393588 : if (gequal0(g)) /* false */
1187 40602353 : { if (b) closure_evalvoid(b); }
1188 : else /* true */
1189 791235 : { if (a) closure_evalvoid(a); }
1190 41393567 : }
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 64280808 : andpari(GEN a, GEN b/*closure*/)
1210 : {
1211 : GEN g;
1212 64280808 : if (gequal0(a))
1213 53968076 : return gen_0;
1214 10312732 : g=closure_evalgen(b);
1215 10312732 : if (!g) return g;
1216 10312732 : return gequal0(g)?gen_0:gen_1;
1217 : }
1218 :
1219 : GEN
1220 16719531 : orpari(GEN a, GEN b/*closure*/)
1221 : {
1222 : GEN g;
1223 16719531 : if (!gequal0(a))
1224 337275 : return gen_1;
1225 16382256 : g=closure_evalgen(b);
1226 16382256 : if (!g) return g;
1227 16382256 : 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 534443 : GEN gadde(GEN *x, GEN y) { *x = gadd(*x,y); return *x; }
1238 25685195 : 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 20881 : 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); }
|
