/*
    		 Crown Copyright (c) 1996

    This TenDRA(r) Computer Program is subject to Copyright
    owned by the United Kingdom Secretary of State for Defence
    acting through the Defence Evaluation and Research Agency
    (DERA).  It is made available to Recipients with a
    royalty-free licence for its use, reproduction, transfer
    to other parties and amendment for any purpose not excluding
    product development provided that any such use et cetera
    shall be deemed to be acceptance of the following conditions:-

        (1) Its Recipients shall ensure that this Notice is
        reproduced upon any copies or amended versions of it;

        (2) Any amended version of it shall be clearly marked to
        show both the nature of and the organisation responsible
        for the relevant amendment or amendments;

        (3) Its onward transfer from a recipient to another
        party shall be deemed to be that party's acceptance of
        these conditions;

        (4) DERA gives no warranty or assurance as to its
        quality or suitability for any purpose and DERA accepts
        no liability whatsoever in relation to any use to which
        it may be put.
*/
/*
			    VERSION INFORMATION
			    ===================

--------------------------------------------------------------------------
$Header: /u/g/release/CVSROOT/Source/src/installers/680x0/common/evaluate.c,v 1.1.1.1 1998/01/17 15:55:49 release Exp $
--------------------------------------------------------------------------
$Log: evaluate.c,v $
 * Revision 1.1.1.1  1998/01/17  15:55:49  release
 * First version to be checked into rolling release.
 *
Revision 1.3  1997/11/09 14:09:29  ma
Fixed init with null_tag.

Revision 1.2  1997/10/29 10:22:13  ma
Replaced use_alloca with has_alloca.

Revision 1.1.1.1  1997/10/13 12:42:50  ma
First version.

Revision 1.5  1997/10/13 08:49:23  ma
Made all pl_tests for general proc & exception handling pass.

Revision 1.4  1997/09/25 06:44:57  ma
All general_proc tests passed

Revision 1.3  1997/06/18 10:09:27  ma
Checking in before merging with Input Baseline changes.

Revision 1.2  1997/04/20 11:30:24  ma
Introduced gcproc.c & general_proc.[ch].
Added cases for apply_general_proc next to apply_proc in all files.

Revision 1.1.1.1  1997/03/14 07:50:11  ma
Imported from DRA

 * Revision 1.1.1.1  1996/09/20  10:56:53  john
 *
 * Revision 1.2  1996/07/05  14:20:08  john
 * Changes for spec 3.1
 *
 * Revision 1.1.1.1  1996/03/26  15:45:11  john
 *
 * Revision 1.5  94/06/29  14:20:32  14:20:32  ra (Robert Andrews)
 * Turn out of range floating point constants to infinity if
 * flpt_const_overflow_fail is false.
 *
 * Revision 1.4  94/02/21  15:58:07  15:58:07  ra (Robert Andrews)
 * is_comm now returns int, not bool.
 *
 * Revision 1.3  93/11/19  16:18:46  16:18:46  ra (Robert Andrews)
 * Added minptr_tag case.  Corrected floating point bit pattern routines
 * for little endian case.
 *
 * Revision 1.2  93/05/24  15:56:15  15:56:15  ra (Robert Andrews)
 * Added ext_eval_name, which is meant to help in illegal constant error
 * messages.
 *
 * Revision 1.1  93/02/22  17:15:32  17:15:32  ra (Robert Andrews)
 * Initial revision
 *
--------------------------------------------------------------------------
*/


#include "config.h"
#if FS_NO_ANSI_ENVIRON
#include <floatingpoint.h>
#else
#include <float.h>
#endif
#include "common_types.h"
#include "assembler.h"
#include "basicread.h"
#include "expmacs.h"
#include "instrs.h"
#include "shapemacs.h"
#include "fbase.h"
#include "flpt.h"
#include "evaluate.h"
#include "mach.h"
#include "mach_ins.h"
#include "mach_op.h"
#include "codex.h"
#include "tags.h"
#include "translate.h"
#include "utility.h"
#include "f64.h"
#if have_diagnostics
#include "xdb_basics.h"
#endif

extern int is_comm PROTO_S ( ( exp ) ) ;
extern char *get_pointer_name PROTO_S ( ( void * ) ) ;
extern int flpt_const_overflow_fail ;
extern double atof PROTO_S ( ( CONST char * ) ) ;
extern double frexp PROTO_S ( ( double, int * ) ) ;


