NetNews Usenet Archive 1993 #3/NN_1993_3.iso/spool/alt/sources/3072

Text File | 1993-01-23 | 28.8 KB | 844 lines

Newsgroups: alt.sources
Path: sparky!uunet!cs.utexas.edu!qt.cs.utexas.edu!yale.edu!newsserver.jvnc.net!princeton!csservices!tyrolia!mg
From: mg@tyrolia (Michael Golan)
Subject: Duel - a language for debugging C programs part 4/6
Message-ID: <[e-mail]>
Sender: [e-mail] (USENET News System)
Organization: Department of Computer Science, Princeton University
Date: Fri, 22 Jan 1993 03:47:22 GMT
Lines: 833

Submitted-by: [e-mail]
Archive-name: duel/part04

#!/bin/sh
# This is part 04 of duel
if touch 2>&1 | fgrep 'amc' > /dev/null
 then TOUCH=touch
 else TOUCH=true
fi
# ============= src/eval.c ==============
echo "x - extracting src/eval.c (Text)"
sed 's/^X//' << 'SHAR_EOF' > src/eval.c &&
X/*   DUEL - A Very High Level Debugging Langauge.  */
X/*   Public domain code                            */
X/*   Written by Michael Golan [e-mail]  */
X/*$Header: /tmp_mnt/n/fs/grad2/mg/duel/RCS/eval.c,v 1.9 93/01/12 21:50:26 mg Exp $*/
X
X/* this module is the most critical code, the recursive evaluation
X */
X
X/*
X * $Log:    eval.c,v $
X * Revision 1.9  93/01/12  21:50:26  mg
X * cleanup and set for release
X *
X * Revision 1.8  93/01/07  00:09:34  mg
X * scope stack changes a bit.
X * clear/aliases commands.
X * func.x support, x.y etc force existance if y field of x., x=>y w/'_'
X * allow fields in y for x@y, x pointer.
X * fixed eval_node setup
X * added &&/ ||/
X *
X *
X * Revision 1.7  93/01/03  07:29:23  mg
X * function calls, error reporting, printing.
X *
X * Revision 1.6  92/12/24  23:33:48  mg
X * frames support
X *
X * Revision 1.5  92/10/19  15:06:35  mg
X * *** empty log message ***
X *
X * Revision 1.4  92/10/14  02:04:35  mg
X * misc
X *
X * Revision 1.3  92/09/16  11:04:16  mg
X * *** empty log message ***
X *
X * Revision 1.2  92/09/15  05:54:56  mg
X * cosmetics and new ops:
X * generic '.' and '_'  support. x@y. '..x' and 'x..'.  while(), for(), ?:
X *
X */
X
X#include "duel.h"
X
X
X
X#define DOT_STACK_SIZE 100    /* dot stack size, maximum no. of dots in stmt */
X
X/* the scope eval stack.
X * This is used for two purposes: to push _'s values, and to push structs
X * and unions for x.y and x->y.
X * realv is the real value for the left side operand. It is used for '_'
X * fieldv is the one to be used to fetch fields. It is either the same
X * as realv (e.g. for x.y), is *realv (for x->y) or null (for x=>y).
X */
Xstruct {
X    tvalue *realv ;     /* actual value for x in x.y or x->y etc. used for _ */
X    tvalue *fieldv;     /* value to use for fetching fields, *realv for x->y */
X  } dot_stack[DOT_STACK_SIZE] ;
Xint dot_stack_top= -1 ;
X
XPROC duel_reset_eval(void)   /* reset evaluation states from previous eval */
X{
X  dot_stack_top= -1 ;   /* reset stack */
X}
X
X/* try to find the given name on the dot_stack of structures.
X * if found, return true and value in(v) else return false.
X * the symbolic value is not set.
X * if top_only, looks only at the top of the stack.
X */
XLFUNC bool find_dot_name(char *name,tvalue *v,bool top_only)
X{
X    int i,j ;
X    tctype_field *f ;
X    tctype *t ;
X    tvalue *x;
X
X    for(i=dot_stack_top ; i>=0 ; i--) {           /* look at the stack[i]    */
X        if(top_only && i!=dot_stack_top) break ;  /* consider only top of stk*/
X        x=dot_stack[i].realv ;
X        if(name[0]=='_' && name[1]==0 ||                           /* _ */
X           name[1]=='_' && i==dot_stack_top-1 && name[2]==0 ||     /* __ */
X           name[1]=='0'+dot_stack_top-i && name[2]==0) {           /* _[0-9] */
X            *v = *x ;
X            return TRUE ;
X        }
X        x=dot_stack[i].fieldv;
X        if(x->val_kind==VK_FVALUE) {
X            if(!duel_get_target_variable(name,x->u.fvalue,v)) continue ;
X            strcpy(v->symb_val,name);
X            return TRUE ;
X        }
X        if(!x) continue ;
X        t=x->ctype ;
X        if(!ctype_kind_struct_like(t)) continue ;
X        duel_assert(x->val_kind==VK_LVALUE);
X        for(j=0 ; j<t->u.f.fields_no ; j++) {  /* look at field[j] of struct*/
X            f= &t->u.f.fields[j] ;
X            if(strcmp(f->name,name)==0) goto found ;
X        }
X    }
X    return FALSE ;
Xfound:
X    v->ctype=f->ctype ;
X    strcpy(v->symb_val,name);
X    if(f->bitlen==0) {
X       v->u.lvalue=x->u.lvalue+f->bitpos/BITS_PER_BYTE ;
X       v->val_kind=VK_LVALUE ;
X       return TRUE ;
X   }
X   /* special care for a bitfield */
X   if(f->ctype->type_kind!=CTK_INT && f->ctype->type_kind!=CTK_UINT)
X       duel_gen_error("bitfield '%s' must be int or unsigned",name);
X    v->val_kind=VK_BVALUE ;
X    v->u.bvalue.lvalue=x->u.lvalue ;
X    v->u.bvalue.bitpos=f->bitpos ;
X    v->u.bvalue.bitlen=f->bitlen ;
X    return TRUE ;
X}
X
X/* find the value of a given symbolic name and
X * return in in v
X * if name is not found, aborts with an error
X */
X
XLPROC duel_eval_name(char *name,tvalue *v)
X{
X   tvalue *aval=duel_find_alias(name) ; /* find internal alias */
X   if(aval!=NULL) *v= *aval ;
X   else
X   if(find_dot_name(name,v,FALSE)) return ;   /* setup name itself */
X   else
X   if(duel_get_target_variable(name,-1,v));
X   else
X   if(strcmp(name,"frames_no")==0) {            /* check special variables */
X       v->val_kind=VK_RVALUE ;
X       v->ctype=ctype_int ;
X       v->u.rval_int=duel_get_frames_number();
X   }
X   else duel_gen_error("variable '%s' not found",name);
X   strcpy(v->symb_val,name);
X}
X
X
XLPROC push_val(tval_list *l,tvalue *v)
X{
X  tval_lcell *e = duel_malloc(sizeof(tval_lcell));
X  e->val = *v ;
X  e->next=l->head ;
X  l->head=e ;
X  if(l->tail==0) l->tail=e ;
X}
X
XLPROC append_val(tval_list *l,tvalue *v)
X{
X  tval_lcell *e=duel_malloc(sizeof(tval_lcell)) ;
X  e->val = *v ;
X  e->next=0 ;
X  if(l->head==0) l->head=l->tail=e ;
X  else     l->tail=l->tail->next=e ;
X}
X
X/* push a whole val-list(ins) into (l) i.e. insert (ins) at the head of(l)
X */
X
XLPROC push_val_list(tval_list *l,tval_list *ins)
X{
X  if(ins->head==NULL) return ;              /* inserted list is empty */
X  if(l->head==NULL) { *l= *ins ; return ; }  /* insert-into is empty */
X  ins->tail->next=l->head ;
X  l->head=ins->head ;
X}
X
X
X/* remove first(top) element */
XLFUNC bool pop_val(tval_list *l,tvalue *v)
X{
X  tval_lcell *e=l->head ;
X  if(e==0) return(FALSE);
X  *v=e->val ;
X  l->head=e->next ;
X  return(TRUE);
X}
X/* compute the symbolic value of one iteration of a search (eg -->) operator.
X * Normally, for (x) and (y) the result x->y  is returned.
X * But, if x === a-->next[[n]] and y === next, then we
X * return a-->next[[m]] where m=n+1.
X * Also, instead of returning x->y we return x-->y[[1]]
X *
X * note: this was not written for speed! I don't know if it takes
X * a significant amount of time or not.
X */
X
XLPROC set_search_symb_val(char *opcode,tvalue *xval,tvalue *yval)
X{
X    char *x = xval->symb_val ;
X    char *y = yval->symb_val ;
X    int i,opl=strlen(opcode),xl=strlen(x),yl=strlen(y) ;
X    char s[3*VALUE_MAX_SYMBOLIC_SIZE];
X
X    if(yl+2<xl && strcmp(x+xl-yl,y)==0 && x[xl-yl-2]=='-' && x[xl-yl-1]=='>')
X        sprintf(s,"%-.*s%s%s[[2]]",xl-yl-2,x,opcode,y);
X    else {
X    for(i=xl-1 ; i>0  ; i--)            /* see if we have op in x */
X        if(strncmp(&x[i],opcode,opl)==0) break ;
X    if(i>0 && strncmp(&x[i+opl],y,yl)==0 &&
X       x[i+opl+yl]=='[' && x[i+opl+yl+1]=='[' && x[xl-2]==']' && x[xl-1]==']'){
X        /* x seems to be something like  head-->next[1] */
X        int j,val=0 ;
X        for(j=i+opl+yl+2 ; j<xl-2 ; j++) {
X            if(x[j]<'0' || x[j]>'9') goto simple ;
X            val=10*val+x[j]-'0' ;       /* compute index */
X        }
X        sprintf(s,"%-.*s[[%d]]",i+opl+yl,x,val+1);   /* and re-create it */
X    }
X    else {
Xsimple:         /* we failed to find a x-->y[z] pattern, make new one */
X        sprintf(s,"%s->%s",x,y);
X    }
X   }
X   s[VALUE_MAX_SYMBOLIC_SIZE]=0 ; /* chop as needed */
X    strcpy(y,s);
X}
X
XLPROC push_dot_stack(tvalue *realv,tvalue *fieldv)
X{
X   if(dot_stack_top==DOT_STACK_SIZE)
X       duel_gen_error("expression too complex ('.' and '->' levels)",0);
X   dot_stack[++dot_stack_top].realv=realv ;
X   dot_stack[dot_stack_top].fieldv=fieldv ;
X}
X
XLPROC pop_dot_stack(void)
X{
X   duel_assert(dot_stack_top>=0);
X   dot_stack_top-- ;
X}
X
X/* a simple fetch of a field. used mainly when printing
X * v must be a struct with the given name field. value is returned in ret.
X * return false if name not found.
X */
X
XFUNC bool duel_get_dot_name(tvalue *v,char *name,tvalue *ret)
X{
X    bool ok ;
X    push_dot_stack(v,v);
X    ok=find_dot_name(name,ret,TRUE);
X    pop_dot_stack();
X    return ok ;
X}
X
X/* evaluate x.y and similar "with" operators. Special care when y is a
X * name and not an expression -- force y to be a direct field of x.
X * y is the 'y' node. v is value to return. op is opcode for error reports
X * (rv,fv) are values to push on the dot stack. rv is the real 'x' value,
X *         fv is the value of x to use for field lookup (fv= *rv for '->')
X */
X
XLFUNC bool eval_dot(tnode *y,tvalue *v,char *op,tvalue *rv,tvalue *fv)
X{
X   bool ok ;
X   push_dot_stack(rv,fv);
X   if(y->node_kind!=NK_NAME) ok=duel_eval(y,v);  /* "with" style */
X   else {                                        /* x.y y simply name */
X      if(++y->eval.level>1) { y->eval.level=0 ; ok=FALSE ; }
X      else {
X        ok=find_dot_name(y->name,v,TRUE);
X        if(!ok) duel_op_error("field not found in operator '%s'",op,rv,0);
X      }
X   }
X   pop_dot_stack();
X   return ok ;
X}
X
X
X/* evaluate special operators like '-->' '?:' etc */
X
X/* get the next result of an sop val:
X * DFS:  init by pushing(x)
X * Iterate: pop x, compute all x->y, push (reversed)
X * out: x
X
X * POS: init by pushing(x), unmarked.
X * Iterate: pop x, if marked return it. else push back, marked.
X *          compute all x->y, push (reversed)
X *          repeat until marked x is popped.
X * out: poped x which is marked.
X
X * BFS: init by pushing(x)
X * Iterate: get first(x),
X *      compute all x->y and put into queue.
X *      return x.
X */
X
X/* fetch the next value in a DFS search on x-->y. y is given as a node
X * and x is popped of the given list. Value is returned in v.
X * note: the results from x->y are reversed when pushed on the list,
X * this is so x-->(left,right) would return the left first (put last on
X * the stack, even though it is computed first!)
X * malloc problem: newl is kept locally, so in case of ^C while here, mem
X * it points to will be lost. Normally only a few values
X */
X
XLFUNC bool get_next_dfs_val(tval_list *l, tnode *y,tvalue *v)
X{
X   tvalue child,x ;
X   tval_list newl ;
X   newl.head=0 ;
X   do {
X       if(!pop_val(l,v)) return(FALSE) ;
X       x= *v ;
X       duel_get_struct_ptr_val(&x,"x-->y");
X   } while(x.u.lvalue==0) ;     /* ignore null pointers */
X   while(eval_dot(y,&child,"-->",v,&x)) {
X       set_search_symb_val("-->",&x,&child);  /* makes x-->y[n] neatly */
X       append_val(&newl,&child);                /* append to childs list */
X   }
X   push_val_list(l,&newl);              /* append new childs to stack */
X   return(TRUE);                        /* returns the popped value in v */
X}
X
X
X/* stop the evaluation of the expression at node n.
X * useful with operators like first().
X * each node keeps an internal state allowing it to produce the next value.
X * this function resets those states.
X *
X * How: the internal state is kept in n->eval.level. we reset level to zero
X *      for the node and the subnodes. if the level is already zero,
X *      the node has already gone to the 'initial state', so the subnodes
X *      are not visited.
X */
X
XLPROC stop_eval(tnode *n)
X{
X   int i;
X   if(n==NULL || n->eval.level==0) return ; /* done! subnodes are also ok */
X   n->eval.level=0 ;
X   for(i=0 ; i<NODE_MAX_KIDS ; i++) stop_eval(n->kids[i]);
X}
X
X/* evaluate function paramaters. This recursive function should be called
X * with the top node for the parms. Parms are parsed as "," operators.
X * the function leaves the computed values "hanging" on v1 of each node.
X */
X
XLFUNC bool eval_func_parms(tnode *n)
X{
X    tvalue *p = &n->eval.v1 ;
X    if(n->node_kind==NK_OP && n->op_kind==OPK_SBIN && n->op==',') {
X       while(n->eval.level==2 || duel_eval(n->kids[0],p)) {
X          n->eval.level=2 ;  /* left side active parm in p */
X          if(eval_func_parms(n->kids[1])) goto ok;
X          n->eval.level=1 ;   /*re-eval */
X       }
X       return FALSE ;
X   }
X   else if(!duel_eval(n,p)) return FALSE;  /* eval last paramater */
Xok:
X   duel_standardize_func_parm(p);
X   return TRUE ;
X}
X
XLFUNC bool eval_func_call(tnode *n,tvalue *v)
X{
X
X   tvalue *f= &n->eval.v1 ;
X   tvalue *parms[21];
X   int i,parms_no ;
X   tnode *p ;
X
Xagain:
X   if(n->kids[1]==NULL) {       /* no parms */
X       n->eval.level=1 ;
X       if(!duel_eval(n->kids[0],f)) return FALSE ;
X   }
X   else {
X      while(n->eval.level==2 || duel_eval(n->kids[0],f)) {
X        n->eval.level=2 ;  /* function in f */
X        if(eval_func_parms(n->kids[1])) goto ok;
X        n->eval.level=1 ;   /*re-eval func */
X      }
X      return FALSE ;
X    ok: ;
X   }
X
X   if(f->ctype->type_kind!=CTK_FUNC) duel_op_error("bad function call",0,f,0);
X
X   p=n->kids[1] ;                       /* collect paramaters now */
X   parms_no=0 ;
X   while(p && p->node_kind==NK_OP && p->op_kind==OPK_SBIN && p->op==',') {
X     parms[parms_no++]= &p->eval.v1 ;
X     p=p->kids[1] ;
X     if(parms_no>=20) duel_op_error("too many paramaters",0,0,0);
X   }
X   if(p) parms[parms_no++]= &p->eval.v1 ;       /* last paramater */
X
X   duel_target_func_call(f,parms,parms_no,v);
X   if(f->ctype->u.kid->type_kind==CTK_VOID) goto again ; /* no return vals */
X   duel_set_symb_val(v,"%s(",f,0);
X   for(i=0 ; i<parms_no ; i++)
X      duel_set_symb_val(v,"%s%s,",v,parms[i]);
X   if(parms_no>0) v->symb_val[strlen(v->symb_val)-1]='\0' ; /*chop ',' tail*/
X   strcat(v->symb_val,")");
X   return TRUE ;
X}
X
X
X/* evaluate for special operators: those the produce more than one value,
X * binary ones. ',' '..' etc
X */
X
XLFUNC bool duel_eval_sbin(tnode *n,tvalue *v)
X{
X   tval_list *vl = &n->eval.vlist ;
X   tvalue y,*v1= &n->eval.v1, *v2= &n->eval.v2 ;
X   tnode *kid0 = n->kids[0], *kid1 = n->kids[1] ;
X   int vi ;
X   bool ok ;
X#define lev n->eval.level
X
X   duel_assert(n->node_kind==NK_OP && n->op_kind==OPK_SBIN);
X   switch(n->op) {
X   case OP_DECL:
X           duel_assert(kid0->node_kind==NK_NAME && kid1->node_kind==NK_CTYPE);
X           if(kid1->ctype->size<=0) duel_gen_error("illegal type size",0);
X           v->val_kind=VK_LVALUE ;
X           v->ctype=kid1->ctype ;
X           v->u.lvalue=duel_alloc_target_space(kid1->ctype->size);
X           strcpy(v->symb_val,kid0->name);
X           duel_set_alias(kid0->name,v);
X   break ;
X   case OP_DEF:
X           if(kid0->node_kind!=NK_NAME)
X                duel_gen_error("left side of := must be a simple var",0);
X           if(!duel_eval(kid1,v)) return FALSE ;
X           duel_set_alias(kid0->name,v);
X           return TRUE ;
X   case ',':
X         if(lev==1 && duel_eval(kid0,v)) return TRUE ;
X         lev=2 ;
X         return duel_eval(kid1,v);
X   case ';':
X         /*note: (x;) is not allowed in syntax, but is allowed here and
X          *means eval x, return nothing. used by parser, e.g. terminating ';'
X          *produces no side effects
X          */
X
X         if(lev==1) while(duel_eval(kid0,v)) ; /* eval all left size */
X         lev=2 ;
X         return duel_eval(kid1,v);
X   break ;
X   case OP_IMP:  /* a=>b  for each _=eval(a) return eval(b) (with _ set) */
X             if(lev>1) goto im2 ;
X             for(;;) {
X                  if(!duel_eval(kid0,v1)) return FALSE ;
X                  lev=2 ;
X             im2: push_dot_stack(v1,0);
X                  ok=duel_eval(kid1,v);
X                  pop_dot_stack();
X                  if(ok) return TRUE ;
X             }
X   case OP_IF:  /* if(a) b  return eval(b) for each eval(a)!=0 */
X             if(lev>1) goto if2 ;
X             for(;;) {
X                  if(!duel_eval(kid0,v)) return FALSE ;
X                  if(!duel_mk_logical(v,"if(x)y")) continue ;
X                  lev=2 ;
X             if2: if(duel_eval(kid1,v)) return TRUE ;
X             }
X   case OP_OR:  /* a||b normal 'C' logical or */
X             if(lev>1) goto or2 ;
X             for(;;) {
X                  if(!duel_eval(kid0,v)) return FALSE ;
X                  if(duel_mk_logical(v,"x||y")) {lev=1 ; return TRUE ;}
X             or2: if(duel_eval(kid1,v)) {
X                    lev=2 ;
X                    duel_mk_logical(v,"y||x");
X                    return TRUE ;
X                  }
X             }
X   case OP_AND:  /* a&&b normal 'C' logical and */
X             if(lev>1) goto an2 ;
X             for(;;) {
X                  if(!duel_eval(kid0,v)) return FALSE ;
X                  if(!duel_mk_logical(v,"x&&y")) {lev=1 ; return TRUE ;}
X             an2: if(duel_eval(kid1,v)) {
X                    lev=2 ;
X                    duel_mk_logical(v,"y&&x");
X                    return TRUE ;
X                  }
X             }
X   case '.':
X             if(lev>1) goto dt2 ;
X             for(;;) {
X                  if(!duel_eval(kid0,v1)) return FALSE ;
X                  *v2 = * v1 ;  /* copy value for the lookup */
X                  if(ctype_kind_func_ptr_like(v1->ctype))  /* func.x */
X                      duel_find_func_frame(v2,"x.y");
X                  else
X                  if(v1->val_kind!=VK_FVALUE)  /* type check frame or struct*/
X                      duel_get_struct_val(v1,"x.y");
X                  lev=2 ;
X             dt2: if(!eval_dot(kid1,v,".",v1,v2)) continue ;
X                  if(v->ctype!=v->ctype || v1->val_kind!=v1->val_kind ||
X                     strcmp(v->symb_val,v1->symb_val)!=0) /* check for x._ */
X                      duel_set_symb_val(v,"%s.%s",v1,v);
X                  return TRUE ;
X             }
X   case OP_ARR:
X             if(lev>1) goto ar2 ;
X             for(;;) {
X                  if(!duel_eval(kid0,v1)) return FALSE ;
X                  *v2 = *v1 ;           /* copy value for dereferencing */
X                  duel_get_struct_ptr_val(v2,"x->y");
X                  lev=2 ;
X             ar2: if(!eval_dot(kid1,v,"->",v1,v2)) continue ;
X                  if(v->ctype!=v->ctype || v1->val_kind!=v1->val_kind ||
X                     strcmp(v->symb_val,v1->symb_val)!=0) /* check for x->_ */
X                      duel_set_symb_val(v,"%s->%s",v1,v);
X                  return TRUE ;
X             }
X   case OP_TO:  /* a..b  Is it legal to have 1..(5,6) sure! */
X         if(lev>1) goto to2 ;
X         do {
X             if(kid0 && !duel_eval(kid0,v1)) break ;
X             do {
X               if(kid1 && !duel_eval(kid1,v2)) break ;
X         to2:  if(duel_do_op_to(kid0? v1:0,kid1? v2:0,++lev-2,v)) return TRUE;
X             } while(kid1);
X         } while(kid0) ;  /* either one (kid0 null) or infinite iterations*/
X   break ;
X   case OP_SEL:          /* x[[y]] */
X           if(lev==1) { lev=2 ; n->eval.counter= -1 ; }
X           if(!duel_eval(kid1,v1)) {
X               stop_eval(kid0);
X               return FALSE ;
X           }
X           vi=duel_get_posint_val(v1,"y[[x]]");
X           if(vi<=n->eval.counter) {
X                   /* v is smaller than previous v value, so reset x and
X                    * start over. Example: \x[1,5,3] after \x[1],
X                    * we continue to get [5]. but to get [3] we reset
X                    * Alternatively, we could have kept a list of old
X                    * generated values.
X                    */
X               stop_eval(kid0) ;
X               n->eval.counter= -1 ;
X           }
X           for( ; n->eval.counter<vi ; n->eval.counter++)
X               if(!duel_eval(kid0,v))
X                   duel_op_error("operator x of y[[x]] too large",0,v1,0);
X           return TRUE ; /* value is the last (v) computed */
X   break ;
X   case '@':             /* x@y - generate x stops when y true */
X           if(!duel_eval(kid0,v)) return FALSE ;
X           if(kid1->node_kind==NK_CONST) {      /* special case y constant */
X               *v2=kid1->cnst ;
X               *v1= *v ;        /* because 'apply_bin_op' destroy its args */
X               duel_apply_bin_op(OP_EQ,v1,v2,&y);
X               if(y.u.rval_int) { stop_eval(kid0); return FALSE ; }
X               return TRUE ;
X           }
X           *v1 = *v ;           /* allow fields in y of x@y for x struct ptr */
X           if(ctype_kind_ptr_like(v->ctype) &&
X              ctype_kind_struct_like(v->ctype->u.kid))
X               duel_get_struct_ptr_val(v1,"x@y");
X
X           while(eval_dot(kid1,v2,"@",v,v1)) /* check &&/y */
X               if(!duel_mk_logical(v2,"y@x")) {  /* y==0, so dont stop x */
X                   stop_eval(kid1);
X                   return TRUE ;
X               }
X           stop_eval(kid0);
X    break ;
X    case '#':            /* x#i define variable i as counter for gen. x*/
X       if(kid1->node_kind!=NK_NAME)
X               duel_gen_error("x#y 2rd operand must be a name",0);
X       if(!duel_eval(kid0,v)) return FALSE ;
X       if(lev==1) { lev=2 ; n->eval.counter= -1 ; } /* first time */
X       y.val_kind=VK_RVALUE ;
X       y.ctype=ctype_int ;
X       y.u.rval_int= ++n->eval.counter ;
X       sprintf(y.symb_val,"%d",n->eval.counter);
X       duel_set_alias(kid1->name,&y);
X       return TRUE ;
X   break ;
X   case OP_DFS:          /* x-->y */
X       if(lev>1) goto df2 ;
X       for(;;) {
X            if(!duel_eval(kid0,v)) return FALSE ;
X            duel_free_val_list(vl);
X            push_val(vl,v);
X            lev=2 ;
X       df2: if(get_next_dfs_val(vl,kid1,v)) return TRUE ;
X       }
X   break ;
X   case OP_WHILE:       /* while(a) b  */
X             if(lev==2) goto wh2 ;
X             for(;;) {
X                  while(duel_eval(kid0,v)) /* check &&/a */
X                    if(!duel_mk_logical(v,"while(x)y")) {
X                       stop_eval(kid0);
X                       return FALSE ;
X                    }
X                  lev=2 ;
X             wh2: if(duel_eval(kid1,v)) return TRUE ;
X             }
X   default: duel_assert(0);
X   }
X   return FALSE ;
X#undef lev
X}
X
X
X
XLFUNC bool duel_eval_tri(tnode *n,tvalue *v)
X{
X#define lev n->eval.level
X   duel_assert(n->node_kind==NK_OP && n->op_kind==OPK_TRI);
X   switch(n->op) {
X   case OP_IF:  /* if(a) b else c return eval(b) for each eval(a)!=0
X                 * and eval(c) for each eval(a)==0 (usu. (a) is one result*/
X             if(lev>1) goto if2;
X             for(;;) {
X                   if(!duel_eval(n->kids[0],v)) return FALSE ;
X                   lev=(duel_mk_logical(v,"if(x) y else z")? 2:3) ;
X              if2: if(duel_eval(n->kids[lev-1],v)) return TRUE ;
X             }
X   case '?':    /* a? b:c has the same semantics as if(a) b else c */
X             if(lev>1) goto qm2;
X             for(;;) {
X                   if(!duel_eval(n->kids[0],v)) return FALSE ;
X                   lev=(duel_mk_logical(v,"x? y:z")? 2:3) ;
X              qm2: if(duel_eval(n->kids[lev-1],v)) return TRUE ;
X             }
X   default: duel_assert(0);
X   }
X   return FALSE ;
X#undef lev
X}
X
XLFUNC bool duel_eval_quad(tnode *n,tvalue *v)
X{
X#define lev n->eval.level
X   duel_assert(n->node_kind==NK_OP && n->op_kind==OPK_QUAD);
X   switch(n->op) {
X   case OP_FOR: /* for(a;b;c) d ;  */
X             if(lev==1) { lev=2 ; while(duel_eval(n->kids[0],v)); }
X             if(lev==3) goto fr3 ;
X             for(;;) {
X                  while(duel_eval(n->kids[1],v)) /* check &&/b */
X                    if(!duel_mk_logical(v,"for(a;x;y)z")) {
X                       stop_eval(n->kids[1]);
X                       return FALSE ;
X                    }
X                  lev=3 ;
X             fr3: if(duel_eval(n->kids[3],v)) return TRUE ;
X                  while(duel_eval(n->kids[2],v));
X             }
X   default: duel_assert(0);
X   }
X   return FALSE ;
X#undef lev
X}
X
XFUNC bool duel_eval(tnode *n,tvalue *v)
X{
X   tvalue u,tmp ;
X   bool ok=FALSE ;
X   tnode *prev_loc ;
X
X   if(!n) return FALSE ;
X   prev_loc=duel_set_eval_loc(n);        /* set current eval node, save prev */
X   if(n->eval.level==0) n->eval.level=1 ; /* indicate node is 'active' */
X
X   switch(n->node_kind) {
X      case NK_CONST: /* return a 'value' node made of this constant */
X         if(n->eval.level==1) {
X            n->eval.level=2 ;
X            *v=n->cnst ;
X            ok=TRUE ;
X         }
X      break ;
X      case NK_NAME:
X         if(n->eval.level==1) {
X            n->eval.level=2 ;
X            duel_eval_name(n->name,v);
X            ok=TRUE ;
X         }
X      break ;
X      case NK_OP:
X         switch(n->op_kind) {
X          case OPK_SUNARY:              /* special unary ops */
X             if(n->op=='#') {
X                 int count=0 ;
X                 if(n->eval.level==1) {
X                     while(duel_eval(n->kids[0],v)) count++ ;
X                     v->val_kind=VK_RVALUE ;
X                     v->ctype=ctype_int ;
X                     v->u.rval_int=count ;
X                     sprintf(v->symb_val,"%d",count);
X                     n->eval.level=2 ;
X                     ok=TRUE ;
X                 }
X             }
X             else
X             if(n->op==OP_AND) {
X                 if(n->eval.level==1) { int result=1 ;
X                     while(duel_eval(n->kids[0],v)) {
X                         if(!duel_mk_logical(v,"&&/x")) {
X                             stop_eval(n->kids[0]);
X                             result=0 ;
X                             break ;
X                         }
X                     }
X                     v->val_kind=VK_RVALUE ;
X                     v->ctype=ctype_int ;
X                     v->u.rval_int=result ;
X                     sprintf(v->symb_val,"%d",result);
X                     n->eval.level=2 ;
X                     ok=TRUE ;
X                 }
X             }
X             else
X             if(n->op==OP_OR) {
X                 if(n->eval.level==1) { int result=0 ;
X                     while(duel_eval(n->kids[0],v)) {
X                         if(duel_mk_logical(v,"||/x")) {
X                             stop_eval(n->kids[0]);
X                             result=1 ;
X                             break ;
X                         }
X                     }
X                     v->val_kind=VK_RVALUE ;
X                     v->ctype=ctype_int ;
X                     v->u.rval_int=result ;
X                     sprintf(v->symb_val,"%d",result);
X                     n->eval.level=2 ;
X                     ok=TRUE ;
X                 }
X             }
X             else
X             if(n->op==OP_SIZ) {
X                 if(n->eval.level==1) {
X                     duel_assert(n->kids[0]->node_kind==NK_CTYPE);
X                     v->val_kind=VK_RVALUE ;
X                     v->ctype=ctype_size_t ;
X                     v->u.rval_size_t=n->kids[0]->ctype->size ;
X                     n->eval.level=2 ;
X                     ok=TRUE ;
X                 }
X             }
X             else duel_assert(0);
X          break ;
X          case OPK_UNARY:
X            if(!duel_eval(n->kids[0],v)) break ;
X            duel_apply_unary_op(n->op,v);
X            ok=TRUE ;
X          break ;
X          case OPK_POST_UNARY:
X            if(!duel_eval(n->kids[0],v)) break ;
X            duel_apply_post_unary_op(n->op,v);
X            ok=TRUE ;
X          break ;
X          case OPK_BIN:    /* a+b, compute and hold a, iterate on b, redo a */
X             while(n->eval.level==2 || duel_eval(n->kids[0],&n->eval.v1)) {
X                n->eval.level=2 ;  /* left side active op in vals[0] */
X                while(duel_eval(n->kids[1],&u)) {
X                  tmp= n->eval.v1 ;  /* copy left val, it is destoryed*/
X                  ok=duel_apply_bin_op(n->op,&tmp,&u,v);
X                  if(ok) goto done;
X                }
X                n->eval.level=1 ;   /*left side val no longer valid, re-eval*/
X             }
X          break ;
X          case OPK_SBIN:   /* a,b etc, special ops */
X             ok=duel_eval_sbin(n,v) ;
X          break ;
X          case OPK_TRI:
X             ok=duel_eval_tri(n,v) ;
X          break ;
X          case OPK_QUAD:
X             ok=duel_eval_quad(n,v) ;
X          break ;
X          case OPK_CAST:
X             duel_assert(n->kids[0]->node_kind==NK_CTYPE);
X             if(!duel_eval(n->kids[1],v)) break ;
X             duel_do_cast(n->kids[0]->ctype,v);
X             ok=TRUE ;
X          break ;
X          case OPK_ASSIGN:
X             duel_gen_error("modified assignment is not supported yet",0);
X          case OPK_FUNC:
X             ok=eval_func_call(n,v) ;
X          break ;
X          default: duel_assert(0);
X         }
X      break ;
X      default: duel_assert(0);
X   }
Xdone:
X   if(!ok) n->eval.level=0 ;  /* no other val available */
X   duel_set_eval_loc(prev_loc);
X   return ok ;
X}
X
X
SHAR_EOF
$TOUCH -am 0113165193 src/eval.c &&
chmod 0644 src/eval.c ||
echo "restore of src/eval.c failed"
set `wc -c src/eval.c`;Wc_c=$1
if test "$Wc_c" != "27680"; then
    echo original size 27680, current size $Wc_c
fi
echo "End of part 4, continue with part 5"
exit 0