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 880336 : translate(const char **src, char *s)
35 : {
36 880336 : const char *t = *src;
37 6943757 : while (*t)
38 : {
39 6944405 : 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 6943757 : if (*t == '"')
51 : {
52 880336 : if (t[1] != '"') break;
53 0 : t += 2; continue;
54 : }
55 6063421 : *s++ = *t++;
56 : }
57 880336 : *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 880332 : strntoGENexp(const char *str, long len)
79 : {
80 880332 : long n = nchar2nlong(len-1);
81 880332 : GEN z = cgetg(1+n, t_STR);
82 880332 : const char *t = str+1;
83 880332 : z[n] = 0;
84 880332 : if (!translate(&t, GSTR(z))) compile_err("run-away string",str);
85 880332 : 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 337396 : pari_init_compiler(void)
122 : {
123 337396 : pari_stack_init(&s_opcode,sizeof(*opcode),(void **)&opcode);
124 337393 : pari_stack_init(&s_operand,sizeof(*operand),(void **)&operand);
125 337388 : pari_stack_init(&s_accesslex,sizeof(*operand),(void **)&accesslex);
126 337390 : pari_stack_init(&s_data,sizeof(*data),(void **)&data);
127 337390 : pari_stack_init(&s_lvar,sizeof(*localvars),(void **)&localvars);
128 337390 : pari_stack_init(&s_dbginfo,sizeof(*dbginfo),(void **)&dbginfo);
129 337390 : pari_stack_init(&s_frame,sizeof(*frames),(void **)&frames);
130 337389 : offset=-1; nblex=0;
131 337389 : }
132 : void
133 335717 : pari_close_compiler(void)
134 : {
135 335717 : pari_stack_delete(&s_opcode);
136 334419 : pari_stack_delete(&s_operand);
137 332921 : pari_stack_delete(&s_accesslex);
138 332010 : pari_stack_delete(&s_data);
139 331375 : pari_stack_delete(&s_lvar);
140 330913 : pari_stack_delete(&s_dbginfo);
141 330669 : pari_stack_delete(&s_frame);
142 330645 : }
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 8984782 : getcodepos(struct codepos *pos)
153 : {
154 8984782 : pos->opcode=s_opcode.n;
155 8984782 : pos->accesslex=s_accesslex.n;
156 8984782 : pos->data=s_data.n;
157 8984782 : pos->offset=offset;
158 8984782 : pos->nblex=nblex;
159 8984782 : pos->localvars=s_lvar.n;
160 8984782 : pos->dbgstart=dbgstart;
161 8984782 : pos->frames=s_frame.n;
162 8984782 : offset=s_data.n-1;
163 8984782 : }
164 :
165 : void
166 445 : compilestate_reset(void)
167 : {
168 445 : s_opcode.n=0;
169 445 : s_operand.n=0;
170 445 : s_accesslex.n=0;
171 445 : s_dbginfo.n=0;
172 445 : s_data.n=0;
173 445 : s_lvar.n=0;
174 445 : s_frame.n=0;
175 445 : offset=-1;
176 445 : nblex=0;
177 445 : dbgstart=NULL;
178 445 : }
179 :
180 : void
181 1429475 : compilestate_save(struct pari_compilestate *comp)
182 : {
183 1429475 : comp->opcode=s_opcode.n;
184 1429475 : comp->operand=s_operand.n;
185 1429475 : comp->accesslex=s_accesslex.n;
186 1429475 : comp->data=s_data.n;
187 1429475 : comp->offset=offset;
188 1429475 : comp->nblex=nblex;
189 1429475 : comp->localvars=s_lvar.n;
190 1429475 : comp->dbgstart=dbgstart;
191 1429475 : comp->dbginfo=s_dbginfo.n;
192 1429475 : comp->frames=s_frame.n;
193 1429475 : }
194 :
195 : void
196 56290 : compilestate_restore(struct pari_compilestate *comp)
197 : {
198 56290 : s_opcode.n=comp->opcode;
199 56290 : s_operand.n=comp->operand;
200 56290 : s_accesslex.n=comp->accesslex;
201 56290 : s_data.n=comp->data;
202 56290 : offset=comp->offset;
203 56290 : nblex=comp->nblex;
204 56290 : s_lvar.n=comp->localvars;
205 56290 : dbgstart=comp->dbgstart;
206 56290 : s_dbginfo.n=comp->dbginfo;
207 56290 : s_frame.n=comp->frames;
208 56290 : }
209 :
210 : static GEN
211 9800963 : gcopyunclone(GEN x) { GEN y = gcopy(x); gunclone(x); return y; }
212 :
213 : static void
214 114858 : access_push(long x)
215 : {
216 114858 : long a = pari_stack_new(&s_accesslex);
217 114858 : accesslex[a] = x;
218 114858 : }
219 :
220 : static GEN
221 8033368 : genctx(long nbmvar, long paccesslex)
222 : {
223 8033368 : GEN acc = const_vec(nbmvar,gen_1);
224 8033368 : long i, lvl = 1 + nbmvar;
225 8075130 : for (i = paccesslex; i<s_accesslex.n; i++)
226 : {
227 41762 : long a = accesslex[i];
228 41762 : if (a > 0) { lvl+=a; continue; }
229 36644 : a += lvl;
230 36644 : if (a <= 0) pari_err_BUG("genctx");
231 36644 : if (a <= nbmvar)
232 28515 : gel(acc, a) = gen_0;
233 : }
234 8033368 : s_accesslex.n = paccesslex;
235 28572486 : for (i = 1; i<=nbmvar; i++)
236 20539118 : if (signe(gel(acc,i))==0)
237 20689 : access_push(i-nbmvar-1);
238 8033368 : return acc;
239 : }
240 :
241 : static GEN
242 8984726 : getfunction(const struct codepos *pos, long arity, long nbmvar, GEN text,
243 : long gap)
244 : {
245 8984726 : long lop = s_opcode.n+1 - pos->opcode;
246 8984726 : long ldat = s_data.n+1 - pos->data;
247 8984726 : long lfram = s_frame.n+1 - pos->frames;
248 8984726 : 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 8984708 : cl[1] = arity;
254 8984708 : gel(cl,2) = cgetg(nchar2nlong(lop)+1, t_STR);
255 8984653 : gel(cl,3) = op = cgetg(lop, t_VECSMALL);
256 8984652 : gel(cl,4) = dat = cgetg(ldat, t_VEC);
257 8984663 : dbg = cgetg(lop, t_VECSMALL);
258 8984662 : frpc = cgetg(lfram, t_VECSMALL);
259 8984656 : fram = cgetg(lfram, t_VEC);
260 8984659 : gel(cl,5) = mkvec3(dbg, frpc, fram);
261 8984688 : if (text) gel(cl,6) = text;
262 8984688 : s = GSTR(gel(cl,2)) - 1;
263 85038159 : for (i = 1; i < lop; i++)
264 : {
265 76053471 : long j = i+pos->opcode-1;
266 76053471 : s[i] = opcode[j];
267 76053471 : op[i] = operand[j];
268 76053471 : dbg[i] = dbginfo[j] - dbgstart;
269 76053471 : if (dbg[i] < 0) dbg[i] += gap;
270 : }
271 8984688 : s[i] = 0;
272 8984688 : s_opcode.n = pos->opcode;
273 8984688 : s_operand.n = pos->opcode;
274 8984688 : s_dbginfo.n = pos->opcode;
275 8984688 : if (lg(cl)==8)
276 8022459 : gel(cl,7) = genctx(nbmvar, pos->accesslex);
277 962229 : else if (nbmvar==0)
278 951412 : s_accesslex.n = pos->accesslex;
279 : else
280 : {
281 10817 : pari_sp av = avma;
282 10817 : (void) genctx(nbmvar, pos->accesslex);
283 10902 : set_avma(av);
284 : }
285 10742747 : for (i = 1; i < ldat; i++)
286 1757976 : if (data[i+pos->data-1]) gel(dat,i) = gcopyunclone(data[i+pos->data-1]);
287 8984771 : s_data.n = pos->data;
288 9013425 : while (s_lvar.n > pos->localvars && !localvars[s_lvar.n-1].inl)
289 : {
290 28654 : if (localvars[s_lvar.n-1].type==Lmy) nblex--;
291 28654 : s_lvar.n--;
292 : }
293 17027848 : for (i = 1; i < lfram; i++)
294 : {
295 8042991 : long j = i+pos->frames-1;
296 8042991 : frpc[i] = frames[j].pc - pos->opcode+1;
297 8042991 : gel(fram, i) = gcopyunclone(frames[j].frame);
298 : }
299 8984857 : s_frame.n = pos->frames;
300 8984857 : offset = pos->offset;
301 8984857 : dbgstart = pos->dbgstart;
302 8984857 : return cl;
303 : }
304 :
305 : static GEN
306 20147 : getclosure(struct codepos *pos, long nbmvar)
307 : {
308 20147 : return getfunction(pos, 0, nbmvar, NULL, 0);
309 : }
310 :
311 : static void
312 76050219 : op_push_loc(op_code o, long x, const char *loc)
313 : {
314 76050219 : long n=pari_stack_new(&s_opcode);
315 76050156 : long m=pari_stack_new(&s_operand);
316 76050093 : long d=pari_stack_new(&s_dbginfo);
317 76050100 : opcode[n]=o;
318 76050100 : operand[m]=x;
319 76050100 : dbginfo[d]=loc;
320 76050100 : }
321 :
322 : static void
323 38514766 : op_push(op_code o, long x, long n)
324 : {
325 38514766 : op_push_loc(o,x,tree[n].str);
326 38514766 : }
327 :
328 : static void
329 2975 : op_insert_loc(long k, op_code o, long x, const char *loc)
330 : {
331 : long i;
332 2975 : long n=pari_stack_new(&s_opcode);
333 2975 : (void) pari_stack_new(&s_operand);
334 2975 : (void) pari_stack_new(&s_dbginfo);
335 623659 : for (i=n-1; i>=k; i--)
336 : {
337 620684 : opcode[i+1] = opcode[i];
338 620684 : operand[i+1]= operand[i];
339 620684 : dbginfo[i+1]= dbginfo[i];
340 : }
341 2975 : opcode[k] = o;
342 2975 : operand[k] = x;
343 2975 : dbginfo[k] = loc;
344 2975 : }
345 :
346 : static long
347 1757976 : data_push(GEN x)
348 : {
349 1757976 : long n=pari_stack_new(&s_data);
350 1757976 : data[n] = x?gclone(x):x;
351 1757976 : return n-offset;
352 : }
353 :
354 : static void
355 65167 : var_push(entree *ep, Ltype type)
356 : {
357 65167 : long n=pari_stack_new(&s_lvar);
358 65167 : localvars[n].ep = ep;
359 65167 : localvars[n].inl = 0;
360 65167 : localvars[n].type = type;
361 65167 : if (type == Lmy) nblex++;
362 65167 : }
363 :
364 : static void
365 8043013 : frame_push(GEN x)
366 : {
367 8043013 : long n=pari_stack_new(&s_frame);
368 8043007 : frames[n].pc = s_opcode.n-1;
369 8043007 : frames[n].frame = gclone(x);
370 8043068 : }
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 gc_upto(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 269316 : addcopy(long n, long mode, long flag, long mask)
485 : {
486 269316 : if (mode==Ggen && !(flag&mask))
487 : {
488 26860 : op_push(OCcopy,0,n);
489 26860 : if (!(flag&FLsurvive) && DEBUGLEVEL)
490 0 : pari_warn(warner,"compiler generates copy for `%.*s'",
491 0 : tree[n].len,tree[n].str);
492 : }
493 269316 : }
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 121793753 : parseproto(char const **q, char *c, const char *str)
501 : {
502 121793753 : char const *p=*q;
503 : long i;
504 121793753 : switch(*p)
505 : {
506 29620124 : case 0:
507 : case '\n':
508 29620124 : return PPend;
509 282041 : case 'D':
510 282041 : switch(p[1])
511 : {
512 191694 : 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 191694 : *c=p[1]; *q=p+2; return PPdefault;
524 90347 : default:
525 545652 : for(i=0;*p && i<2;p++) i+=*p==',';
526 : /* assert(i>=2) because check_proto validated the protototype */
527 90347 : *c=p[-2]; *q=p; return PPdefaultmulti;
528 : }
529 : break;
530 140077 : case 'C':
531 : case 'p':
532 : case 'b':
533 : case 'P':
534 : case 'f':
535 140077 : *c=*p; *q=p+1; return PPauto;
536 1550 : case '&':
537 1550 : *c='*'; *q=p+1; return PPstd;
538 18730 : case 'V':
539 18730 : if (p[1]=='=')
540 : {
541 13610 : if (p[2]!='G')
542 0 : compile_err("function prototype is not supported",str);
543 13610 : *c='='; p+=2;
544 : }
545 : else
546 5120 : *c=*p;
547 18730 : *q=p+1; return PPstd;
548 45222 : case 'E':
549 : case 's':
550 45222 : if (p[1]=='*') { *c=*p++; *q=p+1; return PPstar; }
551 : /*fall through*/
552 : }
553 91700726 : *c=*p; *q=p+1; return PPstd;
554 : }
555 :
556 : static long
557 430796 : detag(long n)
558 : {
559 430796 : while (tree[n].f==Ftag)
560 0 : n=tree[n].x;
561 430796 : return n;
562 : }
563 :
564 : /* return type for GP functions */
565 : static op_code
566 13596360 : get_ret_type(const char **p, long arity, Gtype *t, long *flag)
567 : {
568 13596360 : *flag = 0;
569 13596360 : if (**p == 'v') { (*p)++; *t=Gvoid; return OCcallvoid; }
570 13548283 : else if (**p == 'i') { (*p)++; *t=Gsmall; return OCcallint; }
571 13541514 : else if (**p == 'l') { (*p)++; *t=Gsmall; return OCcalllong; }
572 13515738 : else if (**p == 'u') { (*p)++; *t=Gusmall; return OCcalllong; }
573 13515738 : else if (**p == 'm') { (*p)++; *flag = FLnocopy; }
574 13515738 : *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 14708665 : compilecast_loc(int type, int mode, const char *loc)
590 : {
591 14708665 : if (type==mode) return;
592 4530246 : 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 5145 : case Gsmall:
600 5145 : 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 5138 : break;
604 4512081 : case Ggen:
605 4512081 : if (type==Gsmall) op_push_loc(OCstoi,0,loc);
606 4497755 : else if (type==Gusmall)op_push_loc(OCutoi,0,loc);
607 4497755 : else if (type==Gvoid) op_push_loc(OCpushgnil,0,loc);
608 4512081 : break;
609 8957 : case Gvoid:
610 8957 : op_push_loc(OCpop, 1,loc);
611 8957 : break;
612 3863 : case Gvar:
613 3863 : if (type==Ggen) op_push_loc(OCvarn,-1,loc);
614 7 : else compile_varerr(loc);
615 3856 : break;
616 0 : default:
617 0 : pari_err_BUG("compilecast [unknown type]");
618 : }
619 : }
620 :
621 : static void
622 6688579 : compilecast(long n, int type, int mode) { compilecast_loc(type, mode, tree[n].str); }
623 :
624 : static entree *
625 25221 : fetch_member_raw(const char *s, long len)
626 : {
627 25221 : pari_sp av = avma;
628 25221 : char *t = stack_malloc(len+2);
629 : entree *ep;
630 25221 : t[0] = '_'; strncpy(t+1, s, len); t[++len] = 0; /* prepend '_' */
631 25221 : ep = fetch_entry_raw(t, len);
632 25221 : set_avma(av); return ep;
633 : }
634 : static entree *
635 9650754 : getfunc(long n)
636 : {
637 9650754 : long x=tree[n].x;
638 9650754 : if (tree[x].x==CSTmember) /* str-1 points to '.' */
639 25221 : return do_alias(fetch_member_raw(tree[x].str - 1, tree[x].len + 1));
640 : else
641 9625533 : return do_alias(fetch_entry_raw(tree[x].str, tree[x].len));
642 : }
643 :
644 : static entree *
645 362889 : getentry(long n)
646 : {
647 362889 : n = detag(n);
648 362889 : 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 362868 : return getfunc(n);
655 : }
656 :
657 : static entree *
658 82939 : getvar(long n)
659 82939 : { 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 4993564 : getmvar(entree *ep)
673 : {
674 : long i;
675 4993564 : long vn=0;
676 6125153 : for(i=s_lvar.n-1;i>=0;i--)
677 : {
678 1210758 : if(localvars[i].type==Lmy)
679 1210485 : vn--;
680 1210758 : if(localvars[i].ep==ep)
681 79169 : return localvars[i].type==Lmy?vn:0;
682 : }
683 4914395 : return 0;
684 : }
685 :
686 : static void
687 9578 : ctxmvar(long n)
688 : {
689 9578 : pari_sp av=avma;
690 : GEN ctx;
691 : long i;
692 9578 : if (n==0) return;
693 4159 : ctx = cgetg(n+1,t_VECSMALL);
694 67349 : for(n=0, i=0; i<s_lvar.n; i++)
695 63190 : if(localvars[i].type==Lmy)
696 63190 : ctx[++n]=(long)localvars[i].ep;
697 4159 : frame_push(ctx);
698 4159 : set_avma(av);
699 : }
700 :
701 : INLINE int
702 50859983 : is_func_named(entree *ep, const char *s)
703 : {
704 50859983 : return !strcmp(ep->name, s);
705 : }
706 :
707 : INLINE int
708 4036 : is_node_zero(long n)
709 : {
710 4036 : n = detag(n);
711 4036 : 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 427 : countmatrixelts(long n)
725 : {
726 : long x,i;
727 427 : if (n==-1 || tree[n].f==Fnoarg) return 0;
728 1008 : for(x=n, i=0; tree[x].f==Fmatrixelts; x=tree[x].x)
729 581 : if (tree[tree[x].y].f!=Fnoarg) i++;
730 427 : if (tree[x].f!=Fnoarg) i++;
731 427 : return i;
732 : }
733 :
734 : static long
735 18365210 : countlisttogen(long n, Ffunc f)
736 : {
737 : long x,i;
738 18365210 : if (n==-1 || tree[n].f==Fnoarg) return 0;
739 42747784 : for(x=n, i=0; tree[x].f==f ;x=tree[x].x, i++);
740 17607275 : return i+1;
741 : }
742 :
743 : static GEN
744 18365210 : listtogen(long n, Ffunc f)
745 : {
746 18365210 : long x,i,nb = countlisttogen(n, f);
747 18365210 : GEN z=cgetg(nb+1, t_VECSMALL);
748 18365210 : if (nb)
749 : {
750 42747784 : for (x=n, i = nb-1; i>0; z[i+1]=tree[x].y, x=tree[x].x, i--);
751 17607275 : z[1]=x;
752 : }
753 18365210 : return z;
754 : }
755 :
756 : static long
757 9309398 : first_safe_arg(GEN arg, long mask)
758 : {
759 9309398 : long lnc, l=lg(arg);
760 19637523 : for (lnc=l-1; lnc>0 && (tree[arg[lnc]].flags&mask)==mask; lnc--);
761 9309398 : return lnc;
762 : }
763 :
764 : static void
765 20571 : checkdups(GEN arg, GEN vep)
766 : {
767 20571 : long l=vecsmall_duplicate(vep);
768 20571 : if (l!=0) compile_err("variable declared twice",tree[arg[l]].str);
769 20571 : }
770 :
771 : enum {MAT_range,MAT_std,MAT_line,MAT_column,VEC_std};
772 :
773 : static int
774 15605 : matindex_type(long n)
775 : {
776 15605 : long x = tree[n].x, y = tree[n].y;
777 15605 : long fxx = tree[tree[x].x].f, fxy = tree[tree[x].y].f;
778 15605 : if (y==-1)
779 : {
780 13526 : if (fxy!=Fnorange) return MAT_range;
781 12917 : if (fxx==Fnorange) compile_err("missing index",tree[n].str);
782 12917 : return VEC_std;
783 : }
784 : else
785 : {
786 2079 : long fyx = tree[tree[y].x].f, fyy = tree[tree[y].y].f;
787 2079 : if (fxy!=Fnorange || fyy!=Fnorange) return MAT_range;
788 1904 : if (fxx==Fnorange && fyx==Fnorange)
789 0 : compile_err("missing index",tree[n].str);
790 1904 : 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 48933 : getlvalue(long n)
798 : {
799 49934 : while ((tree[n].f==Fmatcoeff && matindex_type(tree[n].y)!=MAT_range) || tree[n].f==Ftag)
800 1001 : n=tree[n].x;
801 48933 : return getvar(n);
802 : }
803 :
804 : INLINE void
805 45414 : compilestore(long vn, entree *ep, long n)
806 : {
807 45414 : if (vn)
808 4723 : op_push(OCstorelex,vn,n);
809 : else
810 : {
811 40691 : if (EpSTATIC(do_alias(ep)))
812 0 : compile_varerr(tree[n].str);
813 40691 : op_push(OCstoredyn,(long)ep,n);
814 : }
815 45414 : }
816 :
817 : INLINE void
818 840 : compilenewptr(long vn, entree *ep, long n)
819 : {
820 840 : if (vn)
821 : {
822 252 : access_push(vn);
823 252 : op_push(OCnewptrlex,vn,n);
824 : }
825 : else
826 588 : op_push(OCnewptrdyn,(long)ep,n);
827 840 : }
828 :
829 : static void
830 1834 : compilelvalue(long n)
831 : {
832 1834 : n = detag(n);
833 1834 : if (tree[n].f==Fentry)
834 840 : return;
835 : else
836 : {
837 994 : long x = tree[n].x, y = tree[n].y;
838 994 : long yx = tree[y].x, yy = tree[y].y;
839 994 : long m = matindex_type(y);
840 994 : if (m == MAT_range)
841 0 : compile_err("not an lvalue",tree[n].str);
842 994 : 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 994 : compilelvalue(x);
856 994 : switch(m)
857 : {
858 672 : case VEC_std:
859 672 : compilenode(tree[yx].x,Gsmall,0);
860 672 : op_push(OCcompo1ptr,0,y);
861 672 : 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 13491 : compilematcoeff(long n, int mode)
881 : {
882 13491 : long x=tree[n].x, y=tree[n].y;
883 13491 : long yx=tree[y].x, yy=tree[y].y;
884 13491 : long m=matindex_type(y);
885 13491 : compilenode(x,Ggen,FLnocopy);
886 13491 : switch(m)
887 : {
888 11447 : case VEC_std:
889 11447 : compilenode(tree[yx].x,Gsmall,0);
890 11447 : op_push(OCcompo1,mode,y);
891 11447 : 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 616 : case MAT_column:
903 616 : compilenode(tree[yy].x,Gsmall,0);
904 616 : op_push(OCcompoC,0,y);
905 616 : compilecast(n,Gvec,mode);
906 616 : return;
907 784 : case MAT_range:
908 784 : compilenode(tree[yx].x,Gsmall,0);
909 784 : compilenode(tree[yx].y,Gsmall,0);
910 784 : if (yy==-1)
911 609 : 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 784 : compilecast(n,Gvec,mode);
919 777 : return;
920 0 : default:
921 0 : pari_err_BUG("compilematcoeff");
922 : }
923 : }
924 :
925 : static void
926 11100979 : compilesmall(long n, long x, long mode)
927 : {
928 11100979 : if (mode==Ggen)
929 11015429 : op_push(OCpushstoi, x, n);
930 : else
931 : {
932 85550 : if (mode==Gusmall && x < 0) U_compile_err(tree[n].str);
933 85550 : op_push(OCpushlong, x, n);
934 85550 : compilecast(n,Gsmall,mode);
935 : }
936 11100972 : }
937 :
938 : static void
939 4463255 : compilevec(long n, long mode, op_code op)
940 : {
941 4463255 : pari_sp ltop=avma;
942 4463255 : long x=tree[n].x;
943 : long i;
944 4463255 : GEN arg=listtogen(x,Fmatrixelts);
945 4463255 : long l=lg(arg);
946 4463255 : op_push(op,l,n);
947 20310906 : for (i=1;i<l;i++)
948 : {
949 15847651 : if (tree[arg[i]].f==Fnoarg)
950 0 : compile_err("missing vector element",tree[arg[i]].str);
951 15847651 : compilenode(arg[i],Ggen,FLsurvive);
952 15847651 : op_push(OCstackgen,i,n);
953 : }
954 4463255 : set_avma(ltop);
955 4463255 : op_push(OCpop,1,n);
956 4463255 : compilecast(n,Gvec,mode);
957 4463255 : }
958 :
959 : static void
960 9653 : compilemat(long n, long mode)
961 : {
962 9653 : pari_sp ltop=avma;
963 9653 : long x=tree[n].x;
964 : long i,j;
965 9653 : GEN line=listtogen(x,Fmatrixlines);
966 9653 : long lglin = lg(line), lgcol=0;
967 9653 : op_push(OCpushlong, lglin,n);
968 9653 : if (lglin==1)
969 994 : op_push(OCmat,1,n);
970 47957 : for(i=1;i<lglin;i++)
971 : {
972 38304 : GEN col=listtogen(line[i],Fmatrixelts);
973 38304 : long l=lg(col), k;
974 38304 : if (i==1)
975 : {
976 8659 : lgcol=l;
977 8659 : op_push(OCmat,lgcol,n);
978 : }
979 29645 : else if (l!=lgcol)
980 0 : compile_err("matrix must be rectangular",tree[line[i]].str);
981 38304 : k=i;
982 292341 : for(j=1;j<lgcol;j++)
983 : {
984 254037 : k-=lglin;
985 254037 : if (tree[col[j]].f==Fnoarg)
986 0 : compile_err("missing matrix element",tree[col[j]].str);
987 254037 : compilenode(col[j], Ggen, FLsurvive);
988 254037 : op_push(OCstackgen,k,n);
989 : }
990 : }
991 9653 : set_avma(ltop);
992 9653 : op_push(OCpop,1,n);
993 9653 : compilecast(n,Gvec,mode);
994 9653 : }
995 :
996 : static GEN
997 48184 : cattovec(long n, long fnum)
998 : {
999 48184 : long x=n, y, i=0, nb;
1000 : GEN stack;
1001 48184 : if (tree[n].f==Fnoarg) return cgetg(1,t_VECSMALL);
1002 : while(1)
1003 210 : {
1004 48394 : long xx=tree[x].x;
1005 48394 : long xy=tree[x].y;
1006 48394 : 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 48184 : if (tree[x].f==Fnoarg)
1014 0 : compile_err("unexpected character: ", tree[x].str);
1015 48184 : nb=i+1;
1016 48184 : stack=cgetg(nb+1,t_VECSMALL);
1017 48394 : 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 48184 : stack[1]=x;
1024 48184 : 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 23214 : compilecall(long n, int mode, entree *ep)
1041 : {
1042 23214 : pari_sp ltop=avma;
1043 : long j;
1044 23214 : long x=tree[n].x, tx = tree[x].x;
1045 23214 : long y=tree[n].y;
1046 23214 : GEN arg=listtogen(y,Flistarg);
1047 23214 : long nb=lg(arg)-1;
1048 23214 : long lnc=first_safe_arg(arg, COsafelex|COsafedyn);
1049 23214 : long lnl=first_safe_arg(arg, COsafelex);
1050 23214 : long fl = lnl==0? (lnc==0? FLnocopy: FLnocopylex): 0;
1051 23214 : if (ep==NULL)
1052 329 : compilenode(x, Ggen, fl);
1053 : else
1054 : {
1055 22885 : long vn=getmvar(ep);
1056 22885 : if (vn)
1057 : {
1058 567 : access_push(vn);
1059 567 : op_push(OCpushlex,vn,n);
1060 : }
1061 : else
1062 22318 : op_push(OCpushdyn,(long)ep,n);
1063 : }
1064 62645 : for (j=1;j<=nb;j++)
1065 : {
1066 39431 : long x = tree[arg[j]].x, f = tree[arg[j]].f;
1067 39431 : if (f==Fseq)
1068 0 : compile_err("unexpected ';'", tree[x].str+tree[x].len);
1069 39431 : 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 39305 : } else if (tx==CSTmember)
1079 : {
1080 28 : compilenode(arg[j], Ggen,FLnocopy);
1081 28 : op_push(OClock,0,n);
1082 : }
1083 39277 : else if (f!=Fnoarg)
1084 39025 : compilenode(arg[j], Ggen,j>=lnl?FLnocopylex:0);
1085 : else
1086 252 : op_push(OCpushlong,0,n);
1087 : }
1088 23214 : op_push(OCcalluser,nb,x);
1089 23214 : compilecast(n,Ggen,mode);
1090 23214 : set_avma(ltop);
1091 23214 : }
1092 :
1093 : static GEN
1094 20402 : compilefuncinline(long n, long c, long a, long flag, long isif, long lev, long *ev)
1095 : {
1096 : struct codepos pos;
1097 20402 : int type=c=='I'?Gvoid:Ggen;
1098 20402 : long rflag=c=='I'?0:FLsurvive;
1099 20402 : long nbmvar = nblex;
1100 20402 : GEN vep = NULL;
1101 20402 : if (isif && (flag&FLreturn)) rflag|=FLreturn;
1102 20402 : getcodepos(&pos);
1103 20402 : if (c=='J') ctxmvar(nbmvar);
1104 20402 : if (lev)
1105 : {
1106 : long i;
1107 11982 : GEN varg=cgetg(lev+1,t_VECSMALL);
1108 11982 : vep=cgetg(lev+1,t_VECSMALL);
1109 24724 : for(i=0;i<lev;i++)
1110 : {
1111 : entree *ve;
1112 12742 : if (ev[i]<0)
1113 0 : compile_err("missing variable name", tree[a].str-1);
1114 12742 : ve = getvar(ev[i]);
1115 12742 : vep[i+1]=(long)ve;
1116 12742 : varg[i+1]=ev[i];
1117 12742 : var_push(ve,Lmy);
1118 : }
1119 11982 : checkdups(varg,vep);
1120 11982 : if (c=='J')
1121 339 : op_push(OCgetargs,lev,n);
1122 11982 : access_push(lg(vep)-1);
1123 11982 : frame_push(vep);
1124 : }
1125 20402 : if (c=='J')
1126 339 : return compilelambda(a,vep,nbmvar,&pos);
1127 20063 : if (tree[a].f==Fnoarg)
1128 141 : compilecast(a,Gvoid,type);
1129 : else
1130 19922 : compilenode(a,type,rflag);
1131 20063 : return getclosure(&pos, nbmvar);
1132 : }
1133 :
1134 : static long
1135 3420 : countvar(GEN arg)
1136 : {
1137 3420 : long i, l = lg(arg);
1138 3420 : long n = l-1;
1139 10587 : for(i=1; i<l; i++)
1140 : {
1141 7167 : long a=arg[i];
1142 7167 : if (tree[a].f==Fassign)
1143 : {
1144 3966 : long x = detag(tree[a].x);
1145 3966 : if (tree[x].f==Fvec && tree[x].x>=0)
1146 427 : n += countmatrixelts(tree[x].x)-1;
1147 : }
1148 : }
1149 3420 : 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 3392 : compilemy(GEN arg, const char *str, int inl)
1166 : {
1167 3392 : long i, j, k, l = lg(arg);
1168 3392 : long n = countvar(arg);
1169 3392 : GEN vep = cgetg(n+1,t_VECSMALL);
1170 3392 : GEN ver = cgetg(n+1,t_VECSMALL);
1171 3392 : 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 10503 : for(k=0, i=1; i<l; i++)
1178 : {
1179 7111 : long a=arg[i];
1180 7111 : if (tree[a].f==Fassign)
1181 : {
1182 3924 : long x = detag(tree[a].x);
1183 3924 : if (tree[x].f==Fvec && tree[x].x>=0)
1184 413 : {
1185 413 : GEN vars = listtogen(tree[x].x,Fmatrixelts);
1186 413 : long nv = lg(vars)-1;
1187 1379 : for (j=1; j<=nv; j++)
1188 966 : if (tree[vars[j]].f!=Fnoarg)
1189 : {
1190 952 : ver[++k] = vars[j];
1191 952 : vep[k] = (long)getvar(ver[k]);
1192 : }
1193 413 : continue;
1194 3511 : } else ver[++k] = x;
1195 3187 : } else ver[++k] = a;
1196 6698 : vep[k] = (long)getvar(ver[k]);
1197 : }
1198 3392 : checkdups(ver,vep);
1199 11042 : for(i=1; i<=n; i++) var_push(NULL,Lmy);
1200 3392 : op_push_loc(OCnewframe,inl?-n:n,str);
1201 3392 : access_push(lg(vep)-1);
1202 3392 : frame_push(vep);
1203 10503 : for (k=0, i=1; i<l; i++)
1204 : {
1205 7111 : long a=arg[i];
1206 7111 : if (tree[a].f==Fassign)
1207 : {
1208 3924 : long x = detag(tree[a].x);
1209 3924 : if (tree[x].f==Fvec && tree[x].x>=0)
1210 413 : {
1211 413 : GEN vars = listtogen(tree[x].x,Fmatrixelts);
1212 413 : long nv = lg(vars)-1, m = nv;
1213 413 : compilenode(tree[a].y,Ggen,FLnocopy);
1214 1379 : for (j=1; j<=nv; j++)
1215 966 : if (tree[vars[j]].f==Fnoarg) m--;
1216 413 : if (m > 1) op_push(OCdup,m-1,x);
1217 1379 : for (j=1; j<=nv; j++)
1218 966 : if (tree[vars[j]].f!=Fnoarg)
1219 : {
1220 952 : long v = detag(vars[j]);
1221 952 : op_push(OCpushlong,j,v);
1222 952 : op_push(OCcompo1,Ggen,v);
1223 952 : k++;
1224 952 : op_push(OCstorelex,-n+k-1,a);
1225 952 : localvars[s_lvar.n-n+k-1].ep=(entree*)vep[k];
1226 952 : localvars[s_lvar.n-n+k-1].inl=inl;
1227 : }
1228 413 : continue;
1229 : }
1230 3511 : else if (!is_node_zero(tree[a].y))
1231 : {
1232 3370 : compilenode(tree[a].y,Ggen,FLnocopy);
1233 3370 : op_push(OCstorelex,-n+k,a);
1234 : }
1235 : }
1236 6698 : k++;
1237 6698 : localvars[s_lvar.n-n+k-1].ep=(entree*)vep[k];
1238 6698 : localvars[s_lvar.n-n+k-1].inl=inl;
1239 : }
1240 3392 : }
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 4627859 : compilefunc(entree *ep, long n, int mode, long flag)
1337 : {
1338 4627859 : pari_sp ltop=avma;
1339 : long j;
1340 4627859 : 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 4627859 : GEN arg=listtogen(y,Flistarg);
1349 4627859 : long lnc=first_safe_arg(arg, COsafelex|COsafedyn);
1350 4627859 : long lnl=first_safe_arg(arg, COsafelex);
1351 4627859 : long nbpointers=0, nbopcodes;
1352 4627859 : long nb=lg(arg)-1, lev=0;
1353 : long ev[20];
1354 4627859 : if (x>=OPnboperator)
1355 204282 : str=tree[x].str;
1356 : else
1357 : {
1358 4423577 : if (nb==2)
1359 357256 : str=tree[arg[1]].str+tree[arg[1]].len;
1360 4066321 : else if (nb==1)
1361 4065323 : str=tree[arg[1]].str;
1362 : else
1363 998 : str=tree[n].str;
1364 4430005 : while(*str==')') str++;
1365 : }
1366 4627859 : if (tree[n].f==Fassign)
1367 : {
1368 0 : nb=2; lnc=2; lnl=2; arg=mkvecsmall2(x,y);
1369 : }
1370 4627859 : else if (is_func_named(ep,"if"))
1371 : {
1372 4844 : if (nb>=4)
1373 112 : ep=is_entry("_multi_if");
1374 4732 : else if (mode==Gvoid)
1375 3029 : ep=is_entry("_void_if");
1376 : }
1377 4623015 : 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 3680084 : return;
1383 : }
1384 4622910 : 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 4622897 : 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 4622891 : else if (is_func_named(ep,"my"))
1399 : {
1400 3379 : compilemy(arg, str, 0);
1401 3379 : compilecast(n,Gvoid,mode);
1402 3379 : set_avma(ltop);
1403 3379 : return;
1404 : }
1405 4619512 : 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 4619484 : 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 4619443 : 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 4619437 : 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 4619430 : else if (is_func_named(ep,"O"))
1453 : {
1454 4781 : if (nb!=1)
1455 0 : compile_err("wrong number of arguments", tree[n].str+tree[n].len-1);
1456 4781 : ep=is_entry("O(_^_)");
1457 4781 : if (tree[arg[1]].f==Ffunction && tree[arg[1]].x==OPpow)
1458 : {
1459 3619 : arg = listtogen(tree[arg[1]].y,Flistarg);
1460 3619 : nb = lg(arg)-1;
1461 3619 : lnc = first_safe_arg(arg,COsafelex|COsafedyn);
1462 3619 : lnl = first_safe_arg(arg,COsafelex);
1463 : }
1464 : }
1465 4614649 : else if (x==OPn && tree[y].f==Fsmall)
1466 : {
1467 3672012 : set_avma(ltop);
1468 3672012 : compilesmall(y, -tree[y].x, mode);
1469 3672012 : return;
1470 : }
1471 942637 : else if (x==OPtrans && tree[y].f==Fvec)
1472 : {
1473 4487 : set_avma(ltop);
1474 4487 : compilevec(y, mode, OCcol);
1475 4487 : return;
1476 938150 : } 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 938143 : else if (x==OPpow && nb==2)
1484 70989 : {
1485 70989 : long a = arg[2];
1486 70989 : if (tree[a].f==Fsmall)
1487 : {
1488 66303 : if(tree[a].x==2) { nb--; ep=is_entry("sqr"); }
1489 47609 : else ep=is_entry("_^s");
1490 : }
1491 4686 : else if (tree[a].f == Ffunction && tree[a].x == OPn)
1492 : {
1493 1309 : long ay = tree[a].y;
1494 1309 : if (tree[ay].f==Fsmall)
1495 : {
1496 1162 : if (tree[ay].x==1) {nb--; ep=is_entry("_inv"); }
1497 784 : else ep=is_entry("_^s");
1498 : }
1499 : }
1500 : }
1501 867154 : else if (x==OPcat)
1502 0 : compile_err("expected character: ',' or ')' instead of",
1503 0 : tree[arg[1]].str+tree[arg[1]].len);
1504 947775 : p=ep->code;
1505 947775 : if (!ep->value)
1506 0 : compile_err("unknown function",tree[n].str);
1507 947775 : nbopcodes = s_opcode.n;
1508 947775 : ret_op = get_ret_type(&p, ep->arity, &ret_typ, &ret_flag);
1509 947775 : j=1;
1510 947775 : if (*p)
1511 : {
1512 938608 : q=p;
1513 2469191 : while((mod=parseproto(&p,&c,tree[n].str))!=PPend)
1514 : {
1515 1530625 : if (j<=nb && tree[arg[j]].f!=Fnoarg
1516 1421651 : && (mod==PPdefault || mod==PPdefaultmulti))
1517 67198 : mod=PPstd;
1518 1530625 : switch(mod)
1519 : {
1520 1406876 : case PPstd:
1521 1406876 : if (j>nb) compile_err("too few arguments", tree[n].str+tree[n].len-1);
1522 1406876 : if (c!='I' && c!='E' && c!='J')
1523 : {
1524 1386936 : long x = tree[arg[j]].x, f = tree[arg[j]].f;
1525 1386936 : if (f==Fnoarg)
1526 0 : compile_err("missing mandatory argument", tree[arg[j]].str);
1527 1386936 : if (f==Fseq)
1528 0 : compile_err("unexpected ';'", tree[x].str+tree[x].len);
1529 : }
1530 1406876 : switch(c)
1531 : {
1532 1289381 : case 'G':
1533 1289381 : compilenode(arg[j],Ggen,j>=lnl?(j>=lnc?FLnocopy:FLnocopylex):0);
1534 1289381 : j++;
1535 1289381 : 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 74651 : compilenode(arg[j++],Gsmall,0);
1571 74644 : break;
1572 207 : case 'U':
1573 207 : compilenode(arg[j++],Gusmall,0);
1574 200 : break;
1575 3863 : case 'n':
1576 3863 : compilenode(arg[j++],Gvar,0);
1577 3856 : break;
1578 2308 : case '&': case '*':
1579 : {
1580 2308 : long vn, a=arg[j++];
1581 : entree *ep;
1582 2308 : if (c=='&')
1583 : {
1584 1533 : if (tree[a].f!=Frefarg)
1585 0 : compile_err("expected character: '&'", tree[a].str);
1586 1533 : a=tree[a].x;
1587 : }
1588 2308 : a=detag(a);
1589 2308 : ep=getlvalue(a);
1590 2308 : vn=getmvar(ep);
1591 2308 : if (tree[a].f==Fentry)
1592 : {
1593 2105 : if (vn)
1594 : {
1595 516 : access_push(vn);
1596 516 : op_push(OCsimpleptrlex, vn,n);
1597 : }
1598 : else
1599 1589 : op_push(OCsimpleptrdyn, (long)ep,n);
1600 : }
1601 : else
1602 : {
1603 203 : compilenewptr(vn, ep, a);
1604 203 : compilelvalue(a);
1605 203 : op_push(OCpushptr, 0, a);
1606 : }
1607 2308 : nbpointers++;
1608 2308 : break;
1609 : }
1610 19940 : case 'I':
1611 : case 'E':
1612 : case 'J':
1613 : {
1614 19940 : long a = arg[j++];
1615 19940 : GEN d = compilefuncinline(n, c, a, flag, is_func_named(ep,"if"), lev, ev);
1616 19940 : op_push(OCpushgen, data_push(d), a);
1617 19940 : if (lg(d)==8) op_push(OCsaveframe,FLsurvive,n);
1618 19940 : break;
1619 : }
1620 5389 : case 'V':
1621 : {
1622 5389 : long a = arg[j++];
1623 5389 : (void)getvar(a);
1624 5382 : ev[lev++] = a;
1625 5382 : break;
1626 : }
1627 6805 : case '=':
1628 : {
1629 6805 : long a = arg[j++];
1630 6805 : ev[lev++] = tree[a].x;
1631 6805 : compilenode(tree[a].y, Ggen, FLnocopy);
1632 : }
1633 6805 : break;
1634 1111 : case 'r':
1635 : {
1636 1111 : long a=arg[j++];
1637 1111 : if (tree[a].f==Fentry)
1638 : {
1639 1032 : op_push(OCpushgen, data_push(strntoGENstr(tree[tree[a].x].str,
1640 1032 : tree[tree[a].x].len)),n);
1641 1032 : op_push(OCtostr, -1,n);
1642 : }
1643 : else
1644 : {
1645 79 : compilenode(a,Ggen,FLnocopy);
1646 79 : op_push(OCtostr, -1,n);
1647 : }
1648 1111 : break;
1649 : }
1650 2738 : case 's':
1651 : {
1652 2738 : long a = arg[j++];
1653 2738 : GEN g = cattovec(a, OPcat);
1654 2738 : long l, nb = lg(g)-1;
1655 2738 : if (nb==1)
1656 : {
1657 2668 : compilenode(g[1], Ggen, FLnocopy);
1658 2668 : 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 2738 : 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 1406834 : break;
1678 33508 : case PPauto:
1679 33508 : switch(c)
1680 : {
1681 29234 : case 'p':
1682 29234 : op_push(OCprecreal,0,n);
1683 29234 : break;
1684 4221 : case 'b':
1685 4221 : op_push(OCbitprecreal,0,n);
1686 4221 : 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 33508 : break;
1701 43619 : case PPdefault:
1702 43619 : j++;
1703 43619 : switch(c)
1704 : {
1705 33405 : case 'G':
1706 : case '&':
1707 : case 'E':
1708 : case 'I':
1709 : case 'r':
1710 : case 's':
1711 33405 : op_push(OCpushlong,0,n);
1712 33405 : break;
1713 8955 : case 'n':
1714 8955 : op_push(OCpushlong,-1,n);
1715 8955 : break;
1716 916 : case 'V':
1717 916 : ev[lev++] = -1;
1718 916 : 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 43619 : break;
1727 31401 : case PPdefaultmulti:
1728 31401 : j++;
1729 31401 : switch(c)
1730 : {
1731 0 : case 'G':
1732 0 : op_push(OCpushstoi,strtol(q+1,NULL,10),n);
1733 0 : break;
1734 31284 : case 'L':
1735 : case 'M':
1736 31284 : op_push(OCpushlong,strtol(q+1,NULL,10),n);
1737 31284 : 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 31401 : break;
1751 15221 : case PPstar:
1752 15221 : switch(c)
1753 : {
1754 112 : case 'E':
1755 : {
1756 112 : long k, n=nb+1-j;
1757 112 : GEN g=cgetg(n+1,t_VEC);
1758 112 : int ismif = is_func_named(ep,"_multi_if");
1759 574 : for(k=1; k<=n; k++)
1760 528 : gel(g, k) = compilefuncinline(n, c, arg[j+k-1], flag,
1761 462 : ismif && (k==n || odd(k)), lev, ev);
1762 112 : op_push(OCpushgen, data_push(g), arg[j]);
1763 112 : j=nb+1;
1764 112 : break;
1765 : }
1766 15109 : case 's':
1767 : {
1768 15109 : long n=nb+1-j;
1769 : long k,l,l1,m;
1770 15109 : GEN g=cgetg(n+1,t_VEC);
1771 36463 : for(l1=0,k=1;k<=n;k++)
1772 : {
1773 21354 : gel(g,k)=cattovec(arg[j+k-1],OPcat);
1774 21354 : l1+=lg(gel(g,k))-1;
1775 : }
1776 15109 : op_push_loc(OCvec, l1+1, str);
1777 36463 : for(m=1,k=1;k<=n;k++)
1778 42743 : for(l=1;l<lg(gel(g,k));l++,m++)
1779 : {
1780 21389 : compilenode(mael(g,k,l),Ggen,FLsurvive);
1781 21389 : op_push(OCstackgen,m,mael(g,k,l));
1782 : }
1783 15109 : op_push_loc(OCpop, 1, str);
1784 15109 : j=nb+1;
1785 15109 : 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 15221 : break;
1792 0 : default:
1793 0 : pari_err_BUG("compilefunc [unknown PPproto]");
1794 : }
1795 1530583 : q=p;
1796 : }
1797 : }
1798 947733 : if (j<=nb)
1799 0 : compile_err("too many arguments",tree[arg[j]].str);
1800 947733 : op_push_loc(ret_op, (long) ep, str);
1801 947733 : if (mode==Ggen && (ret_flag&FLnocopy) && !(flag&FLnocopy))
1802 10681 : op_push_loc(OCcopy,0,str);
1803 947733 : if (ret_typ==Ggen && nbpointers==0 && s_opcode.n>nbopcodes+128)
1804 : {
1805 2975 : op_insert_loc(nbopcodes,OCavma,0,str);
1806 2975 : op_push_loc(OCgc,0,str);
1807 : }
1808 947733 : compilecast(n,ret_typ,mode);
1809 947733 : if (nbpointers) op_push_loc(OCendptr,nbpointers, str);
1810 947733 : set_avma(ltop);
1811 : }
1812 :
1813 : static void
1814 8018293 : genclosurectx(const char *loc, long nbdata)
1815 : {
1816 : long i;
1817 8018293 : GEN vep = cgetg(nbdata+1,t_VECSMALL);
1818 28440636 : for(i = 1; i <= nbdata; i++)
1819 : {
1820 20422351 : vep[i] = 0;
1821 20422351 : op_push_loc(OCpushlex,-i,loc);
1822 : }
1823 8018285 : frame_push(vep);
1824 8018360 : }
1825 :
1826 : static GEN
1827 8029028 : genclosure(entree *ep, const char *loc, long nbdata, int check)
1828 : {
1829 : struct codepos pos;
1830 8029028 : long nb=0;
1831 8029028 : const char *code=ep->code,*p,*q;
1832 : char c;
1833 : GEN text;
1834 8029028 : long index=ep->arity;
1835 8029028 : long arity=0, maskarg=0, maskarg0=0, stop=0, dovararg=0;
1836 : PPproto mod;
1837 : Gtype ret_typ;
1838 : long ret_flag;
1839 8029028 : op_code ret_op=get_ret_type(&code,ep->arity,&ret_typ,&ret_flag);
1840 8028990 : p=code;
1841 36480361 : while ((mod=parseproto(&p,&c,NULL))!=PPend)
1842 : {
1843 28451371 : if (mod==PPauto)
1844 2017 : stop=1;
1845 : else
1846 : {
1847 28449354 : if (stop) return NULL;
1848 28449354 : if (c=='V') continue;
1849 28449354 : maskarg<<=1; maskarg0<<=1; arity++;
1850 28449354 : switch(mod)
1851 : {
1852 28448134 : case PPstd:
1853 28448134 : maskarg|=1L;
1854 28448134 : break;
1855 489 : case PPdefault:
1856 489 : switch(c)
1857 : {
1858 28 : case '&':
1859 : case 'E':
1860 : case 'I':
1861 28 : maskarg0|=1L;
1862 28 : break;
1863 : }
1864 489 : break;
1865 731 : default:
1866 731 : break;
1867 : }
1868 : }
1869 : }
1870 8028880 : if (check && EpSTATIC(ep) && maskarg==0)
1871 8803 : return gen_0;
1872 8020077 : getcodepos(&pos);
1873 8020123 : dbgstart = loc;
1874 8020123 : if (nbdata > arity)
1875 0 : pari_err(e_MISC,"too many parameters for closure `%s'", ep->name);
1876 8020123 : if (nbdata) genclosurectx(loc, nbdata);
1877 8020176 : text = strtoGENstr(ep->name);
1878 8020134 : arity -= nbdata;
1879 8020134 : if (maskarg) op_push_loc(OCcheckargs,maskarg,loc);
1880 8020077 : if (maskarg0) op_push_loc(OCcheckargs0,maskarg0,loc);
1881 8020077 : p=code;
1882 36469437 : while ((mod=parseproto(&p,&c,NULL))!=PPend)
1883 : {
1884 28449326 : switch(mod)
1885 : {
1886 659 : case PPauto:
1887 659 : switch(c)
1888 : {
1889 659 : case 'p':
1890 659 : op_push_loc(OCprecreal,0,loc);
1891 659 : 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 34 : 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 28449360 : break;
1910 : }
1911 : }
1912 8020083 : q = p = code;
1913 36469413 : while ((mod=parseproto(&p,&c,NULL))!=PPend)
1914 : {
1915 28449330 : switch(mod)
1916 : {
1917 28447892 : case PPstd:
1918 28447892 : switch(c)
1919 : {
1920 28418883 : case 'G':
1921 28418883 : break;
1922 17628 : case 'M':
1923 : case 'L':
1924 17628 : op_push_loc(OCitos,-index,loc);
1925 17628 : break;
1926 11343 : case 'U':
1927 11343 : op_push_loc(OCitou,-index,loc);
1928 11343 : 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 28447892 : break;
1944 659 : case PPauto:
1945 659 : break;
1946 419 : case PPdefault:
1947 419 : switch(c)
1948 : {
1949 223 : case 'G':
1950 : case '&':
1951 : case 'E':
1952 : case 'I':
1953 : case 'V':
1954 223 : 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 419 : 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 28449330 : index--;
2013 28449330 : q = p;
2014 : }
2015 8020030 : op_push_loc(ret_op, (long) ep, loc);
2016 8020088 : if (ret_flag==FLnocopy) op_push_loc(OCcopy,0,loc);
2017 8020088 : compilecast_loc(ret_typ, Ggen, loc);
2018 8020079 : if (dovararg) nb|=VARARGBITS;
2019 8020079 : return getfunction(&pos,nb+arity,nbdata,text,0);
2020 : }
2021 :
2022 : GEN
2023 8016691 : snm_closure(entree *ep, GEN data)
2024 : {
2025 8016691 : long i, n = data ? lg(data)-1: 0;
2026 8016691 : GEN C = genclosure(ep,ep->name,n,0);
2027 28434276 : for(i = 1; i <= n; i++) gmael(C,7,i) = gel(data,i);
2028 8016667 : 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 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 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 10503 : closurefunc(entree *ep, long n, long mode)
2093 : {
2094 10503 : pari_sp ltop=avma;
2095 : GEN C;
2096 10503 : if (!ep->value) compile_err("unknown function",tree[n].str);
2097 10503 : C = genclosure(ep,tree[n].str,0,1);
2098 10503 : if (!C) compile_err("sorry, closure not implemented",tree[n].str);
2099 10503 : if (C==gen_0)
2100 : {
2101 8803 : compilefunc(ep,n,mode,0);
2102 8803 : return;
2103 : }
2104 1700 : op_push(OCpushgen, data_push(C), n);
2105 1700 : compilecast(n,Gclosure,mode);
2106 1700 : set_avma(ltop);
2107 : }
2108 :
2109 : static void
2110 14862 : compileseq(long n, int mode, long flag)
2111 : {
2112 14862 : pari_sp av = avma;
2113 14862 : GEN L = listtogen(n, Fseq);
2114 14862 : long i, l = lg(L)-1;
2115 47412 : for(i = 1; i < l; i++)
2116 32550 : compilenode(L[i],Gvoid,0);
2117 14862 : compilenode(L[l],mode,flag&(FLreturn|FLsurvive));
2118 14862 : set_avma(av);
2119 14862 : }
2120 :
2121 : static void
2122 18631861 : compilenode(long n, int mode, long flag)
2123 : {
2124 : long x,y;
2125 : #ifdef STACK_CHECK
2126 18631861 : if (PARI_stack_limit && (void*) &x <= PARI_stack_limit)
2127 0 : pari_err(e_MISC, "expression nested too deeply");
2128 : #endif
2129 18631861 : if (n<0) pari_err_BUG("compilenode");
2130 18631861 : x=tree[n].x;
2131 18631861 : y=tree[n].y;
2132 :
2133 18631861 : switch(tree[n].f)
2134 : {
2135 14862 : case Fseq:
2136 14862 : compileseq(n, mode, flag);
2137 18631798 : return;
2138 13491 : case Fmatcoeff:
2139 13491 : compilematcoeff(n,mode);
2140 13484 : if (mode==Ggen && !(flag&FLnocopy))
2141 4255 : op_push(OCcopy,0,n);
2142 13484 : return;
2143 45172 : case Fassign:
2144 45172 : x = detag(x);
2145 45172 : if (tree[x].f==Fvec && tree[x].x>=0)
2146 795 : {
2147 795 : GEN vars = listtogen(tree[x].x,Fmatrixelts);
2148 795 : long i, l = lg(vars)-1, d = mode==Gvoid? l-1: l;
2149 795 : compilenode(y,Ggen,mode==Gvoid?0:flag&FLsurvive);
2150 2483 : for (i=1; i<=l; i++)
2151 1688 : if (tree[vars[i]].f==Fnoarg) d--;
2152 795 : if (d) op_push(OCdup, d, x);
2153 2483 : for(i=1; i<=l; i++)
2154 1688 : if (tree[vars[i]].f!=Fnoarg)
2155 : {
2156 1674 : long a = detag(vars[i]);
2157 1674 : entree *ep=getlvalue(a);
2158 1674 : long vn=getmvar(ep);
2159 1674 : op_push(OCpushlong,i,a);
2160 1674 : op_push(OCcompo1,Ggen,a);
2161 1674 : if (tree[a].f==Fentry)
2162 1667 : 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 795 : if (mode!=Gvoid)
2171 459 : compilecast(n,Ggen,mode);
2172 : }
2173 : else
2174 : {
2175 44377 : entree *ep=getlvalue(x);
2176 44377 : long vn=getmvar(ep);
2177 44377 : if (tree[x].f!=Fentry)
2178 : {
2179 630 : compilenewptr(vn,ep,n);
2180 630 : compilelvalue(x);
2181 : }
2182 44377 : compilenode(y,Ggen,mode==Gvoid?FLnocopy:flag&FLsurvive);
2183 44377 : if (mode!=Gvoid)
2184 29475 : op_push(OCdup,1,n);
2185 44377 : if (tree[x].f==Fentry)
2186 43747 : compilestore(vn,ep,n);
2187 : else
2188 630 : op_push(OCstoreptr,0,x);
2189 44377 : if (mode!=Gvoid)
2190 29475 : compilecast(n,Ggen,mode);
2191 : }
2192 45172 : return;
2193 1729333 : case Fconst:
2194 : {
2195 1729333 : pari_sp ltop=avma;
2196 1729333 : if (tree[n].x!=CSTquote)
2197 : {
2198 1725620 : if (mode==Gvoid) return;
2199 1725620 : if (mode==Gvar) compile_varerr(tree[n].str);
2200 : }
2201 1729333 : if (mode==Gsmall) L_compile_err(tree[n].str);
2202 1729333 : if (mode==Gusmall && tree[n].x != CSTint) U_compile_err(tree[n].str);
2203 1729326 : switch(tree[n].x)
2204 : {
2205 5513 : case CSTreal:
2206 5513 : op_push(OCpushreal, data_push(strntoGENstr(tree[n].str,tree[n].len)),n);
2207 5513 : break;
2208 839894 : case CSTint:
2209 839894 : op_push(OCpushgen, data_push(strtoi((char*)tree[n].str)),n);
2210 839894 : compilecast(n,Ggen, mode);
2211 839894 : break;
2212 880206 : case CSTstr:
2213 880206 : op_push(OCpushgen, data_push(strntoGENexp(tree[n].str,tree[n].len)),n);
2214 880206 : break;
2215 3713 : case CSTquote:
2216 : { /* skip ' */
2217 3713 : entree *ep = fetch_entry_raw(tree[n].str+1,tree[n].len-1);
2218 3713 : if (EpSTATIC(ep)) compile_varerr(tree[n].str+1);
2219 3713 : op_push(OCpushvar, (long)ep,n);
2220 3713 : compilecast(n,Ggen, mode);
2221 3713 : break;
2222 : }
2223 0 : default:
2224 0 : pari_err_BUG("compilenode, unsupported constant");
2225 : }
2226 1729326 : set_avma(ltop);
2227 1729326 : return;
2228 : }
2229 7428967 : case Fsmall:
2230 7428967 : compilesmall(n, x, mode);
2231 7428960 : return;
2232 4458768 : case Fvec:
2233 4458768 : compilevec(n, mode, OCvec);
2234 4458768 : return;
2235 9653 : case Fmat:
2236 9653 : compilemat(n, mode);
2237 9653 : 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 279819 : case Fentry:
2245 : {
2246 279819 : entree *ep=getentry(n);
2247 279819 : long vn=getmvar(ep);
2248 279819 : if (vn)
2249 : {
2250 72215 : access_push(vn);
2251 72215 : op_push(OCpushlex,(long)vn,n);
2252 72215 : addcopy(n,mode,flag,FLnocopy|FLnocopylex);
2253 72215 : compilecast(n,Ggen,mode);
2254 : }
2255 207604 : else if (ep->valence==EpVAR || ep->valence==EpNEW)
2256 : {
2257 197101 : if (DEBUGLEVEL && mode==Gvoid)
2258 0 : pari_warn(warner,"statement with no effect: `%s'",ep->name);
2259 197101 : op_push(OCpushdyn,(long)ep,n);
2260 197101 : addcopy(n,mode,flag,FLnocopy);
2261 197101 : compilecast(n,Ggen,mode);
2262 : }
2263 : else
2264 10503 : closurefunc(ep,n,mode);
2265 279819 : return;
2266 : }
2267 4641941 : case Ffunction:
2268 : {
2269 4641941 : entree *ep=getfunc(n);
2270 4641941 : if (getmvar(ep) || EpVALENCE(ep)==EpVAR || EpVALENCE(ep)==EpNEW)
2271 : {
2272 22885 : if (tree[n].x<OPnboperator) /* should not happen */
2273 0 : compile_err("operator unknown",tree[n].str);
2274 22885 : compilecall(n,mode,ep);
2275 : }
2276 : else
2277 4619056 : compilefunc(ep,n,mode,flag);
2278 4641899 : return;
2279 : }
2280 329 : case Fcall:
2281 329 : compilecall(n,mode,NULL);
2282 329 : return;
2283 9239 : case Flambda:
2284 : {
2285 9239 : pari_sp ltop=avma;
2286 : struct codepos pos;
2287 9239 : GEN arg=listtogen(x,Flistarg);
2288 9239 : long nb, lgarg, nbmvar, dovararg=0, gap;
2289 9239 : long strict = GP_DATA->strictargs;
2290 9239 : GEN vep = cgetg_copy(arg, &lgarg);
2291 9239 : GEN text=cgetg(3,t_VEC);
2292 9239 : gel(text,1)=strntoGENstr(tree[x].str,tree[x].len);
2293 9239 : 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 9239 : gel(text,2)=strntoGENstr(tree[y].str,tree[y].len);
2297 9239 : getcodepos(&pos);
2298 9239 : dbgstart=tree[x].str+tree[x].len;
2299 9239 : gap = tree[y].str-dbgstart;
2300 9239 : nbmvar = nblex;
2301 9239 : ctxmvar(nbmvar);
2302 9239 : nb = lgarg-1;
2303 9239 : if (nb)
2304 : {
2305 : long i;
2306 13394 : for(i=1;i<=nb;i++)
2307 : {
2308 8225 : long a = arg[i], f = tree[a].f;
2309 8225 : if (i==nb && f==Fvararg)
2310 : {
2311 21 : dovararg=1;
2312 21 : vep[i]=(long)getvar(tree[a].x);
2313 : }
2314 : else
2315 8204 : vep[i]=(long)getvar(f==Fassign||f==Findarg?tree[a].x:a);
2316 8225 : var_push(NULL,Lmy);
2317 : }
2318 5169 : checkdups(arg,vep);
2319 5169 : op_push(OCgetargs,nb,x);
2320 5169 : access_push(lg(vep)-1);
2321 5169 : frame_push(vep);
2322 13394 : for (i=1;i<=nb;i++)
2323 : {
2324 8225 : long a = arg[i], f = tree[a].f;
2325 8225 : long y = tree[a].y;
2326 8225 : 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 7868 : } else if (f==Findarg)
2340 84 : op_push(OCsetref, -nb+i-1, a);
2341 8225 : localvars[s_lvar.n-nb+i-1].ep=(entree*)vep[i];
2342 : }
2343 : }
2344 9239 : if (strict)
2345 21 : op_push(OCcheckuserargs,nb,x);
2346 9239 : dbgstart=tree[y].str;
2347 9239 : if (y>=0 && tree[y].f!=Fnoarg)
2348 9239 : compilenode(y,Ggen,FLsurvive|FLreturn);
2349 : else
2350 0 : compilecast(n,Gvoid,Ggen);
2351 9239 : if (dovararg) nb|=VARARGBITS;
2352 9239 : op_push(OCpushgen, data_push(getfunction(&pos,nb,nbmvar,text,gap)),n);
2353 9239 : if (nbmvar) op_push(OCsaveframe,!!(flag&FLsurvive),n);
2354 9239 : compilecast(n, Gclosure, mode);
2355 9239 : set_avma(ltop);
2356 9239 : 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 934853 : gp_closure(long n)
2375 : {
2376 : struct codepos pos;
2377 934853 : getcodepos(&pos);
2378 934853 : dbgstart=tree[n].str;
2379 934853 : compilenode(n,Ggen,FLsurvive|FLreturn);
2380 934811 : return getfunction(&pos,0,0,strntoGENstr(tree[n].str,tree[n].len),0);
2381 : }
2382 :
2383 : GEN
2384 112 : closure_derivn(GEN G, long n)
2385 : {
2386 112 : pari_sp ltop = avma;
2387 : struct codepos pos;
2388 112 : long arity = closure_arity(G);
2389 : const char *code;
2390 : GEN t, text;
2391 :
2392 112 : if (arity == 0 || closure_is_variadic(G)) pari_err_TYPE("derivfun",G);
2393 112 : t = closure_get_text(G);
2394 112 : code = GSTR((typ(t) == t_STR)? t: GENtoGENstr(G));
2395 112 : 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 63 : text = cgetg(1+nchar2nlong(4+strlen(code)),t_STR);
2403 63 : sprintf(GSTR(text), (typ(t) == t_STR)? "%s'": "(%s)'",code);
2404 : }
2405 112 : getcodepos(&pos);
2406 112 : dbgstart = code;
2407 112 : op_push_loc(OCpackargs, arity, code);
2408 112 : op_push_loc(OCpushgen, data_push(G), code);
2409 112 : op_push_loc(OCpushlong, n, code);
2410 112 : op_push_loc(OCprecreal, 0, code);
2411 112 : op_push_loc(OCcallgen, (long)is_entry("_derivfun"), code);
2412 112 : 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 4560517 : vec_optimize(GEN arg)
2421 : {
2422 4560517 : long fl = COsafelex|COsafedyn;
2423 : long i;
2424 20740545 : for (i=1; i<lg(arg); i++)
2425 : {
2426 16180035 : optimizenode(arg[i]);
2427 16180028 : fl &= tree[arg[i]].flags;
2428 : }
2429 4560510 : return fl;
2430 : }
2431 :
2432 : static void
2433 4464477 : optimizevec(long n)
2434 : {
2435 4464477 : pari_sp ltop=avma;
2436 4464477 : long x = tree[n].x;
2437 4464477 : GEN arg = listtogen(x, Fmatrixelts);
2438 4464477 : tree[n].flags = vec_optimize(arg);
2439 4464477 : set_avma(ltop);
2440 4464477 : }
2441 :
2442 : static void
2443 9653 : optimizemat(long n)
2444 : {
2445 9653 : pari_sp ltop = avma;
2446 9653 : long x = tree[n].x;
2447 : long i;
2448 9653 : GEN line = listtogen(x,Fmatrixlines);
2449 9653 : long fl = COsafelex|COsafedyn;
2450 47957 : for(i=1;i<lg(line);i++)
2451 : {
2452 38304 : GEN col=listtogen(line[i],Fmatrixelts);
2453 38304 : fl &= vec_optimize(col);
2454 : }
2455 9653 : set_avma(ltop); tree[n].flags=fl;
2456 9653 : }
2457 :
2458 : static void
2459 14485 : optimizematcoeff(long n)
2460 : {
2461 14485 : long x=tree[n].x;
2462 14485 : long y=tree[n].y;
2463 14485 : long yx=tree[y].x;
2464 14485 : long yy=tree[y].y;
2465 : long fl;
2466 14485 : optimizenode(x);
2467 14485 : optimizenode(yx);
2468 14485 : fl=tree[x].flags&tree[yx].flags;
2469 14485 : if (yy>=0)
2470 : {
2471 1757 : optimizenode(yy);
2472 1757 : fl&=tree[yy].flags;
2473 : }
2474 14485 : tree[n].flags=fl;
2475 14485 : }
2476 :
2477 : static void
2478 4623053 : optimizefunc(entree *ep, long n)
2479 : {
2480 4623053 : pari_sp av=avma;
2481 : long j;
2482 4623053 : long x=tree[n].x;
2483 4623053 : long y=tree[n].y;
2484 : Gtype t;
2485 : PPproto mod;
2486 4623053 : long fl=COsafelex|COsafedyn;
2487 : const char *p;
2488 : char c;
2489 4623053 : GEN arg = listtogen(y,Flistarg);
2490 4623053 : long nb=lg(arg)-1, ret_flag;
2491 4623053 : if (is_func_named(ep,"if") && nb>=4)
2492 112 : ep=is_entry("_multi_if");
2493 4623053 : p = ep->code;
2494 4623053 : if (!p)
2495 3480 : fl=0;
2496 : else
2497 4619573 : (void) get_ret_type(&p, 2, &t, &ret_flag);
2498 4623053 : if (p && *p)
2499 : {
2500 4612630 : j=1;
2501 9906292 : while((mod=parseproto(&p,&c,tree[n].str))!=PPend)
2502 : {
2503 5293690 : if (j<=nb && tree[arg[j]].f!=Fnoarg
2504 5116550 : && (mod==PPdefault || mod==PPdefaultmulti))
2505 63684 : mod=PPstd;
2506 5293690 : switch(mod)
2507 : {
2508 5101810 : case PPstd:
2509 5101810 : if (j>nb) compile_err("too few arguments", tree[n].str+tree[n].len-1);
2510 5101782 : if (tree[arg[j]].f==Fnoarg && c!='I' && c!='E')
2511 0 : compile_err("missing mandatory argument", tree[arg[j]].str);
2512 5101782 : switch(c)
2513 : {
2514 5063022 : case 'G':
2515 : case 'n':
2516 : case 'M':
2517 : case 'L':
2518 : case 'U':
2519 : case 'P':
2520 5063022 : optimizenode(arg[j]);
2521 5063022 : fl&=tree[arg[j++]].flags;
2522 5063022 : break;
2523 19947 : case 'I':
2524 : case 'E':
2525 : case 'J':
2526 19947 : optimizenode(arg[j]);
2527 19947 : fl&=tree[arg[j]].flags;
2528 19947 : tree[arg[j++]].flags=COsafelex|COsafedyn;
2529 19947 : break;
2530 2308 : case '&': case '*':
2531 : {
2532 2308 : long a=arg[j];
2533 2308 : if (c=='&')
2534 : {
2535 1533 : if (tree[a].f!=Frefarg)
2536 0 : compile_err("expected character: '&'", tree[a].str);
2537 1533 : a=tree[a].x;
2538 : }
2539 2308 : optimizenode(a);
2540 2308 : tree[arg[j++]].flags=COsafelex|COsafedyn;
2541 2308 : fl=0;
2542 2308 : 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 6500 : case 'V':
2552 : case 'r':
2553 6500 : tree[arg[j++]].flags=COsafelex|COsafedyn;
2554 6500 : break;
2555 6805 : case '=':
2556 : {
2557 6805 : long a=arg[j++], y=tree[a].y;
2558 6805 : if (tree[a].f!=Fassign)
2559 0 : compile_err("expected character: '=' instead of",
2560 0 : tree[a].str+tree[a].len);
2561 6805 : optimizenode(y);
2562 6805 : fl&=tree[y].flags;
2563 : }
2564 6805 : break;
2565 2738 : case 's':
2566 2738 : fl &= vec_optimize(cattovec(arg[j++], OPcat));
2567 2738 : 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 5101782 : break;
2573 103234 : case PPauto:
2574 103234 : break;
2575 73425 : case PPdefault:
2576 : case PPdefaultmulti:
2577 73425 : if (j<=nb) optimizenode(arg[j++]);
2578 73425 : break;
2579 15221 : case PPstar:
2580 15221 : switch(c)
2581 : {
2582 112 : case 'E':
2583 : {
2584 112 : long n=nb+1-j;
2585 : long k;
2586 574 : for(k=1;k<=n;k++)
2587 : {
2588 462 : optimizenode(arg[j+k-1]);
2589 462 : fl &= tree[arg[j+k-1]].flags;
2590 : }
2591 112 : j=nb+1;
2592 112 : break;
2593 : }
2594 15109 : case 's':
2595 : {
2596 15109 : long n=nb+1-j;
2597 : long k;
2598 36463 : for(k=1;k<=n;k++)
2599 21354 : fl &= vec_optimize(cattovec(arg[j+k-1],OPcat));
2600 15109 : j=nb+1;
2601 15109 : 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 15221 : break;
2608 0 : default:
2609 0 : pari_err_BUG("optimizefun [unknown PPproto]");
2610 : }
2611 : }
2612 4612602 : if (j<=nb)
2613 0 : compile_err("too many arguments",tree[arg[j]].str);
2614 : }
2615 10423 : else (void)vec_optimize(arg);
2616 4623025 : set_avma(av); tree[n].flags=fl;
2617 4623025 : }
2618 :
2619 : static void
2620 23221 : optimizecall(long n)
2621 : {
2622 23221 : pari_sp av=avma;
2623 23221 : long x=tree[n].x;
2624 23221 : long y=tree[n].y;
2625 23221 : GEN arg=listtogen(y,Flistarg);
2626 23221 : optimizenode(x);
2627 23221 : tree[n].flags = COsafelex&tree[x].flags&vec_optimize(arg);
2628 23214 : set_avma(av);
2629 23214 : }
2630 :
2631 : static void
2632 14862 : optimizeseq(long n)
2633 : {
2634 14862 : pari_sp av = avma;
2635 14862 : GEN L = listtogen(n, Fseq);
2636 14862 : long i, l = lg(L)-1, flags=-1L;
2637 62274 : for(i = 1; i <= l; i++)
2638 : {
2639 47412 : optimizenode(L[i]);
2640 47412 : flags &= tree[L[i]].flags;
2641 : }
2642 14862 : set_avma(av);
2643 14862 : tree[n].flags = flags;
2644 14862 : }
2645 :
2646 : void
2647 22453667 : optimizenode(long n)
2648 : {
2649 : long x,y;
2650 : #ifdef STACK_CHECK
2651 22453667 : if (PARI_stack_limit && (void*) &x <= PARI_stack_limit)
2652 0 : pari_err(e_MISC, "expression nested too deeply");
2653 : #endif
2654 22453667 : if (n<0)
2655 0 : pari_err_BUG("optimizenode");
2656 22453667 : x=tree[n].x;
2657 22453667 : y=tree[n].y;
2658 :
2659 22453667 : switch(tree[n].f)
2660 : {
2661 14862 : case Fseq:
2662 14862 : optimizeseq(n);
2663 22373739 : return;
2664 16242 : case Frange:
2665 16242 : optimizenode(x);
2666 16242 : optimizenode(y);
2667 16242 : tree[n].flags=tree[x].flags&tree[y].flags;
2668 16242 : break;
2669 14485 : case Fmatcoeff:
2670 14485 : optimizematcoeff(n);
2671 14485 : break;
2672 49159 : case Fassign:
2673 49159 : optimizenode(x);
2674 49159 : optimizenode(y);
2675 49159 : tree[n].flags=0;
2676 49159 : break;
2677 13229143 : case Fnoarg:
2678 : case Fnorange:
2679 : case Fsmall:
2680 : case Fconst:
2681 : case Fentry:
2682 13229143 : tree[n].flags=COsafelex|COsafedyn;
2683 13229143 : return;
2684 4464477 : case Fvec:
2685 4464477 : optimizevec(n);
2686 4464477 : return;
2687 9653 : case Fmat:
2688 9653 : optimizemat(n);
2689 9653 : 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 4645945 : case Ffunction:
2699 : {
2700 4645945 : entree *ep=getfunc(n);
2701 4645945 : if (EpVALENCE(ep)==EpVAR || EpVALENCE(ep)==EpNEW)
2702 22892 : optimizecall(n);
2703 : else
2704 4623053 : optimizefunc(ep,n);
2705 4645910 : return;
2706 : }
2707 329 : case Fcall:
2708 329 : optimizecall(n);
2709 329 : return;
2710 9239 : case Flambda:
2711 9239 : optimizenode(y);
2712 9239 : tree[n].flags=COsafelex|COsafedyn;
2713 9239 : 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 : }
|