#define  par_pl		1	/* On the stack (procedure argument) */
#define  var_pl		2	/* On the stack (allocated variable) */

#ifndef tdf3
#define  par2_pl        4       /* Caller arguments accessed by use of A5 */
#define  par3_pl        5       /* Caller arguments accessed by use of SP */
#endif

/*
    NAME OF THE CONSTANT BEING EVALUATED
*/

static char *ext_eval_name = "???" ;


/*
    LIST OF EXTERNAL CONSTANTS

    All external constants created are formed into a bro-list.
*/

exp const_list = nilexp ;


/*
    DATA CONSTANTS

    In outputting data constants, current_op is the list of values currently
    being built up.  These values are all of size current_sz.  Values not
    yet of this size are built up in pvalue, which contains psz bits.
*/

static mach_op *current_op = null ;
static long current_sz = 0 ;


/*
    OUTPUT AN EVALUATION INSTRUCTION

    An instruction corresponding to current_op is output, and current_op
    is reset.
*/

static void eval_instr
    PROTO_Z ()
{
    if ( current_op ) {
	int s = ins ( current_sz, m_as_byte, m_as_short, m_as_long ) ;
	make_instr ( s, current_op, null, 0 ) ;
	current_op = null ;
    }
    current_sz = 0 ;
    return ;
}


/*
    OUTPUT AN OPERAND

    The operand op of size sz is added to current_op.
*/

void eval_op
    PROTO_N ( ( sz, op ) )
    PROTO_T ( long sz X mach_op *op )
{
    static mach_op *last_op ;
    if ( sz != current_sz ) {
	eval_instr () ;
	current_op = op ;
	current_sz = sz ;
    } else {
	last_op->of = op ;
    }
    last_op = op ;
    return ;
}

/*
    EVALUATE AN EXPRESSION

    The expression e, is evaluated and the integer result is returned.
    (from trans386)
*/
extern int PIC_code ;

long  evalexp
    PROTO_N ( (e) )
    PROTO_T ( exp e )
{
   switch (name(e)) {
   case  val_tag:
   case null_tag:
   case top_tag:
    {
       int k = no ( e ) ;
       if ( is_offset ( e ) ) k /= 8 ;
       return ( k );
    }
   case bitf_to_int_tag:
    {
       return evalexp (son (e));
    }
   case int_to_bitf_tag:
    {
       long  w = evalexp (son (e));
       if (shape_align(sh(e)) != 1) {
	  failer ("should be align 1");
       }
       if (shape_size(sh(e)) != 32) {
	  w &= ((1 << shape_size(sh(e))) - 1);
       }
       return w;
    }
   case not_tag:
    {
       return (~evalexp (son (e)));
    }
   case and_tag:
    {
       return (evalexp (son (e)) & evalexp (bro (son (e))));
    }
   case or_tag:
    {
       return (evalexp (son (e)) | evalexp (bro (son (e))));
    }
   case xor_tag:
    {
       return (evalexp (son (e)) ^ evalexp (bro (son (e))));
    }

   case shr_tag:
    {
       return (evalexp (son (e)) >> evalexp (bro (son (e))));
    }

   case shl_tag:
    {
       return (evalexp (son (e)) << evalexp (bro (son (e))));
    }

   case concatnof_tag:
    {
       long  wd = evalexp (son (e));
       return (wd | (evalexp (bro (son (e))) << shape_size(sh(son(e)))));
    }

   case clear_tag:
    {
       if (shape_size(sh(e)) <= 32)
       return 0;
       break;
    }
   case env_offset_tag:
    {
       exp ident_exp = son(e) ;

       if (ismarked(ident_exp)) {
          long offval ;
          switch (ptno(ident_exp)) {
          case var_pl:
             offval = -no(ident_exp)/8;
             break;
          case par2_pl:
             offval = no(ident_exp)/8;
             break;
          case par3_pl:
          case par_pl:
          default:
             offval = no(ident_exp)/8 + 8;
          }
          return offval ;
       }
       break;
    }
   case env_size_tag:
    {
       dec * et = brog(son(son(e)));
       if (et -> dec_u.dec_val.processed)
       return (et -> dec_u.dec_val.index);
       break;
    }
   case offset_add_tag:
    {
       return (evalexp(son(e))+evalexp(bro(son(e))));
    }
   case offset_max_tag:
    {
       long a = evalexp(son(e));
       long b = evalexp(bro(son(e)));
       return (a > b ? a : b);
    }
   case offset_pad_tag:
    {
       return( rounder(evalexp(son(e)), shape_align(sh(e)) / 8));
    }
   case offset_mult_tag:
    {
       return (evalexp(son(e))*evalexp(bro(son(e))));
    }
   case offset_div_tag:
   case offset_div_by_int_tag:
    {
       long n = evalexp(bro(son(e))) ;
       if ( n == 0 ) {
          n++;
          error("evalexp: divide by zero");
       }
       return (evalexp(son(e)) / n);
    }
   case offset_subtract_tag:
    {
       return (evalexp(son(e))-evalexp(bro(son(e))));
    }
   case offset_negate_tag:
    {
       return (- evalexp(son(e)));
    }
   case seq_tag:
    {
       if (name(son(son(e))) == prof_tag && last(son(son(e))))
	   return (evalexp(bro(son(e))));
       break;
    }
   case cont_tag:
    {
       if (PIC_code && name(son(e)) == name_tag && isglob(son(son(e)))
           && son(son(son(e))) != nilexp
           && !(brog(son(son(e))) -> dec_u.dec_val.dec_var))
       return (evalexp(son(son(son(e)))));
       break;
    }
   }
   error ( "Illegal constant expression in %s", ext_eval_name ) ;
   return ( 0 ) ;
}

