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

Text File | 1993-01-23 | 49.5 KB | 1,348 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 5/6
Message-ID: <[e-mail]>
Sender: [e-mail] (USENET News System)
Organization: Department of Computer Science, Princeton University
Date: Fri, 22 Jan 1993 03:48:06 GMT
Lines: 1337

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

#!/bin/sh
# This is part 05 of duel
if touch 2>&1 | fgrep 'amc' > /dev/null
 then TOUCH=touch
 else TOUCH=true
fi
# ============= src/evalops.c ==============
echo "x - extracting src/evalops.c (Text)"
sed 's/^X//' << 'SHAR_EOF' > src/evalops.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/evalops.c,v 1.8 93/01/12 21:51:29 mg Exp $*/
X
X/* this module contains evalauation code for many standard operators, eg '+'
X */
X
X/*
X * $Log:    evalops.c,v $
X * Revision 1.8  93/01/12  21:51:29  mg
X * cleanup and set for release
X *
X * Revision 1.7  93/01/07  00:10:51  mg
X * auto convert func to &func
X * find a frame for a func
X *
X *
X * Revision 1.6  93/01/03  07:30:02  mg
X * function calls, error reporting, printing.
X *
X * Revision 1.5  92/12/24  23:34:47  mg
X * frames support
X *
X * Revision 1.4  92/10/19  15:07:46  mg
X * fvalue added (not ready yet), svalues dropped
X *
X * Revision 1.3  92/10/14  02:05:10  mg
X * add print/{x} support
X *
X * Revision 1.2  92/09/15  05:48:57  mg
X * support '..' new formats
X *
X */
X
X#include "duel.h"
X
X/*
X * This file is made up of three parts:
X * (1) low-level functions that interact with the debugger/type system directly
X * (2) mid-level functions that compute the result of simple operators like '+'
X * (3) high-level functions that compute any binary/unary op.
X * Only some of the functions in (1) are global, and all of the (3) are.
X * this collection is in one file to allow a minimal of global symbols
X * (for minimum collision with the debugger)
X */
X
X
X
X/****************************************************************************
X A low-level set of functions follows. They interact with the type system
X and the debugger/target's space directly:
X get_storage_type_kind - retrieve ctype_kind, with special conversion for enums
X get_rvalue - retrieve the rvalue of a variable/lvalue.
X set_symb_val - set the symbolic value of a tvalue.
X upgrade_small_int_types - figure out the type to upgrade to from char etc.
X find_numeric_result_type - figure type of x+y where + is generic C op
X convert_scalar_type - convert one scalar type to another
X get_numeric_val - retrieve rvalue, making sure it is numeric
X get_scalar_val  - retrieve rvalue, making sure it is numeric or pointer
X get_integral_val- retrieve rvalue, making sure it is an integer
X get_int_val     - retrieve rvalue, make sure it's an integer, return int val
X get_pointer_val - retrieve rvalue, make sure it's a pointer.
X ****************************************************************************/
X
X/* give the storage-type kind of a given type.
X * this is the same type-kind as the type itslef, except in the case of enums
X * where the type-kind of the storage will be CTK_INT etc (integral type)
X * the storage type kind is set when the enum is created.
X */
X
XLFUNC tctype_kind get_storage_type_kind(tctype *t)
X{
X    if(t->type_kind!=CTK_ENUM) return t->type_kind ;
X    return t->u.e.real_type_kind ;
X}
X
X/* try_get_rvalue -- make an rvalue of v. if v is already an rvalue,
X * nothing is done. Else v is an b/lvalue, so its rvalue is fetched.
X * special care:
X * (1) Enums are fetched as int of same size. type stay enum!
X * (2) Arrays and functions are made into pointers
X * (3) Bitfields are converted to ints (debugger dependent)
X *     there are no rvalues of 'bitfield' type!
X * return succ/fail for bad mem ref. the "real" function everyone calls is
X * get_rvalue (this function is used only by printing functions to avoid
X * chicken&egg problem of error reporting.)
X */
X
XFUNC duel_try_get_rvalue(tvalue *v,char *op)
X{
X   void *p ;
X   int n ;
X   bool ok;
X   if(v->val_kind == VK_RVALUE) return TRUE;
X   if(v->val_kind == VK_FVALUE)
X       duel_op_error("illegal type 'frame' for operand x of '%s'",op,v,0);
X   switch(get_storage_type_kind(v->ctype)) {
X      case CTK_CHAR:    p= &v->u.rval_char   ; n=sizeof(char)         ;break ;
X      case CTK_UCHAR:   p= &v->u.rval_uchar  ; n=sizeof(uchar)        ;break ;
X      case CTK_USHORT:  p= &v->u.rval_ushort ; n=sizeof(ushort)       ;break ;
X      case CTK_SHORT:   p= &v->u.rval_short  ; n=sizeof(short)        ;break ;
X      case CTK_INT:     p= &v->u.rval_int    ; n=sizeof(int)          ;break ;
X      case CTK_UINT:    p= &v->u.rval_uint   ; n=sizeof(uint)         ;break ;
X      case CTK_LONG:    p= &v->u.rval_long   ; n=sizeof(long)         ;break ;
X      case CTK_ULONG:   p= &v->u.rval_ulong  ; n=sizeof(ulong)        ;break ;
X      case CTK_FLOAT:   p= &v->u.rval_float  ; n=sizeof(float)        ;break ;
X      case CTK_DOUBLE:  p= &v->u.rval_double ; n=sizeof(double)       ;break ;
X      case CTK_PTR:     p= &v->u.rval_ptr    ; n=sizeof(ttarget_ptr) ;break ;
X      case CTK_ARRAY:   /* the lvalue becomes an rvalue, a real pointer! */
X                 duel_assert(v->val_kind==VK_LVALUE); /* duel exp rules */
X                 v->val_kind=VK_RVALUE ;
X                 v->ctype=duel_mkctype_ptr(v->ctype->u.kid) ;
X                 v->u.rval_ptr=v->u.lvalue ;
X                 return TRUE;
X      case CTK_FUNC:   /* makes it a pointer to a func*/
X                 duel_assert(v->val_kind==VK_LVALUE); /* duel exp rules */
X                 v->val_kind=VK_RVALUE ;
X                 v->ctype=duel_mkctype_ptr(v->ctype) ;
X                 v->u.rval_ptr=v->u.lvalue ;
X                 return TRUE;
X
X      case CTK_STRUCT: /* can't have an rval from struct? */
X      case CTK_UNION:
X      /* enums were eliminated above */
X      default: duel_assert(0);
X   }
X   if(v->val_kind == VK_BVALUE) {        /* bitfield: lvalue+bitpos/len */
X       tbvalue_info bv;
X       bv=v->u.bvalue ;
X       ok=duel_get_target_bitfield(bv.lvalue, bv.bitpos, bv.bitlen, p,
X                                    v->ctype->type_kind);
X       if(!ok) { v->u.bvalue=bv ; return FALSE ; }
X   }
X   else {
X       ttarget_ptr lv=v->u.lvalue ;
X       ok=duel_get_target_bytes(lv,p,n); /*fetch n debuggee bytes*/
X       if(!ok) { v->u.lvalue=lv ; return FALSE ; }
X   }
X
X   v->val_kind=VK_RVALUE ;
X   /* in remote debugging, one might need to swap byte order at this
X    * point. [remote debugging is not supported by duel v1.0]
X    */
X   return TRUE ;
X}
X
X
X/*
X * safe get_rvalue - produce error messages on memory access failer.
X */
X
XLPROC get_rvalue(tvalue *v,char *op)
X{
X   bool ok=duel_try_get_rvalue(v,op);
X   if(!ok) duel_op_error("illegal address for operand x of '%s'",op,v,0);
X}
X
X/* put_rvalue: put the rvalue of v2 into the location in v1.
X * types are assumed to be the same.
X */
X
XLPROC put_rvalue(tvalue *v1,tvalue *v2,char *op)
X{
X   void *p ;
X   int n ;
X   duel_assert(v1->val_kind!=VK_RVALUE);
X   duel_assert(v1->val_kind!=VK_FVALUE);
X   duel_assert(v2->val_kind==VK_RVALUE);
X   duel_assert(v1->ctype->size == v2->ctype->size);
X   switch(get_storage_type_kind(v2->ctype)) {
X      case CTK_CHAR:    p= &v2->u.rval_char   ; n=sizeof(char)         ;break ;
X      case CTK_UCHAR:   p= &v2->u.rval_uchar  ; n=sizeof(uchar)        ;break ;
X      case CTK_USHORT:  p= &v2->u.rval_ushort ; n=sizeof(ushort)       ;break ;
X      case CTK_SHORT:   p= &v2->u.rval_short  ; n=sizeof(short)        ;break ;
X      case CTK_INT:     p= &v2->u.rval_int    ; n=sizeof(int)          ;break ;
X      case CTK_UINT:    p= &v2->u.rval_uint   ; n=sizeof(uint)         ;break ;
X      case CTK_LONG:    p= &v2->u.rval_long   ; n=sizeof(long)         ;break ;
X      case CTK_ULONG:   p= &v2->u.rval_ulong  ; n=sizeof(ulong)        ;break ;
X      case CTK_FLOAT:   p= &v2->u.rval_float  ; n=sizeof(float)        ;break ;
X      case CTK_DOUBLE:  p= &v2->u.rval_double ; n=sizeof(double)       ;break ;
X      case CTK_PTR:     p= &v2->u.rval_ptr    ; n=sizeof(ttarget_ptr) ;break ;
X      default: duel_assert(0);  /* other types not supported as rvalues */
X   }
X   if(v1->val_kind == VK_BVALUE)
X       duel_gen_error("assignment to bitfields is not yet supported",0);
X   else
X   if(!duel_put_target_bytes(v1->u.lvalue,p,n)) /*store n debuggee bytes*/
X       duel_op_error("cant write memory for operand x of '%s'",op,v1,0);
X}
X
X/* set the symbolic val for tvalue. input format is a sprintf,
X * with v1,v2 being other values that show as '%s' in the format.
X * v1,v2 can be zero if they are unused by the format.
X */
XPROC duel_set_symb_val(tvalue *r,char *format,tvalue *v1,tvalue *v2)
X{
X   char s[3*VALUE_MAX_SYMBOLIC_SIZE];
X   sprintf(s,format,v1->symb_val,v2->symb_val);
X   s[VALUE_MAX_SYMBOLIC_SIZE]=0 ; /* chop as needed */
X   strcpy(r->symb_val,s);
X}
X
X/* given a small int type (short,char,enum) return the upgraded (int or
X * uint) type. Else return the original type
X */
XLFUNC tctype* upgrade_small_int_types(tctype *t)
X{
X   switch(t->type_kind) {
X      case CTK_ENUM:
X      case CTK_CHAR:
X      case CTK_UCHAR:
X      case CTK_SHORT:
X                     return ctype_int ;
X      case CTK_USHORT:
X                     if(sizeof(ushort)==sizeof(int)) return ctype_uint ;
X                     else return ctype_int ;
X        default:
X                      return t ;
X   }
X}
X
X/* find the type of the result of a generic numeric operation on
X * v1,v2. This applies the standard C type upgrade rules.
X * The type of the result is returned.
X * r is setup so it can receive the result: an RVALUE of the specified
X * type. Its symbolic value is also setup based on the symbolic value
X * of v1 v2 and the operation op.
X * Note: op is not used to figure out the numeric result, only
X * the types of v1 and v2. As a side effect, the answer for x|y where
X * y is a double will be given as double. it is up to the caller to
X * verify that v1,v2 have meaningful types of this operation
X *
X */
X
XLFUNC tctype* find_numeric_result_type(tvalue *v1,tvalue *v2,
X                                          tvalue *r,char *op)
X{
X    tctype *t1=upgrade_small_int_types(v1->ctype);   /* upgrade to int etc */
X    tctype *t2=upgrade_small_int_types(v2->ctype);
X    char s[80] ;
X    r->val_kind=VK_RVALUE ;
X    sprintf(s,"%%s%s%%s",op) ;  /* eg, if op=">>" then s becomes "%s>>%s" */
X    duel_set_symb_val(r,s,v1,v2);
X
X    if(t1==ctype_double || t2==ctype_double) return r->ctype=ctype_double ;
X    if(t1==ctype_float  || t2==ctype_float)  return r->ctype=ctype_float ;
X    if(t1==ctype_ulong  || t2==ctype_ulong)  return r->ctype=ctype_ulong ;
X    if(sizeof(unsigned)==sizeof(long) &&
X       (t1==ctype_long && t2==ctype_uint  ||
X        t1==ctype_uint && t2==ctype_long))    return r->ctype=ctype_ulong ;
X    if(t1==ctype_long  || t2==ctype_long)     return r->ctype=ctype_long ;
X    if(t1==ctype_uint  || t2==ctype_uint)     return r->ctype=ctype_uint ;
X    return r->ctype=ctype_int ;
X}
X
X/* convert_to_fix assisting-macro: takes the val stored in v and put it
X * into w. w is an lvalue with a 'fixed' type (t).
X */
X
X#define convert_to_fix(v,w)                          \
X     switch(get_storage_type_kind(v->ctype)) {         \
X      case CTK_CHAR:    w v->u.rval_char     ; break ; \
X      case CTK_UCHAR:   w v->u.rval_uchar    ; break ; \
X      case CTK_USHORT:  w v->u.rval_ushort   ; break ; \
X      case CTK_SHORT:   w v->u.rval_short    ; break ; \
X      case CTK_INT:     w v->u.rval_int      ; break ; \
X      case CTK_UINT:    w v->u.rval_uint     ; break ; \
X      case CTK_LONG:    w v->u.rval_long     ; break ; \
X      case CTK_ULONG:   w v->u.rval_ulong    ; break ; \
X      case CTK_FLOAT:   w v->u.rval_float    ; break ; \
X      case CTK_DOUBLE:  w v->u.rval_double   ; break ; \
X      case CTK_PTR:     w (tptrsize_int) v->u.rval_ptr ; break ; \
X      default: duel_assert(0);                         \
X   }
X
X
X/* convert_scalar_type -- convert rvalue v to type t.
X * uses convert_to_fix macro. In effect, this is a huge switch for
X * all possible combinations of basic C types.
X */
X
XLPROC convert_scalar_type(tvalue *v,tctype *t,char *op)
X{
X   get_rvalue(v,op);
X   switch(get_storage_type_kind(t)) {
X      case CTK_CHAR:   convert_to_fix(v,v->u.rval_char=(char))     ; break ;
X      case CTK_UCHAR:  convert_to_fix(v,v->u.rval_uchar=(uchar))   ; break ;
X      case CTK_SHORT:  convert_to_fix(v,v->u.rval_short=(short))   ; break ;
X      case CTK_USHORT: convert_to_fix(v,v->u.rval_ushort=(ushort)) ; break ;
X      case CTK_INT:    convert_to_fix(v,v->u.rval_int=(int))       ; break ;
X      case CTK_UINT:   convert_to_fix(v,v->u.rval_uint=(uint))     ; break ;
X      case CTK_LONG:   convert_to_fix(v,v->u.rval_long=(long))     ; break ;
X      case CTK_ULONG:  convert_to_fix(v,v->u.rval_ulong=(ulong))   ; break ;
X      case CTK_FLOAT:  convert_to_fix(v,v->u.rval_float=(float))   ; break ;
X      case CTK_DOUBLE: convert_to_fix(v,v->u.rval_double=(double)) ; break ;
X      case CTK_PTR:    convert_to_fix(v,
X                        v->u.rval_ptr=(ttarget_ptr)(tptrsize_int)) ; break ;
X      default: duel_assert(0);
X   }
X   v->ctype=t ;
X}
X
X
X/* verify v is numeric, get its rvalue converted to type tout or at least int*/
XLPROC get_numeric_val(tvalue *v,char *op,tctype *tout)
X{
X   if(!ctype_kind_numeric(v->ctype))
X       duel_op_error("operand x of '%s' is not numeric",op,v,0);
X   if(!tout) tout=upgrade_small_int_types(v->ctype);   /* upgrade to int etc */
X   convert_scalar_type(v,tout,op);
X}
X
X/*verify v is integral, get its rvalue converted to type tout or at least int*/
XLPROC get_integral_val(tvalue *v,char *op,tctype *tout)
X{
X   if(!ctype_kind_integral(v->ctype))
X       duel_op_error("operand x of '%s' is not integral",op,v,0);
X   if(!tout) tout=upgrade_small_int_types(v->ctype);   /* upgrade to int etc */
X   convert_scalar_type(v,tout,op);
X}
X
X/* verify v is integral, return its actual value as 'int' */
XFUNC int duel_get_int_val(tvalue *v,char *op)
X{
X   get_integral_val(v,op,ctype_int);
X   return v->u.rval_int ;
X}
X
X/* verify v is numeric or pointer/array, upgrade type to at least int or ptr
X   and get the rvalue */
XLPROC get_scalar_val(tvalue *v,char *op)
X{
X   if(ctype_kind_ptr_like(v->ctype)) get_rvalue(v,op);
X   else {
X       tctype *t=upgrade_small_int_types(v->ctype);   /* upgrade to int */
X       if(!ctype_kind_numeric(v->ctype))
X           duel_op_error("operand x of '%s' is not a scalar",op,v,0);
X       convert_scalar_type(v,t,op);
X   }
X}
X
XLPROC get_pointer_val(tvalue *v,char *op,bool zero_ok)
X{
X   if(ctype_kind_ptr_like(v->ctype)) get_rvalue(v,op);
X   else
X   if(zero_ok && v->ctype->type_kind==CTK_INT &&
X      v->val_kind==VK_RVALUE && v->u.rval_int==0) {
X           v->ctype=ctype_voidptr ;
X           v->u.rval_ptr=0 ;
X   }
X   else duel_op_error("operand x of '%s' is not a pointer",op,v,0);
X}
X
X/* copy one lvalue over the other. This copy is used for assignment,
X * including the assignment of structures and unions.
X * supports unlimited size and error reports when memory access fails.
X */
X
XLPROC copy_lvalues(tvalue *v1,tvalue *v2,char *op)
X{
X    size_t size ;
X    ttarget_ptr to=v1->u.lvalue,from=v2->u.lvalue ;
X    char buf[BUFSIZ] ;
X    duel_assert(v1->val_kind==VK_LVALUE && v2->val_kind==VK_LVALUE);
X    size=v1->ctype->size ;
X    duel_assert(v2->ctype->size==size);
X    while(size!=0) {
X        size_t chunk_size=((size>BUFSIZ)? BUFSIZ:size) ;
X        if(!duel_get_target_bytes(from,buf,chunk_size))
X            duel_op_error("error reading memory (copy) in '%s'",op,v1,v2);
X        if(!duel_put_target_bytes(to,buf,chunk_size))
X            duel_op_error("error writing memory (copy) in '%s'",op,v1,v2);
X        size-=chunk_size ;
X        to+=chunk_size ;
X        from+=chunk_size ;
X    }
X}
X
X/*
X * check that two values have "compatible" types.
X * since structs compiled in different modules are each unique,
X * we settle for comparing the number of references (array/ptr)
X * and then  make sure the same type-kind is used, with the same
X * physical size.
X * this allows, e.g. struct {short x,y }  and struct {int x}
X * to be considered equal. Possibly one could compare struct/union
X * for member sizes (but not names?!). this however requires to keep
X * track of self references and is not implemented here.
X */
X
XLPROC duel_check_type_eq(tvalue *v1,tvalue *v2,char *op)
X{
X    tctype *t1=v1->ctype, *t2=v2->ctype ;
X    if(t1==ctype_voidptr && ctype_kind_ptr_like(t2) ||
X       t2==ctype_voidptr && ctype_kind_ptr_like(t1) ) return; /*(void*) match*/
X
X    while(ctype_kind_ptr_like(t1) && ctype_kind_ptr_like(t2))
X        t1=t1->u.kid, t2=t2->u.kid ;
X    if(t1==t2) return ; /* exact same type */
X    if(t1->type_kind != t2->type_kind || t1->size != t2->size)
X        duel_op_error("incompatible types for op %s",op,v1,v2);
X}
X
X
X/**************************************************************************
X a set of mid-level functions follow. These actually apply duel/C
X operators to values
X **************************************************************************/
X
X/* these do pointer+int addition/subtraction of v1,v2 and store result in r.
X * NOTE: r's symbolic value is not set.
X */
X
XLPROC add_offset_to_ptr(tvalue *v1,tvalue *v2,tvalue *r)
X{
X   size_t len ;
X   get_pointer_val(v1,"x+y (ptr add)",FALSE);
X   get_integral_val(v2,"y+x (ptr add)",NULL);
X   r->val_kind=VK_RVALUE ;
X   r->ctype=v1->ctype ;
X   len=v1->ctype->u.kid->size ;
X   if(len==0) duel_op_error("unknown pointer object size for '+' op",0,v1,0);
X   switch(v2->ctype->type_kind) {
X    case CTK_INT:   r->u.rval_ptr =v1->u.rval_ptr +len*v2->u.rval_int  ;break ;
X    case CTK_UINT:  r->u.rval_ptr =v1->u.rval_ptr +len*v2->u.rval_uint ;break ;
X    case CTK_LONG:  r->u.rval_ptr =v1->u.rval_ptr +len*v2->u.rval_long ;break ;
X    case CTK_ULONG: r->u.rval_ptr =v1->u.rval_ptr +len*v2->u.rval_ulong;break ;
X    default: duel_assert(0);
X   }
X}
X
XLPROC sub_offset_from_ptr(tvalue *v1,tvalue *v2,tvalue *r)
X{
X   size_t len ;
X   get_pointer_val(v1,"x-y (ptr sub)",FALSE);
X   get_integral_val(v2,"y-x (ptr sub)",NULL);
X   r->val_kind=VK_RVALUE ;
X   r->ctype=v1->ctype ;
X   len=v1->ctype->u.kid->size ;
X   if(len==0) duel_op_error("unknown pointer object size for '-' op",0,v1,0);
X   switch(v2->ctype->type_kind) {
X    case CTK_INT:   r->u.rval_ptr =v1->u.rval_ptr -len*v2->u.rval_int  ;break ;
X    case CTK_UINT:  r->u.rval_ptr =v1->u.rval_ptr -len*v2->u.rval_uint ;break ;
X    case CTK_LONG:  r->u.rval_ptr =v1->u.rval_ptr -len*v2->u.rval_long ;break ;
X    case CTK_ULONG: r->u.rval_ptr =v1->u.rval_ptr -len*v2->u.rval_ulong;break ;
X    default: duel_assert(0);
X   }
X}
X
X
X/* do addition of v1,v2 and store result in r.
X * NOTE: v1, v2 are destroyed!
X */
XLPROC do_op_add(tvalue *v1,tvalue *v2,tvalue *r)
X{
X   tctype *t=find_numeric_result_type(v1,v2,r,"+");
X   if(ctype_kind_ptr_like(v1->ctype)) {
X       get_integral_val(v2,"pointer+x",NULL);
X       add_offset_to_ptr(v1,v2,r);
X       return ;
X   }
X   if(ctype_kind_ptr_like(v2->ctype)) {
X       get_integral_val(v1,"x+pointer",NULL);
X       add_offset_to_ptr(v2,v1,r);
X       return ;
X   }
X   get_numeric_val(v1,"x+y",t);
X   get_numeric_val(v2,"y+x",t);
X   r->val_kind=VK_RVALUE ;
X   r->ctype=t ;
X   duel_set_symb_val(r,"%s+%s",v1,v2);
X   switch(t->type_kind) {
X    case CTK_INT:   r->u.rval_int  =v1->u.rval_int   +v2->u.rval_int   ;break ;
X    case CTK_UINT:  r->u.rval_uint =v1->u.rval_uint  +v2->u.rval_uint  ;break ;
X    case CTK_LONG:  r->u.rval_long =v1->u.rval_long  +v2->u.rval_long  ;break ;
X    case CTK_ULONG: r->u.rval_ulong=v1->u.rval_ulong +v2->u.rval_ulong ;break ;
X    case CTK_FLOAT: r->u.rval_float=v1->u.rval_float +v2->u.rval_float ;break ;
X    case CTK_DOUBLE:r->u.rval_double=v1->u.rval_double+v2->u.rval_double;break;
X    default: duel_assert(0);
X   }
X}
X
X/* do arithmeric subtraction of v1,v2 and store result in r.
X * v1 and v2 should be of numeric type to begin with.
X * NOTE: v1, v2 are destroyed!
X */
XLPROC do_op_subtract(tvalue *v1,tvalue *v2,tvalue *r)
X{
X   tctype *t=find_numeric_result_type(v1,v2,r,"-");
X   if(ctype_kind_ptr_like(v1->ctype)) {
X       if(ctype_kind_ptr_like(v2->ctype)) {
X           long len ;   /* length must be signed to allow signed p-q result*/
X           get_pointer_val(v1,"x-y",FALSE);
X           get_pointer_val(v2,"x-y",FALSE);
X           duel_check_type_eq(v1,v2,"- (ptr)");
X           /* should compare pointer types */
X           len=v1->ctype->u.kid->size ;
X           if(len<=0)
X              duel_op_error("illegal object size for op %s","- (ptr)",v1,v2);
X           r->ctype=ctype_ptrdiff_t ;
X           r->u.rval_ptrdiff_t= (v1->u.rval_ptr - v2->u.rval_ptr)/len ;
X           return ;
X       }
X       get_integral_val(v2,"pointer-x",NULL);
X       sub_offset_from_ptr(v1,v2,r);
X       return ;
X   }
X   get_numeric_val(v1,"x-y",t);
X   get_numeric_val(v2,"y-x",t);
X   switch(t->type_kind) {
X    case CTK_INT:   r->u.rval_int  =v1->u.rval_int   - v2->u.rval_int   ;break;
X    case CTK_UINT:  r->u.rval_uint =v1->u.rval_uint  - v2->u.rval_uint  ;break;
X    case CTK_LONG:  r->u.rval_long =v1->u.rval_long  - v2->u.rval_long  ;break;
X    case CTK_ULONG: r->u.rval_ulong=v1->u.rval_ulong - v2->u.rval_ulong ;break;
X    case CTK_FLOAT: r->u.rval_float=v1->u.rval_float - v2->u.rval_float ;break;
X    case CTK_DOUBLE:r->u.rval_double=v1->u.rval_double-v2->u.rval_double;break;
X    default: duel_assert(0);
X   }
X}
X
X/* compare values of v1 and v2, knowing that at least one is a frame-value
X * type. Allows two fvals to be compared, or an fval to be compared
X * to a func (this compares the func at the frame to the given func)
X */
X
XLFUNC bool comp_bin_op_eq_fvals(tvalue *v1,tvalue *v2)
X{
X   bool v1f=v1->val_kind == VK_FVALUE ;
X   bool v2f=v2->val_kind == VK_FVALUE ;
X   int frame_no ;
X   ttarget_ptr frame_func,p ;
X   if(v1f && v2f) return v1->u.fvalue == v2->u.fvalue ; /*cmp frames */
X   if(v1f) {
X       frame_no = v1->u.fvalue ;
X       get_pointer_val(v2,"frame==x",FALSE) ;
X       if(v2->ctype->u.kid->type_kind!=CTK_FUNC)
X          duel_op_error("operand x of 'frame=x' not a func pointer",0,v2,0);
X       p=v2->u.rval_ptr ;
X   }
X   else {
X       frame_no = v2->u.fvalue ;
X       get_pointer_val(v1,"x==frame",FALSE) ;
X       if(v1->ctype->u.kid->type_kind!=CTK_FUNC)
X          duel_op_error("operand x of 'x==frame' not a func pointer",0,v1,0);
X       p=v1->u.rval_ptr ;
X   }
X   frame_func = duel_get_function_for_frame(frame_no);
X   return frame_func == p ;
X}
X
X
X/* compares of v1,v2 and store result in r.
X * v1 and v2 should be of numeric/pointer type to begin with.
X * NOTE: v1, v2 are destroyed!
X */
X
XLPROC do_op_eq(tvalue *v1,tvalue *v2,tvalue *r)
X{
X   tctype *t=find_numeric_result_type(v1,v2,r,"==");
X   r->ctype=ctype_int ;
X   if(v1->val_kind==VK_FVALUE || v2->val_kind==VK_FVALUE) {
X       r->u.rval_int = comp_bin_op_eq_fvals(v1,v2);
X       return ;
X   }
X   if(ctype_kind_ptr_like(v1->ctype) || ctype_kind_ptr_like(v2->ctype)) {
X       get_pointer_val(v1,"x==y",TRUE);
X       get_pointer_val(v2,"y==x",TRUE);
X       duel_check_type_eq(v1,v2,"==");
X       r->u.rval_int = v1->u.rval_ptr == v2->u.rval_ptr ;
X       return ;
X   }
X   get_numeric_val(v1,"x==y",t);
X   get_numeric_val(v2,"y==x",t);
X   switch(t->type_kind) {
X   case CTK_INT:   r->u.rval_int=v1->u.rval_int    == v2->u.rval_int   ;break;
X   case CTK_UINT:  r->u.rval_int=v1->u.rval_uint   == v2->u.rval_uint  ;break;
X   case CTK_LONG:  r->u.rval_int=v1->u.rval_long   == v2->u.rval_long  ;break;
X   case CTK_ULONG: r->u.rval_int=v1->u.rval_ulong  == v2->u.rval_ulong ;break;
X   case CTK_FLOAT: r->u.rval_int=v1->u.rval_float  == v2->u.rval_float ;break;
X   case CTK_DOUBLE:r->u.rval_int=v1->u.rval_double == v2->u.rval_double;break;
X   default: duel_assert(0);
X   }
X}
X
X
X/* compares of v1,v2 and store result in r.
X * v1 and v2 should be of numeric/pointer type to begin with.
X * NOTE: v1, v2 are destroyed!
X */
X#define mk_func_compare(func,op,sop,xysop,yxsop,nullok) \
XLPROC func(tvalue *v1,tvalue *v2,tvalue *r)                    \
X{                                                              \
X   tctype *t=find_numeric_result_type(v1,v2,r,sop);             \
X   r->ctype=ctype_int ;                                         \
X                                                                \
X   if(ctype_kind_ptr_like(v1->ctype) || ctype_kind_ptr_like(v2->ctype)) { \
X       get_pointer_val(v1,xysop,nullok);                        \
X       get_pointer_val(v2,yxsop,nullok);                        \
X       duel_check_type_eq(v1,v2,sop);                           \
X       r->u.rval_int = v1->u.rval_ptr op v2->u.rval_ptr ;       \
X       return ;                                                 \
X   }                                                            \
X   get_numeric_val(v1,xysop,t);                                 \
X   get_numeric_val(v2,yxsop,t);                                 \
X   switch(t->type_kind) {                                       \
X   case CTK_INT:   r->u.rval_int=v1->u.rval_int    op v2->u.rval_int   ;break;\
X   case CTK_UINT:  r->u.rval_int=v1->u.rval_uint   op v2->u.rval_uint  ;break;\
X   case CTK_LONG:  r->u.rval_int=v1->u.rval_long   op v2->u.rval_long  ;break;\
X   case CTK_ULONG: r->u.rval_int=v1->u.rval_ulong  op v2->u.rval_ulong ;break;\
X   case CTK_FLOAT: r->u.rval_int=v1->u.rval_float  op v2->u.rval_float ;break;\
X   case CTK_DOUBLE:r->u.rval_int=v1->u.rval_double op v2->u.rval_double;break;\
X   default: duel_assert(0);                                     \
X   }                                                            \
X}
X
Xmk_func_compare(do_op_ne,!=,"!=","x!=y","y!=x",TRUE)
Xmk_func_compare(do_op_ge,>=,">=","x>=y","y>=x",FALSE)
Xmk_func_compare(do_op_le,<=,"<=","x<=y","y<=x",FALSE)
Xmk_func_compare(do_op_ls,<, "<", "x<y", "y<x",FALSE)
Xmk_func_compare(do_op_gt,>, ">", "x>y", "y>x",FALSE)
X#undef mk_func_compare
X
X
X/* do_compare_questionmark -- handle the <? >? etc ops */
X
XLFUNC bool do_compare_questionmark(topcode op,tvalue *v1,tvalue *v2,tvalue *r)
X{
X   tvalue tmp ;
X   tmp= *v1 ;
X   switch(op) {
X     case OP_EQQ: do_op_eq(v1,v2,r); break ;
X     case OP_NEQ: do_op_ne(v1,v2,r); break ;
X     case OP_GEQ: do_op_ge(v1,v2,r); break ;
X     case OP_LEQ: do_op_le(v1,v2,r); break ;
X     case OP_LSQ: do_op_ls(v1,v2,r); break ;
X     case OP_GTQ: do_op_gt(v1,v2,r); break ;
X   }
X   if(r->u.rval_int==0) return FALSE ;
X   *r=tmp ;
X   return TRUE ;
X}
X
X
X
X/* apply indirection of a pointer.
X * this  is easy, you just force the value to be an rvalue pointer, then
X * make it into an lvalue with the pointed-to type.
X * useful for (*x x[y] x->y etc)
X * does not setup a symbolic value!
X */
X
X
XLPROC follow_pointer(tvalue *v,char *op,bool nonull)
X{
X   get_pointer_val(v,op,FALSE);
X   if(nonull && v->u.rval_ptr == NULL)
X        duel_op_error("dereference NULL pointer x in '%s'",op,v,0);
X   v->val_kind=VK_LVALUE ;
X   v->u.lvalue=v->u.rval_ptr ;
X   v->ctype=v->ctype->u.kid ;
X}
X
XPROC duel_get_struct_val(tvalue *v,char *op)
X{
X   if(!ctype_kind_struct_like(v->ctype))
X       duel_op_error("operand x of '%s' not a sturct/union",op,v,0);
X   duel_assert(v->val_kind==VK_LVALUE);
X}
X
XPROC duel_get_struct_ptr_val(tvalue *v,char *op)
X{
X   follow_pointer(v,op,FALSE);
X   if(!ctype_kind_struct_like(v->ctype))
X     duel_op_error("operand x of '%s' not a pointer to sturct/union",op,v,0);
X}
X
XFUNC int duel_get_posint_val(tvalue *v,char *op)
X{
X    int x ;
X    x=duel_get_int_val(v,op);
X    if(x<0) duel_op_error("operand x of '%s' can not be negative",op,v,0);
X   return x ;
X}
X
X/* indirection operator (*x) */
X
XLPROC do_op_indirection(tvalue *v)
X{
X   follow_pointer(v,"*x",TRUE);
X   duel_set_symb_val(v,"*%s",v,0);
X}
X
X/* address operator (&x)
X * x must be an lvalue. it is converted into a pointer to the given type,
X * an rvalue.
X */
X
XLPROC do_op_address(tvalue *v)
X{
X   if(v->val_kind != VK_LVALUE)
X       duel_op_error("operand x of '&x' is not a lvalue",0,v,0);
X   v->val_kind=VK_RVALUE ;
X   v->u.rval_ptr=v->u.lvalue ;
X   v->ctype=duel_mkctype_ptr(v->ctype);
X   duel_set_symb_val(v,"&%s",v,0);
X}
X
XLPROC do_op_index(tvalue *v1,tvalue *v2,tvalue *r)
X{
X    get_pointer_val(v1,"x[y]",FALSE);
X    get_integral_val(v2,"y[x]",NULL);
X    add_offset_to_ptr(v1,v2,r);
X    follow_pointer(r,"[]",TRUE);
X    duel_set_symb_val(r,"%s[%s]",v1,v2);
X}
X
X
X/* do arithmeric multiply of v1,v2 and store result in r.
X * NOTE: v1, v2 are destroyed!
X */
XLPROC do_op_multiply(tvalue *v1,tvalue *v2,tvalue *r)
X{
X   tctype *t=find_numeric_result_type(v1,v2,r,"*");
X   get_numeric_val(v1,"x*y",t);
X   get_numeric_val(v2,"y*x",t);
X   r->val_kind=VK_RVALUE ;
X   r->ctype=t ;
X   duel_set_symb_val(r,"%s*%s",v1,v2);
X   switch(t->type_kind) {
X    case CTK_INT:   r->u.rval_int   =v1->u.rval_int   * v2->u.rval_int  ;break;
X    case CTK_UINT:  r->u.rval_uint  =v1->u.rval_uint  * v2->u.rval_uint ;break;
X    case CTK_LONG:  r->u.rval_long  =v1->u.rval_long  * v2->u.rval_long ;break;
X    case CTK_ULONG: r->u.rval_ulong =v1->u.rval_ulong * v2->u.rval_ulong;break;
X    case CTK_FLOAT: r->u.rval_float =v1->u.rval_float * v2->u.rval_float;break;
X    case CTK_DOUBLE:r->u.rval_double=v1->u.rval_double*v2->u.rval_double;break;
X    default: duel_assert(0);
X   }
X}
X
X/* do numeric divide of v1,v2 and store result in r.
X * v1 and v2 should be of numeric type to begin with.
X * NOTE: v1, v2 are destroyed!
X */
XLPROC do_op_divide(tvalue *v1,tvalue *v2,tvalue *r)
X{
X   tctype *t=find_numeric_result_type(v1,v2,r,"/");
X   get_numeric_val(v1,"x/y",t);
X   get_numeric_val(v2,"y/x",t);
X   switch(t->type_kind) {
X    case CTK_INT:   if(v2->u.rval_int==0) goto div_err;
X                    r->u.rval_int   =v1->u.rval_int  / v2->u.rval_int   ;break;
X    case CTK_UINT:  if(v2->u.rval_uint==0) goto div_err;
X                    r->u.rval_uint  =v1->u.rval_uint / v2->u.rval_uint  ;break;
X    case CTK_LONG:  if(v2->u.rval_long==0) goto div_err;
X                    r->u.rval_long  =v1->u.rval_long / v2->u.rval_long  ;break;
X    case CTK_ULONG: if(v2->u.rval_ulong==0) goto div_err;
X                    r->u.rval_ulong =v1->u.rval_ulong/ v2->u.rval_ulong ;break;
X    case CTK_FLOAT: if(v2->u.rval_float==0.0) goto div_err;
X                    r->u.rval_float =v1->u.rval_float/ v2->u.rval_float ;break;
X    case CTK_DOUBLE:if(v2->u.rval_double==0.0) goto div_err;
X                    r->u.rval_double=v1->u.rval_double/v2->u.rval_double;break;
X    default: duel_assert(0);
X   }
X   return ;
Xdiv_err: duel_op_error("division by zero",0,v1,v2);
X}
X
X
X/* do arithmeric reminder of v1,v2 and store result in r.
X * NOTE: v1, v2 are destroyed!
X */
XLPROC do_op_reminder(tvalue *v1,tvalue *v2,tvalue *r)
X{
X   tctype *t=find_numeric_result_type(v1,v2,r,"%");
X   get_integral_val(v1,"x%y",t);
X   get_integral_val(v2,"y%x",t);
X   switch(t->type_kind) {
X    case CTK_INT:    if(v2->u.rval_int==0) goto div_err;
X               r->u.rval_int   = v1->u.rval_int   % v2->u.rval_int    ; break ;
X    case CTK_UINT:   if(v2->u.rval_uint==0) goto div_err;
X               r->u.rval_uint  = v1->u.rval_uint  % v2->u.rval_uint   ; break ;
X    case CTK_LONG:   if(v2->u.rval_long==0) goto div_err;
X               r->u.rval_long  = v1->u.rval_long  % v2->u.rval_long   ; break ;
X    case CTK_ULONG:  if(v2->u.rval_ulong==0) goto div_err;
X               r->u.rval_ulong = v1->u.rval_ulong % v2->u.rval_ulong  ; break ;
X    default: duel_assert(0);
X   }
X   return ;
Xdiv_err: duel_op_error("reminder modulo zero",0,v1,v2);
X}
X
X/* do arithmeric or (bitwise) of v1,v2 and store result in r.
X * NOTE: v1, v2 are destroyed!
X */
XLPROC do_op_or(tvalue *v1,tvalue *v2,tvalue *r)
X{
X   tctype *t=find_numeric_result_type(v1,v2,r,"|");
X   get_integral_val(v1,"x|y",t);
X   get_integral_val(v2,"y|x",t);
X   switch(t->type_kind) {
X    case CTK_INT:  r->u.rval_int  = v1->u.rval_int   | v2->u.rval_int  ; break;
X    case CTK_UINT: r->u.rval_uint = v1->u.rval_uint  | v2->u.rval_uint ; break;
X    case CTK_LONG: r->u.rval_long = v1->u.rval_long  | v2->u.rval_long ; break;
X    case CTK_ULONG:r->u.rval_ulong= v1->u.rval_ulong | v2->u.rval_ulong; break;
X    default: duel_assert(0);
X   }
X   return ;
X}
X
X/* do arithmeric and (bitwise) of v1,v2 and store result in r.
X * NOTE: v1, v2 are destroyed!
X */
XLPROC do_op_and(tvalue *v1,tvalue *v2,tvalue *r)
X{
X   tctype *t=find_numeric_result_type(v1,v2,r,"&");
X   get_integral_val(v1,"x&y",t);
X   get_integral_val(v2,"y&x",t);
X   switch(t->type_kind) {
X    case CTK_INT:  r->u.rval_int  = v1->u.rval_int   & v2->u.rval_int  ; break;
X    case CTK_UINT: r->u.rval_uint = v1->u.rval_uint  & v2->u.rval_uint ; break;
X    case CTK_LONG: r->u.rval_long = v1->u.rval_long  & v2->u.rval_long ; break;
X    case CTK_ULONG:r->u.rval_ulong= v1->u.rval_ulong & v2->u.rval_ulong; break;
X    default: duel_assert(0);
X   }
X}
X
X/* do arithmeric xor (bitwise) of v1,v2 and store result in r.
X * NOTE: v1, v2 are destroyed!
X */
XLPROC do_op_xor(tvalue *v1,tvalue *v2,tvalue *r)
X{
X
X   tctype *t=find_numeric_result_type(v1,v2,r,"^");
X   get_integral_val(v1,"x^y",t);
X   get_integral_val(v2,"y^x",t);
X   switch(t->type_kind) {
X    case CTK_INT:  r->u.rval_int  = v1->u.rval_int  ^ v2->u.rval_int  ; break ;
X    case CTK_UINT: r->u.rval_uint = v1->u.rval_uint ^ v2->u.rval_uint ; break ;
X    case CTK_LONG: r->u.rval_long = v1->u.rval_long ^ v2->u.rval_long ; break ;
X    case CTK_ULONG:r->u.rval_ulong= v1->u.rval_ulong^ v2->u.rval_ulong; break ;
X    default: duel_assert(0);
X   }
X   return ;
X}
X
X/* do arithmeric leftshift of v1,v2 and store result in r.
X * v1 and v2 should be of numeric type to begin with.
X * NOTE: v1, v2 are destroyed!
X */
XLPROC do_op_leftshift(tvalue *v1,tvalue *v2,tvalue *r)
X{
X   int by;
X   get_integral_val(v1,"x<<y",NULL);
X   by=duel_get_int_val(v2,"y<<x");
X   r->val_kind=VK_RVALUE ;
X   r->ctype=v1->ctype ;
X   duel_set_symb_val(r,"%s<<%s",v1,v2);
X   switch(v1->ctype->type_kind) {
X    case CTK_INT:    r->u.rval_int   = v1->u.rval_int   << by ; break ;
X    case CTK_UINT:   r->u.rval_uint  = v1->u.rval_uint  << by ; break ;
X    case CTK_LONG:   r->u.rval_long  = v1->u.rval_long  << by ; break ;
X    case CTK_ULONG:  r->u.rval_ulong = v1->u.rval_ulong << by ; break ;
X    default: duel_assert(0);
X   }
X}
X
X/* do arithmeric rightshift of v1,v2 and store result in r.
X * v1 and v2 should be of numeric type to begin with.
X * NOTE: v1, v2 are destroyed!
X */
XLPROC do_op_rightshift(tvalue *v1,tvalue *v2,tvalue *r)
X{
X   int by ;
X   get_integral_val(v1,"x>>y",NULL);
X   by=duel_get_int_val(v2,"y>>x");
X   r->val_kind=VK_RVALUE ;
X   r->ctype=v1->ctype ;
X   duel_set_symb_val(r,"%s>>%s",v1,v2);
X   switch(v1->ctype->type_kind) {
X    case CTK_INT:    r->u.rval_int   = v1->u.rval_int   >> by ; break ;
X    case CTK_UINT:   r->u.rval_uint  = v1->u.rval_uint  >> by ; break ;
X    case CTK_LONG:   r->u.rval_long  = v1->u.rval_long  >> by ; break ;
X    case CTK_ULONG:  r->u.rval_ulong = v1->u.rval_ulong >> by ; break ;
X    default: duel_assert(0);
X   }
X}
X
X/* do arithmeric not of v (!v) */
XLPROC do_op_not(tvalue *v)
X{
X   get_scalar_val(v,"!x");
X   duel_set_symb_val(v,"!%s",v,0);
X   switch(v->ctype->type_kind) {
X    case CTK_PTR:    v->u.rval_int   =  ! v->u.rval_ptr    ; break ;
X    case CTK_INT:    v->u.rval_int   =  ! v->u.rval_int    ; break ;
X    case CTK_UINT:   v->u.rval_int   =  ! v->u.rval_uint   ; break ;
X    case CTK_LONG:   v->u.rval_int   =  ! v->u.rval_long   ; break ;
X    case CTK_ULONG:  v->u.rval_int   =  ! v->u.rval_ulong  ; break ;
X    case CTK_FLOAT:  v->u.rval_int   =  ! v->u.rval_float  ; break ;
X    case CTK_DOUBLE: v->u.rval_int   =  ! v->u.rval_double ; break ;
X    default: duel_assert(0);
X   }
X   v->ctype=ctype_int ;         /* always returns an int */
X}
X
X/* do bit-complement of v (~v) */
XLPROC do_op_complement(tvalue *v)
X{
X   get_integral_val(v,"~x",NULL);
X   duel_set_symb_val(v,"~%s",v,0);
X   switch(v->ctype->type_kind) {
X    case CTK_INT:    v->u.rval_int   =  ~ v->u.rval_int    ; break ;
X    case CTK_UINT:   v->u.rval_uint  =  ~ v->u.rval_uint   ; break ;
X    case CTK_LONG:   v->u.rval_long  =  ~ v->u.rval_long   ; break ;
X    case CTK_ULONG:  v->u.rval_ulong =  ~ v->u.rval_ulong  ; break ;
X    default: duel_assert(0);
X   }
X}
X
X /* do arithmeric minus of v (-v) */
XLPROC do_op_minus(tvalue *v)
X{
X   get_numeric_val(v,"-x",NULL);
X   duel_set_symb_val(v,"-%s",v,0);
X   switch(v->ctype->type_kind) {
X    case CTK_INT:    v->u.rval_int   =  - v->u.rval_int    ; break ;
X    case CTK_UINT:   v->u.rval_uint  =  - v->u.rval_uint   ; break ;
X    case CTK_LONG:   v->u.rval_long  =  - v->u.rval_long   ; break ;
X    case CTK_ULONG:  v->u.rval_ulong =  - v->u.rval_ulong  ; break ;
X    case CTK_FLOAT:  v->u.rval_float =  - v->u.rval_float  ; break ;
X    case CTK_DOUBLE: v->u.rval_double=  - v->u.rval_double ; break ;
X    default: duel_assert(0);
X   }
X}
X
X/* do sizeif(exp) - simply return the size of the exp's type */
XLPROC do_op_sizeofexp(tvalue *v)
X{
X    v->val_kind=VK_RVALUE ;
X    v->u.rval_size_t=v->ctype->size ;
X    v->ctype=ctype_size_t ;
X    duel_set_symb_val(v,"sizeof(%s)",v,0);
X}
X
XLPROC do_op_assignment(tvalue *v1,tvalue *v2,tvalue *r,char *op)
X{
X    if(v1->val_kind!=VK_LVALUE && v1->val_kind!=VK_BVALUE)
X        duel_op_error("left size not an lvalue for operator '%s'",op,v1,0);
X
X    if(ctype_kind_struct_like(v1->ctype)) {
X        duel_check_type_eq(v1,v2,op);
X        copy_lvalues(v1,v2,op);
X        *r= *v2 ;  /* return the result as an lvalue. this means (x1=x2)=x3
X                      is legal for struct, unlike ansi-c. */
X        return ;
X    }
X    if(ctype_kind_numeric(v1->ctype)) get_numeric_val(v2,op,v1->ctype);
X    else
X    if(v1->ctype->type_kind==CTK_PTR) {
X      get_pointer_val(v2,op,TRUE);
X      duel_check_type_eq(v1,v2,op);
X    }
X    else duel_op_error("bad left operand type for operator '%s'",op,v1,0);
X    put_rvalue(v1,v2,op);
X    *r= *v2 ;
X}
X
XLPROC do_op_increment(tvalue *v,char *op,int inc,bool postfix)
X{
X    tvalue lvalue_v,oldv ;
X    char s[80] ;
X    if(v->val_kind!=VK_LVALUE)
X      duel_op_error("operand of '%s' must be an lvalue",op,v,0);
X    lvalue_v= *v ;
X    if(v->ctype->type_kind==CTK_PTR) get_pointer_val(v,op,FALSE);
X    else get_integral_val(v,op,0);
X    oldv= *v ;
X
X   switch(v->ctype->type_kind) {
X    case CTK_INT:   v->u.rval_int   +=  inc ; break ;
X    case CTK_UINT:  v->u.rval_uint  +=  inc ; break ;
X    case CTK_LONG:  v->u.rval_long  +=  inc ; break ;
X    case CTK_ULONG: v->u.rval_ulong +=  inc ; break ;
X    case CTK_PTR:   v->u.rval_ptr   +=  inc*v->ctype->u.kid->size ; break;
X    default: duel_assert(0);
X   }
X   convert_scalar_type(v,lvalue_v.ctype,op);  /* back to the original type */
X   put_rvalue(&lvalue_v,v,op);
X   if(postfix) {                        /* if prefix, keep v and its sym val*/
X       *v= oldv ;
X       convert_scalar_type(v,lvalue_v.ctype,op);  /* back to original type */
X       sprintf(s,"%%s%s",op);
X       duel_set_symb_val(v,s,v,0);
X   }
X}
X
X/* unary op 'frame(n)' converts int n to a "frame type" */
XLPROC do_op_frame(tvalue *v)
X{
X   int f=duel_get_int_val(v,"frame(x)");
X   if(f<0 || f>=duel_get_frames_number())
X       duel_gen_error("Frame number too big",0);
X   v->val_kind=VK_FVALUE ;
X   v->ctype=ctype_int ;
X   v->u.fvalue=f ;
X   duel_set_symb_val(v,"frame(%s)",v,0);
X}
X
X/* unary op '(x)'. this only add parenthesis to the symbolic value, if needed*/
X
XLPROC do_op_parenthesis(tvalue *v)
X{
X    char *s=v->symb_val ;
X    int l=strlen(s);
X    if(s[0]=='(' && s[l-1]==')') return ; /* val is (x) dont make it ((x)) */
X    while(*s!=0 && (isalnum(*s) || *s=='_')) s++ ; /* find first non alnum*/
X    if(*s==0) return ;  /* no need for (x) if x is a name or constant number */
X    duel_set_symb_val(v,"(%s)",v,0);
X}
X
X/***********************************************************************
X High-level functions, major entries to this module, evaluate a node
X with a standard (single value) result
X ***********************************************************************/
X
X
X/* standardize a paramater to a function call according to the standard rules.
X * we currently don't support union/struct paramater passing
X */
X
XPROC duel_standardize_func_parm(tvalue *p)
X{
X   /* convert paramater into "standard" function calling */
X   if(ctype_kind_integral(p->ctype)) get_integral_val(p,"f()",NULL);
X   else
X   if(ctype_kind_numeric(p->ctype))     /* float, double to double */
X       convert_scalar_type(p,ctype_double,"f()");
X   else
X   if(ctype_kind_ptr_like(p->ctype)) get_pointer_val(p,"f()",FALSE);
X   else
X       duel_op_error("unsupported paramater type",0,p,0);
X}
X
X
X/* given a function (or pointer), find the first (top-most) frame that
X * the function is active in, and return the FVALUE  for it
X */
XPROC duel_find_func_frame(tvalue *v,char *op)
X{
X    int i, frames_no=duel_get_frames_number();
X    get_pointer_val(v,op,FALSE);
X
X    for(i=0 ; i<frames_no ; i++) {
X        ttarget_ptr frame_func = duel_get_function_for_frame(i);
X        if(frame_func==v->u.rval_ptr) {
X            v->val_kind=VK_FVALUE ;
X            v->ctype=ctype_int ;
X            v->u.rval_int=i ;
X            return ;
X        }
X    }
X    duel_op_error("func x is not on the call stack for operator '%s'",op,v,0);
X}
X
X
X/* compute the n'th result of v1..v2 operator.
X * result is returned in r, returns false if there isnt an nth result
X * v1,v2 are converted to integer values (but can be used to call this
X * function again. errors are reported if they arenot integral.
X */
X
XFUNC bool duel_do_op_to(tvalue *v1,tvalue *v2,int n,tvalue *r)
X{
X    int a,b,inc,x ;
X    char *p,*fmt ;
X
X    if(!v1) { a=0 ; b=duel_get_int_val(v2,"..x")-1 ; }
X    else if(!v2) { a=duel_get_int_val(v1,"x.."); b=INT_MAX ; }
X    else { a=duel_get_int_val(v1,"x..y"); b=duel_get_int_val(v2,"x..y"); }
X    if(a<=b) inc=1 ;
X    else inc= -1 ;
X    x=a+n*inc ;
X    if(inc>0 && x>b || inc<0 && x<b) return FALSE ;
X
X    r->val_kind=VK_RVALUE ;
X    r->ctype=ctype_int ;
X    r->u.rval_int=x ;
X    if(v1) p=v1->symb_val ;
X    else   p=v2->symb_val ;
X    if(     *p=='0'  && p[1]=='x'  || p[1]=='X')  fmt="0x%x" ;
X    else if(*p=='0'  && p[1]>='0'  && p[1]<='7')  fmt="0%o"  ;
X    else if(*p=='\'' && isascii(x) && isprint(x)) fmt="'%c'" ;
X    else                                          fmt="%d"   ;
X    sprintf(r->symb_val,fmt,x);
X    return TRUE ;
X}
X
X/* convert value to True/False and return it
X * in case of an illegal operand, indicateds the operator is (op)
X * main use: in operators '&&' '||' and 'if'
X */
X
XFUNC bool duel_mk_logical(tvalue *v,char *op)
X{
X   get_scalar_val(v,op);                /* verify v is scalar */
X   do_op_not(v);                        /* convert and force 0 or 1 */
X   v->u.rval_int = !v->u.rval_int ;
X   sprintf(v->symb_val,"%d",v->u.rval_int);
X   return(v->u.rval_int);
X}
X
X/* cast the value v into type t. */
X
XPROC duel_do_cast(tctype *tout,tvalue *v)
X{
X    tctype *t=v->ctype ;
X    if(ctype_kind_scalar(t) && ctype_kind_scalar(tout)) {
X        if(tout->type_kind==CTK_ARRAY)
X            duel_gen_error("casting to an array type is illegal",0);
X        else convert_scalar_type(v,tout,"(cast) x");
X    }
X    else duel_op_error("illegal type conversion in cast op",0,v,0);
X}
X
X
X/* apply unary oprand op to the given value. The original value is
X * destoryed (of course)
X */
X
XPROC duel_apply_unary_op(topcode op,tvalue *v)
X{
X   switch(op) {
X      case '(':  do_op_parenthesis(v);            break ;
X      case '{':  duel_sprint_scalar_value(v->symb_val,v);break ;
X      case '-':  do_op_minus(v);                  break ;
X      case '!':  do_op_not(v);                    break ;
X      case '*':  do_op_indirection(v);            break ;
X      case '~':  do_op_complement(v);             break ;
X      case '&':  do_op_address(v);                break ;
X      case OP_SIZ: do_op_sizeofexp(v);            break ;
X      case OP_INC: do_op_increment(v,"++",1,FALSE); break ;
X      case OP_DEC: do_op_increment(v,"--",-1,FALSE); break ;
X      case OP_FRAME: do_op_frame(v);    break ;
X      default: duel_assert(0);
X   }
X}
X
XPROC duel_apply_post_unary_op(topcode op,tvalue *v)
X{
X   switch(op) {
X      case OP_INC: do_op_increment(v,"++",1,TRUE); break ;
X      case OP_DEC: do_op_increment(v,"--",-1,TRUE); break ;
X      default: duel_assert(0);
X   }
X}
X
X
X/* apply_bin_op -- apply the operator op to the values v1 v2 and return
X *                 the result in r. the bin op is a 'regular' one, like
X *                 '+', '*', etc. in the C language.
X * note: v1,v2 are destroyed
X * returns: true if a value has been produced, false otherwise.
X *       (ops like '+' always return true. ops like '<=?' also return false)
X */
X
XFUNC bool duel_apply_bin_op(topcode op,tvalue *v1,tvalue *v2,tvalue *r)
X{
X  switch(op) {
X   case '[': do_op_index(v1,v2,r); break ;
X   case '+':  do_op_add(v1,v2,r);      break ;
X   case '-':  do_op_subtract(v1,v2,r); break ;
X   case '*':  do_op_multiply(v1,v2,r); break ;
X   case '/':  do_op_divide(v1,v2,r);   break ;
X   case '%':  do_op_reminder(v1,v2,r); break ;
X   case '|':  do_op_or(v1,v2,r);       break;
X   case '&':  do_op_and(v1,v2,r);      break ;
X   case '^':  do_op_xor(v1,v2,r); break ;
X   case OP_LSH: do_op_leftshift(v1,v2,r); break ;
X   case OP_RSH: do_op_rightshift(v1,v2,r); break ;
X   case OP_EQ:  do_op_eq(v1,v2,r); break ;
X   case OP_NE:  do_op_ne(v1,v2,r); break ;
X   case OP_GE:  do_op_ge(v1,v2,r); break ;
X   case OP_LE:  do_op_le(v1,v2,r); break ;
X   case '<':    do_op_ls(v1,v2,r); break ;
X   case '>':    do_op_gt(v1,v2,r); break ;
X   case OP_EQQ:
X   case OP_NEQ:
X   case OP_GEQ:
X   case OP_LEQ:
X   case OP_LSQ:
X   case OP_GTQ: return do_compare_questionmark(op,v1,v2,r);
X   case '=':    do_op_assignment(v1,v2,r,"="); break ;
X   default: duel_assert(0);
X  }
X  return TRUE ;
X}
SHAR_EOF
$TOUCH -am 0113165193 src/evalops.c &&
chmod 0644 src/evalops.c ||
echo "restore of src/evalops.c failed"
set `wc -c src/evalops.c`;Wc_c=$1
if test "$Wc_c" != "45286"; then
    echo original size 45286, current size $Wc_c
