Subversion Repositories tendra.SVN

/*

    		 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/codec.c,v 1.1.1.1 1998/01/17 15:55:49 release Exp $

--------------------------------------------------------------------------

$Log: codec.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/13 08:27:09  ma

All avs test passed (except add_to_ptr).

Revision 1.2  1997/11/09 14:06:53  ma

Rounding mode represented with names.

Revision 1.1.1.1  1997/10/13 12:42:47  ma

First version.

Revision 1.5  1997/10/13 08:48:58  ma

Made all pl_tests for general proc & exception handling pass.

Revision 1.4  1997/09/25 06:44:49  ma

All general_proc tests passed

Revision 1.3  1997/06/18 10:09:22  ma

Checking in before merging with Input Baseline changes.

Revision 1.2  1997/04/20 11:30:17  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:10  ma

Imported from DRA

 * Revision 1.1.1.1  1996/09/20  10:56:52  john

 *

 * Revision 1.3  1996/07/30  16:29:34  john

 * Fixed bug, discarding side-effecting operations

 *

 * Revision 1.2  1996/07/05  14:16:20  john

 * Changes for spec 3.1

 *

 * Revision 1.1.1.1  1996/03/26  15:45:08  john

 *

 * Revision 1.5  94/11/16  10:36:02  10:36:02  ra (Robert Andrews)

 * Added integer absolute construct.

 * -

 *

 * Revision 1.4  94/06/29  14:18:00  14:18:00  ra (Robert Andrews)

 * Added div0, rem0, max and min for TDF 3.0.

 *

 * Revision 1.3  93/11/19  16:14:42  16:14:42  ra (Robert Andrews)

 * Corrected order of arguments in offset_subtract.

 *

 * Revision 1.2  93/03/03  14:46:05  14:46:05  ra (Robert Andrews)

 * Added error handling routines.

 *

 * Revision 1.1  93/02/22  17:15:17  17:15:17  ra (Robert Andrews)

 * Initial revision

 *

--------------------------------------------------------------------------

*/

#include "config.h"

#include "common_types.h"

#include "exp.h"

#include "expmacs.h"

#include "flags.h"

#include "shapemacs.h"

#include "install_fns.h"

#include "tags.h"

#include "mach.h"

#include "where.h"

#include "codec.h"

#include "coder.h"

#include "operations.h"

#include "utility.h"

#include "mach.h"

#include "instr.h"

#include "codex.h"

#include "instrs.h"

#include "f64.h"

#include "me_fns.h"

#include "evaluate.h"

#include "ops_shared.h"

#include "mach_ins.h"

extern bool have_cond ;

/*

    CONSTRUCT A SIMILAR EXP

    This routine, given a where, copies the corresponding exp, and sets

    its sh equal to the given shape.

*/

exp sim_exp

    PROTO_N ( ( sha, w ) )

    PROTO_T ( shape sha X where w )

{

    exp e = copyexp ( w.wh_exp ) ;

    sh ( e ) = sha ;

    return ( e ) ;

}

/*

    PROCESS A UNARY OPERATION

    This routine processes the unary operation described by the routine

    op.  The operand is given by a and the result, which is of shape

    sha, is put into dest.  The stack argument describes the current

    state of the stack.

*/

static void uop

    PROTO_N ( ( op, sha, a, dest, stack ) )

    PROTO_T ( void ( *op ) PROTO_S ( ( shape, where, where ) ) X

	      shape sha X exp a X where dest X ash stack )

{

    int old_rmode ;

    if ( !is_o ( name ( a ) ) ) {

	/* If a is not an operand, we need to calculate its value first */

	if ( whereis ( dest ) == Dreg ) {

	    /* If dest is in a D register, code a into dest */

	    old_rmode = crt_rmode ;

	    coder ( dest, stack, a ) ;

	    crt_rmode = old_rmode ;

	    /* Now apply op to dest */

	    ( *op ) ( sha, dest, dest ) ;

	    return ;

	} else {

	    /* Code a into D1 */

	    where w ;

	    exp e = sim_exp ( sha, D1 ) ;

	    w = zw ( e ) ;

	    regsinproc |= regmsk ( REG_D1 ) ;

	    old_rmode = crt_rmode ;

	    coder ( w, stack, a ) ;

	    crt_rmode = old_rmode ;

	    /* Apply op to D1 */

	    ( *op ) ( sha, w, dest ) ;

	    retcell ( e ) ;

	    if ( have_cond == 3 ) have_cond = 1 ;

	    return ;

	}

    }

    /* If a is an operand, apply op directly to a */

    ( *op ) ( sha, zw ( a ), dest ) ;

    return ;

}

