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 2782497 : insertep(entree *ep, entree **table, ulong hash)
124 : {
125 2782497 : ep->hash = hash;
126 2782497 : hash %= functions_tblsz;
127 2782497 : ep->next = table[hash];
128 2782497 : table[hash] = ep;
129 2782497 : }
130 :
131 : static entree *
132 36800 : initep(const char *name, long len)
133 : {
134 36800 : const long add = 4*sizeof(long);
135 36800 : entree *ep = (entree *) pari_calloc(sizeof(entree) + add + len+1);
136 36800 : entree *ep1 = initial_value(ep);
137 36800 : char *u = (char *) ep1 + add;
138 36800 : ep->name = u; memcpy(u, name,len); u[len]=0;
139 36800 : ep->valence = EpNEW;
140 36800 : ep->value = NULL;
141 36800 : ep->menu = 0;
142 36800 : ep->code = NULL;
143 36800 : ep->help = NULL;
144 36800 : ep->pvalue = NULL;
145 36800 : ep->arity = 0;
146 36800 : return ep;
147 : }
148 :
149 : /* Look for s of length len in T; if 'insert', insert if missing */
150 : static entree *
151 31644860 : findentry(const char *s, long len, entree **T, int insert)
152 : {
153 31644860 : ulong hash = hash_str_len(s, len);
154 : entree *ep;
155 344532098 : for (ep = T[hash % functions_tblsz]; ep; ep = ep->next)
156 344495374 : if (ep->hash == hash)
157 : {
158 31608178 : const char *t = ep->name;
159 31608178 : if (!strncmp(t, s, len) && !t[len]) return ep;
160 : }
161 : /* not found */
162 36724 : if (insert) { ep = initep(s,len); insertep(ep, T, hash); }
163 36724 : return ep;
164 : }
165 : entree *
166 980 : pari_is_default(const char *s)
167 980 : { return findentry(s, strlen(s), defaults_hash, 0); }
168 : entree *
169 9239193 : is_entry(const char *s)
170 9239193 : { return findentry(s, strlen(s), functions_hash, 0); }
171 : entree *
172 22404687 : fetch_entry_raw(const char *s, long len)
173 22404687 : { return findentry(s, len, functions_hash, 1); }
174 : entree *
175 454263 : 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 804235 : readseq_i(char *t)
184 : {
185 804235 : if (gp_meta(t,0)) return gnil;
186 804235 : return closure_evalres(pari_compile_str(t));
187 : }
188 : GEN
189 804235 : readseq(char *t)
190 804235 : { pari_sp av = avma; return gc_upto(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 gc_upto(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 2721180 : isreturn(char c)
218 2721180 : { 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 532471 : is_long(const char *s)
224 : {
225 532471 : while (isspace((unsigned char)*s)) s++;
226 532471 : if (*s == '+' || *s == '-') s++;
227 1068732 : while (isdigit((unsigned char)*s)) s++;
228 532471 : return *s == ',';
229 : }
230 : /* if is known that 2 commas follow s; base-10 unsigned integer followed
231 : * by comma? */
232 : static int
233 1895 : is_ulong(const char *s)
234 : {
235 1895 : while (isspace((unsigned char)*s)) s++;
236 1895 : if (*s == '+') s++;
237 3790 : while (isdigit((unsigned char)*s)) s++;
238 1895 : return *s == ',';
239 : }
240 : static long
241 2721180 : check_proto(const char *code)
242 : {
243 2721180 : long arity = 0;
244 2721180 : const char *s = code;
245 2721180 : if (isreturn(*s)) s++;
246 9272163 : while (*s && *s != '\n') switch (*s++)
247 : {
248 4792447 : 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 4792447 : arity++; break;
264 145915 : case 'E':
265 : case 's':
266 145915 : if (*s == '*') s++;
267 145915 : arity++; break;
268 1407961 : case 'D':
269 1407961 : switch(*s)
270 : {
271 828115 : case 'G': case '&': case 'n': case 'I': case 'E':
272 828115 : case 'P': case 's': case 'r': s++; arity++; break;
273 20845 : case 'V': s++; break;
274 0 : case 0:
275 0 : pari_err(e_SYNTAX,"function has incomplete prototype", s,code);
276 0 : break;
277 559001 : default:
278 : {
279 : const char *p;
280 : long i;
281 2836695 : for(i = 0, p = s; *p && i < 2; p++) i += *p==','; /* skip 2 commas */
282 559001 : if (i < 2) pari_err(e_SYNTAX,"missing comma",s,code);
283 559001 : arity++;
284 559001 : switch(p[-2])
285 : {
286 532471 : case 'L':
287 532471 : if (!is_long(s)) pari_err(e_SYNTAX,"not a long",s,code);
288 532471 : break;
289 1895 : case 'U':
290 1895 : if (!is_ulong(s)) pari_err(e_SYNTAX,"not an ulong",s,code);
291 1895 : break;
292 24635 : case 'G': case 'r': case 's': case 'M':
293 24635 : break;
294 0 : default: pari_err(e_SYNTAX,"incorrect type",s-2,code);
295 : }
296 559001 : s = p;
297 : }
298 : }
299 1407961 : break;
300 204660 : case 'V':
301 : case '=':
302 204660 : 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 2721180 : if (arity > 20) pari_err_IMPL("functions with more than 20 parameters");
310 2721180 : return arity;
311 : }
312 : static void
313 0 : check_name(const char *name)
314 : {
315 0 : const char *s = name;
316 0 : if (isalpha((unsigned char)*s))
317 0 : while (is_keyword_char(*++s)) /* empty */;
318 0 : if (*s) pari_err(e_SYNTAX,"not a valid identifier", s, name);
319 0 : }
320 :
321 : entree *
322 0 : install(void *f, const char *name, const char *code)
323 : {
324 0 : long arity = check_proto(code);
325 : entree *ep;
326 :
327 0 : check_name(name);
328 0 : ep = fetch_entry(name);
329 0 : 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 0 : ep->value = f;
339 0 : ep->valence = EpINSTALL;
340 : }
341 0 : ep->code = pari_strdup(code);
342 0 : ep->arity = arity; return ep;
343 : }
344 :
345 : static void
346 14 : killep(entree *ep)
347 : {
348 14 : GEN p = (GEN)initial_value(ep);
349 14 : freeep(ep);
350 14 : *p = 0; /* otherwise pari_var_create won't regenerate it */
351 14 : ep->valence = EpNEW;
352 14 : ep->value = NULL;
353 14 : ep->pvalue = NULL;
354 14 : }
355 : /* Kill ep, i.e free all memory it references, and reset to initial value */
356 : void
357 14 : kill0(const char *e)
358 : {
359 14 : entree *ep = is_entry(e);
360 14 : if (!ep || EpSTATIC(ep)) pari_err(e_MISC,"can't kill that");
361 14 : killep(ep);
362 14 : }
363 :
364 : void
365 42 : addhelp(const char *e, const char *s)
366 : {
367 42 : entree *ep = fetch_entry(e);
368 42 : void *f = (void *) ep->help;
369 42 : ep->help = pari_strdup(s);
370 42 : if (f && !EpSTATIC(ep)) pari_free(f);
371 42 : }
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 140374906 : ishex(const char **s)
390 : {
391 140374906 : if (**s == '0' && ((*s)[1] == 'x' || (*s)[1] == 'X' ))
392 : {
393 130 : *s += 2;
394 130 : return 1;
395 : }
396 : else
397 140374776 : return 0;
398 : }
399 :
400 : static int
401 140374962 : isbin(const char **s)
402 : {
403 140374962 : if (**s == '0' && ((*s)[1] == 'b' || (*s)[1] == 'B' ))
404 : {
405 56 : *s += 2;
406 56 : return 1;
407 : }
408 : else
409 140374906 : 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 4140048 : dec_number_len(const char *s, long B)
482 : {
483 4140048 : ulong m = 0;
484 : long n;
485 62396631 : for (n = 0; n < B; n++,s++)
486 58256583 : m = 10*m + (*s - '0');
487 4140048 : return m;
488 : }
489 :
490 : static GEN
491 1042580 : dec_strtoi_len(const char *s, long n)
492 : {
493 1042580 : const long B = MAX_DIGITS;
494 1042580 : long i, l = (n+B-1)/B;
495 1042580 : GEN V = cgetg(l+1, t_VECSMALL);
496 4140048 : for (i=1; i<l; i++)
497 3097468 : uel(V,i) = dec_number_len(s+n-i*B, B);
498 1042580 : uel(V, i) = dec_number_len(s, n-(i-1)*B);
499 1042580 : return fromdigitsu(V, powuu(10, B));
500 : }
501 :
502 : static GEN
503 1042580 : dec_read_more(const char **ps)
504 : {
505 1042580 : pari_sp av = avma;
506 1042580 : const char *s = *ps;
507 59299163 : while (isdigit((unsigned char)**ps)) (*ps)++;
508 1042580 : return gc_INT(av, dec_strtoi_len(s, *ps-s));
509 : }
510 :
511 : static ulong
512 31718742 : number(int *n, const char **s)
513 : {
514 31718742 : ulong m = 0;
515 128196372 : for (*n = 0; *n < MAX_DIGITS && isdigit((unsigned char)**s); (*n)++,(*s)++)
516 96477630 : m = 10*m + (**s - '0');
517 31718742 : return m;
518 : }
519 :
520 : static GEN
521 31643177 : dec_read(const char **s)
522 : {
523 : int nb;
524 31643177 : ulong y = number(&nb, s);
525 31643177 : if (nb < MAX_DIGITS)
526 30600597 : return utoi(y);
527 1042580 : *s -= MAX_DIGITS;
528 1042580 : return dec_read_more(s);
529 : }
530 :
531 : static GEN
532 5690 : real_read_more(GEN y, const char **ps)
533 : {
534 5690 : pari_sp av = avma;
535 5690 : const char *s = *ps;
536 5690 : GEN z = dec_read(ps);
537 5690 : long e = *ps-s;
538 5690 : return gc_INT(av, addmulii(z, powuu(10, e), y));
539 : }
540 :
541 : static long
542 75565 : exponent(const char **pts)
543 : {
544 75565 : const char *s = *pts;
545 : long n;
546 : int nb;
547 75565 : switch(*++s)
548 : {
549 75383 : case '-': s++; n = -(long)number(&nb, &s); break;
550 0 : case '+': s++; /* Fall through */
551 182 : default: n = (long)number(&nb, &s);
552 : }
553 75565 : *pts = s; return n;
554 : }
555 :
556 : static GEN
557 203 : real_0_digits(long n) {
558 203 : long b = (n > 0)? (long)(n/LOG10_2): (long)-((-n)/LOG10_2 + 1);
559 203 : return real_0_bit(b);
560 : }
561 :
562 : static GEN
563 86710 : real_read(pari_sp av, const char **s, GEN y, long prec)
564 : {
565 86710 : long l, n = 0;
566 86710 : switch(**s)
567 : {
568 0 : default: return y; /* integer */
569 12510 : case '.':
570 : {
571 12510 : const char *old = ++*s;
572 12510 : if (isalpha((unsigned char)**s) || **s=='.')
573 : {
574 1344 : if (**s == 'E' || **s == 'e') {
575 1344 : n = exponent(s);
576 1344 : if (!signe(y)) { set_avma(av); return real_0_digits(n); }
577 1288 : break;
578 : }
579 0 : --*s; return y; /* member */
580 : }
581 11166 : if (isdigit((unsigned char)**s)) y = real_read_more(y, s);
582 11166 : n = old - *s;
583 11166 : if (**s != 'E' && **s != 'e')
584 : {
585 11145 : if (!signe(y)) { set_avma(av); return real_0(prec); }
586 9878 : break;
587 : }
588 : }
589 : /* Fall through */
590 : case 'E': case 'e':
591 74221 : n += exponent(s);
592 74221 : if (!signe(y)) { set_avma(av); return real_0_digits(n); }
593 : }
594 85240 : l = nbits2prec(bit_accuracy(lgefint(y)));
595 85240 : if (l < prec) l = prec; else prec = l;
596 85240 : if (!n) return itor(y, prec);
597 80324 : incrprec(l);
598 80324 : y = itor(y, l);
599 80324 : if (n > 0)
600 84 : y = mulrr(y, rpowuu(10UL, (ulong)n, l));
601 : else
602 80240 : y = divrr(y, rpowuu(10UL, (ulong)-n, l));
603 80324 : return gc_leaf(av, rtor(y, prec));
604 : }
605 :
606 : static GEN
607 31550879 : int_read(const char **s)
608 : {
609 : GEN y;
610 31550879 : if (isbin(s))
611 28 : y = bin_read(s);
612 31550851 : else if (ishex(s))
613 74 : y = hex_read(s);
614 : else
615 31550777 : y = dec_read(s);
616 31550879 : return y;
617 : }
618 :
619 : GEN
620 31550879 : strtoi(const char *s) { return int_read(&s); }
621 :
622 : GEN
623 86710 : strtor(const char *s, long prec)
624 : {
625 86710 : pari_sp av = avma;
626 86710 : GEN y = dec_read(&s);
627 86710 : y = real_read(av, &s, y, prec);
628 86710 : if (typ(y) == t_REAL) return y;
629 0 : return gc_leaf(av, itor(y, prec));
630 : }
631 :
632 : static void
633 31543719 : skipdigits(char **lex) {
634 168462116 : while (isdigit((unsigned char)**lex)) ++*lex;
635 31543719 : }
636 :
637 : static int
638 31535645 : skipexponent(char **lex)
639 : {
640 31535645 : char *old=*lex;
641 31535645 : if ((**lex=='e' || **lex=='E'))
642 : {
643 1155 : ++*lex;
644 1155 : if ( **lex=='+' || **lex=='-' ) ++*lex;
645 1155 : if (!isdigit((unsigned char)**lex))
646 : {
647 469 : *lex=old;
648 469 : return KINTEGER;
649 : }
650 686 : skipdigits(lex);
651 686 : return KREAL;
652 : }
653 31534490 : return KINTEGER;
654 : }
655 :
656 : static int
657 31537401 : skipconstante(char **lex)
658 : {
659 31537401 : skipdigits(lex);
660 31537401 : if (**lex=='.')
661 : {
662 20212 : char *old = ++*lex;
663 20212 : if (**lex == '.') { --*lex; return KINTEGER; }
664 18456 : if (isalpha((unsigned char)**lex))
665 : {
666 12824 : skipexponent(lex);
667 12824 : if (*lex == old)
668 : {
669 12656 : --*lex; /* member */
670 12656 : return KINTEGER;
671 : }
672 168 : return KREAL;
673 : }
674 5632 : skipdigits(lex);
675 5632 : skipexponent(lex);
676 5632 : return KREAL;
677 : }
678 31517189 : return skipexponent(lex);
679 : }
680 :
681 : static void
682 3822335 : skipstring(char **lex)
683 : {
684 30148521 : while (**lex)
685 : {
686 30149169 : while (**lex == '\\') *lex+=2;
687 30148521 : if (**lex == '"')
688 : {
689 3822335 : if ((*lex)[1] != '"') break;
690 0 : *lex += 2; continue;
691 : }
692 26326186 : (*lex)++;
693 : }
694 3822335 : }
695 :
696 : int
697 114191039 : pari_lex(union token_value *yylval, struct node_loc *yylloc, char **lex)
698 : {
699 : (void) yylval;
700 114191039 : yylloc->start=*lex;
701 114191039 : if (!**lex)
702 : {
703 937517 : yylloc->end=*lex;
704 937517 : return 0;
705 : }
706 113253522 : if (isalpha((unsigned char)**lex))
707 : {
708 2649818 : while (is_keyword_char(**lex)) ++*lex;
709 592643 : yylloc->end=*lex;
710 592643 : return KENTRY;
711 : }
712 112660879 : if (**lex=='"')
713 : {
714 3822335 : ++*lex;
715 3822335 : skipstring(lex);
716 3822335 : if (!**lex)
717 0 : compile_err("run-away string",*lex-1);
718 3822335 : ++*lex;
719 3822335 : yylloc->end=*lex;
720 3822335 : return KSTRING;
721 : }
722 108838544 : if (**lex == '.')
723 : {
724 : int token;
725 14461 : if ((*lex)[1]== '.')
726 : {
727 1784 : *lex+=2; yylloc->end = *lex; return KDOTDOT;
728 : }
729 12677 : token=skipconstante(lex);
730 12677 : if (token==KREAL)
731 : {
732 21 : yylloc->end = *lex;
733 21 : return token;
734 : }
735 12656 : ++*lex;
736 12656 : yylloc->end=*lex;
737 12656 : return '.';
738 : }
739 108824083 : 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 108824055 : 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 108823999 : if (isdigit((unsigned char)**lex))
752 : {
753 31524724 : int token=skipconstante(lex);
754 31524724 : yylloc->end = *lex;
755 31524724 : return token;
756 : }
757 77299275 : if ((*lex)[1]=='=')
758 30601 : switch (**lex)
759 : {
760 12076 : case '=':
761 12076 : if ((*lex)[2]=='=')
762 343 : { *lex+=3; yylloc->end = *lex; return KID; }
763 : else
764 11733 : { *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 2303 : case '!':
777 2303 : if ((*lex)[2]=='=') break;
778 2303 : *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 77283998 : if (**lex==')' && (*lex)[1]=='-' && (*lex)[2]=='>')
787 : {
788 4121 : *lex+=3; yylloc->end = *lex; return KPARROW;
789 : }
790 77279877 : if (**lex=='-' && (*lex)[1]=='>')
791 : {
792 1409 : *lex+=2; yylloc->end = *lex; return KARROW;
793 : }
794 77278468 : if (**lex=='<' && (*lex)[1]=='>')
795 : {
796 0 : *lex+=2; yylloc->end = *lex; return KNE;
797 : }
798 77278468 : 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 77278433 : if ((*lex)[1]==**lex)
807 8999398 : switch (**lex)
808 : {
809 812 : case '&':
810 812 : *lex+=2; yylloc->end = *lex; return KAND;
811 462 : case '|':
812 462 : *lex+=2; yylloc->end = *lex; return KOR;
813 190 : case '+':
814 190 : *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 77276759 : yylloc->end = *lex+1;
826 77276759 : 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 523432 : varstate_save(struct pari_varstate *s)
841 : {
842 523432 : s->nvar = nvar;
843 523432 : s->max_avail = max_avail;
844 523432 : s->max_priority = max_priority;
845 523432 : s->min_priority = min_priority;
846 523432 : }
847 :
848 : static void
849 9494 : varentries_set(long v, entree *ep)
850 : {
851 9494 : hash_insert(h_polvar, (void*)ep->name, (void*)v);
852 9494 : varentries[v] = ep;
853 9494 : }
854 : static int
855 3010 : _given_value(void *E, hashentry *e) { return e->val == E; }
856 :
857 : static void
858 3177 : varentries_unset(long v)
859 : {
860 3177 : entree *ep = varentries[v];
861 3177 : 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 3177 : }
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 389818 : var_restore(struct pari_varstate *s)
887 : {
888 389818 : nvar = s->nvar;
889 389818 : max_avail = s->max_avail;
890 389818 : max_priority = s->max_priority;
891 389818 : min_priority = s->min_priority;
892 389818 : }
893 :
894 : void
895 13165 : varstate_restore(struct pari_varstate *s)
896 : {
897 : long i;
898 16175 : for (i = nvar-1; i >= s->nvar; i--)
899 : {
900 3010 : varentries_unset(i);
901 3010 : varpriority[i] = -i;
902 : }
903 13214 : for (i = max_avail+1; i <= s->max_avail; i++)
904 : {
905 49 : varentries_unset(i);
906 49 : varpriority[i] = -i;
907 : }
908 13165 : var_restore(s);
909 13165 : }
910 :
911 : void
912 376653 : pari_set_varstate(long *vp, struct pari_varstate *vs)
913 : {
914 376653 : var_restore(vs);
915 376653 : varpriority = (long*)newblock(MAXVARN+2) + 1;
916 376653 : memcpy(varpriority-1,vp-1,(MAXVARN+2)*sizeof(long));
917 376653 : }
918 :
919 : /* must come before destruction of functions_hash */
920 : void
921 1887 : pari_var_close(void)
922 : {
923 1887 : GEN h = hash_values(h_polvar);
924 1887 : long i, l = lg(h);
925 8355 : for (i = 1; i < l; i++)
926 : {
927 6468 : long v = h[i];
928 6468 : entree *ep = varentries[v];
929 6468 : if (ep && ep != is_entry(ep->name)) pari_free(ep);
930 : }
931 1887 : free((void*)varentries);
932 1887 : free((void*)(varpriority-1));
933 1887 : hash_destroy(h_polvar);
934 1887 : }
935 :
936 : void
937 1895 : pari_var_init(void)
938 : {
939 : long i;
940 1895 : varentries = (entree**) pari_calloc((MAXVARN+1)*sizeof(entree*));
941 1895 : varpriority = (long*)pari_malloc((MAXVARN+2)*sizeof(long)) + 1;
942 1895 : varpriority[-1] = 1-LONG_MAX;
943 1895 : h_polvar = hash_create_str(100, 0);
944 1895 : nvar = 0; max_avail = MAXVARN;
945 1895 : max_priority = min_priority = 0;
946 1895 : (void)fetch_user_var("x");
947 1895 : (void)fetch_user_var("y");
948 : /* initialize so that people can use pol_x(i) directly */
949 111163545 : for (i = 2; i <= (long)MAXVARN; i++) varpriority[i] = -i;
950 : /* reserve varnum 1..9 for static temps with predictable priority wrt x */
951 1895 : nvar = 10;
952 1895 : min_priority = -MAXVARN;
953 1895 : }
954 : long
955 4 : pari_var_next(void) { return nvar; }
956 : long
957 0 : pari_var_next_temp(void) { return max_avail; }
958 : long
959 485783 : pari_var_create(entree *ep)
960 : {
961 485783 : GEN p = (GEN)initial_value(ep);
962 : long v;
963 485783 : if (*p) return varn(p);
964 9376 : if (mt_is_thread())
965 0 : pari_err(e_MISC,"mt: attempt to create new variable '%s'",ep->name);
966 9376 : if (nvar == max_avail) pari_err(e_MISC,"no more variables available");
967 9376 : v = nvar++;
968 : /* set p = pol_x(v) */
969 9376 : p[0] = evaltyp(t_POL) | _evallg(4);
970 9376 : p[1] = evalsigne(1) | evalvarn(v);
971 9376 : gel(p,2) = gen_0;
972 9376 : gel(p,3) = gen_1;
973 9376 : varentries_set(v, ep);
974 9376 : varpriority[v]= min_priority--;
975 9376 : return v;
976 : }
977 :
978 : long
979 8492497 : delete_var(void)
980 : { /* user wants to delete one of his/her/its variables */
981 8492497 : if (max_avail == MAXVARN) return 0; /* nothing to delete */
982 8491853 : max_avail++;
983 8491853 : if (varpriority[max_avail] == min_priority) min_priority++;
984 8491853 : else if (varpriority[max_avail] == max_priority) max_priority--;
985 8491853 : return max_avail+1;
986 : }
987 : long
988 67748 : fetch_var(void)
989 : {
990 67748 : if (nvar == max_avail) pari_err(e_MISC,"no more variables available");
991 67748 : varpriority[max_avail] = min_priority--;
992 67748 : return max_avail--;
993 : }
994 : long
995 8424706 : fetch_var_higher(void)
996 : {
997 8424706 : if (nvar == max_avail) pari_err(e_MISC,"no more variables available");
998 8424706 : varpriority[max_avail] = ++max_priority;
999 8424706 : return max_avail--;
1000 : }
1001 :
1002 : static int
1003 49 : _higher(void *E, hashentry *e)
1004 49 : { long v = (long)e->val; return (varncmp(v, (long)E) < 0); }
1005 : static int
1006 42 : _lower(void *E, hashentry *e)
1007 42 : { long v = (long)e->val; return (varncmp(v, (long)E) > 0); }
1008 :
1009 : static GEN
1010 118 : var_register(long v, const char *s)
1011 : {
1012 118 : varentries_reset(v, initep(s, strlen(s)));
1013 118 : return pol_x(v);
1014 : }
1015 : GEN
1016 105 : varhigher(const char *s, long w)
1017 : {
1018 : long v;
1019 105 : if (w >= 0)
1020 : {
1021 56 : hashentry *e = hash_select(h_polvar, (void*)s, (void*)w, _higher);
1022 56 : if (e) return pol_x((long)e->val);
1023 : }
1024 : /* no luck: need to create */
1025 91 : if (nvar == max_avail) pari_err(e_MISC,"no more variables available");
1026 91 : v = nvar++;
1027 91 : varpriority[v]= ++max_priority;
1028 91 : return var_register(v, s);
1029 : }
1030 : GEN
1031 34 : varlower(const char *s, long w)
1032 : {
1033 : long v;
1034 34 : if (w >= 0)
1035 : {
1036 21 : hashentry *e = hash_select(h_polvar, (void*)s, (void*)w, _lower);
1037 21 : if (e) return pol_x((long)e->val);
1038 : }
1039 : /* no luck: need to create */
1040 27 : v = fetch_var();
1041 27 : return var_register(v, s);
1042 : }
1043 :
1044 : long
1045 454165 : fetch_user_var(const char *s)
1046 : {
1047 454165 : entree *ep = fetch_entry(s);
1048 : long v;
1049 454165 : switch (EpVALENCE(ep))
1050 : {
1051 450158 : case EpVAR: return pari_var_create(ep);
1052 4007 : case EpNEW: break;
1053 0 : default: pari_err(e_MISC, "%s already exists with incompatible valence", s);
1054 : }
1055 4007 : v = pari_var_create(ep);
1056 4007 : ep->valence = EpVAR;
1057 4007 : ep->value = initial_value(ep);
1058 4007 : return v;
1059 : }
1060 :
1061 : GEN
1062 7 : fetch_var_value(long v, GEN t)
1063 : {
1064 7 : entree *ep = varentries[v];
1065 7 : if (!ep) return NULL;
1066 7 : if (t)
1067 : {
1068 7 : long vn = localvars_find(t,ep);
1069 7 : if (vn) return get_lex(vn);
1070 : }
1071 7 : return (GEN)ep->value;
1072 : }
1073 :
1074 : void
1075 0 : name_var(long n, const char *s)
1076 : {
1077 : entree *ep;
1078 : char *u;
1079 :
1080 0 : if (n < pari_var_next())
1081 0 : pari_err(e_MISC, "renaming a GP variable is forbidden");
1082 0 : if (n > (long)MAXVARN)
1083 0 : pari_err_OVERFLOW("variable number");
1084 :
1085 0 : ep = (entree*)pari_malloc(sizeof(entree) + strlen(s) + 1);
1086 0 : u = (char *)initial_value(ep);
1087 0 : ep->valence = EpVAR;
1088 0 : ep->name = u; strcpy(u,s);
1089 0 : ep->value = gen_0; /* in case geval is called */
1090 0 : varentries_reset(n, ep);
1091 0 : }
1092 :
1093 : static int
1094 5199 : cmp_by_var(void *E,GEN x, GEN y)
1095 5199 : { (void)E; return varncmp((long)x,(long)y); }
1096 : GEN
1097 1484 : vars_sort_inplace(GEN z)
1098 1484 : { gen_sort_inplace(z,NULL,cmp_by_var,NULL); return z; }
1099 : GEN
1100 231 : vars_to_RgXV(GEN h)
1101 : {
1102 231 : long i, l = lg(h);
1103 231 : GEN z = cgetg(l, t_VEC);
1104 2247 : for (i = 1; i < l; i++) gel(z,i) = pol_x(h[i]);
1105 231 : return z;
1106 : }
1107 : GEN
1108 4655 : gpolvar(GEN x)
1109 : {
1110 : long v;
1111 4655 : if (!x) {
1112 140 : GEN h = hash_values(h_polvar);
1113 140 : return vars_to_RgXV(vars_sort_inplace(h));
1114 : }
1115 4515 : if (typ(x)==t_PADIC) return icopy(padic_p(x));
1116 4508 : v = gvar(x);
1117 4508 : if (v==NO_VARIABLE) return gen_0;
1118 4452 : return pol_x(v);
1119 : }
1120 :
1121 : static void
1122 2745815 : fill_hashtable_single(entree **table, entree *ep)
1123 : {
1124 2745815 : EpSETSTATIC(ep);
1125 2745815 : insertep(ep, table, hash_str(ep->name));
1126 2745815 : if (ep->code) ep->arity = check_proto(ep->code);
1127 2745815 : ep->pvalue = NULL;
1128 2745815 : }
1129 :
1130 : void
1131 5677 : pari_fill_hashtable(entree **table, entree *ep)
1132 : {
1133 2751492 : for ( ; ep->name; ep++) fill_hashtable_single(table, ep);
1134 5677 : }
1135 :
1136 : void
1137 0 : pari_add_function(entree *ep)
1138 : {
1139 0 : fill_hashtable_single(functions_hash, ep);
1140 0 : }
1141 :
1142 : /********************************************************************/
1143 : /** **/
1144 : /** SIMPLE GP FUNCTIONS **/
1145 : /** **/
1146 : /********************************************************************/
1147 :
1148 : GEN
1149 28 : arity0(GEN C)
1150 : {
1151 28 : if (typ(C)!=t_CLOSURE) pari_err_TYPE("arity", C);
1152 28 : return utoi(closure_arity(C));
1153 : }
1154 :
1155 : #define ALIAS(ep) (entree *) ((GEN)ep->value)[1]
1156 :
1157 : entree *
1158 21989979 : do_alias(entree *ep)
1159 : {
1160 21990035 : while (ep->valence == EpALIAS) ep = ALIAS(ep);
1161 21989979 : return ep;
1162 : }
1163 :
1164 : void
1165 28 : alias0(const char *s, const char *old)
1166 : {
1167 : entree *ep, *e;
1168 : GEN x;
1169 :
1170 28 : ep = fetch_entry(old);
1171 28 : e = fetch_entry(s);
1172 28 : if (EpVALENCE(e) != EpALIAS && EpVALENCE(e) != EpNEW)
1173 0 : pari_err(e_MISC,"can't replace an existing symbol by an alias");
1174 28 : freeep(e);
1175 28 : x = cgetg_block(2, t_VECSMALL); gel(x,1) = (GEN)ep;
1176 28 : e->value=x; e->valence=EpALIAS;
1177 28 : }
1178 :
1179 : GEN
1180 13122946 : ifpari(GEN g, GEN a/*closure*/, GEN b/*closure*/)
1181 : {
1182 13122946 : if (gequal0(g)) /* false */
1183 10095853 : return b? closure_evalgen(b): gnil;
1184 : else /* true */
1185 3027093 : return a? closure_evalgen(a): gnil;
1186 : }
1187 :
1188 : void
1189 42401688 : ifpari_void(GEN g, GEN a/*closure*/, GEN b/*closure*/)
1190 : {
1191 42401688 : if (gequal0(g)) /* false */
1192 41140419 : { if (b) closure_evalvoid(b); }
1193 : else /* true */
1194 1261269 : { if (a) closure_evalvoid(a); }
1195 42401667 : }
1196 :
1197 : GEN
1198 30723 : ifpari_multi(GEN g, GEN a/*closure*/)
1199 : {
1200 30723 : long i, nb = lg(a)-1;
1201 30723 : if (!gequal0(g)) /* false */
1202 6713 : return closure_evalgen(gel(a,1));
1203 41496 : for(i=2;i<nb;i+=2)
1204 : {
1205 24122 : GEN g = closure_evalgen(gel(a,i));
1206 24122 : if (!g) return g;
1207 24115 : if (!gequal0(g))
1208 6629 : return closure_evalgen(gel(a,i+1));
1209 : }
1210 17374 : return i<=nb? closure_evalgen(gel(a,i)): gnil;
1211 : }
1212 :
1213 : GEN
1214 64287664 : andpari(GEN a, GEN b/*closure*/)
1215 : {
1216 : GEN g;
1217 64287664 : if (gequal0(a))
1218 53970344 : return gen_0;
1219 10317320 : g=closure_evalgen(b);
1220 10317320 : if (!g) return g;
1221 10317320 : return gequal0(g)?gen_0:gen_1;
1222 : }
1223 :
1224 : GEN
1225 16723997 : orpari(GEN a, GEN b/*closure*/)
1226 : {
1227 : GEN g;
1228 16723997 : if (!gequal0(a))
1229 338407 : return gen_1;
1230 16385590 : g=closure_evalgen(b);
1231 16385590 : if (!g) return g;
1232 16385590 : return gequal0(g)?gen_0:gen_1;
1233 : }
1234 :
1235 : GEN
1236 178685 : gmule(GEN *x, GEN y) { *x = gmul(*x,y); return *x; }
1237 : GEN
1238 56 : gdive(GEN *x, GEN y) { *x = gdiv(*x,y); return *x; }
1239 : GEN
1240 7 : gdivente(GEN *x, GEN y) { *x = gdivent(*x,y); return *x; }
1241 : GEN
1242 7 : gdivrounde(GEN *x, GEN y) { *x = gdivround(*x,y); return *x; }
1243 : GEN
1244 7 : gmode(GEN *x, GEN y) { *x = gmod(*x,y); return *x; }
1245 : GEN
1246 7 : gshiftle(GEN *x, long n) { *x = gshift(*x,n); return *x; }
1247 : GEN
1248 7 : gshiftre(GEN *x, long n) { *x = gshift(*x,-n); return *x; }
1249 : GEN
1250 536517 : gadde(GEN *x, GEN y) { *x = gadd(*x,y); return *x; }
1251 : GEN
1252 25685202 : gadd1e(GEN *x) { *x = typ(*x)==t_INT?addiu(*x,1):gaddgs(*x,1); return *x; }
1253 : GEN
1254 15455370 : gsube(GEN *x, GEN y) { *x = gsub(*x,y); return *x; }
1255 : GEN
1256 20965 : gsub1e(GEN *x) { *x = typ(*x)==t_INT?subiu(*x,1):gsubgs(*x,1); return *x; }
1257 :
1258 : GEN
1259 1392 : gshift_right(GEN x, long n) { return gshift(x,-n); }
|