/*
    EVALUATE AN INTEGER VALUE

    The expression e, representing an integer value, is evaluated.
*/

static void evalno
    PROTO_N ( ( e ) )
    PROTO_T ( exp e )
{
    mach_op *op ;
    long sz = shape_size ( sh ( e ) ) ;
    long k = evalexp(e);

    switch ( sz ) {

      case 8 : {
	op = make_value ( k & 0xff ) ;
	eval_op ( L8, op ) ;
	return ;
      }

      case 16 : {
	op = make_value ( ( k >> 8 ) & 0xff ) ;
	eval_op ( L8, op ) ;
	op = make_value ( k & 0xff ) ;
	eval_op ( L8, op ) ;
	return ;
      }

      case 32 : {
	op = make_value ( ( k >> 24 ) & 0xff ) ;
	eval_op ( L8, op ) ;
	op = make_value ( ( k >> 16 ) & 0xff ) ;
	eval_op ( L8, op ) ;
	op = make_value ( ( k >> 8 ) & 0xff ) ;
	eval_op ( L8, op ) ;
	op = make_value ( k & 0xff ) ;
	eval_op ( L8, op ) ;
	return ;
      }
      case 64 : {
	flt64 bval;
	bval = exp_to_f64(e);
	op = make_value((bval.small>>24) & 0xff);
	eval_op(L8,op);
	op = make_value((bval.small>>16) & 0xff);
	eval_op(L8,op);
	op = make_value((bval.small>>8) & 0xff);
	eval_op(L8,op);
	op = make_value(bval.small & 0xff);
	eval_op(L8,op);

	op = make_value((bval.big>>24) & 0xff);
	eval_op(L8,op);
	op = make_value((bval.big>>16) & 0xff);
	eval_op(L8,op);
	op = make_value((bval.big>>8) & 0xff);
	eval_op(L8,op);
	op = make_value(bval.big & 0xff);
	eval_op(L8,op);
	return;
      }
    }
    error ( "Illegal integer value in %s", ext_eval_name ) ;
    return ;
}


/*
    CONVERT A REAL VALUE TO A BITPATTERN

    This routine converts the real constant e into an array of longs
    giving the bitpattern corresponding to this constant.  Although
    care has been taken, this may not work properly on all machines
    (although it should for all IEEE machines).  It returns NULL if
    it cannot convert the number sufficiently accurately.
*/

