Line data Source code
1 : /* Copyright (C) 2006 The PARI group.
2 :
3 : This file is part of the PARI 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 "opcode.h"
19 :
20 : /********************************************************************/
21 : /* */
22 : /* break/next/return handling */
23 : /* */
24 : /********************************************************************/
25 :
26 : static THREAD long br_status, br_count;
27 : static THREAD GEN br_res;
28 :
29 : long
30 114261028 : loop_break(void)
31 : {
32 114261028 : switch(br_status)
33 : {
34 21 : case br_MULTINEXT :
35 21 : if (! --br_count) br_status = br_NEXT;
36 21 : return 1;
37 70302 : case br_BREAK : if (! --br_count) br_status = br_NONE; /* fall through */
38 78931 : case br_RETURN: return 1;
39 25125 : case br_NEXT: br_status = br_NONE; /* fall through */
40 : }
41 114182076 : return 0;
42 : }
43 :
44 : static void
45 98533 : reset_break(void)
46 : {
47 98533 : br_status = br_NONE;
48 98533 : if (br_res) { gunclone_deep(br_res); br_res = NULL; }
49 98533 : }
50 :
51 : GEN
52 40898 : return0(GEN x)
53 : {
54 40898 : GEN y = br_res;
55 40898 : br_res = (x && x != gnil)? gcloneref(x): NULL;
56 40898 : guncloneNULL_deep(y);
57 40898 : br_status = br_RETURN; return NULL;
58 : }
59 :
60 : GEN
61 25853 : next0(long n)
62 : {
63 25853 : if (n < 1) pari_err_DOMAIN("next", "n", "<", gen_1, stoi(n));
64 25846 : if (n == 1) br_status = br_NEXT;
65 : else
66 : {
67 14 : br_count = n-1;
68 14 : br_status = br_MULTINEXT;
69 : }
70 25846 : return NULL;
71 : }
72 :
73 : GEN
74 70358 : break0(long n)
75 : {
76 70358 : if (n < 1) pari_err_DOMAIN("break", "n", "<", gen_1, stoi(n));
77 70351 : br_count = n;
78 70351 : br_status = br_BREAK; return NULL;
79 : }
80 :
81 : /*******************************************************************/
82 : /* */
83 : /* VARIABLES */
84 : /* */
85 : /*******************************************************************/
86 :
87 : /* As a rule, ep->value is a clone (COPY). push_val and pop_val are private
88 : * functions for use in sumiter: we want a temporary ep->value, which is NOT
89 : * a clone (PUSH), to avoid unnecessary copies. */
90 :
91 : enum {PUSH_VAL = 0, COPY_VAL = 1, DEFAULT_VAL = 2, REF_VAL = 3};
92 :
93 : /* ep->args is the stack of old values (INITIAL if initial value, from
94 : * installep) */
95 : typedef struct var_cell {
96 : struct var_cell *prev; /* cell attached to previous value on stack */
97 : GEN value; /* last value (not including current one, in ep->value) */
98 : char flag; /* status of _current_ ep->value: PUSH or COPY ? */
99 : long valence; /* valence of entree* attached to 'value', to be restored
100 : * by pop_val */
101 : } var_cell;
102 : #define INITIAL NULL
103 :
104 : /* Push x on value stack attached to ep. */
105 : static void
106 19464 : new_val_cell(entree *ep, GEN x, char flag)
107 : {
108 19464 : var_cell *v = (var_cell*) pari_malloc(sizeof(var_cell));
109 19464 : v->value = (GEN)ep->value;
110 19464 : v->prev = (var_cell*) ep->pvalue;
111 19464 : v->flag = flag;
112 19464 : v->valence= ep->valence;
113 :
114 : /* beware: f(p) = Nv = 0
115 : * Nv = p; f(Nv) --> this call would destroy p [ isclone ] */
116 19464 : ep->value = (flag == COPY_VAL)? gclone(x):
117 0 : (x && isclone(x))? gcopy(x): x;
118 : /* Do this last. In case the clone is <C-C>'ed before completion ! */
119 19464 : ep->pvalue= (char*)v;
120 19464 : ep->valence=EpVAR;
121 19464 : }
122 :
123 : /* kill ep->value and replace by preceding one, poped from value stack */
124 : static void
125 19016 : pop_val(entree *ep)
126 : {
127 19016 : var_cell *v = (var_cell*) ep->pvalue;
128 19016 : if (v != INITIAL)
129 : {
130 19016 : GEN old_val = (GEN) ep->value; /* protect against SIGINT */
131 19016 : ep->value = v->value;
132 19016 : if (v->flag == COPY_VAL) gunclone_deep(old_val);
133 19016 : ep->pvalue = (char*) v->prev;
134 19016 : ep->valence=v->valence;
135 19016 : pari_free((void*)v);
136 : }
137 19016 : }
138 :
139 : void
140 36708 : freeep(entree *ep)
141 : {
142 36708 : if (EpSTATIC(ep)) return; /* gp function loaded at init time */
143 36708 : if (ep->help) {pari_free((void*)ep->help); ep->help=NULL;}
144 36708 : if (ep->code) {pari_free((void*)ep->code); ep->code=NULL;}
145 36708 : switch(EpVALENCE(ep))
146 : {
147 24433 : case EpVAR:
148 43393 : while (ep->pvalue!=INITIAL) pop_val(ep);
149 24433 : break;
150 28 : case EpALIAS:
151 28 : killblock((GEN)ep->value); ep->value=NULL; break;
152 : }
153 : }
154 :
155 : INLINE void
156 42 : pushvalue(entree *ep, GEN x) {
157 42 : new_val_cell(ep, x, COPY_VAL);
158 42 : }
159 :
160 : INLINE void
161 14 : zerovalue(entree *ep)
162 : {
163 14 : var_cell *v = (var_cell*) pari_malloc(sizeof(var_cell));
164 14 : v->value = (GEN)ep->value;
165 14 : v->prev = (var_cell*) ep->pvalue;
166 14 : v->flag = COPY_VAL;
167 14 : v->valence= ep->valence;
168 14 : ep->value = gen_0;
169 14 : ep->pvalue= (char*)v;
170 14 : ep->valence=EpVAR;
171 14 : }
172 :
173 : /* as above IF ep->value was PUSHed, or was created after block number 'loc'
174 : return 0 if not deleted, 1 otherwise [for recover()] */
175 : int
176 426373 : pop_val_if_newer(entree *ep, long loc)
177 : {
178 426373 : var_cell *v = (var_cell*) ep->pvalue;
179 :
180 426373 : if (v == INITIAL) return 0;
181 391033 : if (v->flag == COPY_VAL && !pop_entree_block(ep, loc)) return 0;
182 462 : ep->value = v->value;
183 462 : ep->pvalue= (char*) v->prev;
184 462 : ep->valence=v->valence;
185 462 : pari_free((void*)v); return 1;
186 : }
187 :
188 : /* set new value of ep directly to val (COPY), do not save last value unless
189 : * it's INITIAL. */
190 : void
191 29491317 : changevalue(entree *ep, GEN x)
192 : {
193 29491317 : var_cell *v = (var_cell*) ep->pvalue;
194 29491317 : if (v == INITIAL) new_val_cell(ep, x, COPY_VAL);
195 : else
196 : {
197 29471895 : GEN old_val = (GEN) ep->value; /* beware: gunclone_deep may destroy old x */
198 29471895 : ep->value = (void *) gclone(x);
199 29471895 : if (v->flag == COPY_VAL) gunclone_deep(old_val); else v->flag = COPY_VAL;
200 : }
201 29491317 : }
202 :
203 : INLINE GEN
204 746851 : copyvalue(entree *ep)
205 : {
206 746851 : var_cell *v = (var_cell*) ep->pvalue;
207 746851 : if (v && v->flag != COPY_VAL)
208 : {
209 0 : ep->value = (void*) gclone((GEN)ep->value);
210 0 : v->flag = COPY_VAL;
211 : }
212 746851 : return (GEN) ep->value;
213 : }
214 :
215 : INLINE void
216 0 : err_var(GEN x) { pari_err_TYPE("evaluator [variable name expected]", x); }
217 :
218 : enum chk_VALUE { chk_ERROR, chk_NOCREATE, chk_CREATE };
219 :
220 : INLINE void
221 123986539 : checkvalue(entree *ep, enum chk_VALUE flag)
222 : {
223 123986539 : if (mt_is_thread())
224 27 : pari_err(e_MISC,"mt: attempt to change exported variable '%s'",ep->name);
225 123986512 : if (ep->valence==EpNEW)
226 23851 : switch(flag)
227 : {
228 4745 : case chk_ERROR:
229 : /* Do nothing until we can report a meaningful error message
230 : The extra variable will be cleaned-up anyway */
231 : case chk_CREATE:
232 4745 : pari_var_create(ep);
233 4745 : ep->valence = EpVAR;
234 4745 : ep->value = initial_value(ep);
235 4745 : break;
236 19106 : case chk_NOCREATE:
237 19106 : break;
238 : }
239 123962661 : else if (ep->valence!=EpVAR)
240 0 : pari_err(e_MISC, "attempt to change built-in %s", ep->name);
241 123986512 : }
242 :
243 : INLINE GEN
244 23308355 : checkvalueptr(entree *ep)
245 : {
246 23308355 : checkvalue(ep, chk_NOCREATE);
247 23308355 : return ep->valence==EpNEW? gen_0: (GEN)ep->value;
248 : }
249 :
250 : /* make GP variables safe for set_avma(top) */
251 : static void
252 0 : lvar_make_safe(void)
253 : {
254 : long n;
255 : entree *ep;
256 0 : for (n = 0; n < functions_tblsz; n++)
257 0 : for (ep = functions_hash[n]; ep; ep = ep->next)
258 0 : if (EpVALENCE(ep) == EpVAR)
259 : { /* make sure ep->value is a COPY */
260 0 : var_cell *v = (var_cell*)ep->pvalue;
261 0 : if (v && v->flag == PUSH_VAL) {
262 0 : GEN x = (GEN)ep->value;
263 0 : if (x) changevalue(ep, (GEN)ep->value); else pop_val(ep);
264 : }
265 : }
266 0 : }
267 :
268 : static void
269 107083370 : check_array_index(long c, long l)
270 : {
271 107083370 : if (c < 1) pari_err_COMPONENT("", "<", gen_1, stoi(c));
272 107083363 : if (c >= l) pari_err_COMPONENT("", ">", stoi(l-1), stoi(c));
273 107083321 : }
274 :
275 : GEN*
276 0 : safegel(GEN x, long l)
277 : {
278 0 : if (!is_matvec_t(typ(x)))
279 0 : pari_err_TYPE("safegel",x);
280 0 : check_array_index(l, lg(x));
281 0 : return &(gel(x,l));
282 : }
283 :
284 : GEN*
285 0 : safelistel(GEN x, long l)
286 : {
287 : GEN d;
288 0 : if (typ(x)!=t_LIST || list_typ(x)!=t_LIST_RAW)
289 0 : pari_err_TYPE("safelistel",x);
290 0 : d = list_data(x);
291 0 : check_array_index(l, lg(d));
292 0 : return &(gel(d,l));
293 : }
294 :
295 : long*
296 0 : safeel(GEN x, long l)
297 : {
298 0 : if (typ(x)!=t_VECSMALL)
299 0 : pari_err_TYPE("safeel",x);
300 0 : check_array_index(l, lg(x));
301 0 : return &(x[l]);
302 : }
303 :
304 : GEN*
305 0 : safegcoeff(GEN x, long a, long b)
306 : {
307 0 : if (typ(x)!=t_MAT) pari_err_TYPE("safegcoeff", x);
308 0 : check_array_index(b, lg(x));
309 0 : check_array_index(a, lg(gel(x,b)));
310 0 : return &(gcoeff(x,a,b));
311 : }
312 :
313 : typedef struct matcomp
314 : {
315 : GEN *ptcell;
316 : GEN parent;
317 : int full_col, full_row;
318 : } matcomp;
319 :
320 : typedef struct gp_pointer
321 : {
322 : matcomp c;
323 : GEN x, ox;
324 : entree *ep;
325 : long vn;
326 : long sp;
327 : } gp_pointer;
328 :
329 : /* assign res at *pt in "simple array object" p and return it, or a copy.*/
330 : static void
331 9701769 : change_compo(matcomp *c, GEN res)
332 : {
333 9701769 : GEN p = c->parent, *pt = c->ptcell, po;
334 : long i, t;
335 :
336 9701769 : if (typ(p) == t_VECSMALL)
337 : {
338 35 : if (typ(res) != t_INT || is_bigint(res))
339 14 : pari_err_TYPE("t_VECSMALL assignment", res);
340 21 : *pt = (GEN)itos(res); return;
341 : }
342 9701734 : t = typ(res);
343 9701734 : if (c->full_row)
344 : {
345 204988 : if (t != t_VEC) pari_err_TYPE("matrix row assignment", res);
346 204967 : if (lg(res) != lg(p)) pari_err_DIM("matrix row assignment");
347 2105362 : for (i=1; i<lg(p); i++)
348 : {
349 1900416 : GEN p1 = gcoeff(p,c->full_row,i); /* Protect against SIGINT */
350 1900416 : gcoeff(p,c->full_row,i) = gclone(gel(res,i));
351 1900416 : if (isclone(p1)) gunclone_deep(p1);
352 : }
353 204946 : return;
354 : }
355 9496746 : if (c->full_col)
356 : {
357 355397 : if (t != t_COL) pari_err_TYPE("matrix col assignment", res);
358 355383 : if (lg(res) != lg(*pt)) pari_err_DIM("matrix col assignment");
359 : }
360 :
361 9496725 : po = *pt; /* Protect against SIGINT */
362 9496725 : *pt = gclone(res);
363 9496725 : gunclone_deep(po);
364 : }
365 :
366 : /***************************************************************************
367 : ** **
368 : ** Byte-code evaluator **
369 : ** **
370 : ***************************************************************************/
371 :
372 : struct var_lex
373 : {
374 : long flag;
375 : GEN value;
376 : };
377 :
378 : struct trace
379 : {
380 : long pc;
381 : GEN closure;
382 : };
383 :
384 : static THREAD long sp, rp, dbg_level;
385 : static THREAD long *st, *precs;
386 : static THREAD GEN *locks;
387 : static THREAD gp_pointer *ptrs;
388 : static THREAD entree **lvars;
389 : static THREAD struct var_lex *var;
390 : static THREAD struct trace *trace;
391 : static THREAD pari_stack s_st, s_ptrs, s_var, s_trace, s_prec;
392 : static THREAD pari_stack s_lvars, s_locks;
393 :
394 : static void
395 162422356 : changelex(long vn, GEN x)
396 : {
397 162422356 : struct var_lex *v=var+s_var.n+vn;
398 162422356 : GEN old_val = v->value;
399 162422356 : v->value = gclone(x);
400 162422356 : if (v->flag == COPY_VAL) gunclone_deep(old_val); else v->flag = COPY_VAL;
401 162422356 : }
402 :
403 : INLINE GEN
404 9791047 : copylex(long vn)
405 : {
406 9791047 : struct var_lex *v = var+s_var.n+vn;
407 9791047 : if (v->flag!=COPY_VAL && v->flag!=REF_VAL)
408 : {
409 52612 : v->value = gclone(v->value);
410 52612 : v->flag = COPY_VAL;
411 : }
412 9791047 : return v->value;
413 : }
414 :
415 : INLINE void
416 504 : setreflex(long vn)
417 : {
418 504 : struct var_lex *v = var+s_var.n+vn;
419 504 : v->flag = REF_VAL;
420 504 : }
421 :
422 : INLINE void
423 63698660 : pushlex(long vn, GEN x)
424 : {
425 63698660 : struct var_lex *v=var+s_var.n+vn;
426 63698660 : v->flag = PUSH_VAL;
427 63698660 : v->value = x;
428 63698660 : }
429 :
430 : INLINE void
431 186782142 : freelex(void)
432 : {
433 186782142 : struct var_lex *v=var+s_var.n-1;
434 186782142 : s_var.n--;
435 186782142 : if (v->flag == COPY_VAL) gunclone_deep(v->value);
436 186782142 : }
437 :
438 : INLINE void
439 282652914 : restore_vars(long nbmvar, long nblvar, long nblock)
440 : {
441 : long j;
442 463660617 : for(j=1; j<=nbmvar; j++) freelex();
443 282652970 : for(j=1; j<=nblvar; j++) { s_lvars.n--; pop_val(lvars[s_lvars.n]); }
444 282653383 : for(j=1; j<=nblock; j++) { s_locks.n--; gunclone_deep(locks[s_locks.n]); }
445 282652914 : }
446 :
447 : INLINE void
448 5663469 : restore_trace(long nbtrace)
449 : {
450 : long j;
451 11339681 : for(j=1; j<=nbtrace; j++)
452 : {
453 5676212 : GEN C = trace[s_trace.n-j].closure;
454 5676212 : clone_unlock(C);
455 : }
456 5663469 : s_trace.n -= nbtrace;
457 5663469 : }
458 :
459 : INLINE long
460 288272970 : trace_push(long pc, GEN C)
461 : {
462 : long tr;
463 288272970 : BLOCK_SIGINT_START
464 288272970 : tr = pari_stack_new(&s_trace);
465 288272970 : trace[tr].pc = pc;
466 288272970 : clone_lock(C);
467 288272970 : trace[tr].closure = C;
468 288272970 : BLOCK_SIGINT_END
469 288272958 : return tr;
470 : }
471 :
472 : void
473 5774747 : push_lex(GEN a, GEN C)
474 : {
475 5774747 : long vn=pari_stack_new(&s_var);
476 5774747 : struct var_lex *v=var+vn;
477 5774747 : v->flag = PUSH_VAL;
478 5774747 : v->value = a;
479 5774747 : if (C) (void) trace_push(-1, C);
480 5774747 : }
481 :
482 : GEN
483 66868257 : get_lex(long vn)
484 : {
485 66868257 : struct var_lex *v=var+s_var.n+vn;
486 66868257 : return v->value;
487 : }
488 :
489 : void
490 83681554 : set_lex(long vn, GEN x)
491 : {
492 83681554 : struct var_lex *v=var+s_var.n+vn;
493 83681554 : if (v->flag == COPY_VAL) { gunclone_deep(v->value); v->flag = PUSH_VAL; }
494 83681554 : v->value = x;
495 83681554 : }
496 :
497 : void
498 5607054 : pop_lex(long n)
499 : {
500 : long j;
501 11381493 : for(j=1; j<=n; j++)
502 5774439 : freelex();
503 5607054 : restore_trace(1);
504 5607054 : }
505 :
506 : static THREAD pari_stack s_relocs;
507 : static THREAD entree **relocs;
508 :
509 : void
510 378548 : pari_init_evaluator(void)
511 : {
512 378548 : sp=0;
513 378548 : pari_stack_init(&s_st,sizeof(*st),(void**)&st);
514 378548 : pari_stack_alloc(&s_st,32);
515 378548 : s_st.n=s_st.alloc;
516 378548 : rp=0;
517 378548 : pari_stack_init(&s_ptrs,sizeof(*ptrs),(void**)&ptrs);
518 378548 : pari_stack_alloc(&s_ptrs,16);
519 378548 : s_ptrs.n=s_ptrs.alloc;
520 378548 : pari_stack_init(&s_var,sizeof(*var),(void**)&var);
521 378548 : pari_stack_init(&s_lvars,sizeof(*lvars),(void**)&lvars);
522 378548 : pari_stack_init(&s_locks,sizeof(*locks),(void**)&locks);
523 378548 : pari_stack_init(&s_trace,sizeof(*trace),(void**)&trace);
524 378548 : br_res = NULL;
525 378548 : pari_stack_init(&s_relocs,sizeof(*relocs),(void**)&relocs);
526 378548 : pari_stack_init(&s_prec,sizeof(*precs),(void**)&precs);
527 378548 : }
528 : void
529 378540 : pari_close_evaluator(void)
530 : {
531 378540 : pari_stack_delete(&s_st);
532 378540 : pari_stack_delete(&s_ptrs);
533 378540 : pari_stack_delete(&s_var);
534 378540 : pari_stack_delete(&s_lvars);
535 378540 : pari_stack_delete(&s_trace);
536 378540 : pari_stack_delete(&s_relocs);
537 378540 : pari_stack_delete(&s_prec);
538 378540 : }
539 :
540 : static gp_pointer *
541 58686154 : new_ptr(void)
542 : {
543 58686154 : if (rp==s_ptrs.n-1)
544 : {
545 : long i;
546 0 : gp_pointer *old = ptrs;
547 0 : (void)pari_stack_new(&s_ptrs);
548 0 : if (old != ptrs)
549 0 : for(i=0; i<rp; i++)
550 : {
551 0 : gp_pointer *g = &ptrs[i];
552 0 : if(g->sp >= 0) gel(st,g->sp) = (GEN) &(g->x);
553 : }
554 : }
555 58686154 : return &ptrs[rp++];
556 : }
557 :
558 : void
559 487116 : push_localbitprec(long p)
560 : {
561 487116 : long n = pari_stack_new(&s_prec);
562 487116 : precs[n] = p;
563 487116 : }
564 : void
565 99278 : push_localprec(long p) { push_localbitprec(p); }
566 :
567 : void
568 99229 : pop_localprec(void) { s_prec.n--; }
569 :
570 : long
571 22788861 : get_localbitprec(void) { return s_prec.n? precs[s_prec.n-1]: precreal; }
572 :
573 : long
574 22381982 : get_localprec(void) { return nbits2prec(get_localbitprec()); }
575 :
576 : static void
577 11211 : checkprec(const char *f, long p, long M)
578 : {
579 11211 : if (p < 1) pari_err_DOMAIN(f, "p", "<", gen_1, stoi(p));
580 11197 : if (p > M) pari_err_DOMAIN(f, "p", ">", utoipos(M), utoi(p));
581 11185 : }
582 : static long
583 11304 : _prec(GEN p, const char *f)
584 : {
585 11304 : pari_sp av = avma;
586 11304 : if (typ(p) == t_INT) return itos(p);
587 35 : p = gceil(p);
588 35 : if (typ(p) != t_INT) pari_err_TYPE(f, p);
589 28 : return gc_long(av, itos(p));
590 : }
591 : void
592 7847 : localprec(GEN pp)
593 : {
594 7847 : long p = _prec(pp, "localprec");
595 7839 : checkprec("localprec", p, prec2ndec(LGBITS));
596 7826 : p = ndec2nbits(p); push_localbitprec(p);
597 7826 : }
598 : void
599 3373 : localbitprec(GEN pp)
600 : {
601 3373 : long p = _prec(pp, "localbitprec");
602 3372 : checkprec("localbitprec", p, (long)LGBITS);
603 3359 : push_localbitprec(p);
604 3359 : }
605 : long
606 14 : getlocalprec(long prec) { return prec2ndec(prec); }
607 : long
608 3556 : getlocalbitprec(long bit) { return bit; }
609 :
610 : static GEN
611 1246 : _precision0(GEN x)
612 : {
613 1246 : long a = gprecision(x);
614 1246 : return a? utoi(prec2ndec(a)): mkoo();
615 : }
616 : GEN
617 42 : precision0(GEN x, long n)
618 42 : { return n? gprec(x,n): _precision0(x); }
619 : static GEN
620 676 : _bitprecision0(GEN x)
621 : {
622 676 : long a = gprecision(x);
623 676 : return a? utoi(a): mkoo();
624 : }
625 : GEN
626 42 : bitprecision0(GEN x, long n)
627 : {
628 42 : if (n < 0)
629 0 : pari_err_DOMAIN("bitprecision", "bitprecision", "<", gen_0, stoi(n));
630 42 : if (n) {
631 42 : pari_sp av = avma;
632 42 : GEN y = gprec_w(x, nbits2prec(n));
633 42 : return gc_GEN(av, y);
634 : }
635 0 : return _bitprecision0(x);
636 : }
637 : GEN
638 1288 : precision00(GEN x, GEN n)
639 : {
640 1288 : if (!n) return _precision0(x);
641 42 : return precision0(x, _prec(n, "precision"));
642 : }
643 : GEN
644 718 : bitprecision00(GEN x, GEN n)
645 : {
646 718 : if (!n) return _bitprecision0(x);
647 42 : return bitprecision0(x, _prec(n, "bitprecision"));
648 : }
649 :
650 : INLINE GEN
651 75496521 : copyupto(GEN z, GEN t)
652 : {
653 75496521 : if (is_universal_constant(z) || (z>(GEN)pari_mainstack->bot && z<=t))
654 71111970 : return z;
655 : else
656 4384551 : return gcopy(z);
657 : }
658 :
659 : static void closure_eval(GEN C);
660 :
661 : INLINE GEN
662 41666 : get_and_reset_break(void)
663 : {
664 41666 : GEN z = br_res? gcopy(br_res): gnil;
665 41666 : reset_break(); return z;
666 : }
667 :
668 : INLINE GEN
669 51444515 : closure_return(GEN C)
670 : {
671 51444515 : pari_sp av = avma;
672 51444515 : closure_eval(C);
673 51418339 : if (br_status) { set_avma(av); return get_and_reset_break(); }
674 51376722 : return gc_upto(av, gel(st,--sp));
675 : }
676 :
677 : /* for the break_loop debugger. Not memory clean */
678 : GEN
679 175 : closure_evalbrk(GEN C, long *status)
680 : {
681 175 : closure_eval(C); *status = br_status;
682 140 : return br_status? get_and_reset_break(): gel(st,--sp);
683 : }
684 :
685 : INLINE long
686 1162606 : closure_varn(GEN x)
687 : {
688 1162606 : if (!x) return -1;
689 1162004 : if (!gequalX(x)) err_var(x);
690 1162004 : return varn(x);
691 : }
692 :
693 : INLINE void
694 93847314 : closure_castgen(GEN z, long mode)
695 : {
696 93847314 : switch (mode)
697 : {
698 93846425 : case Ggen:
699 93846425 : gel(st,sp++)=z;
700 93846425 : break;
701 889 : case Gsmall:
702 889 : st[sp++]=gtos(z);
703 889 : break;
704 0 : case Gusmall:
705 0 : st[sp++]=gtou(z);
706 0 : break;
707 0 : case Gvar:
708 0 : st[sp++]=closure_varn(z);
709 0 : break;
710 0 : case Gvoid:
711 0 : break;
712 0 : default:
713 0 : pari_err_BUG("closure_castgen, type unknown");
714 : }
715 93847314 : }
716 :
717 : INLINE void
718 5873 : closure_castlong(long z, long mode)
719 : {
720 5873 : switch (mode)
721 : {
722 0 : case Gsmall:
723 0 : st[sp++]=z;
724 0 : break;
725 0 : case Gusmall:
726 0 : if (z < 0)
727 0 : pari_err_TYPE("stou [integer >=0 expected]", stoi(z));
728 0 : st[sp++]=(ulong) z;
729 0 : break;
730 5866 : case Ggen:
731 5866 : gel(st,sp++)=stoi(z);
732 5866 : break;
733 0 : case Gvar:
734 0 : err_var(stoi(z));
735 7 : case Gvoid:
736 7 : break;
737 0 : default:
738 0 : pari_err_BUG("closure_castlong, type unknown");
739 : }
740 5873 : }
741 :
742 : const char *
743 13876 : closure_func_err(void)
744 : {
745 13876 : long fun=s_trace.n-1, pc;
746 : const char *code;
747 : GEN C, oper;
748 13876 : if (fun < 0 || trace[fun].pc < 0) return NULL;
749 13166 : pc = trace[fun].pc; C = trace[fun].closure;
750 13166 : code = closure_codestr(C); oper = closure_get_oper(C);
751 13166 : if (code[pc]==OCcallgen || code[pc]==OCcallgen2 ||
752 3668 : code[pc]==OCcallint || code[pc]==OCcalllong || code[pc]==OCcallvoid)
753 10212 : return ((entree*)oper[pc])->name;
754 2954 : return NULL;
755 : }
756 :
757 : /* return the next label for the call chain debugger closure_err(),
758 : * incorporating the name of the user of member function. Return NULL for an
759 : * anonymous (inline) closure. */
760 : static char *
761 245 : get_next_label(const char *s, int member, char **next_fun)
762 : {
763 245 : const char *v, *t = s+1;
764 : char *u, *next_label;
765 :
766 245 : if (!is_keyword_char(*s)) return NULL;
767 1036 : while (is_keyword_char(*t)) t++;
768 : /* e.g. (x->1/x)(0) instead of (x)->1/x */
769 224 : if (t[0] == '-' && t[1] == '>') return NULL;
770 217 : next_label = (char*)pari_malloc(t - s + 32);
771 217 : sprintf(next_label, "in %sfunction ", member? "member ": "");
772 217 : u = *next_fun = next_label + strlen(next_label);
773 217 : v = s;
774 1246 : while (v < t) *u++ = *v++;
775 217 : *u++ = 0; return next_label;
776 : }
777 :
778 : static const char *
779 21 : get_arg_name(GEN C, long i)
780 : {
781 21 : GEN d = closure_get_dbg(C), frpc = gel(d,2), fram = gel(d,3);
782 21 : long j, l = lg(frpc);
783 28 : for (j=1; j<l; j++)
784 28 : if (frpc[j]==1 && i<lg(gel(fram,j)))
785 21 : return ((entree*)mael(fram,j,i))->name;
786 0 : return "(unnamed)";
787 : }
788 :
789 : void
790 13004 : closure_err(long level)
791 : {
792 : GEN base;
793 13004 : const long lastfun = s_trace.n - 1 - level;
794 : char *next_label, *next_fun;
795 13004 : long i = maxss(0, lastfun - 19);
796 13004 : if (lastfun < 0) return; /*e.g. when called by gp_main_loop's simplify */
797 12983 : if (i > 0) while (lg(trace[i].closure)==6) i--;
798 12983 : if (lg(trace[i].closure)==6) return; /* Should never happen */
799 12983 : base = closure_get_text(trace[i].closure); /* gcc -Wall*/
800 12983 : next_label = pari_strdup(i == 0? "at top-level": "[...] at");
801 12983 : next_fun = next_label;
802 13661 : for (; i <= lastfun; i++)
803 : {
804 13661 : GEN C = trace[i].closure;
805 13661 : if (lg(C) >= 7) base=closure_get_text(C);
806 13661 : if ((i==lastfun || lg(trace[i+1].closure)>=7))
807 : {
808 13228 : GEN dbg = gel(closure_get_dbg(C),1);
809 : /* After a SIGINT, pc can be slightly off: ensure 0 <= pc < lg() */
810 13228 : long pc = minss(lg(dbg)-1, trace[i].pc>=0 ? trace[i].pc: 1);
811 13228 : long offset = pc? dbg[pc]: 0;
812 : int member;
813 : const char *s, *sbase;
814 13228 : if (typ(base)!=t_VEC) sbase = GSTR(base);
815 189 : else if (offset>=0) sbase = GSTR(gel(base,2));
816 21 : else { sbase = GSTR(gel(base,1)); offset += strlen(sbase); }
817 13228 : s = sbase + offset;
818 13228 : member = offset>0 && (s[-1] == '.');
819 : /* avoid "in function foo: foo" */
820 13228 : if (!next_fun || strcmp(next_fun, s)) {
821 13221 : print_errcontext(pariErr, next_label, s, sbase);
822 13221 : out_putc(pariErr, '\n');
823 : }
824 13228 : pari_free(next_label);
825 13228 : if (i == lastfun) break;
826 :
827 245 : next_label = get_next_label(s, member, &next_fun);
828 245 : if (!next_label) {
829 28 : next_label = pari_strdup("in anonymous function");
830 28 : next_fun = NULL;
831 : }
832 : }
833 : }
834 : }
835 :
836 : GEN
837 41 : pari_self(void)
838 : {
839 41 : long fun = s_trace.n - 1;
840 76 : if (fun > 0) while (lg(trace[fun].closure)==6) fun--;
841 41 : return fun >= 0 ? trace[fun].closure: NULL;
842 : }
843 :
844 : long
845 91 : closure_context(long start, long level)
846 : {
847 91 : const long lastfun = s_trace.n - 1 - level;
848 91 : long i, fun = lastfun;
849 91 : if (fun<0) return lastfun;
850 224 : while (fun>start && lg(trace[fun].closure)==6) fun--;
851 315 : for (i=fun; i <= lastfun; i++)
852 224 : push_frame(trace[i].closure, trace[i].pc,0);
853 126 : for ( ; i < s_trace.n; i++)
854 35 : push_frame(trace[i].closure, trace[i].pc,1);
855 91 : return s_trace.n-level;
856 : }
857 :
858 : INLINE void
859 3010850683 : st_alloc(long n)
860 : {
861 3010850683 : if (sp+n>s_st.n)
862 : {
863 70 : pari_stack_alloc(&s_st,n+16);
864 70 : s_st.n=s_st.alloc;
865 70 : if (DEBUGMEM>=2) pari_warn(warner,"doubling evaluator stack");
866 : }
867 3010850683 : }
868 :
869 : INLINE void
870 9906673 : ptr_proplock(gp_pointer *g, GEN C)
871 : {
872 9906673 : g->x = C;
873 9906673 : if (isclone(g->x))
874 : {
875 445046 : clone_unlock_deep(g->ox);
876 445046 : g->ox = g->x;
877 445046 : ++bl_refc(g->ox);
878 : }
879 9906673 : }
880 :
881 : static void
882 282665609 : closure_eval(GEN C)
883 : {
884 282665609 : const char *code=closure_codestr(C);
885 282665608 : GEN oper=closure_get_oper(C);
886 282665608 : GEN data=closure_get_data(C);
887 282665608 : long loper=lg(oper);
888 282665608 : long saved_sp=sp-closure_arity(C);
889 282665608 : long saved_rp=rp, saved_prec=s_prec.n;
890 282665608 : long j, nbmvar=0, nblvar=0, nblock=0;
891 : long pc, t;
892 : #ifdef STACK_CHECK
893 : GEN stackelt;
894 282665608 : if (PARI_stack_limit && (void*) &stackelt <= PARI_stack_limit)
895 0 : pari_err(e_MISC, "deep recursion");
896 : #endif
897 282665608 : t = trace_push(0, C);
898 282665596 : if (lg(C)==8)
899 : {
900 14691108 : GEN z=closure_get_frame(C);
901 14691108 : long l=lg(z)-1;
902 14691108 : pari_stack_alloc(&s_var,l);
903 14691108 : s_var.n+=l;
904 14691108 : nbmvar+=l;
905 51735172 : for(j=1;j<=l;j++)
906 : {
907 37044064 : var[s_var.n-j].flag=PUSH_VAL;
908 37044064 : var[s_var.n-j].value=gel(z,j);
909 : }
910 : }
911 :
912 3220919021 : for(pc=1;pc<loper;pc++)
913 : {
914 2938618692 : op_code opcode=(op_code) code[pc];
915 2938618692 : long operand=oper[pc];
916 2938618692 : if (sp<0) pari_err_BUG("closure_eval, stack underflow");
917 2938618692 : st_alloc(16);
918 2938618691 : trace[t].pc = pc;
919 : CHECK_CTRLC
920 2938618691 : switch(opcode)
921 : {
922 184874698 : case OCpushlong:
923 184874698 : st[sp++]=operand;
924 184874698 : break;
925 101075 : case OCpushgnil:
926 101075 : gel(st,sp++)=gnil;
927 101075 : break;
928 165766364 : case OCpushgen:
929 165766364 : gel(st,sp++)=gel(data,operand);
930 165766364 : break;
931 86710 : case OCpushreal:
932 86710 : gel(st,sp++)=strtor(GSTR(data[operand]),get_localprec());
933 86710 : break;
934 276084816 : case OCpushstoi:
935 276084816 : gel(st,sp++)=stoi(operand);
936 276084816 : break;
937 26873 : case OCpushvar:
938 : {
939 26873 : entree *ep = (entree *)operand;
940 26873 : gel(st,sp++)=pol_x(pari_var_create(ep));
941 26873 : break;
942 : }
943 93749748 : case OCpushdyn:
944 : {
945 93749748 : entree *ep = (entree *)operand;
946 93749748 : if (!mt_is_thread())
947 : {
948 93748248 : checkvalue(ep, chk_CREATE);
949 93748248 : gel(st,sp++)=(GEN)ep->value;
950 : } else
951 : {
952 1500 : GEN val = export_get(ep->name);
953 1500 : if (!val)
954 0 : pari_err(e_MISC,"mt: please use export(%s)", ep->name);
955 1500 : gel(st,sp++)=val;
956 : }
957 93749748 : break;
958 : }
959 611043405 : case OCpushlex:
960 611043405 : gel(st,sp++)=var[s_var.n+operand].value;
961 611043405 : break;
962 23308355 : case OCsimpleptrdyn:
963 : {
964 23308355 : gp_pointer *g = new_ptr();
965 23308355 : g->vn=0;
966 23308355 : g->ep = (entree*) operand;
967 23308355 : g->x = checkvalueptr(g->ep);
968 23308355 : g->ox = g->x; clone_lock(g->ox);
969 23308355 : g->sp = sp;
970 23308355 : gel(st,sp++) = (GEN)&(g->x);
971 23308355 : break;
972 : }
973 25675981 : case OCsimpleptrlex:
974 : {
975 25675981 : gp_pointer *g = new_ptr();
976 25675981 : g->vn=operand;
977 25675981 : g->ep=(entree *)0x1L;
978 25675981 : g->x = (GEN) var[s_var.n+operand].value;
979 25675981 : g->ox = g->x; clone_lock(g->ox);
980 25675981 : g->sp = sp;
981 25675981 : gel(st,sp++) = (GEN)&(g->x);
982 25675981 : break;
983 : }
984 5033 : case OCnewptrdyn:
985 : {
986 5033 : entree *ep = (entree *)operand;
987 5033 : gp_pointer *g = new_ptr();
988 : matcomp *C;
989 5033 : checkvalue(ep, chk_ERROR);
990 5033 : g->sp = -1;
991 5033 : g->x = copyvalue(ep);
992 5033 : g->ox = g->x; clone_lock(g->ox);
993 5033 : g->vn=0;
994 5033 : g->ep=NULL;
995 5033 : C=&g->c;
996 5033 : C->full_col = C->full_row = 0;
997 5033 : C->parent = (GEN) g->x;
998 5033 : C->ptcell = (GEN *) &g->x;
999 5033 : break;
1000 : }
1001 9696785 : case OCnewptrlex:
1002 : {
1003 9696785 : gp_pointer *g = new_ptr();
1004 : matcomp *C;
1005 9696785 : g->sp = -1;
1006 9696785 : g->x = copylex(operand);
1007 9696785 : g->ox = g->x; clone_lock(g->ox);
1008 9696785 : g->vn=0;
1009 9696785 : g->ep=NULL;
1010 9696785 : C=&g->c;
1011 9696785 : C->full_col = C->full_row = 0;
1012 9696785 : C->parent = (GEN) g->x;
1013 9696785 : C->ptcell = (GEN *) &(g->x);
1014 9696785 : break;
1015 : }
1016 559727 : case OCpushptr:
1017 : {
1018 559727 : gp_pointer *g = &ptrs[rp-1];
1019 559727 : g->sp = sp;
1020 559727 : gel(st,sp++) = (GEN)&(g->x);
1021 : }
1022 559727 : break;
1023 49544007 : case OCendptr:
1024 99088014 : for(j=0;j<operand;j++)
1025 : {
1026 49544007 : gp_pointer *g = &ptrs[--rp];
1027 49544007 : if (g->ep)
1028 : {
1029 48984280 : if (g->vn)
1030 25675981 : changelex(g->vn, g->x);
1031 : else
1032 23308299 : changevalue(g->ep, g->x);
1033 : }
1034 559727 : else change_compo(&(g->c), g->x);
1035 49544007 : clone_unlock_deep(g->ox);
1036 : }
1037 49544007 : break;
1038 6183011 : case OCstoredyn:
1039 : {
1040 6183011 : entree *ep = (entree *)operand;
1041 6183011 : checkvalue(ep, chk_NOCREATE);
1042 6183002 : changevalue(ep, gel(st,--sp));
1043 6183002 : break;
1044 : }
1045 136746375 : case OCstorelex:
1046 136746375 : changelex(operand,gel(st,--sp));
1047 136746375 : break;
1048 9142042 : case OCstoreptr:
1049 : {
1050 9142042 : gp_pointer *g = &ptrs[--rp];
1051 9142042 : change_compo(&(g->c), gel(st,--sp));
1052 9141965 : clone_unlock_deep(g->ox);
1053 9141965 : break;
1054 : }
1055 58445029 : case OCstackgen:
1056 : {
1057 58445029 : GEN z = gc_upto(st[sp-2],gel(st,sp-1));
1058 58445029 : gmael(st,sp-3,operand) = copyupto(z,gel(st,sp-2));
1059 58445029 : st[sp-2] = avma;
1060 58445029 : sp--;
1061 58445029 : break;
1062 : }
1063 22295272 : case OCprecreal:
1064 22295272 : st[sp++]=get_localprec();
1065 22295272 : break;
1066 30226 : case OCbitprecreal:
1067 30226 : st[sp++]=get_localbitprec();
1068 30226 : break;
1069 952 : case OCprecdl:
1070 952 : st[sp++]=precdl;
1071 952 : break;
1072 3059 : case OCavma:
1073 3059 : st[sp++]=avma;
1074 3059 : break;
1075 741818 : case OCcowvardyn:
1076 : {
1077 741818 : entree *ep = (entree *)operand;
1078 741818 : checkvalue(ep, chk_ERROR);
1079 741818 : (void)copyvalue(ep);
1080 741818 : break;
1081 : }
1082 93205 : case OCcowvarlex:
1083 93205 : (void)copylex(operand);
1084 93205 : break;
1085 504 : case OCsetref:
1086 504 : setreflex(operand);
1087 504 : break;
1088 483 : case OClock:
1089 : {
1090 483 : GEN v = gel(st,sp-1);
1091 483 : if (isclone(v))
1092 : {
1093 469 : long n = pari_stack_new(&s_locks);
1094 469 : locks[n] = v;
1095 469 : nblock++;
1096 469 : ++bl_refc(v);
1097 : }
1098 483 : break;
1099 : }
1100 0 : case OCevalmnem:
1101 : {
1102 0 : entree *ep = (entree*) operand;
1103 0 : const char *flags = ep->code;
1104 0 : flags = strchr(flags, '\n'); /* Skip to the following '\n' */
1105 0 : st[sp-1] = eval_mnemonic(gel(st,sp-1), flags+1);
1106 0 : break;
1107 : }
1108 20474523 : case OCstoi:
1109 20474523 : gel(st,sp-1)=stoi(st[sp-1]);
1110 20474523 : break;
1111 0 : case OCutoi:
1112 0 : gel(st,sp-1)=utoi(st[sp-1]);
1113 0 : break;
1114 72998259 : case OCitos:
1115 72998259 : st[sp+operand]=gtos(gel(st,sp+operand));
1116 72998224 : break;
1117 102023 : case OCitou:
1118 102023 : st[sp+operand]=gtou(gel(st,sp+operand));
1119 102023 : break;
1120 5442 : case OCtostr:
1121 : {
1122 5442 : GEN z = gel(st,sp+operand);
1123 5442 : st[sp+operand] = (long) (z ? GENtostr_unquoted(z): NULL);
1124 5442 : break;
1125 : }
1126 1162606 : case OCvarn:
1127 1162606 : st[sp+operand] = closure_varn(gel(st,sp+operand));
1128 1162606 : break;
1129 26347487 : case OCcopy:
1130 26347487 : gel(st,sp-1) = gcopy(gel(st,sp-1));
1131 26347487 : break;
1132 3059 : case OCgc:
1133 : {
1134 : pari_sp av;
1135 : GEN x;
1136 3059 : sp--;
1137 3059 : av = st[sp-1];
1138 3059 : x = gel(st,sp);
1139 3059 : if (isonstack(x))
1140 : {
1141 3059 : pari_sp av2 = (pari_sp)(x + lg(x));
1142 3059 : if ((long) (av - av2) > 1000000L)
1143 : {
1144 7 : if (DEBUGMEM>=2)
1145 0 : pari_warn(warnmem,"eval: recovering %ld bytes", av - av2);
1146 7 : x = gc_upto(av, x);
1147 : }
1148 0 : } else set_avma(av);
1149 3059 : gel(st,sp-1) = x;
1150 3059 : break;
1151 : }
1152 0 : case OCcopyifclone:
1153 0 : if (isclone(gel(st,sp-1)))
1154 0 : gel(st,sp-1) = gcopy(gel(st,sp-1));
1155 0 : break;
1156 92156405 : case OCcompo1:
1157 : {
1158 92156405 : GEN p=gel(st,sp-2);
1159 92156405 : long c=st[sp-1];
1160 92156405 : sp-=2;
1161 92156405 : switch(typ(p))
1162 : {
1163 92149534 : case t_VEC: case t_COL:
1164 92149534 : check_array_index(c, lg(p));
1165 92149534 : closure_castgen(gel(p,c),operand);
1166 92149534 : break;
1167 977 : case t_LIST:
1168 : {
1169 : long lx;
1170 977 : if (list_typ(p)!=t_LIST_RAW)
1171 0 : pari_err_TYPE("_[_] OCcompo1 [not a vector]", p);
1172 977 : p = list_data(p); lx = p? lg(p): 1;
1173 977 : check_array_index(c, lx);
1174 977 : closure_castgen(gel(p,c),operand);
1175 977 : break;
1176 : }
1177 5887 : case t_VECSMALL:
1178 5887 : check_array_index(c,lg(p));
1179 5873 : closure_castlong(p[c],operand);
1180 5873 : break;
1181 7 : default:
1182 7 : pari_err_TYPE("_[_] OCcompo1 [not a vector]", p);
1183 0 : break;
1184 : }
1185 92156384 : break;
1186 : }
1187 9425325 : case OCcompo1ptr:
1188 : {
1189 9425325 : long c=st[sp-1];
1190 : long lx;
1191 9425325 : gp_pointer *g = &ptrs[rp-1];
1192 9425325 : matcomp *C=&g->c;
1193 9425325 : GEN p = g->x;
1194 9425325 : sp--;
1195 9425325 : switch(typ(p))
1196 : {
1197 9425248 : case t_VEC: case t_COL:
1198 9425248 : check_array_index(c, lg(p));
1199 9425248 : C->ptcell = (GEN *) p+c;
1200 9425248 : ptr_proplock(g, *(C->ptcell));
1201 9425248 : break;
1202 42 : case t_VECSMALL:
1203 42 : check_array_index(c, lg(p));
1204 35 : C->ptcell = (GEN *) p+c;
1205 35 : g->x = stoi(p[c]);
1206 35 : break;
1207 28 : case t_LIST:
1208 28 : if (list_typ(p)!=t_LIST_RAW)
1209 0 : pari_err_TYPE("&_[_] OCcompo1 [not a vector]", p);
1210 28 : p = list_data(p); lx = p? lg(p): 1;
1211 28 : check_array_index(c,lx);
1212 28 : C->ptcell = (GEN *) p+c;
1213 28 : ptr_proplock(g, *(C->ptcell));
1214 28 : break;
1215 7 : default:
1216 7 : pari_err_TYPE("&_[_] OCcompo1ptr [not a vector]", p);
1217 : }
1218 9425311 : C->parent = p;
1219 9425311 : break;
1220 : }
1221 1696810 : case OCcompo2:
1222 : {
1223 1696810 : GEN p=gel(st,sp-3);
1224 1696810 : long c=st[sp-2];
1225 1696810 : long d=st[sp-1];
1226 1696810 : if (typ(p)!=t_MAT) pari_err_TYPE("_[_,_] OCcompo2 [not a matrix]", p);
1227 1696803 : check_array_index(d, lg(p));
1228 1696803 : check_array_index(c, lg(gel(p,d)));
1229 1696803 : sp-=3;
1230 1696803 : closure_castgen(gcoeff(p,c,d),operand);
1231 1696803 : break;
1232 : }
1233 126000 : case OCcompo2ptr:
1234 : {
1235 126000 : long c=st[sp-2];
1236 126000 : long d=st[sp-1];
1237 126000 : gp_pointer *g = &ptrs[rp-1];
1238 126000 : matcomp *C=&g->c;
1239 126000 : GEN p = g->x;
1240 126000 : sp-=2;
1241 126000 : if (typ(p)!=t_MAT)
1242 0 : pari_err_TYPE("&_[_,_] OCcompo2ptr [not a matrix]", p);
1243 126000 : check_array_index(d, lg(p));
1244 126000 : check_array_index(c, lg(gel(p,d)));
1245 126000 : C->ptcell = (GEN *) gel(p,d)+c;
1246 126000 : C->parent = p;
1247 126000 : ptr_proplock(g, *(C->ptcell));
1248 126000 : break;
1249 : }
1250 1022635 : case OCcompoC:
1251 : {
1252 1022635 : GEN p=gel(st,sp-2);
1253 1022635 : long c=st[sp-1];
1254 1022635 : if (typ(p)!=t_MAT)
1255 7 : pari_err_TYPE("_[,_] OCcompoC [not a matrix]", p);
1256 1022628 : check_array_index(c, lg(p));
1257 1022621 : sp--;
1258 1022621 : gel(st,sp-1) = gel(p,c);
1259 1022621 : break;
1260 : }
1261 355411 : case OCcompoCptr:
1262 : {
1263 355411 : long c=st[sp-1];
1264 355411 : gp_pointer *g = &ptrs[rp-1];
1265 355411 : matcomp *C=&g->c;
1266 355411 : GEN p = g->x;
1267 355411 : sp--;
1268 355411 : if (typ(p)!=t_MAT)
1269 7 : pari_err_TYPE("&_[,_] OCcompoCptr [not a matrix]", p);
1270 355404 : check_array_index(c, lg(p));
1271 355397 : C->ptcell = (GEN *) p+c;
1272 355397 : C->full_col = c;
1273 355397 : C->parent = p;
1274 355397 : ptr_proplock(g, *(C->ptcell));
1275 355397 : break;
1276 : }
1277 273028 : case OCcompoL:
1278 : {
1279 273028 : GEN p=gel(st,sp-2);
1280 273028 : long r=st[sp-1];
1281 273028 : sp--;
1282 273028 : if (typ(p)!=t_MAT)
1283 7 : pari_err_TYPE("_[_,] OCcompoL [not a matrix]", p);
1284 273021 : check_array_index(r,lg(p) == 1? 1: lgcols(p));
1285 273014 : gel(st,sp-1) = row(p,r);
1286 273014 : break;
1287 : }
1288 205002 : case OCcompoLptr:
1289 : {
1290 205002 : long r=st[sp-1];
1291 205002 : gp_pointer *g = &ptrs[rp-1];
1292 205002 : matcomp *C=&g->c;
1293 205002 : GEN p = g->x, p2;
1294 205002 : sp--;
1295 205002 : if (typ(p)!=t_MAT)
1296 7 : pari_err_TYPE("&_[_,] OCcompoLptr [not a matrix]", p);
1297 204995 : check_array_index(r,lg(p) == 1? 1: lgcols(p));
1298 204988 : p2 = rowcopy(p,r);
1299 204988 : C->full_row = r; /* record row number */
1300 204988 : C->ptcell = &p2;
1301 204988 : C->parent = p;
1302 204988 : g->x = p2;
1303 204988 : break;
1304 : }
1305 102942 : case OCdefaultarg:
1306 102942 : if (var[s_var.n+operand].flag==DEFAULT_VAL)
1307 : {
1308 3465 : GEN z = gel(st,sp-1);
1309 3465 : if (typ(z)==t_CLOSURE)
1310 : {
1311 1057 : pushlex(operand, closure_evalnobrk(z));
1312 1057 : copylex(operand);
1313 : }
1314 : else
1315 2408 : pushlex(operand, z);
1316 : }
1317 102942 : sp--;
1318 102942 : break;
1319 51 : case OClocalvar:
1320 : {
1321 : long n;
1322 51 : entree *ep = (entree *)operand;
1323 51 : checkvalue(ep, chk_NOCREATE);
1324 42 : n = pari_stack_new(&s_lvars);
1325 42 : lvars[n] = ep;
1326 42 : nblvar++;
1327 42 : pushvalue(ep,gel(st,--sp));
1328 42 : break;
1329 : }
1330 23 : case OClocalvar0:
1331 : {
1332 : long n;
1333 23 : entree *ep = (entree *)operand;
1334 23 : checkvalue(ep, chk_NOCREATE);
1335 14 : n = pari_stack_new(&s_lvars);
1336 14 : lvars[n] = ep;
1337 14 : nblvar++;
1338 14 : zerovalue(ep);
1339 11 : break;
1340 : }
1341 41 : case OCexportvar:
1342 : {
1343 41 : entree *ep = (entree *)operand;
1344 41 : mt_export_add(ep->name, gel(st,--sp));
1345 41 : break;
1346 : }
1347 6 : case OCunexportvar:
1348 : {
1349 6 : entree *ep = (entree *)operand;
1350 6 : mt_export_del(ep->name);
1351 6 : break;
1352 : }
1353 :
1354 : #define EVAL_f(f, type, resEQ) \
1355 : switch (ep->arity) \
1356 : { \
1357 : case 0: resEQ ((type (*)(void))f)(); break; \
1358 : case 1: sp--; resEQ ((type (*)(long))f)(st[sp]); break; \
1359 : case 2: sp-=2; resEQ((type (*)(long,long))f)(st[sp],st[sp+1]); break; \
1360 : case 3: sp-=3; resEQ((type (*)(long,long,long))f)(st[sp],st[sp+1],st[sp+2]); break; \
1361 : case 4: sp-=4; resEQ((type (*)(long,long,long,long))f)(st[sp],st[sp+1],st[sp+2],st[sp+3]); break; \
1362 : case 5: sp-=5; resEQ((type (*)(long,long,long,long,long))f)(st[sp],st[sp+1],st[sp+2],st[sp+3],st[sp+4]); break; \
1363 : case 6: sp-=6; resEQ((type (*)(long,long,long,long,long,long))f)(st[sp],st[sp+1],st[sp+2],st[sp+3],st[sp+4],st[sp+5]); break; \
1364 : case 7: sp-=7; resEQ((type (*)(long,long,long,long,long,long,long))f)(st[sp],st[sp+1],st[sp+2],st[sp+3],st[sp+4],st[sp+5],st[sp+6]); break; \
1365 : case 8: sp-=8; resEQ((type (*)(long,long,long,long,long,long,long,long))f)(st[sp],st[sp+1],st[sp+2],st[sp+3],st[sp+4],st[sp+5],st[sp+6],st[sp+7]); break; \
1366 : case 9: sp-=9; resEQ((type (*)(long,long,long,long,long,long,long,long,long))f)(st[sp],st[sp+1],st[sp+2],st[sp+3],st[sp+4],st[sp+5],st[sp+6],st[sp+7],st[sp+8]); break; \
1367 : case 10: sp-=10; resEQ((type (*)(long,long,long,long,long,long,long,long,long,long))f)(st[sp],st[sp+1],st[sp+2],st[sp+3],st[sp+4],st[sp+5],st[sp+6],st[sp+7],st[sp+8],st[sp+9]); break; \
1368 : case 11: sp-=11; resEQ((type (*)(long,long,long,long,long,long,long,long,long,long,long))f)(st[sp],st[sp+1],st[sp+2],st[sp+3],st[sp+4],st[sp+5],st[sp+6],st[sp+7],st[sp+8],st[sp+9],st[sp+10]); break; \
1369 : case 12: sp-=12; resEQ((type (*)(long,long,long,long,long,long,long,long,long,long,long,long))f)(st[sp],st[sp+1],st[sp+2],st[sp+3],st[sp+4],st[sp+5],st[sp+6],st[sp+7],st[sp+8],st[sp+9],st[sp+10],st[sp+11]); break; \
1370 : case 13: sp-=13; resEQ((type (*)(long,long,long,long,long,long,long,long,long,long,long,long,long))f)(st[sp],st[sp+1],st[sp+2],st[sp+3],st[sp+4],st[sp+5],st[sp+6],st[sp+7],st[sp+8],st[sp+9],st[sp+10],st[sp+11],st[sp+12]); break; \
1371 : case 14: sp-=14; resEQ((type (*)(long,long,long,long,long,long,long,long,long,long,long,long,long,long))f)(st[sp],st[sp+1],st[sp+2],st[sp+3],st[sp+4],st[sp+5],st[sp+6],st[sp+7],st[sp+8],st[sp+9],st[sp+10],st[sp+11],st[sp+12],st[sp+13]); break; \
1372 : case 15: sp-=15; resEQ((type (*)(long,long,long,long,long,long,long,long,long,long,long,long,long,long,long))f)(st[sp],st[sp+1],st[sp+2],st[sp+3],st[sp+4],st[sp+5],st[sp+6],st[sp+7],st[sp+8],st[sp+9],st[sp+10],st[sp+11],st[sp+12],st[sp+13],st[sp+14]); break; \
1373 : case 16: sp-=16; resEQ((type (*)(long,long,long,long,long,long,long,long,long,long,long,long,long,long,long,long))f)(st[sp],st[sp+1],st[sp+2],st[sp+3],st[sp+4],st[sp+5],st[sp+6],st[sp+7],st[sp+8],st[sp+9],st[sp+10],st[sp+11],st[sp+12],st[sp+13],st[sp+14],st[sp+15]); break; \
1374 : case 17: sp-=17; resEQ((type (*)(long,long,long,long,long,long,long,long,long,long,long,long,long,long,long,long,long))f)(st[sp],st[sp+1],st[sp+2],st[sp+3],st[sp+4],st[sp+5],st[sp+6],st[sp+7],st[sp+8],st[sp+9],st[sp+10],st[sp+11],st[sp+12],st[sp+13],st[sp+14],st[sp+15],st[sp+16]); break; \
1375 : case 18: sp-=18; resEQ((type (*)(long,long,long,long,long,long,long,long,long,long,long,long,long,long,long,long,long,long))f)(st[sp],st[sp+1],st[sp+2],st[sp+3],st[sp+4],st[sp+5],st[sp+6],st[sp+7],st[sp+8],st[sp+9],st[sp+10],st[sp+11],st[sp+12],st[sp+13],st[sp+14],st[sp+15],st[sp+16],st[sp+17]); break; \
1376 : case 19: sp-=19; resEQ((type (*)(long,long,long,long,long,long,long,long,long,long,long,long,long,long,long,long,long,long,long))f)(st[sp],st[sp+1],st[sp+2],st[sp+3],st[sp+4],st[sp+5],st[sp+6],st[sp+7],st[sp+8],st[sp+9],st[sp+10],st[sp+11],st[sp+12],st[sp+13],st[sp+14],st[sp+15],st[sp+16],st[sp+17],st[sp+18]); break; \
1377 : case 20: sp-=20; resEQ((type (*)(long,long,long,long,long,long,long,long,long,long,long,long,long,long,long,long,long,long,long,long))f)(st[sp],st[sp+1],st[sp+2],st[sp+3],st[sp+4],st[sp+5],st[sp+6],st[sp+7],st[sp+8],st[sp+9],st[sp+10],st[sp+11],st[sp+12],st[sp+13],st[sp+14],st[sp+15],st[sp+16],st[sp+17],st[sp+18],st[sp+19]); break; \
1378 : default: \
1379 : pari_err_IMPL("functions with more than 20 parameters");\
1380 : goto endeval; /*LCOV_EXCL_LINE*/ \
1381 : }
1382 :
1383 :
1384 107614186 : case OCcallgen:
1385 : {
1386 107614186 : entree *ep = (entree *)operand;
1387 : GEN res;
1388 : /* Macro Madness : evaluate function ep->value on arguments
1389 : * st[sp-ep->arity .. sp]. Set res = result. */
1390 107614186 : EVAL_f(ep->value, GEN, res=);
1391 107597211 : if (br_status) goto endeval;
1392 107460082 : gel(st,sp++)=res;
1393 107460082 : break;
1394 : }
1395 593994138 : case OCcallgen2: /*same for ep->arity = 2. Is this optimization worth it ?*/
1396 : {
1397 593994138 : entree *ep = (entree *)operand;
1398 : GEN res;
1399 593994138 : sp-=2;
1400 593994138 : res = ((GEN (*)(GEN,GEN))ep->value)(gel(st,sp),gel(st,sp+1));
1401 593950778 : if (br_status) goto endeval;
1402 593950750 : gel(st,sp++)=res;
1403 593950750 : break;
1404 : }
1405 18775406 : case OCcalllong:
1406 : {
1407 18775406 : entree *ep = (entree *)operand;
1408 : long res;
1409 18775406 : EVAL_f(ep->value, long, res=);
1410 18774643 : if (br_status) goto endeval;
1411 18774643 : st[sp++] = res;
1412 18774643 : break;
1413 : }
1414 1703820 : case OCcallint:
1415 : {
1416 1703820 : entree *ep = (entree *)operand;
1417 : long res;
1418 1703820 : EVAL_f(ep->value, int, res=);
1419 1703610 : if (br_status) goto endeval;
1420 1703610 : st[sp++] = res;
1421 1703610 : break;
1422 : }
1423 49789139 : case OCcallvoid:
1424 : {
1425 49789139 : entree *ep = (entree *)operand;
1426 49789139 : EVAL_f(ep->value, void,(void));
1427 49788614 : if (br_status) goto endeval;
1428 49630053 : break;
1429 : }
1430 : #undef EVAL_f
1431 :
1432 35512221 : case OCcalluser:
1433 : {
1434 35512221 : long n=operand;
1435 35512221 : GEN fun = gel(st,sp-1-n);
1436 : long arity, isvar;
1437 : GEN z;
1438 35512221 : if (typ(fun)!=t_CLOSURE) pari_err(e_NOTFUNC, fun);
1439 35509512 : isvar = closure_is_variadic(fun);
1440 35509512 : arity = closure_arity(fun);
1441 35509512 : if (!isvar || n < arity)
1442 : {
1443 35509442 : st_alloc(arity-n);
1444 35509442 : if (n>arity)
1445 0 : pari_err(e_MISC,"too many parameters in user-defined function call");
1446 35536087 : for (j=n+1;j<=arity;j++)
1447 26645 : gel(st,sp++)=0;
1448 35509442 : if (isvar) gel(st,sp-1) = cgetg(1,t_VEC);
1449 : }
1450 : else
1451 : {
1452 : GEN v;
1453 70 : long j, m = n-arity+1;
1454 70 : v = cgetg(m+1,t_VEC);
1455 70 : sp-=m;
1456 301 : for (j=1; j<=m; j++)
1457 231 : gel(v,j) = gel(st,sp+j-1)? gcopy(gel(st,sp+j-1)): gen_0;
1458 70 : gel(st,sp++)=v;
1459 : }
1460 35509512 : z = closure_return(fun);
1461 35504767 : if (br_status) goto endeval;
1462 35504767 : gel(st, sp-1) = z;
1463 35504767 : break;
1464 : }
1465 43070170 : case OCnewframe:
1466 43070170 : if (operand>0) nbmvar+=operand;
1467 13 : else operand=-operand;
1468 43070170 : pari_stack_alloc(&s_var,operand);
1469 43070170 : s_var.n+=operand;
1470 123329849 : for(j=1;j<=operand;j++)
1471 : {
1472 80259679 : var[s_var.n-j].flag=PUSH_VAL;
1473 80259679 : var[s_var.n-j].value=gen_0;
1474 : }
1475 43070170 : break;
1476 7383 : case OCsaveframe:
1477 : {
1478 7383 : GEN cl = (operand?gcopy:shallowcopy)(gel(st,sp-1));
1479 7383 : GEN f = gel(cl, 7);
1480 7383 : long j, l = lg(f);
1481 7383 : GEN v = cgetg(l, t_VEC);
1482 79790 : for (j = 1; j < l; j++)
1483 72407 : if (signe(gel(f,l-j))==0)
1484 : {
1485 10423 : GEN val = var[s_var.n-j].value;
1486 10423 : gel(v,j) = operand?gcopy(val):val;
1487 : } else
1488 61984 : gel(v,j) = gnil;
1489 7383 : gel(cl,7) = v;
1490 7383 : gel(st,sp-1) = cl;
1491 : }
1492 7383 : break;
1493 112 : case OCpackargs:
1494 : {
1495 112 : GEN def = cgetg(operand+1, t_VECSMALL);
1496 112 : GEN args = cgetg(operand+1, t_VEC);
1497 112 : pari_stack_alloc(&s_var,operand);
1498 112 : sp-=operand;
1499 238 : for (j=0;j<operand;j++)
1500 : {
1501 126 : if (gel(st,sp+j))
1502 : {
1503 126 : gel(args,j+1) = gel(st,sp+j);
1504 126 : uel(def ,j+1) = 1;
1505 : }
1506 : else
1507 : {
1508 0 : gel(args,j+1) = gen_0;
1509 0 : uel(def ,j+1) = 0;
1510 : }
1511 : }
1512 112 : gel(st, sp++) = args;
1513 112 : gel(st, sp++) = def;
1514 112 : break;
1515 : }
1516 36564735 : case OCgetargs:
1517 36564735 : pari_stack_alloc(&s_var,operand);
1518 36564735 : s_var.n+=operand;
1519 36564735 : nbmvar+=operand;
1520 36564735 : sp-=operand;
1521 100268953 : for (j=0;j<operand;j++)
1522 : {
1523 63704218 : if (gel(st,sp+j))
1524 63695195 : pushlex(j-operand,gel(st,sp+j));
1525 : else
1526 : {
1527 9023 : var[s_var.n+j-operand].flag=DEFAULT_VAL;
1528 9023 : var[s_var.n+j-operand].value=gen_0;
1529 : }
1530 : }
1531 36564735 : break;
1532 49 : case OCcheckuserargs:
1533 105 : for (j=0; j<operand; j++)
1534 77 : if (var[s_var.n-operand+j].flag==DEFAULT_VAL)
1535 21 : pari_err(e_MISC,"missing mandatory argument"
1536 : " '%s' in user function",get_arg_name(C,j+1));
1537 28 : break;
1538 13935992 : case OCcheckargs:
1539 62529579 : for (j=sp-1;operand;operand>>=1UL,j--)
1540 48593587 : if ((operand&1L) && gel(st,j)==NULL)
1541 0 : pari_err(e_MISC,"missing mandatory argument");
1542 13935992 : break;
1543 441 : case OCcheckargs0:
1544 882 : for (j=sp-1;operand;operand>>=1UL,j--)
1545 441 : if ((operand&1L) && gel(st,j))
1546 0 : pari_err(e_MISC,"argument type not implemented");
1547 441 : break;
1548 23474 : case OCdefaultlong:
1549 23474 : sp--;
1550 23474 : if (st[sp+operand])
1551 1050 : st[sp+operand]=gtos(gel(st,sp+operand));
1552 : else
1553 22424 : st[sp+operand]=st[sp];
1554 23474 : break;
1555 0 : case OCdefaultulong:
1556 0 : sp--;
1557 0 : if (st[sp+operand])
1558 0 : st[sp+operand]=gtou(gel(st,sp+operand));
1559 : else
1560 0 : st[sp+operand]=st[sp];
1561 0 : break;
1562 0 : case OCdefaultgen:
1563 0 : sp--;
1564 0 : if (!st[sp+operand])
1565 0 : st[sp+operand]=st[sp];
1566 0 : break;
1567 21737309 : case OCvec:
1568 21737309 : gel(st,sp++)=cgetg(operand,t_VEC);
1569 21737309 : st[sp++]=avma;
1570 21737309 : break;
1571 5104 : case OCcol:
1572 5104 : gel(st,sp++)=cgetg(operand,t_COL);
1573 5104 : st[sp++]=avma;
1574 5104 : break;
1575 55985 : case OCmat:
1576 : {
1577 : GEN z;
1578 55985 : long l=st[sp-1];
1579 55985 : z=cgetg(operand,t_MAT);
1580 186645 : for(j=1;j<operand;j++)
1581 130660 : gel(z,j) = cgetg(l,t_COL);
1582 55985 : gel(st,sp-1) = z;
1583 55985 : st[sp++]=avma;
1584 : }
1585 55985 : break;
1586 83765549 : case OCpop:
1587 83765549 : sp-=operand;
1588 83765549 : break;
1589 31400847 : case OCdup:
1590 : {
1591 31400847 : long i, s=st[sp-1];
1592 31400847 : st_alloc(operand);
1593 62812229 : for(i=1;i<=operand;i++)
1594 31411382 : st[sp++]=s;
1595 : }
1596 31400847 : break;
1597 : }
1598 : }
1599 : if (0)
1600 : {
1601 295718 : endeval:
1602 295718 : sp = saved_sp;
1603 295718 : for( ; rp>saved_rp ; )
1604 : {
1605 0 : gp_pointer *g = &ptrs[--rp];
1606 0 : clone_unlock_deep(g->ox);
1607 : }
1608 : }
1609 282596047 : s_prec.n = saved_prec;
1610 282596047 : s_trace.n--;
1611 282596047 : restore_vars(nbmvar, nblvar, nblock);
1612 282596046 : clone_unlock(C);
1613 282596046 : }
1614 :
1615 : GEN
1616 34052505 : closure_evalgen(GEN C)
1617 : {
1618 34052505 : pari_sp ltop=avma;
1619 34052505 : closure_eval(C);
1620 34009255 : if (br_status) return gc_NULL(ltop);
1621 34009193 : return gc_upto(ltop,gel(st,--sp));
1622 : }
1623 :
1624 : long
1625 1040570 : evalstate_get_trace(void)
1626 1040570 : { return s_trace.n; }
1627 :
1628 : void
1629 18 : evalstate_set_trace(long lvl)
1630 18 : { s_trace.n = lvl; }
1631 :
1632 : void
1633 1432294 : evalstate_save(struct pari_evalstate *state)
1634 : {
1635 1432294 : state->avma = avma;
1636 1432294 : state->sp = sp;
1637 1432294 : state->rp = rp;
1638 1432294 : state->prec = s_prec.n;
1639 1432294 : state->var = s_var.n;
1640 1432294 : state->lvars= s_lvars.n;
1641 1432294 : state->locks= s_locks.n;
1642 1432294 : state->trace= s_trace.n;
1643 1432294 : compilestate_save(&state->comp);
1644 1432294 : mtstate_save(&state->mt);
1645 1432294 : }
1646 :
1647 : void
1648 56415 : evalstate_restore(struct pari_evalstate *state)
1649 : {
1650 56415 : set_avma(state->avma);
1651 56415 : mtstate_restore(&state->mt);
1652 56415 : sp = state->sp;
1653 56415 : rp = state->rp;
1654 56415 : s_prec.n = state->prec;
1655 56415 : restore_vars(s_var.n-state->var, s_lvars.n-state->lvars,
1656 56415 : s_locks.n-state->locks);
1657 56415 : restore_trace(s_trace.n-state->trace);
1658 56415 : reset_break();
1659 56415 : compilestate_restore(&state->comp);
1660 56415 : }
1661 :
1662 : GEN
1663 43250 : evalstate_restore_err(struct pari_evalstate *state)
1664 : {
1665 43250 : GENbin* err = copy_bin(pari_err_last());
1666 43250 : evalstate_restore(state);
1667 43250 : return bin_copy(err);
1668 : }
1669 :
1670 : void
1671 452 : evalstate_reset(void)
1672 : {
1673 452 : mtstate_reset();
1674 452 : restore_vars(s_var.n, s_lvars.n, s_locks.n);
1675 452 : sp = rp = dbg_level = s_trace.n = 0;
1676 452 : reset_break();
1677 452 : compilestate_reset();
1678 452 : parsestate_reset();
1679 452 : set_avma(pari_mainstack->top);
1680 452 : }
1681 :
1682 : void
1683 0 : evalstate_clone(void)
1684 : {
1685 : long i;
1686 0 : for (i = 1; i<=s_var.n; i++) copylex(-i);
1687 0 : lvar_make_safe();
1688 0 : for (i = 0; i< s_trace.n; i++)
1689 : {
1690 0 : GEN C = trace[i].closure;
1691 0 : if (isonstack(C)) trace[i].closure = gclone(C);
1692 : }
1693 0 : }
1694 :
1695 : GEN
1696 76030935 : closure_evalnobrk(GEN C)
1697 : {
1698 76030935 : pari_sp ltop=avma;
1699 76030935 : closure_eval(C);
1700 76030914 : if (br_status) pari_err(e_MISC, "break not allowed here");
1701 76030907 : return gc_upto(ltop,gel(st,--sp));
1702 : }
1703 :
1704 : void
1705 121137479 : closure_evalvoid(GEN C)
1706 : {
1707 121137479 : pari_sp ltop=avma;
1708 121137479 : closure_eval(C);
1709 121137396 : set_avma(ltop);
1710 121137396 : }
1711 :
1712 : GEN
1713 937237 : closure_evalres(GEN C)
1714 : {
1715 937237 : return closure_return(C);
1716 : }
1717 :
1718 : INLINE GEN
1719 14997766 : closure_returnupto(GEN C)
1720 : {
1721 14997766 : pari_sp av=avma;
1722 14997766 : return copyupto(closure_return(C),(GEN)av);
1723 : }
1724 :
1725 : GEN
1726 12 : pareval_worker(GEN C)
1727 : {
1728 12 : return closure_callgenall(C, 0);
1729 : }
1730 :
1731 : GEN
1732 6 : pareval(GEN C)
1733 : {
1734 6 : pari_sp av = avma;
1735 6 : long l = lg(C), i;
1736 : GEN worker;
1737 6 : if (!is_vec_t(typ(C))) pari_err_TYPE("pareval",C);
1738 18 : for (i=1; i<l; i++)
1739 12 : if (typ(gel(C,i))!=t_CLOSURE)
1740 0 : pari_err_TYPE("pareval",gel(C,i));
1741 6 : worker = snm_closure(is_entry("_pareval_worker"), NULL);
1742 6 : return gc_upto(av, gen_parapply(worker, C));
1743 : }
1744 :
1745 : GEN
1746 643 : parvector_worker(GEN i, GEN C)
1747 : {
1748 643 : return closure_callgen1(C, i);
1749 : }
1750 :
1751 : GEN
1752 87 : parmatrix_worker(GEN i, GEN j, GEN C)
1753 : {
1754 87 : return closure_callgen2(C, i, j);
1755 : }
1756 :
1757 : GEN
1758 9563 : parfor_worker(GEN i, GEN C)
1759 : {
1760 9563 : retmkvec2(gcopy(i), closure_callgen1(C, i));
1761 : }
1762 :
1763 : GEN
1764 13 : parmatrix(long n, long m, GEN code)
1765 : {
1766 13 : long i, pending = 0, workid, nm = n*m;
1767 13 : long a[] = {evaltyp(t_VEC) | _evallg(3), 0, 0};
1768 13 : long ai[] = {evaltyp(t_INT) | _evallg(3), evalsigne(1) | evallgefint(3), 0};
1769 13 : long aj[] = {evaltyp(t_INT) | _evallg(3), evalsigne(1) | evallgefint(3), 0};
1770 : GEN worker, M, done;
1771 : struct pari_mt pt;
1772 13 : if (m < 0) pari_err_DOMAIN("parmatrix", "nbcols", "<", gen_0, stoi(m));
1773 13 : if (n < 0) pari_err_DOMAIN("parmatrix", "nbrows", "<", gen_0, stoi(n));
1774 13 : worker = snm_closure(is_entry("_parmatrix_worker"), mkvec(code));
1775 13 : mt_queue_start_lim(&pt, worker, n);
1776 13 : gel(a,1) = ai;
1777 13 : gel(a,2) = aj;
1778 13 : M = cgetg(m+1, t_MAT);
1779 46 : for (i = 1; i <= m; i++)
1780 33 : gel(M,i) = cgetg(n+1, t_COL);
1781 104 : for (i = 0; i < nm || pending; i < nm ? i++: 0)
1782 : {
1783 91 : ai[2] = 1 + (i%n);
1784 91 : aj[2] = 1 + (i/n);
1785 91 : mt_queue_submit(&pt, i, i < nm ? a: NULL);
1786 91 : done = mt_queue_get(&pt, &workid, &pending);
1787 91 : if (done) gcoeff(M,1+(workid%n),1+(workid/n)) = done;
1788 : }
1789 13 : mt_queue_end(&pt);
1790 13 : return M;
1791 : }
1792 :
1793 : GEN
1794 31 : parvector(long n, GEN code)
1795 : {
1796 31 : long i, pending = 0, workid;
1797 31 : long a[] = {evaltyp(t_VEC) | _evallg(2), 0};
1798 31 : long ai[] = {evaltyp(t_INT) | _evallg(3), evalsigne(1) | evallgefint(3), 0};
1799 : GEN worker, V, done;
1800 : struct pari_mt pt;
1801 31 : if (n < 0) pari_err_DOMAIN("parvector", "dimension", "<", gen_0, stoi(n));
1802 31 : worker = snm_closure(is_entry("_parvector_worker"), mkvec(code));
1803 31 : mt_queue_start_lim(&pt, worker, n);
1804 31 : gel(a, 1) = ai;
1805 31 : V = cgetg(n+1, t_VEC);
1806 620 : for (i=1; i<=n || pending; i<=n ? i++: 0)
1807 : {
1808 595 : ai[2] = i;
1809 595 : mt_queue_submit(&pt, i, i<=n? a: NULL);
1810 591 : done = mt_queue_get(&pt, &workid, &pending);
1811 589 : if (done) gel(V,workid) = done;
1812 : }
1813 25 : mt_queue_end(&pt);
1814 25 : return V;
1815 : }
1816 :
1817 : /* suitable for gc_upto */
1818 : GEN
1819 7545 : parsum_slice_worker(GEN a, GEN b, GEN m, GEN worker)
1820 : {
1821 7545 : pari_sp av = avma;
1822 7545 : GEN s = gen_0;
1823 139846 : while (gcmp(a,b)<=0)
1824 : {
1825 132328 : s = gadd(s, closure_callgen1(worker, a));
1826 132301 : a = addii(a, m);
1827 132301 : if (gc_needed(av,1))
1828 : {
1829 0 : if (DEBUGMEM>1) pari_warn(warnmem,"parsum_slice");
1830 0 : (void)gc_all(av,2,&a,&s);
1831 : }
1832 : }
1833 7518 : return gc_upto(av,s);
1834 : }
1835 :
1836 : GEN
1837 2062 : parsum(GEN a, GEN b, GEN code)
1838 : {
1839 2062 : pari_sp av = avma;
1840 : GEN worker, mG, v, s, N;
1841 : long r, m, pending;
1842 : struct pari_mt pt;
1843 : pari_sp av2;
1844 :
1845 2062 : if (typ(a) != t_INT) pari_err_TYPE("parsum",a);
1846 2062 : if (gcmp(b,a) < 0) return gen_0;
1847 2062 : b = gfloor(b);
1848 2062 : N = addiu(subii(b, a), 1);
1849 2062 : mG = sqrti(N);
1850 2062 : m = itou(mG);
1851 2062 : worker = snm_closure(is_entry("_parsum_slice_worker"), mkvec3(b,mG,code));
1852 2062 : mt_queue_start_lim(&pt, worker, m);
1853 2062 : s = gen_0; a = setloop(a); v = mkvec(a); pending = 0; av2 = avma;
1854 12087 : for (r = 1; r <= m || pending; r++)
1855 : {
1856 : long workid;
1857 : GEN done;
1858 10046 : mt_queue_submit(&pt, 0, r <= m? v: NULL);
1859 10028 : done = mt_queue_get(&pt, &workid, &pending);
1860 10025 : if (done)
1861 : {
1862 7518 : s = gadd(s, done);
1863 7518 : if (gc_needed(av2,1))
1864 : {
1865 0 : if (DEBUGMEM>1) pari_warn(warnmem,"parsum");
1866 0 : s = gc_upto(av2,s);
1867 : }
1868 : }
1869 10025 : a = incloop(a); gel(v,1) = a;
1870 : }
1871 2041 : mt_queue_end(&pt); return gc_upto(av, s);
1872 : }
1873 :
1874 : void
1875 340 : parfor(GEN a, GEN b, GEN code, void *E, long call(void*, GEN, GEN))
1876 : {
1877 340 : pari_sp av = avma, av2;
1878 340 : long running, pending = 0, lim;
1879 340 : long status = br_NONE;
1880 340 : GEN worker = snm_closure(is_entry("_parfor_worker"), mkvec(code));
1881 340 : GEN done, stop = NULL;
1882 : struct pari_mt pt;
1883 340 : if (typ(a) != t_INT) pari_err_TYPE("parfor",a);
1884 340 : if (b)
1885 : {
1886 340 : if (gcmp(b,a) < 0) return;
1887 340 : if (typ(b) == t_INFINITY)
1888 : {
1889 6 : if (inf_get_sign(b) < 0) return;
1890 6 : b = NULL;
1891 : }
1892 : else
1893 334 : b = gfloor(b);
1894 : }
1895 340 : lim = b ? itos_or_0(subii(addis(b,1),a)): 0;
1896 340 : mt_queue_start_lim(&pt, worker, lim);
1897 340 : a = mkvec(setloop(a));
1898 340 : av2 = avma;
1899 7454 : while ((running = (!stop && (!b || cmpii(gel(a,1),b) <= 0))) || pending)
1900 : {
1901 7120 : mt_queue_submit(&pt, 0, running ? a: NULL);
1902 7116 : done = mt_queue_get(&pt, NULL, &pending);
1903 7114 : if (call && done && (!stop || cmpii(gel(done,1),stop) < 0))
1904 5455 : if (call(E, gel(done,1), gel(done,2)))
1905 : {
1906 223 : status = br_status;
1907 223 : br_status = br_NONE;
1908 223 : stop = gc_INT(av2, gel(done,1));
1909 : }
1910 7114 : gel(a,1) = incloop(gel(a,1));
1911 7114 : if (!stop) set_avma(av2);
1912 : }
1913 334 : set_avma(av2);
1914 334 : mt_queue_end(&pt);
1915 334 : br_status = status;
1916 334 : set_avma(av);
1917 : }
1918 :
1919 : static void
1920 0 : parforiter_init(struct parfor_iter *T, GEN code)
1921 : {
1922 0 : T->pending = 0;
1923 0 : T->worker = snm_closure(is_entry("_parfor_worker"), mkvec(code));
1924 0 : mt_queue_start(&T->pt, T->worker);
1925 0 : }
1926 :
1927 : static GEN
1928 0 : parforiter_next(struct parfor_iter *T, GEN v)
1929 : {
1930 0 : mt_queue_submit(&T->pt, 0, v);
1931 0 : return mt_queue_get(&T->pt, NULL, &T->pending);
1932 : }
1933 :
1934 : static void
1935 0 : parforiter_stop(struct parfor_iter *T)
1936 : {
1937 0 : while (T->pending)
1938 : {
1939 0 : mt_queue_submit(&T->pt, 0, NULL);
1940 0 : (void) mt_queue_get(&T->pt, NULL, &T->pending);
1941 : }
1942 0 : mt_queue_end(&T->pt);
1943 0 : }
1944 :
1945 : void
1946 0 : parfor_init(parfor_t *T, GEN a, GEN b, GEN code)
1947 : {
1948 0 : if (typ(a) != t_INT) pari_err_TYPE("parfor",a);
1949 0 : T->b = b ? gfloor(b): NULL;
1950 0 : T->a = mkvec(setloop(a));
1951 0 : parforiter_init(&T->iter, code);
1952 0 : }
1953 :
1954 : GEN
1955 0 : parfor_next(parfor_t *T)
1956 : {
1957 : long running;
1958 0 : while ((running=((!T->b || cmpii(gel(T->a,1),T->b) <= 0))) || T->iter.pending)
1959 : {
1960 0 : GEN done = parforiter_next(&T->iter, running ? T->a: NULL);
1961 0 : gel(T->a,1) = incloop(gel(T->a,1));
1962 0 : if (done) return done;
1963 : }
1964 0 : mt_queue_end(&T->iter.pt);
1965 0 : return NULL;
1966 : }
1967 :
1968 : void
1969 0 : parfor_stop(parfor_t *T) { parforiter_stop(&T->iter); }
1970 :
1971 : static long
1972 8471 : gp_evalvoid2(void *E, GEN x, GEN y)
1973 : {
1974 8471 : GEN code =(GEN) E;
1975 8471 : push_lex(x, code);
1976 8471 : push_lex(y, NULL);
1977 8471 : closure_evalvoid(code);
1978 8471 : pop_lex(2);
1979 8471 : return loop_break();
1980 : }
1981 :
1982 : void
1983 340 : parfor0(GEN a, GEN b, GEN code, GEN code2)
1984 : {
1985 340 : parfor(a, b, code, (void*)code2, code2 ? gp_evalvoid2: NULL);
1986 334 : }
1987 :
1988 : static int
1989 0 : negcmp(GEN x, GEN y) { return gcmp(y,x); }
1990 :
1991 : void
1992 39 : parforstep(GEN a, GEN b, GEN s, GEN code, void *E, long call(void*, GEN, GEN))
1993 : {
1994 39 : pari_sp av = avma, av2;
1995 39 : long running, pending = 0;
1996 39 : long status = br_NONE;
1997 39 : GEN worker = snm_closure(is_entry("_parfor_worker"), mkvec(code));
1998 39 : GEN done, stop = NULL;
1999 : struct pari_mt pt;
2000 : long i, ss;
2001 39 : GEN v = NULL, lim;
2002 : int (*cmp)(GEN,GEN);
2003 :
2004 39 : b = gcopy(b);
2005 39 : s = gcopy(s); av = avma;
2006 39 : switch(typ(s))
2007 : {
2008 13 : case t_VEC: case t_COL:
2009 : {
2010 13 : GEN vs = vecsum(s);
2011 13 : ss = gsigne(vs); v = s;
2012 0 : lim = typ(b)==t_INFINITY ? inf_get_sign(b)==ss
2013 0 : ? int2n(BITS_IN_LONG): gen_0
2014 13 : : gdiv(gmulgs(gadd(gsub(b,a),vs),lg(vs)-1),vs);
2015 13 : break;
2016 : }
2017 13 : case t_INTMOD:
2018 13 : if (typ(a) != t_INT) a = gceil(a);
2019 13 : a = addii(a, modii(subii(gel(s,2),a), gel(s,1)));
2020 13 : s = gel(s,1); /* FALL THROUGH */
2021 26 : default:
2022 26 : ss = gsigne(s);
2023 26 : lim = typ(b)==t_INFINITY ? inf_get_sign(b)==ss
2024 0 : ? int2n(BITS_IN_LONG): gen_0
2025 26 : : gdiv(gadd(gsub(b,a),s),s);
2026 : }
2027 39 : lim = ceil_safe(lim);
2028 39 : if (!ss || typ(lim)!=t_INT) pari_err_DOMAIN("parforstep","step","=",gen_0,s);
2029 39 : if (signe(lim)<=0) { set_avma(av); return; }
2030 39 : cmp = (ss > 0)? &gcmp: &negcmp;
2031 39 : i = 0;
2032 39 : a = mkvec(a);
2033 39 : mt_queue_start_lim(&pt, worker, itou_or_0(lim));
2034 39 : av2 = avma;
2035 2695 : while ((running = (!stop && (!b || cmp(gel(a,1),b) <= 0))) || pending)
2036 : {
2037 2656 : mt_queue_submit(&pt, 0, running ? a: NULL);
2038 2656 : done = mt_queue_get(&pt, NULL, &pending);
2039 2656 : if (call && done && (!stop || cmp(gel(done,1),stop) < 0))
2040 2521 : if (call(E, gel(done,1), gel(done,2)))
2041 : {
2042 0 : status = br_status;
2043 0 : br_status = br_NONE;
2044 0 : stop = gel(done,1);
2045 : }
2046 2656 : if (running)
2047 : {
2048 2521 : if (v)
2049 : {
2050 1637 : if (++i >= lg(v)) i = 1;
2051 1637 : s = gel(v,i);
2052 : }
2053 2521 : gel(a,1) = gadd(gel(a,1),s);
2054 2521 : if (!stop) gel(a,1) = gc_upto(av2, gel(a,1));
2055 : }
2056 : }
2057 39 : mt_queue_end(&pt);
2058 39 : br_status = status;
2059 39 : set_avma(av);
2060 : }
2061 :
2062 : void
2063 39 : parforstep0(GEN a, GEN b, GEN s, GEN code, GEN code2)
2064 : {
2065 39 : parforstep(a, b, s, code, (void*)code2, code2 ? gp_evalvoid2: NULL);
2066 39 : }
2067 :
2068 : void
2069 0 : parforstep_init(parforstep_t *T, GEN a, GEN b, GEN s, GEN code)
2070 : {
2071 : long ss;
2072 0 : if (typ(a) != t_INT) pari_err_TYPE("parfor",a);
2073 0 : switch(typ(s))
2074 : {
2075 0 : case t_VEC: case t_COL:
2076 0 : ss = gsigne(vecsum(s));
2077 0 : break;
2078 0 : case t_INTMOD:
2079 0 : if (typ(a) != t_INT) a = gceil(a);
2080 0 : a = addii(a, modii(subii(gel(s,2),a), gel(s,1)));
2081 0 : s = gel(s,1);
2082 0 : default: /* FALL THROUGH */
2083 0 : ss = gsigne(s);
2084 : }
2085 0 : T->cmp = (ss > 0)? &gcmp: &negcmp;
2086 0 : T->s = s;
2087 0 : T->i = 0;
2088 0 : T->b = b;
2089 0 : T->a = mkvec(a);
2090 0 : parforiter_init(&T->iter, code);
2091 0 : }
2092 :
2093 : GEN
2094 0 : parforstep_next(parforstep_t *T)
2095 : {
2096 : long running;
2097 0 : while ((running=((!T->b || T->cmp(gel(T->a,1),T->b) <= 0))) || T->iter.pending)
2098 : {
2099 0 : GEN done = parforiter_next(&T->iter, running ? T->a: NULL);
2100 0 : if (running)
2101 : {
2102 0 : if (is_vec_t(typ(T->s)))
2103 : {
2104 0 : if (++(T->i) >= lg(T->s)) T->i = 1;
2105 0 : gel(T->a,1) = gadd(gel(T->a,1), gel(T->s,T->i));
2106 : }
2107 0 : else gel(T->a,1) = gadd(gel(T->a,1), T->s);
2108 : }
2109 0 : if (done) return done;
2110 : }
2111 0 : mt_queue_end(&T->iter.pt);
2112 0 : return NULL;
2113 : }
2114 :
2115 : void
2116 0 : parforstep_stop(parforstep_t *T) { parforiter_stop(&T->iter); }
2117 :
2118 : void
2119 0 : parforprimestep_init(parforprime_t *T, GEN a, GEN b, GEN q, GEN code)
2120 : {
2121 0 : forprimestep_init(&T->forprime, a, b, q);
2122 0 : T->v = mkvec(gen_0);
2123 0 : parforiter_init(&T->iter, code);
2124 0 : }
2125 :
2126 : void
2127 0 : parforprime_init(parforprime_t *T, GEN a, GEN b, GEN code)
2128 0 : { parforprimestep_init(T, a, b, NULL, code); }
2129 :
2130 : GEN
2131 0 : parforprime_next(parforprime_t *T)
2132 : {
2133 : long running;
2134 0 : while ((running = !!forprime_next(&T->forprime)) || T->iter.pending)
2135 : {
2136 : GEN done;
2137 0 : gel(T->v, 1) = T->forprime.pp;
2138 0 : done = parforiter_next(&T->iter, running ? T->v: NULL);
2139 0 : if (done) return done;
2140 : }
2141 0 : mt_queue_end(&T->iter.pt);
2142 0 : return NULL;
2143 : }
2144 :
2145 : void
2146 0 : parforprime_stop(parforprime_t *T) { parforiter_stop(&T->iter); }
2147 :
2148 : void
2149 20 : parforprimestep(GEN a, GEN b, GEN q, GEN code, void *E, long call(void*, GEN, GEN))
2150 : {
2151 20 : pari_sp av = avma, av2;
2152 20 : long running, pending = 0;
2153 20 : long status = br_NONE;
2154 20 : GEN worker = snm_closure(is_entry("_parfor_worker"), mkvec(code));
2155 20 : GEN v, done, stop = NULL;
2156 : struct pari_mt pt;
2157 : forprime_t T;
2158 :
2159 20 : if (!forprimestep_init(&T, a,b,q)) { set_avma(av); return; }
2160 20 : mt_queue_start(&pt, worker);
2161 20 : v = mkvec(gen_0);
2162 20 : av2 = avma;
2163 172 : while ((running = (!stop && forprime_next(&T))) || pending)
2164 : {
2165 152 : gel(v, 1) = T.pp;
2166 152 : mt_queue_submit(&pt, 0, running ? v: NULL);
2167 152 : done = mt_queue_get(&pt, NULL, &pending);
2168 152 : if (call && done && (!stop || cmpii(gel(done,1),stop) < 0))
2169 125 : if (call(E, gel(done,1), gel(done,2)))
2170 : {
2171 0 : status = br_status;
2172 0 : br_status = br_NONE;
2173 0 : stop = gc_INT(av2, gel(done,1));
2174 : }
2175 152 : if (!stop) set_avma(av2);
2176 : }
2177 20 : set_avma(av2);
2178 20 : mt_queue_end(&pt);
2179 20 : br_status = status;
2180 20 : set_avma(av);
2181 : }
2182 :
2183 : void
2184 13 : parforprime(GEN a, GEN b, GEN code, void *E, long call(void*, GEN, GEN))
2185 : {
2186 13 : parforprimestep(a, b, NULL, code, E, call);
2187 13 : }
2188 :
2189 : void
2190 13 : parforprime0(GEN a, GEN b, GEN code, GEN code2)
2191 : {
2192 13 : parforprime(a, b, code, (void*)code2, code2? gp_evalvoid2: NULL);
2193 13 : }
2194 :
2195 : void
2196 7 : parforprimestep0(GEN a, GEN b, GEN q, GEN code, GEN code2)
2197 : {
2198 7 : parforprimestep(a, b, q, code, (void*)code2, code2? gp_evalvoid2: NULL);
2199 7 : }
2200 :
2201 : void
2202 0 : parforvec_init(parforvec_t *T, GEN x, GEN code, long flag)
2203 : {
2204 0 : forvec_init(&T->forvec, x, flag);
2205 0 : T->v = mkvec(gen_0); T->running = 1;
2206 0 : parforiter_init(&T->iter, code);
2207 0 : }
2208 :
2209 : GEN
2210 0 : parforvec_next(parforvec_t *T)
2211 : {
2212 0 : GEN v = NULL;
2213 0 : while ((T->running && (v = forvec_next(&T->forvec))) || T->iter.pending)
2214 : {
2215 : GEN done;
2216 0 : if (!v) T->running = 0;
2217 0 : else if (T->running) gel(T->v, 1) = v;
2218 0 : done = parforiter_next(&T->iter, v ? T->v: NULL);
2219 0 : if (done) return done;
2220 : }
2221 0 : mt_queue_end(&T->iter.pt);
2222 0 : return NULL;
2223 : }
2224 :
2225 : void
2226 0 : parforvec_stop(parforvec_t *T) { parforiter_stop(&T->iter); }
2227 :
2228 : void
2229 39 : parforvec(GEN x, GEN code, long flag, void *E, long call(void*, GEN, GEN))
2230 : {
2231 39 : pari_sp av = avma, av2;
2232 39 : long running, pending = 0;
2233 39 : long status = br_NONE;
2234 39 : GEN worker = snm_closure(is_entry("_parfor_worker"), mkvec(code));
2235 39 : GEN done, stop = NULL;
2236 : struct pari_mt pt;
2237 : forvec_t T;
2238 39 : GEN a, v = gen_0;
2239 :
2240 39 : if (!forvec_init(&T, x, flag)) { set_avma(av); return; }
2241 39 : mt_queue_start(&pt, worker);
2242 39 : a = mkvec(gen_0);
2243 39 : av2 = avma;
2244 415 : while ((running = (!stop && v && (v = forvec_next(&T)))) || pending)
2245 : {
2246 376 : gel(a, 1) = v;
2247 376 : mt_queue_submit(&pt, 0, running ? a: NULL);
2248 376 : done = mt_queue_get(&pt, NULL, &pending);
2249 376 : if (call && done && (!stop || lexcmp(gel(done,1),stop) < 0))
2250 300 : if (call(E, gel(done,1), gel(done,2)))
2251 : {
2252 0 : status = br_status;
2253 0 : br_status = br_NONE;
2254 0 : stop = gc_GEN(av2, gel(done,1));
2255 : }
2256 376 : if (!stop) set_avma(av2);
2257 : }
2258 39 : set_avma(av2);
2259 39 : mt_queue_end(&pt);
2260 39 : br_status = status;
2261 39 : set_avma(av);
2262 : }
2263 :
2264 : void
2265 39 : parforvec0(GEN x, GEN code, GEN code2, long flag)
2266 : {
2267 39 : parforvec(x, code, flag, (void*)code2, code2? gp_evalvoid2: NULL);
2268 39 : }
2269 :
2270 : void
2271 0 : parforeach_init(parforeach_t *T, GEN x, GEN code)
2272 : {
2273 0 : switch(typ(x))
2274 : {
2275 0 : case t_LIST:
2276 0 : x = list_data(x); /* FALL THROUGH */
2277 0 : if (!x) return;
2278 : case t_MAT: case t_VEC: case t_COL:
2279 0 : break;
2280 0 : default:
2281 0 : pari_err_TYPE("foreach",x);
2282 : return; /*LCOV_EXCL_LINE*/
2283 : }
2284 0 : T->x = x; T->i = 1; T->l = lg(x);
2285 0 : T->W = mkvec(gen_0);
2286 0 : T->iter.pending = 0;
2287 0 : T->iter.worker = snm_closure(is_entry("_parvector_worker"), mkvec(code));
2288 0 : mt_queue_start(&T->iter.pt, T->iter.worker);
2289 : }
2290 :
2291 : GEN
2292 0 : parforeach_next(parforeach_t *T)
2293 : {
2294 0 : while (T->i < T->l || T->iter.pending)
2295 : {
2296 : GEN done;
2297 : long workid;
2298 0 : if (T->i < T->l) gel(T->W,1) = gel(T->x, T->i);
2299 0 : mt_queue_submit(&T->iter.pt, T->i, T->i < T->l ? T->W: NULL);
2300 0 : T->i = minss(T->i+1, T->l);
2301 0 : done = mt_queue_get(&T->iter.pt, &workid, &T->iter.pending);
2302 0 : if (done) return mkvec2(gel(T->x,workid),done);
2303 : }
2304 0 : mt_queue_end(&T->iter.pt);
2305 0 : return NULL;
2306 : }
2307 :
2308 : void
2309 0 : parforeach_stop(parforeach_t *T) { parforiter_stop(&T->iter); }
2310 :
2311 : void
2312 14 : parforeach(GEN x, GEN code, void *E, long call(void*, GEN, GEN))
2313 : {
2314 14 : pari_sp av = avma, av2;
2315 14 : long pending = 0, n, i, stop = 0;
2316 14 : long status = br_NONE, workid;
2317 14 : GEN worker = snm_closure(is_entry("_parvector_worker"), mkvec(code));
2318 : GEN done, W;
2319 : struct pari_mt pt;
2320 14 : switch(typ(x))
2321 : {
2322 0 : case t_LIST:
2323 0 : x = list_data(x); /* FALL THROUGH */
2324 0 : if (!x) return;
2325 : case t_MAT: case t_VEC: case t_COL:
2326 14 : break;
2327 0 : default:
2328 0 : pari_err_TYPE("foreach",x);
2329 : return; /*LCOV_EXCL_LINE*/
2330 : }
2331 14 : clone_lock(x); n = lg(x)-1;
2332 14 : mt_queue_start_lim(&pt, worker, n);
2333 14 : W = cgetg(2, t_VEC);
2334 14 : av2 = avma;
2335 91 : for (i=1; i<=n || pending; i++)
2336 : {
2337 77 : if (!stop && i <= n) gel(W,1) = gel(x,i);
2338 77 : mt_queue_submit(&pt, i, !stop && i<=n? W: NULL);
2339 77 : done = mt_queue_get(&pt, &workid, &pending);
2340 77 : if (call && done && (!stop || workid < stop))
2341 70 : if (call(E, gel(x, workid), done))
2342 : {
2343 0 : status = br_status;
2344 0 : br_status = br_NONE;
2345 0 : stop = workid;
2346 : }
2347 77 : if (!stop) set_avma(av2);
2348 : }
2349 14 : set_avma(av2);
2350 14 : mt_queue_end(&pt);
2351 14 : clone_unlock_deep(x);
2352 14 : br_status = status;
2353 14 : set_avma(av);
2354 : }
2355 :
2356 : void
2357 14 : parforeach0(GEN x, GEN code, GEN code2)
2358 : {
2359 14 : parforeach(x, code, (void*)code2, code2? gp_evalvoid2: NULL);
2360 14 : }
2361 :
2362 : void
2363 0 : closure_callvoid1(GEN C, GEN x)
2364 : {
2365 0 : long i, ar = closure_arity(C);
2366 0 : gel(st,sp++) = x;
2367 0 : for(i=2; i <= ar; i++) gel(st,sp++) = NULL;
2368 0 : closure_evalvoid(C);
2369 0 : }
2370 :
2371 : GEN
2372 7 : closure_callgen0(GEN C)
2373 : {
2374 : GEN z;
2375 7 : long i, ar = closure_arity(C);
2376 7 : for(i=1; i<= ar; i++) gel(st,sp++) = NULL;
2377 7 : z = closure_returnupto(C);
2378 7 : return z;
2379 : }
2380 :
2381 : GEN
2382 421 : closure_callgen0prec(GEN C, long prec)
2383 : {
2384 : GEN z;
2385 421 : long i, ar = closure_arity(C);
2386 421 : for(i=1; i<= ar; i++) gel(st,sp++) = NULL;
2387 421 : push_localprec(prec);
2388 421 : z = closure_returnupto(C);
2389 421 : pop_localprec();
2390 421 : return z;
2391 : }
2392 :
2393 : GEN
2394 9598962 : closure_callgen1(GEN C, GEN x)
2395 : {
2396 9598962 : long i, ar = closure_arity(C);
2397 9598962 : gel(st,sp++) = x;
2398 9688681 : for(i=2; i<= ar; i++) gel(st,sp++) = NULL;
2399 9598962 : return closure_returnupto(C);
2400 : }
2401 :
2402 : GEN
2403 76681 : closure_callgen1prec(GEN C, GEN x, long prec)
2404 : {
2405 : GEN z;
2406 76681 : long i, ar = closure_arity(C);
2407 76681 : gel(st,sp++) = x;
2408 76695 : for(i=2; i<= ar; i++) gel(st,sp++) = NULL;
2409 76681 : push_localprec(prec);
2410 76681 : z = closure_returnupto(C);
2411 76681 : pop_localprec();
2412 76681 : return z;
2413 : }
2414 :
2415 : GEN
2416 67118 : closure_callgen2(GEN C, GEN x, GEN y)
2417 : {
2418 67118 : long i, ar = closure_arity(C);
2419 67118 : st_alloc(ar);
2420 67118 : gel(st,sp++) = x;
2421 67118 : gel(st,sp++) = y;
2422 67118 : for(i=3; i<=ar; i++) gel(st,sp++) = NULL;
2423 67118 : return closure_returnupto(C);
2424 : }
2425 :
2426 : GEN
2427 5254236 : closure_callgenvec(GEN C, GEN args)
2428 : {
2429 5254236 : long ar = closure_arity(C), isvar = closure_is_variadic(C);
2430 5254236 : long i, l = lg(args)-1;
2431 5254236 : st_alloc(ar);
2432 5254236 : if (l > ar)
2433 0 : pari_err(e_MISC,"too many parameters in user-defined function call");
2434 5254236 : if (closure_is_variadic(C) && l==ar && typ(gel(args,l))!=t_VEC)
2435 7 : pari_err_TYPE("call", gel(args,l));
2436 10552914 : for (i = 1; i <= l; i++) gel(st,sp++) = gel(args,i);
2437 5266260 : for( ; i <= ar; i++) gel(st,sp++) = NULL;
2438 5254229 : if (isvar && l<ar) gel(st,sp-1) = cgetg(1,t_VEC);
2439 5254229 : return closure_returnupto(C);
2440 : }
2441 :
2442 : GEN
2443 0 : closure_callgenvecprec(GEN C, GEN args, long prec)
2444 : {
2445 : GEN z;
2446 0 : push_localprec(prec);
2447 0 : z = closure_callgenvec(C, args);
2448 0 : pop_localprec();
2449 0 : return z;
2450 : }
2451 :
2452 : GEN
2453 336 : closure_callgenvecdef(GEN C, GEN args, GEN def)
2454 : {
2455 336 : long i, l = lg(args)-1, ar = closure_arity(C);
2456 336 : st_alloc(ar);
2457 336 : if (l > ar)
2458 0 : pari_err(e_MISC,"too many parameters in user-defined function call");
2459 336 : if (closure_is_variadic(C) && l==ar && typ(gel(args,l))!=t_VEC)
2460 0 : pari_err_TYPE("call", gel(args,l));
2461 700 : for (i = 1; i <= l; i++) gel(st,sp++) = def[i] ? gel(args,i): NULL;
2462 336 : for( ; i <= ar; i++) gel(st,sp++) = NULL;
2463 336 : return closure_returnupto(C);
2464 : }
2465 :
2466 : GEN
2467 336 : closure_callgenvecdefprec(GEN C, GEN args, GEN def, long prec)
2468 : {
2469 : GEN z;
2470 336 : push_localprec(prec);
2471 336 : z = closure_callgenvecdef(C, args, def);
2472 336 : pop_localprec();
2473 336 : return z;
2474 : }
2475 : GEN
2476 12 : closure_callgenall(GEN C, long n, ...)
2477 : {
2478 : va_list ap;
2479 12 : long i, ar = closure_arity(C);
2480 12 : va_start(ap,n);
2481 12 : if (n > ar)
2482 0 : pari_err(e_MISC,"too many parameters in user-defined function call");
2483 12 : st_alloc(ar);
2484 12 : for (i = 1; i <=n; i++) gel(st,sp++) = va_arg(ap, GEN);
2485 12 : for( ; i <=ar; i++) gel(st,sp++) = NULL;
2486 12 : va_end(ap);
2487 12 : return closure_returnupto(C);
2488 : }
2489 :
2490 : GEN
2491 39693078 : gp_eval(void *E, GEN x)
2492 : {
2493 39693078 : GEN code = (GEN)E;
2494 39693078 : set_lex(-1,x);
2495 39693078 : return closure_evalnobrk(code);
2496 : }
2497 :
2498 : GEN
2499 2053896 : gp_evalupto(void *E, GEN x)
2500 : {
2501 2053896 : pari_sp av = avma;
2502 2053896 : return copyupto(gp_eval(E,x), (GEN)av);
2503 : }
2504 :
2505 : GEN
2506 20734 : gp_evalprec(void *E, GEN x, long prec)
2507 : {
2508 : GEN z;
2509 20734 : push_localprec(prec);
2510 20734 : z = gp_eval(E, x);
2511 20734 : pop_localprec();
2512 20734 : return z;
2513 : }
2514 :
2515 : long
2516 26166301 : gp_evalbool(void *E, GEN x)
2517 26166301 : { pari_sp av = avma; return gc_long(av, !gequal0(gp_eval(E,x))); }
2518 :
2519 : long
2520 4146639 : gp_evalvoid(void *E, GEN x)
2521 : {
2522 4146639 : GEN code = (GEN)E;
2523 4146639 : set_lex(-1,x);
2524 4146639 : closure_evalvoid(code);
2525 4146639 : return loop_break();
2526 : }
2527 :
2528 : GEN
2529 114479 : gp_call(void *E, GEN x)
2530 : {
2531 114479 : GEN code = (GEN)E;
2532 114479 : return closure_callgen1(code, x);
2533 : }
2534 :
2535 : GEN
2536 23478 : gp_callprec(void *E, GEN x, long prec)
2537 : {
2538 23478 : GEN code = (GEN)E;
2539 23478 : return closure_callgen1prec(code, x, prec);
2540 : }
2541 :
2542 : GEN
2543 91 : gp_call2(void *E, GEN x, GEN y)
2544 : {
2545 91 : GEN code = (GEN)E;
2546 91 : return closure_callgen2(code, x, y);
2547 : }
2548 :
2549 : long
2550 872130 : gp_callbool(void *E, GEN x)
2551 : {
2552 872130 : pari_sp av = avma;
2553 872130 : GEN code = (GEN)E;
2554 872130 : return gc_long(av, !gequal0(closure_callgen1(code, x)));
2555 : }
2556 :
2557 : long
2558 0 : gp_callvoid(void *E, GEN x)
2559 : {
2560 0 : GEN code = (GEN)E;
2561 0 : closure_callvoid1(code, x);
2562 0 : return loop_break();
2563 : }
2564 :
2565 : INLINE const char *
2566 0 : disassemble_cast(long mode)
2567 : {
2568 0 : switch (mode)
2569 : {
2570 0 : case Gsmall:
2571 0 : return "small";
2572 0 : case Ggen:
2573 0 : return "gen";
2574 0 : case Gvar:
2575 0 : return "var";
2576 0 : case Gvoid:
2577 0 : return "void";
2578 0 : default:
2579 0 : return "unknown";
2580 : }
2581 : }
2582 :
2583 : void
2584 0 : closure_disassemble(GEN C)
2585 : {
2586 : const char * code;
2587 : GEN oper;
2588 : long i;
2589 0 : if (typ(C)!=t_CLOSURE) pari_err_TYPE("disassemble",C);
2590 0 : code=closure_codestr(C);
2591 0 : oper=closure_get_oper(C);
2592 0 : for(i=1;i<lg(oper);i++)
2593 : {
2594 0 : op_code opcode=(op_code) code[i];
2595 0 : long operand=oper[i];
2596 0 : pari_printf("%05ld\t",i);
2597 0 : switch(opcode)
2598 : {
2599 0 : case OCpushlong:
2600 0 : pari_printf("pushlong\t%ld\n",operand);
2601 0 : break;
2602 0 : case OCpushgnil:
2603 0 : pari_printf("pushgnil\n");
2604 0 : break;
2605 0 : case OCpushgen:
2606 0 : pari_printf("pushgen\t\t%ld\n",operand);
2607 0 : break;
2608 0 : case OCpushreal:
2609 0 : pari_printf("pushreal\t%ld\n",operand);
2610 0 : break;
2611 0 : case OCpushstoi:
2612 0 : pari_printf("pushstoi\t%ld\n",operand);
2613 0 : break;
2614 0 : case OCpushvar:
2615 : {
2616 0 : entree *ep = (entree *)operand;
2617 0 : pari_printf("pushvar\t%s\n",ep->name);
2618 0 : break;
2619 : }
2620 0 : case OCpushdyn:
2621 : {
2622 0 : entree *ep = (entree *)operand;
2623 0 : pari_printf("pushdyn\t\t%s\n",ep->name);
2624 0 : break;
2625 : }
2626 0 : case OCpushlex:
2627 0 : pari_printf("pushlex\t\t%ld\n",operand);
2628 0 : break;
2629 0 : case OCstoredyn:
2630 : {
2631 0 : entree *ep = (entree *)operand;
2632 0 : pari_printf("storedyn\t%s\n",ep->name);
2633 0 : break;
2634 : }
2635 0 : case OCstorelex:
2636 0 : pari_printf("storelex\t%ld\n",operand);
2637 0 : break;
2638 0 : case OCstoreptr:
2639 0 : pari_printf("storeptr\n");
2640 0 : break;
2641 0 : case OCsimpleptrdyn:
2642 : {
2643 0 : entree *ep = (entree *)operand;
2644 0 : pari_printf("simpleptrdyn\t%s\n",ep->name);
2645 0 : break;
2646 : }
2647 0 : case OCsimpleptrlex:
2648 0 : pari_printf("simpleptrlex\t%ld\n",operand);
2649 0 : break;
2650 0 : case OCnewptrdyn:
2651 : {
2652 0 : entree *ep = (entree *)operand;
2653 0 : pari_printf("newptrdyn\t%s\n",ep->name);
2654 0 : break;
2655 : }
2656 0 : case OCnewptrlex:
2657 0 : pari_printf("newptrlex\t%ld\n",operand);
2658 0 : break;
2659 0 : case OCpushptr:
2660 0 : pari_printf("pushptr\n");
2661 0 : break;
2662 0 : case OCstackgen:
2663 0 : pari_printf("stackgen\t%ld\n",operand);
2664 0 : break;
2665 0 : case OCendptr:
2666 0 : pari_printf("endptr\t\t%ld\n",operand);
2667 0 : break;
2668 0 : case OCprecreal:
2669 0 : pari_printf("precreal\n");
2670 0 : break;
2671 0 : case OCbitprecreal:
2672 0 : pari_printf("bitprecreal\n");
2673 0 : break;
2674 0 : case OCprecdl:
2675 0 : pari_printf("precdl\n");
2676 0 : break;
2677 0 : case OCstoi:
2678 0 : pari_printf("stoi\n");
2679 0 : break;
2680 0 : case OCutoi:
2681 0 : pari_printf("utoi\n");
2682 0 : break;
2683 0 : case OCitos:
2684 0 : pari_printf("itos\t\t%ld\n",operand);
2685 0 : break;
2686 0 : case OCitou:
2687 0 : pari_printf("itou\t\t%ld\n",operand);
2688 0 : break;
2689 0 : case OCtostr:
2690 0 : pari_printf("tostr\t\t%ld\n",operand);
2691 0 : break;
2692 0 : case OCvarn:
2693 0 : pari_printf("varn\t\t%ld\n",operand);
2694 0 : break;
2695 0 : case OCcopy:
2696 0 : pari_printf("copy\n");
2697 0 : break;
2698 0 : case OCcopyifclone:
2699 0 : pari_printf("copyifclone\n");
2700 0 : break;
2701 0 : case OCcompo1:
2702 0 : pari_printf("compo1\t\t%s\n",disassemble_cast(operand));
2703 0 : break;
2704 0 : case OCcompo1ptr:
2705 0 : pari_printf("compo1ptr\n");
2706 0 : break;
2707 0 : case OCcompo2:
2708 0 : pari_printf("compo2\t\t%s\n",disassemble_cast(operand));
2709 0 : break;
2710 0 : case OCcompo2ptr:
2711 0 : pari_printf("compo2ptr\n");
2712 0 : break;
2713 0 : case OCcompoC:
2714 0 : pari_printf("compoC\n");
2715 0 : break;
2716 0 : case OCcompoCptr:
2717 0 : pari_printf("compoCptr\n");
2718 0 : break;
2719 0 : case OCcompoL:
2720 0 : pari_printf("compoL\n");
2721 0 : break;
2722 0 : case OCcompoLptr:
2723 0 : pari_printf("compoLptr\n");
2724 0 : break;
2725 0 : case OCcheckargs:
2726 0 : pari_printf("checkargs\t0x%lx\n",operand);
2727 0 : break;
2728 0 : case OCcheckargs0:
2729 0 : pari_printf("checkargs0\t0x%lx\n",operand);
2730 0 : break;
2731 0 : case OCcheckuserargs:
2732 0 : pari_printf("checkuserargs\t%ld\n",operand);
2733 0 : break;
2734 0 : case OCdefaultlong:
2735 0 : pari_printf("defaultlong\t%ld\n",operand);
2736 0 : break;
2737 0 : case OCdefaultulong:
2738 0 : pari_printf("defaultulong\t%ld\n",operand);
2739 0 : break;
2740 0 : case OCdefaultgen:
2741 0 : pari_printf("defaultgen\t%ld\n",operand);
2742 0 : break;
2743 0 : case OCpackargs:
2744 0 : pari_printf("packargs\t%ld\n",operand);
2745 0 : break;
2746 0 : case OCgetargs:
2747 0 : pari_printf("getargs\t\t%ld\n",operand);
2748 0 : break;
2749 0 : case OCdefaultarg:
2750 0 : pari_printf("defaultarg\t%ld\n",operand);
2751 0 : break;
2752 0 : case OClocalvar:
2753 : {
2754 0 : entree *ep = (entree *)operand;
2755 0 : pari_printf("localvar\t%s\n",ep->name);
2756 0 : break;
2757 : }
2758 0 : case OClocalvar0:
2759 : {
2760 0 : entree *ep = (entree *)operand;
2761 0 : pari_printf("localvar0\t%s\n",ep->name);
2762 0 : break;
2763 : }
2764 0 : case OCexportvar:
2765 : {
2766 0 : entree *ep = (entree *)operand;
2767 0 : pari_printf("exportvar\t%s\n",ep->name);
2768 0 : break;
2769 : }
2770 0 : case OCunexportvar:
2771 : {
2772 0 : entree *ep = (entree *)operand;
2773 0 : pari_printf("unexportvar\t%s\n",ep->name);
2774 0 : break;
2775 : }
2776 0 : case OCcallgen:
2777 : {
2778 0 : entree *ep = (entree *)operand;
2779 0 : pari_printf("callgen\t\t%s\n",ep->name);
2780 0 : break;
2781 : }
2782 0 : case OCcallgen2:
2783 : {
2784 0 : entree *ep = (entree *)operand;
2785 0 : pari_printf("callgen2\t%s\n",ep->name);
2786 0 : break;
2787 : }
2788 0 : case OCcalllong:
2789 : {
2790 0 : entree *ep = (entree *)operand;
2791 0 : pari_printf("calllong\t%s\n",ep->name);
2792 0 : break;
2793 : }
2794 0 : case OCcallint:
2795 : {
2796 0 : entree *ep = (entree *)operand;
2797 0 : pari_printf("callint\t\t%s\n",ep->name);
2798 0 : break;
2799 : }
2800 0 : case OCcallvoid:
2801 : {
2802 0 : entree *ep = (entree *)operand;
2803 0 : pari_printf("callvoid\t%s\n",ep->name);
2804 0 : break;
2805 : }
2806 0 : case OCcalluser:
2807 0 : pari_printf("calluser\t%ld\n",operand);
2808 0 : break;
2809 0 : case OCvec:
2810 0 : pari_printf("vec\t\t%ld\n",operand);
2811 0 : break;
2812 0 : case OCcol:
2813 0 : pari_printf("col\t\t%ld\n",operand);
2814 0 : break;
2815 0 : case OCmat:
2816 0 : pari_printf("mat\t\t%ld\n",operand);
2817 0 : break;
2818 0 : case OCnewframe:
2819 0 : pari_printf("newframe\t%ld\n",operand);
2820 0 : break;
2821 0 : case OCsaveframe:
2822 0 : pari_printf("saveframe\t%ld\n", operand);
2823 0 : break;
2824 0 : case OCpop:
2825 0 : pari_printf("pop\t\t%ld\n",operand);
2826 0 : break;
2827 0 : case OCdup:
2828 0 : pari_printf("dup\t\t%ld\n",operand);
2829 0 : break;
2830 0 : case OCavma:
2831 0 : pari_printf("avma\n",operand);
2832 0 : break;
2833 0 : case OCgc:
2834 0 : pari_printf("gc\n",operand);
2835 0 : break;
2836 0 : case OCcowvardyn:
2837 : {
2838 0 : entree *ep = (entree *)operand;
2839 0 : pari_printf("cowvardyn\t%s\n",ep->name);
2840 0 : break;
2841 : }
2842 0 : case OCcowvarlex:
2843 0 : pari_printf("cowvarlex\t%ld\n",operand);
2844 0 : break;
2845 0 : case OCsetref:
2846 0 : pari_printf("setref\t\t%ld\n",operand);
2847 0 : break;
2848 0 : case OClock:
2849 0 : pari_printf("lock\t\t%ld\n",operand);
2850 0 : break;
2851 0 : case OCevalmnem:
2852 : {
2853 0 : entree *ep = (entree *)operand;
2854 0 : pari_printf("evalmnem\t%s\n",ep->name);
2855 0 : break;
2856 : }
2857 : }
2858 : }
2859 0 : }
2860 :
2861 : static int
2862 0 : opcode_need_relink(op_code opcode)
2863 : {
2864 0 : switch(opcode)
2865 : {
2866 0 : case OCpushlong:
2867 : case OCpushgen:
2868 : case OCpushgnil:
2869 : case OCpushreal:
2870 : case OCpushstoi:
2871 : case OCpushlex:
2872 : case OCstorelex:
2873 : case OCstoreptr:
2874 : case OCsimpleptrlex:
2875 : case OCnewptrlex:
2876 : case OCpushptr:
2877 : case OCstackgen:
2878 : case OCendptr:
2879 : case OCprecreal:
2880 : case OCbitprecreal:
2881 : case OCprecdl:
2882 : case OCstoi:
2883 : case OCutoi:
2884 : case OCitos:
2885 : case OCitou:
2886 : case OCtostr:
2887 : case OCvarn:
2888 : case OCcopy:
2889 : case OCcopyifclone:
2890 : case OCcompo1:
2891 : case OCcompo1ptr:
2892 : case OCcompo2:
2893 : case OCcompo2ptr:
2894 : case OCcompoC:
2895 : case OCcompoCptr:
2896 : case OCcompoL:
2897 : case OCcompoLptr:
2898 : case OCcheckargs:
2899 : case OCcheckargs0:
2900 : case OCcheckuserargs:
2901 : case OCpackargs:
2902 : case OCgetargs:
2903 : case OCdefaultarg:
2904 : case OCdefaultgen:
2905 : case OCdefaultlong:
2906 : case OCdefaultulong:
2907 : case OCcalluser:
2908 : case OCvec:
2909 : case OCcol:
2910 : case OCmat:
2911 : case OCnewframe:
2912 : case OCsaveframe:
2913 : case OCdup:
2914 : case OCpop:
2915 : case OCavma:
2916 : case OCgc:
2917 : case OCcowvarlex:
2918 : case OCsetref:
2919 : case OClock:
2920 0 : break;
2921 0 : case OCpushvar:
2922 : case OCpushdyn:
2923 : case OCstoredyn:
2924 : case OCsimpleptrdyn:
2925 : case OCnewptrdyn:
2926 : case OClocalvar:
2927 : case OClocalvar0:
2928 : case OCexportvar:
2929 : case OCunexportvar:
2930 : case OCcallgen:
2931 : case OCcallgen2:
2932 : case OCcalllong:
2933 : case OCcallint:
2934 : case OCcallvoid:
2935 : case OCcowvardyn:
2936 : case OCevalmnem:
2937 0 : return 1;
2938 : }
2939 0 : return 0;
2940 : }
2941 :
2942 : static void
2943 0 : closure_relink(GEN C, hashtable *table)
2944 : {
2945 0 : const char *code = closure_codestr(C);
2946 0 : GEN oper = closure_get_oper(C);
2947 0 : GEN fram = gel(closure_get_dbg(C),3);
2948 : long i, j;
2949 0 : for(i=1;i<lg(oper);i++)
2950 0 : if (oper[i] && opcode_need_relink((op_code)code[i]))
2951 0 : oper[i] = (long) hash_search(table,(void*) oper[i])->val;
2952 0 : for (i=1;i<lg(fram);i++)
2953 0 : for (j=1;j<lg(gel(fram,i));j++)
2954 0 : if (mael(fram,i,j))
2955 0 : mael(fram,i,j) = (long) hash_search(table,(void*) mael(fram,i,j))->val;
2956 0 : }
2957 :
2958 : void
2959 0 : gen_relink(GEN x, hashtable *table)
2960 : {
2961 0 : long i, lx, tx = typ(x);
2962 0 : switch(tx)
2963 : {
2964 0 : case t_CLOSURE:
2965 0 : closure_relink(x, table);
2966 0 : gen_relink(closure_get_data(x), table);
2967 0 : if (lg(x)==8) gen_relink(closure_get_frame(x), table);
2968 0 : break;
2969 0 : case t_LIST:
2970 0 : if (list_data(x)) gen_relink(list_data(x), table);
2971 0 : break;
2972 0 : case t_VEC: case t_COL: case t_MAT: case t_ERROR:
2973 0 : lx = lg(x);
2974 0 : for (i = lontyp[tx]; i < lx; i++) gen_relink(gel(x,i), table);
2975 : }
2976 0 : }
2977 :
2978 : static void
2979 0 : closure_unlink(GEN C)
2980 : {
2981 0 : const char *code = closure_codestr(C);
2982 0 : GEN oper = closure_get_oper(C);
2983 0 : GEN fram = gel(closure_get_dbg(C),3);
2984 : long i, j;
2985 0 : for(i=1;i<lg(oper);i++)
2986 0 : if (oper[i] && opcode_need_relink((op_code) code[i]))
2987 : {
2988 0 : long n = pari_stack_new(&s_relocs);
2989 0 : relocs[n] = (entree *) oper[i];
2990 : }
2991 0 : for (i=1;i<lg(fram);i++)
2992 0 : for (j=1;j<lg(gel(fram,i));j++)
2993 0 : if (mael(fram,i,j))
2994 : {
2995 0 : long n = pari_stack_new(&s_relocs);
2996 0 : relocs[n] = (entree *) mael(fram,i,j);
2997 : }
2998 0 : }
2999 :
3000 : static void
3001 16 : gen_unlink(GEN x)
3002 : {
3003 16 : long i, lx, tx = typ(x);
3004 16 : switch(tx)
3005 : {
3006 0 : case t_CLOSURE:
3007 0 : closure_unlink(x);
3008 0 : gen_unlink(closure_get_data(x));
3009 0 : if (lg(x)==8) gen_unlink(closure_get_frame(x));
3010 0 : break;
3011 4 : case t_LIST:
3012 4 : if (list_data(x)) gen_unlink(list_data(x));
3013 4 : break;
3014 0 : case t_VEC: case t_COL: case t_MAT: case t_ERROR:
3015 0 : lx = lg(x);
3016 0 : for (i = lontyp[tx]; i<lx; i++) gen_unlink(gel(x,i));
3017 : }
3018 16 : }
3019 :
3020 : GEN
3021 12 : copybin_unlink(GEN C)
3022 : {
3023 12 : long i, l, n, nold = s_relocs.n;
3024 : GEN v, w, V, res;
3025 12 : if (C)
3026 8 : gen_unlink(C);
3027 : else
3028 : { /* contents of all variables */
3029 4 : long v, maxv = pari_var_next();
3030 44 : for (v=0; v<maxv; v++)
3031 : {
3032 40 : entree *ep = varentries[v];
3033 40 : if (!ep || !ep->value) continue;
3034 8 : gen_unlink((GEN)ep->value);
3035 : }
3036 : }
3037 12 : n = s_relocs.n-nold;
3038 12 : v = cgetg(n+1, t_VECSMALL);
3039 12 : for(i=0; i<n; i++)
3040 0 : v[i+1] = (long) relocs[i];
3041 12 : s_relocs.n = nold;
3042 12 : w = vecsmall_uniq(v); l = lg(w);
3043 12 : res = cgetg(3,t_VEC);
3044 12 : V = cgetg(l, t_VEC);
3045 12 : for(i=1; i<l; i++)
3046 : {
3047 0 : entree *ep = (entree*) w[i];
3048 0 : gel(V,i) = strtoGENstr(ep->name);
3049 : }
3050 12 : gel(res,1) = vecsmall_copy(w);
3051 12 : gel(res,2) = V;
3052 12 : return res;
3053 : }
3054 :
3055 : /* e = t_VECSMALL of entree *ep [ addresses ],
3056 : * names = t_VEC of strtoGENstr(ep.names),
3057 : * Return hashtable : ep => is_entry(ep.name) */
3058 : hashtable *
3059 0 : hash_from_link(GEN e, GEN names, int use_stack)
3060 : {
3061 0 : long i, l = lg(e);
3062 0 : hashtable *h = hash_create_ulong(l-1, use_stack);
3063 0 : if (lg(names) != l) pari_err_DIM("hash_from_link");
3064 0 : for (i = 1; i < l; i++)
3065 : {
3066 0 : char *s = GSTR(gel(names,i));
3067 0 : hash_insert(h, (void*)e[i], (void*)fetch_entry(s));
3068 : }
3069 0 : return h;
3070 : }
3071 :
3072 : void
3073 0 : bincopy_relink(GEN C, GEN V)
3074 : {
3075 0 : pari_sp av = avma;
3076 0 : hashtable *table = hash_from_link(gel(V,1),gel(V,2),1);
3077 0 : gen_relink(C, table);
3078 0 : set_avma(av);
3079 0 : }
|