/*

    PROCESS A BINARY OPERATION

    This routine processes the binary operation described by the routine

    op.  The operands are given by a and b and the result, which is of

    shape sha, is put into dest.  The stack argument describes the current

    state of the stack.

*/

static void bop

    PROTO_N ( ( op, sha, a, b, dest, stack ) )

    PROTO_T ( void ( *op ) PROTO_S ( ( shape, where, where, where ) ) X

	      shape sha X exp a X exp b X where dest X ash stack )

{

    where w, t ;

    bool noa = !is_o ( name ( a ) ) ;

    bool nob = !is_o ( name ( b ) ) ;

    if ( noa ) {

	/* If a is not an operand, we need to calculate its value first */

	if ( nob ) {

	    /* a and b cannot both not be operands */

	    error ( "Illegal binary operation" ) ;

	}

	t = zw ( b ) ;

	if ( whereis ( dest ) == Dreg && !interfere ( dest, t ) ) {

	    /* If dest is in a D register which is not used in b,

	       code a into dest */

	    coder ( dest, stack, a ) ;

	    /* Apply op to dest and b */

	    ( *op ) ( sha, dest, t, dest ) ;

	    return ;

	} else {

	    /* Code a into D1 */

	    exp e = sim_exp ( sha, D1 ) ;

	    w = zw ( e ) ;

	    regsinproc |= regmsk ( REG_D1 ) ;

	    coder ( w, stack, a ) ;

	    /* Apply op to D1 and b */

	    ( *op ) ( sha, w, t, dest ) ;

	    retcell ( e ) ;

	    if ( have_cond == 3 ) have_cond = 1 ;

	    return ;

	}

    }

    if ( nob ) {

	/* If b is not an operand, we need to calculate its value first */

	t = zw ( a ) ;

	if ( whereis ( dest ) == Dreg && !interfere ( dest, t ) ) {

	    /* If dest is in a D register which is not used in a,

	       code b into dest */

	    coder ( dest, stack, b ) ;

	    /* Apply op to a and dest */

	    ( *op ) ( sha, t, dest, dest ) ;

	    return ;

	} else {

	    /* Code b into D1 */

	    exp e = sim_exp ( sha, D1 ) ;

	    w = zw ( e ) ;

	    regsinproc |= regmsk ( REG_D1 ) ;

	    coder ( w, stack, b ) ;

	    /* Apply op to a and D1 */

	    ( *op ) ( sha, t, w, dest ) ;

	    retcell ( e ) ;

	    if ( have_cond == 3 ) have_cond = 1 ;

	    return ;

	}

    }

    /* If a and b are both operands, apply op directly */

    ( *op ) ( sha, zw ( a ), zw ( b ), dest ) ;

    return ;

}

/*

    PROCESS A LOGICAL OPERATION

    This routine processes the logical operation described by the routine

    op.  This operation will be binary, commutative and associative.  The

    operands are given by the bro-list starting at the son of e.  The

    result is put into dest.  The stack argument describes the current

    state of the stack.

*/

static void logop

    PROTO_N ( ( op, e, dest, stack ) )

    PROTO_T ( void ( *op ) PROTO_S ( ( shape, where, where, where ) ) X

	      exp e X where dest X ash stack )

