OpenXM_contrib2/asir2000/builtin/pf.c - diff

Return to pf.c CVS log

Up to [local] / OpenXM_contrib2 / asir2000 / builtin

Diff for /OpenXM_contrib2/asir2000/builtin/pf.c between version 1.10 and 1.16

version 1.10, 2005/09/08 08:37:02

version 1.16, 2009/07/23 01:04:29

Line 45

* DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE,

* PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE.

* $OpenXM: OpenXM_contrib2/asir2000/builtin/pf.c,v 1.9 2004/12/17 03:09:08 noro Exp $

* $OpenXM: OpenXM_contrib2/asir2000/builtin/pf.c,v 1.15 2008/11/18 20:52:47 ohara Exp $

#include "ca.h"

#include "math.h"

Line 66 void simplify_pow(PFINS,Obj *);

void Pfunctor(),Pargs(),Pfunargs(),Pvtype(),Pcall(),Pdeval(),Pfunargs_ext();

void Pregister_handler();

void Peval_quote();

void Pmapat();

void Pmapat(), Pmap();

void Padd_handler();

void Plist_handler();

void Pclear_handler();

struct ftab puref_tab[] = {

{"mapat",Pmapat,-99999999},

{"map",Pmap,-99999999},

{"functor",Pfunctor,1},

{"args",Pargs,1},

{"funargs",Pfunargs,1},

Line 84 struct ftab puref_tab[] = {

Line 85 struct ftab puref_tab[] = {

{"call",Pcall,2},

{"vtype",Pvtype,1},

{"deval",Pdeval,1},

{"eval_quote",Peval_quote,1},

{"eval_quote",Peval_quote,-2},

{0,0,0},

};

Line 563 void Pcall(NODE arg,Obj *rp)

Line 564 void Pcall(NODE arg,Obj *rp)

{

P p;

V v;

NODE n,n1;

LIST list;

VECT vect;

pointer *a;

int len,i;

p = (P)ARG0(arg);

if ( !p || OID(p) != 2 )

Line 570 void Pcall(NODE arg,Obj *rp)

Line 576 void Pcall(NODE arg,Obj *rp)

v = VR(p);

if ( (int)v->attr != V_SR )

error("call : no such function");

else {

else

list = (LIST) ARG1(arg);

*rp = (Obj)bevalf((FUNC)v->priv,BDY((LIST)ARG1(arg)));

if ( list ) {

switch (OID(list)) {

case O_VECT:

vect = (VECT)list; len = vect->len; a = BDY(vect);

for ( i = len - 1, n = 0; i >= 0; i-- ) {

MKNODE(n1,a[i],n); n = n1;

}

MKLIST(list,n);

/* falling next case */

case O_LIST:

*rp = (Obj)bevalf_with_opts((FUNC)v->priv,BDY(list),current_option);

return;

default:

break;

}

error("call : invalid argument");

}

/* at=position of arg to be used for iteration */

Line 590 void Pmapat(NODE arg,Obj *rp)

Line 613 void Pmapat(NODE arg,Obj *rp)

int len,row,col,i,j,pos;

Obj iter;

pointer val;

NODE option;

option = current_option;

if ( argc(arg) < 3 )

error("mapat : too few arguments");

Line 615 void Pmapat(NODE arg,Obj *rp)

Line 641 void Pmapat(NODE arg,Obj *rp)

NEXTNODE(r0,r);

iter = BDY(t); rest = NEXT(t);

if ( !iter ) {

*rp = bevalf(f,node);

*rp = bevalf_with_opts(f,node,option);

return;

}

switch ( OID(iter) ) {

Line 623 void Pmapat(NODE arg,Obj *rp)

Line 649 void Pmapat(NODE arg,Obj *rp)

v = (VECT)iter; len = v->len; MKVECT(rv,len);

for ( i = 0; i < len; i++ ) {

BDY(r) = BDY(v)[i]; NEXT(r) = rest;

BDY(rv)[i] = bevalf(f,r0);

BDY(rv)[i] = bevalf_with_opts(f,r0,option);

}

*rp = (Obj)rv;

break;

Line 632 void Pmapat(NODE arg,Obj *rp)

Line 658 void Pmapat(NODE arg,Obj *rp)

for ( i = 0; i < row; i++ )

for ( j = 0; j < col; j++ ) {

BDY(r) = BDY(m)[i][j]; NEXT(r) = rest;

BDY(rm)[i][j] = bevalf(f,r0);

BDY(rm)[i][j] = bevalf_with_opts(f,r0,option);

}

*rp = (Obj)rm;

break;

Line 640 void Pmapat(NODE arg,Obj *rp)

Line 666 void Pmapat(NODE arg,Obj *rp)

n = BDY((LIST)iter);

for ( t0 = t = 0; n; n = NEXT(n) ) {

BDY(r) = BDY(n); NEXT(r) = rest;

NEXTNODE(t0,t); BDY(t) = bevalf(f,r0);

NEXTNODE(t0,t); BDY(t) = bevalf_with_opts(f,r0,option);

}

if ( t0 )

NEXT(t) = 0;

Line 648 void Pmapat(NODE arg,Obj *rp)

Line 674 void Pmapat(NODE arg,Obj *rp)

*rp = (Obj)rl;

break;

default:

*rp = bevalf(f,node);

*rp = bevalf_with_opts(f,node,option);

break;

}

/* An implementation of 'map' as builtin function. */

void Pmap(NODE arg,Obj *rp)

{

LIST args;

NODE node,rest,t0,t,n,r,r0;

P fpoly;

V fvar;

FUNC f;

VECT v,rv;

MAT m,rm;

LIST rl;

int len,row,col,i,j;

Obj iter;

pointer val;

NODE option;

option = current_option;

if ( argc(arg) < 2 )

error("mapat : too few arguments");

fpoly = (P)ARG0(arg);

if ( !fpoly || OID(fpoly) != O_P )

error("map : invalid function specification");

fvar = VR(fpoly);

if ( fvar->attr != (pointer)V_SR || !(f=(FUNC)fvar->priv) )

error("map : invalid function specification");

node = NEXT(arg);

len = length(node);

if ( 0 >= len )

error("evalmapf : invalid position");

r0 = 0;

NEXTNODE(r0,r);

iter = BDY(t); rest = NEXT(t);

if ( !iter ) {

*rp = bevalf_with_opts(f,node,option);

return;

}

switch ( OID(iter) ) {

case O_VECT:

v = (VECT)iter; len = v->len; MKVECT(rv,len);

for ( i = 0; i < len; i++ ) {

BDY(r) = BDY(v)[i]; NEXT(r) = rest;

BDY(rv)[i] = bevalf_with_opts(f,r0,option);

}

*rp = (Obj)rv;

break;

case O_MAT:

m = (MAT)iter; row = m->row; col = m->col; MKMAT(rm,row,col);

for ( i = 0; i < row; i++ )

for ( j = 0; j < col; j++ ) {

BDY(r) = BDY(m)[i][j]; NEXT(r) = rest;

BDY(rm)[i][j] = bevalf_with_opts(f,r0,option);

}

*rp = (Obj)rm;

break;

case O_LIST:

n = BDY((LIST)iter);

for ( t0 = t = 0; n; n = NEXT(n) ) {

BDY(r) = BDY(n); NEXT(r) = rest;

NEXTNODE(t0,t); BDY(t) = bevalf_with_opts(f,r0,option);

}

if ( t0 )

NEXT(t) = 0;

MKLIST(rl,t0);

*rp = (Obj)rl;

break;

default:

*rp = bevalf_with_opts(f,node,option);

break;

}

void Pdeval(arg,rp)

NODE arg;

Obj *rp;

Line 665 void Peval_quote(arg,rp)

Line 765 void Peval_quote(arg,rp)

NODE arg;

Obj *rp;

{

asir_assert(ARG0(arg),O_QUOTE,"eval_quote");

FNODE a;

*rp = eval((FNODE)BDY((QUOTE)ARG0(arg)));

QUOTE q;

Obj f;

f = (Obj)ARG0(arg);

if ( !f || OID(f) != O_QUOTE ) {

*rp = f;

return;

}

if ( argc(arg) == 2 && ARG1(arg) ) {

a = partial_eval((FNODE)BDY((QUOTE)ARG0(arg)));

MKQUOTE(q,a);

*rp = (Obj)q;

} else

*rp = eval((FNODE)BDY((QUOTE)ARG0(arg)));

}

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>