long *realrep
    PROTO_N ( ( e ) )
    PROTO_T ( exp e )
{
    int i, n, ex ;
    double d, m ;
    char bits [128] ;
    static long longs [4] ;
    int exp_bits, mant_bits ;
    long sz = shape_size ( sh ( e ) ) ;

    /* Find size of exponent and mantissa */
    if ( sz == 32 ) {
	exp_bits = 8 ;
	mant_bits = 23 ;
    } else if ( sz == 64 ) {
	exp_bits = 11 ;
	mant_bits = 52 ;
    } else {
	exp_bits = 15 ;
	mant_bits = 96 /* or 112? */ ;
    }

#if ( FBASE == 10 )

    if ( !convert_floats ) return ( NULL ) ;

    if ( name ( e ) == real_tag ) {
	/* Calculate value */
	flt *f = flptnos + no ( e ) ;
	char fbuff [100] ;
	char *p = fbuff ;
	if ( f->exp <= DBL_MIN_10_EXP || f->exp >= DBL_MAX_10_EXP ) {
	    /* Reject anything that won't fit into a double */
	    return ( NULL ) ;
	}
	if ( f->sign < 0 ) *( p++ ) = '-' ;
	*( p++ ) = '0' + f->mant [0] ;
	*( p++ ) = '.' ;
	for ( i = 1 ; i < MANT_SIZE ; i++ ) *( p++ ) = '0' + f->mant [i] ;
	sprintf ( p, "e%d", ( int ) f->exp ) ;
	d = atof ( fbuff ) ;
	if ( sz == 32 ) {
	    /* Round floats */
	    static float fd ;
	    fd = ( float ) d ;
	    d = ( double ) fd ;
	}
    } else {
	error ( "Illegal floating-point constant" ) ;
	return ( NULL ) ;
    }

    /* Deal with 0 */
    if ( d == 0.0 ) {
	for ( i = 0 ; i < sz / 32 ; i++ ) longs [i] = 0 ;
	return ( longs ) ;
    }

    /* Fill in sign */
    if ( d < 0.0 ) {
	bits [0] = 1 ;
	d = -d ;
    } else {
	bits [0] = 0 ;
    }

    /* Work out mantissa and exponent */
    m = frexp ( d, &ex ) ;
    m = 2.0 * m - 1.0 ;
    ex-- ;

    /* Fill in mantissa */
    for ( i = 1 ; i <= mant_bits ; i++ ) {
	int j = exp_bits + i ;
	m *= 2.0 ;
	if ( m >= 1.0 ) {
	    m -= 1.0 ;
	    bits [j] = 1 ;
	} else {
	    bits [j] = 0 ;
	}
    }

#else

    if ( name ( e ) == real_tag ) {
	int j, k = -1 ;
	flt *f = flptnos + no ( e ) ;

	/* Deal with 0 */
	if ( f->sign == 0 ) {
	    for ( i = 0 ; i < sz / 32 ; i++ ) longs [i] = 0 ;
	    return ( longs ) ;
	}

	/* Fill in sign */
	bits [0] = ( f->sign < 0 ? 1 : 0 ) ;

	/* Work out exponent */
	ex = FBITS * ( f->exp ) + ( FBITS - 1 ) ;

	/* Fill in mantissa */
	for ( i = 0 ; i < MANT_SIZE ; i++ ) {
	    for ( j = FBITS - 1 ; j >= 0 ; j-- ) {
		if ( ( f->mant [i] ) & ( 1 << j ) ) {
		    if ( k >= 0 ) {
			if ( k < sz ) bits [k] = 1 ;
			k++ ;
		    } else {
			/* Ignore first 1 */
			k = exp_bits + 1 ;
		    }
		} else {
		    if ( k >= 0 ) {
			if ( k < sz ) bits [k] = 0 ;
			k++ ;
		    } else {
			/* Step over initial zeros */
			ex-- ;
		    }
		}
	    }
	}

    } else {
	error ( "Illegal floating-point constant" ) ;
	return ( NULL ) ;
    }

#endif

    /* Fill in exponent */
    ex += ( 1 << ( exp_bits - 1 ) ) - 1 ;
    if ( ex <= 0 || ex >= ( 1 << exp_bits ) - 1 ) {
	if ( flpt_const_overflow_fail ) {
	    error ( "Floating point constant out of range" ) ;
	}
	if ( sz == 32 ) {
	    if ( bits [0] ) longs [0] = 0x80000000 ;
	    longs [0] += 0x7f800000 ;
	} else {
	    if ( bits [0] ) longs [0] = 0x80000000 ;
	    longs [0] += 0x7ff00000 ;
	    longs [1] = 0 ;
	}
	return ( longs ) ;
    }
    for ( i = 0 ; i < exp_bits ; i++ ) {
	int j = exp_bits - i ;
	bits [j] = ( ( ex & ( 1 << i ) ) ? 1 : 0 ) ;
    }

    /* Convert bits to longs */
    n = ( sz / 32 ) - 1 ;
    for ( i = 0 ; i <= n ; i++ ) {
	int j ;
	long b0 = 0, b1 = 0, b2 = 0, b3 = 0 ;
	for ( j = 0 ; j < 8 ; j++ ) b0 = 2 * b0 + bits [ 32 * i + j ] ;
	for ( j = 8 ; j < 16 ; j++ ) b1 = 2 * b1 + bits [ 32 * i + j ] ;
	for ( j = 16 ; j < 24 ; j++ ) b2 = 2 * b2 + bits [ 32 * i + j ] ;
	for ( j = 24 ; j < 32 ; j++ ) b3 = 2 * b3 + bits [ 32 * i + j ] ;
#if little_end
	longs [ n - i ] = ( b0 << 24 ) + ( b1 << 16 ) + ( b2 << 8 ) + b3 ;
#else
	longs [i] = ( b0 << 24 ) + ( b1 << 16 ) + ( b2 << 8 ) + b3 ;
#endif
    }
    return ( longs ) ;
}


