OpenXM_contrib2/asir2000/parse/eval.c - diff

Return to eval.c CVS log

Up to [local] / OpenXM_contrib2 / asir2000 / parse

Diff for /OpenXM_contrib2/asir2000/parse/eval.c between version 1.1 and 1.16

version 1.1, 1999/12/03 07:39:12

version 1.16, 2001/10/09 01:36:24

Line 1

/* $OpenXM: OpenXM/src/asir99/parse/eval.c,v 1.2 1999/11/18 05:42:03 noro Exp $ */

* FUJITSU LABORATORIES LIMITED ("FLL") hereby grants you a limited,

* non-exclusive and royalty-free license to use, copy, modify and

* redistribute, solely for non-commercial and non-profit purposes, the

* computer program, "Risa/Asir" ("SOFTWARE"), subject to the terms and

* conditions of this Agreement. For the avoidance of doubt, you acquire

* only a limited right to use the SOFTWARE hereunder, and FLL or any

* third party developer retains all rights, including but not limited to

* copyrights, in and to the SOFTWARE.

* (1) FLL does not grant you a license in any way for commercial

* purposes. You may use the SOFTWARE only for non-commercial and

* non-profit purposes only, such as academic, research and internal

* business use.

* (2) The SOFTWARE is protected by the Copyright Law of Japan and

* international copyright treaties. If you make copies of the SOFTWARE,

* with or without modification, as permitted hereunder, you shall affix

* to all such copies of the SOFTWARE the above copyright notice.

* (3) An explicit reference to this SOFTWARE and its copyright owner

* shall be made on your publication or presentation in any form of the

* results obtained by use of the SOFTWARE.

* (4) In the event that you modify the SOFTWARE, you shall notify FLL by

* e-mail at risa-admin@sec.flab.fujitsu.co.jp of the detailed specification

* for such modification or the source code of the modified part of the

* SOFTWARE.

* THE SOFTWARE IS PROVIDED AS IS WITHOUT ANY WARRANTY OF ANY KIND. FLL

* MAKES ABSOLUTELY NO WARRANTIES, EXPRESSED, IMPLIED OR STATUTORY, AND

* EXPRESSLY DISCLAIMS ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS

* FOR A PARTICULAR PURPOSE OR NONINFRINGEMENT OF THIRD PARTIES'

* RIGHTS. NO FLL DEALER, AGENT, EMPLOYEES IS AUTHORIZED TO MAKE ANY

* MODIFICATIONS, EXTENSIONS, OR ADDITIONS TO THIS WARRANTY.

* UNDER NO CIRCUMSTANCES AND UNDER NO LEGAL THEORY, TORT, CONTRACT,

* OR OTHERWISE, SHALL FLL BE LIABLE TO YOU OR ANY OTHER PERSON FOR ANY

* DIRECT, INDIRECT, SPECIAL, INCIDENTAL, PUNITIVE OR CONSEQUENTIAL

* DAMAGES OF ANY CHARACTER, INCLUDING, WITHOUT LIMITATION, DAMAGES

* ARISING OUT OF OR RELATING TO THE SOFTWARE OR THIS AGREEMENT, DAMAGES

* FOR LOSS OF GOODWILL, WORK STOPPAGE, OR LOSS OF DATA, OR FOR ANY

* DAMAGES, EVEN IF FLL SHALL HAVE BEEN INFORMED OF THE POSSIBILITY OF

* SUCH DAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. EVEN IF A PART

* OF THE SOFTWARE HAS BEEN DEVELOPED BY A THIRD PARTY, THE THIRD PARTY

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

* PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE.

* $OpenXM: OpenXM_contrib2/asir2000/parse/eval.c,v 1.15 2001/09/20 04:08:21 noro Exp $

#include <ctype.h>

#include "ca.h"

#include "al.h"

#include "base.h"

#include "parse.h"

#if !defined(THINK_C)

#include <sys/types.h>

#include <sys/stat.h>

#endif

#if PARI

#include "genpari.h"

#endif

extern jmp_buf timer_env;

Line 16 int f_break,f_return,f_continue;

Line 64 int f_break,f_return,f_continue;

int evalstatline;

int recv_intr;

pointer bevalf(), evalmapf(), evall();

pointer eval(FNODE f)

Obj getopt_from_cpvs();

pointer eval(f)

