version 1.2, 2000/08/21 08:31:21 |
version 1.5, 2018/03/29 01:32:50 |
|
|
* shall be made on your publication or presentation in any form of the |
* shall be made on your publication or presentation in any form of the |
* results obtained by use of the SOFTWARE. |
* results obtained by use of the SOFTWARE. |
* (4) In the event that you modify the SOFTWARE, you shall notify FLL by |
* (4) In the event that you modify the SOFTWARE, you shall notify FLL by |
* e-mail at risa-admin@flab.fujitsu.co.jp of the detailed specification |
* e-mail at risa-admin@sec.flab.fujitsu.co.jp of the detailed specification |
* for such modification or the source code of the modified part of the |
* for such modification or the source code of the modified part of the |
* SOFTWARE. |
* SOFTWARE. |
* |
* |
|
|
* DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE, |
* DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE, |
* PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE. |
* PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE. |
* |
* |
* $OpenXM: OpenXM_contrib2/asir2000/builtin/reduct.c,v 1.1.1.1 1999/12/03 07:39:07 noro Exp $ |
* $OpenXM: OpenXM_contrib2/asir2000/builtin/reduct.c,v 1.4 2017/08/31 02:36:20 noro Exp $ |
*/ |
*/ |
#include "ca.h" |
#include "ca.h" |
#include "parse.h" |
#include "parse.h" |
|
|
void Pred(), Predc(), Pprim(); |
void Pred(), Predc(), Pprim(); |
|
|
struct ftab reduct_tab[] = { |
struct ftab reduct_tab[] = { |
{"red",Pred,1}, |
{"red",Pred,1}, |
{"redc",Predc,2}, |
{"redc",Predc,2}, |
{"prim",Pprim,-2}, |
{"prim",Pprim,-2}, |
{0,0,0}, |
{0,0,0}, |
}; |
}; |
|
|
void Pred(arg,rp) |
void Pred(NODE arg,Obj *rp) |
NODE arg; |
|
Obj *rp; |
|
{ |
{ |
asir_assert(ARG0(arg),O_R,"red"); |
Obj a,b,t; |
reductr(CO,(Obj)ARG0(arg),rp); |
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) |
void Predc(NODE arg,P *rp) |
NODE arg; |
|
P *rp; |
|
{ |
{ |
asir_assert(ARG0(arg),O_P,"redc"); |
asir_assert(ARG0(arg),O_P,"redc"); |
asir_assert(ARG1(arg),O_P,"redc"); |
asir_assert(ARG1(arg),O_P,"redc"); |
remsdcp(CO,(P)ARG0(arg),(P)ARG1(arg),rp); |
remsdcp(CO,(P)ARG0(arg),(P)ARG1(arg),rp); |
} |
} |
|
|
void Pprim(arg,rp) |
void Pprim(NODE arg,P *rp) |
NODE arg; |
|
P *rp; |
|
{ |
{ |
P t,p,p1,r; |
P t,p,p1,r; |
V v; |
V v; |
VL vl; |
VL vl; |
|
|
asir_assert(ARG0(arg),O_P,"prim"); |
asir_assert(ARG0(arg),O_P,"prim"); |
p = (P)ARG0(arg); |
p = (P)ARG0(arg); |
if ( NUM(p) ) |
if ( NUM(p) ) |
*rp = (P)ONE; |
*rp = (P)ONE; |
else { |
else { |
if ( argc(arg) == 2 ) { |
if ( argc(arg) == 2 ) { |
v = VR((P)ARG1(arg)); |
v = VR((P)ARG1(arg)); |
change_mvar(CO,p,v,&p1); |
change_mvar(CO,p,v,&p1); |
if ( VR(p1) != v ) { |
if ( VR(p1) != v ) { |
*rp = (P)ONE; return; |
*rp = (P)ONE; return; |
} else { |
} else { |
reordvar(CO,v,&vl); pcp(vl,p1,&r,&t); |
reordvar(CO,v,&vl); pcp(vl,p1,&r,&t); |
restore_mvar(CO,r,v,rp); |
restore_mvar(CO,r,v,rp); |
} |
} |
} else |
} else |
pcp(CO,p,rp,&t); |
pcp(CO,p,rp,&t); |
} |
} |
} |
} |