/*
    EVALUATE A REAL VALUE

    The expression e, representing a real value, is evaluated.  There
    are two cases, depending on the macro convert_floats.  Either the
    number itself or its representation in bits is output.
*/

static void evalreal
    PROTO_N ( ( e ) )
    PROTO_T ( exp e )
{
    long *p ;
    long sz = shape_size ( sh ( e ) ) ;
    eval_instr () ;
    p = realrep ( e ) ;
    if ( p ) {
	int i ;
	for ( i = 0 ; i < sz / 32 ; i++ ) {
	    mach_op *op = make_value ( p [i] ) ;
	    eval_op ( L32, op ) ;
	}
    } else {
	flt *f = flptnos + no ( e ) ;
	mach_op *op = make_float_data ( f ) ;
	int instr = insf ( sz, m_as_float, m_as_double, m_dont_know ) ;
	make_instr ( instr, op, null, 0 ) ;
	current_sz = 0 ;
    }
    return ;
}


/*
    CLEAR A NUMBER OF BYTES

    The next n bits are cleared, either by padding with zeros or by
    using a space instruction.
*/

static void clear_out
    PROTO_N ( ( n, isconst, al ) )
    PROTO_T ( long n X bool isconst X long al )
{
    mach_op *op ;
    if ( isconst ) {
	while ( n > 0 ) {
	    op = make_value ( 0 ) ;
	    eval_op ( L8, op ) ;
	    n-- ;
	}
    } else {
	eval_instr () ;
	current_sz = 0 ;
	if(n > 0) {
	  op = make_int_data ( n ) ;
	  make_instr ( m_as_space, op, null, 0 ) ;
	}
	current_sz = 0 ;
    }
    return ;
}


/*
    OUTPUT A CONSTANT

    This is the main constant evaluation routine.  The expression e is
    evaluated.  al gives the alignment of e.
*/