{

    exp arg1 = son ( e ) ;	/* First argument */

    exp arg2 = bro ( arg1 ) ;	/* Second argument */

    exp t, u, v ;

    where w ;

    if ( last ( arg1 ) ) {

	/* If there is of one argument, code it into dest */

	coder ( dest, stack, arg1 ) ;

	return ;

    }

    if ( last ( arg2 ) ) {

	/* If there are two arguments, use bop */

	bop ( op, sh ( e ), arg1, arg2, dest, stack ) ;

	return ;

    }

    /* Three or more arguments : need to take care about overlap between

       dest and args, so use D1. */

    regsinproc |= regmsk ( REG_D1 ) ;

    v = sim_exp ( sh ( e ), D1 ) ;

    w = zw ( v ) ;

    t = arg1 ;

    /* Scan the arguments.  t will hold either the first non-operand,

       or nilexp if all the arguments are operands.  There should be

       at most one non-operand.  */

    while ( 1 ) {

	if ( !is_o ( name ( t ) ) ) break ;

	if ( last ( t ) ) {

	    t = nilexp ;

	    break ;

	}

	t = bro ( t ) ;

    }

    /*

       Deal with the case where all the arguments are operands.  This

       does :

		D1 = op ( arg1, arg2 )

		D1 = op ( arg3, D1 )

		D1 = op ( arg4, D1 )

		....................

		dest = op ( argn, D1 )

    */

    if ( t == nilexp ) {

	/* Process the first two terms */

	( *op ) ( sh ( e ), zw ( arg1 ), zw ( arg2 ), w ) ;

	t = bro ( arg2 ) ;

	while ( !last ( t ) ) {

	    /* Process the third, fourth, ... terms */

	    ( *op ) ( sh ( e ), zw ( t ), w, w ) ;

	    t = bro ( t ) ;

	}

	/* Process the last term */

	reuseables |= regmsk ( REG_D1 ) ;

	( *op ) ( sh ( e ), zw ( t ), w, dest ) ;

	reuseables &= ~regmsk ( REG_D1 ) ;

	retcell ( v ) ;

	if ( have_cond == 3 ) have_cond = 1 ;

	return ;

    }

    /*

	Deal with the case where one argument, say arg2, is a non-operand.

	This does :

		D1 = arg2

		D1 = op ( arg1, D1 )

		D1 = op ( arg3, D1 )

		....................

		dest = op ( argn, D1 )

    */

    coder ( w, stack, t ) ;

    u = arg1 ;

    while ( 1 ) {

	if ( t != u ) {

	    if ( last ( u ) || ( bro ( u ) == t && last ( bro ( u ) ) ) ) {

		( *op ) ( sh ( e ), zw ( u ), w, dest ) ;

	    } else {

		( *op ) ( sh ( e ), zw ( u ), w, w ) ;

	    }

	}

	if ( last ( u ) ) break ;

	u = bro ( u ) ;

    }

    retcell ( v ) ;

    if ( have_cond == 3 ) have_cond = 1 ;

    return ;

}

/*

  PROCESS ADD AND SUBTRACT

  This routine processes the binary operation add.  It does dest = b + a.

  The second argument, a, may be of the form neg ( a1 ), in which case

  we use sub.

*/

static void addsub

    PROTO_N ( ( sha, a, b, dest, stack ) )

    PROTO_T ( shape sha X where a X where b X where dest X ash stack )

{

    exp e = a.wh_exp ;

    if ( name ( e ) == neg_tag ) {

      bop ( sub, sha, son ( e ), b.wh_exp, dest, stack ) ;

    }

    else {

      bop ( add, sha, e, b.wh_exp, dest, stack ) ;

    }

    return ;

}

/*

  Some constructs only set the overflow bit for 32 bit results.

  This checks values of other varieties to determine whether or not an

  overflow has occured

*/

void check_unset_overflow

    PROTO_N ( (dest,shp) )

    PROTO_T ( where dest X shape shp )

{

  exp max_val = getexp(shp,nilexp,0,nilexp,nilexp,0,range_max(shp),

		       val_tag);

  exp min_val = getexp(shp,nilexp,0,nilexp,nilexp,0,range_min(shp),

		       val_tag);

  bool sw;

  move(shp,dest,D0);

  if(is_signed(shp) && (shape_size(shp) < 32)) {

    ins1((shape_size(shp) == 16)?m_extl : m_extbl,32,D0,1);

  }

  sw = cmp(is_signed(shp)?slongsh:ulongsh,D0,zw(max_val),tst_gr);

  test_overflow2(branch_ins(tst_gr,sw,is_signed(shp),is_floating(name(shp))));

  sw = cmp(is_signed(shp)?slongsh:ulongsh,D0,zw(min_val),tst_ls);

  test_overflow2(branch_ins(tst_ls,sw,is_signed(shp), is_floating(name(shp))));

  kill_exp(max_val,max_val);

  kill_exp(min_val,min_val);

  return;

}

