version 1.63, 2005/09/28 08:08:34 |
version 1.68, 2005/10/05 07:38:08 |
|
|
* 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/strobj.c,v 1.62 2005/09/27 09:32:22 noro Exp $ |
* $OpenXM: OpenXM_contrib2/asir2000/builtin/strobj.c,v 1.67 2005/10/03 00:06:40 noro Exp $ |
*/ |
*/ |
#include "ca.h" |
#include "ca.h" |
#include "parse.h" |
#include "parse.h" |
Line 78 void Pquotetotex(); |
|
Line 78 void Pquotetotex(); |
|
void Pquotetotex_env(); |
void Pquotetotex_env(); |
void Pflatten_quote(); |
void Pflatten_quote(); |
void Pquote_to_funargs(),Pfunargs_to_quote(),Pget_function_name(); |
void Pquote_to_funargs(),Pfunargs_to_quote(),Pget_function_name(); |
void Pquote_unify(),Pget_quote_id(); |
void Pquote_unify(),Pget_quote_id(),Pquote_match_rewrite(); |
void Pquote_bin_to_nary(),Pquote_nary_to_bin(); |
void Pquote_to_nary(),Pquote_to_bin(); |
void do_assign(NODE arg); |
void do_assign(NODE arg); |
void fnodetotex_tb(FNODE f,TB tb); |
void fnodetotex_tb(FNODE f,TB tb); |
char *symbol_name(char *name); |
char *symbol_name(char *name); |
Line 107 struct ftab str_tab[] = { |
|
Line 107 struct ftab str_tab[] = { |
|
{"tb_to_string",Ptb_to_string,1}, |
{"tb_to_string",Ptb_to_string,1}, |
{"string_to_tb",Pstring_to_tb,1}, |
{"string_to_tb",Pstring_to_tb,1}, |
{"get_quote_id",Pget_quote_id,1}, |
{"get_quote_id",Pget_quote_id,1}, |
{"quote_bin_to_nary",Pquote_bin_to_nary,1}, |
{"quote_to_nary",Pquote_to_nary,1}, |
{"quote_nary_to_bin",Pquote_nary_to_bin,2}, |
{"quote_to_bin",Pquote_to_bin,2}, |
{"quotetotex_tb",Pquotetotex_tb,2}, |
{"quotetotex_tb",Pquotetotex_tb,2}, |
{"quotetotex",Pquotetotex,1}, |
{"quotetotex",Pquotetotex,1}, |
{"quotetotex_env",Pquotetotex_env,-99999999}, |
{"quotetotex_env",Pquotetotex_env,-99999999}, |
{"flatten_quote",Pflatten_quote,2}, |
{"flatten_quote",Pflatten_quote,-2}, |
{"quote_to_funargs",Pquote_to_funargs,1}, |
{"quote_to_funargs",Pquote_to_funargs,1}, |
{"quote_unify",Pquote_unify,2}, |
{"quote_unify",Pquote_unify,2}, |
|
{"quote_match_rewrite",Pquote_match_rewrite,-4}, |
{"funargs_to_quote",Pfunargs_to_quote,1}, |
{"funargs_to_quote",Pfunargs_to_quote,1}, |
{"get_function_name",Pget_function_name,1}, |
{"get_function_name",Pget_function_name,1}, |
{0,0,0}, |
{0,0,0}, |
Line 512 void Pwrite_to_tb(NODE arg,Q *rp) |
|
Line 513 void Pwrite_to_tb(NODE arg,Q *rp) |
|
*rp = 0; |
*rp = 0; |
} |
} |
|
|
FNODE partial_eval(FNODE), quote_bin_to_nary(FNODE), quote_nary_to_bin(FNODE,int); |
FNODE partial_eval(FNODE), quote_to_nary(FNODE), quote_to_bin(FNODE,int); |
|
|
void Pquote_bin_to_nary(NODE arg,QUOTE *rp) |
void Pquote_to_nary(NODE arg,QUOTE *rp) |
{ |
{ |
FNODE f; |
FNODE f; |
|
|
f = quote_bin_to_nary(BDY((QUOTE)ARG0(arg))); |
f = quote_to_nary(BDY((QUOTE)ARG0(arg))); |
MKQUOTE(*rp,f); |
MKQUOTE(*rp,f); |
} |
} |
|
|
void Pquote_nary_to_bin(NODE arg,QUOTE *rp) |
void Pquote_to_bin(NODE arg,QUOTE *rp) |
{ |
{ |
FNODE f; |
FNODE f; |
int direction; |
int direction; |
|
|
direction = QTOS((Q)ARG1(arg)); |
direction = QTOS((Q)ARG1(arg)); |
f = quote_nary_to_bin(BDY((QUOTE)ARG0(arg)),direction); |
f = quote_to_bin(BDY((QUOTE)ARG0(arg)),direction); |
|
|
MKQUOTE(*rp,f); |
MKQUOTE(*rp,f); |
} |
} |
Line 536 void Pquote_nary_to_bin(NODE arg,QUOTE *rp) |
|
Line 537 void Pquote_nary_to_bin(NODE arg,QUOTE *rp) |
|
void Pquote_unify(NODE arg,Q *rp) |
void Pquote_unify(NODE arg,Q *rp) |
{ |
{ |
FNODE f,g; |
FNODE f,g; |
|
Obj obj; |
QUOTE q; |
QUOTE q; |
NODE r; |
NODE r; |
int ret; |
int ret; |
Line 545 void Pquote_unify(NODE arg,Q *rp) |
|
Line 547 void Pquote_unify(NODE arg,Q *rp) |
|
MKQUOTE(q,g); |
MKQUOTE(q,g); |
ret = quote_unify((Obj)q,(Obj)ARG1(arg),&r); |
ret = quote_unify((Obj)q,(Obj)ARG1(arg),&r); |
#else |
#else |
ret = quote_unify((Obj)ARG0(arg),(Obj)ARG1(arg),&r); |
obj = (Obj)ARG0(arg); |
|
ret = quote_unify(obj,(Obj)ARG1(arg),&r); |
#endif |
#endif |
if ( ret ) { |
if ( ret ) { |
do_assign(r); |
do_assign(r); |
Line 554 void Pquote_unify(NODE arg,Q *rp) |
|
Line 557 void Pquote_unify(NODE arg,Q *rp) |
|
*rp = 0; |
*rp = 0; |
} |
} |
|
|
|
FNODE rewrite_fnode(FNODE,NODE); |
|
|
|
extern Obj VOIDobj; |
|
|
|
void Pquote_match_rewrite(NODE arg,Obj *rp) |
|
{ |
|
FNODE f,g,h,c,value; |
|
Obj obj; |
|
QUOTE q; |
|
NODE r,t,s,s0,pair; |
|
int ret,ind,ac; |
|
|
|
obj = (Obj)ARG0(arg); |
|
ret = quote_unify(obj,(Obj)ARG1(arg),&r); |
|
if ( ret ) { |
|
for ( t = r, s0 = 0; t; t = NEXT(t) ) { |
|
NEXTNODE(s0,s); |
|
pair = BDY((LIST)BDY(t)); |
|
ind = (int)FA0((FNODE)BDY((QUOTE)BDY(pair))); |
|
value = mkfnode(1,I_FORMULA,BDY(NEXT(pair))); |
|
BDY(s) = mknode(2,ind,value); |
|
} |
|
if ( s0 ) NEXT(s) = 0; |
|
switch ( ac = argc(arg) ) { |
|
case 3: |
|
h = rewrite_fnode(BDY((QUOTE)ARG2(arg)),s0); |
|
*rp = eval(h); |
|
break; |
|
case 4: |
|
c = rewrite_fnode(BDY((QUOTE)ARG2(arg)),s0); |
|
if ( eval(c) ) { |
|
h = rewrite_fnode(BDY((QUOTE)ARG3(arg)),s0); |
|
*rp = eval(h); |
|
} else |
|
*rp = VOIDobj; |
|
break; |
|
default: |
|
error("quote_match_rewrite : invalid argument"); |
|
} |
|
} else |
|
*rp = VOIDobj; |
|
} |
|
|
void do_assign(NODE arg) |
void do_assign(NODE arg) |
{ |
{ |
NODE t,pair; |
NODE t,pair; |
Line 621 int quote_unify_node(NODE f,NODE pat,NODE *rp) { |
|
Line 667 int quote_unify_node(NODE f,NODE pat,NODE *rp) { |
|
return 1; |
return 1; |
} |
} |
|
|
|
/* f = [a,b,c,...] pat = [X,Y,...] rpat matches the rest of f */ |
|
|
|
int quote_unify_cons(NODE f,NODE pat,Obj rpat,NODE *rp) { |
|
QUOTE q; |
|
Q id; |
|
FNODE fn; |
|
NODE r,a,tf,tp,r1,arg; |
|
int ret; |
|
LIST list,alist; |
|
|
|
/* matching of the head part */ |
|
if ( length(f) < length(pat) ) return 0; |
|
r = 0; |
|
for ( tf = f, tp = pat; tp; tf = NEXT(tf), tp = NEXT(tp) ) { |
|
ret = quote_unify((Obj)BDY(tf),(Obj)BDY(tp),&a); |
|
if ( !ret ) return 0; |
|
ret = merge_matching_node(r,a,&r1); |
|
if ( !ret ) return 0; |
|
else r = r1; |
|
} |
|
/* matching of the rest */ |
|
MKLIST(list,tf); |
|
STOQ(I_LIST,id); a = mknode(2,id,list); |
|
MKLIST(alist,a); |
|
arg = mknode(1,alist); |
|
Pfunargs_to_quote(arg,&q); |
|
ret = quote_unify((Obj)q,rpat,&a); |
|
if ( !ret ) return 0; |
|
ret = merge_matching_node(r,a,&r1); |
|
if ( !ret ) return 0; |
|
*rp = r1; |
|
return 1; |
|
} |
|
|
void get_quote_id_arg(QUOTE f,int *id,NODE *r) |
void get_quote_id_arg(QUOTE f,int *id,NODE *r) |
{ |
{ |
LIST fa; |
LIST fa; |
Line 636 int quote_unify(Obj f, Obj pat, NODE *rp) |
|
Line 716 int quote_unify(Obj f, Obj pat, NODE *rp) |
|
{ |
{ |
NODE tf,tp,head,body; |
NODE tf,tp,head,body; |
NODE parg,farg,r; |
NODE parg,farg,r; |
|
Obj rpat; |
LIST fa,l; |
LIST fa,l; |
int pid,id; |
int pid,id; |
FUNC ff,pf; |
FUNC ff,pf; |
int ret; |
int ret; |
|
QUOTE q; |
|
FNODE g; |
|
|
if ( OID(pat) == O_LIST ) { |
if ( !f ) |
|
if ( !pat ) { |
|
*rp = 0; return 1; |
|
} else |
|
return 0; |
|
else if ( OID(pat) == O_LIST ) { |
if ( OID(f) == O_LIST ) |
if ( OID(f) == O_LIST ) |
return quote_unify_node(BDY((LIST)f),BDY((LIST)pat),rp); |
return quote_unify_node(BDY((LIST)f),BDY((LIST)pat),rp); |
else |
else |
return 0; |
return 0; |
} else if ( OID(pat) == O_QUOTE ) { |
} else if ( OID(pat) == O_QUOTE ) { |
if ( OID(f) != O_QUOTE ) return 0; |
pid = ((FNODE)BDY((QUOTE)pat))->id; |
get_quote_id_arg((QUOTE)pat,&pid,&parg); |
|
get_quote_id_arg((QUOTE)f,&id,&farg); |
|
switch ( pid ) { |
switch ( pid ) { |
case I_FORMULA: |
case I_FORMULA: |
if ( compquote(CO,f,pat) ) |
if ( compquote(CO,f,pat) ) |
return 0; |
return 0; |
else { |
else { |
*rp = 0; |
*rp = 0; return 1; |
return 1; |
|
} |
} |
break; |
break; |
case I_LIST: |
|
return quote_unify_node(BDY((LIST)BDY(farg)), |
case I_LIST: case I_CONS: |
BDY((LIST)BDY(parg)),rp); |
get_quote_id_arg((QUOTE)pat,&pid,&parg); |
|
if ( OID(f) == O_LIST ) |
|
tf = BDY((LIST)f); |
|
else if ( OID(f) == O_QUOTE |
|
&& ((FNODE)BDY((QUOTE)f))->id == pid ) { |
|
get_quote_id_arg((QUOTE)f,&id,&farg); |
|
tf = BDY((LIST)BDY(farg)); |
|
} else |
|
return 0; |
|
|
|
tp = BDY((LIST)BDY(parg)); |
|
if ( pid == I_LIST ) |
|
return quote_unify_node(tf,tp,rp); |
|
else { |
|
rpat = (Obj)BDY(NEXT(parg)); |
|
return quote_unify_cons(tf,tp,rpat,rp); |
|
} |
|
|
case I_PVAR: |
case I_PVAR: |
/* [[pat,f]] */ |
/* [[pat,f]] */ |
r = mknode(2,pat,f); MKLIST(l,r); |
r = mknode(2,pat,f); MKLIST(l,r); |
*rp = mknode(1,l); |
*rp = mknode(1,l); |
return 1; |
return 1; |
|
|
case I_IFUNC: |
case I_IFUNC: |
/* F(X,Y,...) = ... */ |
/* F(X,Y,...) = ... */ |
|
get_quote_id_arg((QUOTE)f,&id,&farg); |
|
get_quote_id_arg((QUOTE)pat,&pid,&parg); |
if ( id == I_FUNC ) { |
if ( id == I_FUNC ) { |
r = mknode(2,BDY(parg),BDY(farg)); MKLIST(l,r); |
r = mknode(2,BDY(parg),BDY(farg)); MKLIST(l,r); |
head = mknode(1,l); |
head = mknode(1,l); |
Line 678 int quote_unify(Obj f, Obj pat, NODE *rp) |
|
Line 783 int quote_unify(Obj f, Obj pat, NODE *rp) |
|
else return merge_matching_node(head,body,rp); |
else return merge_matching_node(head,body,rp); |
} else |
} else |
return 0; |
return 0; |
case I_BOP: |
|
case I_FUNC: |
case I_NARYOP: case I_BOP: case I_FUNC: |
/* X+Y = ... */ |
/* X+Y = ... */ |
/* f(...) = ... */ |
/* f(...) = ... */ |
|
if ( OID(f) != O_QUOTE ) return 0; |
|
id = ((FNODE)BDY((QUOTE)f))->id; |
|
if ( pid == I_FUNC ) |
|
; |
|
else { |
|
/* XXX converting to I_BOP */ |
|
if ( pid == I_NARYOP ) { |
|
g = quote_to_bin(BDY((QUOTE)pat),1); |
|
MKQUOTE(q,g); pat = (Obj)q; |
|
} |
|
if ( id == I_NARYOP ) { |
|
g = quote_to_bin(BDY((QUOTE)f),1); |
|
MKQUOTE(q,g); f = (Obj)q; |
|
} |
|
} |
|
get_quote_id_arg((QUOTE)pat,&pid,&parg); |
|
get_quote_id_arg((QUOTE)f,&id,&farg); |
if ( compqa(CO,BDY(farg),BDY(parg)) ) return 0; |
if ( compqa(CO,BDY(farg),BDY(parg)) ) return 0; |
return quote_unify_node(NEXT(farg),NEXT(parg),rp); |
return quote_unify_node(NEXT(farg),NEXT(parg),rp); |
break; |
|
default: |
default: |
if ( pid == id ) |
if ( OID(f) != O_QUOTE ) return 0; |
return quote_unify_node(farg,parg,rp); |
id = ((FNODE)BDY((QUOTE)f))->id; |
else |
if ( id != pid ) return 0; |
return 0; |
get_quote_id_arg((QUOTE)pat,&pid,&parg); |
|
get_quote_id_arg((QUOTE)f,&id,&farg); |
|
return quote_unify_node(farg,parg,rp); |
} |
} |
} |
} |
} |
} |
Line 1540 void Pflatten_quote(NODE arg,Obj *rp) |
|
Line 1664 void Pflatten_quote(NODE arg,Obj *rp) |
|
|
|
if ( !ARG0(arg) || OID((Obj)ARG0(arg)) != O_QUOTE ) |
if ( !ARG0(arg) || OID((Obj)ARG0(arg)) != O_QUOTE ) |
*rp = (Obj)ARG0(arg); |
*rp = (Obj)ARG0(arg); |
else { |
else if ( argc(arg) == 1 ) { |
|
f = flatten_fnode(BDY((QUOTE)ARG0(arg)),"+"); |
|
f = flatten_fnode(f,"*"); |
|
MKQUOTE(q,f); |
|
*rp = (Obj)q; |
|
} else { |
f = flatten_fnode(BDY((QUOTE)ARG0(arg)),BDY((STRING)ARG1(arg))); |
f = flatten_fnode(BDY((QUOTE)ARG0(arg)),BDY((STRING)ARG1(arg))); |
MKQUOTE(q,f); |
MKQUOTE(q,f); |
*rp = (Obj)q; |
*rp = (Obj)q; |