Return to user.c CVS log

Up to [local] / OpenXM_contrib2 / asir2000 / builtin

Annotation of OpenXM_contrib2/asir2000/builtin/user.c, Revision 1.5

1.5     ! noro        1: /* $OpenXM: OpenXM_contrib2/asir2000/builtin/user.c,v 1.4 2015/09/03 23:05:36 noro Exp $ */
1.1       noro        2:
                      3: /* a sample file for adding builtin functions */
                      4:
                      5: #include "ca.h"
                      6: #include "parse.h"
                      7:
                      8: void Ppartial_derivative();
                      9: void partial_derivative(VL vl,P p,V v,P *r);
1.2       noro       10: void Pzadd(),Pzsub(),Pzmul();
1.4       noro       11: void Pcomp_f();
1.1       noro       12:
                     13: struct ftab user_tab[] = {
                     14: /*
                     15:   {"partial_derivative",Ppartial_derivative,2},
                     16: */
1.2       noro       17:   {"zadd",Pzadd,2},
                     18:   {"zsub",Pzsub,2},
                     19:   {"zmul",Pzmul,2},
1.4       noro       20:   {"comp_f",Pcomp_f,2},
1.1       noro       21:   {0,0,0},
                     22: };
1.2       noro       23:
1.4       noro       24: /* compare two [[F,M],...] */
                     25:
                     26: void Pcomp_f(NODE arg,Q *rp)
                     27: {
                     28:   NODE l1,l2,e1,e2;
                     29:   int m1,m2,r;
                     30:
                     31:   l1 = BDY((LIST)ARG0(arg));
                     32:   l2 = BDY((LIST)ARG1(arg));
                     33:   for ( ; l1 && l2; l1 = NEXT(l1), l2 = NEXT(l2) ) {
                     34:     e1 = BDY((LIST)BDY(l1));
                     35:     e2 = BDY((LIST)BDY(l2));
                     36:     r = compp(CO,(P)ARG0(e1),(P)ARG0(e2));
                     37:     if ( r ) { STOQ(r,*rp); return; }
                     38:     m1 = QTOS((Q)ARG1(e1));
                     39:     m2 = QTOS((Q)ARG1(e2));
1.5     ! noro       40:   r = m1>m2?1:(m1<m2?-1:0);
        !            41:   if ( r ) { STOQ(r,*rp); return; }
1.4       noro       42:   }
                     43:   r = l1?1:(l2?-1:0);
                     44:   STOQ(r,*rp);
                     45: }
                     46:
1.2       noro       47: void Pzadd(NODE arg,Q *rp)
                     48: {
1.5     ! noro       49:   Z z0,z1,z2;
1.2       noro       50:
1.5     ! noro       51:   z0 = qtoz((Q)ARG0(arg));
        !            52:   z1 = qtoz((Q)ARG1(arg));
        !            53:   z2 = addz(z0,z1);
        !            54:   printz(z2); printf(" ");
        !            55:   *rp = ztoq(z2);
1.2       noro       56: }
                     57:
                     58: void Pzsub(NODE arg,Q *rp)
                     59: {
1.5     ! noro       60:   Z z0,z1,z2;
1.2       noro       61:
1.5     ! noro       62:   z0 = qtoz((Q)ARG0(arg));
        !            63:   z1 = qtoz((Q)ARG1(arg));
        !            64:   z2 = subz(z0,z1);
        !            65:   printz(z2); printf(" ");
        !            66:   *rp = ztoq(z2);
1.2       noro       67: }
                     68:
                     69: void Pzmul(NODE arg,Q *rp)
                     70: {
1.5     ! noro       71:   Z z0,z1,z2;
1.2       noro       72:
1.5     ! noro       73:   z0 = qtoz((Q)ARG0(arg));
        !            74:   z1 = qtoz((Q)ARG1(arg));
        !            75:   z2 = mulz(z0,z1);
        !            76:   printz(z2); printf(" ");
        !            77:   *rp = ztoq(z2);
1.2       noro       78: }
1.1       noro       79:
                     80: /*
                     81: void Ppartial_derivative(NODE arg,P *rp)
                     82: {
                     83:   asir_assert(ARG0(arg),O_P,"partial_derivative");
                     84:   asir_assert(ARG1(arg),O_P,"partial_derivative");
                     85:   partial_derivative(CO,(P)ARG0(arg),((P)ARG1(arg))->v,rp);
                     86: }
                     87:
                     88: void partial_derivative(VL vl,P p,V v,P *r)
                     89: {
                     90:   P t;
                     91:   DCP dc,dcr,dcr0;
                     92:
                     93:   if ( !p || NUM(p) ) *r = 0;
                     94:   else if ( v == p->v ) {
                     95:     for ( dc = p->dc, dcr0 = 0; dc && dc->d; dc = dc->next ) {
                     96:       mulp(vl,dc->c,(P)dc->d,&t);
                     97:       if ( t ) {
                     98:         NEXTDC(dcr0,dcr); subq(dc->d,ONE,&dcr->d); dcr->c = t;
                     99:       }
                    100:     }
                    101:     if ( !dcr0 ) *r = 0;
                    102:     else { dcr->next = 0; MKP(v,dcr0,*r); }
                    103:   } else {
                    104:     for ( dc = p->dc, dcr0 = 0; dc; dc = dc->next ) {
                    105:       partial_derivative(vl,dc->c,v,&t);
                    106:       if ( t ) { NEXTDC(dcr0,dcr); dcr->d = dc->d; dcr->c = t; }
                    107:     }
                    108:     if ( !dcr0 ) *r = 0;
                    109:     else { dcr->next = 0; MKP(p->v,dcr0,*r); }
                    110:   }
                    111: }
                    112: */