/*

  MAIN OPERATION CODING ROUTINE

  This routine creates code to evaluate e, putting the result into dest.

  The stack argument describes the current stack position.

*/

void codec

    PROTO_N ( ( dest, stack, e ) )

    PROTO_T ( where dest X ash stack X exp e )

{

    if ( e == nilexp ) {

	error ( "Internal coding error" ) ;

	return ;

    }

    switch ( name ( e ) ) {

	case plus_tag : {

	    /*

	       Addition is treated similarly to logical operations -

	       see the routine logop above.  It takes a variable number

	       of arguments in the form of a bro-list starting with

	       the son of e.  Each argument may be of the form

	       neg ( x ).

	    */

	    exp arg1 = son ( e ) ;	/* First argument */

	    exp arg2 = bro ( arg1 ) ;	/* Second argument */

	    exp s, t, u, v ;

	    where w ;

            int prev_ov ;

	    if ( last ( arg1 ) ) {

		/* One argument */

		coder ( dest, stack, arg1 ) ;

		return ;

	    }

	    prev_ov = set_overflow ( e ) ;

	    if ( last ( arg2 ) ) {

		/* Two arguments */

		addsub ( sh ( e ), zw ( arg2 ), zw ( arg1 ), dest, stack ) ;

		clear_overflow ( prev_ov ) ;

		return ;

	    }

	    /* Three or more arguments - use D1 */

	    t = arg1 ;

	    regsinproc |= regmsk ( REG_D1 ) ;

	    s = sim_exp ( sh ( e ), D1 ) ;

	    w = zw ( s ) ;

	    /* Look for the non-operand if there is one */

	    while ( 1 ) {

		if ( !is_o ( name ( t ) ) &&

		     ( name ( t ) != neg_tag ||

		       !is_o ( name ( son ( t ) ) ) ) ) break ;

		if ( last( t ) ) {

		    t = nilexp ;

		    break ;

		}

		t = bro( t ) ;

	    }

	    if ( t == nilexp && name ( arg1 ) == neg_tag &&

		 name ( arg2 ) == neg_tag ) t = arg1 ;

	    /* Deal with the case where all the arguments are operands */

	    if ( t == nilexp ) {

		t = bro ( arg2 ) ;

		/* Deal with the first two arguments */

		if ( name ( arg1 ) == neg_tag ) {

		    addsub ( sh ( e ), zw ( arg1 ), zw ( arg2 ),

			     ( ( t == e ) ? dest : w ), stack ) ;

		} else {

		    addsub ( sh ( e ), zw ( arg2 ), zw ( arg1 ),

			     ( ( t == e ) ? dest : w ), stack ) ;

		}

		if ( t == e ) {

		    clear_overflow ( prev_ov ) ;

		    return ;

		}

		/* Deal with the third, fourth, ... arguments */

		while ( !last ( t ) ) {

		    u = bro ( t ) ;

		    addsub ( sh ( e ), zw ( t ), w, w, stack ) ;

		    t = u ;

		}

		/* Deal with the last argument */

		addsub ( sh ( e ), zw ( t ), w, dest, stack ) ;

		retcell ( s ) ;

		if ( have_cond == 3 ) have_cond = 1 ;

		clear_overflow ( prev_ov ) ;

		return ;

	    }

	    /* Deal with the case where one argument is a non-operand */

	    coder ( w, stack, t ) ;

	    u = arg1 ;

	    while ( 1 ) {

		v = bro ( u ) ;

		if ( t != u ) {

		    if ( last ( u ) || ( v == t && last ( v ) ) ) {

			addsub ( sh ( e ), zw ( u ), w, dest, stack ) ;

		    } else {

			addsub ( sh ( e ), zw ( u ), w, w, stack ) ;

		    }

		}

		if ( last ( u ) ) break ;

		u = v ;

	    }

	    retcell ( s ) ;

	    if ( have_cond == 3 ) have_cond = 1 ;

	    clear_overflow ( prev_ov ) ;

	    return ;

	}

#ifndef tdf3

          case addptr_tag : {

             exp pointer = son ( e ) ;

             exp offset  = son ( pointer ) ;

             make_comment("addptr_tag ...") ;

             mova ( zw ( e ), dest ) ;

             make_comment("addptr_tag done") ;

             return ;

          }

#endif

	case chvar_tag : {

	    /* Change variety, the son of e, a, gives the argument */

	    exp a = son ( e ) ;

	    int prev_ov = set_overflow(e);

	    if ( !is_o ( name ( a ) ) ) {

		/* If a is not an operand */

		if ( whereis ( dest ) != Dreg ) {

		    /* If dest is not a D register, code a into D1 */

		    where w ;

		    exp s = sim_exp ( sh ( a ), D1 ) ;

		    w = zw ( s ) ;

		    regsinproc |= regmsk ( REG_D1 ) ;

		    coder ( w, stack, a ) ;

		    /* Preform the change variety on D1 */

		    change_var ( sh ( e ), w, dest ) ;

		    retcell ( s ) ;

		    if ( have_cond == 3 ) have_cond = 1 ;

		    clear_overflow ( prev_ov ) ;

		    return ;

		}

		/* If dest is a D register, code a into dest */

		coder ( dest, stack, a ) ;

		/* Preform the change variety on dest */

		change_var_sh ( sh ( e ), sh ( a ), dest, dest ) ;

		clear_overflow ( prev_ov ) ;

		return ;

	    }

	    /* If a is an operand, call change_var directly */

	    change_var ( sh ( e ), zw ( a ), dest ) ;

	    clear_overflow ( prev_ov ) ;

	    return ;

	}

	case minus_tag : {

	    /* Minus, subtract pointer etc are binary operations */

	    int prev_ov = set_overflow ( e ) ;

	    bop ( sub, sh ( e ), bro ( son ( e ) ), son ( e ),

		  dest, stack ) ;

	    clear_overflow ( prev_ov ) ;

	    return ;

	}

#ifndef tdf3

        case make_stack_limit_tag :

#endif

	case subptr_tag :

	case minptr_tag : {

	    /* Minus, subtract pointer etc are binary operations */

	    bop ( sub, sh ( e ), bro ( son ( e ) ), son ( e ),

		  dest, stack ) ;

	    return ;

	}

	case mult_tag : {

	    /* Multiply is treated as a logical operation */

	    int prev_ov = set_overflow ( e ) ;

	    logop ( mult, e, dest, stack ) ;

	    if (!optop(e)&&(name(sh(e))!=slonghd)&&(name(sh(e))!=ulonghd)) {

	      check_unset_overflow(dest,sh(e));

	    }

	    clear_overflow ( prev_ov ) ;

	    return ;

	}

	case div0_tag :

	case div2_tag : {

	    /* Division is a binary operation */

	  int prev_ov = set_overflow(e);

	  bop ( div2, sh ( e ), bro ( son ( e ) ), son ( e ),

		  dest, stack ) ;

	  if (!optop(e)&&(name(sh(e))!=slonghd)&&(name(sh(e))!=ulonghd)) {

	    check_unset_overflow(dest,sh(e));

	  }

	  clear_overflow( prev_ov );

	  return ;

	}

	case div1_tag : {

	    /* Division is a binary operation */

	  int prev_ov = set_overflow(e);

	  bop ( div1, sh ( e ), bro ( son ( e ) ), son ( e ),

		  dest, stack ) ;

	  if (!optop(e)&&(name(sh(e))!=slonghd)&&(name(sh(e))!=ulonghd)) {

	    check_unset_overflow(dest,sh(e));

	  }

	  clear_overflow( prev_ov );

	  return ;

	}

	case neg_tag : {

	    /* Negation is a unary operation */

	    int prev_ov = set_overflow ( e ) ;

	    uop ( negate, sh ( e ), son ( e ), dest, stack ) ;

	    clear_overflow ( prev_ov ) ;

	    return ;

	}

	case abs_tag : {

           /* Abs is a unary operation */

           int prev_ov = set_overflow(e);

           uop ( absop, sh ( e ), son ( e ), dest, stack ) ;

           clear_overflow( prev_ov ) ;

           return ;

	}

	case shl_tag : {

	    /* Shifting left is a binary operation */

	    int prev_ov = set_overflow ( e ) ;

	    bop ( shift, sh ( e ), bro ( son ( e ) ), son ( e ),

		  dest, stack ) ;

	    clear_overflow ( prev_ov ) ;

	    return ;

	}

	case shr_tag : {

	    /* Shifting right is a binary operation */

	    bop ( rshift, sh ( e ), bro ( son ( e ) ), son ( e ),

		  dest, stack ) ;

	    return ;

	}

	case mod_tag : {

	    /* Remainder is a binary operation */

	    int prev_ov = set_overflow ( e ) ;

	    bop ( rem1, sh ( e ), bro ( son ( e ) ), son ( e ),

		  dest, stack ) ;

	    clear_overflow ( prev_ov ) ;

	    return ;

	}

	case rem0_tag :

	case rem2_tag : {

	    /* Remainder is a binary operation */

	    int prev_ov = set_overflow ( e ) ;

	    bop ( rem2, sh ( e ), bro ( son ( e ) ), son ( e ),

		  dest, stack ) ;

	    clear_overflow ( prev_ov ) ;

	    return ;

	}

	case round_tag : {

	    /* Rounding a floating point number is a unary operation */

	    int prev_ov = set_overflow ( e ) ;

	    set_continue(e);

	    crt_rmode = round_number ( e ) ;

	    uop ( round_float, sh ( e ), son ( e ), dest, stack ) ;

	    clear_overflow ( prev_ov ) ;

	    clear_continue(e);

	    return ;

	}

	case fmult_tag : {

	    /* Floating multiplication is a floating binary operation */

	    exp f1 = son ( e ) ;

	    exp f2 = bro ( f1 ) ;

	    int prev_ov = set_overflow ( e ) ;

	    if(last(f2)) {

	      /* two arguments */

	      fl_binop ( fmult_tag, sh ( e ), zw ( f1 ), zw ( f2 ), dest ) ;

	    }

	    else {

	      /* more than two arguments; use %fp1.  Assumes that all

	       parameters are operands */

	      where w;

	      exp s = sim_exp(sh(e), FP1);

	      regsinproc |= regmsk(REG_FP1);

	      w = zw(s);

	      fl_binop(fmult_tag,sh(e),zw(f1),zw(f2),w);

	      while(!last(f2)) {

		f2 = bro(f2);

		fl_binop(fmult_tag,sh(e),w,zw(f2),(last(f2)?dest:w));

	      }

	    }

	    clear_overflow ( prev_ov ) ;

	    return ;

	}

	case fminus_tag : {

	    /* Floating subtraction is a floating binary operation */

	    exp f1 = son ( e ) ;

	    exp f2 = bro ( f1 ) ;

	    int prev_ov = set_overflow ( e ) ;

	    fl_binop ( fminus_tag, sh ( e ), zw ( f2 ), zw ( f1 ), dest ) ;

	    clear_overflow ( prev_ov ) ;

	    return ;

	}

	case fdiv_tag : {

	    /* Floating division is a floating binary operation */

	    exp f1 = son ( e ) ;

	    exp f2 = bro ( f1 ) ;

	    int prev_ov = set_overflow ( e ) ;

	    fl_binop ( fdiv_tag, sh ( e ), zw ( f2 ), zw ( f1 ), dest ) ;

	    clear_overflow ( prev_ov ) ;

	    return ;

	}

	case fneg_tag : {

	    /* Floating negation is simple */

	    int prev_ov = set_overflow ( e ) ;

	    negate_float ( sh ( e ), zw ( son ( e ) ), dest ) ;

	    clear_overflow ( prev_ov ) ;

	    return ;

	}

	case fabs_tag : {

	    /* Floating absolute value is simple */

	    int prev_ov = set_overflow ( e ) ;

	    abs_float ( sh ( e ), zw ( son ( e ) ), dest ) ;

	    clear_overflow ( prev_ov ) ;

	    return ;

	}

	case float_tag : {

	    /* Casting to a floating point number is simple */

	    int prev_ov = set_overflow ( e ) ;

	    int_to_float ( sh ( e ), zw ( son ( e ) ), dest ) ;

	    clear_overflow ( prev_ov ) ;

	    return ;

	}

	case chfl_tag : {

	    /* Changing a floating variety is simple */

	    int prev_ov = set_overflow ( e ) ;

	    change_flvar ( sh ( e ), zw ( son ( e ) ), dest ) ;

	    clear_overflow ( prev_ov ) ;

	    return ;

	}

	case and_tag : {

	    /* And is a logical operation */

	    logop ( and, e, dest, stack ) ;

	    return ;

	}

	case or_tag : {

	    /* Or is a logical operation */

	    logop ( or, e, dest, stack ) ;

	    return ;

	}

	case xor_tag : {

	    /* Xor is a logical operation */

	    logop ( xor, e, dest, stack ) ;

	    return ;

	}

	case not_tag : {

	    /* Not is a unary operation */

	    uop ( not, sh ( e ), son ( e ), dest, stack ) ;

	    return ;

	}

	case absbool_tag : {

	    /* The setcc instruction is not used */

	    error ( "Not implemented" ) ;

	    return ;

	}

	case fplus_tag : {

	    /* Floating addition is similar to integer addition */

	    exp f1 = son ( e ) ;	/* First argument */

	    exp f2 = bro ( f1 ) ;	/* Second argument */

	    exp t ;

	    long count_dest = 2 ;

	    exp de = dest.wh_exp ;

	    int prev_ov = set_overflow ( e ) ;

	    if ( last ( f1 ) ) {

		/* If there is only one argument things are simple */

		move ( sh ( e ), zw ( f1 ), dest ) ;

		clear_overflow ( prev_ov ) ;

		return ;

	    }

	    if ( last ( f2 ) ) {

		/* If there are two arguments code directly */

		if ( name ( f2 ) == fneg_tag ) {

		    f2 = son ( f2 ) ;

		    fl_binop ( fminus_tag, sh ( e ), zw ( f2 ),

			       zw ( f1 ), dest ) ;

		} else {

		    fl_binop ( fplus_tag, sh ( e ), zw ( f1 ),

			       zw ( f2 ), dest ) ;

		}

		clear_overflow ( prev_ov ) ;

		return ;

	    }

	    if ( last ( bro ( f2 ) ) &&

		 name ( bro ( f2 ) ) == real_tag &&

		 name ( dest.wh_exp ) != apply_tag

              && name ( dest.wh_exp ) != tail_call_tag

              && name ( dest.wh_exp ) != apply_general_tag ) {

		/* If there are 3 arguments, the last of which is constant */

		if ( name ( f2 ) == fneg_tag ) {

		    f2 = son ( f2 ) ;

		    fl_binop ( fminus_tag, sh ( e ), zw ( f2 ),

			       zw ( f1 ), dest ) ;

		    fl_binop ( fplus_tag, sh ( e ), zw ( bro ( f2 ) ),

			       dest, dest ) ;

		} else {

		    fl_binop ( fplus_tag, sh ( e ), zw ( f1 ),

			       zw ( f2 ), dest ) ;

		    fl_binop ( fplus_tag, sh ( e ), zw ( bro ( f2 ) ),

			       dest, dest ) ;

		}

		clear_overflow ( prev_ov ) ;

		return ;

	    }

	    if ( name ( de ) == ass_tag &&

		 name ( son ( de ) ) == name_tag &&

		 ( ( props ( son ( son ( de ) ) ) & 0x9 ) == 0x9 ) ) {

		count_dest = 0 ;

		t = f1 ;

		if ( eq_where ( dest, zw ( t ) ) ) count_dest++ ;

		while ( !last ( t ) ) {

		    t = bro ( t ) ;