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 3822378 : translate(const char **src, char *s)
35 : {
36 3822378 : 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 3822378 : if (t[1] != '"') break;
53 0 : t += 2; continue;
54 : }
55 26326270 : *s++ = *t++;
56 : }
57 3822378 : *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 3822374 : strntoGENexp(const char *str, long len)
79 : {
80 3822374 : long n = nchar2nlong(len-1);
81 3822374 : GEN z = cgetg(1+n, t_STR);
82 3822374 : const char *t = str+1;
83 3822374 : z[n] = 0;
84 3822374 : if (!translate(&t, GSTR(z))) compile_err("run-away string",str);
85 3822374 : 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 378548 : pari_init_compiler(void)
122 : {
123 378548 : pari_stack_init(&s_opcode,sizeof(*opcode),(void **)&opcode);
124 378548 : pari_stack_init(&s_operand,sizeof(*operand),(void **)&operand);
125 378548 : pari_stack_init(&s_accesslex,sizeof(*operand),(void **)&accesslex);
126 378548 : pari_stack_init(&s_data,sizeof(*data),(void **)&data);
127 378548 : pari_stack_init(&s_lvar,sizeof(*localvars),(void **)&localvars);
128 378548 : pari_stack_init(&s_dbginfo,sizeof(*dbginfo),(void **)&dbginfo);
129 378548 : pari_stack_init(&s_frame,sizeof(*frames),(void **)&frames);
130 378548 : offset=-1; nblex=0;
131 378548 : }
132 : void
133 378540 : pari_close_compiler(void)
134 : {
135 378540 : pari_stack_delete(&s_opcode);
136 378540 : pari_stack_delete(&s_operand);
137 378540 : pari_stack_delete(&s_accesslex);
138 378540 : pari_stack_delete(&s_data);
139 378540 : pari_stack_delete(&s_lvar);
140 378540 : pari_stack_delete(&s_dbginfo);
141 378540 : pari_stack_delete(&s_frame);
142 378540 : }
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 10116626 : getcodepos(struct codepos *pos)
153 : {
154 10116626 : pos->opcode=s_opcode.n;
155 10116626 : pos->accesslex=s_accesslex.n;
156 10116626 : pos->data=s_data.n;
157 10116626 : pos->offset=offset;
158 10116626 : pos->nblex=nblex;
159 10116626 : pos->localvars=s_lvar.n;
160 10116626 : pos->dbgstart=dbgstart;
161 10116626 : pos->frames=s_frame.n;
162 10116626 : offset=s_data.n-1;
163 10116626 : }
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 1432294 : compilestate_save(struct pari_compilestate *comp)
182 : {
183 1432294 : comp->opcode=s_opcode.n;
184 1432294 : comp->operand=s_operand.n;
185 1432294 : comp->accesslex=s_accesslex.n;
186 1432294 : comp->data=s_data.n;
187 1432294 : comp->offset=offset;
188 1432294 : comp->nblex=nblex;
189 1432294 : comp->localvars=s_lvar.n;
190 1432294 : comp->dbgstart=dbgstart;
191 1432294 : comp->dbginfo=s_dbginfo.n;
192 1432294 : comp->frames=s_frame.n;
193 1432294 : }
194 :
195 : void
196 56443 : compilestate_restore(struct pari_compilestate *comp)
197 : {
198 56443 : s_opcode.n=comp->opcode;
199 56443 : s_operand.n=comp->operand;
200 56443 : s_accesslex.n=comp->accesslex;
201 56443 : s_data.n=comp->data;
202 56443 : offset=comp->offset;
203 56443 : nblex=comp->nblex;
204 56443 : s_lvar.n=comp->localvars;
205 56443 : dbgstart=comp->dbgstart;
206 56443 : s_dbginfo.n=comp->dbginfo;
207 56443 : s_frame.n=comp->frames;
208 56443 : }
209 :
210 : static GEN
211 13976885 : gcopyunclone(GEN x) { GEN y = gcopy(x); gunclone(x); return y; }
212 :
213 : static void
214 116958 : access_push(long x)
215 : {
216 116958 : long a = pari_stack_new(&s_accesslex);
217 116958 : accesslex[a] = x;
218 116958 : }
219 :
220 : static GEN
221 9162297 : genctx(long nbmvar, long paccesslex)
222 : {
223 9162297 : GEN acc = const_vec(nbmvar,gen_1);
224 9162297 : long i, lvl = 1 + nbmvar;
225 9204797 : for (i = paccesslex; i<s_accesslex.n; i++)
226 : {
227 42500 : long a = accesslex[i];
228 42500 : if (a > 0) { lvl+=a; continue; }
229 37257 : a += lvl;
230 37257 : if (a <= 0) pari_err_BUG("genctx");
231 37257 : if (a <= nbmvar)
232 28843 : gel(acc, a) = gen_0;
233 : }
234 9162297 : s_accesslex.n = paccesslex;
235 32956050 : for (i = 1; i<=nbmvar; i++)
236 23793753 : if (signe(gel(acc,i))==0)
237 20982 : access_push(i-nbmvar-1);
238 9162297 : return acc;
239 : }
240 :
241 : static GEN
242 10116570 : getfunction(const struct codepos *pos, long arity, long nbmvar, GEN text,
243 : long gap)
244 : {
245 10116570 : long lop = s_opcode.n+1 - pos->opcode;
246 10116570 : long ldat = s_data.n+1 - pos->data;
247 10116570 : long lfram = s_frame.n+1 - pos->frames;
248 10116570 : 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 10116570 : cl[1] = arity;
254 10116570 : gel(cl,2) = cgetg(nchar2nlong(lop)+1, t_STR);
255 10116570 : gel(cl,3) = op = cgetg(lop, t_VECSMALL);
256 10116570 : gel(cl,4) = dat = cgetg(ldat, t_VEC);
257 10116570 : dbg = cgetg(lop, t_VECSMALL);
258 10116570 : frpc = cgetg(lfram, t_VECSMALL);
259 10116570 : fram = cgetg(lfram, t_VEC);
260 10116570 : gel(cl,5) = mkvec3(dbg, frpc, fram);
261 10116570 : if (text) gel(cl,6) = text;
262 10116570 : s = GSTR(gel(cl,2)) - 1;
263 169729791 : for (i = 1; i < lop; i++)
264 : {
265 159613221 : long j = i+pos->opcode-1;
266 159613221 : s[i] = opcode[j];
267 159613221 : op[i] = operand[j];
268 159613221 : dbg[i] = dbginfo[j] - dbgstart;
269 159613221 : if (dbg[i] < 0) dbg[i] += gap;
270 : }
271 10116570 : s[i] = 0;
272 10116570 : s_opcode.n = pos->opcode;
273 10116570 : s_operand.n = pos->opcode;
274 10116570 : s_dbginfo.n = pos->opcode;
275 10116570 : if (lg(cl)==8)
276 9151171 : gel(cl,7) = genctx(nbmvar, pos->accesslex);
277 965399 : else if (nbmvar==0)
278 954273 : s_accesslex.n = pos->accesslex;
279 : else
280 : {
281 11126 : pari_sp av = avma;
282 11126 : (void) genctx(nbmvar, pos->accesslex);
283 11126 : set_avma(av);
284 : }
285 14921198 : for (i = 1; i < ldat; i++)
286 4804628 : if (data[i+pos->data-1]) gel(dat,i) = gcopyunclone(data[i+pos->data-1]);
287 10116570 : s_data.n = pos->data;
288 10146032 : while (s_lvar.n > pos->localvars && !localvars[s_lvar.n-1].inl)
289 : {
290 29462 : if (localvars[s_lvar.n-1].type==Lmy) nblex--;
291 29462 : s_lvar.n--;
292 : }
293 19288827 : for (i = 1; i < lfram; i++)
294 : {
295 9172257 : long j = i+pos->frames-1;
296 9172257 : frpc[i] = frames[j].pc - pos->opcode+1;
297 9172257 : gel(fram, i) = gcopyunclone(frames[j].frame);
298 : }
299 10116570 : s_frame.n = pos->frames;
300 10116570 : offset = pos->offset;
301 10116570 : dbgstart = pos->dbgstart;
302 10116570 : return cl;
303 : }
304 :
305 : static GEN
306 20506 : getclosure(struct codepos *pos, long nbmvar)
307 : {
308 20506 : return getfunction(pos, 0, nbmvar, NULL, 0);
309 : }
310 :
311 : static void
312 159610246 : op_push_loc(op_code o, long x, const char *loc)
313 : {
314 159610246 : long n=pari_stack_new(&s_opcode);
315 159610246 : long m=pari_stack_new(&s_operand);
316 159610246 : long d=pari_stack_new(&s_dbginfo);
317 159610246 : opcode[n]=o;
318 159610246 : operand[m]=x;
319 159610246 : dbginfo[d]=loc;
320 159610246 : }
321 :
322 : static void
323 115726787 : op_push(op_code o, long x, long n)
324 : {
325 115726787 : op_push_loc(o,x,tree[n].str);
326 115726787 : }
327 :
328 : static void
329 3052 : op_insert_loc(long k, op_code o, long x, const char *loc)
330 : {
331 : long i;
332 3052 : long n=pari_stack_new(&s_opcode);
333 3052 : (void) pari_stack_new(&s_operand);
334 3052 : (void) pari_stack_new(&s_dbginfo);
335 636644 : for (i=n-1; i>=k; i--)
336 : {
337 633592 : opcode[i+1] = opcode[i];
338 633592 : operand[i+1]= operand[i];
339 633592 : dbginfo[i+1]= dbginfo[i];
340 : }
341 3052 : opcode[k] = o;
342 3052 : operand[k] = x;
343 3052 : dbginfo[k] = loc;
344 3052 : }
345 :
346 : static long
347 4804628 : data_push(GEN x)
348 : {
349 4804628 : long n=pari_stack_new(&s_data);
350 4804628 : data[n] = x?gclone(x):x;
351 4804628 : return n-offset;
352 : }
353 :
354 : static void
355 65975 : var_push(entree *ep, Ltype type)
356 : {
357 65975 : long n=pari_stack_new(&s_lvar);
358 65975 : localvars[n].ep = ep;
359 65975 : localvars[n].inl = 0;
360 65975 : localvars[n].type = type;
361 65975 : if (type == Lmy) nblex++;
362 65975 : }
363 :
364 : static void
365 9172257 : frame_push(GEN x)
366 : {
367 9172257 : long n=pari_stack_new(&s_frame);
368 9172257 : frames[n].pc = s_opcode.n-1;
369 9172257 : frames[n].frame = gclone(x);
370 9172257 : }
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 275982 : addcopy(long n, long mode, long flag, long mask)
485 : {
486 275982 : if (mode==Ggen && !(flag&mask))
487 : {
488 27237 : op_push(OCcopy,0,n);
489 27237 : if (!(flag&FLsurvive) && DEBUGLEVEL)
490 0 : pari_warn(warner,"compiler generates copy for `%.*s'",
491 0 : tree[n].len,tree[n].str);
492 : }
493 275982 : }
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 153856036 : parseproto(char const **q, char *c, const char *str)
501 : {
502 153856036 : char const *p=*q;
503 : long i;
504 153856036 : switch(*p)
505 : {
506 39969325 : case 0:
507 : case '\n':
508 39969325 : return PPend;
509 289302 : case 'D':
510 289302 : switch(p[1])
511 : {
512 196407 : 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 196407 : *c=p[1]; *q=p+2; return PPdefault;
524 92895 : default:
525 562124 : for(i=0;*p && i<2;p++) i+=*p==',';
526 : /* assert(i>=2) because check_proto validated the protototype */
527 92895 : *c=p[-2]; *q=p; return PPdefaultmulti;
528 : }
529 : break;
530 144131 : case 'C':
531 : case 'p':
532 : case 'b':
533 : case 'P':
534 : case 'f':
535 144131 : *c=*p; *q=p+1; return PPauto;
536 1550 : case '&':
537 1550 : *c='*'; *q=p+1; return PPstd;
538 19032 : case 'V':
539 19032 : if (p[1]=='=')
540 : {
541 13762 : if (p[2]!='G')
542 0 : compile_err("function prototype is not supported",str);
543 13762 : *c='='; p+=2;
544 : }
545 : else
546 5270 : *c=*p;
547 19032 : *q=p+1; return PPstd;
548 45994 : case 'E':
549 : case 's':
550 45994 : if (p[1]=='*') { *c=*p++; *q=p+1; return PPstar; }
551 : /*fall through*/
552 : }
553 113401598 : *c=*p; *q=p+1; return PPstd;
554 : }
555 :
556 : static long
557 450284 : detag(long n)
558 : {
559 450284 : while (tree[n].f==Ftag)
560 0 : n=tree[n].x;
561 450284 : return n;
562 : }
563 :
564 : /* return type for GP functions */
565 : static op_code
566 21688116 : get_ret_type(const char **p, long arity, Gtype *t, long *flag)
567 : {
568 21688116 : *flag = 0;
569 21688116 : if (**p == 'v') { (*p)++; *t=Gvoid; return OCcallvoid; }
570 21639053 : else if (**p == 'i') { (*p)++; *t=Gsmall; return OCcallint; }
571 21632256 : else if (**p == 'l') { (*p)++; *t=Gsmall; return OCcalllong; }
572 21606164 : else if (**p == 'u') { (*p)++; *t=Gusmall; return OCcalllong; }
573 21606164 : else if (**p == 'm') { (*p)++; *flag = FLnocopy; }
574 21606164 : *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 27767862 : compilecast_loc(int type, int mode, const char *loc)
590 : {
591 27767862 : if (type==mode) return;
592 15528445 : 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 5234 : case Gsmall:
600 5234 : 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 5227 : break;
604 15510011 : case Ggen:
605 15510011 : if (type==Gsmall) op_push_loc(OCstoi,0,loc);
606 15495522 : else if (type==Gusmall)op_push_loc(OCutoi,0,loc);
607 15495522 : else if (type==Gvoid) op_push_loc(OCpushgnil,0,loc);
608 15510011 : break;
609 8980 : case Gvoid:
610 8980 : op_push_loc(OCpop, 1,loc);
611 8980 : break;
612 4010 : case Gvar:
613 4010 : if (type==Ggen) op_push_loc(OCvarn,-1,loc);
614 7 : else compile_varerr(loc);
615 4003 : break;
616 0 : default:
617 0 : pari_err_BUG("compilecast [unknown type]");
618 : }
619 : }
620 :
621 : static void
622 18619067 : compilecast(long n, int type, int mode) { compilecast_loc(type, mode, tree[n].str); }
623 :
624 : static entree *
625 25291 : fetch_member_raw(const char *s, long len)
626 : {
627 25291 : pari_sp av = avma;
628 25291 : char *t = stack_malloc(len+2);
629 : entree *ep;
630 25291 : t[0] = '_'; strncpy(t+1, s, len); t[++len] = 0; /* prepend '_' */
631 25291 : ep = fetch_entry_raw(t, len);
632 25291 : set_avma(av); return ep;
633 : }
634 : static entree *
635 21942931 : getfunc(long n)
636 : {
637 21942931 : long x=tree[n].x;
638 21942931 : if (tree[x].x==CSTmember) /* str-1 points to '.' */
639 25291 : return do_alias(fetch_member_raw(tree[x].str - 1, tree[x].len + 1));
640 : else
641 21917640 : return do_alias(fetch_entry_raw(tree[x].str, tree[x].len));
642 : }
643 :
644 : static entree *
645 367620 : getentry(long n)
646 : {
647 367620 : n = detag(n);
648 367620 : 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 367599 : return getfunc(n);
655 : }
656 :
657 : static entree *
658 67921 : getvar(long n)
659 67921 : { return getentry(n); }
660 :
661 : static entree *
662 13012 : getvarvec(long n)
663 : {
664 13012 : n = detag(n);
665 13012 : 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 11145077 : getmvar(entree *ep)
683 : {
684 : long i;
685 11145077 : long vn=0;
686 12289671 : for(i=s_lvar.n-1;i>=0;i--)
687 : {
688 1225090 : if(localvars[i].type==Lmy)
689 1224817 : vn--;
690 1225090 : if(localvars[i].ep==ep)
691 80496 : return localvars[i].type==Lmy?vn:0;
692 : }
693 11064581 : return 0;
694 : }
695 :
696 : static void
697 9745 : ctxmvar(long n)
698 : {
699 9745 : pari_sp av=avma;
700 : GEN ctx;
701 : long i;
702 9745 : 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 118438288 : is_func_named(entree *ep, const char *s)
713 : {
714 118438288 : return !strcmp(ep->name, s);
715 : }
716 :
717 : INLINE int
718 4294 : is_node_zero(long n)
719 : {
720 4294 : n = detag(n);
721 4294 : 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 52648788 : countlisttogen(long n, Ffunc f)
746 : {
747 : long x,i;
748 52648788 : if (n==-1 || tree[n].f==Fnoarg) return 0;
749 122040496 : for(x=n, i=0; tree[x].f==f ;x=tree[x].x, i++);
750 49380025 : return i+1;
751 : }
752 :
753 : static GEN
754 52648788 : listtogen(long n, Ffunc f)
755 : {
756 52648788 : long x,i,nb = countlisttogen(n, f);
757 52648788 : GEN z=cgetg(nb+1, t_VECSMALL);
758 52648788 : if (nb)
759 : {
760 122040496 : for (x=n, i = nb-1; i>0; z[i+1]=tree[x].y, x=tree[x].x, i--);
761 49380025 : z[1]=x;
762 : }
763 52648788 : return z;
764 : }
765 :
766 : static long
767 21597184 : first_safe_arg(GEN arg, long mask)
768 : {
769 21597184 : long lnc, l=lg(arg);
770 45805874 : for (lnc=l-1; lnc>0 && (tree[arg[lnc]].flags&mask)==mask; lnc--);
771 21597184 : return lnc;
772 : }
773 :
774 : static void
775 21079 : checkdups(GEN arg, GEN vep)
776 : {
777 21079 : long l=vecsmall_duplicate(vep);
778 21079 : if (l!=0) compile_err("variable declared twice",tree[arg[l]].str);
779 21079 : }
780 :
781 : enum {MAT_range,MAT_std,MAT_line,MAT_column,VEC_std};
782 :
783 : static int
784 15744 : matindex_type(long n)
785 : {
786 15744 : long x = tree[n].x, y = tree[n].y;
787 15744 : long fxx = tree[tree[x].x].f, fxy = tree[tree[x].y].f;
788 15744 : if (y==-1)
789 : {
790 13666 : if (fxy!=Fnorange) return MAT_range;
791 13057 : if (fxx==Fnorange) compile_err("missing index",tree[n].str);
792 13057 : 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 49818 : getlvalue(long n)
808 : {
809 50826 : while ((tree[n].f==Fmatcoeff && matindex_type(tree[n].y)!=MAT_range) || tree[n].f==Ftag)
810 1008 : n=tree[n].x;
811 49818 : return getvar(n);
812 : }
813 :
814 : INLINE void
815 46194 : compilestore(long vn, entree *ep, long n)
816 : {
817 46194 : if (vn)
818 4786 : op_push(OCstorelex,vn,n);
819 : else
820 : {
821 41408 : if (EpSTATIC(do_alias(ep)))
822 0 : compile_varerr(tree[n].str);
823 41408 : op_push(OCstoredyn,(long)ep,n);
824 : }
825 46194 : }
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 13616 : compilematcoeff(long n, int mode)
891 : {
892 13616 : long x=tree[n].x, y=tree[n].y;
893 13616 : long yx=tree[y].x, yy=tree[y].y;
894 13616 : long m=matindex_type(y);
895 13616 : compilenode(x,Ggen,FLnocopy);
896 13616 : switch(m)
897 : {
898 11573 : case VEC_std:
899 11573 : compilenode(tree[yx].x,Gsmall,0);
900 11573 : op_push(OCcompo1,mode,y);
901 11573 : 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 30554193 : compilesmall(long n, long x, long mode)
937 : {
938 30554193 : if (mode==Ggen)
939 30466073 : op_push(OCpushstoi, x, n);
940 : else
941 : {
942 88120 : if (mode==Gusmall && x < 0) U_compile_err(tree[n].str);
943 88120 : op_push(OCpushlong, x, n);
944 88120 : compilecast(n,Gsmall,mode);
945 : }
946 30554186 : }
947 :
948 : static void
949 15460591 : compilevec(long n, long mode, op_code op)
950 : {
951 15460591 : pari_sp ltop=avma;
952 15460591 : long x=tree[n].x;
953 : long i;
954 15460591 : GEN arg=listtogen(x,Fmatrixelts);
955 15460591 : long l=lg(arg);
956 15460591 : op_push(op,l,n);
957 64012298 : for (i=1;i<l;i++)
958 : {
959 48551707 : if (tree[arg[i]].f==Fnoarg)
960 0 : compile_err("missing vector element",tree[arg[i]].str);
961 48551707 : compilenode(arg[i],Ggen,FLsurvive);
962 48551707 : op_push(OCstackgen,i,n);
963 : }
964 15460591 : set_avma(ltop);
965 15460591 : op_push(OCpop,1,n);
966 15460591 : compilecast(n,Gvec,mode);
967 15460591 : }
968 :
969 : static void
970 9687 : compilemat(long n, long mode)
971 : {
972 9687 : pari_sp ltop=avma;
973 9687 : long x=tree[n].x;
974 : long i,j;
975 9687 : GEN line=listtogen(x,Fmatrixlines);
976 9687 : long lglin = lg(line), lgcol=0;
977 9687 : op_push(OCpushlong, lglin,n);
978 9687 : if (lglin==1)
979 1001 : op_push(OCmat,1,n);
980 48052 : for(i=1;i<lglin;i++)
981 : {
982 38365 : GEN col=listtogen(line[i],Fmatrixelts);
983 38365 : long l=lg(col), k;
984 38365 : if (i==1)
985 : {
986 8686 : lgcol=l;
987 8686 : op_push(OCmat,lgcol,n);
988 : }
989 29679 : else if (l!=lgcol)
990 0 : compile_err("matrix must be rectangular",tree[line[i]].str);
991 38365 : k=i;
992 292545 : for(j=1;j<lgcol;j++)
993 : {
994 254180 : k-=lglin;
995 254180 : if (tree[col[j]].f==Fnoarg)
996 0 : compile_err("missing matrix element",tree[col[j]].str);
997 254180 : compilenode(col[j], Ggen, FLsurvive);
998 254180 : op_push(OCstackgen,k,n);
999 : }
1000 : }
1001 9687 : set_avma(ltop);
1002 9687 : op_push(OCpop,1,n);
1003 9687 : compilecast(n,Gvec,mode);
1004 9687 : }
1005 :
1006 : static GEN
1007 49050 : cattovec(long n, long fnum)
1008 : {
1009 49050 : long x=n, y, i=0, nb;
1010 : GEN stack;
1011 49050 : if (tree[n].f==Fnoarg) return cgetg(1,t_VECSMALL);
1012 : while(1)
1013 208 : {
1014 49258 : long xx=tree[x].x;
1015 49258 : long xy=tree[x].y;
1016 49258 : if (tree[x].f!=Ffunction || xx!=fnum) break;
1017 208 : x=tree[xy].x;
1018 208 : y=tree[xy].y;
1019 208 : if (tree[y].f==Fnoarg)
1020 0 : compile_err("unexpected character: ", tree[y].str);
1021 208 : i++;
1022 : }
1023 49050 : if (tree[x].f==Fnoarg)
1024 0 : compile_err("unexpected character: ", tree[x].str);
1025 49050 : nb=i+1;
1026 49050 : stack=cgetg(nb+1,t_VECSMALL);
1027 49258 : for(x=n;i>0;i--)
1028 : {
1029 208 : long y=tree[x].y;
1030 208 : x=tree[y].x;
1031 208 : stack[i+1]=tree[y].y;
1032 : }
1033 49050 : stack[1]=x;
1034 49050 : 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 23396 : compilecall(long n, int mode, entree *ep)
1051 : {
1052 23396 : pari_sp ltop=avma;
1053 : long j;
1054 23396 : long x=tree[n].x, tx = tree[x].x;
1055 23396 : long y=tree[n].y;
1056 23396 : GEN arg=listtogen(y,Flistarg);
1057 23396 : long nb=lg(arg)-1;
1058 23396 : long lnc=first_safe_arg(arg, COsafelex|COsafedyn);
1059 23396 : long lnl=first_safe_arg(arg, COsafelex);
1060 23396 : long fl = lnl==0? (lnc==0? FLnocopy: FLnocopylex): 0;
1061 23396 : if (ep==NULL)
1062 329 : compilenode(x, Ggen, fl);
1063 : else
1064 : {
1065 23067 : long vn=getmvar(ep);
1066 23067 : if (vn)
1067 : {
1068 567 : access_push(vn);
1069 567 : op_push(OCpushlex,vn,n);
1070 : }
1071 : else
1072 22500 : op_push(OCpushdyn,(long)ep,n);
1073 : }
1074 63107 : for (j=1;j<=nb;j++)
1075 : {
1076 39711 : long x = tree[arg[j]].x, f = tree[arg[j]].f;
1077 39711 : if (f==Fseq)
1078 0 : compile_err("unexpected ';'", tree[x].str+tree[x].len);
1079 39711 : 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 39585 : } else if (tx==CSTmember)
1089 : {
1090 28 : compilenode(arg[j], Ggen,FLnocopy);
1091 28 : op_push(OClock,0,n);
1092 : }
1093 39557 : else if (f!=Fnoarg)
1094 39305 : compilenode(arg[j], Ggen,j>=lnl?FLnocopylex:0);
1095 : else
1096 252 : op_push(OCpushlong,0,n);
1097 : }
1098 23396 : op_push(OCcalluser,nb,x);
1099 23396 : compilecast(n,Ggen,mode);
1100 23396 : set_avma(ltop);
1101 23396 : }
1102 :
1103 : static GEN
1104 20781 : compilefuncinline(long n, long c, long a, long flag, long isif, long lev, long *ev)
1105 : {
1106 : struct codepos pos;
1107 20781 : int type=c=='I'?Gvoid:Ggen;
1108 20781 : long rflag=c=='I'?0:FLsurvive;
1109 20781 : long nbmvar = nblex;
1110 20781 : GEN vep = NULL;
1111 20781 : if (isif && (flag&FLreturn)) rflag|=FLreturn;
1112 20781 : getcodepos(&pos);
1113 20781 : if (c=='J') ctxmvar(nbmvar);
1114 20781 : if (lev)
1115 : {
1116 12197 : long i, slev = 0;
1117 12197 : GEN varg = cgetg(lev+1,t_VECSMALL);
1118 12197 : vep = cgetg(lev+1,t_VECSMALL);
1119 25202 : for (i = 1; i <= lev; i++)
1120 : {
1121 : entree *ve;
1122 13012 : long v = ev[i-1];
1123 13012 : if (v < 0)
1124 0 : compile_err("missing variable name", tree[a].str-1);
1125 13012 : ve = getvarvec(v);
1126 13005 : vep[i] = (long)ve;
1127 13005 : varg[i] = v;
1128 13005 : var_push(ve,Lmy);
1129 : }
1130 12190 : checkdups(varg,vep);
1131 12190 : if (c=='J')
1132 359 : op_push(OCgetargs,lev,n);
1133 12190 : access_push(lev);
1134 12190 : frame_push(vep);
1135 25195 : for (i = 1; i <= lev; i++)
1136 : {
1137 13005 : long v = ev[i-1];
1138 13005 : 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 20774 : if (c=='J')
1170 359 : return compilelambda(a,vep,nbmvar,&pos);
1171 20415 : if (tree[a].f==Fnoarg)
1172 119 : compilecast(a,Gvoid,type);
1173 : else
1174 20296 : compilenode(a,type,rflag);
1175 20415 : return getclosure(&pos, nbmvar);
1176 : }
1177 :
1178 : static long
1179 3601 : countvar(GEN arg)
1180 : {
1181 3601 : long i, l = lg(arg);
1182 3601 : long n = l-1;
1183 11026 : for(i=1; i<l; i++)
1184 : {
1185 7425 : long a=arg[i];
1186 7425 : if (tree[a].f==Fassign)
1187 : {
1188 4189 : long x = detag(tree[a].x);
1189 4189 : if (tree[x].f==Fvec && tree[x].x>=0)
1190 427 : n += countmatrixelts(tree[x].x)-1;
1191 : }
1192 : }
1193 3601 : 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 3573 : compilemy(GEN arg, const char *str, int inl)
1210 : {
1211 3573 : long i, j, k, l = lg(arg);
1212 3573 : long n = countvar(arg);
1213 3573 : GEN vep = cgetg(n+1,t_VECSMALL);
1214 3573 : GEN ver = cgetg(n+1,t_VECSMALL);
1215 3573 : 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 10942 : for(k=0, i=1; i<l; i++)
1222 : {
1223 7369 : long a=arg[i];
1224 7369 : if (tree[a].f==Fassign)
1225 : {
1226 4147 : long x = detag(tree[a].x);
1227 4147 : 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 3734 : } else ver[++k] = x;
1239 3222 : } else ver[++k] = a;
1240 6956 : vep[k] = (long)getvar(ver[k]);
1241 : }
1242 3573 : checkdups(ver,vep);
1243 11481 : for(i=1; i<=n; i++) var_push(NULL,Lmy);
1244 3573 : op_push_loc(OCnewframe,inl?-n:n,str);
1245 3573 : access_push(lg(vep)-1);
1246 3573 : frame_push(vep);
1247 10942 : for (k=0, i=1; i<l; i++)
1248 : {
1249 7369 : long a=arg[i];
1250 7369 : if (tree[a].f==Fassign)
1251 : {
1252 4147 : long x = detag(tree[a].x);
1253 4147 : 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 3734 : else if (!is_node_zero(tree[a].y))
1275 : {
1276 3586 : compilenode(tree[a].y,Ggen,FLnocopy);
1277 3586 : op_push(OCstorelex,-n+k,a);
1278 : }
1279 : }
1280 6956 : k++;
1281 6956 : localvars[s_lvar.n-n+k-1].ep=(entree*)vep[k];
1282 6956 : localvars[s_lvar.n-n+k-1].inl=inl;
1283 : }
1284 3573 : }
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 10771458 : compilefunc(entree *ep, long n, int mode, long flag)
1381 : {
1382 10771458 : pari_sp ltop=avma;
1383 : long j;
1384 10771458 : 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 10771458 : GEN arg=listtogen(y,Flistarg);
1393 10771458 : long lnc=first_safe_arg(arg, COsafelex|COsafedyn);
1394 10771458 : long lnl=first_safe_arg(arg, COsafelex);
1395 10771458 : long nbpointers=0, nbopcodes;
1396 10771458 : long nb=lg(arg)-1, lev=0;
1397 : long ev[20];
1398 10771458 : if (x>=OPnboperator)
1399 208323 : str=tree[x].str;
1400 : else
1401 : {
1402 10563135 : if (nb==2)
1403 1151335 : str=tree[arg[1]].str+tree[arg[1]].len;
1404 9411800 : else if (nb==1)
1405 9410767 : str=tree[arg[1]].str;
1406 : else
1407 1033 : str=tree[n].str;
1408 10569615 : while(*str==')') str++;
1409 : }
1410 10771458 : if (tree[n].f==Fassign)
1411 : {
1412 0 : nb=2; lnc=2; lnl=2; arg=mkvecsmall2(x,y);
1413 : }
1414 10771458 : else if (is_func_named(ep,"if"))
1415 : {
1416 4928 : if (nb>=4)
1417 112 : ep=is_entry("_multi_if");
1418 4816 : else if (mode==Gvoid)
1419 3078 : ep=is_entry("_void_if");
1420 : }
1421 10766530 : 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 9004043 : return;
1427 : }
1428 10766425 : 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 10766412 : 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 10766406 : else if (is_func_named(ep,"my"))
1443 : {
1444 3560 : compilemy(arg, str, 0);
1445 3560 : compilecast(n,Gvoid,mode);
1446 3560 : set_avma(ltop);
1447 3560 : return;
1448 : }
1449 10762846 : 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 10762818 : 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 10762777 : 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 10762771 : 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 10762764 : else if (is_func_named(ep,"O"))
1497 : {
1498 4949 : if (nb!=1)
1499 0 : compile_err("wrong number of arguments", tree[n].str+tree[n].len-1);
1500 4949 : ep=is_entry("O(_^_)");
1501 4949 : 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 10757815 : else if (x==OPn && tree[y].f==Fsmall)
1510 : {
1511 8995734 : set_avma(ltop);
1512 8995734 : compilesmall(y, -tree[y].x, mode);
1513 8995734 : return;
1514 : }
1515 1762081 : else if (x==OPtrans && tree[y].f==Fvec)
1516 : {
1517 4543 : set_avma(ltop);
1518 4543 : compilevec(y, mode, OCcol);
1519 4543 : return;
1520 1757538 : } 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 1757531 : else if (x==OPpow && nb==2)
1528 73921 : {
1529 73921 : long a = arg[2];
1530 73921 : if (tree[a].f==Fsmall)
1531 : {
1532 69158 : if(tree[a].x==2) { nb--; ep=is_entry("sqr"); }
1533 49638 : 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 1683610 : else if (x==OPcat)
1546 0 : compile_err("expected character: ',' or ')' instead of",
1547 0 : tree[arg[1]].str+tree[arg[1]].len);
1548 1767415 : p=ep->code;
1549 1767415 : if (!ep->value)
1550 0 : compile_err("unknown function",tree[n].str);
1551 1767415 : nbopcodes = s_opcode.n;
1552 1767415 : ret_op = get_ret_type(&p, ep->arity, &ret_typ, &ret_flag);
1553 1767415 : j=1;
1554 1767415 : if (*p)
1555 : {
1556 1758199 : q=p;
1557 4907182 : while((mod=parseproto(&p,&c,tree[n].str))!=PPend)
1558 : {
1559 3149032 : if (j<=nb && tree[arg[j]].f!=Fnoarg
1560 3037028 : && (mod==PPdefault || mod==PPdefaultmulti))
1561 68441 : mod=PPstd;
1562 3149032 : switch(mod)
1563 : {
1564 3021959 : case PPstd:
1565 3021959 : if (j>nb) compile_err("too few arguments", tree[n].str+tree[n].len-1);
1566 3021959 : if (c!='I' && c!='E' && c!='J')
1567 : {
1568 3001640 : long x = tree[arg[j]].x, f = tree[arg[j]].f;
1569 3001640 : if (f==Fnoarg)
1570 0 : compile_err("missing mandatory argument", tree[arg[j]].str);
1571 3001640 : if (f==Fseq)
1572 0 : compile_err("unexpected ';'", tree[x].str+tree[x].len);
1573 : }
1574 3021959 : switch(c)
1575 : {
1576 2901073 : case 'G':
1577 2901073 : compilenode(arg[j],Ggen,j>=lnl?(j>=lnc?FLnocopy:FLnocopylex):0);
1578 2901073 : j++;
1579 2901073 : 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 77169 : compilenode(arg[j++],Gsmall,0);
1615 77162 : break;
1616 217 : case 'U':
1617 217 : compilenode(arg[j++],Gusmall,0);
1618 210 : break;
1619 4010 : case 'n':
1620 4010 : compilenode(arg[j++],Gvar,0);
1621 4003 : 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 20319 : case 'I':
1655 : case 'E':
1656 : case 'J':
1657 : {
1658 20319 : long a = arg[j++];
1659 20319 : GEN d = compilefuncinline(n, c, a, flag, is_func_named(ep,"if"), lev, ev);
1660 20312 : op_push(OCpushgen, data_push(d), a);
1661 20312 : if (lg(d)==8) op_push(OCsaveframe,FLsurvive,n);
1662 20312 : break;
1663 : }
1664 5569 : case 'V':
1665 : {
1666 5569 : long a = arg[j++];
1667 5569 : ev[lev++] = a;
1668 5569 : break;
1669 : }
1670 6881 : case '=':
1671 : {
1672 6881 : long a = arg[j++];
1673 6881 : ev[lev++] = tree[a].x;
1674 6881 : compilenode(tree[a].y, Ggen, FLnocopy);
1675 : }
1676 6881 : 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 2688 : compilenode(g[1], Ggen, FLnocopy);
1701 2688 : op_push(OCtostr, -1, a);
1702 : } else
1703 : {
1704 69 : op_push(OCvec, nb+1, a);
1705 207 : for(l=1; l<=nb; l++)
1706 : {
1707 138 : compilenode(g[l], Ggen, FLsurvive);
1708 138 : op_push(OCstackgen,l, a);
1709 : }
1710 69 : op_push(OCpop, 1, a);
1711 69 : op_push(OCcallgen,(long)is_entry("Str"), a);
1712 69 : 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 3021917 : break;
1721 34034 : case PPauto:
1722 34034 : switch(c)
1723 : {
1724 29669 : case 'p':
1725 29669 : op_push(OCprecreal,0,n);
1726 29669 : break;
1727 4312 : case 'b':
1728 4312 : op_push(OCbitprecreal,0,n);
1729 4312 : 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 34034 : break;
1744 45041 : case PPdefault:
1745 45041 : j++;
1746 45041 : switch(c)
1747 : {
1748 6446 : case 'E':
1749 : case 'I':
1750 : {
1751 : long i;
1752 9080 : for (i = 0; i<lev; i++)
1753 2641 : if (ev[i]>=0) getvar(ev[i]);
1754 : }
1755 : case 'G': /*FALLTHROUGH*/
1756 : case '&':
1757 : case 'r':
1758 : case 's':
1759 34680 : op_push(OCpushlong,0,n);
1760 34680 : break;
1761 9053 : case 'n':
1762 9053 : op_push(OCpushlong,-1,n);
1763 9053 : 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 45034 : break;
1775 32491 : case PPdefaultmulti:
1776 32491 : j++;
1777 32491 : switch(c)
1778 : {
1779 0 : case 'G':
1780 0 : op_push(OCpushstoi,strtol(q+1,NULL,10),n);
1781 0 : break;
1782 32410 : case 'L':
1783 : case 'M':
1784 32410 : op_push(OCpushlong,strtol(q+1,NULL,10),n);
1785 32410 : 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 32491 : break;
1799 15507 : case PPstar:
1800 15507 : 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 15395 : case 's':
1815 : {
1816 15395 : long n=nb+1-j;
1817 : long k,l,l1,m;
1818 15395 : GEN g=cgetg(n+1,t_VEC);
1819 37163 : for(l1=0,k=1;k<=n;k++)
1820 : {
1821 21768 : gel(g,k)=cattovec(arg[j+k-1],OPcat);
1822 21768 : l1+=lg(gel(g,k))-1;
1823 : }
1824 15395 : op_push_loc(OCvec, l1+1, str);
1825 37163 : for(m=1,k=1;k<=n;k++)
1826 43571 : for(l=1;l<lg(gel(g,k));l++,m++)
1827 : {
1828 21803 : compilenode(mael(g,k,l),Ggen,FLsurvive);
1829 21803 : op_push(OCstackgen,m,mael(g,k,l));
1830 : }
1831 15395 : op_push_loc(OCpop, 1, str);
1832 15395 : j=nb+1;
1833 15395 : 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 15507 : break;
1840 0 : default:
1841 0 : pari_err_BUG("compilefunc [unknown PPproto]");
1842 : }
1843 3148983 : q=p;
1844 : }
1845 : }
1846 1767366 : if (j<=nb)
1847 0 : compile_err("too many arguments",tree[arg[j]].str);
1848 1767366 : op_push_loc(ret_op, (long) ep, str);
1849 1767366 : if (mode==Ggen && (ret_flag&FLnocopy) && !(flag&FLnocopy))
1850 10709 : op_push_loc(OCcopy,0,str);
1851 1767366 : if (ret_typ==Ggen && nbpointers==0 && s_opcode.n>nbopcodes+128)
1852 : {
1853 3052 : op_insert_loc(nbopcodes,OCavma,0,str);
1854 3052 : op_push_loc(OCgc,0,str);
1855 : }
1856 1767366 : compilecast(n,ret_typ,mode);
1857 1767366 : if (nbpointers) op_push_loc(OCendptr,nbpointers, str);
1858 1767366 : set_avma(ltop);
1859 : }
1860 :
1861 : static void
1862 9146971 : genclosurectx(const char *loc, long nbdata)
1863 : {
1864 : long i;
1865 9146971 : GEN vep = cgetg(nbdata+1,t_VECSMALL);
1866 32822979 : for(i = 1; i <= nbdata; i++)
1867 : {
1868 23676008 : vep[i] = 0;
1869 23676008 : op_push_loc(OCpushlex,-i,loc);
1870 : }
1871 9146971 : frame_push(vep);
1872 9146971 : }
1873 :
1874 : static GEN
1875 9157712 : genclosure(entree *ep, const char *loc, long nbdata, int check)
1876 : {
1877 : struct codepos pos;
1878 9157712 : long nb=0;
1879 9157712 : const char *code=ep->code,*p,*q;
1880 : char c;
1881 : GEN text;
1882 9157712 : long index=ep->arity;
1883 9157712 : long arity=0, maskarg=0, maskarg0=0, stop=0, dovararg=0;
1884 : PPproto mod;
1885 : Gtype ret_typ;
1886 : long ret_flag;
1887 9157712 : op_code ret_op=get_ret_type(&code,ep->arity,&ret_typ,&ret_flag);
1888 9157712 : p=code;
1889 41991658 : while ((mod=parseproto(&p,&c,NULL))!=PPend)
1890 : {
1891 32833946 : if (mod==PPauto)
1892 2066 : stop=1;
1893 : else
1894 : {
1895 32831880 : if (stop) return NULL;
1896 32831880 : if (c=='V') continue;
1897 32831880 : maskarg<<=1; maskarg0<<=1; arity++;
1898 32831880 : switch(mod)
1899 : {
1900 32830681 : case PPstd:
1901 32830681 : maskarg|=1L;
1902 32830681 : 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 717 : default:
1914 717 : break;
1915 : }
1916 : }
1917 : }
1918 9157712 : if (check && EpSTATIC(ep) && maskarg==0)
1919 8917 : return gen_0;
1920 9148795 : getcodepos(&pos);
1921 9148795 : dbgstart = loc;
1922 9148795 : if (nbdata > arity)
1923 0 : pari_err(e_MISC,"too many parameters for closure `%s'", ep->name);
1924 9148795 : if (nbdata) genclosurectx(loc, nbdata);
1925 9148795 : text = strtoGENstr(ep->name);
1926 9148795 : arity -= nbdata;
1927 9148795 : if (maskarg) op_push_loc(OCcheckargs,maskarg,loc);
1928 9148795 : if (maskarg0) op_push_loc(OCcheckargs0,maskarg0,loc);
1929 9148795 : p=code;
1930 41980901 : while ((mod=parseproto(&p,&c,NULL))!=PPend)
1931 : {
1932 32832106 : 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 0 : 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 32832106 : break;
1958 : }
1959 : }
1960 9148795 : q = p = code;
1961 41980901 : while ((mod=parseproto(&p,&c,NULL))!=PPend)
1962 : {
1963 32832106 : switch(mod)
1964 : {
1965 32830681 : case PPstd:
1966 32830681 : switch(c)
1967 : {
1968 32786266 : case 'G':
1969 32786266 : break;
1970 32908 : case 'M':
1971 : case 'L':
1972 32908 : op_push_loc(OCitos,-index,loc);
1973 32908 : break;
1974 11479 : case 'U':
1975 11479 : op_push_loc(OCitou,-index,loc);
1976 11479 : 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 32830681 : 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 32832106 : index--;
2061 32832106 : q = p;
2062 : }
2063 9148795 : op_push_loc(ret_op, (long) ep, loc);
2064 9148795 : if (ret_flag==FLnocopy) op_push_loc(OCcopy,0,loc);
2065 9148795 : compilecast_loc(ret_typ, Ggen, loc);
2066 9148795 : if (dovararg) nb|=VARARGBITS;
2067 9148795 : return getfunction(&pos,nb+arity,nbdata,text,0);
2068 : }
2069 :
2070 : GEN
2071 9145276 : snm_closure(entree *ep, GEN data)
2072 : {
2073 9145276 : long i, n = data ? lg(data)-1: 0;
2074 9145276 : GEN C = genclosure(ep,ep->name,n,0);
2075 32814480 : for(i = 1; i <= n; i++) gmael(C,7,i) = gel(data,i);
2076 9145276 : 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 15276 : compileseq(long n, int mode, long flag)
2159 : {
2160 15276 : pari_sp av = avma;
2161 15276 : GEN L = listtogen(n, Fseq);
2162 15276 : long i, l = lg(L)-1;
2163 48562 : for(i = 1; i < l; i++)
2164 33286 : compilenode(L[i],Gvoid,0);
2165 15276 : compilenode(L[l],mode,flag&(FLreturn|FLsurvive));
2166 15276 : set_avma(av);
2167 15276 : }
2168 :
2169 : static void
2170 52956866 : compilenode(long n, int mode, long flag)
2171 : {
2172 : long x,y;
2173 : #ifdef STACK_CHECK
2174 52956866 : if (PARI_stack_limit && (void*) &x <= PARI_stack_limit)
2175 0 : pari_err(e_MISC, "expression nested too deeply");
2176 : #endif
2177 52956866 : if (n<0) pari_err_BUG("compilenode");
2178 52956866 : x=tree[n].x;
2179 52956866 : y=tree[n].y;
2180 :
2181 52956866 : switch(tree[n].f)
2182 : {
2183 15276 : case Fseq:
2184 15276 : compileseq(n, mode, flag);
2185 52956796 : return;
2186 13616 : case Fmatcoeff:
2187 13616 : compilematcoeff(n,mode);
2188 13609 : if (mode==Ggen && !(flag&FLnocopy))
2189 4283 : op_push(OCcopy,0,n);
2190 13609 : return;
2191 45935 : case Fassign:
2192 45935 : x = detag(x);
2193 45935 : if (tree[x].f==Fvec && tree[x].x>=0)
2194 812 : {
2195 812 : GEN vars = listtogen(tree[x].x,Fmatrixelts);
2196 812 : long i, l = lg(vars)-1, d = mode==Gvoid? l-1: l;
2197 812 : compilenode(y,Ggen,mode==Gvoid?0:flag&FLsurvive);
2198 2541 : for (i=1; i<=l; i++)
2199 1729 : if (tree[vars[i]].f==Fnoarg) d--;
2200 812 : if (d) op_push(OCdup, d, x);
2201 2541 : for(i=1; i<=l; i++)
2202 1729 : if (tree[vars[i]].f!=Fnoarg)
2203 : {
2204 1715 : long a = detag(vars[i]);
2205 1715 : entree *ep=getlvalue(a);
2206 1715 : long vn=getmvar(ep);
2207 1715 : op_push(OCpushlong,i,a);
2208 1715 : op_push(OCcompo1,Ggen,a);
2209 1715 : if (tree[a].f==Fentry)
2210 1708 : 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 812 : if (mode!=Gvoid)
2219 469 : compilecast(n,Ggen,mode);
2220 : }
2221 : else
2222 : {
2223 45123 : entree *ep=getlvalue(x);
2224 45123 : long vn=getmvar(ep);
2225 45123 : if (tree[x].f!=Fentry)
2226 : {
2227 637 : compilenewptr(vn,ep,n);
2228 637 : compilelvalue(x);
2229 : }
2230 45123 : compilenode(y,Ggen,mode==Gvoid?FLnocopy:flag&FLsurvive);
2231 45123 : if (mode!=Gvoid)
2232 29801 : op_push(OCdup,1,n);
2233 45123 : if (tree[x].f==Fentry)
2234 44486 : compilestore(vn,ep,n);
2235 : else
2236 637 : op_push(OCstoreptr,0,x);
2237 45123 : if (mode!=Gvoid)
2238 29801 : compilecast(n,Ggen,mode);
2239 : }
2240 45935 : return;
2241 4775637 : case Fconst:
2242 : {
2243 4775637 : pari_sp ltop=avma;
2244 4775637 : if (tree[n].x!=CSTquote)
2245 : {
2246 4771819 : if (mode==Gvoid) return;
2247 4771819 : if (mode==Gvar) compile_varerr(tree[n].str);
2248 : }
2249 4775637 : if (mode==Gsmall) L_compile_err(tree[n].str);
2250 4775637 : if (mode==Gusmall && tree[n].x != CSTint) U_compile_err(tree[n].str);
2251 4775630 : 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 943222 : case CSTint:
2257 943222 : op_push(OCpushgen, data_push(strtoi((char*)tree[n].str)),n);
2258 943222 : compilecast(n,Ggen, mode);
2259 943222 : break;
2260 3822300 : case CSTstr:
2261 3822300 : op_push(OCpushgen, data_push(strntoGENexp(tree[n].str,tree[n].len)),n);
2262 3822300 : break;
2263 3818 : case CSTquote:
2264 : { /* skip ' */
2265 3818 : entree *ep = fetch_entry_raw(tree[n].str+1,tree[n].len-1);
2266 3818 : if (EpSTATIC(ep)) compile_varerr(tree[n].str+1);
2267 3818 : op_push(OCpushvar, (long)ep,n);
2268 3818 : compilecast(n,Ggen, mode);
2269 3818 : break;
2270 : }
2271 0 : default:
2272 0 : pari_err_BUG("compilenode, unsupported constant");
2273 : }
2274 4775630 : set_avma(ltop);
2275 4775630 : return;
2276 : }
2277 21558459 : case Fsmall:
2278 21558459 : compilesmall(n, x, mode);
2279 21558452 : return;
2280 15456048 : case Fvec:
2281 15456048 : compilevec(n, mode, OCvec);
2282 15456048 : return;
2283 9687 : case Fmat:
2284 9687 : compilemat(n, mode);
2285 9687 : 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 286598 : case Fentry:
2293 : {
2294 286598 : entree *ep=getentry(n);
2295 286598 : long vn=getmvar(ep);
2296 286598 : if (vn)
2297 : {
2298 73472 : access_push(vn);
2299 73472 : op_push(OCpushlex,(long)vn,n);
2300 73472 : addcopy(n,mode,flag,FLnocopy|FLnocopylex);
2301 73472 : compilecast(n,Ggen,mode);
2302 : }
2303 213126 : else if (ep->valence==EpVAR || ep->valence==EpNEW)
2304 : {
2305 202510 : if (DEBUGLEVEL && mode==Gvoid)
2306 0 : pari_warn(warner,"statement with no effect: `%s'",ep->name);
2307 202510 : op_push(OCpushdyn,(long)ep,n);
2308 202510 : addcopy(n,mode,flag,FLnocopy);
2309 202510 : compilecast(n,Ggen,mode);
2310 : }
2311 : else
2312 10616 : closurefunc(ep,n,mode);
2313 286598 : return;
2314 : }
2315 10785608 : case Ffunction:
2316 : {
2317 10785608 : entree *ep=getfunc(n);
2318 10785608 : if (getmvar(ep) || EpVALENCE(ep)==EpVAR || EpVALENCE(ep)==EpNEW)
2319 : {
2320 23067 : if (tree[n].x<OPnboperator) /* should not happen */
2321 0 : compile_err("operator unknown",tree[n].str);
2322 23067 : compilecall(n,mode,ep);
2323 : }
2324 : else
2325 10762541 : compilefunc(ep,n,mode,flag);
2326 10785559 : return;
2327 : }
2328 329 : case Fcall:
2329 329 : compilecall(n,mode,NULL);
2330 329 : return;
2331 9386 : case Flambda:
2332 : {
2333 9386 : pari_sp ltop=avma;
2334 : struct codepos pos;
2335 9386 : GEN arg=listtogen(x,Flistarg);
2336 9386 : long nb, lgarg, nbmvar, dovararg=0, gap;
2337 9386 : long strict = GP_DATA->strictargs;
2338 9386 : GEN vep = cgetg_copy(arg, &lgarg);
2339 9386 : GEN text=cgetg(3,t_VEC);
2340 9386 : gel(text,1)=strntoGENstr(tree[x].str,tree[x].len);
2341 9386 : 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 9386 : gel(text,2)=strntoGENstr(tree[y].str,tree[y].len);
2345 9386 : getcodepos(&pos);
2346 9386 : dbgstart=tree[x].str+tree[x].len;
2347 9386 : gap = tree[y].str-dbgstart;
2348 9386 : nbmvar = nblex;
2349 9386 : ctxmvar(nbmvar);
2350 9386 : nb = lgarg-1;
2351 9386 : if (nb)
2352 : {
2353 : long i;
2354 13723 : for(i=1;i<=nb;i++)
2355 : {
2356 8435 : long a = arg[i], f = tree[a].f;
2357 8435 : if (i==nb && f==Fvararg)
2358 : {
2359 21 : dovararg=1;
2360 21 : vep[i]=(long)getvar(tree[a].x);
2361 : }
2362 : else
2363 8414 : vep[i]=(long)getvar(f==Fassign||f==Findarg?tree[a].x:a);
2364 8435 : var_push(NULL,Lmy);
2365 : }
2366 5288 : checkdups(arg,vep);
2367 5288 : op_push(OCgetargs,nb,x);
2368 5288 : access_push(lg(vep)-1);
2369 5288 : frame_push(vep);
2370 13723 : for (i=1;i<=nb;i++)
2371 : {
2372 8435 : long a = arg[i], f = tree[a].f;
2373 8435 : long y = tree[a].y;
2374 8435 : 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 8050 : } else if (f==Findarg)
2388 84 : op_push(OCsetref, -nb+i-1, a);
2389 8435 : localvars[s_lvar.n-nb+i-1].ep=(entree*)vep[i];
2390 : }
2391 : }
2392 9386 : if (strict)
2393 21 : op_push(OCcheckuserargs,nb,x);
2394 9386 : dbgstart=tree[y].str;
2395 9386 : if (y>=0 && tree[y].f!=Fnoarg)
2396 9386 : compilenode(y,Ggen,FLsurvive|FLreturn);
2397 : else
2398 0 : compilecast(n,Gvoid,Ggen);
2399 9386 : if (dovararg) nb|=VARARGBITS;
2400 9386 : op_push(OCpushgen, data_push(getfunction(&pos,nb,nbmvar,text,gap)),n);
2401 9386 : if (nbmvar) op_push(OCsaveframe,!!(flag&FLsurvive),n);
2402 9386 : compilecast(n, Gclosure, mode);
2403 9386 : set_avma(ltop);
2404 9386 : 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 937461 : gp_closure(long n)
2423 : {
2424 : struct codepos pos;
2425 937461 : getcodepos(&pos);
2426 937461 : dbgstart=tree[n].str;
2427 937461 : compilenode(n,Ggen,FLsurvive|FLreturn);
2428 937412 : 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 15558872 : vec_optimize(GEN arg)
2469 : {
2470 15558872 : long fl = COsafelex|COsafedyn;
2471 : long i;
2472 64444278 : for (i=1; i<lg(arg); i++)
2473 : {
2474 48885413 : optimizenode(arg[i]);
2475 48885406 : fl &= tree[arg[i]].flags;
2476 : }
2477 15558865 : return fl;
2478 : }
2479 :
2480 : static void
2481 15461830 : optimizevec(long n)
2482 : {
2483 15461830 : pari_sp ltop=avma;
2484 15461830 : long x = tree[n].x;
2485 15461830 : GEN arg = listtogen(x, Fmatrixelts);
2486 15461830 : tree[n].flags = vec_optimize(arg);
2487 15461830 : set_avma(ltop);
2488 15461830 : }
2489 :
2490 : static void
2491 9687 : optimizemat(long n)
2492 : {
2493 9687 : pari_sp ltop = avma;
2494 9687 : long x = tree[n].x;
2495 : long i;
2496 9687 : GEN line = listtogen(x,Fmatrixlines);
2497 9687 : long fl = COsafelex|COsafedyn;
2498 48052 : for(i=1;i<lg(line);i++)
2499 : {
2500 38365 : GEN col=listtogen(line[i],Fmatrixelts);
2501 38365 : fl &= vec_optimize(col);
2502 : }
2503 9687 : set_avma(ltop); tree[n].flags=fl;
2504 9687 : }
2505 :
2506 : static void
2507 14617 : optimizematcoeff(long n)
2508 : {
2509 14617 : long x=tree[n].x;
2510 14617 : long y=tree[n].y;
2511 14617 : long yx=tree[y].x;
2512 14617 : long yy=tree[y].y;
2513 : long fl;
2514 14617 : optimizenode(x);
2515 14617 : optimizenode(yx);
2516 14617 : fl=tree[x].flags&tree[yx].flags;
2517 14617 : if (yy>=0)
2518 : {
2519 1756 : optimizenode(yy);
2520 1756 : fl&=tree[yy].flags;
2521 : }
2522 14617 : tree[n].flags=fl;
2523 14617 : }
2524 :
2525 : static void
2526 10766650 : optimizefunc(entree *ep, long n)
2527 : {
2528 10766650 : pari_sp av=avma;
2529 : long j;
2530 10766650 : long x=tree[n].x;
2531 10766650 : long y=tree[n].y;
2532 : Gtype t;
2533 : PPproto mod;
2534 10766650 : long fl=COsafelex|COsafedyn;
2535 : const char *p;
2536 : char c;
2537 10766650 : GEN arg = listtogen(y,Flistarg);
2538 10766650 : long nb=lg(arg)-1, ret_flag;
2539 10766650 : if (is_func_named(ep,"if") && nb>=4)
2540 112 : ep=is_entry("_multi_if");
2541 10766650 : p = ep->code;
2542 10766650 : if (!p)
2543 3661 : fl=0;
2544 : else
2545 10762989 : (void) get_ret_type(&p, 2, &t, &ret_flag);
2546 10766650 : if (p && *p)
2547 : {
2548 10755901 : j=1;
2549 22995394 : while((mod=parseproto(&p,&c,tree[n].str))!=PPend)
2550 : {
2551 12239521 : if (j<=nb && tree[arg[j]].f!=Fnoarg
2552 12056475 : && (mod==PPdefault || mod==PPdefaultmulti))
2553 64815 : mod=PPstd;
2554 12239521 : switch(mod)
2555 : {
2556 12041434 : case PPstd:
2557 12041434 : if (j>nb) compile_err("too few arguments", tree[n].str+tree[n].len-1);
2558 12041406 : if (tree[arg[j]].f==Fnoarg && c!='I' && c!='E')
2559 0 : compile_err("missing mandatory argument", tree[arg[j]].str);
2560 12041406 : switch(c)
2561 : {
2562 12001937 : case 'G':
2563 : case 'n':
2564 : case 'M':
2565 : case 'L':
2566 : case 'U':
2567 : case 'P':
2568 12001937 : optimizenode(arg[j]);
2569 12001937 : fl&=tree[arg[j++]].flags;
2570 12001937 : break;
2571 20319 : case 'I':
2572 : case 'E':
2573 : case 'J':
2574 20319 : optimizenode(arg[j]);
2575 20319 : fl&=tree[arg[j]].flags;
2576 20319 : tree[arg[j++]].flags=COsafelex|COsafedyn;
2577 20319 : 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 6644 : case 'V':
2600 : case 'r':
2601 6644 : tree[arg[j++]].flags=COsafelex|COsafedyn;
2602 6644 : break;
2603 6881 : case '=':
2604 : {
2605 6881 : long a=arg[j++], y=tree[a].y;
2606 6881 : if (tree[a].f!=Fassign)
2607 0 : compile_err("expected character: '=' instead of",
2608 0 : tree[a].str+tree[a].len);
2609 6881 : optimizenode(y);
2610 6881 : fl&=tree[y].flags;
2611 : }
2612 6881 : 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 12041406 : break;
2621 106699 : case PPauto:
2622 106699 : break;
2623 75881 : case PPdefault:
2624 : case PPdefaultmulti:
2625 75881 : if (j<=nb) optimizenode(arg[j++]);
2626 75881 : break;
2627 15507 : case PPstar:
2628 15507 : 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 15395 : case 's':
2643 : {
2644 15395 : long n=nb+1-j;
2645 : long k;
2646 37163 : for(k=1;k<=n;k++)
2647 21768 : fl &= vec_optimize(cattovec(arg[j+k-1],OPcat));
2648 15395 : j=nb+1;
2649 15395 : 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 15507 : break;
2656 0 : default:
2657 0 : pari_err_BUG("optimizefun [unknown PPproto]");
2658 : }
2659 : }
2660 10755873 : if (j<=nb)
2661 0 : compile_err("too many arguments",tree[arg[j]].str);
2662 : }
2663 10749 : else (void)vec_optimize(arg);
2664 10766622 : set_avma(av); tree[n].flags=fl;
2665 10766622 : }
2666 :
2667 : static void
2668 23403 : optimizecall(long n)
2669 : {
2670 23403 : pari_sp av=avma;
2671 23403 : long x=tree[n].x;
2672 23403 : long y=tree[n].y;
2673 23403 : GEN arg=listtogen(y,Flistarg);
2674 23403 : optimizenode(x);
2675 23403 : tree[n].flags = COsafelex&tree[x].flags&vec_optimize(arg);
2676 23396 : set_avma(av);
2677 23396 : }
2678 :
2679 : static void
2680 15276 : optimizeseq(long n)
2681 : {
2682 15276 : pari_sp av = avma;
2683 15276 : GEN L = listtogen(n, Fseq);
2684 15276 : long i, l = lg(L)-1, flags=-1L;
2685 63838 : for(i = 1; i <= l; i++)
2686 : {
2687 48562 : optimizenode(L[i]);
2688 48562 : flags &= tree[L[i]].flags;
2689 : }
2690 15276 : set_avma(av);
2691 15276 : tree[n].flags = flags;
2692 15276 : }
2693 :
2694 : void
2695 62105104 : optimizenode(long n)
2696 : {
2697 : long x,y;
2698 : #ifdef STACK_CHECK
2699 62105104 : if (PARI_stack_limit && (void*) &x <= PARI_stack_limit)
2700 0 : pari_err(e_MISC, "expression nested too deeply");
2701 : #endif
2702 62105104 : if (n<0)
2703 0 : pari_err_BUG("optimizenode");
2704 62105104 : x=tree[n].x;
2705 62105104 : y=tree[n].y;
2706 :
2707 62105104 : switch(tree[n].f)
2708 : {
2709 15276 : case Fseq:
2710 15276 : optimizeseq(n);
2711 62023927 : return;
2712 16373 : case Frange:
2713 16373 : optimizenode(x);
2714 16373 : optimizenode(y);
2715 16373 : tree[n].flags=tree[x].flags&tree[y].flags;
2716 16373 : break;
2717 14617 : case Fmatcoeff:
2718 14617 : optimizematcoeff(n);
2719 14617 : break;
2720 50145 : case Fassign:
2721 50145 : optimizenode(x);
2722 50145 : optimizenode(y);
2723 50145 : tree[n].flags=0;
2724 50145 : break;
2725 35737604 : case Fnoarg:
2726 : case Fnorange:
2727 : case Fsmall:
2728 : case Fconst:
2729 : case Fentry:
2730 35737604 : tree[n].flags=COsafelex|COsafedyn;
2731 35737604 : return;
2732 15461830 : case Fvec:
2733 15461830 : optimizevec(n);
2734 15461830 : return;
2735 9687 : case Fmat:
2736 9687 : optimizemat(n);
2737 9687 : 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 10789724 : case Ffunction:
2747 : {
2748 10789724 : entree *ep=getfunc(n);
2749 10789724 : if (EpVALENCE(ep)==EpVAR || EpVALENCE(ep)==EpNEW)
2750 23074 : optimizecall(n);
2751 : else
2752 10766650 : optimizefunc(ep,n);
2753 10789689 : return;
2754 : }
2755 329 : case Fcall:
2756 329 : optimizecall(n);
2757 329 : return;
2758 9386 : case Flambda:
2759 9386 : optimizenode(y);
2760 9386 : tree[n].flags=COsafelex|COsafedyn;
2761 9386 : 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 : }
|
