=================================================================== RCS file: /home/cvs/OpenXM_contrib2/asir2000/builtin/subst.c,v retrieving revision 1.2 retrieving revision 1.8 diff -u -p -r1.2 -r1.8 --- OpenXM_contrib2/asir2000/builtin/subst.c 2000/08/21 08:31:21 1.2 +++ OpenXM_contrib2/asir2000/builtin/subst.c 2010/01/28 08:56:26 1.8 @@ -23,7 +23,7 @@ * shall be made on your publication or presentation in any form of the * results obtained by use of the SOFTWARE. * (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 * SOFTWARE. * @@ -45,20 +45,83 @@ * 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.1.1.1 1999/12/03 07:39:07 noro Exp $ + * $OpenXM: OpenXM_contrib2/asir2000/builtin/subst.c,v 1.7 2004/06/22 09:17:21 noro Exp $ */ #include "ca.h" #include "parse.h" -void Psubst(), Ppsubst(), Psubstf(); +void Psubst(), Ppsubst(), Psubstf(), Psubst_quote(); +void Psubstr2np(); struct ftab subst_tab[] = { {"subst",Psubst,-99999999}, + {"substr2np",Psubstr2np,2}, + {"subst_quote",Psubst_quote,-99999999}, {"psubst",Ppsubst,-99999999}, {"substf",Psubstf,-99999999}, {0,0,0}, }; +extern Obj VOIDobj; + +void Psubstr2np(NODE arg,Obj *rp) +{ + Obj a; + P nm,dn,p; + R r; + VL vl,tvl; + int nv,i; + NODE slist,t,ps; + 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)); + 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_N,"substr2np"); + v = VR(p); + for ( i = 0; i < nv; i++ ) if ( vvect[i] == v ) break; + svect[i] = s; + } + + switch ( OID(a) ) { + case O_P: + substpp(vl,(P)a,vvect,svect,nv,&nm); *rp = (Obj)nm; + return; + case O_R: + substpp(vl,(P)NM((R)a),vvect,svect,nv,&nm); + substpp(vl,(P)DN((R)a),vvect,svect,nv,&dn); + if ( !dn ) + error("substr2np: division by 0"); + else if ( NUM(dn) ) { + divsp(vl,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; @@ -66,27 +129,137 @@ Obj *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; if ( !arg ) { *rp = 0; return; } - asir_assert(ARG0(arg),O_R,"subst"); - reductr(CO,(Obj)ARG0(arg),&a); -/* a = (Obj)ARG0(arg); */ - arg = NEXT(arg); + 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),&a); + arg = NEXT(arg); + if ( arg && (l = (LIST)ARG0(arg)) && OID(l) == O_LIST ) + arg = BDY(l); + while ( arg ) { + if ( !BDY(arg) || OID((Obj)BDY(arg)) != O_P ) + error("subst : invalid argument"); + v = VR((P)BDY(arg)); arg = NEXT(arg); + if ( !arg ) + error("subst : invalid argument"); + asir_assert(ARG0(arg),O_R,"subst"); + reductr(CO,(Obj)BDY(arg),&b); arg = NEXT(arg); + /* b = (Obj)BDY(arg); arg = NEXT(arg); */ + substr(CO,0,a,v,b,&t); a = t; + } + *rp = a; + 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 = NEXT(arg); + Psubst(&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 = NEXT(arg); + Psubst(&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 = NEXT(arg); + Psubst(&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 = NEXT(arg); + Psubst(&arg0,&b); + if ( b ) { + NEXTMP(mp0,mp); + C(mp) = (P)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("subst : invalid argument"); + } +} + +FNODE subst_in_fnode(); + +void Psubst_quote(arg,rp) +NODE arg; +QUOTE *rp; +{ + QUOTE h; + FNODE fn; + Obj g; + LIST l; + V v; + + if ( !arg ) { + *rp = 0; return; + } + asir_assert(ARG0(arg),O_QUOTE,"subst_quote"); + fn = BDY((QUOTE)ARG0(arg)); arg = NEXT(arg); if ( arg && (l = (LIST)ARG0(arg)) && OID(l) == O_LIST ) arg = BDY(l); while ( arg ) { - asir_assert(BDY(arg),O_P,"subst"); + asir_assert(BDY(arg),O_P,"subst_quote"); v = VR((P)BDY(arg)); arg = NEXT(arg); if ( !arg ) - error("subst : invalid argument"); - asir_assert(ARG0(arg),O_R,"subst"); - reductr(CO,(Obj)BDY(arg),&b); arg = NEXT(arg); -/* b = (Obj)BDY(arg); arg = NEXT(arg); */ - substr(CO,0,a,v,b,&t); a = t; + error("subst_quote : invalid argument"); + g = (Obj)ARG0(arg); arg = NEXT(arg); + if ( !g || OID(g) != O_QUOTE ) + objtoquote(g,&h); + else + h = (QUOTE)g; + fn = subst_in_fnode(fn,v,BDY(h)); } - *rp = a; + MKQUOTE(*rp,fn); } void Ppsubst(arg,rp)