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 3822364 : translate(const char **src, char *s)
35 : {
36 3822364 : const char *t = *src;
37 30148648 : while (*t)
38 : {
39 30149296 : 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 30148648 : if (*t == '"')
51 : {
52 3822364 : if (t[1] != '"') break;
53 0 : t += 2; continue;
54 : }
55 26326284 : *s++ = *t++;
56 : }
57 3822364 : *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 3822360 : strntoGENexp(const char *str, long len)
79 : {
80 3822360 : long n = nchar2nlong(len-1);
81 3822360 : GEN z = cgetg(1+n, t_STR);
82 3822360 : const char *t = str+1;
83 3822360 : z[n] = 0;
84 3822360 : if (!translate(&t, GSTR(z))) compile_err("run-away string",str);
85 3822360 : 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 373064 : pari_init_compiler(void)
122 : {
123 373064 : pari_stack_init(&s_opcode,sizeof(*opcode),(void **)&opcode);
124 373059 : pari_stack_init(&s_operand,sizeof(*operand),(void **)&operand);
125 373056 : pari_stack_init(&s_accesslex,sizeof(*operand),(void **)&accesslex);
126 373056 : pari_stack_init(&s_data,sizeof(*data),(void **)&data);
127 373056 : pari_stack_init(&s_lvar,sizeof(*localvars),(void **)&localvars);
128 373055 : pari_stack_init(&s_dbginfo,sizeof(*dbginfo),(void **)&dbginfo);
129 373054 : pari_stack_init(&s_frame,sizeof(*frames),(void **)&frames);
130 373055 : offset=-1; nblex=0;
131 373055 : }
132 : void
133 371407 : pari_close_compiler(void)
134 : {
135 371407 : pari_stack_delete(&s_opcode);
136 370020 : pari_stack_delete(&s_operand);
137 368487 : pari_stack_delete(&s_accesslex);
138 367550 : pari_stack_delete(&s_data);
139 366916 : pari_stack_delete(&s_lvar);
140 366376 : pari_stack_delete(&s_dbginfo);
141 366165 : pari_stack_delete(&s_frame);
142 366072 : }
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 10108204 : getcodepos(struct codepos *pos)
153 : {
154 10108204 : pos->opcode=s_opcode.n;
155 10108204 : pos->accesslex=s_accesslex.n;
156 10108204 : pos->data=s_data.n;
157 10108204 : pos->offset=offset;
158 10108204 : pos->nblex=nblex;
159 10108204 : pos->localvars=s_lvar.n;
160 10108204 : pos->dbgstart=dbgstart;
161 10108204 : pos->frames=s_frame.n;
162 10108204 : offset=s_data.n-1;
163 10108204 : }
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 1431855 : compilestate_save(struct pari_compilestate *comp)
182 : {
183 1431855 : comp->opcode=s_opcode.n;
184 1431855 : comp->operand=s_operand.n;
185 1431855 : comp->accesslex=s_accesslex.n;
186 1431855 : comp->data=s_data.n;
187 1431855 : comp->offset=offset;
188 1431855 : comp->nblex=nblex;
189 1431855 : comp->localvars=s_lvar.n;
190 1431855 : comp->dbgstart=dbgstart;
191 1431855 : comp->dbginfo=s_dbginfo.n;
192 1431855 : comp->frames=s_frame.n;
193 1431855 : }
194 :
195 : void
196 56429 : compilestate_restore(struct pari_compilestate *comp)
197 : {
198 56429 : s_opcode.n=comp->opcode;
199 56429 : s_operand.n=comp->operand;
200 56429 : s_accesslex.n=comp->accesslex;
201 56429 : s_data.n=comp->data;
202 56429 : offset=comp->offset;
203 56429 : nblex=comp->nblex;
204 56429 : s_lvar.n=comp->localvars;
205 56429 : dbgstart=comp->dbgstart;
206 56429 : s_dbginfo.n=comp->dbginfo;
207 56429 : s_frame.n=comp->frames;
208 56429 : }
209 :
210 : static GEN
211 13968644 : gcopyunclone(GEN x) { GEN y = gcopy(x); gunclone(x); return y; }
212 :
213 : static void
214 116741 : access_push(long x)
215 : {
216 116741 : long a = pari_stack_new(&s_accesslex);
217 116741 : accesslex[a] = x;
218 116741 : }
219 :
220 : static GEN
221 9154221 : genctx(long nbmvar, long paccesslex)
222 : {
223 9154221 : GEN acc = const_vec(nbmvar,gen_1);
224 9154239 : long i, lvl = 1 + nbmvar;
225 9196676 : for (i = paccesslex; i<s_accesslex.n; i++)
226 : {
227 42437 : long a = accesslex[i];
228 42437 : if (a > 0) { lvl+=a; continue; }
229 37215 : a += lvl;
230 37215 : if (a <= 0) pari_err_BUG("genctx");
231 37215 : if (a <= nbmvar)
232 28822 : gel(acc, a) = gen_0;
233 : }
234 9154239 : s_accesslex.n = paccesslex;
235 32927326 : for (i = 1; i<=nbmvar; i++)
236 23773084 : if (signe(gel(acc,i))==0)
237 20961 : access_push(i-nbmvar-1);
238 9154242 : return acc;
239 : }
240 :
241 : static GEN
242 10108103 : getfunction(const struct codepos *pos, long arity, long nbmvar, GEN text,
243 : long gap)
244 : {
245 10108103 : long lop = s_opcode.n+1 - pos->opcode;
246 10108103 : long ldat = s_data.n+1 - pos->data;
247 10108103 : long lfram = s_frame.n+1 - pos->frames;
248 10108103 : 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 10108079 : cl[1] = arity;
254 10108079 : gel(cl,2) = cgetg(nchar2nlong(lop)+1, t_STR);
255 10108019 : gel(cl,3) = op = cgetg(lop, t_VECSMALL);
256 10108005 : gel(cl,4) = dat = cgetg(ldat, t_VEC);
257 10108004 : dbg = cgetg(lop, t_VECSMALL);
258 10108001 : frpc = cgetg(lfram, t_VECSMALL);
259 10107991 : fram = cgetg(lfram, t_VEC);
260 10107997 : gel(cl,5) = mkvec3(dbg, frpc, fram);
261 10108029 : if (text) gel(cl,6) = text;
262 10108029 : s = GSTR(gel(cl,2)) - 1;
263 169676030 : for (i = 1; i < lop; i++)
264 : {
265 159568001 : long j = i+pos->opcode-1;
266 159568001 : s[i] = opcode[j];
267 159568001 : op[i] = operand[j];
268 159568001 : dbg[i] = dbginfo[j] - dbgstart;
269 159568001 : if (dbg[i] < 0) dbg[i] += gap;
270 : }
271 10108029 : s[i] = 0;
272 10108029 : s_opcode.n = pos->opcode;
273 10108029 : s_operand.n = pos->opcode;
274 10108029 : s_dbginfo.n = pos->opcode;
275 10108029 : if (lg(cl)==8)
276 9143126 : gel(cl,7) = genctx(nbmvar, pos->accesslex);
277 964903 : else if (nbmvar==0)
278 953895 : s_accesslex.n = pos->accesslex;
279 : else
280 : {
281 11008 : pari_sp av = avma;
282 11008 : (void) genctx(nbmvar, pos->accesslex);
283 11091 : set_avma(av);
284 : }
285 14912627 : for (i = 1; i < ldat; i++)
286 4804505 : if (data[i+pos->data-1]) gel(dat,i) = gcopyunclone(data[i+pos->data-1]);
287 10108122 : s_data.n = pos->data;
288 10137500 : while (s_lvar.n > pos->localvars && !localvars[s_lvar.n-1].inl)
289 : {
290 29378 : if (localvars[s_lvar.n-1].type==Lmy) nblex--;
291 29378 : s_lvar.n--;
292 : }
293 19272376 : for (i = 1; i < lfram; i++)
294 : {
295 9164145 : long j = i+pos->frames-1;
296 9164145 : frpc[i] = frames[j].pc - pos->opcode+1;
297 9164145 : gel(fram, i) = gcopyunclone(frames[j].frame);
298 : }
299 10108231 : s_frame.n = pos->frames;
300 10108231 : offset = pos->offset;
301 10108231 : dbgstart = pos->dbgstart;
302 10108231 : return cl;
303 : }
304 :
305 : static GEN
306 20436 : getclosure(struct codepos *pos, long nbmvar)
307 : {
308 20436 : return getfunction(pos, 0, nbmvar, NULL, 0);
309 : }
310 :
311 : static void
312 159564680 : op_push_loc(op_code o, long x, const char *loc)
313 : {
314 159564680 : long n=pari_stack_new(&s_opcode);
315 159564614 : long m=pari_stack_new(&s_operand);
316 159564556 : long d=pari_stack_new(&s_dbginfo);
317 159564576 : opcode[n]=o;
318 159564576 : operand[m]=x;
319 159564576 : dbginfo[d]=loc;
320 159564576 : }
321 :
322 : static void
323 115722482 : op_push(op_code o, long x, long n)
324 : {
325 115722482 : op_push_loc(o,x,tree[n].str);
326 115722482 : }
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 4804505 : data_push(GEN x)
348 : {
349 4804505 : long n=pari_stack_new(&s_data);
350 4804505 : data[n] = x?gclone(x):x;
351 4804505 : return n-offset;
352 : }
353 :
354 : static void
355 65891 : var_push(entree *ep, Ltype type)
356 : {
357 65891 : long n=pari_stack_new(&s_lvar);
358 65891 : localvars[n].ep = ep;
359 65891 : localvars[n].inl = 0;
360 65891 : localvars[n].type = type;
361 65891 : if (type == Lmy) nblex++;
362 65891 : }
363 :
364 : static void
365 9164177 : frame_push(GEN x)
366 : {
367 9164177 : long n=pari_stack_new(&s_frame);
368 9164170 : frames[n].pc = s_opcode.n-1;
369 9164170 : frames[n].frame = gclone(x);
370 9164245 : }
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 274708 : addcopy(long n, long mode, long flag, long mask)
485 : {
486 274708 : if (mode==Ggen && !(flag&mask))
487 : {
488 27167 : op_push(OCcopy,0,n);
489 27167 : if (!(flag&FLsurvive) && DEBUGLEVEL)
490 0 : pari_warn(warner,"compiler generates copy for `%.*s'",
491 0 : tree[n].len,tree[n].str);
492 : }
493 274708 : }
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 153727933 : parseproto(char const **q, char *c, const char *str)
501 : {
502 153727933 : char const *p=*q;
503 : long i;
504 153727933 : switch(*p)
505 : {
506 39939727 : case 0:
507 : case '\n':
508 39939727 : return PPend;
509 288091 : case 'D':
510 288091 : switch(p[1])
511 : {
512 195483 : 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 195483 : *c=p[1]; *q=p+2; return PPdefault;
524 92608 : default:
525 560388 : for(i=0;*p && i<2;p++) i+=*p==',';
526 : /* assert(i>=2) because check_proto validated the protototype */
527 92608 : *c=p[-2]; *q=p; return PPdefaultmulti;
528 : }
529 : break;
530 143473 : case 'C':
531 : case 'p':
532 : case 'b':
533 : case 'P':
534 : case 'f':
535 143473 : *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 113305144 : *c=*p; *q=p+1; return PPstd;
554 : }
555 :
556 : static long
557 448499 : detag(long n)
558 : {
559 448499 : while (tree[n].f==Ftag)
560 0 : n=tree[n].x;
561 448499 : return n;
562 : }
563 :
564 : /* return type for GP functions */
565 : static op_code
566 21674844 : get_ret_type(const char **p, long arity, Gtype *t, long *flag)
567 : {
568 21674844 : *flag = 0;
569 21674844 : if (**p == 'v') { (*p)++; *t=Gvoid; return OCcallvoid; }
570 21625900 : else if (**p == 'i') { (*p)++; *t=Gsmall; return OCcallint; }
571 21619103 : else if (**p == 'l') { (*p)++; *t=Gsmall; return OCcalllong; }
572 21593067 : else if (**p == 'u') { (*p)++; *t=Gusmall; return OCcalllong; }
573 21593067 : else if (**p == 'm') { (*p)++; *flag = FLnocopy; }
574 21593067 : *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 27755176 : compilecast_loc(int type, int mode, const char *loc)
590 : {
591 27755176 : if (type==mode) return;
592 15528277 : 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 15509871 : case Ggen:
605 15509871 : if (type==Gsmall) op_push_loc(OCstoi,0,loc);
606 15495410 : else if (type==Gusmall)op_push_loc(OCutoi,0,loc);
607 15495410 : else if (type==Gvoid) op_push_loc(OCpushgnil,0,loc);
608 15509871 : 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 18614435 : 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 21935875 : getfunc(long n)
636 : {
637 21935875 : long x=tree[n].x;
638 21935875 : 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 21910612 : return do_alias(fetch_entry_raw(tree[x].str, tree[x].len));
642 : }
643 :
644 : static entree *
645 366094 : getentry(long n)
646 : {
647 366094 : n = detag(n);
648 366094 : 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 366073 : return getfunc(n);
655 : }
656 :
657 : static entree *
658 67725 : getvar(long n)
659 67725 : { 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 11140877 : getmvar(entree *ep)
683 : {
684 : long i;
685 11140877 : long vn=0;
686 12284813 : for(i=s_lvar.n-1;i>=0;i--)
687 : {
688 1224299 : if(localvars[i].type==Lmy)
689 1224026 : vn--;
690 1224299 : if(localvars[i].ep==ep)
691 80363 : return localvars[i].type==Lmy?vn:0;
692 : }
693 11060514 : return 0;
694 : }
695 :
696 : static void
697 9738 : ctxmvar(long n)
698 : {
699 9738 : pari_sp av=avma;
700 : GEN ctx;
701 : long i;
702 9738 : if (n==0) return;
703 4200 : ctx = cgetg(n+1,t_VECSMALL);
704 67648 : for(n=0, i=0; i<s_lvar.n; i++)
705 63448 : if(localvars[i].type==Lmy)
706 63448 : ctx[++n]=(long)localvars[i].ep;
707 4200 : frame_push(ctx);
708 4200 : set_avma(av);
709 : }
710 :
711 : INLINE int
712 118408132 : is_func_named(entree *ep, const char *s)
713 : {
714 118408132 : return !strcmp(ep->name, s);
715 : }
716 :
717 : INLINE int
718 4280 : is_node_zero(long n)
719 : {
720 4280 : n = detag(n);
721 4280 : 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 52642929 : countlisttogen(long n, Ffunc f)
746 : {
747 : long x,i;
748 52642929 : if (n==-1 || tree[n].f==Fnoarg) return 0;
749 122029156 : for(x=n, i=0; tree[x].f==f ;x=tree[x].x, i++);
750 49374166 : return i+1;
751 : }
752 :
753 : static GEN
754 52642929 : listtogen(long n, Ffunc f)
755 : {
756 52642929 : long x,i,nb = countlisttogen(n, f);
757 52642929 : GEN z=cgetg(nb+1, t_VECSMALL);
758 52642929 : if (nb)
759 : {
760 122029156 : for (x=n, i = nb-1; i>0; z[i+1]=tree[x].y, x=tree[x].x, i--);
761 49374166 : z[1]=x;
762 : }
763 52642929 : return z;
764 : }
765 :
766 : static long
767 21591654 : first_safe_arg(GEN arg, long mask)
768 : {
769 21591654 : long lnc, l=lg(arg);
770 45790012 : for (lnc=l-1; lnc>0 && (tree[arg[lnc]].flags&mask)==mask; lnc--);
771 21591654 : return lnc;
772 : }
773 :
774 : static void
775 21009 : checkdups(GEN arg, GEN vep)
776 : {
777 21009 : long l=vecsmall_duplicate(vep);
778 21009 : if (l!=0) compile_err("variable declared twice",tree[arg[l]].str);
779 21009 : }
780 :
781 : enum {MAT_range,MAT_std,MAT_line,MAT_column,VEC_std};
782 :
783 : static int
784 15737 : matindex_type(long n)
785 : {
786 15737 : long x = tree[n].x, y = tree[n].y;
787 15737 : long fxx = tree[tree[x].x].f, fxy = tree[tree[x].y].f;
788 15737 : if (y==-1)
789 : {
790 13659 : if (fxy!=Fnorange) return MAT_range;
791 13050 : if (fxx==Fnorange) compile_err("missing index",tree[n].str);
792 13050 : 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 49678 : getlvalue(long n)
808 : {
809 50686 : while ((tree[n].f==Fmatcoeff && matindex_type(tree[n].y)!=MAT_range) || tree[n].f==Ftag)
810 1008 : n=tree[n].x;
811 49678 : return getvar(n);
812 : }
813 :
814 : INLINE void
815 46054 : compilestore(long vn, entree *ep, long n)
816 : {
817 46054 : if (vn)
818 4779 : 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 46054 : }
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 13609 : compilematcoeff(long n, int mode)
891 : {
892 13609 : long x=tree[n].x, y=tree[n].y;
893 13609 : long yx=tree[y].x, yy=tree[y].y;
894 13609 : long m=matindex_type(y);
895 13609 : compilenode(x,Ggen,FLnocopy);
896 13609 : switch(m)
897 : {
898 11566 : case VEC_std:
899 11566 : compilenode(tree[yx].x,Gsmall,0);
900 11566 : op_push(OCcompo1,mode,y);
901 11566 : 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 30552615 : compilesmall(long n, long x, long mode)
937 : {
938 30552615 : if (mode==Ggen)
939 30465013 : op_push(OCpushstoi, x, n);
940 : else
941 : {
942 87602 : if (mode==Gusmall && x < 0) U_compile_err(tree[n].str);
943 87602 : op_push(OCpushlong, x, n);
944 87602 : compilecast(n,Gsmall,mode);
945 : }
946 30552608 : }
947 :
948 : static void
949 15460514 : compilevec(long n, long mode, op_code op)
950 : {
951 15460514 : pari_sp ltop=avma;
952 15460514 : long x=tree[n].x;
953 : long i;
954 15460514 : GEN arg=listtogen(x,Fmatrixelts);
955 15460514 : long l=lg(arg);
956 15460514 : op_push(op,l,n);
957 64011941 : for (i=1;i<l;i++)
958 : {
959 48551427 : if (tree[arg[i]].f==Fnoarg)
960 0 : compile_err("missing vector element",tree[arg[i]].str);
961 48551427 : compilenode(arg[i],Ggen,FLsurvive);
962 48551427 : op_push(OCstackgen,i,n);
963 : }
964 15460514 : set_avma(ltop);
965 15460514 : op_push(OCpop,1,n);
966 15460514 : compilecast(n,Gvec,mode);
967 15460514 : }
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 20711 : compilefuncinline(long n, long c, long a, long flag, long isif, long lev, long *ev)
1105 : {
1106 : struct codepos pos;
1107 20711 : int type=c=='I'?Gvoid:Ggen;
1108 20711 : long rflag=c=='I'?0:FLsurvive;
1109 20711 : long nbmvar = nblex;
1110 20711 : GEN vep = NULL;
1111 20711 : if (isif && (flag&FLreturn)) rflag|=FLreturn;
1112 20711 : getcodepos(&pos);
1113 20711 : if (c=='J') ctxmvar(nbmvar);
1114 20711 : 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 20704 : if (c=='J')
1170 359 : return compilelambda(a,vep,nbmvar,&pos);
1171 20345 : if (tree[a].f==Fnoarg)
1172 119 : compilecast(a,Gvoid,type);
1173 : else
1174 20226 : compilenode(a,type,rflag);
1175 20345 : return getclosure(&pos, nbmvar);
1176 : }
1177 :
1178 : static long
1179 3594 : countvar(GEN arg)
1180 : {
1181 3594 : long i, l = lg(arg);
1182 3594 : long n = l-1;
1183 11005 : for(i=1; i<l; i++)
1184 : {
1185 7411 : long a=arg[i];
1186 7411 : if (tree[a].f==Fassign)
1187 : {
1188 4175 : long x = detag(tree[a].x);
1189 4175 : if (tree[x].f==Fvec && tree[x].x>=0)
1190 427 : n += countmatrixelts(tree[x].x)-1;
1191 : }
1192 : }
1193 3594 : 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 3566 : compilemy(GEN arg, const char *str, int inl)
1210 : {
1211 3566 : long i, j, k, l = lg(arg);
1212 3566 : long n = countvar(arg);
1213 3566 : GEN vep = cgetg(n+1,t_VECSMALL);
1214 3566 : GEN ver = cgetg(n+1,t_VECSMALL);
1215 3566 : 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 10921 : for(k=0, i=1; i<l; i++)
1222 : {
1223 7355 : long a=arg[i];
1224 7355 : if (tree[a].f==Fassign)
1225 : {
1226 4133 : long x = detag(tree[a].x);
1227 4133 : 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 3720 : } else ver[++k] = x;
1239 3222 : } else ver[++k] = a;
1240 6942 : vep[k] = (long)getvar(ver[k]);
1241 : }
1242 3566 : checkdups(ver,vep);
1243 11460 : for(i=1; i<=n; i++) var_push(NULL,Lmy);
1244 3566 : op_push_loc(OCnewframe,inl?-n:n,str);
1245 3566 : access_push(lg(vep)-1);
1246 3566 : frame_push(vep);
1247 10921 : for (k=0, i=1; i<l; i++)
1248 : {
1249 7355 : long a=arg[i];
1250 7355 : if (tree[a].f==Fassign)
1251 : {
1252 4133 : long x = detag(tree[a].x);
1253 4133 : 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 3720 : else if (!is_node_zero(tree[a].y))
1275 : {
1276 3572 : compilenode(tree[a].y,Ggen,FLnocopy);
1277 3572 : op_push(OCstorelex,-n+k,a);
1278 : }
1279 : }
1280 6942 : k++;
1281 6942 : localvars[s_lvar.n-n+k-1].ep=(entree*)vep[k];
1282 6942 : localvars[s_lvar.n-n+k-1].inl=inl;
1283 : }
1284 3566 : }
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 10768714 : compilefunc(entree *ep, long n, int mode, long flag)
1381 : {
1382 10768714 : pari_sp ltop=avma;
1383 : long j;
1384 10768714 : 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 10768714 : GEN arg=listtogen(y,Flistarg);
1393 10768714 : long lnc=first_safe_arg(arg, COsafelex|COsafedyn);
1394 10768714 : long lnl=first_safe_arg(arg, COsafelex);
1395 10768714 : long nbpointers=0, nbopcodes;
1396 10768714 : long nb=lg(arg)-1, lev=0;
1397 : long ev[20];
1398 10768714 : if (x>=OPnboperator)
1399 207735 : str=tree[x].str;
1400 : else
1401 : {
1402 10560979 : if (nb==2)
1403 1149389 : str=tree[arg[1]].str+tree[arg[1]].len;
1404 9411590 : else if (nb==1)
1405 9410585 : str=tree[arg[1]].str;
1406 : else
1407 1005 : str=tree[n].str;
1408 10567424 : while(*str==')') str++;
1409 : }
1410 10768714 : if (tree[n].f==Fassign)
1411 : {
1412 0 : nb=2; lnc=2; lnl=2; arg=mkvecsmall2(x,y);
1413 : }
1414 10768714 : else if (is_func_named(ep,"if"))
1415 : {
1416 4921 : if (nb>=4)
1417 112 : ep=is_entry("_multi_if");
1418 4809 : else if (mode==Gvoid)
1419 3071 : ep=is_entry("_void_if");
1420 : }
1421 10763793 : 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 9003904 : return;
1427 : }
1428 10763688 : 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 10763675 : 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 10763669 : else if (is_func_named(ep,"my"))
1443 : {
1444 3553 : compilemy(arg, str, 0);
1445 3553 : compilecast(n,Gvoid,mode);
1446 3553 : set_avma(ltop);
1447 3553 : return;
1448 : }
1449 10760116 : 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 10760088 : 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 10760047 : 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 10760041 : 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 10760034 : 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 10755092 : 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 1759490 : else if (x==OPtrans && tree[y].f==Fvec)
1516 : {
1517 4543 : set_avma(ltop);
1518 4543 : compilevec(y, mode, OCcol);
1519 4543 : return;
1520 1754947 : } 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 1754940 : else if (x==OPpow && nb==2)
1528 73319 : {
1529 73319 : long a = arg[2];
1530 73319 : if (tree[a].f==Fsmall)
1531 : {
1532 68556 : 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 1681621 : else if (x==OPcat)
1546 0 : compile_err("expected character: ',' or ')' instead of",
1547 0 : tree[arg[1]].str+tree[arg[1]].len);
1548 1764810 : p=ep->code;
1549 1764810 : if (!ep->value)
1550 0 : compile_err("unknown function",tree[n].str);
1551 1764810 : nbopcodes = s_opcode.n;
1552 1764810 : ret_op = get_ret_type(&p, ep->arity, &ret_typ, &ret_flag);
1553 1764810 : j=1;
1554 1764810 : if (*p)
1555 : {
1556 1755594 : q=p;
1557 4899305 : while((mod=parseproto(&p,&c,tree[n].str))!=PPend)
1558 : {
1559 3143760 : if (j<=nb && tree[arg[j]].f!=Fnoarg
1560 3032169 : && (mod==PPdefault || mod==PPdefaultmulti))
1561 68217 : mod=PPstd;
1562 3143760 : switch(mod)
1563 : {
1564 3017142 : case PPstd:
1565 3017142 : if (j>nb) compile_err("too few arguments", tree[n].str+tree[n].len-1);
1566 3017142 : if (c!='I' && c!='E' && c!='J')
1567 : {
1568 2996893 : long x = tree[arg[j]].x, f = tree[arg[j]].f;
1569 2996893 : if (f==Fnoarg)
1570 0 : compile_err("missing mandatory argument", tree[arg[j]].str);
1571 2996893 : if (f==Fseq)
1572 0 : compile_err("unexpected ';'", tree[x].str+tree[x].len);
1573 : }
1574 3017142 : switch(c)
1575 : {
1576 2896914 : case 'G':
1577 2896914 : compilenode(arg[j],Ggen,j>=lnl?(j>=lnc?FLnocopy:FLnocopylex):0);
1578 2896914 : j++;
1579 2896914 : 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 76651 : compilenode(arg[j++],Gsmall,0);
1615 76644 : 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 20249 : case 'I':
1655 : case 'E':
1656 : case 'J':
1657 : {
1658 20249 : long a = arg[j++];
1659 20249 : GEN d = compilefuncinline(n, c, a, flag, is_func_named(ep,"if"), lev, ev);
1660 20242 : op_push(OCpushgen, data_push(d), a);
1661 20242 : if (lg(d)==8) op_push(OCsaveframe,FLsurvive,n);
1662 20242 : break;
1663 : }
1664 5534 : case 'V':
1665 : {
1666 5534 : long a = arg[j++];
1667 5534 : ev[lev++] = a;
1668 5534 : 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 3017100 : break;
1721 34006 : case PPauto:
1722 34006 : switch(c)
1723 : {
1724 29648 : case 'p':
1725 29648 : op_push(OCprecreal,0,n);
1726 29648 : break;
1727 4305 : case 'b':
1728 4305 : op_push(OCbitprecreal,0,n);
1729 4305 : 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 34006 : break;
1744 44782 : case PPdefault:
1745 44782 : j++;
1746 44782 : switch(c)
1747 : {
1748 6411 : case 'E':
1749 : case 'I':
1750 : {
1751 : long i;
1752 9017 : for (i = 0; i<lev; i++)
1753 2613 : if (ev[i]>=0) getvar(ev[i]);
1754 : }
1755 : case 'G': /*FALLTHROUGH*/
1756 : case '&':
1757 : case 'r':
1758 : case 's':
1759 34449 : op_push(OCpushlong,0,n);
1760 34449 : break;
1761 9025 : case 'n':
1762 9025 : op_push(OCpushlong,-1,n);
1763 9025 : break;
1764 958 : case 'V':
1765 958 : ev[lev++] = -1;
1766 958 : break;
1767 343 : case 'P':
1768 343 : op_push(OCprecdl,0,n);
1769 343 : break;
1770 0 : default:
1771 0 : pari_err(e_MISC,"Unknown prototype code `%c' for `%.*s'",c,
1772 0 : tree[x].len, tree[x].str);
1773 : }
1774 44775 : break;
1775 32365 : case PPdefaultmulti:
1776 32365 : j++;
1777 32365 : switch(c)
1778 : {
1779 0 : case 'G':
1780 0 : op_push(OCpushstoi,strtol(q+1,NULL,10),n);
1781 0 : break;
1782 32284 : case 'L':
1783 : case 'M':
1784 32284 : op_push(OCpushlong,strtol(q+1,NULL,10),n);
1785 32284 : break;
1786 42 : case 'U':
1787 42 : op_push(OCpushlong,(long)strtoul(q+1,NULL,10),n);
1788 42 : break;
1789 39 : case 'r':
1790 : case 's':
1791 39 : str_defproto(p, q, tree[n].str);
1792 39 : op_push(OCtostr, -1, n);
1793 39 : break;
1794 0 : default:
1795 0 : pari_err(e_MISC,"Unknown prototype code `%c' for `%.*s'",c,
1796 0 : tree[x].len, tree[x].str);
1797 : }
1798 32365 : break;
1799 15465 : case PPstar:
1800 15465 : switch(c)
1801 : {
1802 112 : case 'E':
1803 : {
1804 112 : long k, n=nb+1-j;
1805 112 : GEN g=cgetg(n+1,t_VEC);
1806 112 : int ismif = is_func_named(ep,"_multi_if");
1807 574 : for(k=1; k<=n; k++)
1808 528 : gel(g, k) = compilefuncinline(n, c, arg[j+k-1], flag,
1809 462 : ismif && (k==n || odd(k)), lev, ev);
1810 112 : op_push(OCpushgen, data_push(g), arg[j]);
1811 112 : j=nb+1;
1812 112 : break;
1813 : }
1814 15353 : case 's':
1815 : {
1816 15353 : long n=nb+1-j;
1817 : long k,l,l1,m;
1818 15353 : GEN g=cgetg(n+1,t_VEC);
1819 37058 : for(l1=0,k=1;k<=n;k++)
1820 : {
1821 21705 : gel(g,k)=cattovec(arg[j+k-1],OPcat);
1822 21705 : l1+=lg(gel(g,k))-1;
1823 : }
1824 15353 : op_push_loc(OCvec, l1+1, str);
1825 37058 : for(m=1,k=1;k<=n;k++)
1826 43445 : for(l=1;l<lg(gel(g,k));l++,m++)
1827 : {
1828 21740 : compilenode(mael(g,k,l),Ggen,FLsurvive);
1829 21740 : op_push(OCstackgen,m,mael(g,k,l));
1830 : }
1831 15353 : op_push_loc(OCpop, 1, str);
1832 15353 : j=nb+1;
1833 15353 : break;
1834 : }
1835 0 : default:
1836 0 : pari_err(e_MISC,"Unknown prototype code `%c*' for `%.*s'",c,
1837 0 : tree[x].len, tree[x].str);
1838 : }
1839 15465 : break;
1840 0 : default:
1841 0 : pari_err_BUG("compilefunc [unknown PPproto]");
1842 : }
1843 3143711 : q=p;
1844 : }
1845 : }
1846 1764761 : if (j<=nb)
1847 0 : compile_err("too many arguments",tree[arg[j]].str);
1848 1764761 : op_push_loc(ret_op, (long) ep, str);
1849 1764761 : if (mode==Ggen && (ret_flag&FLnocopy) && !(flag&FLnocopy))
1850 10688 : op_push_loc(OCcopy,0,str);
1851 1764761 : if (ret_typ==Ggen && nbpointers==0 && s_opcode.n>nbopcodes+128)
1852 : {
1853 2975 : op_insert_loc(nbopcodes,OCavma,0,str);
1854 2975 : op_push_loc(OCgc,0,str);
1855 : }
1856 1764761 : compilecast(n,ret_typ,mode);
1857 1764761 : if (nbpointers) op_push_loc(OCendptr,nbpointers, str);
1858 1764761 : set_avma(ltop);
1859 : }
1860 :
1861 : static void
1862 9138962 : genclosurectx(const char *loc, long nbdata)
1863 : {
1864 : long i;
1865 9138962 : GEN vep = cgetg(nbdata+1,t_VECSMALL);
1866 32794187 : for(i = 1; i <= nbdata; i++)
1867 : {
1868 23655268 : vep[i] = 0;
1869 23655268 : op_push_loc(OCpushlex,-i,loc);
1870 : }
1871 9138919 : frame_push(vep);
1872 9139024 : }
1873 :
1874 : static GEN
1875 9149796 : genclosure(entree *ep, const char *loc, long nbdata, int check)
1876 : {
1877 : struct codepos pos;
1878 9149796 : long nb=0;
1879 9149796 : const char *code=ep->code,*p,*q;
1880 : char c;
1881 : GEN text;
1882 9149796 : long index=ep->arity;
1883 9149796 : long arity=0, maskarg=0, maskarg0=0, stop=0, dovararg=0;
1884 : PPproto mod;
1885 : Gtype ret_typ;
1886 : long ret_flag;
1887 9149796 : op_code ret_op=get_ret_type(&code,ep->arity,&ret_typ,&ret_flag);
1888 9149765 : p=code;
1889 41955176 : while ((mod=parseproto(&p,&c,NULL))!=PPend)
1890 : {
1891 32805411 : if (mod==PPauto)
1892 2066 : stop=1;
1893 : else
1894 : {
1895 32803345 : if (stop) return NULL;
1896 32803345 : if (c=='V') continue;
1897 32803345 : maskarg<<=1; maskarg0<<=1; arity++;
1898 32803345 : switch(mod)
1899 : {
1900 32802142 : case PPstd:
1901 32802142 : maskarg|=1L;
1902 32802142 : break;
1903 482 : case PPdefault:
1904 482 : switch(c)
1905 : {
1906 28 : case '&':
1907 : case 'E':
1908 : case 'I':
1909 28 : maskarg0|=1L;
1910 28 : break;
1911 : }
1912 482 : break;
1913 721 : default:
1914 721 : break;
1915 : }
1916 : }
1917 : }
1918 9149678 : if (check && EpSTATIC(ep) && maskarg==0)
1919 8917 : return gen_0;
1920 9140761 : getcodepos(&pos);
1921 9140788 : dbgstart = loc;
1922 9140788 : if (nbdata > arity)
1923 0 : pari_err(e_MISC,"too many parameters for closure `%s'", ep->name);
1924 9140788 : if (nbdata) genclosurectx(loc, nbdata);
1925 9140841 : text = strtoGENstr(ep->name);
1926 9140772 : arity -= nbdata;
1927 9140772 : if (maskarg) op_push_loc(OCcheckargs,maskarg,loc);
1928 9140720 : if (maskarg0) op_push_loc(OCcheckargs0,maskarg0,loc);
1929 9140720 : p=code;
1930 41944033 : while ((mod=parseproto(&p,&c,NULL))!=PPend)
1931 : {
1932 32803284 : switch(mod)
1933 : {
1934 666 : case PPauto:
1935 666 : switch(c)
1936 : {
1937 666 : case 'p':
1938 666 : op_push_loc(OCprecreal,0,loc);
1939 666 : break;
1940 0 : case 'b':
1941 0 : op_push_loc(OCbitprecreal,0,loc);
1942 0 : break;
1943 0 : case 'P':
1944 0 : op_push_loc(OCprecdl,0,loc);
1945 0 : break;
1946 0 : case 'C':
1947 0 : op_push_loc(OCpushgen,data_push(pack_localvars()),loc);
1948 29 : break;
1949 0 : case 'f':
1950 : {
1951 : static long foo;
1952 0 : op_push_loc(OCpushlong,(long)&foo,loc);
1953 0 : break;
1954 : }
1955 : }
1956 : default:
1957 32803313 : break;
1958 : }
1959 : }
1960 9140739 : q = p = code;
1961 41944030 : while ((mod=parseproto(&p,&c,NULL))!=PPend)
1962 : {
1963 32803291 : switch(mod)
1964 : {
1965 32801866 : case PPstd:
1966 32801866 : switch(c)
1967 : {
1968 32758380 : case 'G':
1969 32758380 : break;
1970 31999 : case 'M':
1971 : case 'L':
1972 31999 : op_push_loc(OCitos,-index,loc);
1973 31999 : break;
1974 11455 : case 'U':
1975 11455 : op_push_loc(OCitou,-index,loc);
1976 11455 : break;
1977 0 : case 'n':
1978 0 : op_push_loc(OCvarn,-index,loc);
1979 0 : break;
1980 0 : case '&': case '*':
1981 : case 'I':
1982 : case 'E':
1983 : case 'V':
1984 : case '=':
1985 0 : return NULL;
1986 28 : case 'r':
1987 : case 's':
1988 28 : op_push_loc(OCtostr,-index,loc);
1989 28 : break;
1990 : }
1991 32801866 : break;
1992 666 : case PPauto:
1993 666 : break;
1994 412 : case PPdefault:
1995 412 : switch(c)
1996 : {
1997 216 : case 'G':
1998 : case '&':
1999 : case 'E':
2000 : case 'I':
2001 : case 'V':
2002 216 : break;
2003 14 : case 'r':
2004 : case 's':
2005 14 : op_push_loc(OCtostr,-index,loc);
2006 14 : break;
2007 112 : case 'n':
2008 112 : op_push_loc(OCvarn,-index,loc);
2009 112 : break;
2010 70 : case 'P':
2011 70 : op_push_loc(OCprecdl,0,loc);
2012 70 : op_push_loc(OCdefaultlong,-index,loc);
2013 70 : break;
2014 0 : default:
2015 0 : pari_err(e_MISC,"Unknown prototype code `D%c' for `%s'",c,ep->name);
2016 : }
2017 412 : break;
2018 319 : case PPdefaultmulti:
2019 319 : switch(c)
2020 : {
2021 0 : case 'G':
2022 0 : op_push_loc(OCpushstoi,strtol(q+1,NULL,10),loc);
2023 0 : op_push_loc(OCdefaultgen,-index,loc);
2024 0 : break;
2025 319 : case 'L':
2026 : case 'M':
2027 319 : op_push_loc(OCpushlong,strtol(q+1,NULL,10),loc);
2028 319 : op_push_loc(OCdefaultlong,-index,loc);
2029 319 : break;
2030 0 : case 'U':
2031 0 : op_push_loc(OCpushlong,(long)strtoul(q+1,NULL,10),loc);
2032 0 : op_push_loc(OCdefaultulong,-index,loc);
2033 0 : break;
2034 0 : case 'r':
2035 : case 's':
2036 0 : str_defproto(p, q, loc);
2037 0 : op_push_loc(OCdefaultgen,-index,loc);
2038 0 : op_push_loc(OCtostr,-index,loc);
2039 0 : break;
2040 0 : default:
2041 0 : pari_err(e_MISC,
2042 : "Unknown prototype code `D...,%c,' for `%s'",c,ep->name);
2043 : }
2044 319 : break;
2045 28 : case PPstar:
2046 28 : switch(c)
2047 : {
2048 28 : case 's':
2049 28 : dovararg = 1;
2050 28 : break;
2051 0 : case 'E':
2052 0 : return NULL;
2053 0 : default:
2054 0 : pari_err(e_MISC,"Unknown prototype code `%c*' for `%s'",c,ep->name);
2055 : }
2056 28 : break;
2057 0 : default:
2058 0 : return NULL;
2059 : }
2060 32803291 : index--;
2061 32803291 : q = p;
2062 : }
2063 9140686 : op_push_loc(ret_op, (long) ep, loc);
2064 9140742 : if (ret_flag==FLnocopy) op_push_loc(OCcopy,0,loc);
2065 9140742 : compilecast_loc(ret_typ, Ggen, loc);
2066 9140739 : if (dovararg) nb|=VARARGBITS;
2067 9140739 : return getfunction(&pos,nb+arity,nbdata,text,0);
2068 : }
2069 :
2070 : GEN
2071 9137353 : snm_closure(entree *ep, GEN data)
2072 : {
2073 9137353 : long i, n = data ? lg(data)-1: 0;
2074 9137353 : GEN C = genclosure(ep,ep->name,n,0);
2075 32786151 : for(i = 1; i <= n; i++) gmael(C,7,i) = gel(data,i);
2076 9137332 : return C;
2077 : }
2078 :
2079 : GEN
2080 1820 : strtoclosure(const char *s, long n, ...)
2081 : {
2082 1820 : pari_sp av = avma;
2083 1820 : entree *ep = is_entry(s);
2084 : GEN C;
2085 1820 : if (!ep) pari_err(e_NOTFUNC, strtoGENstr(s));
2086 1820 : ep = do_alias(ep);
2087 1820 : if ((!EpSTATIC(ep) && EpVALENCE(ep)!=EpINSTALL) || !ep->value)
2088 0 : pari_err(e_MISC,"not a built-in/install'ed function: \"%s\"",s);
2089 1820 : C = genclosure(ep,ep->name,n,0);
2090 1820 : if (!C) pari_err(e_MISC,"function prototype unsupported: \"%s\"",s);
2091 : else
2092 : {
2093 : va_list ap;
2094 : long i;
2095 1820 : va_start(ap,n);
2096 8624 : for(i = 1; i <= n; i++) gmael(C,7,i) = va_arg(ap, GEN);
2097 1820 : va_end(ap);
2098 : }
2099 1820 : return gc_GEN(av, C);
2100 : }
2101 :
2102 : GEN
2103 0 : closuretoinl(GEN C)
2104 : {
2105 0 : long i, n = closure_arity(C);
2106 0 : GEN text = closure_get_text(C);
2107 : struct codepos pos;
2108 : const char *loc;
2109 0 : getcodepos(&pos);
2110 0 : if (typ(text)==t_VEC) text = gel(text, 2);
2111 0 : loc = GSTR(text);
2112 0 : dbgstart = loc;
2113 0 : op_push_loc(OCpushgen, data_push(C), loc);
2114 0 : for (i = n; i >= 1 ; i--)
2115 0 : op_push_loc(OCpushlex, -i, loc);
2116 0 : op_push_loc(OCcalluser, n, loc);
2117 0 : return getfunction(&pos,0,0,text,0);
2118 : }
2119 :
2120 : GEN
2121 119 : strtofunction(const char *s) { return strtoclosure(s, 0); }
2122 :
2123 : GEN
2124 28 : call0(GEN fun, GEN args)
2125 : {
2126 28 : if (!is_vec_t(typ(args))) pari_err_TYPE("call",args);
2127 28 : switch(typ(fun))
2128 : {
2129 7 : case t_STR:
2130 7 : fun = strtofunction(GSTR(fun));
2131 28 : case t_CLOSURE: /* fall through */
2132 28 : return closure_callgenvec(fun, args);
2133 0 : default:
2134 0 : pari_err_TYPE("call", fun);
2135 : return NULL; /* LCOV_EXCL_LINE */
2136 : }
2137 : }
2138 :
2139 : static void
2140 10616 : closurefunc(entree *ep, long n, long mode)
2141 : {
2142 10616 : pari_sp ltop=avma;
2143 : GEN C;
2144 10616 : if (!ep->value) compile_err("unknown function",tree[n].str);
2145 10616 : C = genclosure(ep,tree[n].str,0,1);
2146 10616 : if (!C) compile_err("sorry, closure not implemented",tree[n].str);
2147 10616 : if (C==gen_0)
2148 : {
2149 8917 : compilefunc(ep,n,mode,0);
2150 8917 : return;
2151 : }
2152 1699 : op_push(OCpushgen, data_push(C), n);
2153 1699 : compilecast(n,Gclosure,mode);
2154 1699 : set_avma(ltop);
2155 : }
2156 :
2157 : static void
2158 15220 : compileseq(long n, int mode, long flag)
2159 : {
2160 15220 : pari_sp av = avma;
2161 15220 : GEN L = listtogen(n, Fseq);
2162 15220 : long i, l = lg(L)-1;
2163 48422 : for(i = 1; i < l; i++)
2164 33202 : compilenode(L[i],Gvoid,0);
2165 15220 : compilenode(L[l],mode,flag&(FLreturn|FLsurvive));
2166 15220 : set_avma(av);
2167 15220 : }
2168 :
2169 : static void
2170 52951041 : compilenode(long n, int mode, long flag)
2171 : {
2172 : long x,y;
2173 : #ifdef STACK_CHECK
2174 52951041 : if (PARI_stack_limit && (void*) &x <= PARI_stack_limit)
2175 0 : pari_err(e_MISC, "expression nested too deeply");
2176 : #endif
2177 52951041 : if (n<0) pari_err_BUG("compilenode");
2178 52951041 : x=tree[n].x;
2179 52951041 : y=tree[n].y;
2180 :
2181 52951041 : switch(tree[n].f)
2182 : {
2183 15220 : case Fseq:
2184 15220 : compileseq(n, mode, flag);
2185 52950971 : return;
2186 13609 : case Fmatcoeff:
2187 13609 : compilematcoeff(n,mode);
2188 13602 : if (mode==Ggen && !(flag&FLnocopy))
2189 4283 : op_push(OCcopy,0,n);
2190 13602 : return;
2191 45809 : case Fassign:
2192 45809 : x = detag(x);
2193 45809 : if (tree[x].f==Fvec && tree[x].x>=0)
2194 805 : {
2195 805 : GEN vars = listtogen(tree[x].x,Fmatrixelts);
2196 805 : long i, l = lg(vars)-1, d = mode==Gvoid? l-1: l;
2197 805 : compilenode(y,Ggen,mode==Gvoid?0:flag&FLsurvive);
2198 2513 : for (i=1; i<=l; i++)
2199 1708 : if (tree[vars[i]].f==Fnoarg) d--;
2200 805 : if (d) op_push(OCdup, d, x);
2201 2513 : for(i=1; i<=l; i++)
2202 1708 : if (tree[vars[i]].f!=Fnoarg)
2203 : {
2204 1694 : long a = detag(vars[i]);
2205 1694 : entree *ep=getlvalue(a);
2206 1694 : long vn=getmvar(ep);
2207 1694 : op_push(OCpushlong,i,a);
2208 1694 : op_push(OCcompo1,Ggen,a);
2209 1694 : if (tree[a].f==Fentry)
2210 1687 : compilestore(vn,ep,n);
2211 : else
2212 : {
2213 7 : compilenewptr(vn,ep,n);
2214 7 : compilelvalue(a);
2215 7 : op_push(OCstoreptr,0,a);
2216 : }
2217 : }
2218 805 : if (mode!=Gvoid)
2219 462 : compilecast(n,Ggen,mode);
2220 : }
2221 : else
2222 : {
2223 45004 : entree *ep=getlvalue(x);
2224 45004 : long vn=getmvar(ep);
2225 45004 : if (tree[x].f!=Fentry)
2226 : {
2227 637 : compilenewptr(vn,ep,n);
2228 637 : compilelvalue(x);
2229 : }
2230 45004 : compilenode(y,Ggen,mode==Gvoid?FLnocopy:flag&FLsurvive);
2231 45004 : if (mode!=Gvoid)
2232 29738 : op_push(OCdup,1,n);
2233 45004 : if (tree[x].f==Fentry)
2234 44367 : compilestore(vn,ep,n);
2235 : else
2236 637 : op_push(OCstoreptr,0,x);
2237 45004 : if (mode!=Gvoid)
2238 29738 : compilecast(n,Ggen,mode);
2239 : }
2240 45809 : return;
2241 4775577 : case Fconst:
2242 : {
2243 4775577 : pari_sp ltop=avma;
2244 4775577 : if (tree[n].x!=CSTquote)
2245 : {
2246 4771773 : if (mode==Gvoid) return;
2247 4771773 : if (mode==Gvar) compile_varerr(tree[n].str);
2248 : }
2249 4775577 : if (mode==Gsmall) L_compile_err(tree[n].str);
2250 4775577 : if (mode==Gusmall && tree[n].x != CSTint) U_compile_err(tree[n].str);
2251 4775570 : switch(tree[n].x)
2252 : {
2253 6290 : case CSTreal:
2254 6290 : op_push(OCpushreal, data_push(strntoGENstr(tree[n].str,tree[n].len)),n);
2255 6290 : break;
2256 943190 : case CSTint:
2257 943190 : op_push(OCpushgen, data_push(strtoi((char*)tree[n].str)),n);
2258 943190 : compilecast(n,Ggen, mode);
2259 943190 : break;
2260 3822286 : case CSTstr:
2261 3822286 : op_push(OCpushgen, data_push(strntoGENexp(tree[n].str,tree[n].len)),n);
2262 3822286 : break;
2263 3804 : case CSTquote:
2264 : { /* skip ' */
2265 3804 : entree *ep = fetch_entry_raw(tree[n].str+1,tree[n].len-1);
2266 3804 : if (EpSTATIC(ep)) compile_varerr(tree[n].str+1);
2267 3804 : op_push(OCpushvar, (long)ep,n);
2268 3804 : compilecast(n,Ggen, mode);
2269 3804 : break;
2270 : }
2271 0 : default:
2272 0 : pari_err_BUG("compilenode, unsupported constant");
2273 : }
2274 4775570 : set_avma(ltop);
2275 4775570 : return;
2276 : }
2277 21557013 : case Fsmall:
2278 21557013 : compilesmall(n, x, mode);
2279 21557006 : return;
2280 15455971 : case Fvec:
2281 15455971 : compilevec(n, mode, OCvec);
2282 15455971 : return;
2283 9680 : case Fmat:
2284 9680 : compilemat(n, mode);
2285 9680 : return;
2286 0 : case Frefarg:
2287 0 : compile_err("unexpected character '&':",tree[n].str);
2288 0 : return;
2289 0 : case Findarg:
2290 0 : compile_err("unexpected character '~':",tree[n].str);
2291 0 : return;
2292 285324 : case Fentry:
2293 : {
2294 285324 : entree *ep=getentry(n);
2295 285324 : long vn=getmvar(ep);
2296 285324 : if (vn)
2297 : {
2298 73346 : access_push(vn);
2299 73346 : op_push(OCpushlex,(long)vn,n);
2300 73346 : addcopy(n,mode,flag,FLnocopy|FLnocopylex);
2301 73346 : compilecast(n,Ggen,mode);
2302 : }
2303 211978 : else if (ep->valence==EpVAR || ep->valence==EpNEW)
2304 : {
2305 201362 : if (DEBUGLEVEL && mode==Gvoid)
2306 0 : pari_warn(warner,"statement with no effect: `%s'",ep->name);
2307 201362 : op_push(OCpushdyn,(long)ep,n);
2308 201362 : addcopy(n,mode,flag,FLnocopy);
2309 201362 : compilecast(n,Ggen,mode);
2310 : }
2311 : else
2312 10616 : closurefunc(ep,n,mode);
2313 285324 : return;
2314 : }
2315 10782843 : case Ffunction:
2316 : {
2317 10782843 : entree *ep=getfunc(n);
2318 10782843 : if (getmvar(ep) || EpVALENCE(ep)==EpVAR || EpVALENCE(ep)==EpNEW)
2319 : {
2320 23046 : if (tree[n].x<OPnboperator) /* should not happen */
2321 0 : compile_err("operator unknown",tree[n].str);
2322 23046 : compilecall(n,mode,ep);
2323 : }
2324 : else
2325 10759797 : compilefunc(ep,n,mode,flag);
2326 10782794 : return;
2327 : }
2328 329 : case Fcall:
2329 329 : compilecall(n,mode,NULL);
2330 329 : return;
2331 9379 : case Flambda:
2332 : {
2333 9379 : pari_sp ltop=avma;
2334 : struct codepos pos;
2335 9379 : GEN arg=listtogen(x,Flistarg);
2336 9379 : long nb, lgarg, nbmvar, dovararg=0, gap;
2337 9379 : long strict = GP_DATA->strictargs;
2338 9379 : GEN vep = cgetg_copy(arg, &lgarg);
2339 9379 : GEN text=cgetg(3,t_VEC);
2340 9379 : gel(text,1)=strntoGENstr(tree[x].str,tree[x].len);
2341 9379 : if (lgarg==2 && tree[x].str[0]!='~' && tree[x].f==Findarg)
2342 : /* This occurs for member functions */
2343 14 : gel(text,1)=shallowconcat(strntoGENstr("~",1),gel(text,1));
2344 9379 : gel(text,2)=strntoGENstr(tree[y].str,tree[y].len);
2345 9379 : getcodepos(&pos);
2346 9379 : dbgstart=tree[x].str+tree[x].len;
2347 9379 : gap = tree[y].str-dbgstart;
2348 9379 : nbmvar = nblex;
2349 9379 : ctxmvar(nbmvar);
2350 9379 : nb = lgarg-1;
2351 9379 : if (nb)
2352 : {
2353 : long i;
2354 13702 : for(i=1;i<=nb;i++)
2355 : {
2356 8421 : long a = arg[i], f = tree[a].f;
2357 8421 : if (i==nb && f==Fvararg)
2358 : {
2359 21 : dovararg=1;
2360 21 : vep[i]=(long)getvar(tree[a].x);
2361 : }
2362 : else
2363 8400 : vep[i]=(long)getvar(f==Fassign||f==Findarg?tree[a].x:a);
2364 8421 : var_push(NULL,Lmy);
2365 : }
2366 5281 : checkdups(arg,vep);
2367 5281 : op_push(OCgetargs,nb,x);
2368 5281 : access_push(lg(vep)-1);
2369 5281 : frame_push(vep);
2370 13702 : for (i=1;i<=nb;i++)
2371 : {
2372 8421 : long a = arg[i], f = tree[a].f;
2373 8421 : long y = tree[a].y;
2374 8421 : if (f==Fassign && (strict || !is_node_zero(y)))
2375 : {
2376 385 : if (tree[y].f==Fsmall)
2377 294 : compilenode(y, Ggen, 0);
2378 : else
2379 : {
2380 : struct codepos lpos;
2381 91 : long nbmvar = nblex;
2382 91 : getcodepos(&lpos);
2383 91 : compilenode(y, Ggen, 0);
2384 91 : op_push(OCpushgen, data_push(getclosure(&lpos,nbmvar)),a);
2385 : }
2386 385 : op_push(OCdefaultarg,-nb+i-1,a);
2387 8036 : } else if (f==Findarg)
2388 84 : op_push(OCsetref, -nb+i-1, a);
2389 8421 : localvars[s_lvar.n-nb+i-1].ep=(entree*)vep[i];
2390 : }
2391 : }
2392 9379 : if (strict)
2393 21 : op_push(OCcheckuserargs,nb,x);
2394 9379 : dbgstart=tree[y].str;
2395 9379 : if (y>=0 && tree[y].f!=Fnoarg)
2396 9379 : compilenode(y,Ggen,FLsurvive|FLreturn);
2397 : else
2398 0 : compilecast(n,Gvoid,Ggen);
2399 9379 : if (dovararg) nb|=VARARGBITS;
2400 9379 : op_push(OCpushgen, data_push(getfunction(&pos,nb,nbmvar,text,gap)),n);
2401 9379 : if (nbmvar) op_push(OCsaveframe,!!(flag&FLsurvive),n);
2402 9379 : compilecast(n, Gclosure, mode);
2403 9379 : set_avma(ltop);
2404 9379 : return;
2405 : }
2406 0 : case Ftag:
2407 0 : compilenode(x, mode,flag);
2408 0 : return;
2409 7 : case Fnoarg:
2410 7 : compilecast(n,Gvoid,mode);
2411 7 : return;
2412 280 : case Fnorange:
2413 280 : op_push(OCpushlong,LONG_MAX,n);
2414 280 : compilecast(n,Gsmall,mode);
2415 280 : return;
2416 0 : default:
2417 0 : pari_err_BUG("compilenode");
2418 : }
2419 : }
2420 :
2421 : GEN
2422 937125 : gp_closure(long n)
2423 : {
2424 : struct codepos pos;
2425 937125 : getcodepos(&pos);
2426 937125 : dbgstart=tree[n].str;
2427 937125 : compilenode(n,Ggen,FLsurvive|FLreturn);
2428 937076 : return getfunction(&pos,0,0,strntoGENstr(tree[n].str,tree[n].len),0);
2429 : }
2430 :
2431 : GEN
2432 112 : closure_derivn(GEN G, long n)
2433 : {
2434 112 : pari_sp ltop = avma;
2435 : struct codepos pos;
2436 112 : long arity = closure_arity(G);
2437 : const char *code;
2438 : GEN t, text;
2439 :
2440 112 : if (arity == 0 || closure_is_variadic(G)) pari_err_TYPE("derivfun",G);
2441 112 : t = closure_get_text(G);
2442 112 : code = GSTR((typ(t) == t_STR)? t: GENtoGENstr(G));
2443 112 : if (n > 1)
2444 : {
2445 49 : text = cgetg(1+nchar2nlong(9+strlen(code)+n),t_STR);
2446 49 : sprintf(GSTR(text), "derivn(%s,%ld)", code, n);
2447 : }
2448 : else
2449 : {
2450 63 : text = cgetg(1+nchar2nlong(4+strlen(code)),t_STR);
2451 63 : sprintf(GSTR(text), (typ(t) == t_STR)? "%s'": "(%s)'",code);
2452 : }
2453 112 : getcodepos(&pos);
2454 112 : dbgstart = code;
2455 112 : op_push_loc(OCpackargs, arity, code);
2456 112 : op_push_loc(OCpushgen, data_push(G), code);
2457 112 : op_push_loc(OCpushlong, n, code);
2458 112 : op_push_loc(OCprecreal, 0, code);
2459 112 : op_push_loc(OCcallgen, (long)is_entry("_derivfun"), code);
2460 112 : return gc_GEN(ltop, getfunction(&pos, arity, 0, text, 0));
2461 : }
2462 :
2463 : GEN
2464 0 : closure_deriv(GEN G)
2465 0 : { return closure_derivn(G, 1); }
2466 :
2467 : static long
2468 15558676 : vec_optimize(GEN arg)
2469 : {
2470 15558676 : long fl = COsafelex|COsafedyn;
2471 : long i;
2472 64443634 : for (i=1; i<lg(arg); i++)
2473 : {
2474 48884965 : optimizenode(arg[i]);
2475 48884958 : fl &= tree[arg[i]].flags;
2476 : }
2477 15558669 : return fl;
2478 : }
2479 :
2480 : static void
2481 15461746 : optimizevec(long n)
2482 : {
2483 15461746 : pari_sp ltop=avma;
2484 15461746 : long x = tree[n].x;
2485 15461746 : GEN arg = listtogen(x, Fmatrixelts);
2486 15461746 : tree[n].flags = vec_optimize(arg);
2487 15461746 : set_avma(ltop);
2488 15461746 : }
2489 :
2490 : static void
2491 9680 : optimizemat(long n)
2492 : {
2493 9680 : pari_sp ltop = avma;
2494 9680 : long x = tree[n].x;
2495 : long i;
2496 9680 : GEN line = listtogen(x,Fmatrixlines);
2497 9680 : long fl = COsafelex|COsafedyn;
2498 48031 : for(i=1;i<lg(line);i++)
2499 : {
2500 38351 : GEN col=listtogen(line[i],Fmatrixelts);
2501 38351 : fl &= vec_optimize(col);
2502 : }
2503 9680 : set_avma(ltop); tree[n].flags=fl;
2504 9680 : }
2505 :
2506 : static void
2507 14610 : optimizematcoeff(long n)
2508 : {
2509 14610 : long x=tree[n].x;
2510 14610 : long y=tree[n].y;
2511 14610 : long yx=tree[y].x;
2512 14610 : long yy=tree[y].y;
2513 : long fl;
2514 14610 : optimizenode(x);
2515 14610 : optimizenode(yx);
2516 14610 : fl=tree[x].flags&tree[yx].flags;
2517 14610 : if (yy>=0)
2518 : {
2519 1756 : optimizenode(yy);
2520 1756 : fl&=tree[yy].flags;
2521 : }
2522 14610 : tree[n].flags=fl;
2523 14610 : }
2524 :
2525 : static void
2526 10763906 : optimizefunc(entree *ep, long n)
2527 : {
2528 10763906 : pari_sp av=avma;
2529 : long j;
2530 10763906 : long x=tree[n].x;
2531 10763906 : long y=tree[n].y;
2532 : Gtype t;
2533 : PPproto mod;
2534 10763906 : long fl=COsafelex|COsafedyn;
2535 : const char *p;
2536 : char c;
2537 10763906 : GEN arg = listtogen(y,Flistarg);
2538 10763906 : long nb=lg(arg)-1, ret_flag;
2539 10763906 : if (is_func_named(ep,"if") && nb>=4)
2540 112 : ep=is_entry("_multi_if");
2541 10763906 : p = ep->code;
2542 10763906 : if (!p)
2543 3654 : fl=0;
2544 : else
2545 10760252 : (void) get_ret_type(&p, 2, &t, &ret_flag);
2546 10763906 : if (p && *p)
2547 : {
2548 10753171 : j=1;
2549 22986567 : while((mod=parseproto(&p,&c,tree[n].str))!=PPend)
2550 : {
2551 12233424 : if (j<=nb && tree[arg[j]].f!=Fnoarg
2552 12051386 : && (mod==PPdefault || mod==PPdefaultmulti))
2553 64591 : mod=PPstd;
2554 12233424 : switch(mod)
2555 : {
2556 12036387 : case PPstd:
2557 12036387 : if (j>nb) compile_err("too few arguments", tree[n].str+tree[n].len-1);
2558 12036359 : if (tree[arg[j]].f==Fnoarg && c!='I' && c!='E')
2559 0 : compile_err("missing mandatory argument", tree[arg[j]].str);
2560 12036359 : switch(c)
2561 : {
2562 11997009 : case 'G':
2563 : case 'n':
2564 : case 'M':
2565 : case 'L':
2566 : case 'U':
2567 : case 'P':
2568 11997009 : optimizenode(arg[j]);
2569 11997009 : fl&=tree[arg[j++]].flags;
2570 11997009 : break;
2571 20249 : case 'I':
2572 : case 'E':
2573 : case 'J':
2574 20249 : optimizenode(arg[j]);
2575 20249 : fl&=tree[arg[j]].flags;
2576 20249 : tree[arg[j++]].flags=COsafelex|COsafedyn;
2577 20249 : break;
2578 2308 : case '&': case '*':
2579 : {
2580 2308 : long a=arg[j];
2581 2308 : if (c=='&')
2582 : {
2583 1533 : if (tree[a].f!=Frefarg)
2584 0 : compile_err("expected character: '&'", tree[a].str);
2585 1533 : a=tree[a].x;
2586 : }
2587 2308 : optimizenode(a);
2588 2308 : tree[arg[j++]].flags=COsafelex|COsafedyn;
2589 2308 : fl=0;
2590 2308 : break;
2591 : }
2592 560 : case 'W':
2593 : {
2594 560 : long a = tree[arg[j]].f==Findarg ? tree[arg[j]].x: arg[j];
2595 560 : optimizenode(a);
2596 560 : fl=0; j++;
2597 560 : break;
2598 : }
2599 6609 : case 'V':
2600 : case 'r':
2601 6609 : tree[arg[j++]].flags=COsafelex|COsafedyn;
2602 6609 : break;
2603 6867 : case '=':
2604 : {
2605 6867 : long a=arg[j++], y=tree[a].y;
2606 6867 : if (tree[a].f!=Fassign)
2607 0 : compile_err("expected character: '=' instead of",
2608 0 : tree[a].str+tree[a].len);
2609 6867 : optimizenode(y);
2610 6867 : fl&=tree[y].flags;
2611 : }
2612 6867 : break;
2613 2757 : case 's':
2614 2757 : fl &= vec_optimize(cattovec(arg[j++], OPcat));
2615 2757 : break;
2616 0 : default:
2617 0 : pari_err(e_MISC,"Unknown prototype code `%c' for `%.*s'",c,
2618 0 : tree[x].len, tree[x].str);
2619 : }
2620 12036359 : break;
2621 106069 : case PPauto:
2622 106069 : break;
2623 75503 : case PPdefault:
2624 : case PPdefaultmulti:
2625 75503 : if (j<=nb) optimizenode(arg[j++]);
2626 75503 : break;
2627 15465 : case PPstar:
2628 15465 : switch(c)
2629 : {
2630 112 : case 'E':
2631 : {
2632 112 : long n=nb+1-j;
2633 : long k;
2634 574 : for(k=1;k<=n;k++)
2635 : {
2636 462 : optimizenode(arg[j+k-1]);
2637 462 : fl &= tree[arg[j+k-1]].flags;
2638 : }
2639 112 : j=nb+1;
2640 112 : break;
2641 : }
2642 15353 : case 's':
2643 : {
2644 15353 : long n=nb+1-j;
2645 : long k;
2646 37058 : for(k=1;k<=n;k++)
2647 21705 : fl &= vec_optimize(cattovec(arg[j+k-1],OPcat));
2648 15353 : j=nb+1;
2649 15353 : break;
2650 : }
2651 0 : default:
2652 0 : pari_err(e_MISC,"Unknown prototype code `%c*' for `%.*s'",c,
2653 0 : tree[x].len, tree[x].str);
2654 : }
2655 15465 : break;
2656 0 : default:
2657 0 : pari_err_BUG("optimizefun [unknown PPproto]");
2658 : }
2659 : }
2660 10753143 : if (j<=nb)
2661 0 : compile_err("too many arguments",tree[arg[j]].str);
2662 : }
2663 10735 : else (void)vec_optimize(arg);
2664 10763878 : set_avma(av); tree[n].flags=fl;
2665 10763878 : }
2666 :
2667 : static void
2668 23382 : optimizecall(long n)
2669 : {
2670 23382 : pari_sp av=avma;
2671 23382 : long x=tree[n].x;
2672 23382 : long y=tree[n].y;
2673 23382 : GEN arg=listtogen(y,Flistarg);
2674 23382 : optimizenode(x);
2675 23382 : tree[n].flags = COsafelex&tree[x].flags&vec_optimize(arg);
2676 23375 : set_avma(av);
2677 23375 : }
2678 :
2679 : static void
2680 15220 : optimizeseq(long n)
2681 : {
2682 15220 : pari_sp av = avma;
2683 15220 : GEN L = listtogen(n, Fseq);
2684 15220 : long i, l = lg(L)-1, flags=-1L;
2685 63642 : for(i = 1; i <= l; i++)
2686 : {
2687 48422 : optimizenode(L[i]);
2688 48422 : flags &= tree[L[i]].flags;
2689 : }
2690 15220 : set_avma(av);
2691 15220 : tree[n].flags = flags;
2692 15220 : }
2693 :
2694 : void
2695 62098825 : optimizenode(long n)
2696 : {
2697 : long x,y;
2698 : #ifdef STACK_CHECK
2699 62098825 : if (PARI_stack_limit && (void*) &x <= PARI_stack_limit)
2700 0 : pari_err(e_MISC, "expression nested too deeply");
2701 : #endif
2702 62098825 : if (n<0)
2703 0 : pari_err_BUG("optimizenode");
2704 62098825 : x=tree[n].x;
2705 62098825 : y=tree[n].y;
2706 :
2707 62098825 : switch(tree[n].f)
2708 : {
2709 15220 : case Fseq:
2710 15220 : optimizeseq(n);
2711 62017802 : return;
2712 16366 : case Frange:
2713 16366 : optimizenode(x);
2714 16366 : optimizenode(y);
2715 16366 : tree[n].flags=tree[x].flags&tree[y].flags;
2716 16366 : break;
2717 14610 : case Fmatcoeff:
2718 14610 : optimizematcoeff(n);
2719 14610 : break;
2720 50005 : case Fassign:
2721 50005 : optimizenode(x);
2722 50005 : optimizenode(y);
2723 50005 : tree[n].flags=0;
2724 50005 : break;
2725 35734398 : case Fnoarg:
2726 : case Fnorange:
2727 : case Fsmall:
2728 : case Fconst:
2729 : case Fentry:
2730 35734398 : tree[n].flags=COsafelex|COsafedyn;
2731 35734398 : return;
2732 15461746 : case Fvec:
2733 15461746 : optimizevec(n);
2734 15461746 : return;
2735 9680 : case Fmat:
2736 9680 : optimizemat(n);
2737 9680 : return;
2738 7 : case Frefarg:
2739 7 : compile_err("unexpected character '&'",tree[n].str);
2740 0 : return;
2741 126 : case Findarg:
2742 126 : return;
2743 0 : case Fvararg:
2744 0 : compile_err("unexpected characters '..'",tree[n].str);
2745 0 : return;
2746 10786959 : case Ffunction:
2747 : {
2748 10786959 : entree *ep=getfunc(n);
2749 10786959 : if (EpVALENCE(ep)==EpVAR || EpVALENCE(ep)==EpNEW)
2750 23053 : optimizecall(n);
2751 : else
2752 10763906 : optimizefunc(ep,n);
2753 10786924 : return;
2754 : }
2755 329 : case Fcall:
2756 329 : optimizecall(n);
2757 329 : return;
2758 9379 : case Flambda:
2759 9379 : optimizenode(y);
2760 9379 : tree[n].flags=COsafelex|COsafedyn;
2761 9379 : return;
2762 0 : case Ftag:
2763 0 : optimizenode(x);
2764 0 : tree[n].flags=tree[x].flags;
2765 0 : return;
2766 0 : default:
2767 0 : pari_err_BUG("optimizenode");
2768 : }
2769 : }
|
