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 457 : IS_ID(char c) { return isalnum((unsigned char)c) || c == '_'; }
45 : long
46 35 : eval_mnemonic(GEN str, const char *tmplate)
47 : {
48 : const char *arg, *etmplate;
49 35 : ulong retval = 0;
50 :
51 35 : if (typ(str)==t_INT) return itos(str);
52 35 : if (typ(str)!=t_STR) pari_err_TYPE("eval_mnemonic",str);
53 :
54 35 : arg = GSTR(str);
55 35 : etmplate = strchr(tmplate, '\n');
56 35 : if (!etmplate) etmplate = tmplate + strlen(tmplate);
57 :
58 : while (1)
59 43 : {
60 : long numarg;
61 78 : const char *e, *id, *negated = NULL;
62 78 : int negate = 0; /* Arg has 'no' prefix removed */
63 : ulong l;
64 : char *buf;
65 : static char b[80];
66 :
67 78 : while (isspace((unsigned char)*arg)) arg++;
68 78 : if (!*arg) break;
69 434 : e = arg; while (IS_ID(*e)) e++;
70 : /* Now the ID is whatever is between arg and e. */
71 43 : l = e - arg;
72 43 : if (l >= sizeof(b)) pari_err(e_MISC,"id too long in a mnemonic");
73 43 : if (!l) pari_err(e_MISC,"mnemonic does not start with an id");
74 43 : strncpy(b, arg, l); b[l] = 0;
75 43 : arg = e; e = buf = b;
76 43 : while ('0' <= *e && *e <= '9') e++;
77 43 : if (*e == 0) pari_err(e_MISC,"numeric id in a mnemonic");
78 43 : FIND:
79 43 : id = tmplate;
80 43 : while ((id = strstr(id, buf)) && id < etmplate)
81 : {
82 43 : const char *s = id;
83 43 : id += l; if (s[l] != '|') continue; /* False positive */
84 43 : 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 43 : 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 43 : 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 43 : if (*id++ != '|') pari_err(e_MISC,"Missing | in mnemonic template");
103 43 : e = id;
104 102 : while (*e >= '0' && *e <= '9') e++;
105 43 : while (isspace((unsigned char)*e)) e++;
106 43 : if (*e && *e != ';' && *e != ',')
107 0 : pari_err(e_MISC, "Non-numeric argument in mnemonic template");
108 43 : numarg = atol(id);
109 43 : if (negate) retval &= ~numarg; else retval |= numarg;
110 43 : while (isspace((unsigned char)*arg)) arg++;
111 43 : if (*arg && !ispunct((unsigned char)*arg++)) /* skip punctuation */
112 0 : pari_err(e_MISC,"Junk after id in mnemonic");
113 : }
114 35 : return retval;
115 : }
116 :
117 : /********************************************************************/
118 : /** **/
119 : /** HASH TABLE MANIPULATIONS **/
120 : /** **/
121 : /********************************************************************/
122 : static void
123 2682253 : insertep(entree *ep, entree **table, ulong hash)
124 : {
125 2682253 : ep->hash = hash;
126 2682253 : hash %= functions_tblsz;
127 2682253 : ep->next = table[hash];
128 2682253 : table[hash] = ep;
129 2682253 : }
130 :
131 : static entree *
132 35413 : initep(const char *name, long len)
133 : {
134 35413 : const long add = 4*sizeof(long);
135 35413 : entree *ep = (entree *) pari_calloc(sizeof(entree) + add + len+1);
136 35413 : entree *ep1 = initial_value(ep);
137 35413 : char *u = (char *) ep1 + add;
138 35413 : ep->name = u; memcpy(u, name,len); u[len]=0;
139 35413 : ep->valence = EpNEW;
140 35413 : ep->value = NULL;
141 35413 : ep->menu = 0;
142 35413 : ep->code = NULL;
143 35413 : ep->help = NULL;
144 35413 : ep->pvalue = NULL;
145 35413 : ep->arity = 0;
146 35413 : return ep;
147 : }
148 :
149 : /* Look for s of length len in T; if 'insert', insert if missing */
150 : static entree *
151 18254861 : findentry(const char *s, long len, entree **T, int insert)
152 : {
153 18254861 : ulong hash = hash_str_len(s, len);
154 : entree *ep;
155 181782606 : for (ep = T[hash % functions_tblsz]; ep; ep = ep->next)
156 181747263 : if (ep->hash == hash)
157 : {
158 18219657 : const char *t = ep->name;
159 18219657 : if (!strncmp(t, s, len) && !t[len]) return ep;
160 : }
161 : /* not found */
162 35343 : if (insert) { ep = initep(s,len); insertep(ep, T, hash); }
163 35345 : return ep;
164 : }
165 : entree *
166 965 : pari_is_default(const char *s)
167 965 : { return findentry(s, strlen(s), defaults_hash, 0); }
168 : entree *
169 8074328 : is_entry(const char *s)
170 8074328 : { return findentry(s, strlen(s), functions_hash, 0); }
171 : entree *
172 10179567 : fetch_entry_raw(const char *s, long len)
173 10179567 : { return findentry(s, len, functions_hash, 1); }
174 : entree *
175 449234 : 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 803787 : readseq_i(char *t)
184 : {
185 803787 : if (gp_meta(t,0)) return gnil;
186 803787 : return closure_evalres(pari_compile_str(t));
187 : }
188 : GEN
189 803787 : readseq(char *t)
190 803787 : { 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_prec(const char *s, long prec)
202 : {
203 : GEN x;
204 0 : push_localbitprec(prec);
205 0 : x = gp_read_str(s);
206 0 : pop_localprec();
207 0 : return x;
208 : }
209 :
210 : /* Deprecated, keep for backward compatibility */
211 : GEN
212 0 : gp_read_str_bitprec(const char *s, long bitprec)
213 0 : { return gp_read_str_prec(s, bitprec); }
214 :
215 : /* valid return type */
216 : static int
217 2622642 : isreturn(char c)
218 2622642 : { return c == 'l' || c == 'v' || c == 'i' || c == 'm' || c == 'u'; }
219 :
220 : /* if is known that 2 commas follow s; base-10 signed integer followed
221 : * by comma? */
222 : static int
223 520390 : is_long(const char *s)
224 : {
225 520390 : while (isspace((unsigned char)*s)) s++;
226 520390 : if (*s == '+' || *s == '-') s++;
227 1042648 : while (isdigit((unsigned char)*s)) s++;
228 520390 : return *s == ',';
229 : }
230 : /* if is known that 2 commas follow s; base-10 unsigned integer followed
231 : * by comma? */
232 : static int
233 1884 : is_ulong(const char *s)
234 : {
235 1884 : while (isspace((unsigned char)*s)) s++;
236 1884 : if (*s == '+') s++;
237 3760 : while (isdigit((unsigned char)*s)) s++;
238 1884 : return *s == ',';
239 : }
240 : static long
241 2622642 : check_proto(const char *code)
242 : {
243 2622642 : long arity = 0;
244 2622642 : const char *s = code;
245 2622642 : if (isreturn(*s)) s++;
246 8884470 : while (*s && *s != '\n') switch (*s++)
247 : {
248 4571438 : case '&':
249 : case 'C':
250 : case 'G':
251 : case 'I':
252 : case 'J':
253 : case 'U':
254 : case 'L':
255 : case 'M':
256 : case 'P':
257 : case 'W':
258 : case 'f':
259 : case 'n':
260 : case 'p':
261 : case 'b':
262 : case 'r':
263 4571438 : arity++; break;
264 144144 : case 'E':
265 : case 's':
266 144144 : if (*s == '*') s++;
267 144144 : arity++; break;
268 1351570 : case 'D':
269 1351570 : switch(*s)
270 : {
271 786240 : case 'G': case '&': case 'n': case 'I': case 'E':
272 786240 : case 'P': case 's': case 'r': s++; arity++; break;
273 20592 : case 'V': s++; break;
274 0 : case 0:
275 0 : pari_err(e_SYNTAX,"function has incomplete prototype", s,code);
276 0 : break;
277 544738 : default:
278 : {
279 : const char *p;
280 : long i;
281 2759270 : for(i = 0, p = s; *p && i < 2; p++) i += *p==','; /* skip 2 commas */
282 544738 : if (i < 2) pari_err(e_SYNTAX,"missing comma",s,code);
283 544738 : arity++;
284 544738 : switch(p[-2])
285 : {
286 520390 : case 'L':
287 520390 : if (!is_long(s)) pari_err(e_SYNTAX,"not a long",s,code);
288 520386 : break;
289 1884 : case 'U':
290 1884 : if (!is_ulong(s)) pari_err(e_SYNTAX,"not an ulong",s,code);
291 1876 : break;
292 22464 : case 'G': case 'r': case 's': case 'M':
293 22464 : break;
294 0 : default: pari_err(e_SYNTAX,"incorrect type",s-2,code);
295 : }
296 544726 : s = p;
297 : }
298 : }
299 1351558 : break;
300 194688 : case 'V':
301 : case '=':
302 194688 : case ',': break;
303 0 : case '\n': break; /* Before the mnemonic */
304 0 : default:
305 0 : if (isreturn(s[-1]))
306 0 : pari_err(e_SYNTAX, "this code has to come first", s-1, code);
307 0 : pari_err(e_SYNTAX, "unknown parser code", s-1, code);
308 : }
309 2622630 : if (arity > 20) pari_err_IMPL("functions with more than 20 parameters");
310 2622630 : return arity;
311 : }
312 : static void
313 8 : check_name(const char *name)
314 : {
315 8 : const char *s = name;
316 8 : if (isalpha((unsigned char)*s))
317 40 : while (is_keyword_char(*++s)) /* empty */;
318 8 : if (*s) pari_err(e_SYNTAX,"not a valid identifier", s, name);
319 8 : }
320 :
321 : entree *
322 20 : install(void *f, const char *name, const char *code)
323 : {
324 20 : long arity = check_proto(code);
325 : entree *ep;
326 :
327 8 : check_name(name);
328 8 : ep = fetch_entry(name);
329 8 : if (ep->valence != EpNEW)
330 : {
331 0 : if (ep->valence != EpINSTALL)
332 0 : pari_err(e_MISC,"[install] identifier '%s' already in use", name);
333 0 : pari_warn(warner, "[install] updating '%s' prototype; module not reloaded", name);
334 0 : if (ep->code) pari_free((void*)ep->code);
335 : }
336 : else
337 : {
338 8 : ep->value = f;
339 8 : ep->valence = EpINSTALL;
340 : }
341 8 : ep->code = pari_strdup(code);
342 8 : ep->arity = arity; return ep;
343 : }
344 :
345 : static void
346 18 : killep(entree *ep)
347 : {
348 18 : GEN p = (GEN)initial_value(ep);
349 18 : freeep(ep);
350 18 : *p = 0; /* otherwise pari_var_create won't regenerate it */
351 18 : ep->valence = EpNEW;
352 18 : ep->value = NULL;
353 18 : ep->pvalue = NULL;
354 18 : }
355 : /* Kill ep, i.e free all memory it references, and reset to initial value */
356 : void
357 18 : kill0(const char *e)
358 : {
359 18 : entree *ep = is_entry(e);
360 18 : if (!ep || EpSTATIC(ep)) pari_err(e_MISC,"can't kill that");
361 18 : killep(ep);
362 18 : }
363 :
364 : void
365 50 : addhelp(const char *e, const char *s)
366 : {
367 50 : entree *ep = fetch_entry(e);
368 50 : void *f = (void *) ep->help;
369 50 : ep->help = pari_strdup(s);
370 50 : if (f && !EpSTATIC(ep)) pari_free(f);
371 50 : }
372 :
373 : /*******************************************************************/
374 : /* */
375 : /* PARSER */
376 : /* */
377 : /*******************************************************************/
378 :
379 : #ifdef LONG_IS_64BIT
380 : static const long MAX_DIGITS = 19;
381 : #else
382 : static const long MAX_DIGITS = 9;
383 : #endif
384 :
385 : static const long MAX_XDIGITS = BITS_IN_LONG>>2;
386 : static const long MAX_BDIGITS = BITS_IN_LONG;
387 :
388 : static int
389 50129683 : ishex(const char **s)
390 : {
391 50129683 : if (**s == '0' && ((*s)[1] == 'x' || (*s)[1] == 'X' ))
392 : {
393 130 : *s += 2;
394 130 : return 1;
395 : }
396 : else
397 50129553 : return 0;
398 : }
399 :
400 : static int
401 50129739 : isbin(const char **s)
402 : {
403 50129739 : if (**s == '0' && ((*s)[1] == 'b' || (*s)[1] == 'B' ))
404 : {
405 56 : *s += 2;
406 56 : return 1;
407 : }
408 : else
409 50129683 : return 0;
410 : }
411 :
412 : static ulong
413 37 : bin_number_len(const char *s, long n)
414 : {
415 37 : ulong m = 0;
416 : long i;
417 1073 : for (i = 0; i < n; i++,s++)
418 1036 : m = 2*m + (*s - '0');
419 37 : return m;
420 : }
421 :
422 : static int
423 1064 : pari_isbdigit(int c)
424 : {
425 1064 : return c=='0' || c=='1';
426 : }
427 :
428 : static ulong
429 108 : hex_number_len(const char *s, long n)
430 : {
431 108 : ulong m = 0;
432 : long i;
433 1249 : for(i = 0; i < n; i++, s++)
434 : {
435 : ulong c;
436 1141 : if( *s >= '0' && *s <= '9')
437 566 : c = *s - '0';
438 575 : else if( *s >= 'A' && *s <= 'F')
439 42 : c = *s - 'A' + 10;
440 : else
441 533 : c = *s - 'a' + 10;
442 1141 : m = 16*m + c;
443 : }
444 108 : return m;
445 : }
446 :
447 : static GEN
448 102 : strtobin_len(const char *s, long n, long B, ulong num(const char *s, long n))
449 : {
450 102 : long i, l = (n+B-1)/B;
451 : GEN N, Np;
452 102 : N = cgetipos(l+2);
453 102 : Np = int_LSW(N);
454 145 : for (i=1; i<l; i++, Np = int_nextW(Np))
455 43 : uel(Np, 0) = num(s+n-i*B, B);
456 102 : uel(Np, 0) = num(s, n-(i-1)*B);
457 102 : return int_normalize(N, 0);
458 : }
459 :
460 : static GEN
461 102 : binary_read(const char **ps, long B, int is(int), ulong num(const char *s, long n))
462 : {
463 102 : const char *s = *ps;
464 2279 : while (is((unsigned char)**ps)) (*ps)++;
465 102 : return strtobin_len(s, *ps-s, B, num);
466 : }
467 :
468 : static GEN
469 28 : bin_read(const char **ps)
470 : {
471 28 : return binary_read(ps, MAX_BDIGITS, pari_isbdigit, bin_number_len);
472 : }
473 :
474 : static GEN
475 74 : hex_read(const char **ps)
476 : {
477 74 : return binary_read(ps, MAX_XDIGITS, isxdigit, hex_number_len);
478 : }
479 :
480 : static ulong
481 3789830 : dec_number_len(const char *s, long B)
482 : {
483 3789830 : ulong m = 0;
484 : long n;
485 58693495 : for (n = 0; n < B; n++,s++)
486 54903665 : m = 10*m + (*s - '0');
487 3789830 : return m;
488 : }
489 :
490 : static GEN
491 872747 : dec_strtoi_len(const char *s, long n)
492 : {
493 872747 : const long B = MAX_DIGITS;
494 872747 : long i, l = (n+B-1)/B;
495 872747 : GEN V = cgetg(l+1, t_VECSMALL);
496 3789830 : for (i=1; i<l; i++)
497 2917083 : uel(V,i) = dec_number_len(s+n-i*B, B);
498 872747 : uel(V, i) = dec_number_len(s, n-(i-1)*B);
499 872747 : return fromdigitsu(V, powuu(10, B));
500 : }
501 :
502 : static GEN
503 872747 : dec_read_more(const char **ps)
504 : {
505 872747 : pari_sp av = avma;
506 872747 : const char *s = *ps;
507 55776412 : while (isdigit((unsigned char)**ps)) (*ps)++;
508 872747 : return gerepileuptoint(av, dec_strtoi_len(s, *ps-s));
509 : }
510 :
511 : static ulong
512 12130427 : number(int *n, const char **s)
513 : {
514 12130427 : ulong m = 0;
515 54459570 : for (*n = 0; *n < MAX_DIGITS && isdigit((unsigned char)**s); (*n)++,(*s)++)
516 42329143 : m = 10*m + (**s - '0');
517 12130427 : return m;
518 : }
519 :
520 : static GEN
521 12054890 : dec_read(const char **s)
522 : {
523 : int nb;
524 12054890 : ulong y = number(&nb, s);
525 12054890 : if (nb < MAX_DIGITS)
526 11182143 : return utoi(y);
527 872747 : *s -= MAX_DIGITS;
528 872747 : return dec_read_more(s);
529 : }
530 :
531 : static GEN
532 4906 : real_read_more(GEN y, const char **ps)
533 : {
534 4906 : pari_sp av = avma;
535 4906 : const char *s = *ps;
536 4906 : GEN z = dec_read(ps);
537 4906 : long e = *ps-s;
538 4906 : return gerepileuptoint(av, addmulii(z, powuu(10, e), y));
539 : }
540 :
541 : static long
542 75537 : exponent(const char **pts)
543 : {
544 75537 : const char *s = *pts;
545 : long n;
546 : int nb;
547 75537 : switch(*++s)
548 : {
549 75355 : case '-': s++; n = -(long)number(&nb, &s); break;
550 0 : case '+': s++; /* Fall through */
551 182 : default: n = (long)number(&nb, &s);
552 : }
553 75537 : *pts = s; return n;
554 : }
555 :
556 : static GEN
557 196 : real_0_digits(long n) {
558 196 : long b = (n > 0)? (long)(n/LOG10_2): (long)-((-n)/LOG10_2 + 1);
559 196 : return real_0_bit(b);
560 : }
561 :
562 : static GEN
563 85793 : real_read(pari_sp av, const char **s, GEN y, long prec)
564 : {
565 85793 : long l, n = 0;
566 85793 : switch(**s)
567 : {
568 0 : default: return y; /* integer */
569 11614 : case '.':
570 : {
571 11614 : const char *old = ++*s;
572 11614 : if (isalpha((unsigned char)**s) || **s=='.')
573 : {
574 1337 : if (**s == 'E' || **s == 'e') {
575 1337 : n = exponent(s);
576 1337 : if (!signe(y)) { set_avma(av); return real_0_digits(n); }
577 1288 : break;
578 : }
579 0 : --*s; return y; /* member */
580 : }
581 10277 : if (isdigit((unsigned char)**s)) y = real_read_more(y, s);
582 10277 : n = old - *s;
583 10277 : if (**s != 'E' && **s != 'e')
584 : {
585 10256 : if (!signe(y)) { set_avma(av); return real_0(prec); }
586 9003 : break;
587 : }
588 : }
589 : /* Fall through */
590 : case 'E': case 'e':
591 74200 : n += exponent(s);
592 74200 : if (!signe(y)) { set_avma(av); return real_0_digits(n); }
593 : }
594 84344 : l = nbits2prec(bit_accuracy(lgefint(y)));
595 84344 : if (l < prec) l = prec; else prec = l;
596 84344 : if (!n) return itor(y, prec);
597 79519 : incrprec(l);
598 79519 : y = itor(y, l);
599 79519 : if (n > 0)
600 84 : y = mulrr(y, rpowuu(10UL, (ulong)n, l));
601 : else
602 79435 : y = divrr(y, rpowuu(10UL, (ulong)-n, l));
603 79519 : return gerepileuptoleaf(av, rtor(y, prec));
604 : }
605 :
606 : static GEN
607 11964293 : int_read(const char **s)
608 : {
609 : GEN y;
610 11964293 : if (isbin(s))
611 28 : y = bin_read(s);
612 11964265 : else if (ishex(s))
613 74 : y = hex_read(s);
614 : else
615 11964191 : y = dec_read(s);
616 11964293 : return y;
617 : }
618 :
619 : GEN
620 11964293 : strtoi(const char *s) { return int_read(&s); }
621 :
622 : GEN
623 85793 : strtor(const char *s, long prec)
624 : {
625 85793 : pari_sp av = avma;
626 85793 : GEN y = dec_read(&s);
627 85793 : y = real_read(av, &s, y, prec);
628 85793 : if (typ(y) == t_REAL) return y;
629 0 : return gerepileuptoleaf(av, itor(y, prec));
630 : }
631 :
632 : static void
633 11973191 : skipdigits(char **lex) {
634 93667828 : while (isdigit((unsigned char)**lex)) ++*lex;
635 11973191 : }
636 :
637 : static int
638 11966139 : skipexponent(char **lex)
639 : {
640 11966139 : char *old=*lex;
641 11966139 : if ((**lex=='e' || **lex=='E'))
642 : {
643 1127 : ++*lex;
644 1127 : if ( **lex=='+' || **lex=='-' ) ++*lex;
645 1127 : if (!isdigit((unsigned char)**lex))
646 : {
647 469 : *lex=old;
648 469 : return KINTEGER;
649 : }
650 658 : skipdigits(lex);
651 658 : return KREAL;
652 : }
653 11965012 : return KINTEGER;
654 : }
655 :
656 : static int
657 11967762 : skipconstante(char **lex)
658 : {
659 11967762 : skipdigits(lex);
660 11967762 : if (**lex=='.')
661 : {
662 19134 : char *old = ++*lex;
663 19134 : if (**lex == '.') { --*lex; return KINTEGER; }
664 17511 : if (isalpha((unsigned char)**lex))
665 : {
666 12740 : skipexponent(lex);
667 12740 : if (*lex == old)
668 : {
669 12579 : --*lex; /* member */
670 12579 : return KINTEGER;
671 : }
672 161 : return KREAL;
673 : }
674 4771 : skipdigits(lex);
675 4771 : skipexponent(lex);
676 4771 : return KREAL;
677 : }
678 11948628 : return skipexponent(lex);
679 : }
680 :
681 : static void
682 879996 : skipstring(char **lex)
683 : {
684 6940852 : while (**lex)
685 : {
686 6941500 : while (**lex == '\\') *lex+=2;
687 6940852 : if (**lex == '"')
688 : {
689 879996 : if ((*lex)[1] != '"') break;
690 0 : *lex += 2; continue;
691 : }
692 6060856 : (*lex)++;
693 : }
694 879996 : }
695 :
696 : int
697 40557919 : pari_lex(union token_value *yylval, struct node_loc *yylloc, char **lex)
698 : {
699 : (void) yylval;
700 40557919 : yylloc->start=*lex;
701 40557919 : if (!**lex)
702 : {
703 932095 : yylloc->end=*lex;
704 932095 : return 0;
705 : }
706 39625824 : if (isalpha((unsigned char)**lex))
707 : {
708 2535888 : while (is_keyword_char(**lex)) ++*lex;
709 566131 : yylloc->end=*lex;
710 566131 : return KENTRY;
711 : }
712 39059693 : if (**lex=='"')
713 : {
714 879996 : ++*lex;
715 879996 : skipstring(lex);
716 879996 : if (!**lex)
717 0 : compile_err("run-away string",*lex-1);
718 879996 : ++*lex;
719 879996 : yylloc->end=*lex;
720 879996 : return KSTRING;
721 : }
722 38179697 : if (**lex == '.')
723 : {
724 : int token;
725 14251 : if ((*lex)[1]== '.')
726 : {
727 1651 : *lex+=2; yylloc->end = *lex; return KDOTDOT;
728 : }
729 12600 : token=skipconstante(lex);
730 12600 : if (token==KREAL)
731 : {
732 21 : yylloc->end = *lex;
733 21 : return token;
734 : }
735 12579 : ++*lex;
736 12579 : yylloc->end=*lex;
737 12579 : return '.';
738 : }
739 38165446 : if (isbin((const char**)lex))
740 : {
741 1064 : while (**lex=='0' || **lex=='1') ++*lex;
742 28 : yylloc->end = *lex;
743 28 : return KINTEGER;
744 : }
745 38165418 : if (ishex((const char**)lex))
746 : {
747 903 : while (isxdigit((unsigned int)**lex)) ++*lex;
748 56 : yylloc->end = *lex;
749 56 : return KINTEGER;
750 : }
751 38165362 : if (isdigit((unsigned char)**lex))
752 : {
753 11955162 : int token=skipconstante(lex);
754 11955162 : yylloc->end = *lex;
755 11955162 : return token;
756 : }
757 26210200 : if ((*lex)[1]=='=')
758 29702 : switch (**lex)
759 : {
760 11810 : case '=':
761 11810 : if ((*lex)[2]=='=')
762 343 : { *lex+=3; yylloc->end = *lex; return KID; }
763 : else
764 11467 : { *lex+=2; yylloc->end = *lex; return KEQ; }
765 125 : case '>':
766 125 : *lex+=2; yylloc->end = *lex; return KGE;
767 237 : case '<':
768 237 : *lex+=2; yylloc->end = *lex; return KLE;
769 195 : case '*':
770 195 : *lex+=2; yylloc->end = *lex; return KME;
771 35 : case '/':
772 35 : *lex+=2; yylloc->end = *lex; return KDE;
773 7 : case '%':
774 7 : if ((*lex)[2]=='=') break;
775 7 : *lex+=2; yylloc->end = *lex; return KMODE;
776 2149 : case '!':
777 2149 : if ((*lex)[2]=='=') break;
778 2149 : *lex+=2; yylloc->end = *lex; return KNE;
779 7 : case '\\':
780 7 : *lex+=2; yylloc->end = *lex; return KEUCE;
781 229 : case '+':
782 229 : *lex+=2; yylloc->end = *lex; return KPE;
783 63 : case '-':
784 63 : *lex+=2; yylloc->end = *lex; return KSE;
785 : }
786 26195343 : if (**lex==')' && (*lex)[1]=='-' && (*lex)[2]=='>')
787 : {
788 4100 : *lex+=3; yylloc->end = *lex; return KPARROW;
789 : }
790 26191243 : if (**lex=='-' && (*lex)[1]=='>')
791 : {
792 1332 : *lex+=2; yylloc->end = *lex; return KARROW;
793 : }
794 26189911 : if (**lex=='<' && (*lex)[1]=='>')
795 : {
796 0 : *lex+=2; yylloc->end = *lex; return KNE;
797 : }
798 26189911 : if (**lex=='\\' && (*lex)[1]=='/')
799 35 : switch((*lex)[2])
800 : {
801 7 : case '=':
802 7 : *lex+=3; yylloc->end = *lex; return KDRE;
803 28 : default:
804 28 : *lex+=2; yylloc->end = *lex; return KDR;
805 : }
806 26189876 : if ((*lex)[1]==**lex)
807 2398649 : switch (**lex)
808 : {
809 816 : case '&':
810 816 : *lex+=2; yylloc->end = *lex; return KAND;
811 413 : case '|':
812 413 : *lex+=2; yylloc->end = *lex; return KOR;
813 183 : case '+':
814 183 : *lex+=2; yylloc->end = *lex; return KPP;
815 28 : case '-':
816 28 : *lex+=2; yylloc->end = *lex; return KSS;
817 28 : case '>':
818 28 : if ((*lex)[2]=='=') { *lex+=3; yylloc->end = *lex; return KSRE;}
819 21 : *lex+=2; yylloc->end = *lex; return KSR;
820 154 : case '<':
821 154 : if ((*lex)[2]=='=')
822 7 : { *lex+=3; yylloc->end = *lex; return KSLE; }
823 147 : *lex+=2; yylloc->end = *lex; return KSL;
824 : }
825 26188254 : yylloc->end = *lex+1;
826 26188254 : return (unsigned char) *(*lex)++;
827 : }
828 :
829 : /********************************************************************/
830 : /* */
831 : /* Formal variables management */
832 : /* */
833 : /********************************************************************/
834 : static THREAD long max_priority, min_priority;
835 : static THREAD long max_avail; /* max variable not yet used */
836 : static THREAD long nvar; /* first GP free variable */
837 : static hashtable *h_polvar;
838 :
839 : void
840 465442 : varstate_save(struct pari_varstate *s)
841 : {
842 465442 : s->nvar = nvar;
843 465442 : s->max_avail = max_avail;
844 465442 : s->max_priority = max_priority;
845 465442 : s->min_priority = min_priority;
846 465442 : }
847 :
848 : static void
849 9287 : varentries_set(long v, entree *ep)
850 : {
851 9287 : hash_insert(h_polvar, (void*)ep->name, (void*)v);
852 9287 : varentries[v] = ep;
853 9287 : }
854 : static int
855 3010 : _given_value(void *E, hashentry *e) { return e->val == E; }
856 :
857 : static void
858 15979 : varentries_unset(long v)
859 : {
860 15979 : entree *ep = varentries[v];
861 15979 : if (ep)
862 : {
863 3010 : hashentry *e = hash_remove_select(h_polvar, (void*)ep->name, (void*)v,
864 : _given_value);
865 3010 : if (!e) pari_err_BUG("varentries_unset [unknown var]");
866 3010 : varentries[v] = NULL;
867 3010 : pari_free(e);
868 3010 : if (v <= nvar && ep == is_entry(ep->name))
869 3003 : { /* known to the GP interpreter; entree in functions_hash is permanent */
870 3003 : GEN p = (GEN)initial_value(ep);
871 3003 : if (ep->value == p) { ep->value = NULL; ep->valence = EpNEW; }
872 3003 : *p = 0;
873 : }
874 : else /* from name_var() or a direct pari_var_create() */
875 7 : pari_free(ep);
876 : }
877 15979 : }
878 : static void
879 118 : varentries_reset(long v, entree *ep)
880 : {
881 118 : varentries_unset(v);
882 118 : varentries_set(v, ep);
883 118 : }
884 :
885 : static void
886 337037 : var_restore(struct pari_varstate *s)
887 : {
888 337037 : nvar = s->nvar;
889 337037 : max_avail = s->max_avail;
890 337037 : max_priority = s->max_priority;
891 337037 : min_priority = s->min_priority;
892 337037 : }
893 :
894 : void
895 12809 : varstate_restore(struct pari_varstate *s)
896 : {
897 : long i;
898 28628 : for (i = nvar; i >= s->nvar; i--)
899 : {
900 15819 : varentries_unset(i);
901 15819 : varpriority[i] = -i;
902 : }
903 12851 : for (i = max_avail+1; i <= s->max_avail; i++)
904 : {
905 42 : varentries_unset(i);
906 42 : varpriority[i] = -i;
907 : }
908 12809 : var_restore(s);
909 12809 : }
910 :
911 : void
912 324241 : pari_set_varstate(long *vp, struct pari_varstate *vs)
913 : {
914 324241 : var_restore(vs);
915 324206 : varpriority = (long*)newblock(MAXVARN+2) + 1;
916 324173 : memcpy(varpriority-1,vp-1,(MAXVARN+2)*sizeof(long));
917 324173 : }
918 :
919 : /* must come before destruction of functions_hash */
920 : void
921 1862 : pari_var_close(void)
922 : {
923 1862 : GEN h = hash_values(h_polvar);
924 1862 : long i, l = lg(h);
925 8119 : for (i = 1; i < l; i++)
926 : {
927 6257 : long v = h[i];
928 6257 : entree *ep = varentries[v];
929 6257 : if (ep && ep != is_entry(ep->name)) pari_free(ep);
930 : }
931 1862 : free((void*)varentries);
932 1862 : free((void*)(varpriority-1));
933 1862 : hash_destroy(h_polvar);
934 1862 : }
935 :
936 : void
937 1872 : pari_var_init(void)
938 : {
939 : long i;
940 1872 : varentries = (entree**) pari_calloc((MAXVARN+1)*sizeof(entree*));
941 1872 : varpriority = (long*)pari_malloc((MAXVARN+2)*sizeof(long)) + 1;
942 1872 : varpriority[-1] = 1-LONG_MAX;
943 1872 : h_polvar = hash_create_str(100, 0);
944 1872 : nvar = 0; max_avail = MAXVARN;
945 1872 : max_priority = min_priority = 0;
946 1872 : (void)fetch_user_var("x");
947 1872 : (void)fetch_user_var("y");
948 : /* initialize so that people can use pol_x(i) directly */
949 110000304 : for (i = 2; i <= (long)MAXVARN; i++) varpriority[i] = -i;
950 : /* reserve varnum 1..9 for static temps with predictable priority wrt x */
951 1872 : nvar = 10;
952 1872 : min_priority = -MAXVARN;
953 1872 : }
954 8 : long pari_var_next(void) { return nvar; }
955 0 : long pari_var_next_temp(void) { return max_avail; }
956 : long
957 479562 : pari_var_create(entree *ep)
958 : {
959 479562 : GEN p = (GEN)initial_value(ep);
960 : long v;
961 479562 : if (*p) return varn(p);
962 9169 : if (nvar == max_avail) pari_err(e_MISC,"no more variables available");
963 9169 : v = nvar++;
964 : /* set p = pol_x(v) */
965 9169 : p[0] = evaltyp(t_POL) | _evallg(4);
966 9169 : p[1] = evalsigne(1) | evalvarn(v);
967 9169 : gel(p,2) = gen_0;
968 9169 : gel(p,3) = gen_1;
969 9169 : varentries_set(v, ep);
970 9169 : varpriority[v]= min_priority--;
971 9169 : return v;
972 : }
973 :
974 : long
975 1249011 : delete_var(void)
976 : { /* user wants to delete one of his/her/its variables */
977 1249011 : if (max_avail == MAXVARN) return 0; /* nothing to delete */
978 1248381 : max_avail++;
979 1248381 : if (varpriority[max_avail] == min_priority) min_priority++;
980 1248381 : else if (varpriority[max_avail] == max_priority) max_priority--;
981 1248381 : return max_avail+1;
982 : }
983 : long
984 86921 : fetch_var(void)
985 : {
986 86921 : if (nvar == max_avail) pari_err(e_MISC,"no more variables available");
987 86921 : varpriority[max_avail] = min_priority--;
988 86921 : return max_avail--;
989 : }
990 : long
991 1162060 : fetch_var_higher(void)
992 : {
993 1162060 : if (nvar == max_avail) pari_err(e_MISC,"no more variables available");
994 1162062 : varpriority[max_avail] = ++max_priority;
995 1162062 : return max_avail--;
996 : }
997 :
998 : static int
999 49 : _higher(void *E, hashentry *e)
1000 49 : { long v = (long)e->val; return (varncmp(v, (long)E) < 0); }
1001 : static int
1002 42 : _lower(void *E, hashentry *e)
1003 42 : { long v = (long)e->val; return (varncmp(v, (long)E) > 0); }
1004 :
1005 : static GEN
1006 118 : var_register(long v, const char *s)
1007 : {
1008 118 : varentries_reset(v, initep(s, strlen(s)));
1009 118 : return pol_x(v);
1010 : }
1011 : GEN
1012 105 : varhigher(const char *s, long w)
1013 : {
1014 : long v;
1015 105 : if (w >= 0)
1016 : {
1017 56 : hashentry *e = hash_select(h_polvar, (void*)s, (void*)w, _higher);
1018 56 : if (e) return pol_x((long)e->val);
1019 : }
1020 : /* no luck: need to create */
1021 91 : if (nvar == max_avail) pari_err(e_MISC,"no more variables available");
1022 91 : v = nvar++;
1023 91 : varpriority[v]= ++max_priority;
1024 91 : return var_register(v, s);
1025 : }
1026 : GEN
1027 34 : varlower(const char *s, long w)
1028 : {
1029 : long v;
1030 34 : if (w >= 0)
1031 : {
1032 21 : hashentry *e = hash_select(h_polvar, (void*)s, (void*)w, _lower);
1033 21 : if (e) return pol_x((long)e->val);
1034 : }
1035 : /* no luck: need to create */
1036 27 : v = fetch_var();
1037 27 : return var_register(v, s);
1038 : }
1039 :
1040 : long
1041 449120 : fetch_user_var(const char *s)
1042 : {
1043 449120 : entree *ep = fetch_entry(s);
1044 : long v;
1045 449120 : switch (EpVALENCE(ep))
1046 : {
1047 445173 : case EpVAR: return pari_var_create(ep);
1048 3947 : case EpNEW: break;
1049 0 : default: pari_err(e_MISC, "%s already exists with incompatible valence", s);
1050 : }
1051 3947 : v = pari_var_create(ep);
1052 3947 : ep->valence = EpVAR;
1053 3947 : ep->value = initial_value(ep);
1054 3947 : return v;
1055 : }
1056 :
1057 : GEN
1058 7 : fetch_var_value(long v, GEN t)
1059 : {
1060 7 : entree *ep = varentries[v];
1061 7 : if (!ep) return NULL;
1062 7 : if (t)
1063 : {
1064 7 : long vn = localvars_find(t,ep);
1065 7 : if (vn) return get_lex(vn);
1066 : }
1067 7 : return (GEN)ep->value;
1068 : }
1069 :
1070 : void
1071 0 : name_var(long n, const char *s)
1072 : {
1073 : entree *ep;
1074 : char *u;
1075 :
1076 0 : if (n < pari_var_next())
1077 0 : pari_err(e_MISC, "renaming a GP variable is forbidden");
1078 0 : if (n > (long)MAXVARN)
1079 0 : pari_err_OVERFLOW("variable number");
1080 :
1081 0 : ep = (entree*)pari_malloc(sizeof(entree) + strlen(s) + 1);
1082 0 : u = (char *)initial_value(ep);
1083 0 : ep->valence = EpVAR;
1084 0 : ep->name = u; strcpy(u,s);
1085 0 : ep->value = gen_0; /* in case geval is called */
1086 0 : varentries_reset(n, ep);
1087 0 : }
1088 :
1089 : static int
1090 5150 : cmp_by_var(void *E,GEN x, GEN y)
1091 5150 : { (void)E; return varncmp((long)x,(long)y); }
1092 : GEN
1093 1211 : vars_sort_inplace(GEN z)
1094 1211 : { gen_sort_inplace(z,NULL,cmp_by_var,NULL); return z; }
1095 : GEN
1096 175 : vars_to_RgXV(GEN h)
1097 : {
1098 175 : long i, l = lg(h);
1099 175 : GEN z = cgetg(l, t_VEC);
1100 2086 : for (i = 1; i < l; i++) gel(z,i) = pol_x(h[i]);
1101 175 : return z;
1102 : }
1103 : GEN
1104 1183 : gpolvar(GEN x)
1105 : {
1106 : long v;
1107 1183 : if (!x) {
1108 140 : GEN h = hash_values(h_polvar);
1109 140 : return vars_to_RgXV(vars_sort_inplace(h));
1110 : }
1111 1043 : if (typ(x)==t_PADIC) return gcopy( gel(x,2) );
1112 1036 : v = gvar(x);
1113 1036 : if (v==NO_VARIABLE) return gen_0;
1114 980 : return pol_x(v);
1115 : }
1116 :
1117 : static void
1118 2646958 : fill_hashtable_single(entree **table, entree *ep)
1119 : {
1120 2646958 : EpSETSTATIC(ep);
1121 2646958 : insertep(ep, table, hash_str(ep->name));
1122 2646958 : if (ep->code) ep->arity = check_proto(ep->code);
1123 2646958 : ep->pvalue = NULL;
1124 2646958 : }
1125 :
1126 : void
1127 5606 : pari_fill_hashtable(entree **table, entree *ep)
1128 : {
1129 2652564 : for ( ; ep->name; ep++) fill_hashtable_single(table, ep);
1130 5606 : }
1131 :
1132 : void
1133 0 : pari_add_function(entree *ep)
1134 : {
1135 0 : fill_hashtable_single(functions_hash, ep);
1136 0 : }
1137 :
1138 : /********************************************************************/
1139 : /** **/
1140 : /** SIMPLE GP FUNCTIONS **/
1141 : /** **/
1142 : /********************************************************************/
1143 :
1144 : GEN
1145 28 : arity0(GEN C)
1146 : {
1147 28 : if (typ(C)!=t_CLOSURE) pari_err_TYPE("arity", C);
1148 28 : return utoi(closure_arity(C));
1149 : }
1150 :
1151 : #define ALIAS(ep) (entree *) ((GEN)ep->value)[1]
1152 :
1153 : entree *
1154 9767995 : do_alias(entree *ep)
1155 : {
1156 9768051 : while (ep->valence == EpALIAS) ep = ALIAS(ep);
1157 9767995 : return ep;
1158 : }
1159 :
1160 : void
1161 28 : alias0(const char *s, const char *old)
1162 : {
1163 : entree *ep, *e;
1164 : GEN x;
1165 :
1166 28 : ep = fetch_entry(old);
1167 28 : e = fetch_entry(s);
1168 28 : if (EpVALENCE(e) != EpALIAS && EpVALENCE(e) != EpNEW)
1169 0 : pari_err(e_MISC,"can't replace an existing symbol by an alias");
1170 28 : freeep(e);
1171 28 : x = cgetg_block(2, t_VECSMALL); gel(x,1) = (GEN)ep;
1172 28 : e->value=x; e->valence=EpALIAS;
1173 28 : }
1174 :
1175 : GEN
1176 13077669 : ifpari(GEN g, GEN a/*closure*/, GEN b/*closure*/)
1177 : {
1178 13077669 : if (gequal0(g)) /* false */
1179 10051142 : return b? closure_evalgen(b): gnil;
1180 : else /* true */
1181 3026527 : return a? closure_evalgen(a): gnil;
1182 : }
1183 :
1184 : void
1185 41473169 : ifpari_void(GEN g, GEN a/*closure*/, GEN b/*closure*/)
1186 : {
1187 41473169 : if (gequal0(g)) /* false */
1188 40680299 : { if (b) closure_evalvoid(b); }
1189 : else /* true */
1190 792870 : { if (a) closure_evalvoid(a); }
1191 41473148 : }
1192 :
1193 : GEN
1194 31325 : ifpari_multi(GEN g, GEN a/*closure*/)
1195 : {
1196 31325 : long i, nb = lg(a)-1;
1197 31325 : if (!gequal0(g)) /* false */
1198 6713 : return closure_evalgen(gel(a,1));
1199 42098 : for(i=2;i<nb;i+=2)
1200 : {
1201 24724 : GEN g = closure_evalgen(gel(a,i));
1202 24724 : if (!g) return g;
1203 24717 : if (!gequal0(g))
1204 7231 : return closure_evalgen(gel(a,i+1));
1205 : }
1206 17374 : return i<=nb? closure_evalgen(gel(a,i)): gnil;
1207 : }
1208 :
1209 : GEN
1210 64287451 : andpari(GEN a, GEN b/*closure*/)
1211 : {
1212 : GEN g;
1213 64287451 : if (gequal0(a))
1214 53970190 : return gen_0;
1215 10317261 : g=closure_evalgen(b);
1216 10317261 : if (!g) return g;
1217 10317261 : return gequal0(g)?gen_0:gen_1;
1218 : }
1219 :
1220 : GEN
1221 16723451 : orpari(GEN a, GEN b/*closure*/)
1222 : {
1223 : GEN g;
1224 16723451 : if (!gequal0(a))
1225 338407 : return gen_1;
1226 16385044 : g=closure_evalgen(b);
1227 16385044 : if (!g) return g;
1228 16385044 : return gequal0(g)?gen_0:gen_1;
1229 : }
1230 :
1231 178691 : GEN gmule(GEN *x, GEN y) { *x = gmul(*x,y); return *x; }
1232 56 : GEN gdive(GEN *x, GEN y) { *x = gdiv(*x,y); return *x; }
1233 7 : GEN gdivente(GEN *x, GEN y) { *x = gdivent(*x,y); return *x; }
1234 7 : GEN gdivrounde(GEN *x, GEN y) { *x = gdivround(*x,y); return *x; }
1235 7 : GEN gmode(GEN *x, GEN y) { *x = gmod(*x,y); return *x; }
1236 7 : GEN gshiftle(GEN *x, long n) { *x = gshift(*x,n); return *x; }
1237 7 : GEN gshiftre(GEN *x, long n) { *x = gshift(*x,-n); return *x; }
1238 536517 : GEN gadde(GEN *x, GEN y) { *x = gadd(*x,y); return *x; }
1239 25685195 : GEN gadd1e(GEN *x) { *x = typ(*x)==t_INT?addiu(*x,1):gaddgs(*x,1); return *x; }
1240 15455370 : GEN gsube(GEN *x, GEN y) { *x = gsub(*x,y); return *x; }
1241 20965 : GEN gsub1e(GEN *x) { *x = typ(*x)==t_INT?subiu(*x,1):gsubgs(*x,1); return *x; }
1242 :
1243 1392 : GEN gshift_right(GEN x, long n) { return gshift(x,-n); }
|
