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