Subversion Repositories tendra.SVN

/*

 * Copyright (c) 2002-2005 The TenDRA Project <http://www.tendra.org/>.

 * All rights reserved.

 *

 * Redistribution and use in source and binary forms, with or without

 * modification, are permitted provided that the following conditions are met:

 *

 * 1. Redistributions of source code must retain the above copyright notice,

 *    this list of conditions and the following disclaimer.

 * 2. Redistributions in binary form must reproduce the above copyright notice,

 *    this list of conditions and the following disclaimer in the documentation

 *    and/or other materials provided with the distribution.

 * 3. Neither the name of The TenDRA Project nor the names of its contributors

 *    may be used to endorse or promote products derived from this software

 *    without specific, prior written permission.

 *

 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS

 * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,

 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR

 * PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR

 * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,

 * EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,

 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;

 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,

 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR

 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF

 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

 *

 * $Id$

 */

/*

    		 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(exp);

extern char *get_pointer_name(void *);

extern int flpt_const_overflow_fail;

extern double atof(CONST char *);

extern double frexp(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

(void)

{

    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

(long sz, 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

(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

(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

(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

(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

(long n, bool isconst, 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

(exp e, bool isconst, 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;

		    }