FNODE f;

{

LIST t;

STRING str;

Line 33 FNODE f;

Line 77 FNODE f;

FNODE f1;

UP2 up2;

UP up;

UM um;

Obj obj;

GF2N gf2n;

GFPN gfpn;

GFSN gfsn;

#if defined(VISUAL)

if ( recv_intr ) {

Line 51 FNODE f;

Line 98 FNODE f;

if ( !f )

return ( 0 );

switch ( f->id ) {

case I_PAREN:

val = eval((FNODE)(FA0(f)));

break;

case I_MINUS:

a1 = eval((FNODE)(FA0(f)));

arf_chsgn((Obj)a1,&obj);

val = (pointer)obj;

break;

case I_BOP:

a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f));

(*((ARF)FA0(f))->fp)(CO,a1,a2,&val);

break;

case I_COP:

a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f));

c = arf_comp(CO,a1,a2);

Line 113 FNODE f;

Line 168 FNODE f;

break;

case I_MAP:

val = evalmapf((FUNC)FA0(f),(FNODE)FA1(f)); break;

case I_RECMAP:

val = eval_rec_mapf((FUNC)FA0(f),(FNODE)FA1(f)); break;

case I_IFUNC:

val = evalif((FNODE)FA0(f),(FNODE)FA1(f)); break;

#if !defined(VISUAL)

Line 135 FNODE f;

Line 192 FNODE f;

}

break;

#endif

#if 0

case I_PRESELF: case I_POSTSELF:

val = evalpv(f->id,FA1(f),FA0(f)); break;

case I_PVAR:

val = evalpv(f->id,FA0(f),0); break;

case I_ASSPVAR:

val = evalpv(f->id,FA0(f),FA1(f)); break;

#endif

#if 1

case I_PRESELF:

f1 = (FNODE)FA1(f);

if ( ID(f1) == I_PVAR ) {

Line 155 FNODE f;

Line 203 FNODE f;

(*((ARF)FA0(f))->fp)(CO,u,ONE,&val); putarray(a,tn,val);

}

} else

val = evalpv(f->id,(FNODE)FA1(f),FA0(f));

error("++ : not implemented yet");

break;

case I_POSTSELF:

f1 = (FNODE)FA1(f);

Line 169 FNODE f;

Line 217 FNODE f;

val = a;

}

} else

val = evalpv(f->id,(FNODE)FA1(f),FA0(f));

error("-- : not implemented yet");

break;

case I_CAST:

getmember((FNODE)f,(Obj *)&val); break;

case I_PVAR:

pv = (int)FA0(f); ind = (NODE)FA1(f); GETPV(pv,a);

if ( !ind )

Line 192 FNODE f;

Line 238 FNODE f;

evalnodebody(ind,&tn);

putarray(a,tn,val = eval((FNODE)FA1(f)));

}

} else

} else if ( ID(f1) == I_POINT ) {

val = evalpv(ID(f),(FNODE)FA0(f),FA1(f));

/* f1 <-> FA0(f1)->FA1(f1) */

a = eval(FA0(f1));

assign_to_member(a,(char *)FA1(f1),val = eval((FNODE)FA1(f)));

} else if ( ID(f1) == I_INDEX ) {

/* f1 <-> FA0(f1)[FA1(f1)] */

a = eval((FNODE)FA0(f1)); ind = (NODE)FA1(f1);

evalnodebody(ind,&tn);

putarray(a,tn,val = eval((FNODE)FA1(f)));

} else {

error("eval : invalid assignment");

}

break;

#endif

case I_ANS:

if ( (pv =(int)FA0(f)) < (int)APVS->n )

val = APVS->va[pv].priv;

Line 209 FNODE f;

Line 264 FNODE f;

break;

case I_GFPNGEN:

up = UPALLOC(1);

up->d=1;

DEG(up)=1;

up->c[0] = 0;

COEF(up)[0] = 0;

up->c[1] = (Num)ONELM;

COEF(up)[1] = (Num)ONELM;

MKGFPN(up,gfpn);

val = (pointer)gfpn;

break;

case I_GFSNGEN:

um = UMALLOC(1);

DEG(um) = 1;

COEF(um)[0] = 0;

COEF(um)[1] = _onesf();

MKGFSN(um,gfsn);

val = (pointer)gfsn;

