Annotation of OpenXM_contrib2/asir2018/builtin/user.c, Revision 1.2
1.2 ! noro 1: /* $OpenXM: OpenXM_contrib2/asir2018/builtin/user.c,v 1.1 2018/09/19 05:45:06 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);
10: void Pzadd(),Pzsub(),Pzmul();
11: void Pcomp_f();
12:
13: struct ftab user_tab[] = {
14: /*
15: {"partial_derivative",Ppartial_derivative,2},
16: */
17: {"comp_f",Pcomp_f,2},
18: {0,0,0},
19: };
20:
21: /* compare two [[F,M],...] */
22:
23: void Pcomp_f(NODE arg,Z *rp)
24: {
25: NODE l1,l2,e1,e2;
26: int m1,m2,r;
27:
28: l1 = BDY((LIST)ARG0(arg));
29: l2 = BDY((LIST)ARG1(arg));
30: for ( ; l1 && l2; l1 = NEXT(l1), l2 = NEXT(l2) ) {
31: e1 = BDY((LIST)BDY(l1));
32: e2 = BDY((LIST)BDY(l2));
33: r = compp(CO,(P)ARG0(e1),(P)ARG0(e2));
34: if ( r ) { STOQ(r,*rp); return; }
35: m1 = QTOS((Q)ARG1(e1));
36: m2 = QTOS((Q)ARG1(e2));
37: r = m1>m2?1:(m1<m2?-1:0);
38: if ( r ) { STOQ(r,*rp); return; }
39: }
40: r = l1?1:(l2?-1:0);
41: STOQ(r,*rp);
42: }
43:
44: /*
45: void Ppartial_derivative(NODE arg,P *rp)
46: {
47: asir_assert(ARG0(arg),O_P,"partial_derivative");
48: asir_assert(ARG1(arg),O_P,"partial_derivative");
49: partial_derivative(CO,(P)ARG0(arg),((P)ARG1(arg))->v,rp);
50: }
51:
52: void partial_derivative(VL vl,P p,V v,P *r)
53: {
54: P t;
55: DCP dc,dcr,dcr0;
56:
57: if ( !p || NUM(p) ) *r = 0;
58: else if ( v == p->v ) {
59: for ( dc = p->dc, dcr0 = 0; dc && dc->d; dc = dc->next ) {
60: mulp(vl,dc->c,(P)dc->d,&t);
61: if ( t ) {
62: NEXTDC(dcr0,dcr); subq(dc->d,ONE,&dcr->d); dcr->c = t;
63: }
64: }
65: if ( !dcr0 ) *r = 0;
66: else { dcr->next = 0; MKP(v,dcr0,*r); }
67: } else {
68: for ( dc = p->dc, dcr0 = 0; dc; dc = dc->next ) {
69: partial_derivative(vl,dc->c,v,&t);
70: if ( t ) { NEXTDC(dcr0,dcr); dcr->d = dc->d; dcr->c = t; }
71: }
72: if ( !dcr0 ) *r = 0;
73: else { dcr->next = 0; MKP(p->v,dcr0,*r); }
74: }
75: }
76: */
1.2 ! noro 77:
! 78: void dsave(char *name,Obj a)
! 79: {
! 80: extern int ox_file_io;
! 81: VL vl;
! 82: FILE *fp = fopen(name,"wb");
! 83: ox_file_io = 1; /* network byte order is used */
! 84: get_vars_recursive(a,&vl);
! 85: savevl(fp,CO);
! 86: saveobj(fp,a);
! 87: fclose(fp);
! 88: ox_file_io = 0;
! 89: }
! 90:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>