void evalaux
    PROTO_N ( ( e, isconst, al ) )
    PROTO_T ( exp e X bool isconst X long al )
{
    switch ( name ( e ) ) {

	case real_tag : {
	    /* Real values */
	    evalreal ( e ) ;
	    return ;
	}

	case compound_tag : {
	    /* Compound values - deal with each component */
	    exp val ;
	    mach_op *op ;
	    exp offe = son ( e ) ;
	    long off ;
	    long work = 0 ;
	    long crt_off = 0 ;
	    long bits_left = 0 ;
            int pad ;
            bool param_aligned = 0 ;

	    if ( offe == nilexp ) return ;

            /* look ahead to determine if it is parameter aligned */
            val = bro ( offe ) ;
            if ( ! last ( val ) ) {
               offe = bro ( val ) ;
               if ( offe->shf->sonf.ald->al.al_val.al == 32 ) {
                  param_aligned = 1 ;
               }
            }
            offe = son ( e ) ;

	    while ( 1 ) {
		off = no ( offe ) ;
		val = bro ( offe ) ;

		if ( bits_left && off >= ( crt_off + 8 ) ) {
		    op = make_value ( ( work >> 24 ) & 0xff ) ;
		    eval_op ( L8, op ) ;
		    crt_off += 8 ;
		    work = 0 ;
		    bits_left = 0 ;
		}

		if ( off < crt_off ) {
		    error ( "Compound constants out of order in %s",
			    ext_eval_name ) ;
		}

		if ( off > crt_off && !bits_left ) {
		    clear_out ( ( off - crt_off ) / 8, 1, al ) ;
		    crt_off = off ;
		}

		if ( name ( sh ( val ) ) != bitfhd ) {
                   pad = 0 ;
                   if ( param_aligned ) {
                      switch ( name ( sh ( val ) ) ) {
                      case scharhd:
                      case ucharhd:
                         clear_out ( 3, 1, al ) ;
                         crt_off += 3*8 ;
                         break;
                      case swordhd:
                      case uwordhd:
                         clear_out ( 2, 1, al ) ;
                         crt_off += 2*8 ;
                         break;
                      }
                   }

		    evalaux ( val, isconst, ( crt_off + al ) & 56 ) ;
		    crt_off += shape_size ( sh ( val ) ) ;
		} else {
		    long sz = shape_size ( sh ( val ) ) ;
		    long offn = off - crt_off ;
		    long nx, enx ;
		    long extra_byte = 0 ;
		    if ( name ( val ) == val_tag ) {
			nx = no ( val ) ;
		    } else {
			nx = no ( son ( val ) ) ;
		    }
		    if ( sz > 32 - offn ) {
			enx = ( nx & 0xff ) ;
			extra_byte = 1 ;
			nx >>= 8 ;
			sz -= 8 ;
		    }
		    nx = ( nx & lo_bits [sz] ) << ( 32 - offn - sz ) ;
		    work += nx ;
		    bits_left = offn + sz ;
		    while ( bits_left >= 8 ) {
			long v ;
			bits_left -= 8 ;
			v = ( work >> 24 ) & 0xff ;
			work <<= 8 ;
			if ( extra_byte ) {
			    bits_left += 8 ;
			    work += ( enx << ( 32 - bits_left ) ) ;
			    extra_byte = 0 ;
			}
			op = make_value ( v ) ;
			eval_op ( L8, op ) ;
			crt_off += 8 ;
		    }
		}

		if ( last ( val ) ) {
		    long left ;
		    if ( bits_left ) {
			op = make_value ( ( work >> 24 ) & 0xff ) ;
			eval_op ( L8, op ) ;
			crt_off += 8 ;
		    }
		    left = shape_size ( sh ( e ) ) - crt_off ;
		    if ( left > 0 ) clear_out ( left / 8, 1, al ) ;
		    return ;
		}
		offe = bro ( val ) ;
	    }
	    /* Not reached */
	}

	case name_tag : {
	    /* External names */
	    mach_op *op ;
	    long n = no ( e ) ;
	    long sz = shape_size ( sh ( e ) ) ;
	    char *nm = brog ( son ( e ) )->dec_u.dec_val.dec_id ;
	    op = make_extern_data ( nm, n / 8 ) ;
	    eval_op ( sz, op ) ;
	    return ;
	}

	case string_tag : {
	    /* Strings */
	    long i ;
	    long char_size = ( long ) props ( e ) ;
	    long n = shape_size ( sh ( e ) ) / char_size ;
	    switch ( char_size ) {

		case 8 : {
		    char *s = nostr ( e ) ;
		    for ( i = 0 ; i < n ; i++ ) {
			long ch = ( long ) s [i] ;
			eval_op ( char_size, make_value ( ch ) ) ;
		    }
		    break ;
		}

		case 16 : {
		    short *s = ( short * ) nostr ( e ) ;
		    for ( i = 0 ; i < n ; i++ ) {
			long ch = ( long ) s [i] ;
			eval_op ( char_size, make_value ( ch ) ) ;
		    }
		    break ;
		}

		case 32 : {
		    long *s = ( long * ) nostr ( e ) ;
		    for ( i = 0 ; i < n ; i++ ) {
			long ch = s [i] ;
			eval_op ( char_size, make_value ( ch ) ) ;
		    }
		    break ;
		}

		default : {
		    error ( "Illegal string size in %s", ext_eval_name ) ;
		    break ;
		}
	    }
	    return ;
	}

	case res_tag : {
	    /* Result values */
	    shape ss = sh ( son ( e ) ) ;
	    long sz = shape_size ( ss ) / 8 ;
	    long sa = shape_align ( ss ) ;
	    clear_out ( sz, isconst, sa ) ;
	    return ;
	}
      case top_tag :
      case null_tag : {
	    /* Null values */
	    shape ss = sh ( e ) ;
	    long sz = shape_size ( ss ) / 8 ;
	    long sa = shape_align ( ss ) ;
	    clear_out ( sz, isconst, sa ) ;
	    return ;
	}

	case ncopies_tag : {
	    /* Multiple copies */
	    long i ;
	    exp t = son ( e ) ;
	    long sa = shape_align ( sh ( t ) ) ;
	    if ( is_comm ( t ) ) {
		long sz = rounder ( shape_size ( sh ( t ) ), sa ) / 8 ;
		clear_out ( sz * no ( e ), isconst, sa ) ;
		return ;
	    }
	    for ( i = 0 ; i < no ( e ) ; i++ ) evalaux ( t, isconst, sa ) ;
	    return ;
	}

	case nof_tag : {
	    /* Array values */
	    exp t = son ( e ) ;
	    if ( t == nilexp ) return ;
	    while ( 1 ) {
		evalaux ( t, isconst, al ) ;
		if ( last ( t ) ) return ;
		t = bro ( t ) ;
	    }
	    /* Not reached */
	}

	case concatnof_tag : {
	    /* Concatenated arrays */
	    long a2 = ( al + shape_size ( son ( e ) ) ) & 63 ;
	    evalaux ( son ( e ), isconst, al ) ;
	    evalaux ( bro ( son ( e ) ), isconst, a2 ) ;
	    return ;
	}

	case chvar_tag :
	case int_to_bitf_tag : {
	    /* Change variety */
	    if ( name ( son ( e ) ) == val_tag ) {
		sh ( son ( e ) ) = sh ( e ) ;
		evalaux ( son ( e ), isconst, al ) ;
		return ;
	    }
	    error ( "Illegal change variety constant in %s", ext_eval_name ) ;
	    return ;
	}

	case chfl_tag : {
	    /* Change floating variety */
	    if ( name ( son ( e ) ) == real_tag ) {
		sh ( son ( e ) ) = sh ( e ) ;
		evalaux ( son ( e ), isconst, al ) ;
		return ;
	    }
	    error ( "Illegal change floating variety constant in %s",
		    ext_eval_name ) ;
	    return ;
	}

	case clear_tag : {
	    long sz = shape_size ( sh ( e ) ) / 8 ;
	    clear_out ( sz, isconst, al ) ;
	    return ;
	}
#if 0
        case env_size_tag: {
           dec* d = brog(son(son(e)));
           mach_op* op = make_lab_data ( (long) d, 0 ) ;
           eval_op(L32,op);
           return ;
        }

	case env_offset_tag : {
           /* Offsets */
           long offval;
           mach_op *op;
           exp ident_exp = son ( e ) ;
           op = make_lab_data ( (long) ident_exp, 0 ) ;
           eval_op(L32,op);

           return ;
	}
#endif
	case ident_tag : {
	     /* Simple identifications */
	     exp body = bro ( son ( e ) ) ;
	     if ( name ( body ) == name_tag && son ( body ) == e ) {
		evalaux ( son ( e ), isconst, al ) ;
		return ;
	     }
	     break ;
	}

	case minptr_tag : {
	    exp p1 = son ( e ) ;
	    exp p2 = bro ( p1 ) ;
	    if ( name ( p1 ) == name_tag && name ( p2 ) == name_tag ) {
		long n = no ( p1 ) - no ( p2 ) ;
		long sz = shape_size ( sh ( e ) ) ;
		char *n1 = brog ( son ( p1 ) )->dec_u.dec_val.dec_id ;
		char *n2 = brog ( son ( p2 ) )->dec_u.dec_val.dec_id ;
		mach_op *op1 = new_mach_op () ;
		mach_op *op2 = new_mach_op () ;
		mach_op *op3 = new_mach_op () ;
		op1->type = MACH_EXT ;
		op1->def.str = n1 ;
		op1->plus = op2 ;
		op2->type = MACH_NEG ;
		op2->plus = op3 ;
		op3->type = MACH_EXT ;
		op3->def.str = n2 ;
		if ( n ) {
		    mach_op *op4 = new_mach_op () ;
		    op4->type = MACH_VAL ;
		    op4->def.num = n ;
		    op3->plus = op4 ;
		}
		eval_op ( sz, op1 ) ;
		return ;
	    }
	    break ;
	}
	default:
            evalno ( e ) ;
    }
}


