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 "tree.h"
19 : #include "opcode.h"
20 :
21 : #define DEBUGLEVEL DEBUGLEVEL_compiler
22 :
23 : #define tree pari_tree
24 :
25 : enum COflags {COsafelex=1, COsafedyn=2};
26 :
27 : /***************************************************************************
28 : ** **
29 : ** String constant expansion **
30 : ** **
31 : ***************************************************************************/
32 :
33 : static char *
34 880070 : translate(const char **src, char *s)
35 : {
36 880070 : const char *t = *src;
37 6940593 : while (*t)
38 : {
39 6941241 : while (*t == '\\')
40 : {
41 648 : switch(*++t)
42 : {
43 0 : case 'e': *s='\033'; break; /* escape */
44 466 : case 'n': *s='\n'; break;
45 14 : case 't': *s='\t'; break;
46 168 : default: *s=*t; if (!*t) { *src=s; return NULL; }
47 : }
48 648 : t++; s++;
49 : }
50 6940593 : if (*t == '"')
51 : {
52 880070 : if (t[1] != '"') break;
53 0 : t += 2; continue;
54 : }
55 6060523 : *s++ = *t++;
56 : }
57 880070 : *s=0; *src=t; return s;
58 : }
59 :
60 : static void
61 8 : matchQ(const char *s, char *entry)
62 : {
63 8 : if (*s != '"')
64 0 : pari_err(e_SYNTAX,"expected character: '\"' instead of",s,entry);
65 8 : }
66 :
67 : /* Read a "string" from src. Format then copy it, starting at s. Return
68 : * pointer to char following the end of the input string */
69 : char *
70 4 : pari_translate_string(const char *src, char *s, char *entry)
71 : {
72 4 : matchQ(src, entry); src++; s = translate(&src, s);
73 4 : if (!s) pari_err(e_SYNTAX,"run-away string",src,entry);
74 4 : matchQ(src, entry); return (char*)src+1;
75 : }
76 :
77 : static GEN
78 880066 : strntoGENexp(const char *str, long len)
79 : {
80 880066 : long n = nchar2nlong(len-1);
81 880066 : GEN z = cgetg(1+n, t_STR);
82 880066 : const char *t = str+1;
83 880066 : z[n] = 0;
84 880066 : if (!translate(&t, GSTR(z))) compile_err("run-away string",str);
85 880066 : return z;
86 : }
87 :
88 : /***************************************************************************
89 : ** **
90 : ** Byte-code compiler **
91 : ** **
92 : ***************************************************************************/
93 :
94 : typedef enum {Llocal, Lmy} Ltype;
95 :
96 : struct vars_s
97 : {
98 : Ltype type; /*Only Llocal and Lmy are allowed */
99 : int inl;
100 : entree *ep;
101 : };
102 :
103 : struct frame_s
104 : {
105 : long pc;
106 : GEN frame;
107 : };
108 :
109 : static THREAD pari_stack s_opcode, s_operand, s_data, s_lvar;
110 : static THREAD pari_stack s_dbginfo, s_frame, s_accesslex;
111 : static THREAD char *opcode;
112 : static THREAD long *operand;
113 : static THREAD long *accesslex;
114 : static THREAD GEN *data;
115 : static THREAD long offset, nblex;
116 : static THREAD struct vars_s *localvars;
117 : static THREAD const char **dbginfo, *dbgstart;
118 : static THREAD struct frame_s *frames;
119 :
120 : void
121 326279 : pari_init_compiler(void)
122 : {
123 326279 : pari_stack_init(&s_opcode,sizeof(*opcode),(void **)&opcode);
124 326259 : pari_stack_init(&s_operand,sizeof(*operand),(void **)&operand);
125 326244 : pari_stack_init(&s_accesslex,sizeof(*operand),(void **)&accesslex);
126 326236 : pari_stack_init(&s_data,sizeof(*data),(void **)&data);
127 326225 : pari_stack_init(&s_lvar,sizeof(*localvars),(void **)&localvars);
128 326188 : pari_stack_init(&s_dbginfo,sizeof(*dbginfo),(void **)&dbginfo);
129 326174 : pari_stack_init(&s_frame,sizeof(*frames),(void **)&frames);
130 326170 : offset=-1; nblex=0;
131 326170 : }
132 : void
133 325084 : pari_close_compiler(void)
134 : {
135 325084 : pari_stack_delete(&s_opcode);
136 323866 : pari_stack_delete(&s_operand);
137 322395 : pari_stack_delete(&s_accesslex);
138 321664 : pari_stack_delete(&s_data);
139 321169 : pari_stack_delete(&s_lvar);
140 320822 : pari_stack_delete(&s_dbginfo);
141 320666 : pari_stack_delete(&s_frame);
142 320646 : }
143 :
144 : struct codepos
145 : {
146 : long opcode, data, localvars, frames, accesslex;
147 : long offset, nblex;
148 : const char *dbgstart;
149 : };
150 :
151 : static void
152 8949663 : getcodepos(struct codepos *pos)
153 : {
154 8949663 : pos->opcode=s_opcode.n;
155 8949663 : pos->accesslex=s_accesslex.n;
156 8949663 : pos->data=s_data.n;
157 8949663 : pos->offset=offset;
158 8949663 : pos->nblex=nblex;
159 8949663 : pos->localvars=s_lvar.n;
160 8949663 : pos->dbgstart=dbgstart;
161 8949663 : pos->frames=s_frame.n;
162 8949663 : offset=s_data.n-1;
163 8949663 : }
164 :
165 : void
166 438 : compilestate_reset(void)
167 : {
168 438 : s_opcode.n=0;
169 438 : s_operand.n=0;
170 438 : s_accesslex.n=0;
171 438 : s_dbginfo.n=0;
172 438 : s_data.n=0;
173 438 : s_lvar.n=0;
174 438 : s_frame.n=0;
175 438 : offset=-1;
176 438 : nblex=0;
177 438 : dbgstart=NULL;
178 438 : }
179 :
180 : void
181 1418810 : compilestate_save(struct pari_compilestate *comp)
182 : {
183 1418810 : comp->opcode=s_opcode.n;
184 1418810 : comp->operand=s_operand.n;
185 1418810 : comp->accesslex=s_accesslex.n;
186 1418810 : comp->data=s_data.n;
187 1418810 : comp->offset=offset;
188 1418810 : comp->nblex=nblex;
189 1418810 : comp->localvars=s_lvar.n;
190 1418810 : comp->dbgstart=dbgstart;
191 1418810 : comp->dbginfo=s_dbginfo.n;
192 1418810 : comp->frames=s_frame.n;
193 1418810 : }
194 :
195 : void
196 49010 : compilestate_restore(struct pari_compilestate *comp)
197 : {
198 49010 : s_opcode.n=comp->opcode;
199 49010 : s_operand.n=comp->operand;
200 49010 : s_accesslex.n=comp->accesslex;
201 49010 : s_data.n=comp->data;
202 49010 : offset=comp->offset;
203 49010 : nblex=comp->nblex;
204 49010 : s_lvar.n=comp->localvars;
205 49010 : dbgstart=comp->dbgstart;
206 49010 : s_dbginfo.n=comp->dbginfo;
207 49010 : s_frame.n=comp->frames;
208 49010 : }
209 :
210 : static GEN
211 9768627 : gcopyunclone(GEN x) { GEN y = gcopy(x); gunclone(x); return y; }
212 :
213 : static void
214 112758 : access_push(long x)
215 : {
216 112758 : long a = pari_stack_new(&s_accesslex);
217 112758 : accesslex[a] = x;
218 112758 : }
219 :
220 : static GEN
221 8001682 : genctx(long nbmvar, long paccesslex)
222 : {
223 8001682 : GEN acc = const_vec(nbmvar,gen_1);
224 8001695 : long i, lvl = 1 + nbmvar;
225 8042967 : for (i = paccesslex; i<s_accesslex.n; i++)
226 : {
227 41272 : long a = accesslex[i];
228 41272 : if (a > 0) { lvl+=a; continue; }
229 36252 : a += lvl;
230 36252 : if (a <= 0) pari_err_BUG("genctx");
231 36252 : if (a <= nbmvar)
232 28221 : gel(acc, a) = gen_0;
233 : }
234 8001695 : s_accesslex.n = paccesslex;
235 28374996 : for (i = 1; i<=nbmvar; i++)
236 20373304 : if (signe(gel(acc,i))==0)
237 20493 : access_push(i-nbmvar-1);
238 8001692 : return acc;
239 : }
240 :
241 : static GEN
242 8949573 : getfunction(const struct codepos *pos, long arity, long nbmvar, GEN text,
243 : long gap)
244 : {
245 8949573 : long lop = s_opcode.n+1 - pos->opcode;
246 8949573 : long ldat = s_data.n+1 - pos->data;
247 8949573 : long lfram = s_frame.n+1 - pos->frames;
248 8949573 : GEN cl = cgetg(nbmvar && text? 8: (text? 7: 6), t_CLOSURE);
249 : GEN frpc, fram, dbg, op, dat;
250 : char *s;
251 : long i;
252 :
253 8949559 : cl[1] = arity;
254 8949559 : gel(cl,2) = cgetg(nchar2nlong(lop)+1, t_STR);
255 8949533 : gel(cl,3) = op = cgetg(lop, t_VECSMALL);
256 8949541 : gel(cl,4) = dat = cgetg(ldat, t_VEC);
257 8949548 : dbg = cgetg(lop, t_VECSMALL);
258 8949549 : frpc = cgetg(lfram, t_VECSMALL);
259 8949556 : fram = cgetg(lfram, t_VEC);
260 8949556 : gel(cl,5) = mkvec3(dbg, frpc, fram);
261 8949566 : if (text) gel(cl,6) = text;
262 8949566 : s = GSTR(gel(cl,2)) - 1;
263 84725270 : for (i = 1; i < lop; i++)
264 : {
265 75775704 : long j = i+pos->opcode-1;
266 75775704 : s[i] = opcode[j];
267 75775704 : op[i] = operand[j];
268 75775704 : dbg[i] = dbginfo[j] - dbgstart;
269 75775704 : if (dbg[i] < 0) dbg[i] += gap;
270 : }
271 8949566 : s[i] = 0;
272 8949566 : s_opcode.n = pos->opcode;
273 8949566 : s_operand.n = pos->opcode;
274 8949566 : s_dbginfo.n = pos->opcode;
275 8949566 : if (lg(cl)==8)
276 7990849 : gel(cl,7) = genctx(nbmvar, pos->accesslex);
277 958717 : else if (nbmvar==0)
278 947961 : s_accesslex.n = pos->accesslex;
279 : else
280 : {
281 10756 : pari_sp av = avma;
282 10756 : (void) genctx(nbmvar, pos->accesslex);
283 10818 : set_avma(av);
284 : }
285 10707265 : for (i = 1; i < ldat; i++)
286 1757616 : if (data[i+pos->data-1]) gel(dat,i) = gcopyunclone(data[i+pos->data-1]);
287 8949649 : s_data.n = pos->data;
288 8977736 : while (s_lvar.n > pos->localvars && !localvars[s_lvar.n-1].inl)
289 : {
290 28087 : if (localvars[s_lvar.n-1].type==Lmy) nblex--;
291 28087 : s_lvar.n--;
292 : }
293 16960738 : for (i = 1; i < lfram; i++)
294 : {
295 8011022 : long j = i+pos->frames-1;
296 8011022 : frpc[i] = frames[j].pc - pos->opcode+1;
297 8011022 : gel(fram, i) = gcopyunclone(frames[j].frame);
298 : }
299 8949716 : s_frame.n = pos->frames;
300 8949716 : offset = pos->offset;
301 8949716 : dbgstart = pos->dbgstart;
302 8949716 : return cl;
303 : }
304 :
305 : static GEN
306 19923 : getclosure(struct codepos *pos, long nbmvar)
307 : {
308 19923 : return getfunction(pos, 0, nbmvar, NULL, 0);
309 : }
310 :
311 : static void
312 75772482 : op_push_loc(op_code o, long x, const char *loc)
313 : {
314 75772482 : long n=pari_stack_new(&s_opcode);
315 75772452 : long m=pari_stack_new(&s_operand);
316 75772378 : long d=pari_stack_new(&s_dbginfo);
317 75772332 : opcode[n]=o;
318 75772332 : operand[m]=x;
319 75772332 : dbginfo[d]=loc;
320 75772332 : }
321 :
322 : static void
323 38479598 : op_push(op_code o, long x, long n)
324 : {
325 38479598 : op_push_loc(o,x,tree[n].str);
326 38479598 : }
327 :
328 : static void
329 2940 : op_insert_loc(long k, op_code o, long x, const char *loc)
330 : {
331 : long i;
332 2940 : long n=pari_stack_new(&s_opcode);
333 2940 : (void) pari_stack_new(&s_operand);
334 2940 : (void) pari_stack_new(&s_dbginfo);
335 617282 : for (i=n-1; i>=k; i--)
336 : {
337 614342 : opcode[i+1] = opcode[i];
338 614342 : operand[i+1]= operand[i];
339 614342 : dbginfo[i+1]= dbginfo[i];
340 : }
341 2940 : opcode[k] = o;
342 2940 : operand[k] = x;
343 2940 : dbginfo[k] = loc;
344 2940 : }
345 :
346 : static long
347 1757616 : data_push(GEN x)
348 : {
349 1757616 : long n=pari_stack_new(&s_data);
350 1757616 : data[n] = x?gclone(x):x;
351 1757616 : return n-offset;
352 : }
353 :
354 : static void
355 64600 : var_push(entree *ep, Ltype type)
356 : {
357 64600 : long n=pari_stack_new(&s_lvar);
358 64600 : localvars[n].ep = ep;
359 64600 : localvars[n].inl = 0;
360 64600 : localvars[n].type = type;
361 64600 : if (type == Lmy) nblex++;
362 64600 : }
363 :
364 : static void
365 8010994 : frame_push(GEN x)
366 : {
367 8010994 : long n=pari_stack_new(&s_frame);
368 8010988 : frames[n].pc = s_opcode.n-1;
369 8010988 : frames[n].frame = gclone(x);
370 8011004 : }
371 :
372 : static GEN
373 53 : pack_localvars(void)
374 : {
375 53 : GEN pack=cgetg(3,t_VEC);
376 53 : long i, l=s_lvar.n;
377 53 : GEN t=cgetg(1+l,t_VECSMALL);
378 53 : GEN e=cgetg(1+l,t_VECSMALL);
379 53 : gel(pack,1)=t;
380 53 : gel(pack,2)=e;
381 129 : for(i=1;i<=l;i++)
382 : {
383 76 : t[i]=localvars[i-1].type;
384 76 : e[i]=(long)localvars[i-1].ep;
385 : }
386 129 : for(i=1;i<=nblex;i++)
387 76 : access_push(-i);
388 53 : return pack;
389 : }
390 :
391 : void
392 259 : push_frame(GEN C, long lpc, long dummy)
393 : {
394 259 : const char *code=closure_codestr(C);
395 259 : GEN oper=closure_get_oper(C);
396 259 : GEN dbg=closure_get_dbg(C);
397 259 : GEN frpc=gel(dbg,2);
398 259 : GEN fram=gel(dbg,3);
399 259 : long pc, j=1, lfr = lg(frpc);
400 259 : if (lpc==-1)
401 : {
402 : long k;
403 56 : GEN e = gel(fram, 1);
404 112 : for(k=1; k<lg(e); k++)
405 56 : var_push(dummy?NULL:(entree*)e[k], Lmy);
406 56 : return;
407 : }
408 259 : if (lg(C)<8) while (j<lfr && frpc[j]==0) j++;
409 1715 : for(pc=0; pc<lpc; pc++) /* do not assume lpc was completed */
410 : {
411 1512 : if (pc>0 && (code[pc]==OClocalvar || code[pc]==OClocalvar0))
412 0 : var_push((entree*)oper[pc],Llocal);
413 1512 : if (j<lfr && pc==frpc[j])
414 : {
415 : long k;
416 154 : GEN e = gel(fram,j);
417 399 : for(k=1; k<lg(e); k++)
418 245 : var_push(dummy?NULL:(entree*)e[k], Lmy);
419 154 : j++;
420 : }
421 : }
422 : }
423 :
424 : void
425 0 : debug_context(void)
426 : {
427 : long i;
428 0 : for(i=0;i<s_lvar.n;i++)
429 : {
430 0 : entree *ep = localvars[i].ep;
431 0 : Ltype type = localvars[i].type;
432 0 : err_printf("%ld: %s: %s\n",i,(type==Lmy?"my":"local"),(ep?ep->name:"NULL"));
433 : }
434 0 : }
435 :
436 : GEN
437 10992 : localvars_read_str(const char *x, GEN pack)
438 : {
439 10992 : pari_sp av = avma;
440 : GEN code;
441 10992 : long l=0, nbmvar=nblex;
442 10992 : if (pack)
443 : {
444 10992 : GEN t=gel(pack,1);
445 10992 : GEN e=gel(pack,2);
446 : long i;
447 10992 : l=lg(t)-1;
448 47171 : for(i=1;i<=l;i++)
449 36179 : var_push((entree*)e[i],(Ltype)t[i]);
450 : }
451 10992 : code = compile_str(x);
452 10992 : s_lvar.n -= l;
453 10992 : nblex = nbmvar;
454 10992 : return gerepileupto(av, closure_evalres(code));
455 : }
456 :
457 : long
458 7 : localvars_find(GEN pack, entree *ep)
459 : {
460 7 : GEN t=gel(pack,1);
461 7 : GEN e=gel(pack,2);
462 : long i;
463 7 : long vn=0;
464 7 : for(i=lg(e)-1;i>=1;i--)
465 : {
466 0 : if(t[i]==Lmy)
467 0 : vn--;
468 0 : if(e[i]==(long)ep)
469 0 : return t[i]==Lmy?vn:0;
470 : }
471 7 : return 0;
472 : }
473 :
474 : /*
475 : Flags for copy optimisation:
476 : -- Freturn: The result will be returned.
477 : -- FLsurvive: The result must survive the closure.
478 : -- FLnocopy: The result will never be updated nor part of a user variable.
479 : -- FLnocopylex: The result will never be updated nor part of dynamic variable.
480 : */
481 : enum FLflag {FLreturn=1, FLsurvive=2, FLnocopy=4, FLnocopylex=8};
482 :
483 : static void
484 261665 : addcopy(long n, long mode, long flag, long mask)
485 : {
486 261665 : if (mode==Ggen && !(flag&mask))
487 : {
488 25922 : op_push(OCcopy,0,n);
489 25922 : if (!(flag&FLsurvive) && DEBUGLEVEL)
490 0 : pari_warn(warner,"compiler generates copy for `%.*s'",
491 0 : tree[n].len,tree[n].str);
492 : }
493 261665 : }
494 :
495 : static void compilenode(long n, int mode, long flag);
496 :
497 : typedef enum {PPend,PPstd,PPdefault,PPdefaultmulti,PPstar,PPauto} PPproto;
498 :
499 : static PPproto
500 121137361 : parseproto(char const **q, char *c, const char *str)
501 : {
502 121137361 : char const *p=*q;
503 : long i;
504 121137361 : switch(*p)
505 : {
506 29554941 : case 0:
507 : case '\n':
508 29554941 : return PPend;
509 275118 : case 'D':
510 275118 : switch(p[1])
511 : {
512 186395 : case 'G':
513 : case '&':
514 : case 'W':
515 : case 'V':
516 : case 'I':
517 : case 'E':
518 : case 'J':
519 : case 'n':
520 : case 'P':
521 : case 'r':
522 : case 's':
523 186395 : *c=p[1]; *q=p+2; return PPdefault;
524 88723 : default:
525 535908 : for(i=0;*p && i<2;p++) i+=*p==',';
526 : /* assert(i>=2) because check_proto validated the protototype */
527 88723 : *c=p[-2]; *q=p; return PPdefaultmulti;
528 : }
529 : break;
530 137501 : case 'C':
531 : case 'p':
532 : case 'b':
533 : case 'P':
534 : case 'f':
535 137501 : *c=*p; *q=p+1; return PPauto;
536 1536 : case '&':
537 1536 : *c='*'; *q=p+1; return PPstd;
538 18548 : case 'V':
539 18548 : if (p[1]=='=')
540 : {
541 13484 : if (p[2]!='G')
542 0 : compile_err("function prototype is not supported",str);
543 13484 : *c='='; p+=2;
544 : }
545 : else
546 5064 : *c=*p;
547 18548 : *q=p+1; return PPstd;
548 44480 : case 'E':
549 : case 's':
550 44480 : if (p[1]=='*') { *c=*p++; *q=p+1; return PPstar; }
551 : /*fall through*/
552 : }
553 91119898 : *c=*p; *q=p+1; return PPstd;
554 : }
555 :
556 : static long
557 418553 : detag(long n)
558 : {
559 418553 : while (tree[n].f==Ftag)
560 0 : n=tree[n].x;
561 418553 : return n;
562 : }
563 :
564 : /* return type for GP functions */
565 : static op_code
566 13593883 : get_ret_type(const char **p, long arity, Gtype *t, long *flag)
567 : {
568 13593883 : *flag = 0;
569 13593883 : if (**p == 'v') { (*p)++; *t=Gvoid; return OCcallvoid; }
570 13546730 : else if (**p == 'i') { (*p)++; *t=Gsmall; return OCcallint; }
571 13540493 : else if (**p == 'l') { (*p)++; *t=Gsmall; return OCcalllong; }
572 13515081 : else if (**p == 'u') { (*p)++; *t=Gusmall; return OCcalllong; }
573 13515081 : else if (**p == 'm') { (*p)++; *flag = FLnocopy; }
574 13515081 : *t=Ggen; return arity==2?OCcallgen2:OCcallgen;
575 : }
576 :
577 : static void
578 7 : U_compile_err(const char *s)
579 7 : { compile_err("this should be a small non-negative integer",s); }
580 : static void
581 7 : L_compile_err(const char *s)
582 7 : { compile_err("this should be a small integer",s); }
583 :
584 : /*supported types:
585 : * type: Gusmall, Gsmall, Ggen, Gvoid, Gvec, Gclosure
586 : * mode: Gusmall, Gsmall, Ggen, Gvar, Gvoid
587 : */
588 : static void
589 14652622 : compilecast_loc(int type, int mode, const char *loc)
590 : {
591 14652622 : if (type==mode) return;
592 4527810 : switch (mode)
593 : {
594 200 : case Gusmall:
595 200 : if (type==Ggen) op_push_loc(OCitou,-1,loc);
596 158 : else if (type==Gvoid) op_push_loc(OCpushlong,0,loc);
597 158 : else if (type!=Gsmall) U_compile_err(loc);
598 200 : break;
599 5082 : case Gsmall:
600 5082 : if (type==Ggen) op_push_loc(OCitos,-1,loc);
601 7 : else if (type==Gvoid) op_push_loc(OCpushlong,0,loc);
602 7 : else if (type!=Gusmall) L_compile_err(loc);
603 5075 : break;
604 4509883 : case Ggen:
605 4509883 : if (type==Gsmall) op_push_loc(OCstoi,0,loc);
606 4495963 : else if (type==Gusmall)op_push_loc(OCutoi,0,loc);
607 4495963 : else if (type==Gvoid) op_push_loc(OCpushgnil,0,loc);
608 4509883 : break;
609 8859 : case Gvoid:
610 8859 : op_push_loc(OCpop, 1,loc);
611 8859 : break;
612 3786 : case Gvar:
613 3786 : if (type==Ggen) op_push_loc(OCvarn,-1,loc);
614 7 : else compile_varerr(loc);
615 3779 : break;
616 0 : default:
617 0 : pari_err_BUG("compilecast [unknown type]");
618 : }
619 : }
620 :
621 : static void
622 6664133 : compilecast(long n, int type, int mode) { compilecast_loc(type, mode, tree[n].str); }
623 :
624 : static entree *
625 25137 : fetch_member_raw(const char *s, long len)
626 : {
627 25137 : pari_sp av = avma;
628 25137 : char *t = stack_malloc(len+2);
629 : entree *ep;
630 25137 : t[0] = '_'; strncpy(t+1, s, len); t[++len] = 0; /* prepend '_' */
631 25137 : ep = fetch_entry_raw(t, len);
632 25137 : set_avma(av); return ep;
633 : }
634 : static entree *
635 9722952 : getfunc(long n)
636 : {
637 9722952 : long x=tree[n].x;
638 9722952 : if (tree[x].x==CSTmember) /* str-1 points to '.' */
639 25137 : return do_alias(fetch_member_raw(tree[x].str - 1, tree[x].len + 1));
640 : else
641 9697815 : return do_alias(fetch_entry_raw(tree[x].str, tree[x].len));
642 : }
643 :
644 : static entree *
645 352655 : getentry(long n)
646 : {
647 352655 : n = detag(n);
648 352655 : if (tree[n].f!=Fentry)
649 : {
650 21 : if (tree[n].f==Fseq)
651 0 : compile_err("unexpected character: ';'", tree[tree[n].y].str-1);
652 21 : compile_varerr(tree[n].str);
653 : }
654 352634 : return getfunc(n);
655 : }
656 :
657 : static entree *
658 80664 : getvar(long n)
659 80664 : { return getentry(n); }
660 :
661 : /* match Fentry that are not actually EpSTATIC functions called without parens*/
662 : static entree *
663 131 : getvardyn(long n)
664 : {
665 131 : entree *ep = getentry(n);
666 131 : if (EpSTATIC(do_alias(ep)))
667 0 : compile_varerr(tree[n].str);
668 131 : return ep;
669 : }
670 :
671 : static long
672 5024756 : getmvar(entree *ep)
673 : {
674 : long i;
675 5024756 : long vn=0;
676 6146720 : for(i=s_lvar.n-1;i>=0;i--)
677 : {
678 1199530 : if(localvars[i].type==Lmy)
679 1199257 : vn--;
680 1199530 : if(localvars[i].ep==ep)
681 77566 : return localvars[i].type==Lmy?vn:0;
682 : }
683 4947190 : return 0;
684 : }
685 :
686 : static void
687 9424 : ctxmvar(long n)
688 : {
689 9424 : pari_sp av=avma;
690 : GEN ctx;
691 : long i;
692 9424 : if (n==0) return;
693 4117 : ctx = cgetg(n+1,t_VECSMALL);
694 67139 : for(n=0, i=0; i<s_lvar.n; i++)
695 63022 : if(localvars[i].type==Lmy)
696 63022 : ctx[++n]=(long)localvars[i].ep;
697 4117 : frame_push(ctx);
698 4117 : set_avma(av);
699 : }
700 :
701 : INLINE int
702 51316495 : is_func_named(entree *ep, const char *s)
703 : {
704 51316495 : return !strcmp(ep->name, s);
705 : }
706 :
707 : INLINE int
708 3980 : is_node_zero(long n)
709 : {
710 3980 : n = detag(n);
711 3980 : return (tree[n].f==Fsmall && tree[n].x==0);
712 : }
713 :
714 : static void
715 91 : str_defproto(const char *p, const char *q, const char *loc)
716 : {
717 91 : long len = p-4-q;
718 91 : if (q[1]!='"' || q[len]!='"')
719 0 : compile_err("default argument must be a string",loc);
720 91 : op_push_loc(OCpushgen,data_push(strntoGENexp(q+1,len)),loc);
721 91 : }
722 :
723 : static long
724 406 : countmatrixelts(long n)
725 : {
726 : long x,i;
727 406 : if (n==-1 || tree[n].f==Fnoarg) return 0;
728 959 : for(x=n, i=0; tree[x].f==Fmatrixelts; x=tree[x].x)
729 553 : if (tree[tree[x].y].f!=Fnoarg) i++;
730 406 : if (tree[x].f!=Fnoarg) i++;
731 406 : return i;
732 : }
733 :
734 : static long
735 18443365 : countlisttogen(long n, Ffunc f)
736 : {
737 : long x,i;
738 18443365 : if (n==-1 || tree[n].f==Fnoarg) return 0;
739 42793571 : for(x=n, i=0; tree[x].f==f ;x=tree[x].x, i++);
740 17686032 : return i+1;
741 : }
742 :
743 : static GEN
744 18443365 : listtogen(long n, Ffunc f)
745 : {
746 18443365 : long x,i,nb = countlisttogen(n, f);
747 18443365 : GEN z=cgetg(nb+1, t_VECSMALL);
748 18443365 : if (nb)
749 : {
750 42793571 : for (x=n, i = nb-1; i>0; z[i+1]=tree[x].y, x=tree[x].x, i--);
751 17686032 : z[1]=x;
752 : }
753 18443365 : return z;
754 : }
755 :
756 : static long
757 9391186 : first_safe_arg(GEN arg, long mask)
758 : {
759 9391186 : long lnc, l=lg(arg);
760 19776844 : for (lnc=l-1; lnc>0 && (tree[arg[lnc]].flags&mask)==mask; lnc--);
761 9391186 : return lnc;
762 : }
763 :
764 : static void
765 20179 : checkdups(GEN arg, GEN vep)
766 : {
767 20179 : long l=vecsmall_duplicate(vep);
768 20179 : if (l!=0) compile_err("variable declared twice",tree[arg[l]].str);
769 20179 : }
770 :
771 : enum {MAT_range,MAT_std,MAT_line,MAT_column,VEC_std};
772 :
773 : static int
774 15206 : matindex_type(long n)
775 : {
776 15206 : long x = tree[n].x, y = tree[n].y;
777 15206 : long fxx = tree[tree[x].x].f, fxy = tree[tree[x].y].f;
778 15206 : if (y==-1)
779 : {
780 13134 : if (fxy!=Fnorange) return MAT_range;
781 12546 : if (fxx==Fnorange) compile_err("missing index",tree[n].str);
782 12546 : return VEC_std;
783 : }
784 : else
785 : {
786 2072 : long fyx = tree[tree[y].x].f, fyy = tree[tree[y].y].f;
787 2072 : if (fxy!=Fnorange || fyy!=Fnorange) return MAT_range;
788 1897 : if (fxx==Fnorange && fyx==Fnorange)
789 0 : compile_err("missing index",tree[n].str);
790 1897 : if (fxx==Fnorange) return MAT_column;
791 1092 : if (fyx==Fnorange) return MAT_line;
792 826 : return MAT_std;
793 : }
794 : }
795 :
796 : static entree *
797 47302 : getlvalue(long n)
798 : {
799 48289 : while ((tree[n].f==Fmatcoeff && matindex_type(tree[n].y)!=MAT_range) || tree[n].f==Ftag)
800 987 : n=tree[n].x;
801 47302 : return getvar(n);
802 : }
803 :
804 : INLINE void
805 43832 : compilestore(long vn, entree *ep, long n)
806 : {
807 43832 : if (vn)
808 4632 : op_push(OCstorelex,vn,n);
809 : else
810 : {
811 39200 : if (EpSTATIC(do_alias(ep)))
812 0 : compile_varerr(tree[n].str);
813 39200 : op_push(OCstoredyn,(long)ep,n);
814 : }
815 43832 : }
816 :
817 : INLINE void
818 826 : compilenewptr(long vn, entree *ep, long n)
819 : {
820 826 : if (vn)
821 : {
822 252 : access_push(vn);
823 252 : op_push(OCnewptrlex,vn,n);
824 : }
825 : else
826 574 : op_push(OCnewptrdyn,(long)ep,n);
827 826 : }
828 :
829 : static void
830 1806 : compilelvalue(long n)
831 : {
832 1806 : n = detag(n);
833 1806 : if (tree[n].f==Fentry)
834 826 : return;
835 : else
836 : {
837 980 : long x = tree[n].x, y = tree[n].y;
838 980 : long yx = tree[y].x, yy = tree[y].y;
839 980 : long m = matindex_type(y);
840 980 : if (m == MAT_range)
841 0 : compile_err("not an lvalue",tree[n].str);
842 980 : if (m == VEC_std && tree[x].f==Fmatcoeff)
843 : {
844 119 : int mx = matindex_type(tree[x].y);
845 119 : if (mx==MAT_line)
846 : {
847 0 : int xy = tree[x].y, xyx = tree[xy].x;
848 0 : compilelvalue(tree[x].x);
849 0 : compilenode(tree[xyx].x,Gsmall,0);
850 0 : compilenode(tree[yx].x,Gsmall,0);
851 0 : op_push(OCcompo2ptr,0,y);
852 0 : return;
853 : }
854 : }
855 980 : compilelvalue(x);
856 980 : switch(m)
857 : {
858 658 : case VEC_std:
859 658 : compilenode(tree[yx].x,Gsmall,0);
860 658 : op_push(OCcompo1ptr,0,y);
861 658 : break;
862 126 : case MAT_std:
863 126 : compilenode(tree[yx].x,Gsmall,0);
864 126 : compilenode(tree[yy].x,Gsmall,0);
865 126 : op_push(OCcompo2ptr,0,y);
866 126 : break;
867 98 : case MAT_line:
868 98 : compilenode(tree[yx].x,Gsmall,0);
869 98 : op_push(OCcompoLptr,0,y);
870 98 : break;
871 98 : case MAT_column:
872 98 : compilenode(tree[yy].x,Gsmall,0);
873 98 : op_push(OCcompoCptr,0,y);
874 98 : break;
875 : }
876 : }
877 : }
878 :
879 : static void
880 13120 : compilematcoeff(long n, int mode)
881 : {
882 13120 : long x=tree[n].x, y=tree[n].y;
883 13120 : long yx=tree[y].x, yy=tree[y].y;
884 13120 : long m=matindex_type(y);
885 13120 : compilenode(x,Ggen,FLnocopy);
886 13120 : switch(m)
887 : {
888 11104 : case VEC_std:
889 11104 : compilenode(tree[yx].x,Gsmall,0);
890 11104 : op_push(OCcompo1,mode,y);
891 11104 : return;
892 574 : case MAT_std:
893 574 : compilenode(tree[yx].x,Gsmall,0);
894 574 : compilenode(tree[yy].x,Gsmall,0);
895 574 : op_push(OCcompo2,mode,y);
896 574 : return;
897 70 : case MAT_line:
898 70 : compilenode(tree[yx].x,Gsmall,0);
899 70 : op_push(OCcompoL,0,y);
900 70 : compilecast(n,Gvec,mode);
901 70 : return;
902 609 : case MAT_column:
903 609 : compilenode(tree[yy].x,Gsmall,0);
904 609 : op_push(OCcompoC,0,y);
905 609 : compilecast(n,Gvec,mode);
906 609 : return;
907 763 : case MAT_range:
908 763 : compilenode(tree[yx].x,Gsmall,0);
909 763 : compilenode(tree[yx].y,Gsmall,0);
910 763 : if (yy==-1)
911 588 : op_push(OCcallgen,(long)is_entry("_[_.._]"),n);
912 : else
913 : {
914 175 : compilenode(tree[yy].x,Gsmall,0);
915 175 : compilenode(tree[yy].y,Gsmall,0);
916 175 : op_push(OCcallgen,(long)is_entry("_[_.._,_.._]"),n);
917 : }
918 763 : compilecast(n,Gvec,mode);
919 756 : return;
920 0 : default:
921 0 : pari_err_BUG("compilematcoeff");
922 : }
923 : }
924 :
925 : static void
926 11090027 : compilesmall(long n, long x, long mode)
927 : {
928 11090027 : if (mode==Ggen)
929 11005702 : op_push(OCpushstoi, x, n);
930 : else
931 : {
932 84325 : if (mode==Gusmall && x < 0) U_compile_err(tree[n].str);
933 84325 : op_push(OCpushlong, x, n);
934 84325 : compilecast(n,Gsmall,mode);
935 : }
936 11090020 : }
937 :
938 : static void
939 4461981 : compilevec(long n, long mode, op_code op)
940 : {
941 4461981 : pari_sp ltop=avma;
942 4461981 : long x=tree[n].x;
943 : long i;
944 4461981 : GEN arg=listtogen(x,Fmatrixelts);
945 4461981 : long l=lg(arg);
946 4461981 : op_push(op,l,n);
947 20306762 : for (i=1;i<l;i++)
948 : {
949 15844781 : if (tree[arg[i]].f==Fnoarg)
950 0 : compile_err("missing vector element",tree[arg[i]].str);
951 15844781 : compilenode(arg[i],Ggen,FLsurvive);
952 15844781 : op_push(OCstackgen,i,n);
953 : }
954 4461981 : set_avma(ltop);
955 4461981 : op_push(OCpop,1,n);
956 4461981 : compilecast(n,Gvec,mode);
957 4461981 : }
958 :
959 : static void
960 9590 : compilemat(long n, long mode)
961 : {
962 9590 : pari_sp ltop=avma;
963 9590 : long x=tree[n].x;
964 : long i,j;
965 9590 : GEN line=listtogen(x,Fmatrixlines);
966 9590 : long lglin = lg(line), lgcol=0;
967 9590 : op_push(OCpushlong, lglin,n);
968 9590 : if (lglin==1)
969 994 : op_push(OCmat,1,n);
970 47684 : for(i=1;i<lglin;i++)
971 : {
972 38094 : GEN col=listtogen(line[i],Fmatrixelts);
973 38094 : long l=lg(col), k;
974 38094 : if (i==1)
975 : {
976 8596 : lgcol=l;
977 8596 : op_push(OCmat,lgcol,n);
978 : }
979 29498 : else if (l!=lgcol)
980 0 : compile_err("matrix must be rectangular",tree[line[i]].str);
981 38094 : k=i;
982 290745 : for(j=1;j<lgcol;j++)
983 : {
984 252651 : k-=lglin;
985 252651 : if (tree[col[j]].f==Fnoarg)
986 0 : compile_err("missing matrix element",tree[col[j]].str);
987 252651 : compilenode(col[j], Ggen, FLsurvive);
988 252651 : op_push(OCstackgen,k,n);
989 : }
990 : }
991 9590 : set_avma(ltop);
992 9590 : op_push(OCpop,1,n);
993 9590 : compilecast(n,Gvec,mode);
994 9590 : }
995 :
996 : static GEN
997 47106 : cattovec(long n, long fnum)
998 : {
999 47106 : long x=n, y, i=0, nb;
1000 : GEN stack;
1001 47106 : if (tree[n].f==Fnoarg) return cgetg(1,t_VECSMALL);
1002 : while(1)
1003 210 : {
1004 47316 : long xx=tree[x].x;
1005 47316 : long xy=tree[x].y;
1006 47316 : if (tree[x].f!=Ffunction || xx!=fnum) break;
1007 210 : x=tree[xy].x;
1008 210 : y=tree[xy].y;
1009 210 : if (tree[y].f==Fnoarg)
1010 0 : compile_err("unexpected character: ", tree[y].str);
1011 210 : i++;
1012 : }
1013 47106 : if (tree[x].f==Fnoarg)
1014 0 : compile_err("unexpected character: ", tree[x].str);
1015 47106 : nb=i+1;
1016 47106 : stack=cgetg(nb+1,t_VECSMALL);
1017 47316 : for(x=n;i>0;i--)
1018 : {
1019 210 : long y=tree[x].y;
1020 210 : x=tree[y].x;
1021 210 : stack[i+1]=tree[y].y;
1022 : }
1023 47106 : stack[1]=x;
1024 47106 : return stack;
1025 : }
1026 :
1027 : static GEN
1028 339 : compilelambda(long y, GEN vep, long nbmvar, struct codepos *pos)
1029 : {
1030 339 : long lev = vep ? lg(vep)-1 : 0;
1031 339 : GEN text=cgetg(3,t_VEC);
1032 339 : gel(text,1)=strtoGENstr(lev? ((entree*) vep[1])->name: "");
1033 339 : gel(text,2)=strntoGENstr(tree[y].str,tree[y].len);
1034 339 : dbgstart = tree[y].str;
1035 339 : compilenode(y,Ggen,FLsurvive|FLreturn);
1036 339 : return getfunction(pos,lev,nbmvar,text,2);
1037 : }
1038 :
1039 : static void
1040 22752 : compilecall(long n, int mode, entree *ep)
1041 : {
1042 22752 : pari_sp ltop=avma;
1043 : long j;
1044 22752 : long x=tree[n].x, tx = tree[x].x;
1045 22752 : long y=tree[n].y;
1046 22752 : GEN arg=listtogen(y,Flistarg);
1047 22752 : long nb=lg(arg)-1;
1048 22752 : long lnc=first_safe_arg(arg, COsafelex|COsafedyn);
1049 22752 : long lnl=first_safe_arg(arg, COsafelex);
1050 22752 : long fl = lnl==0? (lnc==0? FLnocopy: FLnocopylex): 0;
1051 22752 : if (ep==NULL)
1052 322 : compilenode(x, Ggen, fl);
1053 : else
1054 : {
1055 22430 : long vn=getmvar(ep);
1056 22430 : if (vn)
1057 : {
1058 567 : access_push(vn);
1059 567 : op_push(OCpushlex,vn,n);
1060 : }
1061 : else
1062 21863 : op_push(OCpushdyn,(long)ep,n);
1063 : }
1064 61252 : for (j=1;j<=nb;j++)
1065 : {
1066 38500 : long x = tree[arg[j]].x, f = tree[arg[j]].f;
1067 38500 : if (f==Fseq)
1068 0 : compile_err("unexpected ';'", tree[x].str+tree[x].len);
1069 38500 : else if (f==Findarg)
1070 : {
1071 126 : long a = tree[arg[j]].x;
1072 126 : entree *ep = getlvalue(a);
1073 126 : long vn = getmvar(ep);
1074 126 : if (vn)
1075 49 : op_push(OCcowvarlex, vn, a);
1076 126 : compilenode(a, Ggen,FLnocopy);
1077 126 : op_push(OClock,0,n);
1078 38374 : } else if (tx==CSTmember)
1079 : {
1080 28 : compilenode(arg[j], Ggen,FLnocopy);
1081 28 : op_push(OClock,0,n);
1082 : }
1083 38346 : else if (f!=Fnoarg)
1084 38094 : compilenode(arg[j], Ggen,j>=lnl?FLnocopylex:0);
1085 : else
1086 252 : op_push(OCpushlong,0,n);
1087 : }
1088 22752 : op_push(OCcalluser,nb,x);
1089 22752 : compilecast(n,Ggen,mode);
1090 22752 : set_avma(ltop);
1091 22752 : }
1092 :
1093 : static GEN
1094 20178 : compilefuncinline(long n, long c, long a, long flag, long isif, long lev, long *ev)
1095 : {
1096 : struct codepos pos;
1097 20178 : int type=c=='I'?Gvoid:Ggen;
1098 20178 : long rflag=c=='I'?0:FLsurvive;
1099 20178 : long nbmvar = nblex;
1100 20178 : GEN vep = NULL;
1101 20178 : if (isif && (flag&FLreturn)) rflag|=FLreturn;
1102 20178 : getcodepos(&pos);
1103 20178 : if (c=='J') ctxmvar(nbmvar);
1104 20178 : if (lev)
1105 : {
1106 : long i;
1107 11828 : GEN varg=cgetg(lev+1,t_VECSMALL);
1108 11828 : vep=cgetg(lev+1,t_VECSMALL);
1109 24416 : for(i=0;i<lev;i++)
1110 : {
1111 : entree *ve;
1112 12588 : if (ev[i]<0)
1113 0 : compile_err("missing variable name", tree[a].str-1);
1114 12588 : ve = getvar(ev[i]);
1115 12588 : vep[i+1]=(long)ve;
1116 12588 : varg[i+1]=ev[i];
1117 12588 : var_push(ve,Lmy);
1118 : }
1119 11828 : checkdups(varg,vep);
1120 11828 : if (c=='J')
1121 339 : op_push(OCgetargs,lev,n);
1122 11828 : access_push(lg(vep)-1);
1123 11828 : frame_push(vep);
1124 : }
1125 20178 : if (c=='J')
1126 339 : return compilelambda(a,vep,nbmvar,&pos);
1127 19839 : if (tree[a].f==Fnoarg)
1128 134 : compilecast(a,Gvoid,type);
1129 : else
1130 19705 : compilenode(a,type,rflag);
1131 19839 : return getclosure(&pos, nbmvar);
1132 : }
1133 :
1134 : static long
1135 3322 : countvar(GEN arg)
1136 : {
1137 3322 : long i, l = lg(arg);
1138 3322 : long n = l-1;
1139 10328 : for(i=1; i<l; i++)
1140 : {
1141 7006 : long a=arg[i];
1142 7006 : if (tree[a].f==Fassign)
1143 : {
1144 3889 : long x = detag(tree[a].x);
1145 3889 : if (tree[x].f==Fvec && tree[x].x>=0)
1146 406 : n += countmatrixelts(tree[x].x)-1;
1147 : }
1148 : }
1149 3322 : return n;
1150 : }
1151 :
1152 : static void
1153 6 : compileuninline(GEN arg)
1154 : {
1155 : long j;
1156 6 : if (lg(arg) > 1)
1157 0 : compile_err("too many arguments",tree[arg[1]].str);
1158 18 : for(j=0; j<s_lvar.n; j++)
1159 12 : if(!localvars[j].inl)
1160 0 : pari_err(e_MISC,"uninline is only valid at top level");
1161 6 : s_lvar.n = 0; nblex = 0;
1162 6 : }
1163 :
1164 : static void
1165 3294 : compilemy(GEN arg, const char *str, int inl)
1166 : {
1167 3294 : long i, j, k, l = lg(arg);
1168 3294 : long n = countvar(arg);
1169 3294 : GEN vep = cgetg(n+1,t_VECSMALL);
1170 3294 : GEN ver = cgetg(n+1,t_VECSMALL);
1171 3294 : if (inl)
1172 : {
1173 13 : for(j=0; j<s_lvar.n; j++)
1174 0 : if(!localvars[j].inl)
1175 0 : pari_err(e_MISC,"inline is only valid at top level");
1176 : }
1177 10244 : for(k=0, i=1; i<l; i++)
1178 : {
1179 6950 : long a=arg[i];
1180 6950 : if (tree[a].f==Fassign)
1181 : {
1182 3847 : long x = detag(tree[a].x);
1183 3847 : if (tree[x].f==Fvec && tree[x].x>=0)
1184 392 : {
1185 392 : GEN vars = listtogen(tree[x].x,Fmatrixelts);
1186 392 : long nv = lg(vars)-1;
1187 1309 : for (j=1; j<=nv; j++)
1188 917 : if (tree[vars[j]].f!=Fnoarg)
1189 : {
1190 903 : ver[++k] = vars[j];
1191 903 : vep[k] = (long)getvar(ver[k]);
1192 : }
1193 392 : continue;
1194 3455 : } else ver[++k] = x;
1195 3103 : } else ver[++k] = a;
1196 6558 : vep[k] = (long)getvar(ver[k]);
1197 : }
1198 3294 : checkdups(ver,vep);
1199 10755 : for(i=1; i<=n; i++) var_push(NULL,Lmy);
1200 3294 : op_push_loc(OCnewframe,inl?-n:n,str);
1201 3294 : access_push(lg(vep)-1);
1202 3294 : frame_push(vep);
1203 10244 : for (k=0, i=1; i<l; i++)
1204 : {
1205 6950 : long a=arg[i];
1206 6950 : if (tree[a].f==Fassign)
1207 : {
1208 3847 : long x = detag(tree[a].x);
1209 3847 : if (tree[x].f==Fvec && tree[x].x>=0)
1210 392 : {
1211 392 : GEN vars = listtogen(tree[x].x,Fmatrixelts);
1212 392 : long nv = lg(vars)-1, m = nv;
1213 392 : compilenode(tree[a].y,Ggen,FLnocopy);
1214 1309 : for (j=1; j<=nv; j++)
1215 917 : if (tree[vars[j]].f==Fnoarg) m--;
1216 392 : if (m > 1) op_push(OCdup,m-1,x);
1217 1309 : for (j=1; j<=nv; j++)
1218 917 : if (tree[vars[j]].f!=Fnoarg)
1219 : {
1220 903 : long v = detag(vars[j]);
1221 903 : op_push(OCpushlong,j,v);
1222 903 : op_push(OCcompo1,Ggen,v);
1223 903 : k++;
1224 903 : op_push(OCstorelex,-n+k-1,a);
1225 903 : localvars[s_lvar.n-n+k-1].ep=(entree*)vep[k];
1226 903 : localvars[s_lvar.n-n+k-1].inl=inl;
1227 : }
1228 392 : continue;
1229 : }
1230 3455 : else if (!is_node_zero(tree[a].y))
1231 : {
1232 3314 : compilenode(tree[a].y,Ggen,FLnocopy);
1233 3314 : op_push(OCstorelex,-n+k,a);
1234 : }
1235 : }
1236 6558 : k++;
1237 6558 : localvars[s_lvar.n-n+k-1].ep=(entree*)vep[k];
1238 6558 : localvars[s_lvar.n-n+k-1].inl=inl;
1239 : }
1240 3294 : }
1241 :
1242 : static long
1243 70 : localpush(op_code op, long a)
1244 : {
1245 70 : entree *ep = getvardyn(a);
1246 70 : long vep = (long) ep;
1247 70 : op_push(op,vep,a);
1248 70 : var_push(ep,Llocal);
1249 70 : return vep;
1250 : }
1251 :
1252 : static void
1253 28 : compilelocal(GEN arg)
1254 : {
1255 28 : long i, j, k, l = lg(arg);
1256 28 : long n = countvar(arg);
1257 28 : GEN vep = cgetg(n+1,t_VECSMALL);
1258 28 : GEN ver = cgetg(n+1,t_VECSMALL);
1259 84 : for(k=0, i=1; i<l; i++)
1260 : {
1261 56 : long a=arg[i];
1262 56 : if (tree[a].f==Fassign)
1263 : {
1264 42 : long x = detag(tree[a].x);
1265 42 : if (tree[x].f==Fvec && tree[x].x>=0)
1266 14 : {
1267 14 : GEN vars = listtogen(tree[x].x,Fmatrixelts);
1268 14 : long nv = lg(vars)-1, m = nv;
1269 14 : compilenode(tree[a].y,Ggen,FLnocopy);
1270 56 : for (j=1; j<=nv; j++)
1271 42 : if (tree[vars[j]].f==Fnoarg) m--;
1272 14 : if (m > 1) op_push(OCdup,m-1,x);
1273 56 : for (j=1; j<=nv; j++)
1274 42 : if (tree[vars[j]].f!=Fnoarg)
1275 : {
1276 28 : long v = detag(vars[j]);
1277 28 : op_push(OCpushlong,j,v);
1278 28 : op_push(OCcompo1,Ggen,v);
1279 28 : vep[++k] = localpush(OClocalvar, v);
1280 28 : ver[k] = v;
1281 : }
1282 14 : continue;
1283 28 : } else if (!is_node_zero(tree[a].y))
1284 : {
1285 21 : compilenode(tree[a].y,Ggen,FLnocopy);
1286 21 : ver[++k] = x;
1287 21 : vep[k] = localpush(OClocalvar, ver[k]);
1288 21 : continue;
1289 : }
1290 : else
1291 7 : ver[++k] = x;
1292 : } else
1293 14 : ver[++k] = a;
1294 21 : vep[k] = localpush(OClocalvar0, ver[k]);
1295 : }
1296 28 : checkdups(ver,vep);
1297 28 : }
1298 :
1299 : static void
1300 41 : compileexport(GEN arg)
1301 : {
1302 41 : long i, l = lg(arg);
1303 82 : for (i=1; i<l; i++)
1304 : {
1305 41 : long a=arg[i];
1306 41 : if (tree[a].f==Fassign)
1307 : {
1308 14 : long x = detag(tree[a].x);
1309 14 : long v = (long) getvardyn(x);
1310 14 : compilenode(tree[a].y,Ggen,FLnocopy);
1311 14 : op_push(OCexportvar,v,x);
1312 : } else
1313 : {
1314 27 : long x = detag(a);
1315 27 : long v = (long) getvardyn(x);
1316 27 : op_push(OCpushdyn,v,x);
1317 27 : op_push(OCexportvar,v,x);
1318 : }
1319 : }
1320 41 : }
1321 :
1322 : static void
1323 6 : compileunexport(GEN arg)
1324 : {
1325 6 : long i, l = lg(arg);
1326 12 : for (i=1; i<l; i++)
1327 : {
1328 6 : long a = arg[i];
1329 6 : long x = detag(a);
1330 6 : long v = (long) getvardyn(x);
1331 6 : op_push(OCunexportvar,v,x);
1332 : }
1333 6 : }
1334 :
1335 : static void
1336 4669257 : compilefunc(entree *ep, long n, int mode, long flag)
1337 : {
1338 4669257 : pari_sp ltop=avma;
1339 : long j;
1340 4669257 : long x=tree[n].x, y=tree[n].y;
1341 : op_code ret_op;
1342 : long ret_flag;
1343 : Gtype ret_typ;
1344 : char const *p,*q;
1345 : char c;
1346 : const char *str;
1347 : PPproto mod;
1348 4669257 : GEN arg=listtogen(y,Flistarg);
1349 4669257 : long lnc=first_safe_arg(arg, COsafelex|COsafedyn);
1350 4669257 : long lnl=first_safe_arg(arg, COsafelex);
1351 4669257 : long nbpointers=0, nbopcodes;
1352 4669257 : long nb=lg(arg)-1, lev=0;
1353 : long ev[20];
1354 4669257 : if (x>=OPnboperator)
1355 199592 : str=tree[x].str;
1356 : else
1357 : {
1358 4469665 : if (nb==2)
1359 348709 : str=tree[arg[1]].str+tree[arg[1]].len;
1360 4120956 : else if (nb==1)
1361 4119979 : str=tree[arg[1]].str;
1362 : else
1363 977 : str=tree[n].str;
1364 4475897 : while(*str==')') str++;
1365 : }
1366 4669257 : if (tree[n].f==Fassign)
1367 : {
1368 0 : nb=2; lnc=2; lnl=2; arg=mkvecsmall2(x,y);
1369 : }
1370 4669257 : else if (is_func_named(ep,"if"))
1371 : {
1372 4774 : if (nb>=4)
1373 119 : ep=is_entry("_multi_if");
1374 4655 : else if (mode==Gvoid)
1375 3001 : ep=is_entry("_void_if");
1376 : }
1377 4664483 : else if (is_func_named(ep,"return") && (flag&FLreturn) && nb<=1)
1378 : {
1379 105 : if (nb==0) op_push(OCpushgnil,0,n);
1380 105 : else compilenode(arg[1],Ggen,FLsurvive|FLreturn);
1381 105 : set_avma(ltop);
1382 3733808 : return;
1383 : }
1384 4664378 : else if (is_func_named(ep,"inline"))
1385 : {
1386 13 : compilemy(arg, str, 1);
1387 13 : compilecast(n,Gvoid,mode);
1388 13 : set_avma(ltop);
1389 13 : return;
1390 : }
1391 4664365 : else if (is_func_named(ep,"uninline"))
1392 : {
1393 6 : compileuninline(arg);
1394 6 : compilecast(n,Gvoid,mode);
1395 6 : set_avma(ltop);
1396 6 : return;
1397 : }
1398 4664359 : else if (is_func_named(ep,"my"))
1399 : {
1400 3281 : compilemy(arg, str, 0);
1401 3281 : compilecast(n,Gvoid,mode);
1402 3281 : set_avma(ltop);
1403 3281 : return;
1404 : }
1405 4661078 : else if (is_func_named(ep,"local"))
1406 : {
1407 28 : compilelocal(arg);
1408 28 : compilecast(n,Gvoid,mode);
1409 28 : set_avma(ltop);
1410 28 : return;
1411 : }
1412 4661050 : else if (is_func_named(ep,"export"))
1413 : {
1414 41 : compileexport(arg);
1415 41 : compilecast(n,Gvoid,mode);
1416 41 : set_avma(ltop);
1417 41 : return;
1418 : }
1419 4661009 : else if (is_func_named(ep,"unexport"))
1420 : {
1421 6 : compileunexport(arg);
1422 6 : compilecast(n,Gvoid,mode);
1423 6 : set_avma(ltop);
1424 6 : return;
1425 : }
1426 : /*We generate dummy code for global() for compatibility with gp2c*/
1427 4661003 : else if (is_func_named(ep,"global"))
1428 : {
1429 : long i;
1430 21 : for (i=1;i<=nb;i++)
1431 : {
1432 14 : long a=arg[i];
1433 : long en;
1434 14 : if (tree[a].f==Fassign)
1435 : {
1436 7 : compilenode(tree[a].y,Ggen,0);
1437 7 : a=tree[a].x;
1438 7 : en=(long)getvardyn(a);
1439 7 : op_push(OCstoredyn,en,a);
1440 : }
1441 : else
1442 : {
1443 7 : en=(long)getvardyn(a);
1444 7 : op_push(OCpushdyn,en,a);
1445 7 : op_push(OCpop,1,a);
1446 : }
1447 : }
1448 7 : compilecast(n,Gvoid,mode);
1449 7 : set_avma(ltop);
1450 7 : return;
1451 : }
1452 4660996 : else if (is_func_named(ep,"O"))
1453 : {
1454 4725 : if (nb!=1)
1455 0 : compile_err("wrong number of arguments", tree[n].str+tree[n].len-1);
1456 4725 : ep=is_entry("O(_^_)");
1457 4725 : if (tree[arg[1]].f==Ffunction && tree[arg[1]].x==OPpow)
1458 : {
1459 3577 : arg = listtogen(tree[arg[1]].y,Flistarg);
1460 3577 : nb = lg(arg)-1;
1461 3577 : lnc = first_safe_arg(arg,COsafelex|COsafedyn);
1462 3577 : lnl = first_safe_arg(arg,COsafelex);
1463 : }
1464 : }
1465 4656271 : else if (x==OPn && tree[y].f==Fsmall)
1466 : {
1467 3725981 : set_avma(ltop);
1468 3725981 : compilesmall(y, -tree[y].x, mode);
1469 3725981 : return;
1470 : }
1471 930290 : else if (x==OPtrans && tree[y].f==Fvec)
1472 : {
1473 4340 : set_avma(ltop);
1474 4340 : compilevec(y, mode, OCcol);
1475 4340 : return;
1476 925950 : } else if(x==OPlength && tree[y].f==Ffunction && tree[y].x==OPtrans)
1477 : {
1478 7 : arg[1] = tree[y].y;
1479 7 : lnc = first_safe_arg(arg,COsafelex|COsafedyn);
1480 7 : lnl = first_safe_arg(arg,COsafelex);
1481 7 : ep = is_entry("#_~");
1482 : }
1483 925943 : else if (x==OPpow && nb==2)
1484 69771 : {
1485 69771 : long a = arg[2];
1486 69771 : if (tree[a].f==Fsmall)
1487 : {
1488 65176 : if(tree[a].x==2) { nb--; ep=is_entry("sqr"); }
1489 46993 : else ep=is_entry("_^s");
1490 : }
1491 4595 : else if (tree[a].f == Ffunction && tree[a].x == OPn)
1492 : {
1493 1281 : long ay = tree[a].y;
1494 1281 : if (tree[ay].f==Fsmall)
1495 : {
1496 1134 : if (tree[ay].x==1) {nb--; ep=is_entry("_inv"); }
1497 756 : else ep=is_entry("_^s");
1498 : }
1499 : }
1500 : }
1501 856172 : else if (x==OPcat)
1502 0 : compile_err("expected character: ',' or ')' instead of",
1503 0 : tree[arg[1]].str+tree[arg[1]].len);
1504 935449 : p=ep->code;
1505 935449 : if (!ep->value)
1506 0 : compile_err("unknown function",tree[n].str);
1507 935449 : nbopcodes = s_opcode.n;
1508 935449 : ret_op = get_ret_type(&p, ep->arity, &ret_typ, &ret_flag);
1509 935449 : j=1;
1510 935449 : if (*p)
1511 : {
1512 926597 : q=p;
1513 2430959 : while((mod=parseproto(&p,&c,tree[n].str))!=PPend)
1514 : {
1515 1504404 : if (j<=nb && tree[arg[j]].f!=Fnoarg
1516 1398153 : && (mod==PPdefault || mod==PPdefaultmulti))
1517 65756 : mod=PPstd;
1518 1504404 : switch(mod)
1519 : {
1520 1383714 : case PPstd:
1521 1383714 : if (j>nb) compile_err("too few arguments", tree[n].str+tree[n].len-1);
1522 1383714 : if (c!='I' && c!='E' && c!='J')
1523 : {
1524 1364019 : long x = tree[arg[j]].x, f = tree[arg[j]].f;
1525 1364019 : if (f==Fnoarg)
1526 0 : compile_err("missing mandatory argument", tree[arg[j]].str);
1527 1364019 : if (f==Fseq)
1528 0 : compile_err("unexpected ';'", tree[x].str+tree[x].len);
1529 : }
1530 1383714 : switch(c)
1531 : {
1532 1267626 : case 'G':
1533 1267626 : compilenode(arg[j],Ggen,j>=lnl?(j>=lnc?FLnocopy:FLnocopylex):0);
1534 1267626 : j++;
1535 1267626 : break;
1536 448 : case 'W':
1537 : {
1538 448 : long a = tree[arg[j]].f==Findarg ? tree[arg[j]].x: arg[j];
1539 448 : entree *ep = getlvalue(a);
1540 434 : long vn = getmvar(ep);
1541 434 : if (vn)
1542 224 : op_push(OCcowvarlex, vn, a);
1543 210 : else op_push(OCcowvardyn, (long)ep, a);
1544 434 : compilenode(a, Ggen,FLnocopy);
1545 434 : j++;
1546 434 : break;
1547 : }
1548 84 : case 'M':
1549 84 : if (tree[arg[j]].f!=Fsmall)
1550 : {
1551 35 : const char *flags = ep->code;
1552 35 : flags = strchr(flags, '\n'); /* Skip to the following '\n' */
1553 35 : if (!flags)
1554 0 : compile_err("missing flag in string function signature",
1555 0 : tree[n].str);
1556 35 : flags++;
1557 35 : if (tree[arg[j]].f==Fconst && tree[arg[j]].x==CSTstr)
1558 35 : {
1559 35 : GEN str=strntoGENexp(tree[arg[j]].str,tree[arg[j]].len);
1560 35 : op_push(OCpushlong, eval_mnemonic(str, flags),n);
1561 35 : j++;
1562 : } else
1563 : {
1564 0 : compilenode(arg[j++],Ggen,FLnocopy);
1565 0 : op_push(OCevalmnem,(long)ep,n);
1566 : }
1567 35 : break;
1568 : }
1569 : case 'P': case 'L':
1570 73762 : compilenode(arg[j++],Gsmall,0);
1571 73755 : break;
1572 207 : case 'U':
1573 207 : compilenode(arg[j++],Gusmall,0);
1574 200 : break;
1575 3786 : case 'n':
1576 3786 : compilenode(arg[j++],Gvar,0);
1577 3779 : break;
1578 2266 : case '&': case '*':
1579 : {
1580 2266 : long vn, a=arg[j++];
1581 : entree *ep;
1582 2266 : if (c=='&')
1583 : {
1584 1498 : if (tree[a].f!=Frefarg)
1585 0 : compile_err("expected character: '&'", tree[a].str);
1586 1498 : a=tree[a].x;
1587 : }
1588 2266 : a=detag(a);
1589 2266 : ep=getlvalue(a);
1590 2266 : vn=getmvar(ep);
1591 2266 : if (tree[a].f==Fentry)
1592 : {
1593 2070 : if (vn)
1594 : {
1595 509 : access_push(vn);
1596 509 : op_push(OCsimpleptrlex, vn,n);
1597 : }
1598 : else
1599 1561 : op_push(OCsimpleptrdyn, (long)ep,n);
1600 : }
1601 : else
1602 : {
1603 196 : compilenewptr(vn, ep, a);
1604 196 : compilelvalue(a);
1605 196 : op_push(OCpushptr, 0, a);
1606 : }
1607 2266 : nbpointers++;
1608 2266 : break;
1609 : }
1610 19695 : case 'I':
1611 : case 'E':
1612 : case 'J':
1613 : {
1614 19695 : long a = arg[j++];
1615 19695 : GEN d = compilefuncinline(n, c, a, flag, is_func_named(ep,"if"), lev, ev);
1616 19695 : op_push(OCpushgen, data_push(d), a);
1617 19695 : if (lg(d)==8) op_push(OCsaveframe,FLsurvive,n);
1618 19695 : break;
1619 : }
1620 5312 : case 'V':
1621 : {
1622 5312 : long a = arg[j++];
1623 5312 : (void)getvar(a);
1624 5305 : ev[lev++] = a;
1625 5305 : break;
1626 : }
1627 6742 : case '=':
1628 : {
1629 6742 : long a = arg[j++];
1630 6742 : ev[lev++] = tree[a].x;
1631 6742 : compilenode(tree[a].y, Ggen, FLnocopy);
1632 : }
1633 6742 : break;
1634 1104 : case 'r':
1635 : {
1636 1104 : long a=arg[j++];
1637 1104 : if (tree[a].f==Fentry)
1638 : {
1639 1025 : op_push(OCpushgen, data_push(strntoGENstr(tree[tree[a].x].str,
1640 1025 : tree[tree[a].x].len)),n);
1641 1025 : op_push(OCtostr, -1,n);
1642 : }
1643 : else
1644 : {
1645 79 : compilenode(a,Ggen,FLnocopy);
1646 79 : op_push(OCtostr, -1,n);
1647 : }
1648 1104 : break;
1649 : }
1650 2731 : case 's':
1651 : {
1652 2731 : long a = arg[j++];
1653 2731 : GEN g = cattovec(a, OPcat);
1654 2731 : long l, nb = lg(g)-1;
1655 2731 : if (nb==1)
1656 : {
1657 2661 : compilenode(g[1], Ggen, FLnocopy);
1658 2661 : op_push(OCtostr, -1, a);
1659 : } else
1660 : {
1661 70 : op_push(OCvec, nb+1, a);
1662 210 : for(l=1; l<=nb; l++)
1663 : {
1664 140 : compilenode(g[l], Ggen, FLsurvive);
1665 140 : op_push(OCstackgen,l, a);
1666 : }
1667 70 : op_push(OCpop, 1, a);
1668 70 : op_push(OCcallgen,(long)is_entry("Str"), a);
1669 70 : op_push(OCtostr, -1, a);
1670 : }
1671 2731 : break;
1672 : }
1673 0 : default:
1674 0 : pari_err(e_MISC,"Unknown prototype code `%c' for `%.*s'",c,
1675 0 : tree[x].len, tree[x].str);
1676 : }
1677 1383672 : break;
1678 32829 : case PPauto:
1679 32829 : switch(c)
1680 : {
1681 28632 : case 'p':
1682 28632 : op_push(OCprecreal,0,n);
1683 28632 : break;
1684 4144 : case 'b':
1685 4144 : op_push(OCbitprecreal,0,n);
1686 4144 : break;
1687 0 : case 'P':
1688 0 : op_push(OCprecdl,0,n);
1689 0 : break;
1690 53 : case 'C':
1691 53 : op_push(OCpushgen,data_push(pack_localvars()),n);
1692 53 : break;
1693 0 : case 'f':
1694 : {
1695 : static long foo;
1696 0 : op_push(OCpushlong,(long)&foo,n);
1697 0 : break;
1698 : }
1699 : }
1700 32829 : break;
1701 42310 : case PPdefault:
1702 42310 : j++;
1703 42310 : switch(c)
1704 : {
1705 32586 : case 'G':
1706 : case '&':
1707 : case 'E':
1708 : case 'I':
1709 : case 'r':
1710 : case 's':
1711 32586 : op_push(OCpushlong,0,n);
1712 32586 : break;
1713 8479 : case 'n':
1714 8479 : op_push(OCpushlong,-1,n);
1715 8479 : break;
1716 902 : case 'V':
1717 902 : ev[lev++] = -1;
1718 902 : break;
1719 343 : case 'P':
1720 343 : op_push(OCprecdl,0,n);
1721 343 : break;
1722 0 : default:
1723 0 : pari_err(e_MISC,"Unknown prototype code `%c' for `%.*s'",c,
1724 0 : tree[x].len, tree[x].str);
1725 : }
1726 42310 : break;
1727 30673 : case PPdefaultmulti:
1728 30673 : j++;
1729 30673 : switch(c)
1730 : {
1731 0 : case 'G':
1732 0 : op_push(OCpushstoi,strtol(q+1,NULL,10),n);
1733 0 : break;
1734 30556 : case 'L':
1735 : case 'M':
1736 30556 : op_push(OCpushlong,strtol(q+1,NULL,10),n);
1737 30556 : break;
1738 42 : case 'U':
1739 42 : op_push(OCpushlong,(long)strtoul(q+1,NULL,10),n);
1740 42 : break;
1741 75 : case 'r':
1742 : case 's':
1743 75 : str_defproto(p, q, tree[n].str);
1744 75 : op_push(OCtostr, -1, n);
1745 75 : break;
1746 0 : default:
1747 0 : pari_err(e_MISC,"Unknown prototype code `%c' for `%.*s'",c,
1748 0 : tree[x].len, tree[x].str);
1749 : }
1750 30673 : break;
1751 14878 : case PPstar:
1752 14878 : switch(c)
1753 : {
1754 119 : case 'E':
1755 : {
1756 119 : long k, n=nb+1-j;
1757 119 : GEN g=cgetg(n+1,t_VEC);
1758 119 : int ismif = is_func_named(ep,"_multi_if");
1759 602 : for(k=1; k<=n; k++)
1760 552 : gel(g, k) = compilefuncinline(n, c, arg[j+k-1], flag,
1761 483 : ismif && (k==n || odd(k)), lev, ev);
1762 119 : op_push(OCpushgen, data_push(g), arg[j]);
1763 119 : j=nb+1;
1764 119 : break;
1765 : }
1766 14759 : case 's':
1767 : {
1768 14759 : long n=nb+1-j;
1769 : long k,l,l1,m;
1770 14759 : GEN g=cgetg(n+1,t_VEC);
1771 35581 : for(l1=0,k=1;k<=n;k++)
1772 : {
1773 20822 : gel(g,k)=cattovec(arg[j+k-1],OPcat);
1774 20822 : l1+=lg(gel(g,k))-1;
1775 : }
1776 14759 : op_push_loc(OCvec, l1+1, str);
1777 35581 : for(m=1,k=1;k<=n;k++)
1778 41679 : for(l=1;l<lg(gel(g,k));l++,m++)
1779 : {
1780 20857 : compilenode(mael(g,k,l),Ggen,FLsurvive);
1781 20857 : op_push(OCstackgen,m,mael(g,k,l));
1782 : }
1783 14759 : op_push_loc(OCpop, 1, str);
1784 14759 : j=nb+1;
1785 14759 : break;
1786 : }
1787 0 : default:
1788 0 : pari_err(e_MISC,"Unknown prototype code `%c*' for `%.*s'",c,
1789 0 : tree[x].len, tree[x].str);
1790 : }
1791 14878 : break;
1792 0 : default:
1793 0 : pari_err_BUG("compilefunc [unknown PPproto]");
1794 : }
1795 1504362 : q=p;
1796 : }
1797 : }
1798 935407 : if (j<=nb)
1799 0 : compile_err("too many arguments",tree[arg[j]].str);
1800 935407 : op_push_loc(ret_op, (long) ep, str);
1801 935407 : if (mode==Ggen && (ret_flag&FLnocopy) && !(flag&FLnocopy))
1802 10667 : op_push_loc(OCcopy,0,str);
1803 935407 : if (ret_typ==Ggen && nbpointers==0 && s_opcode.n>nbopcodes+128)
1804 : {
1805 2940 : op_insert_loc(nbopcodes,OCavma,0,str);
1806 2940 : op_push_loc(OCgerepile,0,str);
1807 : }
1808 935407 : compilecast(n,ret_typ,mode);
1809 935407 : if (nbpointers) op_push_loc(OCendptr,nbpointers, str);
1810 935407 : set_avma(ltop);
1811 : }
1812 :
1813 : static void
1814 7986728 : genclosurectx(const char *loc, long nbdata)
1815 : {
1816 : long i;
1817 7986728 : GEN vep = cgetg(nbdata+1,t_VECSMALL);
1818 28243691 : for(i = 1; i <= nbdata; i++)
1819 : {
1820 20256995 : vep[i] = 0;
1821 20256995 : op_push_loc(OCpushlex,-i,loc);
1822 : }
1823 7986696 : frame_push(vep);
1824 7986733 : }
1825 :
1826 : static GEN
1827 7997127 : genclosure(entree *ep, const char *loc, long nbdata, int check)
1828 : {
1829 : struct codepos pos;
1830 7997127 : long nb=0;
1831 7997127 : const char *code=ep->code,*p,*q;
1832 : char c;
1833 : GEN text;
1834 7997127 : long index=ep->arity;
1835 7997127 : long arity=0, maskarg=0, maskarg0=0, stop=0, dovararg=0;
1836 : PPproto mod;
1837 : Gtype ret_typ;
1838 : long ret_flag;
1839 7997127 : op_code ret_op=get_ret_type(&code,ep->arity,&ret_typ,&ret_flag);
1840 7997098 : p=code;
1841 36251453 : while ((mod=parseproto(&p,&c,NULL))!=PPend)
1842 : {
1843 28254355 : if (mod==PPauto)
1844 1989 : stop=1;
1845 : else
1846 : {
1847 28252366 : if (stop) return NULL;
1848 28252366 : if (c=='V') continue;
1849 28252366 : maskarg<<=1; maskarg0<<=1; arity++;
1850 28252366 : switch(mod)
1851 : {
1852 28251146 : case PPstd:
1853 28251146 : maskarg|=1L;
1854 28251146 : break;
1855 482 : case PPdefault:
1856 482 : switch(c)
1857 : {
1858 28 : case '&':
1859 : case 'E':
1860 : case 'I':
1861 28 : maskarg0|=1L;
1862 28 : break;
1863 : }
1864 482 : break;
1865 738 : default:
1866 738 : break;
1867 : }
1868 : }
1869 : }
1870 7997007 : if (check && EpSTATIC(ep) && maskarg==0)
1871 8509 : return gen_0;
1872 7988498 : getcodepos(&pos);
1873 7988536 : dbgstart = loc;
1874 7988536 : if (nbdata > arity)
1875 0 : pari_err(e_MISC,"too many parameters for closure `%s'", ep->name);
1876 7988536 : if (nbdata) genclosurectx(loc, nbdata);
1877 7988542 : text = strtoGENstr(ep->name);
1878 7988535 : arity -= nbdata;
1879 7988535 : if (maskarg) op_push_loc(OCcheckargs,maskarg,loc);
1880 7988499 : if (maskarg0) op_push_loc(OCcheckargs0,maskarg0,loc);
1881 7988499 : p=code;
1882 36240895 : while ((mod=parseproto(&p,&c,NULL))!=PPend)
1883 : {
1884 28252364 : switch(mod)
1885 : {
1886 652 : case PPauto:
1887 652 : switch(c)
1888 : {
1889 652 : case 'p':
1890 652 : op_push_loc(OCprecreal,0,loc);
1891 652 : break;
1892 0 : case 'b':
1893 0 : op_push_loc(OCbitprecreal,0,loc);
1894 0 : break;
1895 0 : case 'P':
1896 0 : op_push_loc(OCprecdl,0,loc);
1897 0 : break;
1898 0 : case 'C':
1899 0 : op_push_loc(OCpushgen,data_push(pack_localvars()),loc);
1900 32 : break;
1901 0 : case 'f':
1902 : {
1903 : static long foo;
1904 0 : op_push_loc(OCpushlong,(long)&foo,loc);
1905 0 : break;
1906 : }
1907 : }
1908 : default:
1909 28252396 : break;
1910 : }
1911 : }
1912 7988502 : q = p = code;
1913 36240884 : while ((mod=parseproto(&p,&c,NULL))!=PPend)
1914 : {
1915 28252382 : switch(mod)
1916 : {
1917 28250958 : case PPstd:
1918 28250958 : switch(c)
1919 : {
1920 28221906 : case 'G':
1921 28221906 : break;
1922 17649 : case 'M':
1923 : case 'L':
1924 17649 : op_push_loc(OCitos,-index,loc);
1925 17649 : break;
1926 11364 : case 'U':
1927 11364 : op_push_loc(OCitou,-index,loc);
1928 11364 : break;
1929 0 : case 'n':
1930 0 : op_push_loc(OCvarn,-index,loc);
1931 0 : break;
1932 0 : case '&': case '*':
1933 : case 'I':
1934 : case 'E':
1935 : case 'V':
1936 : case '=':
1937 0 : return NULL;
1938 37 : case 'r':
1939 : case 's':
1940 37 : op_push_loc(OCtostr,-index,loc);
1941 37 : break;
1942 : }
1943 28250958 : break;
1944 652 : case PPauto:
1945 652 : break;
1946 412 : case PPdefault:
1947 412 : switch(c)
1948 : {
1949 216 : case 'G':
1950 : case '&':
1951 : case 'E':
1952 : case 'I':
1953 : case 'V':
1954 216 : break;
1955 14 : case 'r':
1956 : case 's':
1957 14 : op_push_loc(OCtostr,-index,loc);
1958 14 : break;
1959 112 : case 'n':
1960 112 : op_push_loc(OCvarn,-index,loc);
1961 112 : break;
1962 70 : case 'P':
1963 70 : op_push_loc(OCprecdl,0,loc);
1964 70 : op_push_loc(OCdefaultlong,-index,loc);
1965 70 : break;
1966 0 : default:
1967 0 : pari_err(e_MISC,"Unknown prototype code `D%c' for `%s'",c,ep->name);
1968 : }
1969 412 : break;
1970 339 : case PPdefaultmulti:
1971 339 : switch(c)
1972 : {
1973 0 : case 'G':
1974 0 : op_push_loc(OCpushstoi,strtol(q+1,NULL,10),loc);
1975 0 : op_push_loc(OCdefaultgen,-index,loc);
1976 0 : break;
1977 319 : case 'L':
1978 : case 'M':
1979 319 : op_push_loc(OCpushlong,strtol(q+1,NULL,10),loc);
1980 319 : op_push_loc(OCdefaultlong,-index,loc);
1981 319 : break;
1982 4 : case 'U':
1983 4 : op_push_loc(OCpushlong,(long)strtoul(q+1,NULL,10),loc);
1984 4 : op_push_loc(OCdefaultulong,-index,loc);
1985 4 : break;
1986 16 : case 'r':
1987 : case 's':
1988 16 : str_defproto(p, q, loc);
1989 16 : op_push_loc(OCdefaultgen,-index,loc);
1990 16 : op_push_loc(OCtostr,-index,loc);
1991 16 : break;
1992 0 : default:
1993 0 : pari_err(e_MISC,
1994 : "Unknown prototype code `D...,%c,' for `%s'",c,ep->name);
1995 : }
1996 339 : break;
1997 21 : case PPstar:
1998 21 : switch(c)
1999 : {
2000 21 : case 's':
2001 21 : dovararg = 1;
2002 21 : break;
2003 0 : case 'E':
2004 0 : return NULL;
2005 0 : default:
2006 0 : pari_err(e_MISC,"Unknown prototype code `%c*' for `%s'",c,ep->name);
2007 : }
2008 21 : break;
2009 0 : default:
2010 0 : return NULL;
2011 : }
2012 28252382 : index--;
2013 28252382 : q = p;
2014 : }
2015 7988459 : op_push_loc(ret_op, (long) ep, loc);
2016 7988489 : if (ret_flag==FLnocopy) op_push_loc(OCcopy,0,loc);
2017 7988489 : compilecast_loc(ret_typ, Ggen, loc);
2018 7988488 : if (dovararg) nb|=VARARGBITS;
2019 7988488 : return getfunction(&pos,nb+arity,nbdata,text,0);
2020 : }
2021 :
2022 : GEN
2023 7985109 : snm_closure(entree *ep, GEN data)
2024 : {
2025 7985109 : long i, n = data ? lg(data)-1: 0;
2026 7985109 : GEN C = genclosure(ep,ep->name,n,0);
2027 28237382 : for(i = 1; i <= n; i++) gmael(C,7,i) = gel(data,i);
2028 7985116 : return C;
2029 : }
2030 :
2031 : GEN
2032 1820 : strtoclosure(const char *s, long n, ...)
2033 : {
2034 1820 : pari_sp av = avma;
2035 1820 : entree *ep = is_entry(s);
2036 : GEN C;
2037 1820 : if (!ep) pari_err(e_NOTFUNC, strtoGENstr(s));
2038 1820 : ep = do_alias(ep);
2039 1820 : if ((!EpSTATIC(ep) && EpVALENCE(ep)!=EpINSTALL) || !ep->value)
2040 0 : pari_err(e_MISC,"not a built-in/install'ed function: \"%s\"",s);
2041 1820 : C = genclosure(ep,ep->name,n,0);
2042 1820 : if (!C) pari_err(e_MISC,"function prototype unsupported: \"%s\"",s);
2043 : else
2044 : {
2045 : va_list ap;
2046 : long i;
2047 1820 : va_start(ap,n);
2048 6923 : for(i = 1; i <= n; i++) gmael(C,7,i) = va_arg(ap, GEN);
2049 1820 : va_end(ap);
2050 : }
2051 1820 : return gerepilecopy(av, C);
2052 : }
2053 :
2054 : GEN
2055 0 : closuretoinl(GEN C)
2056 : {
2057 0 : long i, n = closure_arity(C);
2058 0 : GEN text = closure_get_text(C);
2059 : struct codepos pos;
2060 : const char *loc;
2061 0 : getcodepos(&pos);
2062 0 : if (typ(text)==t_VEC) text = gel(text, 2);
2063 0 : loc = GSTR(text);
2064 0 : dbgstart = loc;
2065 0 : op_push_loc(OCpushgen, data_push(C), loc);
2066 0 : for (i = n; i >= 1 ; i--)
2067 0 : op_push_loc(OCpushlex, -i, loc);
2068 0 : op_push_loc(OCcalluser, n, loc);
2069 0 : return getfunction(&pos,0,0,text,0);
2070 : }
2071 :
2072 : GEN
2073 119 : strtofunction(const char *s) { return strtoclosure(s, 0); }
2074 :
2075 : GEN
2076 21 : call0(GEN fun, GEN args)
2077 : {
2078 21 : if (!is_vec_t(typ(args))) pari_err_TYPE("call",args);
2079 21 : switch(typ(fun))
2080 : {
2081 7 : case t_STR:
2082 7 : fun = strtofunction(GSTR(fun));
2083 21 : case t_CLOSURE: /* fall through */
2084 21 : return closure_callgenvec(fun, args);
2085 0 : default:
2086 0 : pari_err_TYPE("call", fun);
2087 : return NULL; /* LCOV_EXCL_LINE */
2088 : }
2089 : }
2090 :
2091 : static void
2092 10195 : closurefunc(entree *ep, long n, long mode)
2093 : {
2094 10195 : pari_sp ltop=avma;
2095 : GEN C;
2096 10195 : if (!ep->value) compile_err("unknown function",tree[n].str);
2097 10195 : C = genclosure(ep,tree[n].str,0,1);
2098 10195 : if (!C) compile_err("sorry, closure not implemented",tree[n].str);
2099 10195 : if (C==gen_0)
2100 : {
2101 8509 : compilefunc(ep,n,mode,0);
2102 8509 : return;
2103 : }
2104 1686 : op_push(OCpushgen, data_push(C), n);
2105 1686 : compilecast(n,Gclosure,mode);
2106 1686 : set_avma(ltop);
2107 : }
2108 :
2109 : static void
2110 14568 : compileseq(long n, int mode, long flag)
2111 : {
2112 14568 : pari_sp av = avma;
2113 14568 : GEN L = listtogen(n, Fseq);
2114 14568 : long i, l = lg(L)-1;
2115 46537 : for(i = 1; i < l; i++)
2116 31969 : compilenode(L[i],Gvoid,0);
2117 14568 : compilenode(L[l],mode,flag&(FLreturn|FLsurvive));
2118 14568 : set_avma(av);
2119 14568 : }
2120 :
2121 : static void
2122 18596498 : compilenode(long n, int mode, long flag)
2123 : {
2124 : long x,y;
2125 : #ifdef STACK_CHECK
2126 18596498 : if (PARI_stack_limit && (void*) &x <= PARI_stack_limit)
2127 0 : pari_err(e_MISC, "expression nested too deeply");
2128 : #endif
2129 18596498 : if (n<0) pari_err_BUG("compilenode");
2130 18596498 : x=tree[n].x;
2131 18596498 : y=tree[n].y;
2132 :
2133 18596498 : switch(tree[n].f)
2134 : {
2135 14568 : case Fseq:
2136 14568 : compileseq(n, mode, flag);
2137 18596435 : return;
2138 13120 : case Fmatcoeff:
2139 13120 : compilematcoeff(n,mode);
2140 13113 : if (mode==Ggen && !(flag&FLnocopy))
2141 4171 : op_push(OCcopy,0,n);
2142 13113 : return;
2143 43604 : case Fassign:
2144 43604 : x = detag(x);
2145 43604 : if (tree[x].f==Fvec && tree[x].x>=0)
2146 781 : {
2147 781 : GEN vars = listtogen(tree[x].x,Fmatrixelts);
2148 781 : long i, l = lg(vars)-1, d = mode==Gvoid? l-1: l;
2149 781 : compilenode(y,Ggen,mode==Gvoid?0:flag&FLsurvive);
2150 2434 : for (i=1; i<=l; i++)
2151 1653 : if (tree[vars[i]].f==Fnoarg) d--;
2152 781 : if (d) op_push(OCdup, d, x);
2153 2434 : for(i=1; i<=l; i++)
2154 1653 : if (tree[vars[i]].f!=Fnoarg)
2155 : {
2156 1639 : long a = detag(vars[i]);
2157 1639 : entree *ep=getlvalue(a);
2158 1639 : long vn=getmvar(ep);
2159 1639 : op_push(OCpushlong,i,a);
2160 1639 : op_push(OCcompo1,Ggen,a);
2161 1639 : if (tree[a].f==Fentry)
2162 1632 : compilestore(vn,ep,n);
2163 : else
2164 : {
2165 7 : compilenewptr(vn,ep,n);
2166 7 : compilelvalue(a);
2167 7 : op_push(OCstoreptr,0,a);
2168 : }
2169 : }
2170 781 : if (mode!=Gvoid)
2171 445 : compilecast(n,Ggen,mode);
2172 : }
2173 : else
2174 : {
2175 42823 : entree *ep=getlvalue(x);
2176 42823 : long vn=getmvar(ep);
2177 42823 : if (tree[x].f!=Fentry)
2178 : {
2179 623 : compilenewptr(vn,ep,n);
2180 623 : compilelvalue(x);
2181 : }
2182 42823 : compilenode(y,Ggen,mode==Gvoid?FLnocopy:flag&FLsurvive);
2183 42823 : if (mode!=Gvoid)
2184 28159 : op_push(OCdup,1,n);
2185 42823 : if (tree[x].f==Fentry)
2186 42200 : compilestore(vn,ep,n);
2187 : else
2188 623 : op_push(OCstoreptr,0,x);
2189 42823 : if (mode!=Gvoid)
2190 28159 : compilecast(n,Ggen,mode);
2191 : }
2192 43604 : return;
2193 1729197 : case Fconst:
2194 : {
2195 1729197 : pari_sp ltop=avma;
2196 1729197 : if (tree[n].x!=CSTquote)
2197 : {
2198 1725680 : if (mode==Gvoid) return;
2199 1725680 : if (mode==Gvar) compile_varerr(tree[n].str);
2200 : }
2201 1729197 : if (mode==Gsmall) L_compile_err(tree[n].str);
2202 1729197 : if (mode==Gusmall && tree[n].x != CSTint) U_compile_err(tree[n].str);
2203 1729190 : switch(tree[n].x)
2204 : {
2205 5457 : case CSTreal:
2206 5457 : op_push(OCpushreal, data_push(strntoGENstr(tree[n].str,tree[n].len)),n);
2207 5457 : break;
2208 840276 : case CSTint:
2209 840276 : op_push(OCpushgen, data_push(strtoi((char*)tree[n].str)),n);
2210 840276 : compilecast(n,Ggen, mode);
2211 840276 : break;
2212 879940 : case CSTstr:
2213 879940 : op_push(OCpushgen, data_push(strntoGENexp(tree[n].str,tree[n].len)),n);
2214 879940 : break;
2215 3517 : case CSTquote:
2216 : { /* skip ' */
2217 3517 : entree *ep = fetch_entry_raw(tree[n].str+1,tree[n].len-1);
2218 3517 : if (EpSTATIC(ep)) compile_varerr(tree[n].str+1);
2219 3517 : op_push(OCpushvar, (long)ep,n);
2220 3517 : compilecast(n,Ggen, mode);
2221 3517 : break;
2222 : }
2223 0 : default:
2224 0 : pari_err_BUG("compilenode, unsupported constant");
2225 : }
2226 1729190 : set_avma(ltop);
2227 1729190 : return;
2228 : }
2229 7364046 : case Fsmall:
2230 7364046 : compilesmall(n, x, mode);
2231 7364039 : return;
2232 4457641 : case Fvec:
2233 4457641 : compilevec(n, mode, OCvec);
2234 4457641 : return;
2235 9590 : case Fmat:
2236 9590 : compilemat(n, mode);
2237 9590 : return;
2238 0 : case Frefarg:
2239 0 : compile_err("unexpected character '&':",tree[n].str);
2240 0 : return;
2241 0 : case Findarg:
2242 0 : compile_err("unexpected character '~':",tree[n].str);
2243 0 : return;
2244 271860 : case Fentry:
2245 : {
2246 271860 : entree *ep=getentry(n);
2247 271860 : long vn=getmvar(ep);
2248 271860 : if (vn)
2249 : {
2250 70710 : access_push(vn);
2251 70710 : op_push(OCpushlex,(long)vn,n);
2252 70710 : addcopy(n,mode,flag,FLnocopy|FLnocopylex);
2253 70710 : compilecast(n,Ggen,mode);
2254 : }
2255 201150 : else if (ep->valence==EpVAR || ep->valence==EpNEW)
2256 : {
2257 190955 : if (DEBUGLEVEL && mode==Gvoid)
2258 0 : pari_warn(warner,"statement with no effect: `%s'",ep->name);
2259 190955 : op_push(OCpushdyn,(long)ep,n);
2260 190955 : addcopy(n,mode,flag,FLnocopy);
2261 190955 : compilecast(n,Ggen,mode);
2262 : }
2263 : else
2264 10195 : closurefunc(ep,n,mode);
2265 271860 : return;
2266 : }
2267 4683178 : case Ffunction:
2268 : {
2269 4683178 : entree *ep=getfunc(n);
2270 4683178 : if (getmvar(ep) || EpVALENCE(ep)==EpVAR || EpVALENCE(ep)==EpNEW)
2271 : {
2272 22430 : if (tree[n].x<OPnboperator) /* should not happen */
2273 0 : compile_err("operator unknown",tree[n].str);
2274 22430 : compilecall(n,mode,ep);
2275 : }
2276 : else
2277 4660748 : compilefunc(ep,n,mode,flag);
2278 4683136 : return;
2279 : }
2280 322 : case Fcall:
2281 322 : compilecall(n,mode,NULL);
2282 322 : return;
2283 9085 : case Flambda:
2284 : {
2285 9085 : pari_sp ltop=avma;
2286 : struct codepos pos;
2287 9085 : GEN arg=listtogen(x,Flistarg);
2288 9085 : long nb, lgarg, nbmvar, dovararg=0, gap;
2289 9085 : long strict = GP_DATA->strictargs;
2290 9085 : GEN vep = cgetg_copy(arg, &lgarg);
2291 9085 : GEN text=cgetg(3,t_VEC);
2292 9085 : gel(text,1)=strntoGENstr(tree[x].str,tree[x].len);
2293 9085 : if (lgarg==2 && tree[x].str[0]!='~' && tree[x].f==Findarg)
2294 : /* This occurs for member functions */
2295 14 : gel(text,1)=shallowconcat(strntoGENstr("~",1),gel(text,1));
2296 9085 : gel(text,2)=strntoGENstr(tree[y].str,tree[y].len);
2297 9085 : getcodepos(&pos);
2298 9085 : dbgstart=tree[x].str+tree[x].len;
2299 9085 : gap = tree[y].str-dbgstart;
2300 9085 : nbmvar = nblex;
2301 9085 : ctxmvar(nbmvar);
2302 9085 : nb = lgarg-1;
2303 9085 : if (nb)
2304 : {
2305 : long i;
2306 13030 : for(i=1;i<=nb;i++)
2307 : {
2308 8001 : long a = arg[i], f = tree[a].f;
2309 8001 : if (i==nb && f==Fvararg)
2310 : {
2311 21 : dovararg=1;
2312 21 : vep[i]=(long)getvar(tree[a].x);
2313 : }
2314 : else
2315 7980 : vep[i]=(long)getvar(f==Fassign||f==Findarg?tree[a].x:a);
2316 8001 : var_push(NULL,Lmy);
2317 : }
2318 5029 : checkdups(arg,vep);
2319 5029 : op_push(OCgetargs,nb,x);
2320 5029 : access_push(lg(vep)-1);
2321 5029 : frame_push(vep);
2322 13030 : for (i=1;i<=nb;i++)
2323 : {
2324 8001 : long a = arg[i], f = tree[a].f;
2325 8001 : long y = tree[a].y;
2326 8001 : if (f==Fassign && (strict || !is_node_zero(y)))
2327 : {
2328 357 : if (tree[y].f==Fsmall)
2329 273 : compilenode(y, Ggen, 0);
2330 : else
2331 : {
2332 : struct codepos lpos;
2333 84 : long nbmvar = nblex;
2334 84 : getcodepos(&lpos);
2335 84 : compilenode(y, Ggen, 0);
2336 84 : op_push(OCpushgen, data_push(getclosure(&lpos,nbmvar)),a);
2337 : }
2338 357 : op_push(OCdefaultarg,-nb+i-1,a);
2339 7644 : } else if (f==Findarg)
2340 84 : op_push(OCsetref, -nb+i-1, a);
2341 8001 : localvars[s_lvar.n-nb+i-1].ep=(entree*)vep[i];
2342 : }
2343 : }
2344 9085 : if (strict)
2345 21 : op_push(OCcheckuserargs,nb,x);
2346 9085 : dbgstart=tree[y].str;
2347 9085 : if (y>=0 && tree[y].f!=Fnoarg)
2348 9085 : compilenode(y,Ggen,FLsurvive|FLreturn);
2349 : else
2350 0 : compilecast(n,Gvoid,Ggen);
2351 9085 : if (dovararg) nb|=VARARGBITS;
2352 9085 : op_push(OCpushgen, data_push(getfunction(&pos,nb,nbmvar,text,gap)),n);
2353 9085 : if (nbmvar) op_push(OCsaveframe,!!(flag&FLsurvive),n);
2354 9085 : compilecast(n, Gclosure, mode);
2355 9085 : set_avma(ltop);
2356 9085 : return;
2357 : }
2358 0 : case Ftag:
2359 0 : compilenode(x, mode,flag);
2360 0 : return;
2361 7 : case Fnoarg:
2362 7 : compilecast(n,Gvoid,mode);
2363 7 : return;
2364 280 : case Fnorange:
2365 280 : op_push(OCpushlong,LONG_MAX,n);
2366 280 : compilecast(n,Gsmall,mode);
2367 280 : return;
2368 0 : default:
2369 0 : pari_err_BUG("compilenode");
2370 : }
2371 : }
2372 :
2373 : GEN
2374 931675 : gp_closure(long n)
2375 : {
2376 : struct codepos pos;
2377 931675 : getcodepos(&pos);
2378 931675 : dbgstart=tree[n].str;
2379 931675 : compilenode(n,Ggen,FLsurvive|FLreturn);
2380 931633 : return getfunction(&pos,0,0,strntoGENstr(tree[n].str,tree[n].len),0);
2381 : }
2382 :
2383 : GEN
2384 105 : closure_derivn(GEN G, long n)
2385 : {
2386 105 : pari_sp ltop = avma;
2387 : struct codepos pos;
2388 105 : long arity = closure_arity(G);
2389 : const char *code;
2390 : GEN t, text;
2391 :
2392 105 : if (arity == 0 || closure_is_variadic(G)) pari_err_TYPE("derivfun",G);
2393 105 : t = closure_get_text(G);
2394 105 : code = GSTR((typ(t) == t_STR)? t: GENtoGENstr(G));
2395 105 : if (n > 1)
2396 : {
2397 49 : text = cgetg(1+nchar2nlong(9+strlen(code)+n),t_STR);
2398 49 : sprintf(GSTR(text), "derivn(%s,%ld)", code, n);
2399 : }
2400 : else
2401 : {
2402 56 : text = cgetg(1+nchar2nlong(4+strlen(code)),t_STR);
2403 56 : sprintf(GSTR(text), (typ(t) == t_STR)? "%s'": "(%s)'",code);
2404 : }
2405 105 : getcodepos(&pos);
2406 105 : dbgstart = code;
2407 105 : op_push_loc(OCpackargs, arity, code);
2408 105 : op_push_loc(OCpushgen, data_push(G), code);
2409 105 : op_push_loc(OCpushlong, n, code);
2410 105 : op_push_loc(OCprecreal, 0, code);
2411 105 : op_push_loc(OCcallgen, (long)is_entry("_derivfun"), code);
2412 105 : return gerepilecopy(ltop, getfunction(&pos, arity, 0, text, 0));
2413 : }
2414 :
2415 : GEN
2416 0 : closure_deriv(GEN G)
2417 0 : { return closure_derivn(G, 1); }
2418 :
2419 : static long
2420 4557801 : vec_optimize(GEN arg)
2421 : {
2422 4557801 : long fl = COsafelex|COsafedyn;
2423 : long i;
2424 20731802 : for (i=1; i<lg(arg); i++)
2425 : {
2426 16174008 : optimizenode(arg[i]);
2427 16174001 : fl &= tree[arg[i]].flags;
2428 : }
2429 4557794 : return fl;
2430 : }
2431 :
2432 : static void
2433 4463168 : optimizevec(long n)
2434 : {
2435 4463168 : pari_sp ltop=avma;
2436 4463168 : long x = tree[n].x;
2437 4463168 : GEN arg = listtogen(x, Fmatrixelts);
2438 4463168 : tree[n].flags = vec_optimize(arg);
2439 4463168 : set_avma(ltop);
2440 4463168 : }
2441 :
2442 : static void
2443 9590 : optimizemat(long n)
2444 : {
2445 9590 : pari_sp ltop = avma;
2446 9590 : long x = tree[n].x;
2447 : long i;
2448 9590 : GEN line = listtogen(x,Fmatrixlines);
2449 9590 : long fl = COsafelex|COsafedyn;
2450 47684 : for(i=1;i<lg(line);i++)
2451 : {
2452 38094 : GEN col=listtogen(line[i],Fmatrixelts);
2453 38094 : fl &= vec_optimize(col);
2454 : }
2455 9590 : set_avma(ltop); tree[n].flags=fl;
2456 9590 : }
2457 :
2458 : static void
2459 14100 : optimizematcoeff(long n)
2460 : {
2461 14100 : long x=tree[n].x;
2462 14100 : long y=tree[n].y;
2463 14100 : long yx=tree[y].x;
2464 14100 : long yy=tree[y].y;
2465 : long fl;
2466 14100 : optimizenode(x);
2467 14100 : optimizenode(yx);
2468 14100 : fl=tree[x].flags&tree[yx].flags;
2469 14100 : if (yy>=0)
2470 : {
2471 1750 : optimizenode(yy);
2472 1750 : fl&=tree[yy].flags;
2473 : }
2474 14100 : tree[n].flags=fl;
2475 14100 : }
2476 :
2477 : static void
2478 4664703 : optimizefunc(entree *ep, long n)
2479 : {
2480 4664703 : pari_sp av=avma;
2481 : long j;
2482 4664703 : long x=tree[n].x;
2483 4664703 : long y=tree[n].y;
2484 : Gtype t;
2485 : PPproto mod;
2486 4664703 : long fl=COsafelex|COsafedyn;
2487 : const char *p;
2488 : char c;
2489 4664703 : GEN arg = listtogen(y,Flistarg);
2490 4664703 : long nb=lg(arg)-1, ret_flag;
2491 4664703 : if (is_func_named(ep,"if") && nb>=4)
2492 119 : ep=is_entry("_multi_if");
2493 4664703 : p = ep->code;
2494 4664703 : if (!p)
2495 3382 : fl=0;
2496 : else
2497 4661321 : (void) get_ret_type(&p, 2, &t, &ret_flag);
2498 4664703 : if (p && *p)
2499 : {
2500 4654476 : j=1;
2501 9974080 : while((mod=parseproto(&p,&c,tree[n].str))!=PPend)
2502 : {
2503 5319632 : if (j<=nb && tree[arg[j]].f!=Fnoarg
2504 5146377 : && (mod==PPdefault || mod==PPdefaultmulti))
2505 62284 : mod=PPstd;
2506 5319632 : switch(mod)
2507 : {
2508 5131973 : case PPstd:
2509 5131973 : if (j>nb) compile_err("too few arguments", tree[n].str+tree[n].len-1);
2510 5131945 : if (tree[arg[j]].f==Fnoarg && c!='I' && c!='E')
2511 0 : compile_err("missing mandatory argument", tree[arg[j]].str);
2512 5131945 : switch(c)
2513 : {
2514 5093626 : case 'G':
2515 : case 'n':
2516 : case 'M':
2517 : case 'L':
2518 : case 'U':
2519 : case 'P':
2520 5093626 : optimizenode(arg[j]);
2521 5093626 : fl&=tree[arg[j++]].flags;
2522 5093626 : break;
2523 19702 : case 'I':
2524 : case 'E':
2525 : case 'J':
2526 19702 : optimizenode(arg[j]);
2527 19702 : fl&=tree[arg[j]].flags;
2528 19702 : tree[arg[j++]].flags=COsafelex|COsafedyn;
2529 19702 : break;
2530 2266 : case '&': case '*':
2531 : {
2532 2266 : long a=arg[j];
2533 2266 : if (c=='&')
2534 : {
2535 1498 : if (tree[a].f!=Frefarg)
2536 0 : compile_err("expected character: '&'", tree[a].str);
2537 1498 : a=tree[a].x;
2538 : }
2539 2266 : optimizenode(a);
2540 2266 : tree[arg[j++]].flags=COsafelex|COsafedyn;
2541 2266 : fl=0;
2542 2266 : break;
2543 : }
2544 462 : case 'W':
2545 : {
2546 462 : long a = tree[arg[j]].f==Findarg ? tree[arg[j]].x: arg[j];
2547 462 : optimizenode(a);
2548 462 : fl=0; j++;
2549 462 : break;
2550 : }
2551 6416 : case 'V':
2552 : case 'r':
2553 6416 : tree[arg[j++]].flags=COsafelex|COsafedyn;
2554 6416 : break;
2555 6742 : case '=':
2556 : {
2557 6742 : long a=arg[j++], y=tree[a].y;
2558 6742 : if (tree[a].f!=Fassign)
2559 0 : compile_err("expected character: '=' instead of",
2560 0 : tree[a].str+tree[a].len);
2561 6742 : optimizenode(y);
2562 6742 : fl&=tree[y].flags;
2563 : }
2564 6742 : break;
2565 2731 : case 's':
2566 2731 : fl &= vec_optimize(cattovec(arg[j++], OPcat));
2567 2731 : break;
2568 0 : default:
2569 0 : pari_err(e_MISC,"Unknown prototype code `%c' for `%.*s'",c,
2570 0 : tree[x].len, tree[x].str);
2571 : }
2572 5131945 : break;
2573 101379 : case PPauto:
2574 101379 : break;
2575 71402 : case PPdefault:
2576 : case PPdefaultmulti:
2577 71402 : if (j<=nb) optimizenode(arg[j++]);
2578 71402 : break;
2579 14878 : case PPstar:
2580 14878 : switch(c)
2581 : {
2582 119 : case 'E':
2583 : {
2584 119 : long n=nb+1-j;
2585 : long k;
2586 602 : for(k=1;k<=n;k++)
2587 : {
2588 483 : optimizenode(arg[j+k-1]);
2589 483 : fl &= tree[arg[j+k-1]].flags;
2590 : }
2591 119 : j=nb+1;
2592 119 : break;
2593 : }
2594 14759 : case 's':
2595 : {
2596 14759 : long n=nb+1-j;
2597 : long k;
2598 35581 : for(k=1;k<=n;k++)
2599 20822 : fl &= vec_optimize(cattovec(arg[j+k-1],OPcat));
2600 14759 : j=nb+1;
2601 14759 : break;
2602 : }
2603 0 : default:
2604 0 : pari_err(e_MISC,"Unknown prototype code `%c*' for `%.*s'",c,
2605 0 : tree[x].len, tree[x].str);
2606 : }
2607 14878 : break;
2608 0 : default:
2609 0 : pari_err_BUG("optimizefun [unknown PPproto]");
2610 : }
2611 : }
2612 4654448 : if (j<=nb)
2613 0 : compile_err("too many arguments",tree[arg[j]].str);
2614 : }
2615 10227 : else (void)vec_optimize(arg);
2616 4664675 : set_avma(av); tree[n].flags=fl;
2617 4664675 : }
2618 :
2619 : static void
2620 22759 : optimizecall(long n)
2621 : {
2622 22759 : pari_sp av=avma;
2623 22759 : long x=tree[n].x;
2624 22759 : long y=tree[n].y;
2625 22759 : GEN arg=listtogen(y,Flistarg);
2626 22759 : optimizenode(x);
2627 22759 : tree[n].flags = COsafelex&tree[x].flags&vec_optimize(arg);
2628 22752 : set_avma(av);
2629 22752 : }
2630 :
2631 : static void
2632 14568 : optimizeseq(long n)
2633 : {
2634 14568 : pari_sp av = avma;
2635 14568 : GEN L = listtogen(n, Fseq);
2636 14568 : long i, l = lg(L)-1, flags=-1L;
2637 61105 : for(i = 1; i <= l; i++)
2638 : {
2639 46537 : optimizenode(L[i]);
2640 46537 : flags &= tree[L[i]].flags;
2641 : }
2642 14568 : set_avma(av);
2643 14568 : tree[n].flags = flags;
2644 14568 : }
2645 :
2646 : void
2647 22468346 : optimizenode(long n)
2648 : {
2649 : long x,y;
2650 : #ifdef STACK_CHECK
2651 22468346 : if (PARI_stack_limit && (void*) &x <= PARI_stack_limit)
2652 0 : pari_err(e_MISC, "expression nested too deeply");
2653 : #endif
2654 22468346 : if (n<0)
2655 0 : pari_err_BUG("optimizenode");
2656 22468346 : x=tree[n].x;
2657 22468346 : y=tree[n].y;
2658 :
2659 22468346 : switch(tree[n].f)
2660 : {
2661 14568 : case Fseq:
2662 14568 : optimizeseq(n);
2663 22390840 : return;
2664 15850 : case Frange:
2665 15850 : optimizenode(x);
2666 15850 : optimizenode(y);
2667 15850 : tree[n].flags=tree[x].flags&tree[y].flags;
2668 15850 : break;
2669 14100 : case Fmatcoeff:
2670 14100 : optimizematcoeff(n);
2671 14100 : break;
2672 47514 : case Fassign:
2673 47514 : optimizenode(x);
2674 47514 : optimizenode(y);
2675 47514 : tree[n].flags=0;
2676 47514 : break;
2677 13206876 : case Fnoarg:
2678 : case Fnorange:
2679 : case Fsmall:
2680 : case Fconst:
2681 : case Fentry:
2682 13206876 : tree[n].flags=COsafelex|COsafedyn;
2683 13206876 : return;
2684 4463168 : case Fvec:
2685 4463168 : optimizevec(n);
2686 4463168 : return;
2687 9590 : case Fmat:
2688 9590 : optimizemat(n);
2689 9590 : return;
2690 7 : case Frefarg:
2691 7 : compile_err("unexpected character '&'",tree[n].str);
2692 0 : return;
2693 126 : case Findarg:
2694 126 : return;
2695 0 : case Fvararg:
2696 0 : compile_err("unexpected characters '..'",tree[n].str);
2697 0 : return;
2698 4687140 : case Ffunction:
2699 : {
2700 4687140 : entree *ep=getfunc(n);
2701 4687140 : if (EpVALENCE(ep)==EpVAR || EpVALENCE(ep)==EpNEW)
2702 22437 : optimizecall(n);
2703 : else
2704 4664703 : optimizefunc(ep,n);
2705 4687105 : return;
2706 : }
2707 322 : case Fcall:
2708 322 : optimizecall(n);
2709 322 : return;
2710 9085 : case Flambda:
2711 9085 : optimizenode(y);
2712 9085 : tree[n].flags=COsafelex|COsafedyn;
2713 9085 : return;
2714 0 : case Ftag:
2715 0 : optimizenode(x);
2716 0 : tree[n].flags=tree[x].flags;
2717 0 : return;
2718 0 : default:
2719 0 : pari_err_BUG("optimizenode");
2720 : }
2721 : }
|
