=================================================================== RCS file: /home/cvs/OpenXM_contrib2/asir2000/builtin/pf.c,v retrieving revision 1.13 retrieving revision 1.16 diff -u -p -r1.13 -r1.16 --- OpenXM_contrib2/asir2000/builtin/pf.c 2008/09/01 07:53:59 1.13 +++ OpenXM_contrib2/asir2000/builtin/pf.c 2009/07/23 01:04:29 1.16 @@ -45,7 +45,7 @@ * DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE, * PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE. * - * $OpenXM: OpenXM_contrib2/asir2000/builtin/pf.c,v 1.12 2005/10/05 07:38:08 noro Exp $ + * $OpenXM: OpenXM_contrib2/asir2000/builtin/pf.c,v 1.15 2008/11/18 20:52:47 ohara Exp $ */ #include "ca.h" #include "math.h" @@ -564,6 +564,11 @@ void Pcall(NODE arg,Obj *rp) { P p; V v; + NODE n,n1; + LIST list; + VECT vect; + pointer *a; + int len,i; p = (P)ARG0(arg); if ( !p || OID(p) != 2 ) @@ -571,9 +576,26 @@ void Pcall(NODE arg,Obj *rp) v = VR(p); if ( (int)v->attr != V_SR ) error("call : no such function"); - - else - *rp = (Obj)bevalf((FUNC)v->priv,BDY((LIST)ARG1(arg))); + else { + list = (LIST) ARG1(arg); + if ( list ) { + switch (OID(list)) { + case O_VECT: + vect = (VECT)list; len = vect->len; a = BDY(vect); + for ( i = len - 1, n = 0; i >= 0; i-- ) { + MKNODE(n1,a[i],n); n = n1; + } + MKLIST(list,n); + /* falling next case */ + case O_LIST: + *rp = (Obj)bevalf_with_opts((FUNC)v->priv,BDY(list),current_option); + return; + default: + break; + } + } + error("call : invalid argument"); + } } /* at=position of arg to be used for iteration */ @@ -591,7 +613,10 @@ void Pmapat(NODE arg,Obj *rp) int len,row,col,i,j,pos; Obj iter; pointer val; + NODE option; + option = current_option; + if ( argc(arg) < 3 ) error("mapat : too few arguments"); @@ -616,7 +641,7 @@ void Pmapat(NODE arg,Obj *rp) NEXTNODE(r0,r); iter = BDY(t); rest = NEXT(t); if ( !iter ) { - *rp = bevalf(f,node); + *rp = bevalf_with_opts(f,node,option); return; } switch ( OID(iter) ) { @@ -624,7 +649,7 @@ void Pmapat(NODE arg,Obj *rp) v = (VECT)iter; len = v->len; MKVECT(rv,len); for ( i = 0; i < len; i++ ) { BDY(r) = BDY(v)[i]; NEXT(r) = rest; - BDY(rv)[i] = bevalf(f,r0); + BDY(rv)[i] = bevalf_with_opts(f,r0,option); } *rp = (Obj)rv; break; @@ -633,7 +658,7 @@ void Pmapat(NODE arg,Obj *rp) for ( i = 0; i < row; i++ ) for ( j = 0; j < col; j++ ) { BDY(r) = BDY(m)[i][j]; NEXT(r) = rest; - BDY(rm)[i][j] = bevalf(f,r0); + BDY(rm)[i][j] = bevalf_with_opts(f,r0,option); } *rp = (Obj)rm; break; @@ -641,7 +666,7 @@ void Pmapat(NODE arg,Obj *rp) n = BDY((LIST)iter); for ( t0 = t = 0; n; n = NEXT(n) ) { BDY(r) = BDY(n); NEXT(r) = rest; - NEXTNODE(t0,t); BDY(t) = bevalf(f,r0); + NEXTNODE(t0,t); BDY(t) = bevalf_with_opts(f,r0,option); } if ( t0 ) NEXT(t) = 0; @@ -649,7 +674,7 @@ void Pmapat(NODE arg,Obj *rp) *rp = (Obj)rl; break; default: - *rp = bevalf(f,node); + *rp = bevalf_with_opts(f,node,option); break; } } @@ -668,7 +693,10 @@ void Pmap(NODE arg,Obj *rp) int len,row,col,i,j; Obj iter; pointer val; + NODE option; + option = current_option; + if ( argc(arg) < 2 ) error("mapat : too few arguments"); @@ -687,7 +715,7 @@ void Pmap(NODE arg,Obj *rp) NEXTNODE(r0,r); iter = BDY(t); rest = NEXT(t); if ( !iter ) { - *rp = bevalf(f,node); + *rp = bevalf_with_opts(f,node,option); return; } switch ( OID(iter) ) { @@ -695,7 +723,7 @@ void Pmap(NODE arg,Obj *rp) v = (VECT)iter; len = v->len; MKVECT(rv,len); for ( i = 0; i < len; i++ ) { BDY(r) = BDY(v)[i]; NEXT(r) = rest; - BDY(rv)[i] = bevalf(f,r0); + BDY(rv)[i] = bevalf_with_opts(f,r0,option); } *rp = (Obj)rv; break; @@ -704,7 +732,7 @@ void Pmap(NODE arg,Obj *rp) for ( i = 0; i < row; i++ ) for ( j = 0; j < col; j++ ) { BDY(r) = BDY(m)[i][j]; NEXT(r) = rest; - BDY(rm)[i][j] = bevalf(f,r0); + BDY(rm)[i][j] = bevalf_with_opts(f,r0,option); } *rp = (Obj)rm; break; @@ -712,7 +740,7 @@ void Pmap(NODE arg,Obj *rp) n = BDY((LIST)iter); for ( t0 = t = 0; n; n = NEXT(n) ) { BDY(r) = BDY(n); NEXT(r) = rest; - NEXTNODE(t0,t); BDY(t) = bevalf(f,r0); + NEXTNODE(t0,t); BDY(t) = bevalf_with_opts(f,r0,option); } if ( t0 ) NEXT(t) = 0; @@ -720,7 +748,7 @@ void Pmap(NODE arg,Obj *rp) *rp = (Obj)rl; break; default: - *rp = bevalf(f,node); + *rp = bevalf_with_opts(f,node,option); break; } }