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: */
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>