===================================================================
RCS file: /home/cvs/OpenXM_contrib2/asir2000/builtin/subst.c,v
retrieving revision 1.7
retrieving revision 1.12
diff -u -p -r1.7 -r1.12
--- OpenXM_contrib2/asir2000/builtin/subst.c	2004/06/22 09:17:21	1.7
+++ OpenXM_contrib2/asir2000/builtin/subst.c	2018/03/27 06:29:19	1.12
@@ -45,21 +45,112 @@
  * DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE,
  * PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE.
  *
- * $OpenXM: OpenXM_contrib2/asir2000/builtin/subst.c,v 1.6 2003/11/27 08:28:40 noro Exp $ 
+ * $OpenXM: OpenXM_contrib2/asir2000/builtin/subst.c,v 1.11 2017/09/06 06:25:26 noro Exp $ 
 */
 #include "ca.h"
 #include "parse.h"
 
 void Psubst(), Ppsubst(), Psubstf(), Psubst_quote();
+void Psubstr2np();
 
 struct ftab subst_tab[] = {
 	{"subst",Psubst,-99999999},
+	{"substr2np",Psubstr2np,-3},
 	{"subst_quote",Psubst_quote,-99999999},
 	{"psubst",Ppsubst,-99999999},
 	{"substf",Psubstf,-99999999},
 	{0,0,0},
 };
 
+extern Obj VOIDobj;
+
+/* substr2np(P,[[v,a],...]) or substr2np(P,[v1,...],[a1,...]) */
+
+void Psubstr2np(NODE arg,Obj *rp)
+{
+  Obj a,b;
+  P nm,dn,p,q;
+  R r;
+  VL vl,tvl;
+  int nv,i,ac,j;
+  NODE slist,t,ps,u,vlist;
+  P s;
+  P *svect;
+  V v;
+  V *vvect;
+
+  a = (Obj)ARG0(arg);
+  if ( !a || NUM(a) ) {
+    *rp = a;
+    return;
+  }
+  asir_assert(ARG0(arg),O_R,"substr2np");
+  asir_assert(ARG1(arg),O_LIST,"substr2np");
+  get_vars(a,&vl);
+  for ( i = 0, tvl = vl; tvl; tvl = NEXT(tvl), i++ );
+  nv = i;
+  vvect = (V *)MALLOC((nv)*sizeof(V));
+  for ( i = 0, tvl = vl; tvl; tvl = NEXT(tvl), i++ ) vvect[i] = tvl->v;
+  svect = (P *)MALLOC((nv)*sizeof(P));
+  ac = argc(arg);
+  if ( ac == 2 ) {
+    slist = BDY((LIST)ARG1(arg));
+    for ( i = 0; i < nv; i++ ) svect[i] = (P)VOIDobj;
+    for ( t = slist; t; t = NEXT(t) ) {
+      ps = BDY((LIST)BDY(t)); p = (P)BDY(ps); s = (P)BDY(NEXT(ps));  
+      asir_assert(p,O_P,"substr2np"); asir_assert(s,O_P,"substr2np");
+      v = VR(p);
+      for ( i = 0; i < nv; i++ ) if ( vvect[i] == v ) break;
+      svect[i] = s;
+    }
+  } else if ( ac == 3 ) {
+    asir_assert(ARG2(arg),O_LIST,"substr2np");
+    vlist = BDY((LIST)ARG1(arg));
+    slist = BDY((LIST)ARG2(arg));
+    for ( i = 0; i < nv; i++ ) svect[i] = (P)VOIDobj;
+      for ( u = vlist, t = slist; u && t; u = NEXT(u), t = NEXT(t) ) {
+        v = VR((P)BDY(u));
+        for ( i = 0; i < nv; i++ ) if ( vvect[i] == v ) break;
+        svect[i] = (P)BDY(t);
+      }
+    } else
+      error("substr2np : argument mismatch");
+  for ( i = 0; i < nv; i++ ) {
+    if ( (int)(vvect[i]->attr) == V_PF ) {
+      MKV(vvect[i],p);
+      for ( j = 0; j < nv; j++ )
+        if ( j != i ) {
+          substr(CO,0,(Obj)p,vvect[j],(Obj)svect[j],&b); p = (P)b;
+        }
+      if ( OID(svect[i]) == O_VOID ) svect[i] = p;
+      else if ( arf_comp(CO,(Obj)p,(Obj)svect[i]) )
+        error("substr2np : inconsistent values for substitution");
+    }
+  }
+  switch ( OID(a) ) {
+    case O_P:
+      substpp(CO,(P)a,vvect,svect,nv,&nm); *rp = (Obj)nm;
+      return;
+    case O_R:
+      substpp(CO,(P)NM((R)a),vvect,svect,nv,&nm);
+      substpp(CO,(P)DN((R)a),vvect,svect,nv,&dn);
+      if ( !dn )
+        error("substr2np: division by 0");
+      else if ( !nm )
+        *rp = 0;
+      else if ( NUM(dn) ) {
+        divsp(CO,nm,dn,&p);
+        *rp = (Obj)p;
+      } else {
+        MKRAT(nm,dn,0,r);
+        *rp = (Obj)r;
+      }
+      return;
+    default:
+      error("substr2np: invalid argument");
+  }
+}
+
 void Psubst(arg,rp)
 NODE arg;
 Obj *rp;
@@ -75,6 +166,7 @@ Obj *rp;
 	struct oNODE arg0;
 	MP m,mp,mp0;
 	DP d;
+	VL lastvl,vl,tvl,prev,cur;
 
 	if ( !arg ) {
 		*rp = 0; return;
@@ -84,6 +176,7 @@ Obj *rp;
 		*rp = 0;
 		return;
 	}
+	lastvl = LASTCO;
 	switch ( OID(a) ) {
 		case O_N: case O_P: case O_R:
 			reductr(CO,(Obj)ARG0(arg),&a);
@@ -162,7 +255,19 @@ Obj *rp;
 
 			break;
 		default:
-			error("subst invalid argument");
+			error("subst : invalid argument");
+	}
+	if ( lastvl != LASTCO ) {
+		get_vars_recursive(*rp,&vl);
+		prev = lastvl; cur = NEXT(prev);
+		while ( cur ) {
+			v = cur->v;
+			for ( tvl = vl; tvl && tvl->v != v; tvl = NEXT(tvl) );
+			if ( !tvl ) NEXT(prev) = NEXT(cur);
+			else prev = cur;
+			cur = NEXT(cur);
+		}
+		update_LASTCO();
 	}
 }