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