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