===================================================================
RCS file: /home/cvs/OpenXM_contrib2/asir2000/builtin/pf.c,v
retrieving revision 1.12
retrieving revision 1.23
diff -u -p -r1.12 -r1.23
--- OpenXM_contrib2/asir2000/builtin/pf.c	2005/10/05 07:38:08	1.12
+++ OpenXM_contrib2/asir2000/builtin/pf.c	2018/03/27 06:29:19	1.23
@@ -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.11 2005/09/27 03:00:21 noro Exp $ 
+ * $OpenXM: OpenXM_contrib2/asir2000/builtin/pf.c,v 1.22 2015/08/14 13:51:54 fujimoto Exp $ 
 */
 #include "ca.h"
 #include "math.h"
@@ -62,17 +62,19 @@ void make_itri(void);
 void make_tri(void);
 void make_exp(void);
 void simplify_pow(PFINS,Obj *);
+FNODE partial_eval(FNODE f);
 
 void Pfunctor(),Pargs(),Pfunargs(),Pvtype(),Pcall(),Pdeval(),Pfunargs_ext();
 void Pregister_handler();
 void Peval_quote();
-void Pmapat();
+void Pmapat(), Pmap();
 void Padd_handler();
 void Plist_handler();
 void Pclear_handler();
 
 struct ftab puref_tab[] = {
 	{"mapat",Pmapat,-99999999},
+	{"map",Pmap,-99999999},
 	{"functor",Pfunctor,1},
 	{"args",Pargs,1},
 	{"funargs",Pfunargs,1},
@@ -88,18 +90,12 @@ struct ftab puref_tab[] = {
 	{0,0,0},
 };
 
-#if defined(PARI)
-int p_pi(),p_e();
-int p_log(),p_exp(),p_pow();
-int p_sin(),p_cos(),p_tan(),p_asin(),p_acos(),p_atan();
-int p_sinh(),p_cosh(),p_tanh(),p_asinh(),p_acosh(),p_atanh();
-#else
-int p_pi,p_e;
-int p_log,p_exp,p_pow;
-int p_sin,p_cos,p_tan,p_asin,p_acos,p_atan;
-int p_sinh,p_cosh,p_tanh,p_asinh,p_acosh,p_atanh;
-#endif
+int mp_pi(),mp_e();
+int mp_exp(), mp_log(), mp_pow();
+int mp_sin(),mp_cos(),mp_tan(),mp_asin(),mp_acos(),mp_atan();
+int mp_sinh(),mp_cosh(),mp_tanh(),mp_asinh(),mp_acosh(),mp_atanh();
 
+
 static V *uarg,*darg;
 static P x,y;
 static PF pidef,edef;
@@ -114,6 +110,8 @@ static PF asinhdef,acoshdef,atanhdef;
 double const_pi() { return 3.14159265358979323846264338327950288; }
 double const_e() { return 2.718281828459045235360287471352662497; }
 
+int simplify_elemfunc_ins();
+
 void pf_init() {
 	uarg = (V *)CALLOC(1,sizeof(V));
 	uarg[0] = &oVAR[26]; MKV(uarg[0],x);
@@ -122,33 +120,33 @@ void pf_init() {
 	darg[0] = &oVAR[26];
 	darg[1] = &oVAR[27]; MKV(darg[1],y);
 
-	mkpf("@pi",0,0,0,(int (*)())p_pi,const_pi,0,&pidef);
-	mkpf("@e",0,0,0,(int (*)())p_e,const_e,0,&edef);
+	mkpf("@pi",0,0,0,(int (*)())mp_pi,const_pi,simplify_elemfunc_ins,&pidef);
+	mkpf("@e",0,0,0,(int (*)())mp_e,const_e,simplify_elemfunc_ins,&edef);
 
-	mkpf("log",0,1,uarg,(int (*)())p_log,log,0,&logdef);
-	mkpf("exp",0,1,uarg,(int (*)())p_exp,exp,0,&expdef);
-	mkpf("pow",0,2,darg,(int (*)())p_pow,pow,(int (*)())simplify_pow,&powdef);
+	mkpf("log",0,1,uarg,(int (*)())mp_log,log,simplify_elemfunc_ins,&logdef);
+	mkpf("exp",0,1,uarg,(int (*)())mp_exp,exp,simplify_elemfunc_ins,&expdef);
+	mkpf("pow",0,2,darg,(int (*)())mp_pow,pow,(int (*)())simplify_pow,&powdef);
 
-	mkpf("sin",0,1,uarg,(int (*)())p_sin,sin,0,&sindef);
-	mkpf("cos",0,1,uarg,(int (*)())p_cos,cos,0,&cosdef);
-	mkpf("tan",0,1,uarg,(int (*)())p_tan,tan,0,&tandef);
-	mkpf("asin",0,1,uarg,(int (*)())p_asin,asin,0,&asindef);
-	mkpf("acos",0,1,uarg,(int (*)())p_acos,acos,0,&acosdef);
-	mkpf("atan",0,1,uarg,(int (*)())p_atan,atan,0,&atandef);
+	mkpf("sin",0,1,uarg,(int (*)())mp_sin,sin,simplify_elemfunc_ins,&sindef);
+	mkpf("cos",0,1,uarg,(int (*)())mp_cos,cos,simplify_elemfunc_ins,&cosdef);
+	mkpf("tan",0,1,uarg,(int (*)())mp_tan,tan,simplify_elemfunc_ins,&tandef);
+	mkpf("asin",0,1,uarg,(int (*)())mp_asin,asin,simplify_elemfunc_ins,&asindef);
+	mkpf("acos",0,1,uarg,(int (*)())mp_acos,acos,simplify_elemfunc_ins,&acosdef);
+	mkpf("atan",0,1,uarg,(int (*)())mp_atan,atan,simplify_elemfunc_ins,&atandef);
 
-	mkpf("sinh",0,1,uarg,(int (*)())p_sinh,sinh,0,&sinhdef);
-	mkpf("cosh",0,1,uarg,(int (*)())p_cosh,cosh,0,&coshdef);
-	mkpf("tanh",0,1,uarg,(int (*)())p_tanh,tanh,0,&tanhdef);
-#if !defined(VISUAL)
-	mkpf("asinh",0,1,uarg,(int (*)())p_asinh,asinh,0,&asinhdef);
-	mkpf("acosh",0,1,uarg,(int (*)())p_acosh,acosh,0,&acoshdef);
-	mkpf("atanh",0,1,uarg,(int (*)())p_atanh,atanh,0,&atanhdef);
+	mkpf("sinh",0,1,uarg,(int (*)())mp_sinh,sinh,simplify_elemfunc_ins,&sinhdef);
+	mkpf("cosh",0,1,uarg,(int (*)())mp_cosh,cosh,simplify_elemfunc_ins,&coshdef);
+	mkpf("tanh",0,1,uarg,(int (*)())mp_tanh,tanh,simplify_elemfunc_ins,&tanhdef);
+#if !defined(VISUAL) && !defined(__MINGW32__)
+	mkpf("asinh",0,1,uarg,(int (*)())mp_asinh,asinh,simplify_elemfunc_ins,&asinhdef);
+	mkpf("acosh",0,1,uarg,(int (*)())mp_acosh,acosh,simplify_elemfunc_ins,&acoshdef);
+	mkpf("atanh",0,1,uarg,(int (*)())mp_atanh,atanh,simplify_elemfunc_ins,&atanhdef);
 #endif
 	make_exp();
 	make_tri();
 	make_itri();
 	make_hyp();
-#if !defined(VISUAL)
+#if !defined(VISUAL) && !defined(__MINGW32__)
 	make_ihyp();
 #endif
 }
@@ -278,6 +276,8 @@ Obj *r;
 	simplify_ins(ins,r);
 }
 
+extern int evalef;
+
 void simplify_pow(ins,rp)
 PFINS ins;
 Obj *rp;
@@ -288,6 +288,10 @@ Obj *rp;
 	V v;
 	P t;
 
+	if ( evalef ) {
+		simplify_elemfunc_ins(ins,rp);
+		return;
+	}
 	pf = ins->pf; ad = ins->ad; a0 = ad[0].arg; a1 = ad[1].arg;	
 	if ( !a1 )
 		*rp = (Obj)ONE;
@@ -297,12 +301,12 @@ Obj *rp;
 		else if ( RATN(a1) && SGN((Q)a1) < 0 )
 			error("simplify_pow : division by 0");
 		else {
-			instov(ins,&v); MKV(v,t); *rp = (Obj)t;
+			instoobj(ins,rp);
 		}
 	} else if ( NUM(a1) && INT(a1) )
 		arf_pwr(CO,a0,a1,rp);
 	else {
-		instov(ins,&v); MKV(v,t); *rp = (Obj)t;
+		instoobj(ins,rp);
 	}
 }
 