fi
# ============= src/error.c ==============
echo "x - extracting src/error.c (Text)"
sed 's/^X//' << 'SHAR_EOF' > src/error.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/error.c,v 1.4 93/01/12 21:35:31 mg Exp $*/
X
X/* display errors in a neat way */
X
X/*
X * $Log:    error.c,v $
X * Revision 1.4  93/01/12  21:35:31  mg
X * cleanup and set for release
X *
X */
X
X#include "duel.h"
X
Xstatic tnode *curr_eval_node ;    /* current node being evaluated */
Xstatic  char *curr_inputstr ;   /* current input string being eval */
X
X/* indicate the active node where an operator is now evaluated.
X * if an error occurs, this marker is used to tell the user where
X * the error is located.
X * return previous setup to caller, so it can be restored.
X */
X
XFUNC tnode* duel_set_eval_loc(tnode *n)
X{
X    tnode *prev=curr_eval_node ;
X    curr_eval_node=n ;
X    return prev ;
X}
X
X/* indicate the current input string which is evaluated
X * (intended for future versions with multiple input strings)
X */
X
XFUNC char* duel_set_input_string(char *s)
X{
X   char *prev=curr_inputstr ;
X   curr_inputstr=s ;
X   return prev ;
X}
X/* display source position for errors, based on current node being eval'ed */
X
XLPROC print_src_pos(void)
X{
X    int src_pos=0 ;
X    int i ;
X    if(curr_eval_node) src_pos=curr_eval_node->src_pos ;
X    printf("Error:   %s\n",curr_inputstr) ;
X    printf("         ") ;
X    for(i=0 ; i<src_pos ; i++) printf("-");
X    printf("^-- ");
X}
X
X/* called for errors that are results of bad user input (syntax/sematics),
X * e.g. an illegal variable name, etc
X * the message is printed as a format string for 'op'.
X * the error location in the source is printed based on the current eval node,
X * and the value of the given operands are displayed.
X */
X
XPROC duel_op_error(char *mesg,char *op,tvalue *v1,tvalue *v2)
X{
X    char s[160] ;
X    print_src_pos();
X    printf(mesg,op);
X    printf("\n");
X    if(v1) {
X      printf("operand%s ``%s'' ",(v2!=0)? "1":"",v1->symb_val);
X      printf("\t-- type: ");
X      duel_print_type(v1->ctype,1);
X      duel_sprint_scalar_value(s,v1);
X      printf("\n\t\t-- value: %s\n",s);
X    }
X    if(v2) {
X      printf("operand%s ``%s'' ",(v1!=0)? "2":"",v2->symb_val);
X      printf("\t-- type: ");
X      duel_print_type(v2->ctype,1);
X      duel_sprint_scalar_value(s,v2);
X      printf("\n\t\t-- value: %s\n",s);
X    }
X
X    duel_abort();
X}
X
X/* handle a genral error, no value (operand) is involved.
X * location (node) is still displayed
X */
X
XPROC duel_gen_error(char *mesg,char *arg1)
X{
X    print_src_pos();
X    printf(mesg,arg1);
X    printf("\n");
X    duel_abort();
X}
X
X/* handle fatal messages */
X
XPROC duel_fatal(char *msg)
X{
X   printf("Fatal Duel error: %s\n",msg);
X   duel_abort();
X}
X
X
SHAR_EOF
$TOUCH -am 0113165193 src/error.c &&
chmod 0644 src/error.c ||
echo "restore of src/error.c failed"
set `wc -c src/error.c`;Wc_c=$1
if test "$Wc_c" != "2715"; then
    echo original size 2715, current size $Wc_c
fi
echo "End of part 5, continue with part 6"
exit 0