break;

case I_STR:

MKSTR(str,FA0(f)); val = (pointer)str; break;

case I_FORMULA:

Line 255 FNODE f;

Line 318 FNODE f;

case I_GETOPT:

val = (pointer)getopt_from_cpvs((char *)FA0(f));

break;

case I_POINT:

a = (pointer)eval(FA0(f));

val = (pointer)memberofstruct(a,(char *)FA1(f));

break;

default:

error("eval : unknown id");

break;

Line 262 FNODE f;

Line 329 FNODE f;

return ( val );

}

pointer evalstat(f)

pointer evalstat(SNODE f)

SNODE f;

{

pointer val = 0,t,s,s1;

P u;

Line 368 SNODE f;

Line 434 SNODE f;

return ( val );

}

pointer evalnode(node)

pointer evalnode(NODE node)

NODE node;

{

NODE tn;

pointer val;

Line 383 NODE node;

Line 448 NODE node;

extern FUNC cur_binf;

extern NODE PVSS;

pointer evalf(f,a,opt)

pointer evalf(FUNC f,FNODE a,FNODE opt)

FUNC f;

FNODE a;

FNODE opt;

{

LIST args;

pointer val;

int i,n,level;

NODE tn,sn,opts;

NODE tn,sn,opts,opt1;

VS pvs;

char errbuf[BUFSIZ];

static int stack_size;

static void *stack_base;

if ( f->id == A_UNDEF ) {

sprintf(errbuf,"evalf : %s undefined",NAME(f));

Line 425 FNODE opt;

Line 489 FNODE opt;

cur_binf = 0;

break;

case A_USR:

/* stack check */

#if !defined(VISUAL)

if ( !stack_size ) {

struct rlimit rl;

getrlimit(RLIMIT_STACK,&rl);

stack_size = rl.rlim_cur;

}

if ( !stack_base )

stack_base = (void *)GC_get_stack_base();

if ( (stack_base - (void *)&args) +0x100000 > stack_size )

error("stack overflow");

#endif

args = (LIST)eval(a);

if ( opt )

if ( opt ) {

opts = BDY((LIST)eval(opt));

else

/* opts = ["opt1",arg1],... */

opt1 = BDY((LIST)BDY(opts));

if ( !strcmp(BDY((STRING)BDY(opt1)),"option_list") ) {

* the special option specification:

* option_list=[["o1","a1"],...]

asir_assert(BDY(NEXT(opt1)),O_LIST,"evalf");

opts = BDY((LIST)BDY(NEXT(opt1)));

}

} else

opts = 0;

pvs = f->f.usrf->pvs;

if ( PVSS ) {

Line 466 FNODE opt;

Line 552 FNODE opt;

return val;

}

pointer evalmapf(f,a)

pointer evalmapf(FUNC f,FNODE a)

FUNC f;

FNODE a;

{

LIST args;

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

Line 481 FNODE a;

Line 565 FNODE a;

args = (LIST)eval(a);

node = BDY(args); head = (Obj)BDY(node); rest = NEXT(node);

if ( !head ) {

val = bevalf(f,node);

return val;

}

switch ( OID(head) ) {

case O_VECT:

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

Line 514 FNODE a;

Line 602 FNODE a;

return val;

}

pointer bevalf(f,a)

pointer eval_rec_mapf(FUNC f,FNODE a)

FUNC f;

NODE a;

{

LIST args;

args = (LIST)eval(a);

return beval_rec_mapf(f,BDY(args));

}

pointer beval_rec_mapf(FUNC f,NODE node)

{

NODE rest,t,n,r,r0;

Obj head;

VECT v,rv;

MAT m,rm;

LIST rl;

int len,row,col,i,j;

pointer val;

head = (Obj)BDY(node); rest = NEXT(node);

if ( !head ) {

val = bevalf(f,node);

return val;

}

switch ( OID(head) ) {

case O_VECT:

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

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

MKNODE(t,BDY(v)[i],rest); BDY(rv)[i] = beval_rec_mapf(f,t);

}

val = (pointer)rv;

break;

case O_MAT:

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

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

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

MKNODE(t,BDY(m)[i][j],rest);

BDY(rm)[i][j] = beval_rec_mapf(f,t);

}

val = (pointer)rm;

break;

case O_LIST:

n = BDY((LIST)head);

for ( r0 = r = 0; n; n = NEXT(n) ) {

NEXTNODE(r0,r); MKNODE(t,BDY(n),rest);

BDY(r) = beval_rec_mapf(f,t);

}

if ( r0 )

NEXT(r) = 0;

MKLIST(rl,r0);

val = (pointer)rl;

break;

default:

val = bevalf(f,node);

break;

}

return val;

}

pointer bevalf(FUNC f,NODE a)

{

pointer val;

int i,n;

NODE tn,sn;

VS pvs;

struct oLIST list;

struct oFNODE fnode;

char errbuf[BUFSIZ];

if ( f->id == A_UNDEF ) {

Line 585 NODE a;

Line 727 NODE a;

return val;

}

pointer evalif(f,a)

pointer evalif(FNODE f,FNODE a)

FNODE f,a;

{

Obj g;

Line 595 FNODE f,a;

Line 736 FNODE f,a;

return evalf((FUNC)VR((P)g)->priv,a,0);

else {

error("invalid function pointer");

/* NOTREACHED */

return (pointer)-1;

}

pointer evalpf(pf,args)

pointer evalpf(PF pf,NODE args)

PF pf;

NODE args;

{

Obj s,s1;

int i;

NODE node;

PFINS ins;

PFAD ad;

char errbuf[BUFSIZ];

if ( !pf->body ) {

ins = (PFINS)CALLOC(1,sizeof(PF)+pf->argc*sizeof(struct oPFAD));

Line 626 NODE args;

Line 766 NODE args;

return (pointer)s;

}

void evalnodebody(sn,dnp)

void evalnodebody(NODE sn,NODE *dnp)

NODE sn;

NODE *dnp;

{

NODE n,n0,tn;

int line;

Line 646 NODE *dnp;

Line 784 NODE *dnp;

NEXT(n) = 0; *dnp = n0;

}

void searchf(fn,name,r)

void gen_searchf(char *name,FUNC *r)

NODE fn;

char *name;

FUNC *r;

{

FUNC val;

searchf(sysf,name,&val);

if ( !val )

searchf(ubinf,name,&val);

if ( !val )

searchpf(name,&val);

if ( !val )

searchf(usrf,name,&val);

if ( !val )

appenduf(name,&val);

*r = val;

}

void searchf(NODE fn,char *name,FUNC *r)

{

NODE tn;

for ( tn = fn;

Line 662 FUNC *r;

Line 813 FUNC *r;

*r = 0;

}

void appenduf(name,r)

void appenduf(char *name,FUNC *r)

char *name;

FUNC *r;

{

NODE tn;

FUNC f;

Line 675 FUNC *r;

Line 824 FUNC *r;

*r = f;

}

void mkparif(name,r)

void mkparif(char *name,FUNC *r)

char *name;

FUNC *r;

{

FUNC f;

Line 685 FUNC *r;

Line 832 FUNC *r;

f->name = name; f->id = A_PARI; f->argc = 0; f->f.binf = 0;

}

void mkuf(name,fname,args,body,startl,endl,desc)

void mkuf(char *name,char *fname,NODE args,SNODE body,int startl,int endl,char *desc)

char *name,*fname;

NODE args;

SNODE body;

int startl,endl;

char *desc;

{

FUNC f;

USRF t;

Line 737 char *desc;

Line 879 char *desc;

CVS->opt = BDY([[key,value],[key,value],...])

Obj getopt_from_cpvs(key)

Obj getopt_from_cpvs(char *key)

char *key;

{

NODE opts,opt;

Obj value;

LIST r;

extern Obj VOIDobj;

opts = CPVS->opt;

for ( ; opts; opts = NEXT(opts) ) {

if ( !key ) {

opt = BDY((LIST)BDY(opts));

MKLIST(r,opts);

if ( !strcmp(key,BDY((STRING)BDY(opt))) )

return (Obj)r;

return (Obj)BDY(NEXT(opt));

} else {

for ( ; opts; opts = NEXT(opts) ) {

asir_assert(BDY(opts),O_LIST,"getopt_from_cvps");

opt = BDY((LIST)BDY(opts));

if ( !strcmp(key,BDY((STRING)BDY(opt))) )

return (Obj)BDY(NEXT(opt));

}

return VOIDobj;

}

return VOIDobj;

}

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