@@ -563,6 +567,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 )
@@ -570,9 +579,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 */
@@ -590,7 +616,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");
 
@@ -615,7 +644,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) ) {
@@ -623,7 +652,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;
@@ -632,7 +661,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;
@@ -640,7 +669,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;
@@ -648,7 +677,81 @@ void Pmapat(NODE arg,Obj *rp)
 			*rp = (Obj)rl;
 			break;
 		default:
-			*rp = bevalf(f,node);
+			*rp = bevalf_with_opts(f,node,option);
+			break;
+	}
+}
+
+/* An implementation of 'map' as builtin function. */
+void Pmap(NODE arg,Obj *rp)
+{
+	LIST args;
+	NODE node,rest,t0,t,n,r,r0;
+	P fpoly;
+	V fvar;
+	FUNC f;
+	VECT v,rv;
+	MAT m,rm;
+	LIST rl;
+	int len,row,col,i,j;
+	Obj iter;
+	pointer val;
+	NODE option;
+
+	option = current_option;
+
+	if ( argc(arg) < 2 )
+		error("mapat : too few arguments");
+
+	fpoly = (P)ARG0(arg);
+	if ( !fpoly || OID(fpoly) != O_P )
+		error("map : invalid function specification");
+	fvar = VR(fpoly);
+	if ( fvar->attr != (pointer)V_SR || !(f=(FUNC)fvar->priv) )
+		error("map : invalid function specification");
+
+	node = NEXT(arg);
+	len = length(node);
+	if ( 0 >= len )
+		error("evalmapf : invalid position");
+	r0 = 0;
+	NEXTNODE(r0,r);
+	iter = BDY(node); rest = NEXT(node);
+	if ( !iter ) {
+		*rp = bevalf_with_opts(f,node,option);
+		return;
+	}
+	switch ( OID(iter) ) {
+		case O_VECT:
+			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_with_opts(f,r0,option);
+			}
+			*rp = (Obj)rv;
+			break;
+		case O_MAT:
+			m = (MAT)iter; row = m->row; col = m->col; MKMAT(rm,row,col);
+			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_with_opts(f,r0,option);
+				}
+			*rp = (Obj)rm;
+			break;
+		case O_LIST:
+			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_with_opts(f,r0,option);
+			}
+			if ( t0 )
+				NEXT(t) = 0;
+			MKLIST(rl,t0);
+			*rp = (Obj)rl;
+			break;
+		default:
+			*rp = bevalf_with_opts(f,node,option);
 			break;
 	}
 }