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 3822357 : translate(const char **src, char *s)
35 : {
36 3822357 : const char *t = *src;
37 30148606 : while (*t)
38 : {
39 30149254 : 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 30148606 : if (*t == '"')
51 : {
52 3822357 : if (t[1] != '"') break;
53 0 : t += 2; continue;
54 : }
55 26326249 : *s++ = *t++;
56 : }
57 3822357 : *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 3822353 : strntoGENexp(const char *str, long len)
79 : {
80 3822353 : long n = nchar2nlong(len-1);
81 3822353 : GEN z = cgetg(1+n, t_STR);
82 3822353 : const char *t = str+1;
83 3822353 : z[n] = 0;
84 3822353 : if (!translate(&t, GSTR(z))) compile_err("run-away string",str);
85 3822353 : 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 372883 : pari_init_compiler(void)
122 : {
123 372883 : pari_stack_init(&s_opcode,sizeof(*opcode),(void **)&opcode);
124 372886 : pari_stack_init(&s_operand,sizeof(*operand),(void **)&operand);
125 372883 : pari_stack_init(&s_accesslex,sizeof(*operand),(void **)&accesslex);
126 372877 : pari_stack_init(&s_data,sizeof(*data),(void **)&data);
127 372878 : pari_stack_init(&s_lvar,sizeof(*localvars),(void **)&localvars);
128 372876 : pari_stack_init(&s_dbginfo,sizeof(*dbginfo),(void **)&dbginfo);
129 372877 : pari_stack_init(&s_frame,sizeof(*frames),(void **)&frames);
130 372878 : offset=-1; nblex=0;
131 372878 : }
132 : void
133 371379 : pari_close_compiler(void)
134 : {
135 371379 : pari_stack_delete(&s_opcode);
136 370316 : pari_stack_delete(&s_operand);
137 368857 : pari_stack_delete(&s_accesslex);
138 367911 : pari_stack_delete(&s_data);
139 367304 : pari_stack_delete(&s_lvar);
140 366793 : pari_stack_delete(&s_dbginfo);
141 366617 : pari_stack_delete(&s_frame);
142 366585 : }
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 10105964 : getcodepos(struct codepos *pos)
153 : {
154 10105964 : pos->opcode=s_opcode.n;
155 10105964 : pos->accesslex=s_accesslex.n;
156 10105964 : pos->data=s_data.n;
157 10105964 : pos->offset=offset;
158 10105964 : pos->nblex=nblex;
159 10105964 : pos->localvars=s_lvar.n;
160 10105964 : pos->dbgstart=dbgstart;
161 10105964 : pos->frames=s_frame.n;
162 10105964 : offset=s_data.n-1;
163 10105964 : }
164 :
165 : void
166 452 : compilestate_reset(void)
167 : {
168 452 : s_opcode.n=0;
169 452 : s_operand.n=0;
170 452 : s_accesslex.n=0;
171 452 : s_dbginfo.n=0;
172 452 : s_data.n=0;
173 452 : s_lvar.n=0;
174 452 : s_frame.n=0;
175 452 : offset=-1;
176 452 : nblex=0;
177 452 : dbgstart=NULL;
178 452 : }
179 :
180 : void
181 1431705 : compilestate_save(struct pari_compilestate *comp)
182 : {
183 1431705 : comp->opcode=s_opcode.n;
184 1431705 : comp->operand=s_operand.n;
185 1431705 : comp->accesslex=s_accesslex.n;
186 1431705 : comp->data=s_data.n;
187 1431705 : comp->offset=offset;
188 1431705 : comp->nblex=nblex;
189 1431705 : comp->localvars=s_lvar.n;
190 1431705 : comp->dbgstart=dbgstart;
191 1431705 : comp->dbginfo=s_dbginfo.n;
192 1431705 : comp->frames=s_frame.n;
193 1431705 : }
194 :
195 : void
196 56422 : compilestate_restore(struct pari_compilestate *comp)
197 : {
198 56422 : s_opcode.n=comp->opcode;
199 56422 : s_operand.n=comp->operand;
200 56422 : s_accesslex.n=comp->accesslex;
201 56422 : s_data.n=comp->data;
202 56422 : offset=comp->offset;
203 56422 : nblex=comp->nblex;
204 56422 : s_lvar.n=comp->localvars;
205 56422 : dbgstart=comp->dbgstart;
206 56422 : s_dbginfo.n=comp->dbginfo;
207 56422 : s_frame.n=comp->frames;
208 56422 : }
209 :
210 : static GEN
211 13966472 : gcopyunclone(GEN x) { GEN y = gcopy(x); gunclone(x); return y; }
212 :
213 : static void
214 116671 : access_push(long x)
215 : {
216 116671 : long a = pari_stack_new(&s_accesslex);
217 116671 : accesslex[a] = x;
218 116671 : }
219 :
220 : static GEN
221 9152098 : genctx(long nbmvar, long paccesslex)
222 : {
223 9152098 : GEN acc = const_vec(nbmvar,gen_1);
224 9152106 : long i, lvl = 1 + nbmvar;
225 9194529 : for (i = paccesslex; i<s_accesslex.n; i++)
226 : {
227 42423 : long a = accesslex[i];
228 42423 : if (a > 0) { lvl+=a; continue; }
229 37201 : a += lvl;
230 37201 : if (a <= 0) pari_err_BUG("genctx");
231 37201 : if (a <= nbmvar)
232 28808 : gel(acc, a) = gen_0;
233 : }
234 9152106 : s_accesslex.n = paccesslex;
235 32920607 : for (i = 1; i<=nbmvar; i++)
236 23768501 : if (signe(gel(acc,i))==0)
237 20947 : access_push(i-nbmvar-1);
238 9152106 : return acc;
239 : }
240 :
241 : static GEN
242 10105876 : getfunction(const struct codepos *pos, long arity, long nbmvar, GEN text,
243 : long gap)
244 : {
245 10105876 : long lop = s_opcode.n+1 - pos->opcode;
246 10105876 : long ldat = s_data.n+1 - pos->data;
247 10105876 : long lfram = s_frame.n+1 - pos->frames;
248 10105876 : 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 10105851 : cl[1] = arity;
254 10105851 : gel(cl,2) = cgetg(nchar2nlong(lop)+1, t_STR);
255 10105811 : gel(cl,3) = op = cgetg(lop, t_VECSMALL);
256 10105813 : gel(cl,4) = dat = cgetg(ldat, t_VEC);
257 10105821 : dbg = cgetg(lop, t_VECSMALL);
258 10105813 : frpc = cgetg(lfram, t_VECSMALL);
259 10105809 : fram = cgetg(lfram, t_VEC);
260 10105822 : gel(cl,5) = mkvec3(dbg, frpc, fram);
261 10105857 : if (text) gel(cl,6) = text;
262 10105857 : s = GSTR(gel(cl,2)) - 1;
263 169664013 : for (i = 1; i < lop; i++)
264 : {
265 159558156 : long j = i+pos->opcode-1;
266 159558156 : s[i] = opcode[j];
267 159558156 : op[i] = operand[j];
268 159558156 : dbg[i] = dbginfo[j] - dbgstart;
269 159558156 : if (dbg[i] < 0) dbg[i] += gap;
270 : }
271 10105857 : s[i] = 0;
272 10105857 : s_opcode.n = pos->opcode;
273 10105857 : s_operand.n = pos->opcode;
274 10105857 : s_dbginfo.n = pos->opcode;
275 10105857 : if (lg(cl)==8)
276 9141003 : gel(cl,7) = genctx(nbmvar, pos->accesslex);
277 964854 : else if (nbmvar==0)
278 953839 : s_accesslex.n = pos->accesslex;
279 : else
280 : {
281 11015 : pari_sp av = avma;
282 11015 : (void) genctx(nbmvar, pos->accesslex);
283 11084 : set_avma(av);
284 : }
285 14910409 : for (i = 1; i < ldat; i++)
286 4804470 : if (data[i+pos->data-1]) gel(dat,i) = gcopyunclone(data[i+pos->data-1]);
287 10105939 : s_data.n = pos->data;
288 10135296 : while (s_lvar.n > pos->localvars && !localvars[s_lvar.n-1].inl)
289 : {
290 29357 : if (localvars[s_lvar.n-1].type==Lmy) nblex--;
291 29357 : s_lvar.n--;
292 : }
293 19268015 : for (i = 1; i < lfram; i++)
294 : {
295 9162013 : long j = i+pos->frames-1;
296 9162013 : frpc[i] = frames[j].pc - pos->opcode+1;
297 9162013 : gel(fram, i) = gcopyunclone(frames[j].frame);
298 : }
299 10106002 : s_frame.n = pos->frames;
300 10106002 : offset = pos->offset;
301 10106002 : dbgstart = pos->dbgstart;
302 10106002 : return cl;
303 : }
304 :
305 : static GEN
306 20422 : getclosure(struct codepos *pos, long nbmvar)
307 : {
308 20422 : return getfunction(pos, 0, nbmvar, NULL, 0);
309 : }
310 :
311 : static void
312 159554794 : op_push_loc(op_code o, long x, const char *loc)
313 : {
314 159554794 : long n=pari_stack_new(&s_opcode);
315 159554758 : long m=pari_stack_new(&s_operand);
316 159554698 : long d=pari_stack_new(&s_dbginfo);
317 159554715 : opcode[n]=o;
318 159554715 : operand[m]=x;
319 159554715 : dbginfo[d]=loc;
320 159554715 : }
321 :
322 : static void
323 115721691 : op_push(op_code o, long x, long n)
324 : {
325 115721691 : op_push_loc(o,x,tree[n].str);
326 115721691 : }
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 4804470 : data_push(GEN x)
348 : {
349 4804470 : long n=pari_stack_new(&s_data);
350 4804470 : data[n] = x?gclone(x):x;
351 4804470 : return n-offset;
352 : }
353 :
354 : static void
355 65870 : var_push(entree *ep, Ltype type)
356 : {
357 65870 : long n=pari_stack_new(&s_lvar);
358 65870 : localvars[n].ep = ep;
359 65870 : localvars[n].inl = 0;
360 65870 : localvars[n].type = type;
361 65870 : if (type == Lmy) nblex++;
362 65870 : }
363 :
364 : static void
365 9162020 : frame_push(GEN x)
366 : {
367 9162020 : long n=pari_stack_new(&s_frame);
368 9162010 : frames[n].pc = s_opcode.n-1;
369 9162010 : frames[n].frame = gclone(x);
370 9162089 : }
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 274575 : addcopy(long n, long mode, long flag, long mask)
485 : {
486 274575 : if (mode==Ggen && !(flag&mask))
487 : {
488 27139 : op_push(OCcopy,0,n);
489 27139 : if (!(flag&FLsurvive) && DEBUGLEVEL)
490 0 : pari_warn(warner,"compiler generates copy for `%.*s'",
491 0 : tree[n].len,tree[n].str);
492 : }
493 274575 : }
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 153699433 : parseproto(char const **q, char *c, const char *str)
501 : {
502 153699433 : char const *p=*q;
503 : long i;
504 153699433 : switch(*p)
505 : {
506 39932760 : case 0:
507 : case '\n':
508 39932760 : return PPend;
509 287923 : case 'D':
510 287923 : switch(p[1])
511 : {
512 195343 : 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 195343 : *c=p[1]; *q=p+2; return PPdefault;
524 92580 : default:
525 560220 : for(i=0;*p && i<2;p++) i+=*p==',';
526 : /* assert(i>=2) because check_proto validated the protototype */
527 92580 : *c=p[-2]; *q=p; return PPdefaultmulti;
528 : }
529 : break;
530 143368 : case 'C':
531 : case 'p':
532 : case 'b':
533 : case 'P':
534 : case 'f':
535 143368 : *c=*p; *q=p+1; return PPauto;
536 1550 : case '&':
537 1550 : *c='*'; *q=p+1; return PPstd;
538 18934 : case 'V':
539 18934 : if (p[1]=='=')
540 : {
541 13734 : if (p[2]!='G')
542 0 : compile_err("function prototype is not supported",str);
543 13734 : *c='='; p+=2;
544 : }
545 : else
546 5200 : *c=*p;
547 18934 : *q=p+1; return PPstd;
548 45882 : case 'E':
549 : case 's':
550 45882 : if (p[1]=='*') { *c=*p++; *q=p+1; return PPstar; }
551 : /*fall through*/
552 : }
553 113283884 : *c=*p; *q=p+1; return PPstd;
554 : }
555 :
556 : static long
557 446578 : detag(long n)
558 : {
559 446578 : while (tree[n].f==Ftag)
560 0 : n=tree[n].x;
561 446578 : return n;
562 : }
563 :
564 : /* return type for GP functions */
565 : static op_code
566 21672164 : get_ret_type(const char **p, long arity, Gtype *t, long *flag)
567 : {
568 21672164 : *flag = 0;
569 21672164 : if (**p == 'v') { (*p)++; *t=Gvoid; return OCcallvoid; }
570 21623227 : else if (**p == 'i') { (*p)++; *t=Gsmall; return OCcallint; }
571 21616430 : else if (**p == 'l') { (*p)++; *t=Gsmall; return OCcalllong; }
572 21590394 : else if (**p == 'u') { (*p)++; *t=Gusmall; return OCcalllong; }
573 21590394 : else if (**p == 'm') { (*p)++; *flag = FLnocopy; }
574 21590394 : *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 27752558 : compilecast_loc(int type, int mode, const char *loc)
590 : {
591 27752558 : if (type==mode) return;
592 15528200 : switch (mode)
593 : {
594 210 : case Gusmall:
595 210 : if (type==Ggen) op_push_loc(OCitou,-1,loc);
596 161 : else if (type==Gvoid) op_push_loc(OCpushlong,0,loc);
597 161 : else if (type!=Gsmall) U_compile_err(loc);
598 210 : break;
599 5227 : case Gsmall:
600 5227 : 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 5220 : break;
604 15509794 : case Ggen:
605 15509794 : if (type==Gsmall) op_push_loc(OCstoi,0,loc);
606 15495333 : else if (type==Gusmall)op_push_loc(OCutoi,0,loc);
607 15495333 : else if (type==Gvoid) op_push_loc(OCpushgnil,0,loc);
608 15509794 : break;
609 8980 : case Gvoid:
610 8980 : op_push_loc(OCpop, 1,loc);
611 8980 : break;
612 3989 : case Gvar:
613 3989 : if (type==Ggen) op_push_loc(OCvarn,-1,loc);
614 7 : else compile_varerr(loc);
615 3982 : break;
616 0 : default:
617 0 : pari_err_BUG("compilecast [unknown type]");
618 : }
619 : }
620 :
621 : static void
622 18613959 : compilecast(long n, int type, int mode) { compilecast_loc(type, mode, tree[n].str); }
623 :
624 : static entree *
625 25263 : fetch_member_raw(const char *s, long len)
626 : {
627 25263 : pari_sp av = avma;
628 25263 : char *t = stack_malloc(len+2);
629 : entree *ep;
630 25263 : t[0] = '_'; strncpy(t+1, s, len); t[++len] = 0; /* prepend '_' */
631 25263 : ep = fetch_entry_raw(t, len);
632 25263 : set_avma(av); return ep;
633 : }
634 : static entree *
635 21933548 : getfunc(long n)
636 : {
637 21933548 : long x=tree[n].x;
638 21933548 : if (tree[x].x==CSTmember) /* str-1 points to '.' */
639 25263 : return do_alias(fetch_member_raw(tree[x].str - 1, tree[x].len + 1));
640 : else
641 21908285 : return do_alias(fetch_entry_raw(tree[x].str, tree[x].len));
642 : }
643 :
644 : static entree *
645 364264 : getentry(long n)
646 : {
647 364264 : n = detag(n);
648 364264 : if (tree[n].f!=Fentry)
649 : {
650 14 : if (tree[n].f==Fseq)
651 0 : compile_err("unexpected character: ';'", tree[tree[n].y].str-1);
652 14 : compile_varerr(tree[n].str);
653 : }
654 364250 : return getfunc(n);
655 : }
656 :
657 : static entree *
658 66042 : getvar(long n)
659 66042 : { return getentry(n); }
660 :
661 : static entree *
662 12956 : getvarvec(long n)
663 : {
664 12956 : n = detag(n);
665 12956 : if (tree[n].f==Fentry) return getentry(n);
666 42 : if (tree[n].f!=Fvec)
667 7 : compile_varerr(tree[n].str);
668 35 : return do_alias(fetch_entry_raw(tree[n].str, tree[n].len));
669 : }
670 :
671 : /* match Fentry that are not actually EpSTATIC functions called without parens*/
672 : static entree *
673 131 : getvardyn(long n)
674 : {
675 131 : entree *ep = getentry(n);
676 131 : if (EpSTATIC(do_alias(ep)))
677 0 : compile_varerr(tree[n].str);
678 131 : return ep;
679 : }
680 :
681 : static long
682 11140471 : getmvar(entree *ep)
683 : {
684 : long i;
685 11140471 : long vn=0;
686 12283098 : for(i=s_lvar.n-1;i>=0;i--)
687 : {
688 1222941 : if(localvars[i].type==Lmy)
689 1222668 : vn--;
690 1222941 : if(localvars[i].ep==ep)
691 80314 : return localvars[i].type==Lmy?vn:0;
692 : }
693 11060157 : return 0;
694 : }
695 :
696 : static void
697 9724 : ctxmvar(long n)
698 : {
699 9724 : pari_sp av=avma;
700 : GEN ctx;
701 : long i;
702 9724 : if (n==0) return;
703 4193 : ctx = cgetg(n+1,t_VECSMALL);
704 67627 : for(n=0, i=0; i<s_lvar.n; i++)
705 63434 : if(localvars[i].type==Lmy)
706 63434 : ctx[++n]=(long)localvars[i].ep;
707 4193 : frame_push(ctx);
708 4193 : set_avma(av);
709 : }
710 :
711 : INLINE int
712 118405402 : is_func_named(entree *ep, const char *s)
713 : {
714 118405402 : return !strcmp(ep->name, s);
715 : }
716 :
717 : INLINE int
718 4259 : is_node_zero(long n)
719 : {
720 4259 : n = detag(n);
721 4259 : return (tree[n].f==Fsmall && tree[n].x==0);
722 : }
723 :
724 : static void
725 39 : str_defproto(const char *p, const char *q, const char *loc)
726 : {
727 39 : long len = p-4-q;
728 39 : if (q[1]!='"' || q[len]!='"')
729 0 : compile_err("default argument must be a string",loc);
730 39 : op_push_loc(OCpushgen,data_push(strntoGENexp(q+1,len)),loc);
731 39 : }
732 :
733 : static long
734 462 : countmatrixelts(long n)
735 : {
736 : long x,i;
737 462 : if (n==-1 || tree[n].f==Fnoarg) return 0;
738 1092 : for(x=n, i=0; tree[x].f==Fmatrixelts; x=tree[x].x)
739 630 : if (tree[tree[x].y].f!=Fnoarg) i++;
740 462 : if (tree[x].f!=Fnoarg) i++;
741 462 : return i;
742 : }
743 :
744 : static long
745 52642257 : countlisttogen(long n, Ffunc f)
746 : {
747 : long x,i;
748 52642257 : if (n==-1 || tree[n].f==Fnoarg) return 0;
749 122027896 : for(x=n, i=0; tree[x].f==f ;x=tree[x].x, i++);
750 49373522 : return i+1;
751 : }
752 :
753 : static GEN
754 52642257 : listtogen(long n, Ffunc f)
755 : {
756 52642257 : long x,i,nb = countlisttogen(n, f);
757 52642257 : GEN z=cgetg(nb+1, t_VECSMALL);
758 52642257 : if (nb)
759 : {
760 122027896 : for (x=n, i = nb-1; i>0; z[i+1]=tree[x].y, x=tree[x].x, i--);
761 49373522 : z[1]=x;
762 : }
763 52642257 : return z;
764 : }
765 :
766 : static long
767 21591122 : first_safe_arg(GEN arg, long mask)
768 : {
769 21591122 : long lnc, l=lg(arg);
770 45788612 : for (lnc=l-1; lnc>0 && (tree[arg[lnc]].flags&mask)==mask; lnc--);
771 21591122 : return lnc;
772 : }
773 :
774 : static void
775 20995 : checkdups(GEN arg, GEN vep)
776 : {
777 20995 : long l=vecsmall_duplicate(vep);
778 20995 : if (l!=0) compile_err("variable declared twice",tree[arg[l]].str);
779 20995 : }
780 :
781 : enum {MAT_range,MAT_std,MAT_line,MAT_column,VEC_std};
782 :
783 : static int
784 15723 : matindex_type(long n)
785 : {
786 15723 : long x = tree[n].x, y = tree[n].y;
787 15723 : long fxx = tree[tree[x].x].f, fxy = tree[tree[x].y].f;
788 15723 : if (y==-1)
789 : {
790 13645 : if (fxy!=Fnorange) return MAT_range;
791 13036 : if (fxx==Fnorange) compile_err("missing index",tree[n].str);
792 13036 : return VEC_std;
793 : }
794 : else
795 : {
796 2078 : long fyx = tree[tree[y].x].f, fyy = tree[tree[y].y].f;
797 2078 : if (fxy!=Fnorange || fyy!=Fnorange) return MAT_range;
798 1903 : if (fxx==Fnorange && fyx==Fnorange)
799 0 : compile_err("missing index",tree[n].str);
800 1903 : if (fxx==Fnorange) return MAT_column;
801 1098 : if (fyx==Fnorange) return MAT_line;
802 832 : return MAT_std;
803 : }
804 : }
805 :
806 : static entree *
807 49671 : getlvalue(long n)
808 : {
809 50679 : while ((tree[n].f==Fmatcoeff && matindex_type(tree[n].y)!=MAT_range) || tree[n].f==Ftag)
810 1008 : n=tree[n].x;
811 49671 : return getvar(n);
812 : }
813 :
814 : INLINE void
815 46047 : compilestore(long vn, entree *ep, long n)
816 : {
817 46047 : if (vn)
818 4772 : op_push(OCstorelex,vn,n);
819 : else
820 : {
821 41275 : if (EpSTATIC(do_alias(ep)))
822 0 : compile_varerr(tree[n].str);
823 41275 : op_push(OCstoredyn,(long)ep,n);
824 : }
825 46047 : }
826 :
827 : INLINE void
828 847 : compilenewptr(long vn, entree *ep, long n)
829 : {
830 847 : if (vn)
831 : {
832 259 : access_push(vn);
833 259 : op_push(OCnewptrlex,vn,n);
834 : }
835 : else
836 588 : op_push(OCnewptrdyn,(long)ep,n);
837 847 : }
838 :
839 : static void
840 1848 : compilelvalue(long n)
841 : {
842 1848 : n = detag(n);
843 1848 : if (tree[n].f==Fentry)
844 847 : return;
845 : else
846 : {
847 1001 : long x = tree[n].x, y = tree[n].y;
848 1001 : long yx = tree[y].x, yy = tree[y].y;
849 1001 : long m = matindex_type(y);
850 1001 : if (m == MAT_range)
851 0 : compile_err("not an lvalue",tree[n].str);
852 1001 : if (m == VEC_std && tree[x].f==Fmatcoeff)
853 : {
854 119 : int mx = matindex_type(tree[x].y);
855 119 : if (mx==MAT_line)
856 : {
857 0 : int xy = tree[x].y, xyx = tree[xy].x;
858 0 : compilelvalue(tree[x].x);
859 0 : compilenode(tree[xyx].x,Gsmall,0);
860 0 : compilenode(tree[yx].x,Gsmall,0);
861 0 : op_push(OCcompo2ptr,0,y);
862 0 : return;
863 : }
864 : }
865 1001 : compilelvalue(x);
866 1001 : switch(m)
867 : {
868 679 : case VEC_std:
869 679 : compilenode(tree[yx].x,Gsmall,0);
870 679 : op_push(OCcompo1ptr,0,y);
871 679 : break;
872 126 : case MAT_std:
873 126 : compilenode(tree[yx].x,Gsmall,0);
874 126 : compilenode(tree[yy].x,Gsmall,0);
875 126 : op_push(OCcompo2ptr,0,y);
876 126 : break;
877 98 : case MAT_line:
878 98 : compilenode(tree[yx].x,Gsmall,0);
879 98 : op_push(OCcompoLptr,0,y);
880 98 : break;
881 98 : case MAT_column:
882 98 : compilenode(tree[yy].x,Gsmall,0);
883 98 : op_push(OCcompoCptr,0,y);
884 98 : break;
885 : }
886 : }
887 : }
888 :
889 : static void
890 13595 : compilematcoeff(long n, int mode)
891 : {
892 13595 : long x=tree[n].x, y=tree[n].y;
893 13595 : long yx=tree[y].x, yy=tree[y].y;
894 13595 : long m=matindex_type(y);
895 13595 : compilenode(x,Ggen,FLnocopy);
896 13595 : switch(m)
897 : {
898 11552 : case VEC_std:
899 11552 : compilenode(tree[yx].x,Gsmall,0);
900 11552 : op_push(OCcompo1,mode,y);
901 11552 : return;
902 580 : case MAT_std:
903 580 : compilenode(tree[yx].x,Gsmall,0);
904 580 : compilenode(tree[yy].x,Gsmall,0);
905 580 : op_push(OCcompo2,mode,y);
906 580 : return;
907 70 : case MAT_line:
908 70 : compilenode(tree[yx].x,Gsmall,0);
909 70 : op_push(OCcompoL,0,y);
910 70 : compilecast(n,Gvec,mode);
911 70 : return;
912 609 : case MAT_column:
913 609 : compilenode(tree[yy].x,Gsmall,0);
914 609 : op_push(OCcompoC,0,y);
915 609 : compilecast(n,Gvec,mode);
916 609 : return;
917 784 : case MAT_range:
918 784 : compilenode(tree[yx].x,Gsmall,0);
919 784 : compilenode(tree[yx].y,Gsmall,0);
920 784 : if (yy==-1)
921 609 : op_push(OCcallgen,(long)is_entry("_[_.._]"),n);
922 : else
923 : {
924 175 : compilenode(tree[yy].x,Gsmall,0);
925 175 : compilenode(tree[yy].y,Gsmall,0);
926 175 : op_push(OCcallgen,(long)is_entry("_[_.._,_.._]"),n);
927 : }
928 784 : compilecast(n,Gvec,mode);
929 777 : return;
930 0 : default:
931 0 : pari_err_BUG("compilematcoeff");
932 : }
933 : }
934 :
935 : static void
936 30552419 : compilesmall(long n, long x, long mode)
937 : {
938 30552419 : if (mode==Ggen)
939 30464838 : op_push(OCpushstoi, x, n);
940 : else
941 : {
942 87581 : if (mode==Gusmall && x < 0) U_compile_err(tree[n].str);
943 87581 : op_push(OCpushlong, x, n);
944 87581 : compilecast(n,Gsmall,mode);
945 : }
946 30552412 : }
947 :
948 : static void
949 15460451 : compilevec(long n, long mode, op_code op)
950 : {
951 15460451 : pari_sp ltop=avma;
952 15460451 : long x=tree[n].x;
953 : long i;
954 15460451 : GEN arg=listtogen(x,Fmatrixelts);
955 15460451 : long l=lg(arg);
956 15460451 : op_push(op,l,n);
957 64011731 : for (i=1;i<l;i++)
958 : {
959 48551280 : if (tree[arg[i]].f==Fnoarg)
960 0 : compile_err("missing vector element",tree[arg[i]].str);
961 48551280 : compilenode(arg[i],Ggen,FLsurvive);
962 48551280 : op_push(OCstackgen,i,n);
963 : }
964 15460451 : set_avma(ltop);
965 15460451 : op_push(OCpop,1,n);
966 15460451 : compilecast(n,Gvec,mode);
967 15460451 : }
968 :
969 : static void
970 9680 : compilemat(long n, long mode)
971 : {
972 9680 : pari_sp ltop=avma;
973 9680 : long x=tree[n].x;
974 : long i,j;
975 9680 : GEN line=listtogen(x,Fmatrixlines);
976 9680 : long lglin = lg(line), lgcol=0;
977 9680 : op_push(OCpushlong, lglin,n);
978 9680 : if (lglin==1)
979 1001 : op_push(OCmat,1,n);
980 48031 : for(i=1;i<lglin;i++)
981 : {
982 38351 : GEN col=listtogen(line[i],Fmatrixelts);
983 38351 : long l=lg(col), k;
984 38351 : if (i==1)
985 : {
986 8679 : lgcol=l;
987 8679 : op_push(OCmat,lgcol,n);
988 : }
989 29672 : else if (l!=lgcol)
990 0 : compile_err("matrix must be rectangular",tree[line[i]].str);
991 38351 : k=i;
992 292503 : for(j=1;j<lgcol;j++)
993 : {
994 254152 : k-=lglin;
995 254152 : if (tree[col[j]].f==Fnoarg)
996 0 : compile_err("missing matrix element",tree[col[j]].str);
997 254152 : compilenode(col[j], Ggen, FLsurvive);
998 254152 : op_push(OCstackgen,k,n);
999 : }
1000 : }
1001 9680 : set_avma(ltop);
1002 9680 : op_push(OCpop,1,n);
1003 9680 : compilecast(n,Gvec,mode);
1004 9680 : }
1005 :
1006 : static GEN
1007 48924 : cattovec(long n, long fnum)
1008 : {
1009 48924 : long x=n, y, i=0, nb;
1010 : GEN stack;
1011 48924 : if (tree[n].f==Fnoarg) return cgetg(1,t_VECSMALL);
1012 : while(1)
1013 222 : {
1014 49146 : long xx=tree[x].x;
1015 49146 : long xy=tree[x].y;
1016 49146 : if (tree[x].f!=Ffunction || xx!=fnum) break;
1017 222 : x=tree[xy].x;
1018 222 : y=tree[xy].y;
1019 222 : if (tree[y].f==Fnoarg)
1020 0 : compile_err("unexpected character: ", tree[y].str);
1021 222 : i++;
1022 : }
1023 48924 : if (tree[x].f==Fnoarg)
1024 0 : compile_err("unexpected character: ", tree[x].str);
1025 48924 : nb=i+1;
1026 48924 : stack=cgetg(nb+1,t_VECSMALL);
1027 49146 : for(x=n;i>0;i--)
1028 : {
1029 222 : long y=tree[x].y;
1030 222 : x=tree[y].x;
1031 222 : stack[i+1]=tree[y].y;
1032 : }
1033 48924 : stack[1]=x;
1034 48924 : return stack;
1035 : }
1036 :
1037 : static GEN
1038 359 : compilelambda(long y, GEN vep, long nbmvar, struct codepos *pos)
1039 : {
1040 359 : long lev = vep ? lg(vep)-1 : 0;
1041 359 : GEN text=cgetg(3,t_VEC);
1042 359 : gel(text,1)=strtoGENstr(lev? ((entree*) vep[1])->name: "");
1043 359 : gel(text,2)=strntoGENstr(tree[y].str,tree[y].len);
1044 359 : dbgstart = tree[y].str;
1045 359 : compilenode(y,Ggen,FLsurvive|FLreturn);
1046 359 : return getfunction(pos,lev,nbmvar,text,2);
1047 : }
1048 :
1049 : static void
1050 23375 : compilecall(long n, int mode, entree *ep)
1051 : {
1052 23375 : pari_sp ltop=avma;
1053 : long j;
1054 23375 : long x=tree[n].x, tx = tree[x].x;
1055 23375 : long y=tree[n].y;
1056 23375 : GEN arg=listtogen(y,Flistarg);
1057 23375 : long nb=lg(arg)-1;
1058 23375 : long lnc=first_safe_arg(arg, COsafelex|COsafedyn);
1059 23375 : long lnl=first_safe_arg(arg, COsafelex);
1060 23375 : long fl = lnl==0? (lnc==0? FLnocopy: FLnocopylex): 0;
1061 23375 : if (ep==NULL)
1062 329 : compilenode(x, Ggen, fl);
1063 : else
1064 : {
1065 23046 : long vn=getmvar(ep);
1066 23046 : if (vn)
1067 : {
1068 567 : access_push(vn);
1069 567 : op_push(OCpushlex,vn,n);
1070 : }
1071 : else
1072 22479 : op_push(OCpushdyn,(long)ep,n);
1073 : }
1074 63044 : for (j=1;j<=nb;j++)
1075 : {
1076 39669 : long x = tree[arg[j]].x, f = tree[arg[j]].f;
1077 39669 : if (f==Fseq)
1078 0 : compile_err("unexpected ';'", tree[x].str+tree[x].len);
1079 39669 : else if (f==Findarg)
1080 : {
1081 126 : long a = tree[arg[j]].x;
1082 126 : entree *ep = getlvalue(a);
1083 126 : long vn = getmvar(ep);
1084 126 : if (vn)
1085 49 : op_push(OCcowvarlex, vn, a);
1086 126 : compilenode(a, Ggen,FLnocopy);
1087 126 : op_push(OClock,0,n);
1088 39543 : } else if (tx==CSTmember)
1089 : {
1090 28 : compilenode(arg[j], Ggen,FLnocopy);
1091 28 : op_push(OClock,0,n);
1092 : }
1093 39515 : else if (f!=Fnoarg)
1094 39263 : compilenode(arg[j], Ggen,j>=lnl?FLnocopylex:0);
1095 : else
1096 252 : op_push(OCpushlong,0,n);
1097 : }
1098 23375 : op_push(OCcalluser,nb,x);
1099 23375 : compilecast(n,Ggen,mode);
1100 23375 : set_avma(ltop);
1101 23375 : }
1102 :
1103 : static GEN
1104 20697 : compilefuncinline(long n, long c, long a, long flag, long isif, long lev, long *ev)
1105 : {
1106 : struct codepos pos;
1107 20697 : int type=c=='I'?Gvoid:Ggen;
1108 20697 : long rflag=c=='I'?0:FLsurvive;
1109 20697 : long nbmvar = nblex;
1110 20697 : GEN vep = NULL;
1111 20697 : if (isif && (flag&FLreturn)) rflag|=FLreturn;
1112 20697 : getcodepos(&pos);
1113 20697 : if (c=='J') ctxmvar(nbmvar);
1114 20697 : if (lev)
1115 : {
1116 12141 : long i, slev = 0;
1117 12141 : GEN varg = cgetg(lev+1,t_VECSMALL);
1118 12141 : vep = cgetg(lev+1,t_VECSMALL);
1119 25090 : for (i = 1; i <= lev; i++)
1120 : {
1121 : entree *ve;
1122 12956 : long v = ev[i-1];
1123 12956 : if (v < 0)
1124 0 : compile_err("missing variable name", tree[a].str-1);
1125 12956 : ve = getvarvec(v);
1126 12949 : vep[i] = (long)ve;
1127 12949 : varg[i] = v;
1128 12949 : var_push(ve,Lmy);
1129 : }
1130 12134 : checkdups(varg,vep);
1131 12134 : if (c=='J')
1132 359 : op_push(OCgetargs,lev,n);
1133 12134 : access_push(lev);
1134 12134 : frame_push(vep);
1135 25083 : for (i = 1; i <= lev; i++)
1136 : {
1137 12949 : long v = ev[i-1];
1138 12949 : if (tree[v].f==Fvec)
1139 : {
1140 35 : GEN vpar = listtogen(tree[v].x,Fmatrixelts);
1141 35 : long k, l, lvv= lg(vpar), vlev = countmatrixelts(tree[v].x);
1142 35 : GEN vvep = cgetg(vlev+1,t_VECSMALL);
1143 119 : for (k = 1, l = 1; k < lvv; k++)
1144 84 : if (tree[vpar[k]].f!=Fnoarg)
1145 : {
1146 77 : entree *ve = getvar(vpar[k]);
1147 77 : vvep[l++]=(long)ve;
1148 77 : var_push(ve, Lmy);
1149 : }
1150 35 : access_push(vlev);
1151 35 : op_push(OCnewframe,vlev,v);
1152 35 : slev += vlev;
1153 35 : op_push(OCpushlex, i-lev-1-slev, v);
1154 35 : if (vlev > 1) op_push(OCdup,vlev-1,v);
1155 119 : for (k = 1, l = 1; k < lvv; k++)
1156 : {
1157 84 : long va = vpar[k];
1158 84 : if (tree[va].f!=Fnoarg)
1159 : {
1160 77 : op_push(OCpushlong,k,va);
1161 77 : op_push(OCcompo1,Ggen,va);
1162 77 : op_push(OCstorelex, (l++)-vlev-1, va);
1163 : }
1164 : }
1165 35 : frame_push(vvep);
1166 : }
1167 : }
1168 : }
1169 20690 : if (c=='J')
1170 359 : return compilelambda(a,vep,nbmvar,&pos);
1171 20331 : if (tree[a].f==Fnoarg)
1172 119 : compilecast(a,Gvoid,type);
1173 : else
1174 20212 : compilenode(a,type,rflag);
1175 20331 : return getclosure(&pos, nbmvar);
1176 : }
1177 :
1178 : static long
1179 3580 : countvar(GEN arg)
1180 : {
1181 3580 : long i, l = lg(arg);
1182 3580 : long n = l-1;
1183 10970 : for(i=1; i<l; i++)
1184 : {
1185 7390 : long a=arg[i];
1186 7390 : if (tree[a].f==Fassign)
1187 : {
1188 4154 : long x = detag(tree[a].x);
1189 4154 : if (tree[x].f==Fvec && tree[x].x>=0)
1190 427 : n += countmatrixelts(tree[x].x)-1;
1191 : }
1192 : }
1193 3580 : return n;
1194 : }
1195 :
1196 : static void
1197 6 : compileuninline(GEN arg)
1198 : {
1199 : long j;
1200 6 : if (lg(arg) > 1)
1201 0 : compile_err("too many arguments",tree[arg[1]].str);
1202 18 : for(j=0; j<s_lvar.n; j++)
1203 12 : if(!localvars[j].inl)
1204 0 : pari_err(e_MISC,"uninline is only valid at top level");
1205 6 : s_lvar.n = 0; nblex = 0;
1206 6 : }
1207 :
1208 : static void
1209 3552 : compilemy(GEN arg, const char *str, int inl)
1210 : {
1211 3552 : long i, j, k, l = lg(arg);
1212 3552 : long n = countvar(arg);
1213 3552 : GEN vep = cgetg(n+1,t_VECSMALL);
1214 3552 : GEN ver = cgetg(n+1,t_VECSMALL);
1215 3552 : if (inl)
1216 : {
1217 13 : for(j=0; j<s_lvar.n; j++)
1218 0 : if(!localvars[j].inl)
1219 0 : pari_err(e_MISC,"inline is only valid at top level");
1220 : }
1221 10886 : for(k=0, i=1; i<l; i++)
1222 : {
1223 7334 : long a=arg[i];
1224 7334 : if (tree[a].f==Fassign)
1225 : {
1226 4112 : long x = detag(tree[a].x);
1227 4112 : if (tree[x].f==Fvec && tree[x].x>=0)
1228 413 : {
1229 413 : GEN vars = listtogen(tree[x].x,Fmatrixelts);
1230 413 : long nv = lg(vars)-1;
1231 1379 : for (j=1; j<=nv; j++)
1232 966 : if (tree[vars[j]].f!=Fnoarg)
1233 : {
1234 952 : ver[++k] = vars[j];
1235 952 : vep[k] = (long)getvar(ver[k]);
1236 : }
1237 413 : continue;
1238 3699 : } else ver[++k] = x;
1239 3222 : } else ver[++k] = a;
1240 6921 : vep[k] = (long)getvar(ver[k]);
1241 : }
1242 3552 : checkdups(ver,vep);
1243 11425 : for(i=1; i<=n; i++) var_push(NULL,Lmy);
1244 3552 : op_push_loc(OCnewframe,inl?-n:n,str);
1245 3552 : access_push(lg(vep)-1);
1246 3552 : frame_push(vep);
1247 10886 : for (k=0, i=1; i<l; i++)
1248 : {
1249 7334 : long a=arg[i];
1250 7334 : if (tree[a].f==Fassign)
1251 : {
1252 4112 : long x = detag(tree[a].x);
1253 4112 : if (tree[x].f==Fvec && tree[x].x>=0)
1254 413 : {
1255 413 : GEN vars = listtogen(tree[x].x,Fmatrixelts);
1256 413 : long nv = lg(vars)-1, m = nv;
1257 413 : compilenode(tree[a].y,Ggen,FLnocopy);
1258 1379 : for (j=1; j<=nv; j++)
1259 966 : if (tree[vars[j]].f==Fnoarg) m--;
1260 413 : if (m > 1) op_push(OCdup,m-1,x);
1261 1379 : for (j=1; j<=nv; j++)
1262 966 : if (tree[vars[j]].f!=Fnoarg)
1263 : {
1264 952 : long v = detag(vars[j]);
1265 952 : op_push(OCpushlong,j,v);
1266 952 : op_push(OCcompo1,Ggen,v);
1267 952 : k++;
1268 952 : op_push(OCstorelex,-n+k-1,a);
1269 952 : localvars[s_lvar.n-n+k-1].ep=(entree*)vep[k];
1270 952 : localvars[s_lvar.n-n+k-1].inl=inl;
1271 : }
1272 413 : continue;
1273 : }
1274 3699 : else if (!is_node_zero(tree[a].y))
1275 : {
1276 3551 : compilenode(tree[a].y,Ggen,FLnocopy);
1277 3551 : op_push(OCstorelex,-n+k,a);
1278 : }
1279 : }
1280 6921 : k++;
1281 6921 : localvars[s_lvar.n-n+k-1].ep=(entree*)vep[k];
1282 6921 : localvars[s_lvar.n-n+k-1].inl=inl;
1283 : }
1284 3552 : }
1285 :
1286 : static long
1287 70 : localpush(op_code op, long a)
1288 : {
1289 70 : entree *ep = getvardyn(a);
1290 70 : long vep = (long) ep;
1291 70 : op_push(op,vep,a);
1292 70 : var_push(ep,Llocal);
1293 70 : return vep;
1294 : }
1295 :
1296 : static void
1297 28 : compilelocal(GEN arg)
1298 : {
1299 28 : long i, j, k, l = lg(arg);
1300 28 : long n = countvar(arg);
1301 28 : GEN vep = cgetg(n+1,t_VECSMALL);
1302 28 : GEN ver = cgetg(n+1,t_VECSMALL);
1303 84 : for(k=0, i=1; i<l; i++)
1304 : {
1305 56 : long a=arg[i];
1306 56 : if (tree[a].f==Fassign)
1307 : {
1308 42 : long x = detag(tree[a].x);
1309 42 : if (tree[x].f==Fvec && tree[x].x>=0)
1310 14 : {
1311 14 : GEN vars = listtogen(tree[x].x,Fmatrixelts);
1312 14 : long nv = lg(vars)-1, m = nv;
1313 14 : compilenode(tree[a].y,Ggen,FLnocopy);
1314 56 : for (j=1; j<=nv; j++)
1315 42 : if (tree[vars[j]].f==Fnoarg) m--;
1316 14 : if (m > 1) op_push(OCdup,m-1,x);
1317 56 : for (j=1; j<=nv; j++)
1318 42 : if (tree[vars[j]].f!=Fnoarg)
1319 : {
1320 28 : long v = detag(vars[j]);
1321 28 : op_push(OCpushlong,j,v);
1322 28 : op_push(OCcompo1,Ggen,v);
1323 28 : vep[++k] = localpush(OClocalvar, v);
1324 28 : ver[k] = v;
1325 : }
1326 14 : continue;
1327 28 : } else if (!is_node_zero(tree[a].y))
1328 : {
1329 21 : compilenode(tree[a].y,Ggen,FLnocopy);
1330 21 : ver[++k] = x;
1331 21 : vep[k] = localpush(OClocalvar, ver[k]);
1332 21 : continue;
1333 : }
1334 : else
1335 7 : ver[++k] = x;
1336 : } else
1337 14 : ver[++k] = a;
1338 21 : vep[k] = localpush(OClocalvar0, ver[k]);
1339 : }
1340 28 : checkdups(ver,vep);
1341 28 : }
1342 :
1343 : static void
1344 41 : compileexport(GEN arg)
1345 : {
1346 41 : long i, l = lg(arg);
1347 82 : for (i=1; i<l; i++)
1348 : {
1349 41 : long a=arg[i];
1350 41 : if (tree[a].f==Fassign)
1351 : {
1352 14 : long x = detag(tree[a].x);
1353 14 : long v = (long) getvardyn(x);
1354 14 : compilenode(tree[a].y,Ggen,FLnocopy);
1355 14 : op_push(OCexportvar,v,x);
1356 : } else
1357 : {
1358 27 : long x = detag(a);
1359 27 : long v = (long) getvardyn(x);
1360 27 : op_push(OCpushdyn,v,x);
1361 27 : op_push(OCexportvar,v,x);
1362 : }
1363 : }
1364 41 : }
1365 :
1366 : static void
1367 6 : compileunexport(GEN arg)
1368 : {
1369 6 : long i, l = lg(arg);
1370 12 : for (i=1; i<l; i++)
1371 : {
1372 6 : long a = arg[i];
1373 6 : long x = detag(a);
1374 6 : long v = (long) getvardyn(x);
1375 6 : op_push(OCunexportvar,v,x);
1376 : }
1377 6 : }
1378 :
1379 : static void
1380 10768448 : compilefunc(entree *ep, long n, int mode, long flag)
1381 : {
1382 10768448 : pari_sp ltop=avma;
1383 : long j;
1384 10768448 : long x=tree[n].x, y=tree[n].y;
1385 : op_code ret_op;
1386 : long ret_flag;
1387 : Gtype ret_typ;
1388 : char const *p,*q;
1389 : char c;
1390 : const char *str;
1391 : PPproto mod;
1392 10768448 : GEN arg=listtogen(y,Flistarg);
1393 10768448 : long lnc=first_safe_arg(arg, COsafelex|COsafedyn);
1394 10768448 : long lnl=first_safe_arg(arg, COsafelex);
1395 10768448 : long nbpointers=0, nbopcodes;
1396 10768448 : long nb=lg(arg)-1, lev=0;
1397 : long ev[20];
1398 10768448 : if (x>=OPnboperator)
1399 207581 : str=tree[x].str;
1400 : else
1401 : {
1402 10560867 : if (nb==2)
1403 1149291 : str=tree[arg[1]].str+tree[arg[1]].len;
1404 9411576 : else if (nb==1)
1405 9410571 : str=tree[arg[1]].str;
1406 : else
1407 1005 : str=tree[n].str;
1408 10567312 : while(*str==')') str++;
1409 : }
1410 10768448 : if (tree[n].f==Fassign)
1411 : {
1412 0 : nb=2; lnc=2; lnl=2; arg=mkvecsmall2(x,y);
1413 : }
1414 10768448 : else if (is_func_named(ep,"if"))
1415 : {
1416 4907 : if (nb>=4)
1417 112 : ep=is_entry("_multi_if");
1418 4795 : else if (mode==Gvoid)
1419 3064 : ep=is_entry("_void_if");
1420 : }
1421 10763541 : else if (is_func_named(ep,"return") && (flag&FLreturn) && nb<=1)
1422 : {
1423 105 : if (nb==0) op_push(OCpushgnil,0,n);
1424 105 : else compilenode(arg[1],Ggen,FLsurvive|FLreturn);
1425 105 : set_avma(ltop);
1426 9003876 : return;
1427 : }
1428 10763436 : else if (is_func_named(ep,"inline"))
1429 : {
1430 13 : compilemy(arg, str, 1);
1431 13 : compilecast(n,Gvoid,mode);
1432 13 : set_avma(ltop);
1433 13 : return;
1434 : }
1435 10763423 : else if (is_func_named(ep,"uninline"))
1436 : {
1437 6 : compileuninline(arg);
1438 6 : compilecast(n,Gvoid,mode);
1439 6 : set_avma(ltop);
1440 6 : return;
1441 : }
1442 10763417 : else if (is_func_named(ep,"my"))
1443 : {
1444 3539 : compilemy(arg, str, 0);
1445 3539 : compilecast(n,Gvoid,mode);
1446 3539 : set_avma(ltop);
1447 3539 : return;
1448 : }
1449 10759878 : else if (is_func_named(ep,"local"))
1450 : {
1451 28 : compilelocal(arg);
1452 28 : compilecast(n,Gvoid,mode);
1453 28 : set_avma(ltop);
1454 28 : return;
1455 : }
1456 10759850 : else if (is_func_named(ep,"export"))
1457 : {
1458 41 : compileexport(arg);
1459 41 : compilecast(n,Gvoid,mode);
1460 41 : set_avma(ltop);
1461 41 : return;
1462 : }
1463 10759809 : else if (is_func_named(ep,"unexport"))
1464 : {
1465 6 : compileunexport(arg);
1466 6 : compilecast(n,Gvoid,mode);
1467 6 : set_avma(ltop);
1468 6 : return;
1469 : }
1470 : /*We generate dummy code for global() for compatibility with gp2c*/
1471 10759803 : else if (is_func_named(ep,"global"))
1472 : {
1473 : long i;
1474 21 : for (i=1;i<=nb;i++)
1475 : {
1476 14 : long a=arg[i];
1477 : long en;
1478 14 : if (tree[a].f==Fassign)
1479 : {
1480 7 : compilenode(tree[a].y,Ggen,0);
1481 7 : a=tree[a].x;
1482 7 : en=(long)getvardyn(a);
1483 7 : op_push(OCstoredyn,en,a);
1484 : }
1485 : else
1486 : {
1487 7 : en=(long)getvardyn(a);
1488 7 : op_push(OCpushdyn,en,a);
1489 7 : op_push(OCpop,1,a);
1490 : }
1491 : }
1492 7 : compilecast(n,Gvoid,mode);
1493 7 : set_avma(ltop);
1494 7 : return;
1495 : }
1496 10759796 : else if (is_func_named(ep,"O"))
1497 : {
1498 4942 : if (nb!=1)
1499 0 : compile_err("wrong number of arguments", tree[n].str+tree[n].len-1);
1500 4942 : ep=is_entry("O(_^_)");
1501 4942 : if (tree[arg[1]].f==Ffunction && tree[arg[1]].x==OPpow)
1502 : {
1503 3731 : arg = listtogen(tree[arg[1]].y,Flistarg);
1504 3731 : nb = lg(arg)-1;
1505 3731 : lnc = first_safe_arg(arg,COsafelex|COsafedyn);
1506 3731 : lnl = first_safe_arg(arg,COsafelex);
1507 : }
1508 : }
1509 10754854 : else if (x==OPn && tree[y].f==Fsmall)
1510 : {
1511 8995602 : set_avma(ltop);
1512 8995602 : compilesmall(y, -tree[y].x, mode);
1513 8995602 : return;
1514 : }
1515 1759252 : else if (x==OPtrans && tree[y].f==Fvec)
1516 : {
1517 4529 : set_avma(ltop);
1518 4529 : compilevec(y, mode, OCcol);
1519 4529 : return;
1520 1754723 : } else if(x==OPlength && tree[y].f==Ffunction && tree[y].x==OPtrans)
1521 : {
1522 7 : arg[1] = tree[y].y;
1523 7 : lnc = first_safe_arg(arg,COsafelex|COsafedyn);
1524 7 : lnl = first_safe_arg(arg,COsafelex);
1525 7 : ep = is_entry("#_~");
1526 : }
1527 1754716 : else if (x==OPpow && nb==2)
1528 73312 : {
1529 73312 : long a = arg[2];
1530 73312 : if (tree[a].f==Fsmall)
1531 : {
1532 68549 : if(tree[a].x==2) { nb--; ep=is_entry("sqr"); }
1533 49141 : else ep=is_entry("_^s");
1534 : }
1535 4763 : else if (tree[a].f == Ffunction && tree[a].x == OPn)
1536 : {
1537 1323 : long ay = tree[a].y;
1538 1323 : if (tree[ay].f==Fsmall)
1539 : {
1540 1176 : if (tree[ay].x==1) {nb--; ep=is_entry("_inv"); }
1541 798 : else ep=is_entry("_^s");
1542 : }
1543 : }
1544 : }
1545 1681404 : else if (x==OPcat)
1546 0 : compile_err("expected character: ',' or ')' instead of",
1547 0 : tree[arg[1]].str+tree[arg[1]].len);
1548 1764572 : p=ep->code;
1549 1764572 : if (!ep->value)
1550 0 : compile_err("unknown function",tree[n].str);
1551 1764572 : nbopcodes = s_opcode.n;
1552 1764572 : ret_op = get_ret_type(&p, ep->arity, &ret_typ, &ret_flag);
1553 1764572 : j=1;
1554 1764572 : if (*p)
1555 : {
1556 1755356 : q=p;
1557 4898577 : while((mod=parseproto(&p,&c,tree[n].str))!=PPend)
1558 : {
1559 3143263 : if (j<=nb && tree[arg[j]].f!=Fnoarg
1560 3031756 : && (mod==PPdefault || mod==PPdefaultmulti))
1561 68168 : mod=PPstd;
1562 3143263 : switch(mod)
1563 : {
1564 3016729 : case PPstd:
1565 3016729 : if (j>nb) compile_err("too few arguments", tree[n].str+tree[n].len-1);
1566 3016729 : if (c!='I' && c!='E' && c!='J')
1567 : {
1568 2996494 : long x = tree[arg[j]].x, f = tree[arg[j]].f;
1569 2996494 : if (f==Fnoarg)
1570 0 : compile_err("missing mandatory argument", tree[arg[j]].str);
1571 2996494 : if (f==Fseq)
1572 0 : compile_err("unexpected ';'", tree[x].str+tree[x].len);
1573 : }
1574 3016729 : switch(c)
1575 : {
1576 2896536 : case 'G':
1577 2896536 : compilenode(arg[j],Ggen,j>=lnl?(j>=lnc?FLnocopy:FLnocopylex):0);
1578 2896536 : j++;
1579 2896536 : break;
1580 546 : case 'W':
1581 : {
1582 546 : long a = tree[arg[j]].f==Findarg ? tree[arg[j]].x: arg[j];
1583 546 : entree *ep = getlvalue(a);
1584 532 : long vn = getmvar(ep);
1585 532 : if (vn)
1586 224 : op_push(OCcowvarlex, vn, a);
1587 308 : else op_push(OCcowvardyn, (long)ep, a);
1588 532 : compilenode(a, Ggen,FLnocopy);
1589 532 : j++;
1590 532 : break;
1591 : }
1592 84 : case 'M':
1593 84 : if (tree[arg[j]].f!=Fsmall)
1594 : {
1595 35 : const char *flags = ep->code;
1596 35 : flags = strchr(flags, '\n'); /* Skip to the following '\n' */
1597 35 : if (!flags)
1598 0 : compile_err("missing flag in string function signature",
1599 0 : tree[n].str);
1600 35 : flags++;
1601 35 : if (tree[arg[j]].f==Fconst && tree[arg[j]].x==CSTstr)
1602 35 : {
1603 35 : GEN str=strntoGENexp(tree[arg[j]].str,tree[arg[j]].len);
1604 35 : op_push(OCpushlong, eval_mnemonic(str, flags),n);
1605 35 : j++;
1606 : } else
1607 : {
1608 0 : compilenode(arg[j++],Ggen,FLnocopy);
1609 0 : op_push(OCevalmnem,(long)ep,n);
1610 : }
1611 35 : break;
1612 : }
1613 : case 'P': case 'L':
1614 76644 : compilenode(arg[j++],Gsmall,0);
1615 76637 : break;
1616 217 : case 'U':
1617 217 : compilenode(arg[j++],Gusmall,0);
1618 210 : break;
1619 3989 : case 'n':
1620 3989 : compilenode(arg[j++],Gvar,0);
1621 3982 : break;
1622 2308 : case '&': case '*':
1623 : {
1624 2308 : long vn, a=arg[j++];
1625 : entree *ep;
1626 2308 : if (c=='&')
1627 : {
1628 1533 : if (tree[a].f!=Frefarg)
1629 0 : compile_err("expected character: '&'", tree[a].str);
1630 1533 : a=tree[a].x;
1631 : }
1632 2308 : a=detag(a);
1633 2308 : ep=getlvalue(a);
1634 2308 : vn=getmvar(ep);
1635 2308 : if (tree[a].f==Fentry)
1636 : {
1637 2105 : if (vn)
1638 : {
1639 516 : access_push(vn);
1640 516 : op_push(OCsimpleptrlex, vn,n);
1641 : }
1642 : else
1643 1589 : op_push(OCsimpleptrdyn, (long)ep,n);
1644 : }
1645 : else
1646 : {
1647 203 : compilenewptr(vn, ep, a);
1648 203 : compilelvalue(a);
1649 203 : op_push(OCpushptr, 0, a);
1650 : }
1651 2308 : nbpointers++;
1652 2308 : break;
1653 : }
1654 20235 : case 'I':
1655 : case 'E':
1656 : case 'J':
1657 : {
1658 20235 : long a = arg[j++];
1659 20235 : GEN d = compilefuncinline(n, c, a, flag, is_func_named(ep,"if"), lev, ev);
1660 20228 : op_push(OCpushgen, data_push(d), a);
1661 20228 : if (lg(d)==8) op_push(OCsaveframe,FLsurvive,n);
1662 20228 : break;
1663 : }
1664 5520 : case 'V':
1665 : {
1666 5520 : long a = arg[j++];
1667 5520 : ev[lev++] = a;
1668 5520 : break;
1669 : }
1670 6867 : case '=':
1671 : {
1672 6867 : long a = arg[j++];
1673 6867 : ev[lev++] = tree[a].x;
1674 6867 : compilenode(tree[a].y, Ggen, FLnocopy);
1675 : }
1676 6867 : break;
1677 1075 : case 'r':
1678 : {
1679 1075 : long a=arg[j++];
1680 1075 : if (tree[a].f==Fentry)
1681 : {
1682 1012 : op_push(OCpushgen, data_push(strntoGENstr(tree[tree[a].x].str,
1683 1012 : tree[tree[a].x].len)),n);
1684 1012 : op_push(OCtostr, -1,n);
1685 : }
1686 : else
1687 : {
1688 63 : compilenode(a,Ggen,FLnocopy);
1689 63 : op_push(OCtostr, -1,n);
1690 : }
1691 1075 : break;
1692 : }
1693 2757 : case 's':
1694 : {
1695 2757 : long a = arg[j++];
1696 2757 : GEN g = cattovec(a, OPcat);
1697 2757 : long l, nb = lg(g)-1;
1698 2757 : if (nb==1)
1699 : {
1700 2681 : compilenode(g[1], Ggen, FLnocopy);
1701 2681 : op_push(OCtostr, -1, a);
1702 : } else
1703 : {
1704 76 : op_push(OCvec, nb+1, a);
1705 228 : for(l=1; l<=nb; l++)
1706 : {
1707 152 : compilenode(g[l], Ggen, FLsurvive);
1708 152 : op_push(OCstackgen,l, a);
1709 : }
1710 76 : op_push(OCpop, 1, a);
1711 76 : op_push(OCcallgen,(long)is_entry("Str"), a);
1712 76 : op_push(OCtostr, -1, a);
1713 : }
1714 2757 : break;
1715 : }
1716 0 : default:
1717 0 : pari_err(e_MISC,"Unknown prototype code `%c' for `%.*s'",c,
1718 0 : tree[x].len, tree[x].str);
1719 : }
1720 3016687 : break;
1721 33957 : case PPauto:
1722 33957 : switch(c)
1723 : {
1724 29606 : case 'p':
1725 29606 : op_push(OCprecreal,0,n);
1726 29606 : break;
1727 4298 : case 'b':
1728 4298 : op_push(OCbitprecreal,0,n);
1729 4298 : break;
1730 0 : case 'P':
1731 0 : op_push(OCprecdl,0,n);
1732 0 : break;
1733 53 : case 'C':
1734 53 : op_push(OCpushgen,data_push(pack_localvars()),n);
1735 53 : break;
1736 0 : case 'f':
1737 : {
1738 : static long foo;
1739 0 : op_push(OCpushlong,(long)&foo,n);
1740 0 : break;
1741 : }
1742 : }
1743 33957 : break;
1744 44754 : case PPdefault:
1745 44754 : j++;
1746 44754 : switch(c)
1747 : {
1748 34428 : case 'G':
1749 : case '&':
1750 : case 'E':
1751 : case 'I':
1752 : case 'r':
1753 : case 's':
1754 34428 : op_push(OCpushlong,0,n);
1755 34428 : break;
1756 9025 : case 'n':
1757 9025 : op_push(OCpushlong,-1,n);
1758 9025 : break;
1759 958 : case 'V':
1760 958 : ev[lev++] = -1;
1761 958 : break;
1762 343 : case 'P':
1763 343 : op_push(OCprecdl,0,n);
1764 343 : break;
1765 0 : default:
1766 0 : pari_err(e_MISC,"Unknown prototype code `%c' for `%.*s'",c,
1767 0 : tree[x].len, tree[x].str);
1768 : }
1769 44754 : break;
1770 32358 : case PPdefaultmulti:
1771 32358 : j++;
1772 32358 : switch(c)
1773 : {
1774 0 : case 'G':
1775 0 : op_push(OCpushstoi,strtol(q+1,NULL,10),n);
1776 0 : break;
1777 32277 : case 'L':
1778 : case 'M':
1779 32277 : op_push(OCpushlong,strtol(q+1,NULL,10),n);
1780 32277 : break;
1781 42 : case 'U':
1782 42 : op_push(OCpushlong,(long)strtoul(q+1,NULL,10),n);
1783 42 : break;
1784 39 : case 'r':
1785 : case 's':
1786 39 : str_defproto(p, q, tree[n].str);
1787 39 : op_push(OCtostr, -1, n);
1788 39 : break;
1789 0 : default:
1790 0 : pari_err(e_MISC,"Unknown prototype code `%c' for `%.*s'",c,
1791 0 : tree[x].len, tree[x].str);
1792 : }
1793 32358 : break;
1794 15465 : case PPstar:
1795 15465 : switch(c)
1796 : {
1797 112 : case 'E':
1798 : {
1799 112 : long k, n=nb+1-j;
1800 112 : GEN g=cgetg(n+1,t_VEC);
1801 112 : int ismif = is_func_named(ep,"_multi_if");
1802 574 : for(k=1; k<=n; k++)
1803 528 : gel(g, k) = compilefuncinline(n, c, arg[j+k-1], flag,
1804 462 : ismif && (k==n || odd(k)), lev, ev);
1805 112 : op_push(OCpushgen, data_push(g), arg[j]);
1806 112 : j=nb+1;
1807 112 : break;
1808 : }
1809 15353 : case 's':
1810 : {
1811 15353 : long n=nb+1-j;
1812 : long k,l,l1,m;
1813 15353 : GEN g=cgetg(n+1,t_VEC);
1814 37058 : for(l1=0,k=1;k<=n;k++)
1815 : {
1816 21705 : gel(g,k)=cattovec(arg[j+k-1],OPcat);
1817 21705 : l1+=lg(gel(g,k))-1;
1818 : }
1819 15353 : op_push_loc(OCvec, l1+1, str);
1820 37058 : for(m=1,k=1;k<=n;k++)
1821 43445 : for(l=1;l<lg(gel(g,k));l++,m++)
1822 : {
1823 21740 : compilenode(mael(g,k,l),Ggen,FLsurvive);
1824 21740 : op_push(OCstackgen,m,mael(g,k,l));
1825 : }
1826 15353 : op_push_loc(OCpop, 1, str);
1827 15353 : j=nb+1;
1828 15353 : break;
1829 : }
1830 0 : default:
1831 0 : pari_err(e_MISC,"Unknown prototype code `%c*' for `%.*s'",c,
1832 0 : tree[x].len, tree[x].str);
1833 : }
1834 15465 : break;
1835 0 : default:
1836 0 : pari_err_BUG("compilefunc [unknown PPproto]");
1837 : }
1838 3143221 : q=p;
1839 : }
1840 : }
1841 1764530 : if (j<=nb)
1842 0 : compile_err("too many arguments",tree[arg[j]].str);
1843 1764530 : op_push_loc(ret_op, (long) ep, str);
1844 1764530 : if (mode==Ggen && (ret_flag&FLnocopy) && !(flag&FLnocopy))
1845 10688 : op_push_loc(OCcopy,0,str);
1846 1764530 : if (ret_typ==Ggen && nbpointers==0 && s_opcode.n>nbopcodes+128)
1847 : {
1848 2975 : op_insert_loc(nbopcodes,OCavma,0,str);
1849 2975 : op_push_loc(OCgc,0,str);
1850 : }
1851 1764530 : compilecast(n,ret_typ,mode);
1852 1764530 : if (nbpointers) op_push_loc(OCendptr,nbpointers, str);
1853 1764530 : set_avma(ltop);
1854 : }
1855 :
1856 : static void
1857 9136799 : genclosurectx(const char *loc, long nbdata)
1858 : {
1859 : long i;
1860 9136799 : GEN vep = cgetg(nbdata+1,t_VECSMALL);
1861 32787470 : for(i = 1; i <= nbdata; i++)
1862 : {
1863 23650684 : vep[i] = 0;
1864 23650684 : op_push_loc(OCpushlex,-i,loc);
1865 : }
1866 9136786 : frame_push(vep);
1867 9136886 : }
1868 :
1869 : static GEN
1870 9147589 : genclosure(entree *ep, const char *loc, long nbdata, int check)
1871 : {
1872 : struct codepos pos;
1873 9147589 : long nb=0;
1874 9147589 : const char *code=ep->code,*p,*q;
1875 : char c;
1876 : GEN text;
1877 9147589 : long index=ep->arity;
1878 9147589 : long arity=0, maskarg=0, maskarg0=0, stop=0, dovararg=0;
1879 : PPproto mod;
1880 : Gtype ret_typ;
1881 : long ret_flag;
1882 9147589 : op_code ret_op=get_ret_type(&code,ep->arity,&ret_typ,&ret_flag);
1883 9147559 : p=code;
1884 41946047 : while ((mod=parseproto(&p,&c,NULL))!=PPend)
1885 : {
1886 32798488 : if (mod==PPauto)
1887 2052 : stop=1;
1888 : else
1889 : {
1890 32796436 : if (stop) return NULL;
1891 32796436 : if (c=='V') continue;
1892 32796436 : maskarg<<=1; maskarg0<<=1; arity++;
1893 32796436 : switch(mod)
1894 : {
1895 32795237 : case PPstd:
1896 32795237 : maskarg|=1L;
1897 32795237 : break;
1898 482 : case PPdefault:
1899 482 : switch(c)
1900 : {
1901 28 : case '&':
1902 : case 'E':
1903 : case 'I':
1904 28 : maskarg0|=1L;
1905 28 : break;
1906 : }
1907 482 : break;
1908 717 : default:
1909 717 : break;
1910 : }
1911 : }
1912 : }
1913 9147464 : if (check && EpSTATIC(ep) && maskarg==0)
1914 8903 : return gen_0;
1915 9138561 : getcodepos(&pos);
1916 9138628 : dbgstart = loc;
1917 9138628 : if (nbdata > arity)
1918 0 : pari_err(e_MISC,"too many parameters for closure `%s'", ep->name);
1919 9138628 : if (nbdata) genclosurectx(loc, nbdata);
1920 9138709 : text = strtoGENstr(ep->name);
1921 9138638 : arity -= nbdata;
1922 9138638 : if (maskarg) op_push_loc(OCcheckargs,maskarg,loc);
1923 9138593 : if (maskarg0) op_push_loc(OCcheckargs0,maskarg0,loc);
1924 9138593 : p=code;
1925 41935187 : while ((mod=parseproto(&p,&c,NULL))!=PPend)
1926 : {
1927 32796549 : switch(mod)
1928 : {
1929 666 : case PPauto:
1930 666 : switch(c)
1931 : {
1932 666 : case 'p':
1933 666 : op_push_loc(OCprecreal,0,loc);
1934 666 : break;
1935 0 : case 'b':
1936 0 : op_push_loc(OCbitprecreal,0,loc);
1937 0 : break;
1938 0 : case 'P':
1939 0 : op_push_loc(OCprecdl,0,loc);
1940 0 : break;
1941 0 : case 'C':
1942 0 : op_push_loc(OCpushgen,data_push(pack_localvars()),loc);
1943 45 : break;
1944 0 : case 'f':
1945 : {
1946 : static long foo;
1947 0 : op_push_loc(OCpushlong,(long)&foo,loc);
1948 0 : break;
1949 : }
1950 : }
1951 : default:
1952 32796594 : break;
1953 : }
1954 : }
1955 9138605 : q = p = code;
1956 41935177 : while ((mod=parseproto(&p,&c,NULL))!=PPend)
1957 : {
1958 32796572 : switch(mod)
1959 : {
1960 32795147 : case PPstd:
1961 32795147 : switch(c)
1962 : {
1963 32751761 : case 'G':
1964 32751761 : break;
1965 31901 : case 'M':
1966 : case 'L':
1967 31901 : op_push_loc(OCitos,-index,loc);
1968 31901 : break;
1969 11455 : case 'U':
1970 11455 : op_push_loc(OCitou,-index,loc);
1971 11455 : break;
1972 0 : case 'n':
1973 0 : op_push_loc(OCvarn,-index,loc);
1974 0 : break;
1975 0 : case '&': case '*':
1976 : case 'I':
1977 : case 'E':
1978 : case 'V':
1979 : case '=':
1980 0 : return NULL;
1981 28 : case 'r':
1982 : case 's':
1983 28 : op_push_loc(OCtostr,-index,loc);
1984 28 : break;
1985 : }
1986 32795147 : break;
1987 666 : case PPauto:
1988 666 : break;
1989 412 : case PPdefault:
1990 412 : switch(c)
1991 : {
1992 216 : case 'G':
1993 : case '&':
1994 : case 'E':
1995 : case 'I':
1996 : case 'V':
1997 216 : break;
1998 14 : case 'r':
1999 : case 's':
2000 14 : op_push_loc(OCtostr,-index,loc);
2001 14 : break;
2002 112 : case 'n':
2003 112 : op_push_loc(OCvarn,-index,loc);
2004 112 : break;
2005 70 : case 'P':
2006 70 : op_push_loc(OCprecdl,0,loc);
2007 70 : op_push_loc(OCdefaultlong,-index,loc);
2008 70 : break;
2009 0 : default:
2010 0 : pari_err(e_MISC,"Unknown prototype code `D%c' for `%s'",c,ep->name);
2011 : }
2012 412 : break;
2013 319 : case PPdefaultmulti:
2014 319 : switch(c)
2015 : {
2016 0 : case 'G':
2017 0 : op_push_loc(OCpushstoi,strtol(q+1,NULL,10),loc);
2018 0 : op_push_loc(OCdefaultgen,-index,loc);
2019 0 : break;
2020 319 : case 'L':
2021 : case 'M':
2022 319 : op_push_loc(OCpushlong,strtol(q+1,NULL,10),loc);
2023 319 : op_push_loc(OCdefaultlong,-index,loc);
2024 319 : break;
2025 0 : case 'U':
2026 0 : op_push_loc(OCpushlong,(long)strtoul(q+1,NULL,10),loc);
2027 0 : op_push_loc(OCdefaultulong,-index,loc);
2028 0 : break;
2029 0 : case 'r':
2030 : case 's':
2031 0 : str_defproto(p, q, loc);
2032 0 : op_push_loc(OCdefaultgen,-index,loc);
2033 0 : op_push_loc(OCtostr,-index,loc);
2034 0 : break;
2035 0 : default:
2036 0 : pari_err(e_MISC,
2037 : "Unknown prototype code `D...,%c,' for `%s'",c,ep->name);
2038 : }
2039 319 : break;
2040 28 : case PPstar:
2041 28 : switch(c)
2042 : {
2043 28 : case 's':
2044 28 : dovararg = 1;
2045 28 : break;
2046 0 : case 'E':
2047 0 : return NULL;
2048 0 : default:
2049 0 : pari_err(e_MISC,"Unknown prototype code `%c*' for `%s'",c,ep->name);
2050 : }
2051 28 : break;
2052 0 : default:
2053 0 : return NULL;
2054 : }
2055 32796572 : index--;
2056 32796572 : q = p;
2057 : }
2058 9138498 : op_push_loc(ret_op, (long) ep, loc);
2059 9138599 : if (ret_flag==FLnocopy) op_push_loc(OCcopy,0,loc);
2060 9138599 : compilecast_loc(ret_typ, Ggen, loc);
2061 9138592 : if (dovararg) nb|=VARARGBITS;
2062 9138592 : return getfunction(&pos,nb+arity,nbdata,text,0);
2063 : }
2064 :
2065 : GEN
2066 9135178 : snm_closure(entree *ep, GEN data)
2067 : {
2068 9135178 : long i, n = data ? lg(data)-1: 0;
2069 9135178 : GEN C = genclosure(ep,ep->name,n,0);
2070 32779382 : for(i = 1; i <= n; i++) gmael(C,7,i) = gel(data,i);
2071 9135176 : return C;
2072 : }
2073 :
2074 : GEN
2075 1820 : strtoclosure(const char *s, long n, ...)
2076 : {
2077 1820 : pari_sp av = avma;
2078 1820 : entree *ep = is_entry(s);
2079 : GEN C;
2080 1820 : if (!ep) pari_err(e_NOTFUNC, strtoGENstr(s));
2081 1820 : ep = do_alias(ep);
2082 1820 : if ((!EpSTATIC(ep) && EpVALENCE(ep)!=EpINSTALL) || !ep->value)
2083 0 : pari_err(e_MISC,"not a built-in/install'ed function: \"%s\"",s);
2084 1820 : C = genclosure(ep,ep->name,n,0);
2085 1820 : if (!C) pari_err(e_MISC,"function prototype unsupported: \"%s\"",s);
2086 : else
2087 : {
2088 : va_list ap;
2089 : long i;
2090 1820 : va_start(ap,n);
2091 8624 : for(i = 1; i <= n; i++) gmael(C,7,i) = va_arg(ap, GEN);
2092 1820 : va_end(ap);
2093 : }
2094 1820 : return gc_GEN(av, C);
2095 : }
2096 :
2097 : GEN
2098 0 : closuretoinl(GEN C)
2099 : {
2100 0 : long i, n = closure_arity(C);
2101 0 : GEN text = closure_get_text(C);
2102 : struct codepos pos;
2103 : const char *loc;
2104 0 : getcodepos(&pos);
2105 0 : if (typ(text)==t_VEC) text = gel(text, 2);
2106 0 : loc = GSTR(text);
2107 0 : dbgstart = loc;
2108 0 : op_push_loc(OCpushgen, data_push(C), loc);
2109 0 : for (i = n; i >= 1 ; i--)
2110 0 : op_push_loc(OCpushlex, -i, loc);
2111 0 : op_push_loc(OCcalluser, n, loc);
2112 0 : return getfunction(&pos,0,0,text,0);
2113 : }
2114 :
2115 : GEN
2116 119 : strtofunction(const char *s) { return strtoclosure(s, 0); }
2117 :
2118 : GEN
2119 28 : call0(GEN fun, GEN args)
2120 : {
2121 28 : if (!is_vec_t(typ(args))) pari_err_TYPE("call",args);
2122 28 : switch(typ(fun))
2123 : {
2124 7 : case t_STR:
2125 7 : fun = strtofunction(GSTR(fun));
2126 28 : case t_CLOSURE: /* fall through */
2127 28 : return closure_callgenvec(fun, args);
2128 0 : default:
2129 0 : pari_err_TYPE("call", fun);
2130 : return NULL; /* LCOV_EXCL_LINE */
2131 : }
2132 : }
2133 :
2134 : static void
2135 10602 : closurefunc(entree *ep, long n, long mode)
2136 : {
2137 10602 : pari_sp ltop=avma;
2138 : GEN C;
2139 10602 : if (!ep->value) compile_err("unknown function",tree[n].str);
2140 10602 : C = genclosure(ep,tree[n].str,0,1);
2141 10602 : if (!C) compile_err("sorry, closure not implemented",tree[n].str);
2142 10602 : if (C==gen_0)
2143 : {
2144 8903 : compilefunc(ep,n,mode,0);
2145 8903 : return;
2146 : }
2147 1699 : op_push(OCpushgen, data_push(C), n);
2148 1699 : compilecast(n,Gclosure,mode);
2149 1699 : set_avma(ltop);
2150 : }
2151 :
2152 : static void
2153 15213 : compileseq(long n, int mode, long flag)
2154 : {
2155 15213 : pari_sp av = avma;
2156 15213 : GEN L = listtogen(n, Fseq);
2157 15213 : long i, l = lg(L)-1;
2158 48394 : for(i = 1; i < l; i++)
2159 33181 : compilenode(L[i],Gvoid,0);
2160 15213 : compilenode(L[l],mode,flag&(FLreturn|FLsurvive));
2161 15213 : set_avma(av);
2162 15213 : }
2163 :
2164 : static void
2165 52950348 : compilenode(long n, int mode, long flag)
2166 : {
2167 : long x,y;
2168 : #ifdef STACK_CHECK
2169 52950348 : if (PARI_stack_limit && (void*) &x <= PARI_stack_limit)
2170 0 : pari_err(e_MISC, "expression nested too deeply");
2171 : #endif
2172 52950348 : if (n<0) pari_err_BUG("compilenode");
2173 52950348 : x=tree[n].x;
2174 52950348 : y=tree[n].y;
2175 :
2176 52950348 : switch(tree[n].f)
2177 : {
2178 15213 : case Fseq:
2179 15213 : compileseq(n, mode, flag);
2180 52950285 : return;
2181 13595 : case Fmatcoeff:
2182 13595 : compilematcoeff(n,mode);
2183 13588 : if (mode==Ggen && !(flag&FLnocopy))
2184 4283 : op_push(OCcopy,0,n);
2185 13588 : return;
2186 45802 : case Fassign:
2187 45802 : x = detag(x);
2188 45802 : if (tree[x].f==Fvec && tree[x].x>=0)
2189 805 : {
2190 805 : GEN vars = listtogen(tree[x].x,Fmatrixelts);
2191 805 : long i, l = lg(vars)-1, d = mode==Gvoid? l-1: l;
2192 805 : compilenode(y,Ggen,mode==Gvoid?0:flag&FLsurvive);
2193 2513 : for (i=1; i<=l; i++)
2194 1708 : if (tree[vars[i]].f==Fnoarg) d--;
2195 805 : if (d) op_push(OCdup, d, x);
2196 2513 : for(i=1; i<=l; i++)
2197 1708 : if (tree[vars[i]].f!=Fnoarg)
2198 : {
2199 1694 : long a = detag(vars[i]);
2200 1694 : entree *ep=getlvalue(a);
2201 1694 : long vn=getmvar(ep);
2202 1694 : op_push(OCpushlong,i,a);
2203 1694 : op_push(OCcompo1,Ggen,a);
2204 1694 : if (tree[a].f==Fentry)
2205 1687 : compilestore(vn,ep,n);
2206 : else
2207 : {
2208 7 : compilenewptr(vn,ep,n);
2209 7 : compilelvalue(a);
2210 7 : op_push(OCstoreptr,0,a);
2211 : }
2212 : }
2213 805 : if (mode!=Gvoid)
2214 462 : compilecast(n,Ggen,mode);
2215 : }
2216 : else
2217 : {
2218 44997 : entree *ep=getlvalue(x);
2219 44997 : long vn=getmvar(ep);
2220 44997 : if (tree[x].f!=Fentry)
2221 : {
2222 637 : compilenewptr(vn,ep,n);
2223 637 : compilelvalue(x);
2224 : }
2225 44997 : compilenode(y,Ggen,mode==Gvoid?FLnocopy:flag&FLsurvive);
2226 44997 : if (mode!=Gvoid)
2227 29738 : op_push(OCdup,1,n);
2228 44997 : if (tree[x].f==Fentry)
2229 44360 : compilestore(vn,ep,n);
2230 : else
2231 637 : op_push(OCstoreptr,0,x);
2232 44997 : if (mode!=Gvoid)
2233 29738 : compilecast(n,Ggen,mode);
2234 : }
2235 45802 : return;
2236 4775570 : case Fconst:
2237 : {
2238 4775570 : pari_sp ltop=avma;
2239 4775570 : if (tree[n].x!=CSTquote)
2240 : {
2241 4771766 : if (mode==Gvoid) return;
2242 4771766 : if (mode==Gvar) compile_varerr(tree[n].str);
2243 : }
2244 4775570 : if (mode==Gsmall) L_compile_err(tree[n].str);
2245 4775570 : if (mode==Gusmall && tree[n].x != CSTint) U_compile_err(tree[n].str);
2246 4775563 : switch(tree[n].x)
2247 : {
2248 6290 : case CSTreal:
2249 6290 : op_push(OCpushreal, data_push(strntoGENstr(tree[n].str,tree[n].len)),n);
2250 6290 : break;
2251 943190 : case CSTint:
2252 943190 : op_push(OCpushgen, data_push(strtoi((char*)tree[n].str)),n);
2253 943190 : compilecast(n,Ggen, mode);
2254 943190 : break;
2255 3822279 : case CSTstr:
2256 3822279 : op_push(OCpushgen, data_push(strntoGENexp(tree[n].str,tree[n].len)),n);
2257 3822279 : break;
2258 3804 : case CSTquote:
2259 : { /* skip ' */
2260 3804 : entree *ep = fetch_entry_raw(tree[n].str+1,tree[n].len-1);
2261 3804 : if (EpSTATIC(ep)) compile_varerr(tree[n].str+1);
2262 3804 : op_push(OCpushvar, (long)ep,n);
2263 3804 : compilecast(n,Ggen, mode);
2264 3804 : break;
2265 : }
2266 0 : default:
2267 0 : pari_err_BUG("compilenode, unsupported constant");
2268 : }
2269 4775563 : set_avma(ltop);
2270 4775563 : return;
2271 : }
2272 21556817 : case Fsmall:
2273 21556817 : compilesmall(n, x, mode);
2274 21556810 : return;
2275 15455922 : case Fvec:
2276 15455922 : compilevec(n, mode, OCvec);
2277 15455922 : return;
2278 9680 : case Fmat:
2279 9680 : compilemat(n, mode);
2280 9680 : return;
2281 0 : case Frefarg:
2282 0 : compile_err("unexpected character '&':",tree[n].str);
2283 0 : return;
2284 0 : case Findarg:
2285 0 : compile_err("unexpected character '~':",tree[n].str);
2286 0 : return;
2287 285177 : case Fentry:
2288 : {
2289 285177 : entree *ep=getentry(n);
2290 285177 : long vn=getmvar(ep);
2291 285177 : if (vn)
2292 : {
2293 73304 : access_push(vn);
2294 73304 : op_push(OCpushlex,(long)vn,n);
2295 73304 : addcopy(n,mode,flag,FLnocopy|FLnocopylex);
2296 73304 : compilecast(n,Ggen,mode);
2297 : }
2298 211873 : else if (ep->valence==EpVAR || ep->valence==EpNEW)
2299 : {
2300 201271 : if (DEBUGLEVEL && mode==Gvoid)
2301 0 : pari_warn(warner,"statement with no effect: `%s'",ep->name);
2302 201271 : op_push(OCpushdyn,(long)ep,n);
2303 201271 : addcopy(n,mode,flag,FLnocopy);
2304 201271 : compilecast(n,Ggen,mode);
2305 : }
2306 : else
2307 10602 : closurefunc(ep,n,mode);
2308 285177 : return;
2309 : }
2310 10782591 : case Ffunction:
2311 : {
2312 10782591 : entree *ep=getfunc(n);
2313 10782591 : if (getmvar(ep) || EpVALENCE(ep)==EpVAR || EpVALENCE(ep)==EpNEW)
2314 : {
2315 23046 : if (tree[n].x<OPnboperator) /* should not happen */
2316 0 : compile_err("operator unknown",tree[n].str);
2317 23046 : compilecall(n,mode,ep);
2318 : }
2319 : else
2320 10759545 : compilefunc(ep,n,mode,flag);
2321 10782549 : return;
2322 : }
2323 329 : case Fcall:
2324 329 : compilecall(n,mode,NULL);
2325 329 : return;
2326 9365 : case Flambda:
2327 : {
2328 9365 : pari_sp ltop=avma;
2329 : struct codepos pos;
2330 9365 : GEN arg=listtogen(x,Flistarg);
2331 9365 : long nb, lgarg, nbmvar, dovararg=0, gap;
2332 9365 : long strict = GP_DATA->strictargs;
2333 9365 : GEN vep = cgetg_copy(arg, &lgarg);
2334 9365 : GEN text=cgetg(3,t_VEC);
2335 9365 : gel(text,1)=strntoGENstr(tree[x].str,tree[x].len);
2336 9365 : if (lgarg==2 && tree[x].str[0]!='~' && tree[x].f==Findarg)
2337 : /* This occurs for member functions */
2338 14 : gel(text,1)=shallowconcat(strntoGENstr("~",1),gel(text,1));
2339 9365 : gel(text,2)=strntoGENstr(tree[y].str,tree[y].len);
2340 9365 : getcodepos(&pos);
2341 9365 : dbgstart=tree[x].str+tree[x].len;
2342 9365 : gap = tree[y].str-dbgstart;
2343 9365 : nbmvar = nblex;
2344 9365 : ctxmvar(nbmvar);
2345 9365 : nb = lgarg-1;
2346 9365 : if (nb)
2347 : {
2348 : long i;
2349 13702 : for(i=1;i<=nb;i++)
2350 : {
2351 8421 : long a = arg[i], f = tree[a].f;
2352 8421 : if (i==nb && f==Fvararg)
2353 : {
2354 21 : dovararg=1;
2355 21 : vep[i]=(long)getvar(tree[a].x);
2356 : }
2357 : else
2358 8400 : vep[i]=(long)getvar(f==Fassign||f==Findarg?tree[a].x:a);
2359 8421 : var_push(NULL,Lmy);
2360 : }
2361 5281 : checkdups(arg,vep);
2362 5281 : op_push(OCgetargs,nb,x);
2363 5281 : access_push(lg(vep)-1);
2364 5281 : frame_push(vep);
2365 13702 : for (i=1;i<=nb;i++)
2366 : {
2367 8421 : long a = arg[i], f = tree[a].f;
2368 8421 : long y = tree[a].y;
2369 8421 : if (f==Fassign && (strict || !is_node_zero(y)))
2370 : {
2371 385 : if (tree[y].f==Fsmall)
2372 294 : compilenode(y, Ggen, 0);
2373 : else
2374 : {
2375 : struct codepos lpos;
2376 91 : long nbmvar = nblex;
2377 91 : getcodepos(&lpos);
2378 91 : compilenode(y, Ggen, 0);
2379 91 : op_push(OCpushgen, data_push(getclosure(&lpos,nbmvar)),a);
2380 : }
2381 385 : op_push(OCdefaultarg,-nb+i-1,a);
2382 8036 : } else if (f==Findarg)
2383 84 : op_push(OCsetref, -nb+i-1, a);
2384 8421 : localvars[s_lvar.n-nb+i-1].ep=(entree*)vep[i];
2385 : }
2386 : }
2387 9365 : if (strict)
2388 21 : op_push(OCcheckuserargs,nb,x);
2389 9365 : dbgstart=tree[y].str;
2390 9365 : if (y>=0 && tree[y].f!=Fnoarg)
2391 9365 : compilenode(y,Ggen,FLsurvive|FLreturn);
2392 : else
2393 0 : compilecast(n,Gvoid,Ggen);
2394 9365 : if (dovararg) nb|=VARARGBITS;
2395 9365 : op_push(OCpushgen, data_push(getfunction(&pos,nb,nbmvar,text,gap)),n);
2396 9365 : if (nbmvar) op_push(OCsaveframe,!!(flag&FLsurvive),n);
2397 9365 : compilecast(n, Gclosure, mode);
2398 9365 : set_avma(ltop);
2399 9365 : return;
2400 : }
2401 0 : case Ftag:
2402 0 : compilenode(x, mode,flag);
2403 0 : return;
2404 7 : case Fnoarg:
2405 7 : compilecast(n,Gvoid,mode);
2406 7 : return;
2407 280 : case Fnorange:
2408 280 : op_push(OCpushlong,LONG_MAX,n);
2409 280 : compilecast(n,Gsmall,mode);
2410 280 : return;
2411 0 : default:
2412 0 : pari_err_BUG("compilenode");
2413 : }
2414 : }
2415 :
2416 : GEN
2417 937076 : gp_closure(long n)
2418 : {
2419 : struct codepos pos;
2420 937076 : getcodepos(&pos);
2421 937076 : dbgstart=tree[n].str;
2422 937076 : compilenode(n,Ggen,FLsurvive|FLreturn);
2423 937034 : return getfunction(&pos,0,0,strntoGENstr(tree[n].str,tree[n].len),0);
2424 : }
2425 :
2426 : GEN
2427 112 : closure_derivn(GEN G, long n)
2428 : {
2429 112 : pari_sp ltop = avma;
2430 : struct codepos pos;
2431 112 : long arity = closure_arity(G);
2432 : const char *code;
2433 : GEN t, text;
2434 :
2435 112 : if (arity == 0 || closure_is_variadic(G)) pari_err_TYPE("derivfun",G);
2436 112 : t = closure_get_text(G);
2437 112 : code = GSTR((typ(t) == t_STR)? t: GENtoGENstr(G));
2438 112 : if (n > 1)
2439 : {
2440 49 : text = cgetg(1+nchar2nlong(9+strlen(code)+n),t_STR);
2441 49 : sprintf(GSTR(text), "derivn(%s,%ld)", code, n);
2442 : }
2443 : else
2444 : {
2445 63 : text = cgetg(1+nchar2nlong(4+strlen(code)),t_STR);
2446 63 : sprintf(GSTR(text), (typ(t) == t_STR)? "%s'": "(%s)'",code);
2447 : }
2448 112 : getcodepos(&pos);
2449 112 : dbgstart = code;
2450 112 : op_push_loc(OCpackargs, arity, code);
2451 112 : op_push_loc(OCpushgen, data_push(G), code);
2452 112 : op_push_loc(OCpushlong, n, code);
2453 112 : op_push_loc(OCprecreal, 0, code);
2454 112 : op_push_loc(OCcallgen, (long)is_entry("_derivfun"), code);
2455 112 : return gc_GEN(ltop, getfunction(&pos, arity, 0, text, 0));
2456 : }
2457 :
2458 : GEN
2459 0 : closure_deriv(GEN G)
2460 0 : { return closure_derivn(G, 1); }
2461 :
2462 : static long
2463 15558599 : vec_optimize(GEN arg)
2464 : {
2465 15558599 : long fl = COsafelex|COsafedyn;
2466 : long i;
2467 64443389 : for (i=1; i<lg(arg); i++)
2468 : {
2469 48884797 : optimizenode(arg[i]);
2470 48884790 : fl &= tree[arg[i]].flags;
2471 : }
2472 15558592 : return fl;
2473 : }
2474 :
2475 : static void
2476 15461683 : optimizevec(long n)
2477 : {
2478 15461683 : pari_sp ltop=avma;
2479 15461683 : long x = tree[n].x;
2480 15461683 : GEN arg = listtogen(x, Fmatrixelts);
2481 15461683 : tree[n].flags = vec_optimize(arg);
2482 15461683 : set_avma(ltop);
2483 15461683 : }
2484 :
2485 : static void
2486 9680 : optimizemat(long n)
2487 : {
2488 9680 : pari_sp ltop = avma;
2489 9680 : long x = tree[n].x;
2490 : long i;
2491 9680 : GEN line = listtogen(x,Fmatrixlines);
2492 9680 : long fl = COsafelex|COsafedyn;
2493 48031 : for(i=1;i<lg(line);i++)
2494 : {
2495 38351 : GEN col=listtogen(line[i],Fmatrixelts);
2496 38351 : fl &= vec_optimize(col);
2497 : }
2498 9680 : set_avma(ltop); tree[n].flags=fl;
2499 9680 : }
2500 :
2501 : static void
2502 14596 : optimizematcoeff(long n)
2503 : {
2504 14596 : long x=tree[n].x;
2505 14596 : long y=tree[n].y;
2506 14596 : long yx=tree[y].x;
2507 14596 : long yy=tree[y].y;
2508 : long fl;
2509 14596 : optimizenode(x);
2510 14596 : optimizenode(yx);
2511 14596 : fl=tree[x].flags&tree[yx].flags;
2512 14596 : if (yy>=0)
2513 : {
2514 1756 : optimizenode(yy);
2515 1756 : fl&=tree[yy].flags;
2516 : }
2517 14596 : tree[n].flags=fl;
2518 14596 : }
2519 :
2520 : static void
2521 10763654 : optimizefunc(entree *ep, long n)
2522 : {
2523 10763654 : pari_sp av=avma;
2524 : long j;
2525 10763654 : long x=tree[n].x;
2526 10763654 : long y=tree[n].y;
2527 : Gtype t;
2528 : PPproto mod;
2529 10763654 : long fl=COsafelex|COsafedyn;
2530 : const char *p;
2531 : char c;
2532 10763654 : GEN arg = listtogen(y,Flistarg);
2533 10763654 : long nb=lg(arg)-1, ret_flag;
2534 10763654 : if (is_func_named(ep,"if") && nb>=4)
2535 112 : ep=is_entry("_multi_if");
2536 10763654 : p = ep->code;
2537 10763654 : if (!p)
2538 3640 : fl=0;
2539 : else
2540 10760014 : (void) get_ret_type(&p, 2, &t, &ret_flag);
2541 10763654 : if (p && *p)
2542 : {
2543 10752933 : j=1;
2544 22985818 : while((mod=parseproto(&p,&c,tree[n].str))!=PPend)
2545 : {
2546 12232913 : if (j<=nb && tree[arg[j]].f!=Fnoarg
2547 12050952 : && (mod==PPdefault || mod==PPdefaultmulti))
2548 64542 : mod=PPstd;
2549 12232913 : switch(mod)
2550 : {
2551 12035953 : case PPstd:
2552 12035953 : if (j>nb) compile_err("too few arguments", tree[n].str+tree[n].len-1);
2553 12035925 : if (tree[arg[j]].f==Fnoarg && c!='I' && c!='E')
2554 0 : compile_err("missing mandatory argument", tree[arg[j]].str);
2555 12035925 : switch(c)
2556 : {
2557 11996603 : case 'G':
2558 : case 'n':
2559 : case 'M':
2560 : case 'L':
2561 : case 'U':
2562 : case 'P':
2563 11996603 : optimizenode(arg[j]);
2564 11996603 : fl&=tree[arg[j++]].flags;
2565 11996603 : break;
2566 20235 : case 'I':
2567 : case 'E':
2568 : case 'J':
2569 20235 : optimizenode(arg[j]);
2570 20235 : fl&=tree[arg[j]].flags;
2571 20235 : tree[arg[j++]].flags=COsafelex|COsafedyn;
2572 20235 : break;
2573 2308 : case '&': case '*':
2574 : {
2575 2308 : long a=arg[j];
2576 2308 : if (c=='&')
2577 : {
2578 1533 : if (tree[a].f!=Frefarg)
2579 0 : compile_err("expected character: '&'", tree[a].str);
2580 1533 : a=tree[a].x;
2581 : }
2582 2308 : optimizenode(a);
2583 2308 : tree[arg[j++]].flags=COsafelex|COsafedyn;
2584 2308 : fl=0;
2585 2308 : break;
2586 : }
2587 560 : case 'W':
2588 : {
2589 560 : long a = tree[arg[j]].f==Findarg ? tree[arg[j]].x: arg[j];
2590 560 : optimizenode(a);
2591 560 : fl=0; j++;
2592 560 : break;
2593 : }
2594 6595 : case 'V':
2595 : case 'r':
2596 6595 : tree[arg[j++]].flags=COsafelex|COsafedyn;
2597 6595 : break;
2598 6867 : case '=':
2599 : {
2600 6867 : long a=arg[j++], y=tree[a].y;
2601 6867 : if (tree[a].f!=Fassign)
2602 0 : compile_err("expected character: '=' instead of",
2603 0 : tree[a].str+tree[a].len);
2604 6867 : optimizenode(y);
2605 6867 : fl&=tree[y].flags;
2606 : }
2607 6867 : break;
2608 2757 : case 's':
2609 2757 : fl &= vec_optimize(cattovec(arg[j++], OPcat));
2610 2757 : break;
2611 0 : default:
2612 0 : pari_err(e_MISC,"Unknown prototype code `%c' for `%.*s'",c,
2613 0 : tree[x].len, tree[x].str);
2614 : }
2615 12035925 : break;
2616 106027 : case PPauto:
2617 106027 : break;
2618 75468 : case PPdefault:
2619 : case PPdefaultmulti:
2620 75468 : if (j<=nb) optimizenode(arg[j++]);
2621 75468 : break;
2622 15465 : case PPstar:
2623 15465 : switch(c)
2624 : {
2625 112 : case 'E':
2626 : {
2627 112 : long n=nb+1-j;
2628 : long k;
2629 574 : for(k=1;k<=n;k++)
2630 : {
2631 462 : optimizenode(arg[j+k-1]);
2632 462 : fl &= tree[arg[j+k-1]].flags;
2633 : }
2634 112 : j=nb+1;
2635 112 : break;
2636 : }
2637 15353 : case 's':
2638 : {
2639 15353 : long n=nb+1-j;
2640 : long k;
2641 37058 : for(k=1;k<=n;k++)
2642 21705 : fl &= vec_optimize(cattovec(arg[j+k-1],OPcat));
2643 15353 : j=nb+1;
2644 15353 : break;
2645 : }
2646 0 : default:
2647 0 : pari_err(e_MISC,"Unknown prototype code `%c*' for `%.*s'",c,
2648 0 : tree[x].len, tree[x].str);
2649 : }
2650 15465 : break;
2651 0 : default:
2652 0 : pari_err_BUG("optimizefun [unknown PPproto]");
2653 : }
2654 : }
2655 10752905 : if (j<=nb)
2656 0 : compile_err("too many arguments",tree[arg[j]].str);
2657 : }
2658 10721 : else (void)vec_optimize(arg);
2659 10763626 : set_avma(av); tree[n].flags=fl;
2660 10763626 : }
2661 :
2662 : static void
2663 23382 : optimizecall(long n)
2664 : {
2665 23382 : pari_sp av=avma;
2666 23382 : long x=tree[n].x;
2667 23382 : long y=tree[n].y;
2668 23382 : GEN arg=listtogen(y,Flistarg);
2669 23382 : optimizenode(x);
2670 23382 : tree[n].flags = COsafelex&tree[x].flags&vec_optimize(arg);
2671 23375 : set_avma(av);
2672 23375 : }
2673 :
2674 : static void
2675 15213 : optimizeseq(long n)
2676 : {
2677 15213 : pari_sp av = avma;
2678 15213 : GEN L = listtogen(n, Fseq);
2679 15213 : long i, l = lg(L)-1, flags=-1L;
2680 63607 : for(i = 1; i <= l; i++)
2681 : {
2682 48394 : optimizenode(L[i]);
2683 48394 : flags &= tree[L[i]].flags;
2684 : }
2685 15213 : set_avma(av);
2686 15213 : tree[n].flags = flags;
2687 15213 : }
2688 :
2689 : void
2690 62098034 : optimizenode(long n)
2691 : {
2692 : long x,y;
2693 : #ifdef STACK_CHECK
2694 62098034 : if (PARI_stack_limit && (void*) &x <= PARI_stack_limit)
2695 0 : pari_err(e_MISC, "expression nested too deeply");
2696 : #endif
2697 62098034 : if (n<0)
2698 0 : pari_err_BUG("optimizenode");
2699 62098034 : x=tree[n].x;
2700 62098034 : y=tree[n].y;
2701 :
2702 62098034 : switch(tree[n].f)
2703 : {
2704 15213 : case Fseq:
2705 15213 : optimizeseq(n);
2706 62017067 : return;
2707 16352 : case Frange:
2708 16352 : optimizenode(x);
2709 16352 : optimizenode(y);
2710 16352 : tree[n].flags=tree[x].flags&tree[y].flags;
2711 16352 : break;
2712 14596 : case Fmatcoeff:
2713 14596 : optimizematcoeff(n);
2714 14596 : break;
2715 49977 : case Fassign:
2716 49977 : optimizenode(x);
2717 49977 : optimizenode(y);
2718 49977 : tree[n].flags=0;
2719 49977 : break;
2720 35733999 : case Fnoarg:
2721 : case Fnorange:
2722 : case Fsmall:
2723 : case Fconst:
2724 : case Fentry:
2725 35733999 : tree[n].flags=COsafelex|COsafedyn;
2726 35733999 : return;
2727 15461683 : case Fvec:
2728 15461683 : optimizevec(n);
2729 15461683 : return;
2730 9680 : case Fmat:
2731 9680 : optimizemat(n);
2732 9680 : return;
2733 7 : case Frefarg:
2734 7 : compile_err("unexpected character '&'",tree[n].str);
2735 0 : return;
2736 126 : case Findarg:
2737 126 : return;
2738 0 : case Fvararg:
2739 0 : compile_err("unexpected characters '..'",tree[n].str);
2740 0 : return;
2741 10786707 : case Ffunction:
2742 : {
2743 10786707 : entree *ep=getfunc(n);
2744 10786707 : if (EpVALENCE(ep)==EpVAR || EpVALENCE(ep)==EpNEW)
2745 23053 : optimizecall(n);
2746 : else
2747 10763654 : optimizefunc(ep,n);
2748 10786672 : return;
2749 : }
2750 329 : case Fcall:
2751 329 : optimizecall(n);
2752 329 : return;
2753 9365 : case Flambda:
2754 9365 : optimizenode(y);
2755 9365 : tree[n].flags=COsafelex|COsafedyn;
2756 9365 : return;
2757 0 : case Ftag:
2758 0 : optimizenode(x);
2759 0 : tree[n].flags=tree[x].flags;
2760 0 : return;
2761 0 : default:
2762 0 : pari_err_BUG("optimizenode");
2763 : }
2764 : }
|