#if 0

/*
    IS A VALUE ZERO?

    If so it can be put into the common area.
*/

static int is_comm
    PROTO_N ( ( e ) )
    PROTO_T ( exp e )
{
    switch ( name ( e ) ) {

	case val_tag : return ( no ( e ) ? 0 : 1 ) ;

	case int_to_bitf_tag :
	case chvar_tag : return ( is_comm ( son ( e ) ) ) ;

	case real_tag : {
	    flpt f = no ( e ) ;
	    return ( flptnos [f].sign ? 0 : 1 ) ;
	}

	case compound_tag : {
	    exp t = son ( e ) ;
	    if ( t == nilexp ) return ( 1 ) ;
	    while ( 1 ) {
		t = bro ( t ) ;
		if ( name ( sh ( t ) ) != bitfhd ) {
		    if ( !is_comm ( t ) ) return ( 0 ) ;
		} else {
		    if ( name ( t ) == val_tag ) {
			if ( no ( t ) ) return ( 0 ) ;
		    } else {
			if ( no ( son ( t ) ) ) return ( 0 ) ;
		    }
		}
		if ( last ( t ) ) return ( 1 ) ;
		t = bro ( t ) ;
	    }
	    /* Not reached */
	}

	case ncopies_tag : return ( is_comm ( son ( e ) ) ) ;

	case nof_tag : {
	    exp t = son ( e ) ;
	    if ( t == nilexp ) return ( 1 ) ;
	    while ( 1 ) {
		if ( !is_comm ( t ) ) return ( 0 ) ;
		if ( last ( t ) ) return ( 1 ) ;
		t = bro ( t ) ;
	    }
	    /* Not reached */
	}

	case concatnof_tag : {
	    exp t = son ( e ) ;
	    return ( is_comm ( t ) && is_comm ( bro ( t ) ) ) ;
	}

	case clear_tag :
	case res_tag :
	case null_tag : return ( 1 ) ;
    }
    return ( 0 ) ;
}

