1 /*
2 Copyright (C) 2002-2013  The PARI group.
3 
4 This file is part of the GP2C package.
5 
6 PARI/GP is free software; you can redistribute it and/or modify it under the
7 terms of the GNU General Public License as published by the Free Software
8 Foundation. 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 "config.h"
16 #include <stdlib.h>
17 #include <stdio.h>
18 #include <string.h>
19 #include <ctype.h>
20 #include "header.h"
21 
22 static int newanonvar=0;
23 
newanon(void)24 int newanon(void)
25 {
26   char s[33];
27   sprintf(s,"anon_%d",newanonvar++);
28   return newentry(strdup(s));
29 }
30 
newfun(const char * name)31 int newfun(const char *name)
32 {
33   char *s = malloc(5+strlen(name));
34   sprintf(s,"fun_%s",name);
35   if (findfunction(s)<0) return newentry(s);
36   free(s);
37   return newanon();
38 }
39 
mkfunc(int n,int p,int flag,int wr)40 void mkfunc(int n, int p, int flag, int wr)
41 {
42   int x = tree[n].x;
43   gpfunc *gp;
44   const char *name=entryname(x);
45   int nf=findfunction(name);
46   if (nf==-1)
47   {
48     nf = newuserfunc(name);
49     gp = lfunc+nf;
50   }
51   else
52   {
53     gp=lfunc+nf;
54     if (gp->spec!=GPuser)
55       die(n,"Trying to redefine function %s",name);
56     else
57     {
58       userfunc *ufunc=gp->user;
59       int parent=ufunc->pdefnode;
60       int node=ufunc->defnode;
61       if (tree[node].y>=0)
62         warning(node,"Function %s redefined in file %s, line %d",
63                 name, srcfile[tree[n].fileno], tree[n].lineno);
64       if (tree[parent].x==node)
65         tree[parent].x=GNIL;
66       else
67         tree[parent].y=GNIL;
68     }
69   }
70   gp->user->flag=flag;
71   gp->user->wrapper=wr;
72   gp->user->pdefnode=p;
73   gp->user->defnode=n;
74 }
75 
topfunc(int n,int p,int fun,int pfun,int nf,int wr)76 static void topfunc(int n, int p, int fun, int pfun, int nf, int wr)
77 {
78   int code = tree[n].y, arglist = tree[n].x;
79   int args = arglist>=0 ? tree[arglist].y : -1;
80   int fl = wr<0?(1<<UFclosure):(1<<UFclosure)|(1<<UFstatic);
81   if (fun==-1 || pfun==-1)
82   {
83     if(n!=nf) tree[n]=tree[nf];
84     mkfunc(nf,p,0,wr);
85     gentopfunc(args,n,n,p);
86     gentopfunc(code,n,n,p);
87     return;
88   }
89   if (tree[pfun].x==fun)
90   {
91     int seq = newnode(Fseq,nf,newleaf(fun));
92     tree[fun] = tree[seq];
93     mkfunc(nf,seq,fl,wr);
94     gentopfunc(args,n,nf,seq);
95     gentopfunc(code,n,nf,seq);
96   }
97   else
98   {
99     int seq = newnode(Fseq,tree[pfun].x,nf);
100     tree[pfun].x = seq;
101     mkfunc(nf,seq,fl,wr);
102     gentopfunc(args,n,nf,seq);
103     gentopfunc(code,n,nf,seq);
104   }
105 }
106 
topfunclambda(int n,int p,int fun,int pfun,int wr)107 static void topfunclambda(int n, int p, int fun, int pfun, int wr)
108 {
109   int x = tree[n].x, y = tree[n].y;
110   int nn = newanon();
111   int nf = newnode(Fdeffunc,newnode(Ffunction,nn,x),y);
112   int seq = newnode(Fentry,nn,-1);
113   topfunc(nf,p,fun,pfun,nf,wr);
114   if (fun>=0) tree[n] = tree[seq];
115 }
116 
topfuncproto(int n,int fun,int pfun,int nf)117 static int topfuncproto(int n, int fun, int pfun, int nf)
118 {
119   int arg[STACKSZ+1];
120   int nb=genlistargs(n,arg,0,STACKSZ);
121   gpfunc *gp = lfunc+nf;
122   gpwrap *gw = gp->wrap;
123   int nbwr = gw ? gw->nb: 0;
124   const char *proto=gp->proto.code;
125   int i=0;
126   int var=-1, seq, a, t, binf, wr, kvar=-1;
127   char const *p=proto;
128   char c;
129   PPproto mod;
130   gpdesc *iter = lfunc[nf].iter;
131   if (!proto) return 1;
132   while((mod=parseproto(&p,&c)))
133   {
134     switch(mod)
135     {
136     case PPauto:
137       break;
138     case PPstd:
139       if (i>=nb || arg[i]==GNOARG)
140         die(n,"missing mandatory argument");
141       a = arg[i++];
142       wr = i<=nbwr ? gw->w[i-1]:-2;
143       switch(c)
144       {
145         case 'G':
146           if (wr>=0 && tree[a].f==Flambda)
147             topfunclambda(a, n, fun, pfun, wr);
148           break;
149         case 'V':
150           var = a;
151           if (!iter)
152             killlistarg(n,a);
153           break;
154         case '=':
155           genequal(a,lfunc[nf].gpname,&var,&binf,&t);
156           kvar = a;
157           break;
158         case 'I':
159         case 'E':
160           if (iter || wr<-1)
161             break;
162         case 'J': /* Fall through */
163           if (kvar>=0 && !iter) { tree[kvar]=tree[binf]; kvar=-1; }
164           seq = newnode(Flambda,var,newleaf(a));
165           tree[a] = tree[seq];
166           topfunclambda(a, n, fun, pfun, wr);
167           break;
168       }
169       break;
170     case PPdefault:
171       i++;
172       a  = i<=nb ? arg[i-1]: GNOARG;
173       wr = i<=nbwr ? gw->w[i-1]:-2;
174       switch(c)
175       {
176         case 'I':
177         case 'E':
178           if (!iter && a!=GNOARG && (wr>=-1 || var==-1))
179           {
180             if (kvar>=0) { tree[kvar]=tree[binf]; kvar=-1; }
181             seq = newnode(Flambda,var,newleaf(a));
182             tree[a]=tree[seq];
183             topfunclambda(a, n, fun, pfun, wr);
184           }
185           break;
186       }
187       break;
188     case PPdefaultmulti:
189       i++;
190       break;
191     case PPstar:
192       break;
193     default:
194       die(n,"internal error: PPproto %d in genfuncbycode",mod);
195     }
196   }
197   return 0;
198 }
199 
200 /*
201   n: node
202   p:parent node
203 */
gentopfunc(int n,int p,int fun,int pfun)204 void gentopfunc(int n, int p, int fun, int pfun)
205 {
206   int x,y;
207   if (n<0)
208     return;
209   x=tree[n].x;
210   y=tree[n].y;
211   switch(tree[n].f)
212   {
213   case Flambda:
214     topfunclambda(n,p,fun,pfun,-1);
215     break;
216   case Fdeffunc:
217     if (fun>=0)
218     {
219       int nn = newfun(entryname(x));
220       int seq= newnode(Fassign,newnode(Fentry,tree[x].x,-1),newnode(Fentry,nn,-1));
221       int nf = newnode(Fdeffunc,newnode(Ffunction,nn,tree[x].y),tree[n].y);
222       topfunc(n,p,fun,pfun,nf,-1);
223       tree[n] = tree[seq];
224     }
225     else
226       topfunc(n,p,fun,pfun,n,-1);
227     break;
228   case Fassign:
229     if (tree[x].f==Fentry && tree[y].f==Flambda)
230     {
231       int nn = newfun(entryname(x));
232       int seq= newnode(Fentry,nn,-1);
233       int nf = newnode(Fdeffunc,newnode(Ffunction,nn,tree[y].x),tree[y].y);
234       topfunc(y,n,fun,pfun,nf,-1);
235       if (fun>=0) tree[y] = tree[seq];
236     }
237     else
238     {
239       gentopfunc(x,n,fun,pfun);
240       gentopfunc(y,n,fun,pfun);
241     }
242     break;
243   case Ffunction:
244     {
245       int nf;
246       if (x==OPn)
247       {
248         if (tree[y].f==Fsmall)
249         {
250           tree[n]=tree[y];
251           tree[n].x=-tree[n].x;
252           break;
253         }
254         else if (tree[y].f==Fconst)
255         {
256           value_t *val = value + tree[y].x;
257           if (val->type==CSTsmall || val->type==CSTsmallreal)
258           {
259             tree[n]=tree[y];
260             val->val.small=-val->val.small;
261             break;
262           }
263         }
264       }
265       nf = findfunction(entryname(n));
266       if (nf>=0 && lfunc[nf].spec<0)
267         topfuncproto(n,fun,pfun,nf);
268       gentopfunc(y,n,fun,pfun);
269     }
270     break;
271   case Fentry:
272   case Fconst:
273   case Fsmall:
274   case Fnoarg:
275     break;
276   case Frefarg:
277   case Ftag:
278     gentopfunc(x,n,fun,pfun);
279     break;
280   default:
281     if (tree[n].f>=FneedENTRY)
282       die(n,"Internal error: unknown func %s in gentopfunc",funcname(tree[n].f));
283     else
284     {
285       gentopfunc(x,n,fun,pfun);
286       gentopfunc(y,n,fun,pfun);
287     }
288   }
289 }
290