===================================================================
RCS file: /home/cvs/OpenXM_contrib2/asir2000/builtin/reduct.c,v
retrieving revision 1.3
retrieving revision 1.5
diff -u -p -r1.3 -r1.5
--- OpenXM_contrib2/asir2000/builtin/reduct.c	2000/08/22 05:03:59	1.3
+++ OpenXM_contrib2/asir2000/builtin/reduct.c	2018/03/29 01:32:50	1.5
@@ -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/reduct.c,v 1.2 2000/08/21 08:31:21 noro Exp $ 
+ * $OpenXM: OpenXM_contrib2/asir2000/builtin/reduct.c,v 1.4 2017/08/31 02:36:20 noro Exp $ 
 */
 #include "ca.h"
 #include "parse.h"
@@ -53,52 +53,126 @@
 void Pred(), Predc(), Pprim();
 
 struct ftab reduct_tab[] = {
-	{"red",Pred,1},
-	{"redc",Predc,2},
-	{"prim",Pprim,-2},
-	{0,0,0},
+  {"red",Pred,1},
+  {"redc",Predc,2},
+  {"prim",Pprim,-2},
+  {0,0,0},
 };
 
-void Pred(arg,rp)
-NODE arg;
-Obj *rp;
+void Pred(NODE arg,Obj *rp)
 {
-	asir_assert(ARG0(arg),O_R,"red");
-	reductr(CO,(Obj)ARG0(arg),rp);
+  Obj a,b,t;
+  LIST l;
+  V v;
+  int row,col,len;
+  VECT vect;
+  MAT mat;
+  int i,j;
+  NODE n0,n,nd;
+  struct oNODE arg0;
+  MP m,mp,mp0;
+  DP d;
+
+  a = (Obj)ARG0(arg);
+  if ( !a ) {
+    *rp = 0;
+    return;
+  }
+  switch ( OID(a) ) {
+    case O_N: case O_P: case O_R:
+      reductr(CO,(Obj)ARG0(arg),rp);
+      break;
+    case O_LIST:
+      n0 = 0;
+      for ( nd = BDY((LIST)a); nd; nd = NEXT(nd) ) {
+        NEXTNODE(n0,n);
+        arg0.body = (pointer)BDY(nd);
+        arg0.next = 0;
+        Pred(&arg0,&b);
+        BDY(n) = (pointer)b;
+      }
+      if ( n0 )
+        NEXT(n) = 0;
+      MKLIST(l,n0);
+      *rp = (Obj)l;
+      break;
+    case O_VECT:
+      len = ((VECT)a)->len;
+      MKVECT(vect,len);
+      for ( i = 0; i < len; i++ ) {
+        arg0.body = (pointer)BDY((VECT)a)[i];
+        arg0.next = 0;
+        Pred(&arg0,&b);
+        BDY(vect)[i] = (pointer)b;
+      }
+      *rp = (Obj)vect;
+      break;
+    case O_MAT:
+      row = ((MAT)a)->row;
+      col = ((MAT)a)->col;
+      MKMAT(mat,row,col);
+      for ( i = 0; i < row; i++ )
+        for ( j = 0; j < col; j++ ) {
+          arg0.body = (pointer)BDY((MAT)a)[i][j];
+          arg0.next = 0;
+          Pred(&arg0,&b);
+          BDY(mat)[i][j] = (pointer)b;
+        }
+      *rp = (Obj)mat;
+      break;
+    case O_DP:
+      mp0 = 0;
+      for ( m = BDY((DP)a); m; m = NEXT(m) ) {
+        arg0.body = (pointer)C(m);
+        arg0.next = 0;
+        Pred(&arg0,&b);
+        if ( b ) {
+          NEXTMP(mp0,mp);
+          C(mp) = b;
+          mp->dl = m->dl;
+        }
+      }
+      if ( mp0 ) {
+        MKDP(NV((DP)a),mp0,d);
+        d->sugar = ((DP)a)->sugar;
+        *rp = (Obj)d;
+      } else
+        *rp = 0;
+
+      break;
+    default:
+      error("red : invalid argument");
+  }
 }
 
-void Predc(arg,rp)
-NODE arg;
-P *rp;
+void Predc(NODE arg,P *rp)
 {
-	asir_assert(ARG0(arg),O_P,"redc");
-	asir_assert(ARG1(arg),O_P,"redc");
-	remsdcp(CO,(P)ARG0(arg),(P)ARG1(arg),rp);
+  asir_assert(ARG0(arg),O_P,"redc");
+  asir_assert(ARG1(arg),O_P,"redc");
+  remsdcp(CO,(P)ARG0(arg),(P)ARG1(arg),rp);
 }
 
-void Pprim(arg,rp)
-NODE arg;
-P *rp;
+void Pprim(NODE arg,P *rp)
 {
-	P t,p,p1,r;
-	V v;
-	VL vl;
+  P t,p,p1,r;
+  V v;
+  VL vl;
 
-	asir_assert(ARG0(arg),O_P,"prim");
-	p = (P)ARG0(arg);
-	if ( NUM(p) )
-		*rp = (P)ONE;
-	else {
-		if ( argc(arg) == 2 ) {
-			v = VR((P)ARG1(arg));
-			change_mvar(CO,p,v,&p1);
-			if ( VR(p1) != v ) {
-				*rp = (P)ONE; return;
-			} else {
-				reordvar(CO,v,&vl); pcp(vl,p1,&r,&t);
-				restore_mvar(CO,r,v,rp);
-			}
-		} else
-			pcp(CO,p,rp,&t);
-	}
+  asir_assert(ARG0(arg),O_P,"prim");
+  p = (P)ARG0(arg);
+  if ( NUM(p) )
+    *rp = (P)ONE;
+  else {
+    if ( argc(arg) == 2 ) {
+      v = VR((P)ARG1(arg));
+      change_mvar(CO,p,v,&p1);
+      if ( VR(p1) != v ) {
+        *rp = (P)ONE; return;
+      } else {
+        reordvar(CO,v,&vl); pcp(vl,p1,&r,&t);
+        restore_mvar(CO,r,v,rp);
+      }
+    } else
+      pcp(CO,p,rp,&t);
+  }
 }