version 1.8, 2004/06/27 03:15:57 |
version 1.10, 2005/09/08 08:37:02 |
|
|
* DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE, |
* DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE, |
* PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE. |
* PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE. |
* |
* |
* $OpenXM: OpenXM_contrib2/asir2000/builtin/pf.c,v 1.7 2004/06/22 09:17:21 noro Exp $ |
* $OpenXM: OpenXM_contrib2/asir2000/builtin/pf.c,v 1.9 2004/12/17 03:09:08 noro Exp $ |
*/ |
*/ |
#include "ca.h" |
#include "ca.h" |
#include "math.h" |
#include "math.h" |
Line 63 void make_tri(void); |
|
Line 63 void make_tri(void); |
|
void make_exp(void); |
void make_exp(void); |
void simplify_pow(PFINS,Obj *); |
void simplify_pow(PFINS,Obj *); |
|
|
void Pfunctor(),Pargs(),Pfunargs(),Pvtype(),Pcall(),Pdeval(); |
void Pfunctor(),Pargs(),Pfunargs(),Pvtype(),Pcall(),Pdeval(),Pfunargs_ext(); |
void Pregister_handler(); |
void Pregister_handler(); |
void Peval_quote(); |
void Peval_quote(); |
void Pmapat(); |
void Pmapat(); |
|
void Padd_handler(); |
|
void Plist_handler(); |
|
void Pclear_handler(); |
|
|
struct ftab puref_tab[] = { |
struct ftab puref_tab[] = { |
{"mapat",Pmapat,-99999999}, |
{"mapat",Pmapat,-99999999}, |
{"functor",Pfunctor,1}, |
{"functor",Pfunctor,1}, |
{"args",Pargs,1}, |
{"args",Pargs,1}, |
{"funargs",Pfunargs,1}, |
{"funargs",Pfunargs,1}, |
|
{"funargs_ext",Pfunargs_ext,1}, |
{"register_handler",Pregister_handler,1}, |
{"register_handler",Pregister_handler,1}, |
|
{"add_handler",Padd_handler,2}, |
|
{"list_handler",Plist_handler,1}, |
|
{"clear_handler",Pclear_handler,1}, |
{"call",Pcall,2}, |
{"call",Pcall,2}, |
{"vtype",Pvtype,1}, |
{"vtype",Pvtype,1}, |
{"deval",Pdeval,1}, |
{"deval",Pdeval,1}, |
|
|
} |
} |
|
|
#define ISPFINS(p)\ |
#define ISPFINS(p)\ |
(p)&&(ID(p) == O_P)&&((int)VR((P)p)->attr!=V_PF)&&\ |
((p)&&(ID(p) == O_P)&&((int)VR((P)p)->attr==V_PF)&&\ |
UNIQ(DEG(DC((P)p)))&&UNIQ(COEF(DC((P)p))) |
UNIQ(DEG(DC((P)p)))&&UNIQ(COEF(DC((P)p)))) |
|
|
void Pfunctor(arg,rp) |
void Pfunctor(arg,rp) |
NODE arg; |
NODE arg; |
|
|
} |
} |
} |
} |
|
|
|
void Pfunargs_ext(arg,rp) |
|
NODE arg; |
|
LIST *rp; |
|
{ |
|
P p; |
|
P f; |
|
FUNC t; |
|
PF pf; |
|
PFINS ins; |
|
PFAD ad; |
|
NODE n,n0,d,d0,a,a0; |
|
LIST alist,dlist; |
|
Q q; |
|
int i; |
|
|
|
p = (P)ARG0(arg); |
|
if ( !ISPFINS(p) ) |
|
*rp = 0; |
|
else { |
|
ins = (PFINS)VR(p)->priv; ad = ins->ad; pf = ins->pf; |
|
t = (FUNC)MALLOC(sizeof(struct oFUNC)); |
|
t->name = t->fullname = pf->name; t->id = A_PURE; t->argc = pf->argc; |
|
t->f.puref = pf; |
|
makesrvar(t,&f); |
|
|
|
d0 = a0 = 0; |
|
for ( i = 0; i < pf->argc; i++ ) { |
|
NEXTNODE(d0,d); STOQ(ad[i].d,q); BDY(d) = (pointer)q; |
|
NEXTNODE(a0,a); BDY(a) = (pointer)ad[i].arg; |
|
} |
|
NEXT(d) = 0; NEXT(a) = 0; MKLIST(alist,a0); MKLIST(dlist,d0); |
|
|
|
n0 = mknode(3,f,dlist,alist); |
|
MKLIST(*rp,n0); |
|
} |
|
} |
|
|
void Pvtype(arg,rp) |
void Pvtype(arg,rp) |
NODE arg; |
NODE arg; |
Q *rp; |
Q *rp; |
|
|
STOQ((int)VR(p)->attr,*rp); |
STOQ((int)VR(p)->attr,*rp); |
} |
} |
|
|
extern FUNC registered_handler; |
extern NODE user_int_handler,user_quit_handler; |
|
|
void Pregister_handler(arg,rp) |
void Pregister_handler(arg,rp) |
NODE arg; |
NODE arg; |
|
|
{ |
{ |
P p; |
P p; |
V v; |
V v; |
|
NODE n; |
FUNC func; |
FUNC func; |
|
|
p = (P)ARG0(arg); |
p = (P)ARG0(arg); |
if ( !p ) |
if ( !p ) { |
registered_handler = 0; |
user_int_handler = 0; |
else if ( OID(p) != 2 ) |
*rp = 0; |
|
return; |
|
} else if ( OID(p) != 2 ) |
error("register_hanlder : invalid argument"); |
error("register_hanlder : invalid argument"); |
v = VR(p); |
v = VR(p); |
if ( (int)v->attr != V_SR ) |
if ( (int)v->attr != V_SR ) |
|
|
if ( func->argc ) |
if ( func->argc ) |
error("register_hanlder : the function must be with no argument"); |
error("register_hanlder : the function must be with no argument"); |
else { |
else { |
registered_handler = func; |
MKNODE(n,(pointer)func,user_int_handler); |
|
user_int_handler = n; |
*rp = ONE; |
*rp = ONE; |
} |
} |
} |
} |
|
} |
|
|
|
void Padd_handler(arg,rp) |
|
NODE arg; |
|
Q *rp; |
|
{ |
|
P p; |
|
V v; |
|
NODE n; |
|
FUNC func; |
|
char *name; |
|
NODE *hlistp; |
|
|
|
asir_assert(ARG0(arg),O_STR,"add_handler"); |
|
name = BDY((STRING)ARG0(arg)); |
|
p = (P)ARG1(arg); |
|
if ( !strcmp(name,"intr") ) |
|
hlistp = &user_int_handler; |
|
else if ( !strcmp(name,"quit") ) |
|
hlistp = &user_quit_handler; |
|
else |
|
error("add_handler : invalid keyword (must be \"intr\" or \"quit\")"); |
|
if ( !p ) { |
|
*hlistp = 0; *rp = 0; |
|
return; |
|
} |
|
if ( OID(p) == 2 ) { |
|
v = VR(p); |
|
if ( (int)v->attr != V_SR ) |
|
error("add_hanlder : no such function"); |
|
func = (FUNC)v->priv; |
|
} else if ( OID(p) == O_STR ) { |
|
gen_searchf_searchonly(BDY((STRING)p),&func); |
|
if ( !func ) |
|
error("add_hanlder : no such function"); |
|
} |
|
if ( func->argc ) |
|
error("register_hanlder : the function must be with no argument"); |
|
else { |
|
MKNODE(n,(pointer)func,*hlistp); |
|
*hlistp = n; |
|
*rp = ONE; |
|
} |
|
} |
|
|
|
void Plist_handler(arg,rp) |
|
NODE arg; |
|
LIST *rp; |
|
{ |
|
NODE r0,r,t; |
|
char *name; |
|
NODE hlist; |
|
STRING fname; |
|
|
|
asir_assert(ARG0(arg),O_STR,"list_handler"); |
|
name = BDY((STRING)ARG0(arg)); |
|
if ( !strcmp(name,"intr") ) |
|
hlist = user_int_handler; |
|
else if ( !strcmp(name,"quit") ) |
|
hlist = user_quit_handler; |
|
else |
|
error("list_handler : invalid keyword (must be \"intr\" or \"quit\")"); |
|
for ( r0 = 0, t = hlist; t; t = NEXT(t) ) { |
|
NEXTNODE(r0,r); |
|
MKSTR(fname,((FUNC)BDY(t))->fullname); |
|
BDY(r) = (pointer)fname; |
|
} |
|
if ( r0 ) NEXT(r) = 0; |
|
MKLIST(*rp,r0); |
|
} |
|
|
|
void Pclear_handler(arg,rp) |
|
NODE arg; |
|
Q *rp; |
|
{ |
|
NODE r0,r,t; |
|
char *name; |
|
NODE hlist; |
|
STRING fname; |
|
|
|
asir_assert(ARG0(arg),O_STR,"clear_handler"); |
|
name = BDY((STRING)ARG0(arg)); |
|
if ( !strcmp(name,"intr") ) |
|
user_int_handler = 0; |
|
else if ( !strcmp(name,"quit") ) |
|
user_quit_handler = 0; |
|
else |
|
error("clear_handler : invalid keyword (must be \"intr\" or \"quit\")"); |
|
*rp = 0; |
} |
} |
|
|
void Pcall(NODE arg,Obj *rp) |
void Pcall(NODE arg,Obj *rp) |