| Bill Allombert on Thu, 11 Oct 2007 02:02:00 +0200 |
[Date Prev] [Date Next] [Thread Prev] [Thread Next] [Date Index] [Thread Index]
| Functions as first-class objects |
Hello PARI-dev, I would like to discuss moving user functions to first-class objects, and add support for anonymous functions and closures. The attached (-p1) patch implement that. Interestingly this patch reduces the code size while adding features. The idea is to remove the distinction between variables and functions: a function would just be a variable that hold a function object (of type t_CLOSURE in my patch). This means that functions could be passed as parameter, store in local variable and returned by a function. The consequence are far-reaching, so I would really appreciate comments. I would like to keep the syntax in the spirit of GP. 1) We need new syntax to define anonymous functions: The patch adds the following syntax: * (x1,...,xn)->EXPR : create an anonymous function. * x1->EXPR is accepted as a short-hand for (x1)->EXPR * f(x1,...,xn)=EXPR is accepted as a short-hand for f=(x1,...,xn)->EXPR * (EXPR)(x1,...,xn) evaluate the expression EXPR. If the result is a function, it call it on (x1,...,xn), else it fails. Oddity: * Nullary anonymous functions are defined by ()->EXPR * The parens in (EXPR)(x1,...,xn) tend to be annoying: (%34)(5), (f(5))(6), etc. * GP does not know about tuples thought the left part of (x1,...,xn)->EXPR looks like a tuple and the patch provide no support for currying/uncurrying: x->y->x+y and (x,y)->x+y require different calling syntax. * There is no syntactic sugar for basic operations on functions like slice: x->f(x,56), composition x->f(g(x)), etc. 2) We have to print functions since they are objects now. * The patch call all function to be printed as (x1,...,xn)->EXPR even if they were defined through f(x1,...,xn)=EXPR because the latter is actually an affectation and that would break copy-paste: ? f(x)=x^4+1 %1 = (x) -> x^4+1 ? g=(x) -> x^4+1 %2 = (x) -> x^4+1 ? f(x)==g(x) %3 = 1 * Actually closures break copy-paste because they refer to 'hidden' data: ? f(x)=y->x+y %4 = (x) -> y->x+y ? f(5) %5 = (y) -> x+y ? (%5)(6) %6 = 11 ? ((y) -> x+y)(6) %7 = x + 6 3) Incompatibilities: * f(x)=x^4+1 is equivalent to f=(x)->x^4+1 which return the 'value' (x)->x^4+1 instead of void: ? f(x)=x^4+1 %1 = (x) -> x^4+1 * Calling a function without () no more evaluate it: ? f %2 = (x) -> x^4+1 4) Deficiencies * The patch does not provide any low-level operations on closures. * Built-in functions are not first-class objects, and there are no obvious way to encapsulate them in a user function, due to some prototype code which have now user functions equivalent. * While functions act as closure with respect to lexically-scoped local variables, variables values changes occuring after the function is defined are ignored. * It is not possible to define recursive anonymous functions (short of the Y combinator). Maybe we need to add a 'self' construction: ? g(f)=x->if(x,x*f(x-1),1) %17 = (f) -> x->if(x,x*f(x-1),1) ? fix=f->(x->f(y->(x(x))(y)))(x->f(y->(x(x))(y))) %18 = (f) -> (x->f(y->(x(x))(y)))(x->f(y->(x(x))(y))) ? (fix(g))(6) %19 = 720 That's all for today :) Cheers, Bill PS: I dedicate this patch to Henri Cohen for his birthday. Happy birthday, Henri!
Index: parigp3/src/gp/gp.c
===================================================================
--- parigp3.orig/src/gp/gp.c 2007-10-11 00:45:32.000000000 +0200
+++ parigp3/src/gp/gp.c 2007-10-11 00:46:05.000000000 +0200
@@ -390,6 +390,7 @@
t_LIST : list [ code ] [ n ] [ nmax ][ vec ]\n\
t_STR : string [ code ] [ man_1 ] ... [ man_k ]\n\
t_VECSMALL: vec. small ints [ code ] [ x_1 ] ... [ x_k ]\n\
+ t_CLOSURE: functions [ code ] [ arity ] [ code ] [ operand ] [ data ] [text ]\n\
\n");
}
@@ -668,14 +669,14 @@
switch(EpVALENCE(ep))
{
- case EpUSER:
- if (!ep->help || long_help) pariputs(ep->code);
- if (!ep->help) return;
- if (long_help) { pariputs("\n\n"); long_help=0; }
- break;
-
case EpVAR:
- if (!ep->help) { aide_print(s, "user defined variable"); return; }
+ if (typ(ep->value)==t_CLOSURE)
+ {
+ if (!ep->help || long_help) pariprintf("%s = %s",ep->name,GSTR(gel(ep->value,5)));
+ if (!ep->help) return;
+ if (long_help) { pariputs("\n\n"); long_help=0; }
+ }
+ else if (!ep->help) { aide_print(s, "user defined variable"); return; }
long_help=0; break;
case EpINSTALL:
Index: parigp3/src/graph/plotport.c
===================================================================
--- parigp3.orig/src/graph/plotport.c 2007-10-11 00:45:33.000000000 +0200
+++ parigp3/src/graph/plotport.c 2007-10-11 00:46:05.000000000 +0200
@@ -103,7 +103,7 @@
static GEN
READ_EXPR(GEN code, GEN x) {
- if (typ(code)==t_POL || typ(code[1])==t_POL) return gsubst(code,0,x);
+ if (typ(code)!=t_CLOSURE) return gsubst(code,0,x);
set_lex(-1, x); return closure_evalgen(code);
}
Index: parigp3/src/language/anal.c
===================================================================
--- parigp3.orig/src/language/anal.c 2007-10-11 00:45:32.000000000 +0200
+++ parigp3/src/language/anal.c 2007-10-11 00:46:05.000000000 +0200
@@ -637,6 +637,14 @@
case '-':
*lex+=2; yylloc->end = *lex; return KSE;
}
+ if (**lex==')' && (*lex)[1]=='-' && (*lex)[2]=='>')
+ {
+ *lex+=3; yylloc->end = *lex; return KPARROW;
+ }
+ if (**lex=='-' && (*lex)[1]=='>')
+ {
+ *lex+=2; yylloc->end = *lex; return KARROW;
+ }
if (**lex=='<' && (*lex)[1]=='>')
{
*lex+=2; yylloc->end = *lex; return KNE;
@@ -1126,9 +1134,10 @@
int i;
for (i = 0; i < functions_tblsz; i++)
for (ep = functions_hash[i]; ep; ep = ep->next)
- if (EpVALENCE(ep) == EpUSER)
+ if (EpVALENCE(ep) == EpVAR && typ(ep->value)==t_CLOSURE)
{
- pariputc('{'); pariputs(ep->code);
+ pariputc('{');
+ pariprintf("%s = %s",ep->name,GSTR(gel(ep->value,5)));
pariputc('}'); pariputs("\n\n");
}
}
Index: parigp3/src/language/anal.h
===================================================================
--- parigp3.orig/src/language/anal.h 2007-10-11 00:45:32.000000000 +0200
+++ parigp3/src/language/anal.h 2007-10-11 00:46:05.000000000 +0200
@@ -94,8 +94,8 @@
#define EpVALENCE(ep) ((ep)->valence & 0xFF)
#define EpSTATIC(ep) ((ep)->valence & 0x100)
#define EpSETSTATIC(ep) ((ep)->valence |= 0x100)
-#define EpPREDEFINED(ep) (EpVALENCE(ep) < EpUSER)
-enum { EpUSER = 100, EpNEW, EpALIAS, EpVAR, EpMEMBER, EpINSTALL };
+#define EpPREDEFINED(ep) (EpVALENCE(ep) < EpNEW)
+enum { EpNEW=100, EpALIAS, EpVAR, EpMEMBER, EpINSTALL };
#define initial_value(ep) ((ep)+1)
extern entree **varentries;
Index: parigp3/src/language/compile.c
===================================================================
--- parigp3.orig/src/language/compile.c 2007-10-11 00:45:32.000000000 +0200
+++ parigp3/src/language/compile.c 2007-10-11 00:46:05.000000000 +0200
@@ -77,29 +77,31 @@
}
static GEN
-getclosure_var(struct codepos *pos, long nbmvar)
+getfunction(long n, struct codepos *pos, long arity, long nbmvar, GEN text)
{
long lop =s_opcode.n+1-pos->opcode;
long ldat=s_data.n+1-pos->data;
- GEN cl=cgetg(nbmvar?5:4,t_VEC);
+ GEN cl=cgetg(nbmvar?7:6,t_CLOSURE);
char *s;
long i;
- gel(cl,1) = cgetg(nchar2nlong(lop)+1, t_STR);
- gel(cl,2) = cgetg(lop, t_VECSMALL);
- gel(cl,3) = cgetg(ldat, t_VEC);
- if (nbmvar) gel(cl,4) = zerovec(nbmvar);
- s=GSTR(gel(cl,1))-1;
+ cl[1] = arity;
+ gel(cl,2) = cgetg(nchar2nlong(lop)+1, t_STR);
+ gel(cl,3) = cgetg(lop, t_VECSMALL);
+ gel(cl,4) = cgetg(ldat, t_VEC);
+ gel(cl,5) = text;
+ if (nbmvar) gel(cl,6) = zerovec(nbmvar);
+ s=GSTR(gel(cl,2))-1;
for(i=1;i<lop;i++)
{
s[i] = opcode[i+pos->opcode-1];
- mael(cl, 2, i) = operand[i+pos->opcode-1];
+ mael(cl, 3, i) = operand[i+pos->opcode-1];
}
s[i]=0;
s_opcode.n=pos->opcode;
s_operand.n=pos->opcode;
for(i=1;i<ldat;i++)
{
- gmael(cl, 3, i) = gcopy(data[i+pos->data-1]);
+ gmael(cl, 4, i) = gcopy(data[i+pos->data-1]);
gunclone(data[i+pos->data-1]);
}
s_data.n=pos->data;
@@ -108,12 +110,14 @@
return cl;
}
+
static GEN
-getclosure(struct codepos *pos)
+getclosure(long n, struct codepos *pos)
{
- return getclosure_var(pos,0);
+ return getfunction(n,pos,0,0,strntoGENstr(tree[n].str,tree[n].len));
}
+
static void
op_push(op_code o, long x)
{
@@ -551,6 +555,27 @@
enum { RET_GEN, RET_INT, RET_LONG, RET_VOID };
static void
+compilecall(long n, int mode)
+{
+ pari_sp ltop=avma;
+ long j;
+ long x=tree[n].x;
+ long y=tree[n].y;
+ GEN arg=listtogen(y,Flistarg);
+ long nb=lg(arg)-1;
+ compilenode(x,Ggen,0);
+ for (j=1;j<=nb;j++)
+ if (tree[arg[j]].f!=Fnoarg)
+ compilenode(arg[j], Ggen,0);
+ else
+ op_push(OCpushlong,0);
+ op_push(OCcalluser, nb);
+ compilecast(n,Ggen,mode);
+ avma=ltop;
+ return;
+}
+
+static void
compilefunc(long n, int mode)
{
pari_sp ltop=avma;
@@ -565,23 +590,24 @@
long lnc=first_safe_arg(arg);
long nbpointers=0;
long nb=lg(arg)-1, lev=0;
- entree *ep = getfunc(n);
+ entree *ep=getfunc(n);
entree *ev[8];
- if (EpVALENCE(ep)==EpVAR)
- pari_err(talker2,"not a function in function call",
- tree[n].str, get_origin());
- if (EpVALENCE(ep)==EpUSER|| EpVALENCE(ep)==EpNEW)
+ if (EpVALENCE(ep)==EpVAR || EpVALENCE(ep)==EpNEW)
{
+ long vn=getmvar(ep);
+ if (vn)
+ op_push(OCpushlex,vn);
+ else
+ op_push(OCpushdyn,(long)ep);
for (j=1;j<=nb;j++)
if (tree[arg[j]].f!=Fnoarg)
compilenode(arg[j], Ggen,0);
else
op_push(OCpushlong,0);
- op_push(OCpushlong, nb);
if (tree[n].f==Fderfunc)
- op_push(OCderivuser, (long) ep);
+ op_push(OCderivuser, nb);
else
- op_push(OCcalluser, (long) ep);
+ op_push(OCcalluser, nb);
compilecast(n,Ggen,mode);
avma=ltop;
return;
@@ -794,7 +820,7 @@
compilecast(a,Gvoid,type);
else
compilenode(a,type,flag);
- op_push(OCpushgen, data_push(getclosure(&pos)));
+ op_push(OCpushgen, data_push(getclosure(a,&pos)));
break;
}
case 'V':
@@ -1146,26 +1172,25 @@
case Ffunction:
compilefunc(n, mode);
return;
- case Fdeffunc:
+ case Fcall:
+ compilecall(n, mode);
+ return;
+ case Flambda:
{
pari_sp ltop=avma;
struct codepos pos;
long i;
- GEN arg2=listtogen(tree[x].y,Flistarg);
- entree *ep=getfunc(x);
+ GEN arg2=listtogen(x,Flistarg);
long loc=y;
long arity=lg(arg2)-1,nbmvar=numbmvar();
+ GEN text,textv=cgetg(5,t_VEC);
+ gel(textv,1)=strtoGENstr("(");
+ gel(textv,2)=strntoGENstr(tree[x].str,tree[x].len);
+ gel(textv,3)=strtoGENstr(") -> ");
+ gel(textv,4)=strntoGENstr(tree[y].str,tree[y].len);
+ text=concat(textv,NULL);
if (loc>=0)
while (tree[loc].f==Fseq) loc=tree[loc].x;
- if (ep->valence!=EpNEW && ep->valence!=EpUSER)
- {
- if (ep->valence==EpVAR)
- pari_err(talker2,"this is a variable",
- tree[n].str,get_origin());
- else
- pari_err(talker2,"cannot redefine GP functions",
- tree[n].str,get_origin());
- }
getcodepos(&pos);
if (arity) op_push(OCnewframe,arity);
for (i=1;i<=arity;i++)
@@ -1184,7 +1209,7 @@
struct codepos lpos;
getcodepos(&lpos);
compilenode(tree[a].y,Ggen,0);
- op_push(OCpushgen, data_push(getclosure(&lpos)));
+ op_push(OCpushgen, data_push(getclosure(tree[a].y,&lpos)));
en=getvar(tree[a].x);
var_push(en,Lmy);
op_push(OCdefaultarg,-arity+i-1);
@@ -1199,12 +1224,8 @@
compilenode(y,Ggen,FLreturn);
else
compilecast(n,Gvoid,Ggen);
- op_push(OCpushgen, data_push(getclosure_var(&pos,nbmvar)));
- op_push(OCpushgen, data_push(
- strntoGENstr(tree[n].str,tree[n].len)));
- op_push(OCpushlong, arity);
- op_push(OCdeffunc, (long) ep);
- compilecast(n,Gvoid,mode);
+ op_push(OCpushgen, data_push(getfunction(n,&pos,arity,nbmvar,text)));
+ if(nbmvar) op_push(OCsaveframe,0);
avma=ltop;
break;
}
@@ -1224,6 +1245,6 @@
{
struct codepos pos={0,0,0,-1};
compilenode(n,Ggen,0);
- return getclosure(&pos);
+ return getclosure(n,&pos);
}
Index: parigp3/src/language/es.c
===================================================================
--- parigp3.orig/src/language/es.c 2007-10-11 00:45:33.000000000 +0200
+++ parigp3/src/language/es.c 2007-10-11 00:46:05.000000000 +0200
@@ -1307,6 +1307,7 @@
case t_LIST : s="t_LIST"; break;
case t_STR : s="t_STR"; break;
case t_VECSMALL:s="t_VECSMALL";break;
+ case t_CLOSURE: s="t_CLOSURE"; break;
default: pari_err(talker,"unknown type %ld",t);
s = NULL; /* not reached */
}
@@ -1370,7 +1371,8 @@
{
pariprintf("(lmax=%ld):", list_nmax(x));
x = list_data(x); lx = x? lg(x): 1;
- }
+ } else if (tx == t_CLOSURE)
+ pariprintf("(arity=%ld):", x[1]);
for (i=1; i<lx; i++) pariprintf(VOIR_STRING2,x[i]);
bl+=2; pariputc('\n');
switch(tx)
@@ -1430,7 +1432,16 @@
dbg(gel(x,i),nb,bl);
}
break;
-
+ case t_CLOSURE:
+ blancs(bl); pariputs("code = "); dbg(gel(x,2),nb,bl);
+ blancs(bl); pariputs("operand = "); dbg(gel(x,3),nb,bl);
+ blancs(bl); pariputs("data = "); dbg(gel(x,4),nb,bl);
+ blancs(bl); pariputs("text = "); dbg(gel(x,5),nb,bl);
+ if (lg(x)==7)
+ {
+ blancs(bl); pariputs("frame = "); dbg(gel(x,6),nb,bl);
+ }
+ break;
case t_MAT:
{
GEN c = gel(x,1);
@@ -2086,7 +2097,8 @@
case t_STR:
quote_string(GSTR(g)); break;
-
+ case t_CLOSURE:
+ pariputs(GSTR(gel(g,5))); break;
case t_MAT:
{
void (*print)(GEN, pariout_t *, int);
@@ -2453,6 +2465,9 @@
pariputs(GSTR(g)); break;
#endif
}
+ case t_CLOSURE:
+ pariputs(GSTR(gel(g,5)));
+ break;
case t_MAT:
{
void (*print)(GEN, pariout_t *, int);
Index: parigp3/src/language/eval.c
===================================================================
--- parigp3.orig/src/language/eval.c 2007-10-11 00:45:32.000000000 +0200
+++ parigp3/src/language/eval.c 2007-10-11 00:46:05.000000000 +0200
@@ -171,10 +171,6 @@
if (ep->code) {gpfree(ep->code); ep->code=NULL;}
switch(EpVALENCE(ep))
{
- case EpUSER:
- while (ep->pvalue!=INITIAL) pop_val(ep);
- gunclone((GEN)ep->value); ep->value=NULL;
- break;
case EpVAR:
while (ep->pvalue!=INITIAL) pop_val(ep);
break;
@@ -213,11 +209,7 @@
if (v->flag == COPY_VAL && !pop_entree_bloc(ep, loc)) return 0;
ep->value = v->value;
ep->pvalue= (char*) v->prev;
- if (ep->pvalue == INITIAL)
- {
- if (ep->code) ep->valence=EpUSER;
- else if (ep->value==NULL) ep->valence=EpNEW;
- }
+ ep->valence=v->valence;
gpfree((void*)v); return 1;
}
@@ -457,15 +449,16 @@
derivuserwrap(GEN x, void* E)
{
pari_sp ltop;
- entree *ep=(entree*)E;
+ GEN fun=(GEN)E;
GEN z;
+ long arity=fun[1];
long j;
gel(st,sp)=x;
- for (j=1;j<ep->arity;j++)
- gel(st,sp+j)=gel(st,sp+j-ep->arity);
- sp+=ep->arity;
+ for (j=1;j<arity;j++)
+ gel(st,sp+j)=gel(st,sp+j-arity);
+ sp+=arity;
ltop=avma;
- closure_eval((GEN) ep->value);
+ closure_eval(fun);
if (br_status)
{
if (br_status!=br_RETURN)
@@ -479,6 +472,7 @@
return z;
}
+
INLINE long
closure_varn(GEN x)
{
@@ -530,15 +524,15 @@
static void
closure_eval(GEN C)
{
- char *code=GSTR(gel(C,1))-1;
- GEN oper=gel(C,2);
- GEN data=gel(C,3);
+ char *code=GSTR(gel(C,2))-1;
+ GEN oper=gel(C,3);
+ GEN data=gel(C,4);
long saved_sp=sp;
long saved_rp=rp;
long pc, j, nbmvar=0, nblvar=0;
- if (lg(C)==5)
+ if (lg(C)==7)
{
- GEN z=gel(C,4);
+ GEN z=gel(C,6);
long l=lg(z)-1;
stack_alloc(&s_var,l);
s_var.n+=l;
@@ -591,8 +585,7 @@
gel(st,sp++)=(GEN)ep->value;
break;
default:
- gel(st,sp++)=0;
- goto calluser; /*Maybe it is a function*/
+ pari_err(talker,"no such variable `%s'",ep->name);
}
break;
case OCpushlex:
@@ -1006,68 +999,67 @@
case OCderivuser:
{
GEN z;
- long n=st[--sp];
- ep = (entree*) operand;
- if (ep->valence!=EpUSER)
- {
- if (ep->valence==EpNEW)
- pari_err(talker,"function '%s' not yet defined",ep->name);
- else
- pari_err(talker,"not a function in function call: %s",ep->name);
- }
- if (n>ep->arity)
- pari_err(talker,"Too many arguments for function '%s'",ep->name);
- for (j=n+1;j<=ep->arity;j++)
+ long n=operand;
+ long arity;
+ GEN fun = gel(st,sp-1-n);
+ if (typ(fun)!=t_CLOSURE)
+ pari_err(talker,"not a function in function call");
+ arity=fun[1];
+ if (n>arity)
+ pari_err(talker,"too many parameters in user-defined function call");
+ for (j=n+1;j<=arity;j++)
gel(st,sp++)=0;
- z = derivnum((void*)ep, derivuserwrap, gel(st,sp-ep->arity), precreal);
- sp-=ep->arity;
+ z = derivnum((void*)fun, derivuserwrap, gel(st,sp-arity), precreal);
+ sp-=arity;
+ sp--;
gel(st, sp++) = z;
break;
}
case OCcalluser:
-calluser:
{
pari_sp ltop;
- long n=st[--sp];
- entree *ep = (entree*) operand;
+ long n=operand;
+ GEN fun = gel(st,sp-1-n);
+ long arity;
GEN z;
- if (ep->valence!=EpUSER)
+ if (typ(fun)!=t_CLOSURE)
{
- int w;
- if (whatnow_fun && (w = whatnow_fun(ep->name,1)))
- pari_err(obsoler, ep->name, w);
- else
+ if (typ(fun) == t_POL && lg(fun) == 4
+ && gel(fun,2)==gen_0 && gel(fun,3)==gen_1)
{
- if (ep->valence==EpNEW)
- pari_err(talker,"function '%s' not yet defined",ep->name);
- else
- pari_err(talker,"not a function in function call: %s",ep->name);
+ int w;
+ ep = varentries[varn(fun)];
+ if (whatnow_fun && (w = whatnow_fun(ep->name,1)))
+ pari_err(obsoler, ep->name, w);
}
+ pari_err(talker,"not a function in function call");
}
- if (n>ep->arity)
- pari_err(talker,"Too many arguments for function '%s'",ep->name);
- for (j=n+1;j<=ep->arity;j++)
+ arity=fun[1];
+ if (n>arity)
+ pari_err(talker,"too many parameters in user-defined function call");
+ for (j=n+1;j<=arity;j++)
gel(st,sp++)=0;
#ifdef STACK_CHECK
if (PARI_stack_limit && (void*) &z <= PARI_stack_limit)
pari_err(talker, "deep recursion");
#endif
ltop=avma;
- closure_eval((GEN) ep->value);
+ closure_eval(fun);
if (br_status)
{
if (br_status!=br_RETURN)
pari_err(talker, "break/next/allocatemem not allowed here");
avma=ltop;
- sp-=ep->arity;
+ sp-=arity;
z = br_res ? gcopy(br_res) : gnil;
reset_break();
}
- else
- z = gerepileupto(ltop, gel(st,--sp));
- gel(st, sp++) = z;
- break;
- }
+ else
+ z = gerepileupto(ltop, gel(st,--sp));
+ sp--;
+ gel(st, sp++) = z;
+ break;
+ }
case OCnewframe:
stack_alloc(&s_var,operand);
s_var.n+=operand;
@@ -1078,6 +1070,19 @@
var[s_var.n-j].value=gen_0;
}
break;
+ case OCsaveframe:
+ {
+ GEN cl=gcopy(gel(st,sp-1));
+ if (lg(cl)==7)
+ {
+ GEN v=gel(cl,6);
+ long l=lg(v)-1;
+ for(j=1;j<=l;j++)
+ gel(v,j)=gcopy(var[s_var.n-j].value);
+ }
+ gel(st,sp-1) = cl;
+ }
+ break;
case OCvec:
gel(st,sp++)=cgetg(operand,t_VEC);
break;
@@ -1094,37 +1099,6 @@
gel(st,sp-1) = z;
}
break;
- case OCdeffunc:
- ep=(entree*)operand;
- switch(ep->valence)
- {
- case EpUSER:
- gpfree(ep->code);
- /*FIXME: the function might be in use...
- gunclone(ep->value);
- */
- break;
- case EpNEW:
- ep->valence = EpUSER;
- break;
- default:
- pari_err(talker,"function name expected");
- }
- {
- GEN cl=gel(st,sp-3);
- if (lg(cl)==5)
- {
- GEN v=gel(cl,4);
- long l=lg(v)-1;
- for(j=1;j<=l;j++)
- gel(v,j)=var[s_var.n-j].value;
- }
- ep->value = (void *) gclone(cl);
- }
- ep->code = pari_strdup(GSTR(gel(st,sp-2)));
- ep->arity = st[sp-1];
- sp-=3;
- break;
case OCpop:
sp-=operand;
break;
@@ -1207,17 +1181,10 @@
char * code;
GEN oper;
long i;
- if (typ(C)==t_STR)
- {
- entree *ep=fetch_entry(GSTR(C),strlen(GSTR(C)));
- if (ep->valence!=EpUSER)
- pari_err(typeer,"disassemble");
- C=(GEN)ep->value;
- }
- if (typ(C)!=t_VEC || lg(C)!=4 || typ(C[1])!=t_STR || typ(C[2])!=t_VECSMALL)
+ if (typ(C)!=t_CLOSURE)
pari_err(typeer,"disassemble");
- code=GSTR(gel(C,1))-1;
- oper=gel(C,2);
+ code=GSTR(gel(C,2))-1;
+ oper=gel(C,3);
for(i=1;i<lg(oper);i++)
{
op_code opcode=(op_code) code[i];
@@ -1378,12 +1345,10 @@
pariprintf("callvoid\t%s\n",ep->name);
break;
case OCderivuser:
- ep=(entree*)operand;
- pariprintf("derivuser\t\t%s\n",ep->name);
+ pariprintf("derivuser\t%ld\n",operand);
break;
case OCcalluser:
- ep=(entree*)operand;
- pariprintf("calluser\t%s\n",ep->name);
+ pariprintf("calluser\t%ld\n",operand);
break;
case OCvec:
pariprintf("vec\t\t%ld\n",operand);
@@ -1394,13 +1359,12 @@
case OCmat:
pariprintf("mat\t\t%ld\n",operand);
break;
- case OCdeffunc:
- ep=(entree*)operand;
- pariprintf("deffunc\t\t%s\n",ep->name);
- break;
case OCnewframe:
pariprintf("newframe\t%ld\n",operand);
break;
+ case OCsaveframe:
+ pariprintf("saveframe\n");
+ break;
case OCpop:
pariprintf("pop\t\t%ld\n",operand);
break;
Index: parigp3/src/language/init.c
===================================================================
--- parigp3.orig/src/language/init.c 2007-10-11 00:45:33.000000000 +0200
+++ parigp3/src/language/init.c 2007-10-11 00:46:05.000000000 +0200
@@ -1196,7 +1196,7 @@
/* */
/*******************************************************************/
/* lontyp[tx] = 0 (non recursive type) or number of codewords for type tx */
-const long lontyp[] = { 0,0,0,1,1,2,1,2,1,1, 2,2,0,1,1,1,1,1,1,1, 0,0,0 };
+const long lontyp[] = { 0,0,0,1,1,2,1,2,1,1, 2,2,0,1,1,1,1,1,1,1, 0,0,0,2 };
static GEN
list_internal_copy(GEN z, long nmax)
Index: parigp3/src/language/opcode.h
===================================================================
--- parigp3.orig/src/language/opcode.h 2007-10-11 00:45:33.000000000 +0200
+++ parigp3/src/language/opcode.h 2007-10-11 00:46:05.000000000 +0200
@@ -27,7 +27,7 @@
OCcompo1ptr,OCcompo2ptr,OCcompoCptr,OCcompoLptr,
OCcalllong,OCcallgen,OCcallgen2,OCcallint,OCcallvoid,OCcalluser,
OCderivgen,OCderivuser,
- OCdeffunc,OCnewframe,
+ OCnewframe,OCsaveframe,
OCpushdyn,OCstoredyn,OCnewptrdyn,OCsimpleptrdyn,
OCpushlex,OCstorelex,OCnewptrlex,OCsimpleptrlex,
OCgetarg,OCdefaultarg,OClocalvar,OClocalvar0} op_code;
Index: parigp3/src/language/parse.y
===================================================================
--- parigp3.orig/src/language/parse.y 2007-10-11 00:45:32.000000000 +0200
+++ parigp3/src/language/parse.y 2007-10-11 00:46:05.000000000 +0200
@@ -158,6 +158,14 @@
return newconst(CSTint,loc);
}
+static long
+newfunc(CSTtype t, struct node_loc *func, long args, long code,
+ struct node_loc *loc)
+{
+ long name=newnode(Fentry,newconst(t,func),-1,func);
+ return newnode(Faffect,name,newnode(Flambda,args,code,loc),loc);
+}
+
%}
%name-prefix="pari_"
%pure-parser
@@ -169,7 +177,7 @@
%left KDER
%left INT LVAL
%left ';' ','
-%right '=' KPE KSE KME KDE KDRE KEUCE KMODE KSRE KSLE
+%right KPARROW KARROW '=' KPE KSE KME KDE KDRE KEUCE KMODE KSRE KSLE
%left '&' KAND '|' KOR
%left KEQ KNE KGE '<' KLE '>'
%left '+' '-'
@@ -220,6 +228,7 @@
| '%' {$$=newopcall(OPhist,-1,-1,&@$);}
| '%' KINTEGER {$$=newopcall(OPhist,newintnode(&@2),-1,&@$);}
| '%' backticks {$$=newopcall(OPhist,newnode(Fsmall,-$2,-1,&@$),-1,&@$);}
+ | '(' expr ')' '(' listarg ')' {$$=newnode(Fcall,$2,$5,&@$);}
| funcid {$$=$1;}
| funcder {$$=$1;}
| lvalue %prec LVAL {$$=$1;}
@@ -300,17 +309,24 @@
| listarg ',' arg {$$=newnode(Flistarg,$1,$3,&@$);}
;
-funcid: KENTRY '(' listarg ')' {$$=newnode(Ffunction,newconst(CSTentry,&@1),$3,&@$);}
+funcid: KENTRY '(' listarg ')'
+ {$$=newnode(Ffunction,newconst(CSTentry,&@1),$3,&@$);}
;
-funcder: KENTRY KDER listarg ')' {$$=newnode(Fderfunc,newconst(CSTentry,&@1),$3,&@$);}
+funcder: KENTRY KDER listarg ')'
+ {$$=newnode(Fderfunc,newconst(CSTentry,&@1),$3,&@$);}
+;
memberid:
expr '.' KENTRY {$$=newnode(Ffunction,newconst(CSTmember,&@3),$1,&@$);}
;
-definition: funcid '=' seq %prec DEFFUNC {$$=newnode(Fdeffunc,$1,$3,&@$);}
- | memberid '=' seq %prec DEFFUNC {$$=newnode(Fdeffunc,$1,$3,&@$);}
+definition: KENTRY '(' listarg ')' '=' seq %prec DEFFUNC
+ {$$=newfunc(CSTentry,&@1,$3,$6,&@$);}
+ | expr '.' KENTRY '=' seq %prec DEFFUNC
+ {$$=newfunc(CSTmember,&@3,$1,$5,&@$);}
+ | lvalue KARROW seq {$$=newnode(Flambda, $1,$3,&@$);}
+ | '(' listarg KPARROW seq {$$=newnode(Flambda, $2,$4,&@$);}
;
%%
Index: parigp3/src/language/tree.h
===================================================================
--- parigp3.orig/src/language/tree.h 2007-10-11 00:45:32.000000000 +0200
+++ parigp3/src/language/tree.h 2007-10-11 00:46:05.000000000 +0200
@@ -24,7 +24,8 @@
Frefarg,
Fconst,Fsmall,
Ftag,
- Fentry,Ffunction,Fderfunc,Fdeffunc,
+ Fentry,Fcall,Ffunction,Fderfunc,
+ Flambda
} Ffunc;
#define Flastfunc (Fdeffunc)
Index: parigp3/src/test/64/program
===================================================================
--- parigp3.orig/src/test/64/program 2007-10-11 00:45:33.000000000 +0200
+++ parigp3/src/test/64/program 2007-10-11 00:46:05.000000000 +0200
@@ -64,7 +64,7 @@
, 4582267480000687864, -7629613429408037667, 4813661187837882458, -776313336
5088963398, 63, 3001673639903682625])
? getstack
-80
+120
? if(3<2,print("bof"),print("ok"));
ok
? kill(y);print(x+y);
@@ -75,6 +75,7 @@
? f=12
12
? g(u)=if(u,,return(17));u+2
+(u) -> if(u,,return(17));u+2
? g(2)
4
? g(0)
@@ -131,7 +132,7 @@
3
? kill(addii)
? getheap
-[23, 1678]
+[25, 1758]
? print("Total time spent: ",gettime);
Total time spent: 8
? \q
Index: parigp3/src/headers/paritype.h
===================================================================
--- parigp3.orig/src/headers/paritype.h 2007-10-11 00:07:00.000000000 +0200
+++ parigp3/src/headers/paritype.h 2007-10-11 00:46:05.000000000 +0200
@@ -35,7 +35,8 @@
t_MAT = 19,
t_LIST = 20,
t_STR = 21,
- t_VECSMALL= 22
+ t_VECSMALL= 22,
+ t_CLOSURE = 23
};
#define is_const_t(t) ((t) < t_POLMOD)
#define is_extscalar_t(t) ((t) <= t_POL)
Index: parigp3/src/basemath/gen3.c
===================================================================
--- parigp3.orig/src/basemath/gen3.c 2007-10-11 00:07:00.000000000 +0200
+++ parigp3/src/basemath/gen3.c 2007-10-11 00:46:05.000000000 +0200
@@ -3150,6 +3150,9 @@
case t_RFRAC:
av = avma;
return gerepileupto(av, gdiv(geval(gel(x,1)), geval(gel(x,2))));
+ case t_CLOSURE:
+ if (x[1]) pari_err(impl,"eval on functions with parameters");
+ return closure_evalres(x);
}
pari_err(typeer,"geval");
return NULL; /* not reached */
@@ -3165,7 +3168,7 @@
{
case t_INT: case t_REAL: case t_FRAC: case t_FFELT:
case t_INTMOD: case t_PADIC: case t_QFR: case t_QFI:
- case t_LIST: case t_STR: case t_VECSMALL:
+ case t_LIST: case t_STR: case t_VECSMALL: case t_CLOSURE:
return x;
case t_COMPLEX:
Index: parigp3/src/gp/gp_rl.c
===================================================================
--- parigp3.orig/src/gp/gp_rl.c 2007-10-11 00:07:00.000000000 +0200
+++ parigp3/src/gp/gp_rl.c 2007-10-11 00:46:05.000000000 +0200
@@ -288,7 +288,7 @@
if (end < 0 || rl_line_buffer[end] == '(')
return 0; /* not from command_generator or already there */
ep = do_alias(current_ep); /* current_ep set in command_generator */
- if (EpVALENCE(ep) < EpUSER)
+ if (EpVALENCE(ep) < EpNEW)
{ /* is it a constant masked as a function (e.g Pi)? */
s = ep->help; if (!s) return 1;
while (is_keyword_char(*s)) s++;
@@ -296,7 +296,6 @@
}
switch(EpVALENCE(ep))
{
- case EpUSER:
case EpINSTALL: return 1;
}
return 0;