#endif


/*
    OUTPUT A CONSTANT
*/

void evaluate
    PROTO_N ( ( c, cname, s, isconst, global, di ) )
    PROTO_T ( exp c X long cname X char *s X int isconst X int global X diag_global *di )
{
    mach_op *op1, *op2 ;
    long al = ( long ) shape_align ( sh ( c ) ) ;

    if ( is_comm ( c ) ||
        ((name(c) == name_tag) && (son(son(c))) && (name(son(son(c))) == null_tag))) {

	long sz = rounder ( shape_size ( sh ( c ) ), 32 ) ;

	/* Common global values */
	if ( global && cname == -1 && !is_local ( s ) ) {
	    op1 = make_extern_data ( s, 0 ) ;
	    op2 = make_int_data ( sz / 8 ) ;
	    make_instr ( m_as_common, op1, op2, 0 ) ;
#if have_diagnostics
	    if ( di ) xdb_diag_val_begin ( di, s, cname, global ) ;
#endif
	    return ;
	}

#ifdef asm_uses_lcomm
	/* Common local value */
	if ( cname == -1 ) {
	    op1 = make_extern_data ( s, 0 ) ;
	} else {
	    op1 = make_lab_data ( cname, 0 ) ;
	}
	op2 = make_int_data ( sz / 8 ) ;
	make_instr ( m_as_local, op1, op2, 0 ) ;
#if have_diagnostics
	if ( di ) xdb_diag_val_begin ( di, s, cname, global ) ;
#endif
#else
	/* Common local value */
	area ( pbss ) ;
	if ( cname == -1 ) {
	     make_external_label ( s ) ;
	} else {
	     make_label ( cname ) ;
	}
#if have_diagnostics
	if ( di ) xdb_diag_val_begin ( di, s, cname, global ) ;
#endif
	op1 = make_int_data ( sz / 8 ) ;
	make_instr ( m_as_space, op1, null, 0 ) ;
#endif
	return ;
    }

    /* Data values */
    if ( global && cname == -1 && !is_local ( s ) ) {
	op1 = make_extern_data ( s, 0 ) ;
	make_instr ( m_as_global, op1, null, 0 ) ;
    }

#if have_diagnostics
    if ( di ) xdb_diag_val_begin ( di, s, cname, global ) ;
#endif

    if ( al <= 32 ) al = 32 ;

    ext_eval_name = "statically declared object" ;
    if ( cname == -1 ) {
	make_external_label ( s ) ;
	if ( !is_local ( s ) ) ext_eval_name = s ;
    } else {
	make_label ( cname ) ;
    }
    evalaux ( c, ( bool ) isconst, al ) ;
    eval_instr () ;
    return ;
}


