version 1.54, 2005/07/15 00:23:26 |
version 1.66, 2005/09/30 02:20:06 |
|
|
* 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.53 2005/07/14 04:07:31 noro Exp $ |
* $OpenXM: OpenXM_contrib2/asir2000/builtin/strobj.c,v 1.65 2005/09/30 01:35:25 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(); |
void Pquote_unify(),Pget_quote_id(); |
|
void Pquote_to_nary(),Pquote_to_bin(); |
|
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); |
char *conv_rule(char *name); |
char *conv_rule(char *name); |
Line 88 void tb_to_string(TB tb,STRING *rp); |
|
Line 90 void tb_to_string(TB tb,STRING *rp); |
|
void fnodenodetotex_tb(NODE n,TB tb); |
void fnodenodetotex_tb(NODE n,TB tb); |
void fargstotex_tb(char *opname,FNODE f,TB tb); |
void fargstotex_tb(char *opname,FNODE f,TB tb); |
int top_is_minus(FNODE f); |
int top_is_minus(FNODE f); |
NODE quote_unify(Obj f,Obj pat); |
int quote_unify(Obj f,Obj pat,NODE *rp); |
|
|
struct ftab str_tab[] = { |
struct ftab str_tab[] = { |
{"sprintf",Psprintf,-99999999}, |
{"sprintf",Psprintf,-99999999}, |
Line 104 struct ftab str_tab[] = { |
|
Line 106 struct ftab str_tab[] = { |
|
{"clear_tb",Pclear_tb,1}, |
{"clear_tb",Pclear_tb,1}, |
{"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}, |
|
{"quote_to_nary",Pquote_to_nary,1}, |
|
{"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}, |
{"funargs_to_quote",Pfunargs_to_quote,1}, |
{"funargs_to_quote",Pfunargs_to_quote,1}, |
Line 507 void Pwrite_to_tb(NODE arg,Q *rp) |
|
Line 512 void Pwrite_to_tb(NODE arg,Q *rp) |
|
*rp = 0; |
*rp = 0; |
} |
} |
|
|
void Pquote_unify(NODE arg,LIST *rp) |
FNODE partial_eval(FNODE), quote_to_nary(FNODE), quote_to_bin(FNODE,int); |
|
|
|
void Pquote_to_nary(NODE arg,QUOTE *rp) |
{ |
{ |
|
FNODE f; |
|
|
|
f = quote_to_nary(BDY((QUOTE)ARG0(arg))); |
|
MKQUOTE(*rp,f); |
|
} |
|
|
|
void Pquote_to_bin(NODE arg,QUOTE *rp) |
|
{ |
|
FNODE f; |
|
int direction; |
|
|
|
direction = QTOS((Q)ARG1(arg)); |
|
f = quote_to_bin(BDY((QUOTE)ARG0(arg)),direction); |
|
|
|
MKQUOTE(*rp,f); |
|
} |
|
|
|
void Pquote_unify(NODE arg,Q *rp) |
|
{ |
|
FNODE f,g; |
|
Obj obj; |
|
QUOTE q; |
NODE r; |
NODE r; |
|
int ret; |
|
|
r = quote_unify((Obj)ARG0(arg),(Obj)ARG1(arg)); |
#if 0 |
MKLIST(*rp,r); |
g = partial_eval(BDY(((QUOTE)ARG0(arg)))); |
|
MKQUOTE(q,g); |
|
ret = quote_unify((Obj)q,(Obj)ARG1(arg),&r); |
|
#else |
|
obj = (Obj)ARG0(arg); |
|
if ( !obj || OID(obj) != O_QUOTE) { |
|
objtoquote(obj,&q); obj = (Obj)q; |
|
} |
|
ret = quote_unify(obj,(Obj)ARG1(arg),&r); |
|
#endif |
|
if ( ret ) { |
|
do_assign(r); |
|
*rp = ONE; |
|
} else |
|
*rp = 0; |
} |
} |
|
|
|
void do_assign(NODE arg) |
|
{ |
|
NODE t,pair; |
|
int pv; |
|
|
|
QUOTE value; |
|
|
|
for ( t = arg; t; t = NEXT(t) ) { |
|
pair = BDY((LIST)BDY(t)); |
|
pv = (int)FA0((FNODE)BDY((QUOTE)BDY(pair))); |
|
value = (QUOTE)(BDY(NEXT(pair))); |
|
ASSPV(pv,value); |
|
} |
|
} |
|
|
/* |
/* |
/* consistency check and merge */ |
/* consistency check and merge |
|
*/ |
|
|
NODE merge_matching_node(NODE n,NODE a) |
int merge_matching_node(NODE n,NODE a,NODE *rp) |
{ |
{ |
NODE ta,ba,tn,bn; |
NODE ta,ba,tn,bn; |
QUOTE pa,va,pn,vn; |
QUOTE pa,va,pn,vn; |
|
|
if ( !n ) |
if ( !n ) { |
return a; |
*rp = a; |
|
return 1; |
|
} |
for ( ta = a; ta; ta = NEXT(ta) ) { |
for ( ta = a; ta; ta = NEXT(ta) ) { |
ba = BDY((LIST)BDY(ta)); |
ba = BDY((LIST)BDY(ta)); |
|
if ( !ba ) continue; |
pa = (QUOTE)BDY(ba); va = (QUOTE)BDY(NEXT(ba)); |
pa = (QUOTE)BDY(ba); va = (QUOTE)BDY(NEXT(ba)); |
for ( tn = n; tn; tn = NEXT(tn) ) { |
for ( tn = n; tn; tn = NEXT(tn) ) { |
bn = BDY((LIST)BDY(tn)); |
bn = BDY((LIST)BDY(tn)); |
|
if ( !bn ) continue; |
pn = (QUOTE)BDY(bn); vn = (QUOTE)BDY(NEXT(bn)); |
pn = (QUOTE)BDY(bn); vn = (QUOTE)BDY(NEXT(bn)); |
if ( !compquote(CO,pa,pn) && !compquote(CO,va,vn) ) |
if ( !compquote(CO,pa,pn) ) { |
break; |
if ( !compquote(CO,va,vn) ) break; |
|
else return 0; |
|
} |
} |
} |
if ( !tn ) { |
if ( !tn ) { |
MKNODE(tn,(pointer)BDY(ta),n); |
MKNODE(tn,(pointer)BDY(ta),n); |
n = tn; |
n = tn; |
} |
} |
} |
} |
return n; |
*rp = n; |
|
return 1; |
} |
} |
|
|
NODE quote_unify_node(NODE f,NODE pat) { |
int quote_unify_node(NODE f,NODE pat,NODE *rp) { |
NODE r,a,tf,tp; |
NODE r,a,tf,tp,r1; |
|
int ret; |
|
|
if ( length(f) != length(pat) ) return 0; |
if ( length(f) != length(pat) ) return 0; |
r = 0; |
r = 0; |
for ( tf = f, tp = pat; tf; tf = NEXT(tf), tp = NEXT(tp) ) { |
for ( tf = f, tp = pat; tf; tf = NEXT(tf), tp = NEXT(tp) ) { |
a = quote_unify((Obj)BDY(tf),(Obj)BDY(tp)); |
ret = quote_unify((Obj)BDY(tf),(Obj)BDY(tp),&a); |
r = merge_matching_node(r,a); |
if ( !ret ) return 0; |
if ( !r ) return 0; |
ret = merge_matching_node(r,a,&r1); |
|
if ( !ret ) return 0; |
|
else r = r1; |
} |
} |
return r; |
*rp = r; |
|
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 564 void get_quote_id_arg(QUOTE f,int *id,NODE *r) |
|
Line 669 void get_quote_id_arg(QUOTE f,int *id,NODE *r) |
|
*id = QTOS((Q)BDY(fab)); *r = NEXT(fab); |
*id = QTOS((Q)BDY(fab)); *r = NEXT(fab); |
} |
} |
|
|
/* ret : [[quote(A),quote(1)],...] */ |
/* *rp : [[quote(A),quote(1)],...] */ |
|
|
NODE quote_unify(Obj f, Obj pat) |
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; |
|
int ret; |
|
QUOTE q; |
|
FNODE g; |
|
|
if ( OID(pat) == O_LIST ) { |
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)); |
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 ) { |
Line 583 NODE quote_unify(Obj f, Obj pat) |
|
Line 693 NODE quote_unify(Obj f, Obj pat) |
|
get_quote_id_arg((QUOTE)pat,&pid,&parg); |
get_quote_id_arg((QUOTE)pat,&pid,&parg); |
get_quote_id_arg((QUOTE)f,&id,&farg); |
get_quote_id_arg((QUOTE)f,&id,&farg); |
switch ( pid ) { |
switch ( pid ) { |
|
case I_FORMULA: |
|
if ( compquote(CO,f,pat) ) |
|
return 0; |
|
else { |
|
*rp = 0; |
|
return 1; |
|
} |
|
break; |
|
case I_LIST: |
|
return quote_unify_node(BDY((LIST)BDY(farg)), |
|
BDY((LIST)BDY(parg)),rp); |
|
case I_CONS: |
|
tf = BDY((LIST)BDY(farg)); |
|
tp = BDY((LIST)BDY(parg)); |
|
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); |
return mknode(1,l); |
*rp = mknode(1,l); |
|
return 1; |
case I_IFUNC: |
case I_IFUNC: |
/* F(X,Y,...) = ... */ |
/* F(X,Y,...) = ... */ |
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); |
body = quote_unify(BDY(NEXT(farg)),BDY(NEXT(parg))); |
ret = quote_unify(BDY(NEXT(farg)), |
if ( !body ) return 0; |
BDY(NEXT(parg)),&body); |
return merge_matching_node(head,body); |
if ( !ret ) return 0; |
|
else return merge_matching_node(head,body,rp); |
} else |
} else |
return 0; |
return 0; |
|
|
|
case I_NARYOP: |
case I_BOP: |
case I_BOP: |
/* X+Y = ... */ |
/* X+Y = ... */ |
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)); |
|
|
/* XXX converting to I_BOP */ |
|
if ( ((FNODE)BDY((QUOTE)pat))->id == I_NARYOP ) { |
|
g = quote_to_bin(BDY((QUOTE)pat),1); |
|
MKQUOTE(q,g); |
|
get_quote_id_arg((QUOTE)q,&pid,&parg); |
|
} |
|
if ( ((FNODE)BDY((QUOTE)f))->id == I_NARYOP ) { |
|
g = quote_to_bin(BDY((QUOTE)f),1); |
|
MKQUOTE(q,g); |
|
get_quote_id_arg((QUOTE)q,&id,&farg); |
|
} |
|
return quote_unify_node(NEXT(farg),NEXT(parg),rp); |
|
break; |
|
|
|
case I_FUNC: |
|
/* f(...) = ... */ |
|
if ( compqa(CO,BDY(farg),BDY(parg)) ) return 0; |
|
return quote_unify_node(NEXT(farg),NEXT(parg),rp); |
|
break; |
default: |
default: |
if ( pid == id ) |
if ( pid == id ) |
return quote_unify_node(farg,parg); |
return quote_unify_node(farg,parg,rp); |
else |
else |
return 0; |
return 0; |
} |
} |
Line 1456 void Pflatten_quote(NODE arg,Obj *rp) |
|
Line 1605 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; |
} |
} |
|
} |
|
|
|
void Pget_quote_id(NODE arg,Q *rp) |
|
{ |
|
FNODE f; |
|
QUOTE q; |
|
|
|
q = (QUOTE)ARG0(arg); |
|
if ( !q || OID(q) != O_QUOTE ) |
|
error("get_quote_id : invalid argument"); |
|
f = BDY(q); |
|
STOQ((int)f->id,*rp); |
} |
} |
|
|
void Pquote_to_funargs(NODE arg,LIST *rp) |
void Pquote_to_funargs(NODE arg,LIST *rp) |