Return to user.c CVS log

Up to [local] / OpenXM_contrib2 / asir2018 / builtin

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: