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 3263670 : translate(const char **src, char *s)
35 : {
36 3263670 : const char *t = *src;
37 25714852 : while (*t)
38 : {
39 25715343 : while (*t == '\\')
40 : {
41 491 : switch(*++t)
42 : {
43 0 : case 'e': *s='\033'; break; /* escape */
44 342 : case 'n': *s='\n'; break;
45 11 : case 't': *s='\t'; break;
46 138 : default: *s=*t; if (!*t) { *src=s; return NULL; }
47 : }
48 491 : t++; s++;
49 : }
50 25714852 : if (*t == '"')
51 : {
52 3263670 : if (t[1] != '"') break;
53 0 : t += 2; continue;
54 : }
55 22451182 : *s++ = *t++;
56 : }
57 3263670 : *s=0; *src=t; return s;
58 : }
59 :
60 : static void
61 0 : matchQ(const char *s, char *entry)
62 : {
63 0 : if (*s != '"')
64 0 : pari_err(e_SYNTAX,"expected character: '\"' instead of",s,entry);
65 0 : }
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 0 : pari_translate_string(const char *src, char *s, char *entry)
71 : {
72 0 : matchQ(src, entry); src++; s = translate(&src, s);
73 0 : if (!s) pari_err(e_SYNTAX,"run-away string",src,entry);
74 0 : matchQ(src, entry); return (char*)src+1;
75 : }
76 :
77 : static GEN
78 3263670 : strntoGENexp(const char *str, long len)
79 : {
80 3263670 : long n = nchar2nlong(len-1);
81 3263670 : GEN z = cgetg(1+n, t_STR);
82 3263670 : const char *t = str+1;
83 3263670 : z[n] = 0;
84 3263670 : if (!translate(&t, GSTR(z))) compile_err("run-away string",str);
85 3263670 : 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 1488 : pari_init_compiler(void)
122 : {
123 1488 : pari_stack_init(&s_opcode,sizeof(*opcode),(void **)&opcode);
124 1488 : pari_stack_init(&s_operand,sizeof(*operand),(void **)&operand);
125 1488 : pari_stack_init(&s_accesslex,sizeof(*operand),(void **)&accesslex);
126 1488 : pari_stack_init(&s_data,sizeof(*data),(void **)&data);
127 1488 : pari_stack_init(&s_lvar,sizeof(*localvars),(void **)&localvars);
128 1488 : pari_stack_init(&s_dbginfo,sizeof(*dbginfo),(void **)&dbginfo);
129 1488 : pari_stack_init(&s_frame,sizeof(*frames),(void **)&frames);
130 1488 : offset=-1; nblex=0;
131 1488 : }
132 : void
133 1488 : pari_close_compiler(void)
134 : {
135 1488 : pari_stack_delete(&s_opcode);
136 1488 : pari_stack_delete(&s_operand);
137 1488 : pari_stack_delete(&s_accesslex);
138 1488 : pari_stack_delete(&s_data);
139 1488 : pari_stack_delete(&s_lvar);
140 1488 : pari_stack_delete(&s_dbginfo);
141 1488 : pari_stack_delete(&s_frame);
142 1488 : }
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 8117707 : getcodepos(struct codepos *pos)
153 : {
154 8117707 : pos->opcode=s_opcode.n;
155 8117707 : pos->accesslex=s_accesslex.n;
156 8117707 : pos->data=s_data.n;
157 8117707 : pos->offset=offset;
158 8117707 : pos->nblex=nblex;
159 8117707 : pos->localvars=s_lvar.n;
160 8117707 : pos->dbgstart=dbgstart;
161 8117707 : pos->frames=s_frame.n;
162 8117707 : offset=s_data.n-1;
163 8117707 : }
164 :
165 : void
166 366 : compilestate_reset(void)
167 : {
168 366 : s_opcode.n=0;
169 366 : s_operand.n=0;
170 366 : s_accesslex.n=0;
171 366 : s_dbginfo.n=0;
172 366 : s_data.n=0;
173 366 : s_lvar.n=0;
174 366 : s_frame.n=0;
175 366 : offset=-1;
176 366 : nblex=0;
177 366 : dbgstart=NULL;
178 366 : }
179 :
180 : void
181 1219499 : compilestate_save(struct pari_compilestate *comp)
182 : {
183 1219499 : comp->opcode=s_opcode.n;
184 1219499 : comp->operand=s_operand.n;
185 1219499 : comp->accesslex=s_accesslex.n;
186 1219499 : comp->data=s_data.n;
187 1219499 : comp->offset=offset;
188 1219499 : comp->nblex=nblex;
189 1219499 : comp->localvars=s_lvar.n;
190 1219499 : comp->dbgstart=dbgstart;
191 1219499 : comp->dbginfo=s_dbginfo.n;
192 1219499 : comp->frames=s_frame.n;
193 1219499 : }
194 :
195 : void
196 47482 : compilestate_restore(struct pari_compilestate *comp)
197 : {
198 47482 : s_opcode.n=comp->opcode;
199 47482 : s_operand.n=comp->operand;
200 47482 : s_accesslex.n=comp->accesslex;
201 47482 : s_data.n=comp->data;
202 47482 : offset=comp->offset;
203 47482 : nblex=comp->nblex;
204 47482 : s_lvar.n=comp->localvars;
205 47482 : dbgstart=comp->dbgstart;
206 47482 : s_dbginfo.n=comp->dbginfo;
207 47482 : s_frame.n=comp->frames;
208 47482 : }
209 :
210 : static GEN
211 11401181 : gcopyunclone(GEN x) { GEN y = gcopy(x); gunclone(x); return y; }
212 :
213 : static void
214 94401 : access_push(long x)
215 : {
216 94401 : long a = pari_stack_new(&s_accesslex);
217 94401 : accesslex[a] = x;
218 94401 : }
219 :
220 : static GEN
221 7306881 : genctx(long nbmvar, long paccesslex)
222 : {
223 7306881 : GEN acc = const_vec(nbmvar,gen_1);
224 7306881 : long i, lvl = 1 + nbmvar;
225 7341022 : for (i = paccesslex; i<s_accesslex.n; i++)
226 : {
227 34141 : long a = accesslex[i];
228 34141 : if (a > 0) { lvl+=a; continue; }
229 30123 : a += lvl;
230 30123 : if (a <= 0) pari_err_BUG("genctx");
231 30123 : if (a <= nbmvar)
232 23691 : gel(acc, a) = gen_0;
233 : }
234 7306881 : s_accesslex.n = paccesslex;
235 26144699 : for (i = 1; i<=nbmvar; i++)
236 18837818 : if (signe(gel(acc,i))==0)
237 17106 : access_push(i-nbmvar-1);
238 7306881 : return acc;
239 : }
240 :
241 : static GEN
242 8117672 : getfunction(const struct codepos *pos, long arity, long nbmvar, GEN text,
243 : long gap)
244 : {
245 8117672 : long lop = s_opcode.n+1 - pos->opcode;
246 8117672 : long ldat = s_data.n+1 - pos->data;
247 8117672 : long lfram = s_frame.n+1 - pos->frames;
248 8117672 : 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 8117672 : cl[1] = arity;
254 8117672 : gel(cl,2) = cgetg(nchar2nlong(lop)+1, t_STR);
255 8117672 : gel(cl,3) = op = cgetg(lop, t_VECSMALL);
256 8117672 : gel(cl,4) = dat = cgetg(ldat, t_VEC);
257 8117672 : dbg = cgetg(lop, t_VECSMALL);
258 8117672 : frpc = cgetg(lfram, t_VECSMALL);
259 8117672 : fram = cgetg(lfram, t_VEC);
260 8117672 : gel(cl,5) = mkvec3(dbg, frpc, fram);
261 8117672 : if (text) gel(cl,6) = text;
262 8117672 : s = GSTR(gel(cl,2)) - 1;
263 141846640 : for (i = 1; i < lop; i++)
264 : {
265 133728968 : long j = i+pos->opcode-1;
266 133728968 : s[i] = opcode[j];
267 133728968 : op[i] = operand[j];
268 133728968 : dbg[i] = dbginfo[j] - dbgstart;
269 133728968 : if (dbg[i] < 0) dbg[i] += gap;
270 : }
271 8117672 : s[i] = 0;
272 8117672 : s_opcode.n = pos->opcode;
273 8117672 : s_operand.n = pos->opcode;
274 8117672 : s_dbginfo.n = pos->opcode;
275 8117672 : if (lg(cl)==8)
276 7298020 : gel(cl,7) = genctx(nbmvar, pos->accesslex);
277 819652 : else if (nbmvar==0)
278 810791 : s_accesslex.n = pos->accesslex;
279 : else
280 : {
281 8861 : pari_sp av = avma;
282 8861 : (void) genctx(nbmvar, pos->accesslex);
283 8861 : set_avma(av);
284 : }
285 12204438 : for (i = 1; i < ldat; i++)
286 4086766 : if (data[i+pos->data-1]) gel(dat,i) = gcopyunclone(data[i+pos->data-1]);
287 8117672 : s_data.n = pos->data;
288 8140729 : while (s_lvar.n > pos->localvars && !localvars[s_lvar.n-1].inl)
289 : {
290 23057 : if (localvars[s_lvar.n-1].type==Lmy) nblex--;
291 23057 : s_lvar.n--;
292 : }
293 15432087 : for (i = 1; i < lfram; i++)
294 : {
295 7314415 : long j = i+pos->frames-1;
296 7314415 : frpc[i] = frames[j].pc - pos->opcode+1;
297 7314415 : gel(fram, i) = gcopyunclone(frames[j].frame);
298 : }
299 8117672 : s_frame.n = pos->frames;
300 8117672 : offset = pos->offset;
301 8117672 : dbgstart = pos->dbgstart;
302 8117672 : return cl;
303 : }
304 :
305 : static GEN
306 16289 : getclosure(struct codepos *pos, long nbmvar)
307 : {
308 16289 : return getfunction(pos, 0, nbmvar, NULL, 0);
309 : }
310 :
311 : static void
312 133726596 : op_push_loc(op_code o, long x, const char *loc)
313 : {
314 133726596 : long n=pari_stack_new(&s_opcode);
315 133726596 : long m=pari_stack_new(&s_operand);
316 133726596 : long d=pari_stack_new(&s_dbginfo);
317 133726596 : opcode[n]=o;
318 133726596 : operand[m]=x;
319 133726596 : dbginfo[d]=loc;
320 133726596 : }
321 :
322 : static void
323 98804068 : op_push(op_code o, long x, long n)
324 : {
325 98804068 : op_push_loc(o,x,tree[n].str);
326 98804068 : }
327 :
328 : static void
329 2420 : op_insert_loc(long k, op_code o, long x, const char *loc)
330 : {
331 : long i;
332 2420 : long n=pari_stack_new(&s_opcode);
333 2420 : (void) pari_stack_new(&s_operand);
334 2420 : (void) pari_stack_new(&s_dbginfo);
335 507890 : for (i=n-1; i>=k; i--)
336 : {
337 505470 : opcode[i+1] = opcode[i];
338 505470 : operand[i+1]= operand[i];
339 505470 : dbginfo[i+1]= dbginfo[i];
340 : }
341 2420 : opcode[k] = o;
342 2420 : operand[k] = x;
343 2420 : dbginfo[k] = loc;
344 2420 : }
345 :
346 : static long
347 4086766 : data_push(GEN x)
348 : {
349 4086766 : long n=pari_stack_new(&s_data);
350 4086766 : data[n] = x?gclone(x):x;
351 4086766 : return n-offset;
352 : }
353 :
354 : static void
355 54155 : var_push(entree *ep, Ltype type)
356 : {
357 54155 : long n=pari_stack_new(&s_lvar);
358 54155 : localvars[n].ep = ep;
359 54155 : localvars[n].inl = 0;
360 54155 : localvars[n].type = type;
361 54155 : if (type == Lmy) nblex++;
362 54155 : }
363 :
364 : static void
365 7314415 : frame_push(GEN x)
366 : {
367 7314415 : long n=pari_stack_new(&s_frame);
368 7314415 : frames[n].pc = s_opcode.n-1;
369 7314415 : frames[n].frame = gclone(x);
370 7314415 : }
371 :
372 : static GEN
373 39 : pack_localvars(void)
374 : {
375 39 : GEN pack=cgetg(3,t_VEC);
376 39 : long i, l=s_lvar.n;
377 39 : GEN t=cgetg(1+l,t_VECSMALL);
378 39 : GEN e=cgetg(1+l,t_VECSMALL);
379 39 : gel(pack,1)=t;
380 39 : gel(pack,2)=e;
381 87 : for(i=1;i<=l;i++)
382 : {
383 48 : t[i]=localvars[i-1].type;
384 48 : e[i]=(long)localvars[i-1].ep;
385 : }
386 87 : for(i=1;i<=nblex;i++)
387 48 : access_push(-i);
388 39 : return pack;
389 : }
390 :
391 : void
392 222 : push_frame(GEN C, long lpc, long dummy)
393 : {
394 222 : const char *code=closure_codestr(C);
395 222 : GEN oper=closure_get_oper(C);
396 222 : GEN dbg=closure_get_dbg(C);
397 222 : GEN frpc=gel(dbg,2);
398 222 : GEN fram=gel(dbg,3);
399 222 : long pc, j=1, lfr = lg(frpc);
400 222 : if (lpc==-1)
401 : {
402 : long k;
403 48 : GEN e = gel(fram, 1);
404 96 : for(k=1; k<lg(e); k++)
405 48 : var_push(dummy?NULL:(entree*)e[k], Lmy);
406 48 : return;
407 : }
408 222 : if (lg(C)<8) while (j<lfr && frpc[j]==0) j++;
409 1470 : for(pc=0; pc<lpc; pc++) /* do not assume lpc was completed */
410 : {
411 1296 : if (pc>0 && (code[pc]==OClocalvar || code[pc]==OClocalvar0))
412 0 : var_push((entree*)oper[pc],Llocal);
413 1296 : if (j<lfr && pc==frpc[j])
414 : {
415 : long k;
416 132 : GEN e = gel(fram,j);
417 342 : for(k=1; k<lg(e); k++)
418 210 : var_push(dummy?NULL:(entree*)e[k], Lmy);
419 132 : 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 9382 : localvars_read_str(const char *x, GEN pack)
438 : {
439 9382 : pari_sp av = avma;
440 : GEN code;
441 9382 : long l=0, nbmvar=nblex;
442 9382 : if (pack)
443 : {
444 9382 : GEN t=gel(pack,1);
445 9382 : GEN e=gel(pack,2);
446 : long i;
447 9382 : l=lg(t)-1;
448 40204 : for(i=1;i<=l;i++)
449 30822 : var_push((entree*)e[i],(Ltype)t[i]);
450 : }
451 9382 : code = compile_str(x);
452 9382 : s_lvar.n -= l;
453 9382 : nblex = nbmvar;
454 9382 : return gc_upto(av, closure_evalres(code));
455 : }
456 :
457 : long
458 5 : localvars_find(GEN pack, entree *ep)
459 : {
460 5 : GEN t=gel(pack,1);
461 5 : GEN e=gel(pack,2);
462 : long i;
463 5 : long vn=0;
464 5 : 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 5 : 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 223746 : addcopy(long n, long mode, long flag, long mask)
485 : {
486 223746 : if (mode==Ggen && !(flag&mask))
487 : {
488 22242 : op_push(OCcopy,0,n);
489 22242 : if (!(flag&FLsurvive) && DEBUGLEVEL)
490 0 : pari_warn(warner,"compiler generates copy for `%.*s'",
491 0 : tree[n].len,tree[n].str);
492 : }
493 223746 : }
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 123670640 : parseproto(char const **q, char *c, const char *str)
501 : {
502 123670640 : char const *p=*q;
503 : long i;
504 123670640 : switch(*p)
505 : {
506 32518420 : case 0:
507 : case '\n':
508 32518420 : return PPend;
509 235762 : case 'D':
510 235762 : switch(p[1])
511 : {
512 160057 : 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 160057 : *c=p[1]; *q=p+2; return PPdefault;
524 75705 : default:
525 457958 : for(i=0;*p && i<2;p++) i+=*p==',';
526 : /* assert(i>=2) because check_proto validated the protototype */
527 75705 : *c=p[-2]; *q=p; return PPdefaultmulti;
528 : }
529 : break;
530 114923 : case 'C':
531 : case 'p':
532 : case 'b':
533 : case 'P':
534 : case 'f':
535 114923 : *c=*p; *q=p+1; return PPauto;
536 1164 : case '&':
537 1164 : *c='*'; *q=p+1; return PPstd;
538 14912 : case 'V':
539 14912 : if (p[1]=='=')
540 : {
541 10842 : if (p[2]!='G')
542 0 : compile_err("function prototype is not supported",str);
543 10842 : *c='='; p+=2;
544 : }
545 : else
546 4070 : *c=*p;
547 14912 : *q=p+1; return PPstd;
548 36548 : case 'E':
549 : case 's':
550 36548 : if (p[1]=='*') { *c=*p++; *q=p+1; return PPstar; }
551 : /*fall through*/
552 : }
553 90760324 : *c=*p; *q=p+1; return PPstd;
554 : }
555 :
556 : static long
557 357248 : detag(long n)
558 : {
559 357248 : while (tree[n].f==Ftag)
560 0 : n=tree[n].x;
561 357248 : return n;
562 : }
563 :
564 : /* return type for GP functions */
565 : static op_code
566 17939418 : get_ret_type(const char **p, long arity, Gtype *t, long *flag)
567 : {
568 17939418 : *flag = 0;
569 17939418 : if (**p == 'v') { (*p)++; *t=Gvoid; return OCcallvoid; }
570 17900507 : else if (**p == 'i') { (*p)++; *t=Gsmall; return OCcallint; }
571 17894701 : else if (**p == 'l') { (*p)++; *t=Gsmall; return OCcalllong; }
572 17873609 : else if (**p == 'u') { (*p)++; *t=Gusmall; return OCcalllong; }
573 17873609 : else if (**p == 'm') { (*p)++; *flag = FLnocopy; }
574 17873609 : *t=Ggen; return arity==2?OCcallgen2:OCcallgen;
575 : }
576 :
577 : static void
578 6 : U_compile_err(const char *s)
579 6 : { compile_err("this should be a small non-negative integer",s); }
580 : static void
581 5 : L_compile_err(const char *s)
582 5 : { 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 23156723 : compilecast_loc(int type, int mode, const char *loc)
590 : {
591 23156723 : if (type==mode) return;
592 13279795 : switch (mode)
593 : {
594 176 : case Gusmall:
595 176 : if (type==Ggen) op_push_loc(OCitou,-1,loc);
596 135 : else if (type==Gvoid) op_push_loc(OCpushlong,0,loc);
597 135 : else if (type!=Gsmall) U_compile_err(loc);
598 176 : break;
599 4135 : case Gsmall:
600 4135 : if (type==Ggen) op_push_loc(OCitos,-1,loc);
601 5 : else if (type==Gvoid) op_push_loc(OCpushlong,0,loc);
602 5 : else if (type!=Gusmall) L_compile_err(loc);
603 4130 : break;
604 13264904 : case Ggen:
605 13264904 : if (type==Gsmall) op_push_loc(OCstoi,0,loc);
606 13253014 : else if (type==Gusmall)op_push_loc(OCutoi,0,loc);
607 13253014 : else if (type==Gvoid) op_push_loc(OCpushgnil,0,loc);
608 13264904 : break;
609 7397 : case Gvoid:
610 7397 : op_push_loc(OCpop, 1,loc);
611 7397 : break;
612 3183 : case Gvar:
613 3183 : if (type==Ggen) op_push_loc(OCvarn,-1,loc);
614 6 : else compile_varerr(loc);
615 3177 : break;
616 0 : default:
617 0 : pari_err_BUG("compilecast [unknown type]");
618 : }
619 : }
620 :
621 : static void
622 15860691 : compilecast(long n, int type, int mode) { compilecast_loc(type, mode, tree[n].str); }
623 :
624 : static entree *
625 21550 : fetch_member_raw(const char *s, long len)
626 : {
627 21550 : pari_sp av = avma;
628 21550 : char *t = stack_malloc(len+2);
629 : entree *ep;
630 21550 : t[0] = '_'; strncpy(t+1, s, len); t[++len] = 0; /* prepend '_' */
631 21550 : ep = fetch_entry_raw(t, len);
632 21550 : set_avma(av); return ep;
633 : }
634 : static entree *
635 18651178 : getfunc(long n)
636 : {
637 18651178 : long x=tree[n].x;
638 18651178 : if (tree[x].x==CSTmember) /* str-1 points to '.' */
639 21550 : return do_alias(fetch_member_raw(tree[x].str - 1, tree[x].len + 1));
640 : else
641 18629628 : return do_alias(fetch_entry_raw(tree[x].str, tree[x].len));
642 : }
643 :
644 : static entree *
645 300853 : getentry(long n)
646 : {
647 300853 : n = detag(n);
648 300853 : if (tree[n].f!=Fentry)
649 : {
650 18 : if (tree[n].f==Fseq)
651 0 : compile_err("unexpected character: ';'", tree[tree[n].y].str-1);
652 18 : compile_varerr(tree[n].str);
653 : }
654 300835 : return getfunc(n);
655 : }
656 :
657 : static entree *
658 68471 : getvar(long n)
659 68471 : { return getentry(n); }
660 :
661 : /* match Fentry that are not actually EpSTATIC functions called without parens*/
662 : static entree *
663 92 : getvardyn(long n)
664 : {
665 92 : entree *ep = getentry(n);
666 92 : if (EpSTATIC(do_alias(ep)))
667 0 : compile_varerr(tree[n].str);
668 92 : return ep;
669 : }
670 :
671 : static long
672 9466086 : getmvar(entree *ep)
673 : {
674 : long i;
675 9466086 : long vn=0;
676 10423055 : for(i=s_lvar.n-1;i>=0;i--)
677 : {
678 1022461 : if(localvars[i].type==Lmy)
679 1022260 : vn--;
680 1022461 : if(localvars[i].ep==ep)
681 65492 : return localvars[i].type==Lmy?vn:0;
682 : }
683 9400594 : return 0;
684 : }
685 :
686 : static void
687 7849 : ctxmvar(long n)
688 : {
689 7849 : pari_sp av=avma;
690 : GEN ctx;
691 : long i;
692 7849 : if (n==0) return;
693 3423 : ctx = cgetg(n+1,t_VECSMALL);
694 57336 : for(n=0, i=0; i<s_lvar.n; i++)
695 53913 : if(localvars[i].type==Lmy)
696 53913 : ctx[++n]=(long)localvars[i].ep;
697 3423 : frame_push(ctx);
698 3423 : set_avma(av);
699 : }
700 :
701 : INLINE int
702 100739958 : is_func_named(entree *ep, const char *s)
703 : {
704 100739958 : return !strcmp(ep->name, s);
705 : }
706 :
707 : INLINE int
708 3274 : is_node_zero(long n)
709 : {
710 3274 : n = detag(n);
711 3274 : return (tree[n].f==Fsmall && tree[n].x==0);
712 : }
713 :
714 : static void
715 6 : str_defproto(const char *p, const char *q, const char *loc)
716 : {
717 6 : long len = p-4-q;
718 6 : if (q[1]!='"' || q[len]!='"')
719 0 : compile_err("default argument must be a string",loc);
720 6 : op_push_loc(OCpushgen,data_push(strntoGENexp(q+1,len)),loc);
721 6 : }
722 :
723 : static long
724 351 : countmatrixelts(long n)
725 : {
726 : long x,i;
727 351 : if (n==-1 || tree[n].f==Fnoarg) return 0;
728 825 : for(x=n, i=0; tree[x].f==Fmatrixelts; x=tree[x].x)
729 474 : if (tree[tree[x].y].f!=Fnoarg) i++;
730 351 : if (tree[x].f!=Fnoarg) i++;
731 351 : return i;
732 : }
733 :
734 : static long
735 44919652 : countlisttogen(long n, Ffunc f)
736 : {
737 : long x,i;
738 44919652 : if (n==-1 || tree[n].f==Fnoarg) return 0;
739 104083479 : for(x=n, i=0; tree[x].f==f ;x=tree[x].x, i++);
740 42125129 : return i+1;
741 : }
742 :
743 : static GEN
744 44919652 : listtogen(long n, Ffunc f)
745 : {
746 44919652 : long x,i,nb = countlisttogen(n, f);
747 44919652 : GEN z=cgetg(nb+1, t_VECSMALL);
748 44919652 : if (nb)
749 : {
750 104083479 : for (x=n, i = nb-1; i>0; z[i+1]=tree[x].y, x=tree[x].x, i--);
751 42125129 : z[1]=x;
752 : }
753 44919652 : return z;
754 : }
755 :
756 : static long
757 18367914 : first_safe_arg(GEN arg, long mask)
758 : {
759 18367914 : long lnc, l=lg(arg);
760 38927324 : for (lnc=l-1; lnc>0 && (tree[arg[lnc]].flags&mask)==mask; lnc--);
761 18367914 : return lnc;
762 : }
763 :
764 : static void
765 16417 : checkdups(GEN arg, GEN vep)
766 : {
767 16417 : long l=vecsmall_duplicate(vep);
768 16417 : if (l!=0) compile_err("variable declared twice",tree[arg[l]].str);
769 16417 : }
770 :
771 : enum {MAT_range,MAT_std,MAT_line,MAT_column,VEC_std};
772 :
773 : static int
774 13025 : matindex_type(long n)
775 : {
776 13025 : long x = tree[n].x, y = tree[n].y;
777 13025 : long fxx = tree[tree[x].x].f, fxy = tree[tree[x].y].f;
778 13025 : if (y==-1)
779 : {
780 11279 : if (fxy!=Fnorange) return MAT_range;
781 10788 : if (fxx==Fnorange) compile_err("missing index",tree[n].str);
782 10788 : return VEC_std;
783 : }
784 : else
785 : {
786 1746 : long fyx = tree[tree[y].x].f, fyy = tree[tree[y].y].f;
787 1746 : if (fxy!=Fnorange || fyy!=Fnorange) return MAT_range;
788 1614 : if (fxx==Fnorange && fyx==Fnorange)
789 0 : compile_err("missing index",tree[n].str);
790 1614 : if (fxx==Fnorange) return MAT_column;
791 928 : if (fyx==Fnorange) return MAT_line;
792 700 : return MAT_std;
793 : }
794 : }
795 :
796 : static entree *
797 41141 : getlvalue(long n)
798 : {
799 41978 : while ((tree[n].f==Fmatcoeff && matindex_type(tree[n].y)!=MAT_range) || tree[n].f==Ftag)
800 837 : n=tree[n].x;
801 41141 : return getvar(n);
802 : }
803 :
804 : INLINE void
805 38177 : compilestore(long vn, entree *ep, long n)
806 : {
807 38177 : if (vn)
808 3937 : op_push(OCstorelex,vn,n);
809 : else
810 : {
811 34240 : if (EpSTATIC(do_alias(ep)))
812 0 : compile_varerr(tree[n].str);
813 34240 : op_push(OCstoredyn,(long)ep,n);
814 : }
815 38177 : }
816 :
817 : INLINE void
818 699 : compilenewptr(long vn, entree *ep, long n)
819 : {
820 699 : if (vn)
821 : {
822 212 : access_push(vn);
823 212 : op_push(OCnewptrlex,vn,n);
824 : }
825 : else
826 487 : op_push(OCnewptrdyn,(long)ep,n);
827 699 : }
828 :
829 : static void
830 1530 : compilelvalue(long n)
831 : {
832 1530 : n = detag(n);
833 1530 : if (tree[n].f==Fentry)
834 699 : return;
835 : else
836 : {
837 831 : long x = tree[n].x, y = tree[n].y;
838 831 : long yx = tree[y].x, yy = tree[y].y;
839 831 : long m = matindex_type(y);
840 831 : if (m == MAT_range)
841 0 : compile_err("not an lvalue",tree[n].str);
842 831 : if (m == VEC_std && tree[x].f==Fmatcoeff)
843 : {
844 102 : int mx = matindex_type(tree[x].y);
845 102 : 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 831 : compilelvalue(x);
856 831 : switch(m)
857 : {
858 558 : case VEC_std:
859 558 : compilenode(tree[yx].x,Gsmall,0);
860 558 : op_push(OCcompo1ptr,0,y);
861 558 : break;
862 106 : case MAT_std:
863 106 : compilenode(tree[yx].x,Gsmall,0);
864 106 : compilenode(tree[yy].x,Gsmall,0);
865 106 : op_push(OCcompo2ptr,0,y);
866 106 : break;
867 84 : case MAT_line:
868 84 : compilenode(tree[yx].x,Gsmall,0);
869 84 : op_push(OCcompoLptr,0,y);
870 84 : break;
871 83 : case MAT_column:
872 83 : compilenode(tree[yy].x,Gsmall,0);
873 83 : op_push(OCcompoCptr,0,y);
874 83 : break;
875 : }
876 : }
877 : }
878 :
879 : static void
880 11255 : compilematcoeff(long n, int mode)
881 : {
882 11255 : long x=tree[n].x, y=tree[n].y;
883 11255 : long yx=tree[y].x, yy=tree[y].y;
884 11255 : long m=matindex_type(y);
885 11255 : compilenode(x,Ggen,FLnocopy);
886 11255 : switch(m)
887 : {
888 9564 : case VEC_std:
889 9564 : compilenode(tree[yx].x,Gsmall,0);
890 9564 : op_push(OCcompo1,mode,y);
891 9564 : return;
892 488 : case MAT_std:
893 488 : compilenode(tree[yx].x,Gsmall,0);
894 488 : compilenode(tree[yy].x,Gsmall,0);
895 488 : op_push(OCcompo2,mode,y);
896 488 : return;
897 60 : case MAT_line:
898 60 : compilenode(tree[yx].x,Gsmall,0);
899 60 : op_push(OCcompoL,0,y);
900 60 : compilecast(n,Gvec,mode);
901 60 : return;
902 520 : case MAT_column:
903 520 : compilenode(tree[yy].x,Gsmall,0);
904 520 : op_push(OCcompoC,0,y);
905 520 : compilecast(n,Gvec,mode);
906 520 : return;
907 623 : case MAT_range:
908 623 : compilenode(tree[yx].x,Gsmall,0);
909 623 : compilenode(tree[yx].y,Gsmall,0);
910 623 : if (yy==-1)
911 491 : op_push(OCcallgen,(long)is_entry("_[_.._]"),n);
912 : else
913 : {
914 132 : compilenode(tree[yy].x,Gsmall,0);
915 132 : compilenode(tree[yy].y,Gsmall,0);
916 132 : op_push(OCcallgen,(long)is_entry("_[_.._,_.._]"),n);
917 : }
918 623 : compilecast(n,Gvec,mode);
919 618 : return;
920 0 : default:
921 0 : pari_err_BUG("compilematcoeff");
922 : }
923 : }
924 :
925 : static void
926 26070527 : compilesmall(long n, long x, long mode)
927 : {
928 26070527 : if (mode==Ggen)
929 26000465 : op_push(OCpushstoi, x, n);
930 : else
931 : {
932 70062 : if (mode==Gusmall && x < 0) U_compile_err(tree[n].str);
933 70062 : op_push(OCpushlong, x, n);
934 70062 : compilecast(n,Gsmall,mode);
935 : }
936 26070521 : }
937 :
938 : static void
939 13225211 : compilevec(long n, long mode, op_code op)
940 : {
941 13225211 : pari_sp ltop=avma;
942 13225211 : long x=tree[n].x;
943 : long i;
944 13225211 : GEN arg=listtogen(x,Fmatrixelts);
945 13225211 : long l=lg(arg);
946 13225211 : op_push(op,l,n);
947 54704927 : for (i=1;i<l;i++)
948 : {
949 41479716 : if (tree[arg[i]].f==Fnoarg)
950 0 : compile_err("missing vector element",tree[arg[i]].str);
951 41479716 : compilenode(arg[i],Ggen,FLsurvive);
952 41479716 : op_push(OCstackgen,i,n);
953 : }
954 13225211 : set_avma(ltop);
955 13225211 : op_push(OCpop,1,n);
956 13225211 : compilecast(n,Gvec,mode);
957 13225211 : }
958 :
959 : static void
960 7605 : compilemat(long n, long mode)
961 : {
962 7605 : pari_sp ltop=avma;
963 7605 : long x=tree[n].x;
964 : long i,j;
965 7605 : GEN line=listtogen(x,Fmatrixlines);
966 7605 : long lglin = lg(line), lgcol=0;
967 7605 : op_push(OCpushlong, lglin,n);
968 7605 : if (lglin==1)
969 849 : op_push(OCmat,1,n);
970 36892 : for(i=1;i<lglin;i++)
971 : {
972 29287 : GEN col=listtogen(line[i],Fmatrixelts);
973 29287 : long l=lg(col), k;
974 29287 : if (i==1)
975 : {
976 6756 : lgcol=l;
977 6756 : op_push(OCmat,lgcol,n);
978 : }
979 22531 : else if (l!=lgcol)
980 0 : compile_err("matrix must be rectangular",tree[line[i]].str);
981 29287 : k=i;
982 224884 : for(j=1;j<lgcol;j++)
983 : {
984 195597 : k-=lglin;
985 195597 : if (tree[col[j]].f==Fnoarg)
986 0 : compile_err("missing matrix element",tree[col[j]].str);
987 195597 : compilenode(col[j], Ggen, FLsurvive);
988 195597 : op_push(OCstackgen,k,n);
989 : }
990 : }
991 7605 : set_avma(ltop);
992 7605 : op_push(OCpop,1,n);
993 7605 : compilecast(n,Gvec,mode);
994 7605 : }
995 :
996 : static GEN
997 39124 : cattovec(long n, long fnum)
998 : {
999 39124 : long x=n, y, i=0, nb;
1000 : GEN stack;
1001 39124 : if (tree[n].f==Fnoarg) return cgetg(1,t_VECSMALL);
1002 : while(1)
1003 170 : {
1004 39294 : long xx=tree[x].x;
1005 39294 : long xy=tree[x].y;
1006 39294 : if (tree[x].f!=Ffunction || xx!=fnum) break;
1007 170 : x=tree[xy].x;
1008 170 : y=tree[xy].y;
1009 170 : if (tree[y].f==Fnoarg)
1010 0 : compile_err("unexpected character: ", tree[y].str);
1011 170 : i++;
1012 : }
1013 39124 : if (tree[x].f==Fnoarg)
1014 0 : compile_err("unexpected character: ", tree[x].str);
1015 39124 : nb=i+1;
1016 39124 : stack=cgetg(nb+1,t_VECSMALL);
1017 39294 : for(x=n;i>0;i--)
1018 : {
1019 170 : long y=tree[x].y;
1020 170 : x=tree[y].x;
1021 170 : stack[i+1]=tree[y].y;
1022 : }
1023 39124 : stack[1]=x;
1024 39124 : return stack;
1025 : }
1026 :
1027 : static GEN
1028 182 : compilelambda(long y, GEN vep, long nbmvar, struct codepos *pos)
1029 : {
1030 182 : long lev = vep ? lg(vep)-1 : 0;
1031 182 : GEN text=cgetg(3,t_VEC);
1032 182 : gel(text,1)=strtoGENstr(lev? ((entree*) vep[1])->name: "");
1033 182 : gel(text,2)=strntoGENstr(tree[y].str,tree[y].len);
1034 182 : dbgstart = tree[y].str;
1035 182 : compilenode(y,Ggen,FLsurvive|FLreturn);
1036 182 : return getfunction(pos,lev,nbmvar,text,2);
1037 : }
1038 :
1039 : static void
1040 19379 : compilecall(long n, int mode, entree *ep)
1041 : {
1042 19379 : pari_sp ltop=avma;
1043 : long j;
1044 19379 : long x=tree[n].x, tx = tree[x].x;
1045 19379 : long y=tree[n].y;
1046 19379 : GEN arg=listtogen(y,Flistarg);
1047 19379 : long nb=lg(arg)-1;
1048 19379 : long lnc=first_safe_arg(arg, COsafelex|COsafedyn);
1049 19379 : long lnl=first_safe_arg(arg, COsafelex);
1050 19379 : long fl = lnl==0? (lnc==0? FLnocopy: FLnocopylex): 0;
1051 19379 : if (ep==NULL)
1052 263 : compilenode(x, Ggen, fl);
1053 : else
1054 : {
1055 19116 : long vn=getmvar(ep);
1056 19116 : if (vn)
1057 : {
1058 429 : access_push(vn);
1059 429 : op_push(OCpushlex,vn,n);
1060 : }
1061 : else
1062 18687 : op_push(OCpushdyn,(long)ep,n);
1063 : }
1064 52226 : for (j=1;j<=nb;j++)
1065 : {
1066 32847 : long x = tree[arg[j]].x, f = tree[arg[j]].f;
1067 32847 : if (f==Fseq)
1068 0 : compile_err("unexpected ';'", tree[x].str+tree[x].len);
1069 32847 : else if (f==Findarg)
1070 : {
1071 108 : long a = tree[arg[j]].x;
1072 108 : entree *ep = getlvalue(a);
1073 108 : long vn = getmvar(ep);
1074 108 : if (vn)
1075 42 : op_push(OCcowvarlex, vn, a);
1076 108 : compilenode(a, Ggen,FLnocopy);
1077 108 : op_push(OClock,0,n);
1078 32739 : } else if (tx==CSTmember)
1079 : {
1080 24 : compilenode(arg[j], Ggen,FLnocopy);
1081 24 : op_push(OClock,0,n);
1082 : }
1083 32715 : else if (f!=Fnoarg)
1084 32508 : compilenode(arg[j], Ggen,j>=lnl?FLnocopylex:0);
1085 : else
1086 207 : op_push(OCpushlong,0,n);
1087 : }
1088 19379 : op_push(OCcalluser,nb,x);
1089 19379 : compilecast(n,Ggen,mode);
1090 19379 : set_avma(ltop);
1091 19379 : }
1092 :
1093 : static GEN
1094 16393 : compilefuncinline(long n, long c, long a, long flag, long isif, long lev, long *ev)
1095 : {
1096 : struct codepos pos;
1097 16393 : int type=c=='I'?Gvoid:Ggen;
1098 16393 : long rflag=c=='I'?0:FLsurvive;
1099 16393 : long nbmvar = nblex;
1100 16393 : GEN vep = NULL;
1101 16393 : if (isif && (flag&FLreturn)) rflag|=FLreturn;
1102 16393 : getcodepos(&pos);
1103 16393 : if (c=='J') ctxmvar(nbmvar);
1104 16393 : if (lev)
1105 : {
1106 : long i;
1107 9523 : GEN varg=cgetg(lev+1,t_VECSMALL);
1108 9523 : vep=cgetg(lev+1,t_VECSMALL);
1109 19633 : for(i=0;i<lev;i++)
1110 : {
1111 : entree *ve;
1112 10110 : if (ev[i]<0)
1113 0 : compile_err("missing variable name", tree[a].str-1);
1114 10110 : ve = getvar(ev[i]);
1115 10110 : vep[i+1]=(long)ve;
1116 10110 : varg[i+1]=ev[i];
1117 10110 : var_push(ve,Lmy);
1118 : }
1119 9523 : checkdups(varg,vep);
1120 9523 : if (c=='J')
1121 182 : op_push(OCgetargs,lev,n);
1122 9523 : access_push(lg(vep)-1);
1123 9523 : frame_push(vep);
1124 : }
1125 16393 : if (c=='J')
1126 182 : return compilelambda(a,vep,nbmvar,&pos);
1127 16211 : if (tree[a].f==Fnoarg)
1128 99 : compilecast(a,Gvoid,type);
1129 : else
1130 16112 : compilenode(a,type,rflag);
1131 16211 : return getclosure(&pos, nbmvar);
1132 : }
1133 :
1134 : static long
1135 2709 : countvar(GEN arg)
1136 : {
1137 2709 : long i, l = lg(arg);
1138 2709 : long n = l-1;
1139 8513 : for(i=1; i<l; i++)
1140 : {
1141 5804 : long a=arg[i];
1142 5804 : if (tree[a].f==Fassign)
1143 : {
1144 3185 : long x = detag(tree[a].x);
1145 3185 : if (tree[x].f==Fvec && tree[x].x>=0)
1146 351 : n += countmatrixelts(tree[x].x)-1;
1147 : }
1148 : }
1149 2709 : return n;
1150 : }
1151 :
1152 : static void
1153 0 : compileuninline(GEN arg)
1154 : {
1155 : long j;
1156 0 : if (lg(arg) > 1)
1157 0 : compile_err("too many arguments",tree[arg[1]].str);
1158 0 : for(j=0; j<s_lvar.n; j++)
1159 0 : if(!localvars[j].inl)
1160 0 : pari_err(e_MISC,"uninline is only valid at top level");
1161 0 : s_lvar.n = 0; nblex = 0;
1162 0 : }
1163 :
1164 : static void
1165 2687 : compilemy(GEN arg, const char *str, int inl)
1166 : {
1167 2687 : long i, j, k, l = lg(arg);
1168 2687 : long n = countvar(arg);
1169 2687 : GEN vep = cgetg(n+1,t_VECSMALL);
1170 2687 : GEN ver = cgetg(n+1,t_VECSMALL);
1171 2687 : if (inl)
1172 : {
1173 6 : 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 8449 : for(k=0, i=1; i<l; i++)
1178 : {
1179 5762 : long a=arg[i];
1180 5762 : if (tree[a].f==Fassign)
1181 : {
1182 3154 : long x = detag(tree[a].x);
1183 3154 : if (tree[x].f==Fvec && tree[x].x>=0)
1184 341 : {
1185 341 : GEN vars = listtogen(tree[x].x,Fmatrixelts);
1186 341 : long nv = lg(vars)-1;
1187 1136 : for (j=1; j<=nv; j++)
1188 795 : if (tree[vars[j]].f!=Fnoarg)
1189 : {
1190 785 : ver[++k] = vars[j];
1191 785 : vep[k] = (long)getvar(ver[k]);
1192 : }
1193 341 : continue;
1194 2813 : } else ver[++k] = x;
1195 2608 : } else ver[++k] = a;
1196 5421 : vep[k] = (long)getvar(ver[k]);
1197 : }
1198 2687 : checkdups(ver,vep);
1199 8893 : for(i=1; i<=n; i++) var_push(NULL,Lmy);
1200 2687 : op_push_loc(OCnewframe,inl?-n:n,str);
1201 2687 : access_push(lg(vep)-1);
1202 2687 : frame_push(vep);
1203 8449 : for (k=0, i=1; i<l; i++)
1204 : {
1205 5762 : long a=arg[i];
1206 5762 : if (tree[a].f==Fassign)
1207 : {
1208 3154 : long x = detag(tree[a].x);
1209 3154 : if (tree[x].f==Fvec && tree[x].x>=0)
1210 341 : {
1211 341 : GEN vars = listtogen(tree[x].x,Fmatrixelts);
1212 341 : long nv = lg(vars)-1, m = nv;
1213 341 : compilenode(tree[a].y,Ggen,FLnocopy);
1214 1136 : for (j=1; j<=nv; j++)
1215 795 : if (tree[vars[j]].f==Fnoarg) m--;
1216 341 : if (m > 1) op_push(OCdup,m-1,x);
1217 1136 : for (j=1; j<=nv; j++)
1218 795 : if (tree[vars[j]].f!=Fnoarg)
1219 : {
1220 785 : long v = detag(vars[j]);
1221 785 : op_push(OCpushlong,j,v);
1222 785 : op_push(OCcompo1,Ggen,v);
1223 785 : k++;
1224 785 : op_push(OCstorelex,-n+k-1,a);
1225 785 : localvars[s_lvar.n-n+k-1].ep=(entree*)vep[k];
1226 785 : localvars[s_lvar.n-n+k-1].inl=inl;
1227 : }
1228 341 : continue;
1229 : }
1230 2813 : else if (!is_node_zero(tree[a].y))
1231 : {
1232 2705 : compilenode(tree[a].y,Ggen,FLnocopy);
1233 2705 : op_push(OCstorelex,-n+k,a);
1234 : }
1235 : }
1236 5421 : k++;
1237 5421 : localvars[s_lvar.n-n+k-1].ep=(entree*)vep[k];
1238 5421 : localvars[s_lvar.n-n+k-1].inl=inl;
1239 : }
1240 2687 : }
1241 :
1242 : static long
1243 52 : localpush(op_code op, long a)
1244 : {
1245 52 : entree *ep = getvardyn(a);
1246 52 : long vep = (long) ep;
1247 52 : op_push(op,vep,a);
1248 52 : var_push(ep,Llocal);
1249 52 : return vep;
1250 : }
1251 :
1252 : static void
1253 22 : compilelocal(GEN arg)
1254 : {
1255 22 : long i, j, k, l = lg(arg);
1256 22 : long n = countvar(arg);
1257 22 : GEN vep = cgetg(n+1,t_VECSMALL);
1258 22 : GEN ver = cgetg(n+1,t_VECSMALL);
1259 64 : for(k=0, i=1; i<l; i++)
1260 : {
1261 42 : long a=arg[i];
1262 42 : if (tree[a].f==Fassign)
1263 : {
1264 31 : long x = detag(tree[a].x);
1265 31 : if (tree[x].f==Fvec && tree[x].x>=0)
1266 10 : {
1267 10 : GEN vars = listtogen(tree[x].x,Fmatrixelts);
1268 10 : long nv = lg(vars)-1, m = nv;
1269 10 : compilenode(tree[a].y,Ggen,FLnocopy);
1270 40 : for (j=1; j<=nv; j++)
1271 30 : if (tree[vars[j]].f==Fnoarg) m--;
1272 10 : if (m > 1) op_push(OCdup,m-1,x);
1273 40 : for (j=1; j<=nv; j++)
1274 30 : if (tree[vars[j]].f!=Fnoarg)
1275 : {
1276 20 : long v = detag(vars[j]);
1277 20 : op_push(OCpushlong,j,v);
1278 20 : op_push(OCcompo1,Ggen,v);
1279 20 : vep[++k] = localpush(OClocalvar, v);
1280 20 : ver[k] = v;
1281 : }
1282 10 : continue;
1283 21 : } else if (!is_node_zero(tree[a].y))
1284 : {
1285 16 : compilenode(tree[a].y,Ggen,FLnocopy);
1286 16 : ver[++k] = x;
1287 16 : vep[k] = localpush(OClocalvar, ver[k]);
1288 16 : continue;
1289 : }
1290 : else
1291 5 : ver[++k] = x;
1292 : } else
1293 11 : ver[++k] = a;
1294 16 : vep[k] = localpush(OClocalvar0, ver[k]);
1295 : }
1296 22 : checkdups(ver,vep);
1297 22 : }
1298 :
1299 : static void
1300 30 : compileexport(GEN arg)
1301 : {
1302 30 : long i, l = lg(arg);
1303 60 : for (i=1; i<l; i++)
1304 : {
1305 30 : long a=arg[i];
1306 30 : if (tree[a].f==Fassign)
1307 : {
1308 12 : long x = detag(tree[a].x);
1309 12 : long v = (long) getvardyn(x);
1310 12 : compilenode(tree[a].y,Ggen,FLnocopy);
1311 12 : op_push(OCexportvar,v,x);
1312 : } else
1313 : {
1314 18 : long x = detag(a);
1315 18 : long v = (long) getvardyn(x);
1316 18 : op_push(OCpushdyn,v,x);
1317 18 : op_push(OCexportvar,v,x);
1318 : }
1319 : }
1320 30 : }
1321 :
1322 : static void
1323 0 : compileunexport(GEN arg)
1324 : {
1325 0 : long i, l = lg(arg);
1326 0 : for (i=1; i<l; i++)
1327 : {
1328 0 : long a = arg[i];
1329 0 : long x = detag(a);
1330 0 : long v = (long) getvardyn(x);
1331 0 : op_push(OCunexportvar,v,x);
1332 : }
1333 0 : }
1334 :
1335 : static void
1336 9161646 : compilefunc(entree *ep, long n, int mode, long flag)
1337 : {
1338 9161646 : pari_sp ltop=avma;
1339 : long j;
1340 9161646 : 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 9161646 : GEN arg=listtogen(y,Flistarg);
1349 9161646 : long lnc=first_safe_arg(arg, COsafelex|COsafedyn);
1350 9161646 : long lnl=first_safe_arg(arg, COsafelex);
1351 9161646 : long nbpointers=0, nbopcodes;
1352 9161646 : long nb=lg(arg)-1, lev=0;
1353 : long ev[20];
1354 9161646 : if (x>=OPnboperator)
1355 169600 : str=tree[x].str;
1356 : else
1357 : {
1358 8992046 : if (nb==2)
1359 969416 : str=tree[arg[1]].str+tree[arg[1]].len;
1360 8022630 : else if (nb==1)
1361 8021818 : str=tree[arg[1]].str;
1362 : else
1363 812 : str=tree[n].str;
1364 8997314 : while(*str==')') str++;
1365 : }
1366 9161646 : if (tree[n].f==Fassign)
1367 : {
1368 0 : nb=2; lnc=2; lnl=2; arg=mkvecsmall2(x,y);
1369 : }
1370 9161646 : else if (is_func_named(ep,"if"))
1371 : {
1372 3991 : if (nb>=4)
1373 95 : ep=is_entry("_multi_if");
1374 3896 : else if (mode==Gvoid)
1375 2498 : ep=is_entry("_void_if");
1376 : }
1377 9157655 : else if (is_func_named(ep,"return") && (flag&FLreturn) && nb<=1)
1378 : {
1379 90 : if (nb==0) op_push(OCpushgnil,0,n);
1380 90 : else compilenode(arg[1],Ggen,FLsurvive|FLreturn);
1381 90 : set_avma(ltop);
1382 7680397 : return;
1383 : }
1384 9157565 : else if (is_func_named(ep,"inline"))
1385 : {
1386 6 : compilemy(arg, str, 1);
1387 6 : compilecast(n,Gvoid,mode);
1388 6 : set_avma(ltop);
1389 6 : return;
1390 : }
1391 9157559 : else if (is_func_named(ep,"uninline"))
1392 : {
1393 0 : compileuninline(arg);
1394 0 : compilecast(n,Gvoid,mode);
1395 0 : set_avma(ltop);
1396 0 : return;
1397 : }
1398 9157559 : else if (is_func_named(ep,"my"))
1399 : {
1400 2681 : compilemy(arg, str, 0);
1401 2681 : compilecast(n,Gvoid,mode);
1402 2681 : set_avma(ltop);
1403 2681 : return;
1404 : }
1405 9154878 : else if (is_func_named(ep,"local"))
1406 : {
1407 22 : compilelocal(arg);
1408 22 : compilecast(n,Gvoid,mode);
1409 22 : set_avma(ltop);
1410 22 : return;
1411 : }
1412 9154856 : else if (is_func_named(ep,"export"))
1413 : {
1414 30 : compileexport(arg);
1415 30 : compilecast(n,Gvoid,mode);
1416 30 : set_avma(ltop);
1417 30 : return;
1418 : }
1419 9154826 : else if (is_func_named(ep,"unexport"))
1420 : {
1421 0 : compileunexport(arg);
1422 0 : compilecast(n,Gvoid,mode);
1423 0 : set_avma(ltop);
1424 0 : return;
1425 : }
1426 : /*We generate dummy code for global() for compatibility with gp2c*/
1427 9154826 : else if (is_func_named(ep,"global"))
1428 : {
1429 : long i;
1430 15 : for (i=1;i<=nb;i++)
1431 : {
1432 10 : long a=arg[i];
1433 : long en;
1434 10 : if (tree[a].f==Fassign)
1435 : {
1436 5 : compilenode(tree[a].y,Ggen,0);
1437 5 : a=tree[a].x;
1438 5 : en=(long)getvardyn(a);
1439 5 : op_push(OCstoredyn,en,a);
1440 : }
1441 : else
1442 : {
1443 5 : en=(long)getvardyn(a);
1444 5 : op_push(OCpushdyn,en,a);
1445 5 : op_push(OCpop,1,a);
1446 : }
1447 : }
1448 5 : compilecast(n,Gvoid,mode);
1449 5 : set_avma(ltop);
1450 5 : return;
1451 : }
1452 9154821 : else if (is_func_named(ep,"O"))
1453 : {
1454 3876 : if (nb!=1)
1455 0 : compile_err("wrong number of arguments", tree[n].str+tree[n].len-1);
1456 3876 : ep=is_entry("O(_^_)");
1457 3876 : if (tree[arg[1]].f==Ffunction && tree[arg[1]].x==OPpow)
1458 : {
1459 2926 : arg = listtogen(tree[arg[1]].y,Flistarg);
1460 2926 : nb = lg(arg)-1;
1461 2926 : lnc = first_safe_arg(arg,COsafelex|COsafedyn);
1462 2926 : lnl = first_safe_arg(arg,COsafelex);
1463 : }
1464 : }
1465 9150945 : else if (x==OPn && tree[y].f==Fsmall)
1466 : {
1467 7673720 : set_avma(ltop);
1468 7673720 : compilesmall(y, -tree[y].x, mode);
1469 7673720 : return;
1470 : }
1471 1477225 : else if (x==OPtrans && tree[y].f==Fvec)
1472 : {
1473 3843 : set_avma(ltop);
1474 3843 : compilevec(y, mode, OCcol);
1475 3843 : return;
1476 1473382 : } else if(x==OPlength && tree[y].f==Ffunction && tree[y].x==OPtrans)
1477 : {
1478 6 : arg[1] = tree[y].y;
1479 6 : lnc = first_safe_arg(arg,COsafelex|COsafedyn);
1480 6 : lnl = first_safe_arg(arg,COsafelex);
1481 6 : ep = is_entry("#_~");
1482 : }
1483 1473376 : else if (x==OPpow && nb==2)
1484 58012 : {
1485 58012 : long a = arg[2];
1486 58012 : if (tree[a].f==Fsmall)
1487 : {
1488 54169 : if(tree[a].x==2) { nb--; ep=is_entry("sqr"); }
1489 38800 : else ep=is_entry("_^s");
1490 : }
1491 3843 : else if (tree[a].f == Ffunction && tree[a].x == OPn)
1492 : {
1493 1075 : long ay = tree[a].y;
1494 1075 : if (tree[ay].f==Fsmall)
1495 : {
1496 967 : if (tree[ay].x==1) {nb--; ep=is_entry("_inv"); }
1497 658 : else ep=is_entry("_^s");
1498 : }
1499 : }
1500 : }
1501 1415364 : else if (x==OPcat)
1502 0 : compile_err("expected character: ',' or ')' instead of",
1503 0 : tree[arg[1]].str+tree[arg[1]].len);
1504 1481249 : p=ep->code;
1505 1481249 : if (!ep->value)
1506 0 : compile_err("unknown function",tree[n].str);
1507 1481249 : nbopcodes = s_opcode.n;
1508 1481249 : ret_op = get_ret_type(&p, ep->arity, &ret_typ, &ret_flag);
1509 1481249 : j=1;
1510 1481249 : if (*p)
1511 : {
1512 1473812 : q=p;
1513 4112517 : while((mod=parseproto(&p,&c,tree[n].str))!=PPend)
1514 : {
1515 2638740 : if (j<=nb && tree[arg[j]].f!=Fnoarg
1516 2547447 : && (mod==PPdefault || mod==PPdefaultmulti))
1517 55583 : mod=PPstd;
1518 2638740 : switch(mod)
1519 : {
1520 2535246 : case PPstd:
1521 2535246 : if (j>nb) compile_err("too few arguments", tree[n].str+tree[n].len-1);
1522 2535246 : if (c!='I' && c!='E' && c!='J')
1523 : {
1524 2519244 : long x = tree[arg[j]].x, f = tree[arg[j]].f;
1525 2519244 : if (f==Fnoarg)
1526 0 : compile_err("missing mandatory argument", tree[arg[j]].str);
1527 2519244 : if (f==Fseq)
1528 0 : compile_err("unexpected ';'", tree[x].str+tree[x].len);
1529 : }
1530 2535246 : switch(c)
1531 : {
1532 2440114 : case 'G':
1533 2440114 : compilenode(arg[j],Ggen,j>=lnl?(j>=lnc?FLnocopy:FLnocopylex):0);
1534 2440114 : j++;
1535 2440114 : break;
1536 467 : case 'W':
1537 : {
1538 467 : long a = tree[arg[j]].f==Findarg ? tree[arg[j]].x: arg[j];
1539 467 : entree *ep = getlvalue(a);
1540 455 : long vn = getmvar(ep);
1541 455 : if (vn)
1542 192 : op_push(OCcowvarlex, vn, a);
1543 263 : else op_push(OCcowvardyn, (long)ep, a);
1544 455 : compilenode(a, Ggen,FLnocopy);
1545 455 : j++;
1546 455 : break;
1547 : }
1548 41 : case 'M':
1549 41 : if (tree[arg[j]].f!=Fsmall)
1550 : {
1551 5 : const char *flags = ep->code;
1552 5 : flags = strchr(flags, '\n'); /* Skip to the following '\n' */
1553 5 : if (!flags)
1554 0 : compile_err("missing flag in string function signature",
1555 0 : tree[n].str);
1556 5 : flags++;
1557 5 : if (tree[arg[j]].f==Fconst && tree[arg[j]].x==CSTstr)
1558 5 : {
1559 5 : GEN str=strntoGENexp(tree[arg[j]].str,tree[arg[j]].len);
1560 5 : op_push(OCpushlong, eval_mnemonic(str, flags),n);
1561 5 : j++;
1562 : } else
1563 : {
1564 0 : compilenode(arg[j++],Ggen,FLnocopy);
1565 0 : op_push(OCevalmnem,(long)ep,n);
1566 : }
1567 5 : break;
1568 : }
1569 : case 'P': case 'L':
1570 60835 : compilenode(arg[j++],Gsmall,0);
1571 60830 : break;
1572 182 : case 'U':
1573 182 : compilenode(arg[j++],Gusmall,0);
1574 176 : break;
1575 3183 : case 'n':
1576 3183 : compilenode(arg[j++],Gvar,0);
1577 3177 : break;
1578 1860 : case '&': case '*':
1579 : {
1580 1860 : long vn, a=arg[j++];
1581 : entree *ep;
1582 1860 : if (c=='&')
1583 : {
1584 1278 : if (tree[a].f!=Frefarg)
1585 0 : compile_err("expected character: '&'", tree[a].str);
1586 1278 : a=tree[a].x;
1587 : }
1588 1860 : a=detag(a);
1589 1860 : ep=getlvalue(a);
1590 1860 : vn=getmvar(ep);
1591 1860 : if (tree[a].f==Fentry)
1592 : {
1593 1690 : if (vn)
1594 : {
1595 370 : access_push(vn);
1596 370 : op_push(OCsimpleptrlex, vn,n);
1597 : }
1598 : else
1599 1320 : op_push(OCsimpleptrdyn, (long)ep,n);
1600 : }
1601 : else
1602 : {
1603 170 : compilenewptr(vn, ep, a);
1604 170 : compilelvalue(a);
1605 170 : op_push(OCpushptr, 0, a);
1606 : }
1607 1860 : nbpointers++;
1608 1860 : break;
1609 : }
1610 16002 : case 'I':
1611 : case 'E':
1612 : case 'J':
1613 : {
1614 16002 : long a = arg[j++];
1615 16002 : GEN d = compilefuncinline(n, c, a, flag, is_func_named(ep,"if"), lev, ev);
1616 16002 : op_push(OCpushgen, data_push(d), a);
1617 16002 : if (lg(d)==8) op_push(OCsaveframe,FLsurvive,n);
1618 16002 : break;
1619 : }
1620 4307 : case 'V':
1621 : {
1622 4307 : long a = arg[j++];
1623 4307 : (void)getvar(a);
1624 4301 : ev[lev++] = a;
1625 4301 : break;
1626 : }
1627 5421 : case '=':
1628 : {
1629 5421 : long a = arg[j++];
1630 5421 : ev[lev++] = tree[a].x;
1631 5421 : compilenode(tree[a].y, Ggen, FLnocopy);
1632 : }
1633 5421 : break;
1634 852 : case 'r':
1635 : {
1636 852 : long a=arg[j++];
1637 852 : if (tree[a].f==Fentry)
1638 : {
1639 798 : op_push(OCpushgen, data_push(strntoGENstr(tree[tree[a].x].str,
1640 798 : tree[tree[a].x].len)),n);
1641 798 : op_push(OCtostr, -1,n);
1642 : }
1643 : else
1644 : {
1645 54 : compilenode(a,Ggen,FLnocopy);
1646 54 : op_push(OCtostr, -1,n);
1647 : }
1648 852 : break;
1649 : }
1650 2018 : case 's':
1651 : {
1652 2018 : long a = arg[j++];
1653 2018 : GEN g = cattovec(a, OPcat);
1654 2018 : long l, nb = lg(g)-1;
1655 2018 : if (nb==1)
1656 : {
1657 1959 : compilenode(g[1], Ggen, FLnocopy);
1658 1959 : op_push(OCtostr, -1, a);
1659 : } else
1660 : {
1661 59 : op_push(OCvec, nb+1, a);
1662 177 : for(l=1; l<=nb; l++)
1663 : {
1664 118 : compilenode(g[l], Ggen, FLsurvive);
1665 118 : op_push(OCstackgen,l, a);
1666 : }
1667 59 : op_push(OCpop, 1, a);
1668 59 : op_push(OCcallgen,(long)is_entry("Str"), a);
1669 59 : op_push(OCtostr, -1, a);
1670 : }
1671 2018 : 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 2535211 : break;
1678 27667 : case PPauto:
1679 27667 : switch(c)
1680 : {
1681 24009 : case 'p':
1682 24009 : op_push(OCprecreal,0,n);
1683 24009 : break;
1684 3619 : case 'b':
1685 3619 : op_push(OCbitprecreal,0,n);
1686 3619 : break;
1687 0 : case 'P':
1688 0 : op_push(OCprecdl,0,n);
1689 0 : break;
1690 39 : case 'C':
1691 39 : op_push(OCpushgen,data_push(pack_localvars()),n);
1692 39 : break;
1693 0 : case 'f':
1694 : {
1695 : static long foo;
1696 0 : op_push(OCpushlong,(long)&foo,n);
1697 0 : break;
1698 : }
1699 : }
1700 27667 : break;
1701 36742 : case PPdefault:
1702 36742 : j++;
1703 36742 : switch(c)
1704 : {
1705 28267 : case 'G':
1706 : case '&':
1707 : case 'E':
1708 : case 'I':
1709 : case 'r':
1710 : case 's':
1711 28267 : op_push(OCpushlong,0,n);
1712 28267 : break;
1713 7422 : case 'n':
1714 7422 : op_push(OCpushlong,-1,n);
1715 7422 : break;
1716 795 : case 'V':
1717 795 : ev[lev++] = -1;
1718 795 : break;
1719 258 : case 'P':
1720 258 : op_push(OCprecdl,0,n);
1721 258 : 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 36742 : break;
1727 26552 : case PPdefaultmulti:
1728 26552 : j++;
1729 26552 : switch(c)
1730 : {
1731 0 : case 'G':
1732 0 : op_push(OCpushstoi,strtol(q+1,NULL,10),n);
1733 0 : break;
1734 26510 : case 'L':
1735 : case 'M':
1736 26510 : op_push(OCpushlong,strtol(q+1,NULL,10),n);
1737 26510 : break;
1738 36 : case 'U':
1739 36 : op_push(OCpushlong,(long)strtoul(q+1,NULL,10),n);
1740 36 : break;
1741 6 : case 'r':
1742 : case 's':
1743 6 : str_defproto(p, q, tree[n].str);
1744 6 : op_push(OCtostr, -1, n);
1745 6 : 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 26552 : break;
1751 12533 : case PPstar:
1752 12533 : switch(c)
1753 : {
1754 95 : case 'E':
1755 : {
1756 95 : long k, n=nb+1-j;
1757 95 : GEN g=cgetg(n+1,t_VEC);
1758 95 : int ismif = is_func_named(ep,"_multi_if");
1759 486 : for(k=1; k<=n; k++)
1760 457 : gel(g, k) = compilefuncinline(n, c, arg[j+k-1], flag,
1761 391 : ismif && (k==n || odd(k)), lev, ev);
1762 95 : op_push(OCpushgen, data_push(g), arg[j]);
1763 95 : j=nb+1;
1764 95 : break;
1765 : }
1766 12438 : case 's':
1767 : {
1768 12438 : long n=nb+1-j;
1769 : long k,l,l1,m;
1770 12438 : GEN g=cgetg(n+1,t_VEC);
1771 29982 : for(l1=0,k=1;k<=n;k++)
1772 : {
1773 17544 : gel(g,k)=cattovec(arg[j+k-1],OPcat);
1774 17544 : l1+=lg(gel(g,k))-1;
1775 : }
1776 12438 : op_push_loc(OCvec, l1+1, str);
1777 29982 : for(m=1,k=1;k<=n;k++)
1778 35114 : for(l=1;l<lg(gel(g,k));l++,m++)
1779 : {
1780 17570 : compilenode(mael(g,k,l),Ggen,FLsurvive);
1781 17570 : op_push(OCstackgen,m,mael(g,k,l));
1782 : }
1783 12438 : op_push_loc(OCpop, 1, str);
1784 12438 : j=nb+1;
1785 12438 : 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 12533 : break;
1792 0 : default:
1793 0 : pari_err_BUG("compilefunc [unknown PPproto]");
1794 : }
1795 2638705 : q=p;
1796 : }
1797 : }
1798 1481214 : if (j<=nb)
1799 0 : compile_err("too many arguments",tree[arg[j]].str);
1800 1481214 : op_push_loc(ret_op, (long) ep, str);
1801 1481214 : if (mode==Ggen && (ret_flag&FLnocopy) && !(flag&FLnocopy))
1802 9127 : op_push_loc(OCcopy,0,str);
1803 1481214 : if (ret_typ==Ggen && nbpointers==0 && s_opcode.n>nbopcodes+128)
1804 : {
1805 2420 : op_insert_loc(nbopcodes,OCavma,0,str);
1806 2420 : op_push_loc(OCgc,0,str);
1807 : }
1808 1481214 : compilecast(n,ret_typ,mode);
1809 1481214 : if (nbpointers) op_push_loc(OCendptr,nbpointers, str);
1810 1481214 : set_avma(ltop);
1811 : }
1812 :
1813 : static void
1814 7294597 : genclosurectx(const char *loc, long nbdata)
1815 : {
1816 : long i;
1817 7294597 : GEN vep = cgetg(nbdata+1,t_VECSMALL);
1818 26034400 : for(i = 1; i <= nbdata; i++)
1819 : {
1820 18739803 : vep[i] = 0;
1821 18739803 : op_push_loc(OCpushlex,-i,loc);
1822 : }
1823 7294597 : frame_push(vep);
1824 7294597 : }
1825 :
1826 : static GEN
1827 7303243 : genclosure(entree *ep, const char *loc, long nbdata, int check)
1828 : {
1829 : struct codepos pos;
1830 7303243 : long nb=0;
1831 7303243 : const char *code=ep->code,*p,*q;
1832 : char c;
1833 : GEN text;
1834 7303243 : long index=ep->arity;
1835 7303243 : long arity=0, maskarg=0, maskarg0=0, stop=0, dovararg=0;
1836 : PPproto mod;
1837 : Gtype ret_typ;
1838 : long ret_flag;
1839 7303243 : op_code ret_op=get_ret_type(&code,ep->arity,&ret_typ,&ret_flag);
1840 7303243 : p=code;
1841 33346339 : while ((mod=parseproto(&p,&c,NULL))!=PPend)
1842 : {
1843 26043096 : if (mod==PPauto)
1844 1607 : stop=1;
1845 : else
1846 : {
1847 26041489 : if (stop) return NULL;
1848 26041489 : if (c=='V') continue;
1849 26041489 : maskarg<<=1; maskarg0<<=1; arity++;
1850 26041489 : switch(mod)
1851 : {
1852 26040504 : case PPstd:
1853 26040504 : maskarg|=1L;
1854 26040504 : break;
1855 409 : case PPdefault:
1856 409 : switch(c)
1857 : {
1858 22 : case '&':
1859 : case 'E':
1860 : case 'I':
1861 22 : maskarg0|=1L;
1862 22 : break;
1863 : }
1864 409 : break;
1865 576 : default:
1866 576 : break;
1867 : }
1868 : }
1869 : }
1870 7303243 : if (check && EpSTATIC(ep) && maskarg==0)
1871 7211 : return gen_0;
1872 7296032 : getcodepos(&pos);
1873 7296032 : dbgstart = loc;
1874 7296032 : if (nbdata > arity)
1875 0 : pari_err(e_MISC,"too many parameters for closure `%s'", ep->name);
1876 7296032 : if (nbdata) genclosurectx(loc, nbdata);
1877 7296032 : text = strtoGENstr(ep->name);
1878 7296032 : arity -= nbdata;
1879 7296032 : if (maskarg) op_push_loc(OCcheckargs,maskarg,loc);
1880 7296032 : if (maskarg0) op_push_loc(OCcheckargs0,maskarg0,loc);
1881 7296032 : p=code;
1882 33337664 : while ((mod=parseproto(&p,&c,NULL))!=PPend)
1883 : {
1884 26041632 : switch(mod)
1885 : {
1886 509 : case PPauto:
1887 509 : switch(c)
1888 : {
1889 509 : case 'p':
1890 509 : op_push_loc(OCprecreal,0,loc);
1891 509 : 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 0 : 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 26041632 : break;
1910 : }
1911 : }
1912 7296032 : q = p = code;
1913 33337664 : while ((mod=parseproto(&p,&c,NULL))!=PPend)
1914 : {
1915 26041632 : switch(mod)
1916 : {
1917 26040504 : case PPstd:
1918 26040504 : switch(c)
1919 : {
1920 26010370 : case 'G':
1921 26010370 : break;
1922 20653 : case 'M':
1923 : case 'L':
1924 20653 : op_push_loc(OCitos,-index,loc);
1925 20653 : break;
1926 9458 : case 'U':
1927 9458 : op_push_loc(OCitou,-index,loc);
1928 9458 : 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 23 : case 'r':
1939 : case 's':
1940 23 : op_push_loc(OCtostr,-index,loc);
1941 23 : break;
1942 : }
1943 26040504 : break;
1944 509 : case PPauto:
1945 509 : break;
1946 349 : case PPdefault:
1947 349 : switch(c)
1948 : {
1949 181 : case 'G':
1950 : case '&':
1951 : case 'E':
1952 : case 'I':
1953 : case 'V':
1954 181 : break;
1955 12 : case 'r':
1956 : case 's':
1957 12 : op_push_loc(OCtostr,-index,loc);
1958 12 : break;
1959 96 : case 'n':
1960 96 : op_push_loc(OCvarn,-index,loc);
1961 96 : break;
1962 60 : case 'P':
1963 60 : op_push_loc(OCprecdl,0,loc);
1964 60 : op_push_loc(OCdefaultlong,-index,loc);
1965 60 : break;
1966 0 : default:
1967 0 : pari_err(e_MISC,"Unknown prototype code `D%c' for `%s'",c,ep->name);
1968 : }
1969 349 : break;
1970 247 : case PPdefaultmulti:
1971 247 : 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 247 : case 'L':
1978 : case 'M':
1979 247 : op_push_loc(OCpushlong,strtol(q+1,NULL,10),loc);
1980 247 : op_push_loc(OCdefaultlong,-index,loc);
1981 247 : break;
1982 0 : case 'U':
1983 0 : op_push_loc(OCpushlong,(long)strtoul(q+1,NULL,10),loc);
1984 0 : op_push_loc(OCdefaultulong,-index,loc);
1985 0 : break;
1986 0 : case 'r':
1987 : case 's':
1988 0 : str_defproto(p, q, loc);
1989 0 : op_push_loc(OCdefaultgen,-index,loc);
1990 0 : op_push_loc(OCtostr,-index,loc);
1991 0 : break;
1992 0 : default:
1993 0 : pari_err(e_MISC,
1994 : "Unknown prototype code `D...,%c,' for `%s'",c,ep->name);
1995 : }
1996 247 : break;
1997 23 : case PPstar:
1998 23 : switch(c)
1999 : {
2000 23 : case 's':
2001 23 : dovararg = 1;
2002 23 : 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 23 : break;
2009 0 : default:
2010 0 : return NULL;
2011 : }
2012 26041632 : index--;
2013 26041632 : q = p;
2014 : }
2015 7296032 : op_push_loc(ret_op, (long) ep, loc);
2016 7296032 : if (ret_flag==FLnocopy) op_push_loc(OCcopy,0,loc);
2017 7296032 : compilecast_loc(ret_typ, Ggen, loc);
2018 7296032 : if (dovararg) nb|=VARARGBITS;
2019 7296032 : return getfunction(&pos,nb+arity,nbdata,text,0);
2020 : }
2021 :
2022 : GEN
2023 7293377 : snm_closure(entree *ep, GEN data)
2024 : {
2025 7293377 : long i, n = data ? lg(data)-1: 0;
2026 7293377 : GEN C = genclosure(ep,ep->name,n,0);
2027 26028300 : for(i = 1; i <= n; i++) gmael(C,7,i) = gel(data,i);
2028 7293377 : return C;
2029 : }
2030 :
2031 : GEN
2032 1322 : strtoclosure(const char *s, long n, ...)
2033 : {
2034 1322 : pari_sp av = avma;
2035 1322 : entree *ep = is_entry(s);
2036 : GEN C;
2037 1322 : if (!ep) pari_err(e_NOTFUNC, strtoGENstr(s));
2038 1322 : ep = do_alias(ep);
2039 1322 : if ((!EpSTATIC(ep) && EpVALENCE(ep)!=EpINSTALL) || !ep->value)
2040 0 : pari_err(e_MISC,"not a built-in/install'ed function: \"%s\"",s);
2041 1322 : C = genclosure(ep,ep->name,n,0);
2042 1322 : if (!C) pari_err(e_MISC,"function prototype unsupported: \"%s\"",s);
2043 : else
2044 : {
2045 : va_list ap;
2046 : long i;
2047 1322 : va_start(ap,n);
2048 6202 : for(i = 1; i <= n; i++) gmael(C,7,i) = va_arg(ap, GEN);
2049 1322 : va_end(ap);
2050 : }
2051 1322 : return gc_GEN(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 102 : strtofunction(const char *s) { return strtoclosure(s, 0); }
2074 :
2075 : GEN
2076 24 : call0(GEN fun, GEN args)
2077 : {
2078 24 : if (!is_vec_t(typ(args))) pari_err_TYPE("call",args);
2079 24 : switch(typ(fun))
2080 : {
2081 6 : case t_STR:
2082 6 : fun = strtofunction(GSTR(fun));
2083 24 : case t_CLOSURE: /* fall through */
2084 24 : 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 8544 : closurefunc(entree *ep, long n, long mode)
2093 : {
2094 8544 : pari_sp ltop=avma;
2095 : GEN C;
2096 8544 : if (!ep->value) compile_err("unknown function",tree[n].str);
2097 8544 : C = genclosure(ep,tree[n].str,0,1);
2098 8544 : if (!C) compile_err("sorry, closure not implemented",tree[n].str);
2099 8544 : if (C==gen_0)
2100 : {
2101 7211 : compilefunc(ep,n,mode,0);
2102 7211 : return;
2103 : }
2104 1333 : op_push(OCpushgen, data_push(C), n);
2105 1333 : compilecast(n,Gclosure,mode);
2106 1333 : set_avma(ltop);
2107 : }
2108 :
2109 : static void
2110 12199 : compileseq(long n, int mode, long flag)
2111 : {
2112 12199 : pari_sp av = avma;
2113 12199 : GEN L = listtogen(n, Fseq);
2114 12199 : long i, l = lg(L)-1;
2115 39214 : for(i = 1; i < l; i++)
2116 27015 : compilenode(L[i],Gvoid,0);
2117 12199 : compilenode(L[l],mode,flag&(FLreturn|FLsurvive));
2118 12199 : set_avma(av);
2119 12199 : }
2120 :
2121 : static void
2122 45165025 : compilenode(long n, int mode, long flag)
2123 : {
2124 : long x,y;
2125 : #ifdef STACK_CHECK
2126 45165025 : if (PARI_stack_limit && (void*) &x <= PARI_stack_limit)
2127 0 : pari_err(e_MISC, "expression nested too deeply");
2128 : #endif
2129 45165025 : if (n<0) pari_err_BUG("compilenode");
2130 45165025 : x=tree[n].x;
2131 45165025 : y=tree[n].y;
2132 :
2133 45165025 : switch(tree[n].f)
2134 : {
2135 12199 : case Fseq:
2136 12199 : compileseq(n, mode, flag);
2137 45164973 : return;
2138 11255 : case Fmatcoeff:
2139 11255 : compilematcoeff(n,mode);
2140 11250 : if (mode==Ggen && !(flag&FLnocopy))
2141 3502 : op_push(OCcopy,0,n);
2142 11250 : return;
2143 37971 : case Fassign:
2144 37971 : x = detag(x);
2145 37971 : if (tree[x].f==Fvec && tree[x].x>=0)
2146 666 : {
2147 666 : GEN vars = listtogen(tree[x].x,Fmatrixelts);
2148 666 : long i, l = lg(vars)-1, d = mode==Gvoid? l-1: l;
2149 666 : compilenode(y,Ggen,mode==Gvoid?0:flag&FLsurvive);
2150 2077 : for (i=1; i<=l; i++)
2151 1411 : if (tree[vars[i]].f==Fnoarg) d--;
2152 666 : if (d) op_push(OCdup, d, x);
2153 2077 : for(i=1; i<=l; i++)
2154 1411 : if (tree[vars[i]].f!=Fnoarg)
2155 : {
2156 1401 : long a = detag(vars[i]);
2157 1401 : entree *ep=getlvalue(a);
2158 1401 : long vn=getmvar(ep);
2159 1401 : op_push(OCpushlong,i,a);
2160 1401 : op_push(OCcompo1,Ggen,a);
2161 1401 : if (tree[a].f==Fentry)
2162 1396 : compilestore(vn,ep,n);
2163 : else
2164 : {
2165 5 : compilenewptr(vn,ep,n);
2166 5 : compilelvalue(a);
2167 5 : op_push(OCstoreptr,0,a);
2168 : }
2169 : }
2170 666 : if (mode!=Gvoid)
2171 380 : compilecast(n,Ggen,mode);
2172 : }
2173 : else
2174 : {
2175 37305 : entree *ep=getlvalue(x);
2176 37305 : long vn=getmvar(ep);
2177 37305 : if (tree[x].f!=Fentry)
2178 : {
2179 524 : compilenewptr(vn,ep,n);
2180 524 : compilelvalue(x);
2181 : }
2182 37305 : compilenode(y,Ggen,mode==Gvoid?FLnocopy:flag&FLsurvive);
2183 37305 : if (mode!=Gvoid)
2184 24704 : op_push(OCdup,1,n);
2185 37305 : if (tree[x].f==Fentry)
2186 36781 : compilestore(vn,ep,n);
2187 : else
2188 524 : op_push(OCstoreptr,0,x);
2189 37305 : if (mode!=Gvoid)
2190 24704 : compilecast(n,Ggen,mode);
2191 : }
2192 37971 : return;
2193 4063829 : case Fconst:
2194 : {
2195 4063829 : pari_sp ltop=avma;
2196 4063829 : if (tree[n].x!=CSTquote)
2197 : {
2198 4060664 : if (mode==Gvoid) return;
2199 4060664 : if (mode==Gvar) compile_varerr(tree[n].str);
2200 : }
2201 4063829 : if (mode==Gsmall) L_compile_err(tree[n].str);
2202 4063829 : if (mode==Gusmall && tree[n].x != CSTint) U_compile_err(tree[n].str);
2203 4063823 : switch(tree[n].x)
2204 : {
2205 5040 : case CSTreal:
2206 5040 : op_push(OCpushreal, data_push(strntoGENstr(tree[n].str,tree[n].len)),n);
2207 5040 : break;
2208 791959 : case CSTint:
2209 791959 : op_push(OCpushgen, data_push(strtoi((char*)tree[n].str)),n);
2210 791959 : compilecast(n,Ggen, mode);
2211 791959 : break;
2212 3263659 : case CSTstr:
2213 3263659 : op_push(OCpushgen, data_push(strntoGENexp(tree[n].str,tree[n].len)),n);
2214 3263659 : break;
2215 3165 : case CSTquote:
2216 : { /* skip ' */
2217 3165 : entree *ep = fetch_entry_raw(tree[n].str+1,tree[n].len-1);
2218 3165 : if (EpSTATIC(ep)) compile_varerr(tree[n].str+1);
2219 3165 : op_push(OCpushvar, (long)ep,n);
2220 3165 : compilecast(n,Ggen, mode);
2221 3165 : break;
2222 : }
2223 0 : default:
2224 0 : pari_err_BUG("compilenode, unsupported constant");
2225 : }
2226 4063823 : set_avma(ltop);
2227 4063823 : return;
2228 : }
2229 18396807 : case Fsmall:
2230 18396807 : compilesmall(n, x, mode);
2231 18396801 : return;
2232 13221368 : case Fvec:
2233 13221368 : compilevec(n, mode, OCvec);
2234 13221368 : return;
2235 7605 : case Fmat:
2236 7605 : compilemat(n, mode);
2237 7605 : 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 232290 : case Fentry:
2245 : {
2246 232290 : entree *ep=getentry(n);
2247 232290 : long vn=getmvar(ep);
2248 232290 : if (vn)
2249 : {
2250 59841 : access_push(vn);
2251 59841 : op_push(OCpushlex,(long)vn,n);
2252 59841 : addcopy(n,mode,flag,FLnocopy|FLnocopylex);
2253 59841 : compilecast(n,Ggen,mode);
2254 : }
2255 172449 : else if (ep->valence==EpVAR || ep->valence==EpNEW)
2256 : {
2257 163905 : if (DEBUGLEVEL && mode==Gvoid)
2258 0 : pari_warn(warner,"statement with no effect: `%s'",ep->name);
2259 163905 : op_push(OCpushdyn,(long)ep,n);
2260 163905 : addcopy(n,mode,flag,FLnocopy);
2261 163905 : compilecast(n,Ggen,mode);
2262 : }
2263 : else
2264 8544 : closurefunc(ep,n,mode);
2265 232290 : return;
2266 : }
2267 9173551 : case Ffunction:
2268 : {
2269 9173551 : entree *ep=getfunc(n);
2270 9173551 : if (getmvar(ep) || EpVALENCE(ep)==EpVAR || EpVALENCE(ep)==EpNEW)
2271 : {
2272 19116 : if (tree[n].x<OPnboperator) /* should not happen */
2273 0 : compile_err("operator unknown",tree[n].str);
2274 19116 : compilecall(n,mode,ep);
2275 : }
2276 : else
2277 9154435 : compilefunc(ep,n,mode,flag);
2278 9173516 : return;
2279 : }
2280 263 : case Fcall:
2281 263 : compilecall(n,mode,NULL);
2282 263 : return;
2283 7667 : case Flambda:
2284 : {
2285 7667 : pari_sp ltop=avma;
2286 : struct codepos pos;
2287 7667 : GEN arg=listtogen(x,Flistarg);
2288 7667 : long nb, lgarg, nbmvar, dovararg=0, gap;
2289 7667 : long strict = GP_DATA->strictargs;
2290 7667 : GEN vep = cgetg_copy(arg, &lgarg);
2291 7667 : GEN text=cgetg(3,t_VEC);
2292 7667 : gel(text,1)=strntoGENstr(tree[x].str,tree[x].len);
2293 7667 : if (lgarg==2 && tree[x].str[0]!='~' && tree[x].f==Findarg)
2294 : /* This occurs for member functions */
2295 12 : gel(text,1)=shallowconcat(strntoGENstr("~",1),gel(text,1));
2296 7667 : gel(text,2)=strntoGENstr(tree[y].str,tree[y].len);
2297 7667 : getcodepos(&pos);
2298 7667 : dbgstart=tree[x].str+tree[x].len;
2299 7667 : gap = tree[y].str-dbgstart;
2300 7667 : nbmvar = nblex;
2301 7667 : ctxmvar(nbmvar);
2302 7667 : nb = lgarg-1;
2303 7667 : if (nb)
2304 : {
2305 : long i;
2306 10892 : for(i=1;i<=nb;i++)
2307 : {
2308 6707 : long a = arg[i], f = tree[a].f;
2309 6707 : if (i==nb && f==Fvararg)
2310 : {
2311 16 : dovararg=1;
2312 16 : vep[i]=(long)getvar(tree[a].x);
2313 : }
2314 : else
2315 6691 : vep[i]=(long)getvar(f==Fassign||f==Findarg?tree[a].x:a);
2316 6707 : var_push(NULL,Lmy);
2317 : }
2318 4185 : checkdups(arg,vep);
2319 4185 : op_push(OCgetargs,nb,x);
2320 4185 : access_push(lg(vep)-1);
2321 4185 : frame_push(vep);
2322 10892 : for (i=1;i<=nb;i++)
2323 : {
2324 6707 : long a = arg[i], f = tree[a].f;
2325 6707 : long y = tree[a].y;
2326 6707 : if (f==Fassign && (strict || !is_node_zero(y)))
2327 : {
2328 324 : if (tree[y].f==Fsmall)
2329 246 : compilenode(y, Ggen, 0);
2330 : else
2331 : {
2332 : struct codepos lpos;
2333 78 : long nbmvar = nblex;
2334 78 : getcodepos(&lpos);
2335 78 : compilenode(y, Ggen, 0);
2336 78 : op_push(OCpushgen, data_push(getclosure(&lpos,nbmvar)),a);
2337 : }
2338 324 : op_push(OCdefaultarg,-nb+i-1,a);
2339 6383 : } else if (f==Findarg)
2340 72 : op_push(OCsetref, -nb+i-1, a);
2341 6707 : localvars[s_lvar.n-nb+i-1].ep=(entree*)vep[i];
2342 : }
2343 : }
2344 7667 : if (strict)
2345 15 : op_push(OCcheckuserargs,nb,x);
2346 7667 : dbgstart=tree[y].str;
2347 7667 : if (y>=0 && tree[y].f!=Fnoarg)
2348 7667 : compilenode(y,Ggen,FLsurvive|FLreturn);
2349 : else
2350 0 : compilecast(n,Gvoid,Ggen);
2351 7667 : if (dovararg) nb|=VARARGBITS;
2352 7667 : op_push(OCpushgen, data_push(getfunction(&pos,nb,nbmvar,text,gap)),n);
2353 7667 : if (nbmvar) op_push(OCsaveframe,!!(flag&FLsurvive),n);
2354 7667 : compilecast(n, Gclosure, mode);
2355 7667 : set_avma(ltop);
2356 7667 : return;
2357 : }
2358 0 : case Ftag:
2359 0 : compilenode(x, mode,flag);
2360 0 : return;
2361 6 : case Fnoarg:
2362 6 : compilecast(n,Gvoid,mode);
2363 6 : return;
2364 214 : case Fnorange:
2365 214 : op_push(OCpushlong,LONG_MAX,n);
2366 214 : compilecast(n,Gsmall,mode);
2367 214 : return;
2368 0 : default:
2369 0 : pari_err_BUG("compilenode");
2370 : }
2371 : }
2372 :
2373 : GEN
2374 797447 : gp_closure(long n)
2375 : {
2376 : struct codepos pos;
2377 797447 : getcodepos(&pos);
2378 797447 : dbgstart=tree[n].str;
2379 797447 : compilenode(n,Ggen,FLsurvive|FLreturn);
2380 797412 : return getfunction(&pos,0,0,strntoGENstr(tree[n].str,tree[n].len),0);
2381 : }
2382 :
2383 : GEN
2384 90 : closure_derivn(GEN G, long n)
2385 : {
2386 90 : pari_sp ltop = avma;
2387 : struct codepos pos;
2388 90 : long arity = closure_arity(G);
2389 : const char *code;
2390 : GEN t, text;
2391 :
2392 90 : if (arity == 0 || closure_is_variadic(G)) pari_err_TYPE("derivfun",G);
2393 90 : t = closure_get_text(G);
2394 90 : code = GSTR((typ(t) == t_STR)? t: GENtoGENstr(G));
2395 90 : if (n > 1)
2396 : {
2397 39 : text = cgetg(1+nchar2nlong(9+strlen(code)+n),t_STR);
2398 39 : sprintf(GSTR(text), "derivn(%s,%ld)", code, n);
2399 : }
2400 : else
2401 : {
2402 51 : text = cgetg(1+nchar2nlong(4+strlen(code)),t_STR);
2403 51 : sprintf(GSTR(text), (typ(t) == t_STR)? "%s'": "(%s)'",code);
2404 : }
2405 90 : getcodepos(&pos);
2406 90 : dbgstart = code;
2407 90 : op_push_loc(OCpackargs, arity, code);
2408 90 : op_push_loc(OCpushgen, data_push(G), code);
2409 90 : op_push_loc(OCpushlong, n, code);
2410 90 : op_push_loc(OCprecreal, 0, code);
2411 90 : op_push_loc(OCcallgen, (long)is_entry("_derivfun"), code);
2412 90 : return gc_GEN(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 13302772 : vec_optimize(GEN arg)
2421 : {
2422 13302772 : long fl = COsafelex|COsafedyn;
2423 : long i;
2424 55042541 : for (i=1; i<lg(arg); i++)
2425 : {
2426 41739775 : optimizenode(arg[i]);
2427 41739769 : fl &= tree[arg[i]].flags;
2428 : }
2429 13302766 : return fl;
2430 : }
2431 :
2432 : static void
2433 13226228 : optimizevec(long n)
2434 : {
2435 13226228 : pari_sp ltop=avma;
2436 13226228 : long x = tree[n].x;
2437 13226228 : GEN arg = listtogen(x, Fmatrixelts);
2438 13226228 : tree[n].flags = vec_optimize(arg);
2439 13226228 : set_avma(ltop);
2440 13226228 : }
2441 :
2442 : static void
2443 7605 : optimizemat(long n)
2444 : {
2445 7605 : pari_sp ltop = avma;
2446 7605 : long x = tree[n].x;
2447 : long i;
2448 7605 : GEN line = listtogen(x,Fmatrixlines);
2449 7605 : long fl = COsafelex|COsafedyn;
2450 36892 : for(i=1;i<lg(line);i++)
2451 : {
2452 29287 : GEN col=listtogen(line[i],Fmatrixelts);
2453 29287 : fl &= vec_optimize(col);
2454 : }
2455 7605 : set_avma(ltop); tree[n].flags=fl;
2456 7605 : }
2457 :
2458 : static void
2459 12086 : optimizematcoeff(long n)
2460 : {
2461 12086 : long x=tree[n].x;
2462 12086 : long y=tree[n].y;
2463 12086 : long yx=tree[y].x;
2464 12086 : long yy=tree[y].y;
2465 : long fl;
2466 12086 : optimizenode(x);
2467 12086 : optimizenode(yx);
2468 12086 : fl=tree[x].flags&tree[yx].flags;
2469 12086 : if (yy>=0)
2470 : {
2471 1473 : optimizenode(yy);
2472 1473 : fl&=tree[yy].flags;
2473 : }
2474 12086 : tree[n].flags=fl;
2475 12086 : }
2476 :
2477 : static void
2478 9157670 : optimizefunc(entree *ep, long n)
2479 : {
2480 9157670 : pari_sp av=avma;
2481 : long j;
2482 9157670 : long x=tree[n].x;
2483 9157670 : long y=tree[n].y;
2484 : Gtype t;
2485 : PPproto mod;
2486 9157670 : long fl=COsafelex|COsafedyn;
2487 : const char *p;
2488 : char c;
2489 9157670 : GEN arg = listtogen(y,Flistarg);
2490 9157670 : long nb=lg(arg)-1, ret_flag;
2491 9157670 : if (is_func_named(ep,"if") && nb>=4)
2492 95 : ep=is_entry("_multi_if");
2493 9157670 : p = ep->code;
2494 9157670 : if (!p)
2495 2744 : fl=0;
2496 : else
2497 9154926 : (void) get_ret_type(&p, 2, &t, &ret_flag);
2498 9157670 : if (p && *p)
2499 : {
2500 9149360 : j=1;
2501 19536456 : while((mod=parseproto(&p,&c,tree[n].str))!=PPend)
2502 : {
2503 10387120 : if (j<=nb && tree[arg[j]].f!=Fnoarg
2504 10240143 : && (mod==PPdefault || mod==PPdefaultmulti))
2505 52747 : mod=PPstd;
2506 10387120 : switch(mod)
2507 : {
2508 10227972 : case PPstd:
2509 10227972 : if (j>nb) compile_err("too few arguments", tree[n].str+tree[n].len-1);
2510 10227948 : if (tree[arg[j]].f==Fnoarg && c!='I' && c!='E')
2511 0 : compile_err("missing mandatory argument", tree[arg[j]].str);
2512 10227948 : switch(c)
2513 : {
2514 10197003 : case 'G':
2515 : case 'n':
2516 : case 'M':
2517 : case 'L':
2518 : case 'U':
2519 : case 'P':
2520 10197003 : optimizenode(arg[j]);
2521 10197003 : fl&=tree[arg[j++]].flags;
2522 10197003 : break;
2523 16008 : case 'I':
2524 : case 'E':
2525 : case 'J':
2526 16008 : optimizenode(arg[j]);
2527 16008 : fl&=tree[arg[j]].flags;
2528 16008 : tree[arg[j++]].flags=COsafelex|COsafedyn;
2529 16008 : break;
2530 1860 : case '&': case '*':
2531 : {
2532 1860 : long a=arg[j];
2533 1860 : if (c=='&')
2534 : {
2535 1278 : if (tree[a].f!=Frefarg)
2536 0 : compile_err("expected character: '&'", tree[a].str);
2537 1278 : a=tree[a].x;
2538 : }
2539 1860 : optimizenode(a);
2540 1860 : tree[arg[j++]].flags=COsafelex|COsafedyn;
2541 1860 : fl=0;
2542 1860 : break;
2543 : }
2544 479 : case 'W':
2545 : {
2546 479 : long a = tree[arg[j]].f==Findarg ? tree[arg[j]].x: arg[j];
2547 479 : optimizenode(a);
2548 479 : fl=0; j++;
2549 479 : break;
2550 : }
2551 5159 : case 'V':
2552 : case 'r':
2553 5159 : tree[arg[j++]].flags=COsafelex|COsafedyn;
2554 5159 : break;
2555 5421 : case '=':
2556 : {
2557 5421 : long a=arg[j++], y=tree[a].y;
2558 5421 : if (tree[a].f!=Fassign)
2559 0 : compile_err("expected character: '=' instead of",
2560 0 : tree[a].str+tree[a].len);
2561 5421 : optimizenode(y);
2562 5421 : fl&=tree[y].flags;
2563 : }
2564 5421 : break;
2565 2018 : case 's':
2566 2018 : fl &= vec_optimize(cattovec(arg[j++], OPcat));
2567 2018 : 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 10227948 : break;
2573 84631 : case PPauto:
2574 84631 : break;
2575 61984 : case PPdefault:
2576 : case PPdefaultmulti:
2577 61984 : if (j<=nb) optimizenode(arg[j++]);
2578 61984 : break;
2579 12533 : case PPstar:
2580 12533 : switch(c)
2581 : {
2582 95 : case 'E':
2583 : {
2584 95 : long n=nb+1-j;
2585 : long k;
2586 486 : for(k=1;k<=n;k++)
2587 : {
2588 391 : optimizenode(arg[j+k-1]);
2589 391 : fl &= tree[arg[j+k-1]].flags;
2590 : }
2591 95 : j=nb+1;
2592 95 : break;
2593 : }
2594 12438 : case 's':
2595 : {
2596 12438 : long n=nb+1-j;
2597 : long k;
2598 29982 : for(k=1;k<=n;k++)
2599 17544 : fl &= vec_optimize(cattovec(arg[j+k-1],OPcat));
2600 12438 : j=nb+1;
2601 12438 : 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 12533 : break;
2608 0 : default:
2609 0 : pari_err_BUG("optimizefun [unknown PPproto]");
2610 : }
2611 : }
2612 9149336 : if (j<=nb)
2613 0 : compile_err("too many arguments",tree[arg[j]].str);
2614 : }
2615 8310 : else (void)vec_optimize(arg);
2616 9157646 : set_avma(av); tree[n].flags=fl;
2617 9157646 : }
2618 :
2619 : static void
2620 19385 : optimizecall(long n)
2621 : {
2622 19385 : pari_sp av=avma;
2623 19385 : long x=tree[n].x;
2624 19385 : long y=tree[n].y;
2625 19385 : GEN arg=listtogen(y,Flistarg);
2626 19385 : optimizenode(x);
2627 19385 : tree[n].flags = COsafelex&tree[x].flags&vec_optimize(arg);
2628 19379 : set_avma(av);
2629 19379 : }
2630 :
2631 : static void
2632 12199 : optimizeseq(long n)
2633 : {
2634 12199 : pari_sp av = avma;
2635 12199 : GEN L = listtogen(n, Fseq);
2636 12199 : long i, l = lg(L)-1, flags=-1L;
2637 51413 : for(i = 1; i <= l; i++)
2638 : {
2639 39214 : optimizenode(L[i]);
2640 39214 : flags &= tree[L[i]].flags;
2641 : }
2642 12199 : set_avma(av);
2643 12199 : tree[n].flags = flags;
2644 12199 : }
2645 :
2646 : void
2647 52963423 : optimizenode(long n)
2648 : {
2649 : long x,y;
2650 : #ifdef STACK_CHECK
2651 52963423 : if (PARI_stack_limit && (void*) &x <= PARI_stack_limit)
2652 0 : pari_err(e_MISC, "expression nested too deeply");
2653 : #endif
2654 52963423 : if (n<0)
2655 0 : pari_err_BUG("optimizenode");
2656 52963423 : x=tree[n].x;
2657 52963423 : y=tree[n].y;
2658 :
2659 52963423 : switch(tree[n].f)
2660 : {
2661 12199 : case Fseq:
2662 12199 : optimizeseq(n);
2663 52896569 : return;
2664 13559 : case Frange:
2665 13559 : optimizenode(x);
2666 13559 : optimizenode(y);
2667 13559 : tree[n].flags=tree[x].flags&tree[y].flags;
2668 13559 : break;
2669 12086 : case Fmatcoeff:
2670 12086 : optimizematcoeff(n);
2671 12086 : break;
2672 41173 : case Fassign:
2673 41173 : optimizenode(x);
2674 41173 : optimizenode(y);
2675 41173 : tree[n].flags=0;
2676 41173 : break;
2677 30465737 : case Fnoarg:
2678 : case Fnorange:
2679 : case Fsmall:
2680 : case Fconst:
2681 : case Fentry:
2682 30465737 : tree[n].flags=COsafelex|COsafedyn;
2683 30465737 : return;
2684 13226228 : case Fvec:
2685 13226228 : optimizevec(n);
2686 13226228 : return;
2687 7605 : case Fmat:
2688 7605 : optimizemat(n);
2689 7605 : return;
2690 6 : case Frefarg:
2691 6 : compile_err("unexpected character '&'",tree[n].str);
2692 0 : return;
2693 108 : case Findarg:
2694 108 : return;
2695 0 : case Fvararg:
2696 0 : compile_err("unexpected characters '..'",tree[n].str);
2697 0 : return;
2698 9176792 : case Ffunction:
2699 : {
2700 9176792 : entree *ep=getfunc(n);
2701 9176792 : if (EpVALENCE(ep)==EpVAR || EpVALENCE(ep)==EpNEW)
2702 19122 : optimizecall(n);
2703 : else
2704 9157670 : optimizefunc(ep,n);
2705 9176762 : return;
2706 : }
2707 263 : case Fcall:
2708 263 : optimizecall(n);
2709 263 : return;
2710 7667 : case Flambda:
2711 7667 : optimizenode(y);
2712 7667 : tree[n].flags=COsafelex|COsafedyn;
2713 7667 : 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 : }
|
