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

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

$Log: scan2.c,v $

 * Revision 1.1.1.1  1998/01/17  15:55:50  release

 * First version to be checked into rolling release.

 *

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

First version.

Revision 1.4  1997/09/25 06:45:31  ma

All general_proc tests passed

Revision 1.3  1997/06/24 10:56:09  ma

Added changes for "Plumhall Patch"

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

Imported from DRA

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

 *

 * Revision 1.3  1996/07/30  16:32:16  john

 * Added offset conversion

 *

 * Revision 1.2  1996/07/05  14:26:12  john

 * Changes for spec 3.1

 *

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

 *

 * Revision 1.5  94/11/16  10:37:51  10:37:51  ra (Robert Andrews)

 * Added support for integer absolute.

 *

 * Revision 1.4  94/06/29  14:25:38  14:25:38  ra (Robert Andrews)

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

 *

 * Revision 1.3  94/02/21  16:03:43  16:03:43  ra (Robert Andrews)

 * The long argument to ap_argsc is better as an int.

 *

 * Revision 1.2  93/04/19  13:36:21  13:36:21  ra (Robert Andrews)

 * offset_pad_exp has disappeared in March93 spec.

 *

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

 * Initial revision

 *

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

*/

/*

    SCAN2

    Scans through the program and puts all the arguments of operations

    into a suitable 68000 operand form.

*/

#include "config.h"

#include "common_types.h"

#include "exp.h"

#include "expmacs.h"

#include "exptypes.h"

#include "shapemacs.h"

#include "tags.h"

#include "install_fns.h"

#ifndef tdf3

#include "68k_globals.h"

#include "special_exps.h"

#endif

void scan2 PROTO_S ( ( bool, exp, exp ) ) ;

/*

    MACROS TO SET OR GET THE SON OR BRO

*/

#define  assexp( I, P, V )	if ( I ) setson ( P, V ) ; else setbro ( P, V )

#define  contexp( I, P )	( ( I ) ? son ( P ) : bro ( P ) )

/*

  Transform a non-bit offset into a bit offset.

  (borrowed from trans386)

*/

static void make_bitfield_offset

    PROTO_N ( (e,pe,spe,sha) )

    PROTO_T ( exp e X exp pe X int spe X shape sha )

{

  exp omul;

  exp val8;

  if (name(e) == val_tag){

    no(e) *= 8;

    return;

  }

  omul = getexp (sha, bro(e), (int)(last (e)), e, nilexp, 0, 0, offset_mult_tag);

  val8 = getexp (slongsh, omul, 1, nilexp, nilexp, 0, 8, val_tag);

  clearlast(e);

  setbro(e, val8);

  if(spe) {

    son(pe) = omul;

  }

  else{

    bro(pe) = omul;

  }

  return;

}

/*

    INSERT AN IDENTITY DECLARATION

    This routine inserts an identity declaration of x at to and replaces

    x by a use of this identity.

*/

static void cca

    PROTO_N ( ( sto, to, sx, x ) )

    PROTO_T ( bool sto X exp to X bool sx X exp x )

{

   exp d, a, id, tg;

   d = contexp (sx, x);

#ifndef tdf3

   if (name(d)==caller_tag) {	/* position sensitive */

      cca (sto, to, 1, d);

      return;

   }

#endif

   d = contexp ( sx, x ) ;

   a = contexp ( sto, to ) ;

   id = getexp ( sh ( a ), bro ( a ), last(a), d, nilexp, 0, L1, ident_tag ) ;

   tg = getexp ( sh ( d ), bro ( d ), last(d), id, nilexp, 0, L0, name_tag ) ;

   pt ( id ) = tg ;

   clearlast ( d ) ;

   if ( d != a ) {

      bro ( d ) = a ;

      bro ( a ) = id ;

      setlast ( a ) ;

      assexp ( sto, to, id ) ;

      assexp ( sx, x, tg ) ;

   } else {

      bro ( d ) = tg ;

      bro ( tg ) = id ;

      setlast ( tg ) ;

      clearlast ( d ) ;

      assexp ( sto, to, id ) ;

   }

   return ;

}

/*

    INSERT AN IDENTITY DECLARATION IN A BRO-LIST

    Keeping the same to, cc scans along the bro list e, applying cca to

    introduce an identity declaration when doit is 1.  It keeps count as

    the index position along the list in order to pass it to doit.  If it

    uses cca it scans the resulting declaration, using the same to.  If it

    doesn't, it scans the list element, still using the same to.  This keeps

    all operations in the same order.

*/

static void cc

    PROTO_N ( ( sto, to, se, e, doit, count ) )

    PROTO_T ( bool sto X exp to X bool se X exp e X

	      bool ( *doit ) PROTO_S ( ( exp, int ) ) X int count )

{

  exp ec = contexp ( se, e ) ;

  if ( last ( ec ) ) {

    if ( doit ( ec, count ) ) {

      cca ( sto, to, se, e ) ;

      ec = contexp ( sto, to ) ;

      scan2 ( 1, ec, son ( ec ) ) ;

    } else {

      scan2 ( sto, to, ec ) ;

    }

  } else {

    cc ( sto, to, 0, ec, doit, count + 1 ) ;

    ec = contexp ( se, e ) ;

    if ( doit ( ec, count ) ) {

      cca ( sto, to, se, e ) ;

      ec = contexp ( sto, to ) ;

      scan2 ( 1, ec, son ( ec ) ) ;

    } else {

      scan2 ( sto, to, ec ) ;

    }

  }

  return ;

}

/*

    INSERT AN IDENTITY DECLARATION

    This routine is the same as cca, but forces the declaration into

    a register.

*/

static void ccp

    PROTO_N ( ( sto, to, sx, x ) )

    PROTO_T ( bool sto X exp to X bool sx X exp x )

{

    exp xc = contexp ( sx, x ) ;

    exp toc ;

    if ( name ( xc ) != name_tag || !isusereg ( son ( xc ) ) ) {

	cca ( sto, to, sx, x ) ;

	toc = contexp ( sto, to ) ;

	setusereg ( toc ) ;

	scan2 ( 1, toc, son ( toc ) ) ;

    }

    return ;

}

/*

    IS THE EXP e AN OPERAND?

*/

static bool is_opnd

    PROTO_N ( ( e ) )

    PROTO_T ( exp e )

{

    switch ( name ( e ) ) {

	case name_tag : {

	    exp s = son ( e ) ;

	    return ( !isvar ( s ) && (son(son(e))!=nilexp) && !isparam ( son ( son ( e ) ) ) ) ;

	}

	case val_tag :

	case real_tag :

        case env_size_tag :

        case general_proc_tag:

        case proc_tag :

	case cont_tag :

	case string_tag :

	case null_tag : {

	    return ( 1 ) ;

	}

    }

    return ( 0 ) ;

}

/*

    CHECK THE POINTER ARGUMENT OF AN ADDPTR

*/

static void ap_arg1

    PROTO_N ( ( sto, to, sa, a, b ) )

    PROTO_T ( bool sto X exp to X bool sa X exp a X bool b )

{

    exp ac = contexp ( sa, a ) ;

    if ( !b && name ( ac ) == cont_tag && name ( son ( ac ) ) == name_tag &&

	 isvar ( son ( son ( ac ) ) ) ) return ;

    if ( !b && name ( ac ) == name_tag ) return ;

    /* The pointer has to go into a register */

    ccp ( sto, to, sa, a ) ;

    return ;

}

/*

    CHECK THE INTEGER ARGUMENT OF AN ADDPTR

*/

static void ap_argsc

    PROTO_N ( ( sto, to, se, e, sz, b ) )

    PROTO_T ( bool sto X exp to X bool se X exp e X int sz X bool b )

{

    exp ec = contexp ( se, e ) ;

    exp p = son ( ec ) ;

    exp a = bro ( p ) ;

    exp temp ;

    /* Check for multiplication by constant scale factor */

    if ( name ( a ) == offset_mult_tag &&

	 name ( bro ( son ( a ) ) ) == val_tag ) {

	long k = no ( bro ( son ( a ) ) ) ;

	if ( ( k == 8 || k == 16 || k == 32 || k == 64 ) && k == sz ) {

	    ccp ( sto, to, 1, a ) ;

	    ap_arg1 ( sto, to, 1, ec, b ) ;

	    return ;

	}

    }

    if ( sz == 8 ) {

	ccp ( sto, to, 0, son ( ec ) ) ;

	ap_arg1 ( sto, to, 1, ec, b ) ;

	return ;

    }

    if ( b ) {

	ccp ( sto, to, se, e ) ;

	return ;

    }

    cca ( sto, to, se, e ) ;

    temp = contexp ( sto, to ) ;

    scan2 ( 1, temp, son ( temp ) ) ;

    return ;

}

/*

    CHECK THE ARGUMENT OF A CONT OR THE DESTINATION OF AN ASSIGN

*/

static void cont_arg

    PROTO_N ( ( sto, to, e, sa ) )

    PROTO_T ( bool sto X exp to X exp e X shape sa )

{

    unsigned char n = name ( son ( e ) ) ;

    if ( n == name_tag ) return ;

    if ( n == cont_tag ) {

	exp s = son ( son ( e ) ) ;

	if ( name ( s ) == name_tag &&

	     ( isvar ( son ( s ) ) || isglob ( son ( s ) ) ||

	       isusereg ( son ( s ) ) ) ) return ;

	if ( name ( s ) == reff_tag &&

	    name ( son ( s ) ) == name_tag &&

	    ( isvar ( son ( son ( s ) ) ) || isglob ( son ( son ( s ) ) ) ||

	      isusereg ( son ( son ( s ) ) ) ) ) return ;

	ccp ( sto, to, 1, e ) ;

	return ;

    }

    if ( n == reff_tag ) {

	exp s = son ( e ) ;

	if ( name ( son ( s ) ) == name_tag &&

	     isusereg ( son ( son ( s ) ) ) ) return ;

	if ( name ( son ( s ) ) == addptr_tag ) {

	    ap_argsc ( sto, to, 1, s, shape_size ( sa ), 1 ) ;

	    return ;

	}

	ccp ( sto, to, 1, s ) ;

	return ;

    }

    if ( n == addptr_tag ) {

	ap_argsc ( sto, to, 1, e, shape_size ( sa ), 0 ) ;

	return ;

    }

    ccp ( sto, to, 1, e ) ;

    return ;

}

/*

    DOIT ROUTINE, IS t NOT AN OPERAND?

*/

static bool notopnd

    PROTO_N ( ( t, i ) )

    PROTO_T ( exp t X int i )

{

    return ( i >= 0 && !is_opnd ( t ) ) ;

}

#ifndef tdf3

static int scan_for_alloca PROTO_S ( ( exp ) ) ;

static int scan_alloc_args

    PROTO_N ( (s) )

    PROTO_T ( exp s )

{

  if (scan_for_alloca(s))

    return 1;

  if (last(s))

    return 0;

  return scan_alloc_args(bro(s));

}

static int scan_for_alloca

    PROTO_N ( (t) )

    PROTO_T ( exp t )

{

   switch (name(t)) {

   case local_free_all_tag:

   case local_free_tag:

   case last_local_tag:

   case alloca_tag:

   case make_lv_tag:

      return 1;

   case case_tag:

      return scan_for_alloca(son(t));

   case labst_tag:

      return scan_for_alloca(bro(son(t)));

   case env_offset_tag:

   case string_tag:

   case name_tag:

      return 0;

   case apply_general_tag:

      if call_is_untidy(t)

      return 1;

      return scan_alloc_args(son(t));

   default:

      if (son(t) == nilexp)

      return 0;

      return scan_alloc_args(son(t));

   };

}

static bool no_alloca

    PROTO_N ( ( t, i ) )

    PROTO_T ( exp t X int i )

{

    UNUSED ( i ) ;

    return ( scan_for_alloca ( t ) ) ;

}

#endif

/*

    APPLY cc, DOING IT WITH OPERANDS

*/

static void all_opnd

    PROTO_N ( ( sto, to, e ) )

    PROTO_T ( bool sto X exp to X exp e )

{

#if 0

  if(!last(bro(son(e)))) {

    /* Operation has more than two parameters.  Make it diadic */

    exp opn = getexp(sh(e),e,0,bro(son(e)),nilexp,0,0,name(e));

    exp nd = getexp(sh(e),bro(e),last(e),opn,nilexp,0,1,ident_tag);

    exp id = getexp(sh(e),e,1,nd,nilexp,0,0,name_tag);

    pt(nd) = id;

    bro(son(e)) = id;

    setlast(e);

    bro(e) = nd;

    while (!last(bro(son(e)))) {

      bro(son(e)) = bro(bro(son(e)));

    }

    bro(bro(son(e))) = opn;

    e = nd;

    scan2(sto,e,e);

  }

#endif

  cc ( sto, to, 1, e, notopnd, 1 ) ;

  return ;

}

/*

    IS e ASSIGNABLE?

*/

static bool is_assable

    PROTO_N ( ( e ) )

    PROTO_T ( exp e )

{

    long sz ;

    unsigned char n = name ( e ) ;

    if ( is_a ( n ) ) return ( 1 ) ;

    if ( n != apply_tag && n != apply_general_tag ) return ( 0 ) ;

    n = name ( sh ( e ) ) ;

    sz = shape_size ( sh ( e ) ) ;

    return ( n <= ulonghd || ( n == ptrhd && sz == 32 ) ) ;

}

/*

    DOIT ROUTINE, IS t NOT ASSIGNABLE?

*/

static bool notass

    PROTO_N ( ( t, i ) )

    PROTO_T ( exp t X int i )

{

    return ( i >= 0 && !is_assable ( t ) ) ;

}

/*

    APPLY cc, DOING IT WITH ASSIGNABLES

*/

static void all_assable

    PROTO_N ( ( sto, to, e ) )

    PROTO_T ( bool sto X exp to X exp e )

{

    cc ( sto, to, 1, e, notass, 1 ) ;

    return ;

}

/*

    IS e DIRECTLY ADDRESSABLE?

*/

static bool is_direct

    PROTO_N ( ( e ) )

    PROTO_T ( exp e )

{

    unsigned char s = name ( e ) ;

    return ( ( s == name_tag && !isglob ( son ( e ) ) &&

	       !isvar ( son ( e ) ) ) ||

	     ( s == cont_tag && name ( son ( e ) ) == name_tag &&

	       !isglob ( son ( son ( e ) ) ) &&

	       isvar ( son ( son ( e ) ) ) ) ) ;

}

/*

    IS e INDIRECTLY ADDRESSABLE?

*/

static bool is_indable

    PROTO_N ( ( e ) )

    PROTO_T ( exp e )

{

    unsigned char s = name ( e ) ;

    if ( s == name_tag ) return ( 1 ) ;

    if ( s == cont_tag ) {

	unsigned char t = name ( son ( e ) ) ;

	return ( ( t == name_tag && isvar ( son ( son ( e ) ) ) ) ||

		 ( t == cont_tag && name ( son ( son ( e ) ) ) == name_tag &&

		   isvar ( son ( son ( son ( e ) ) ) ) ) ||

		 ( t == reff_tag && is_direct ( son ( son ( e ) ) ) ) ) ;

    }

    return ( ( s == reff_tag && is_direct ( son ( e ) ) ) ||

	     s == addptr_tag ) ;

}

#ifndef tdf3

/*

    MAKES son ( e ) INDIRECTLY ADDRESSABLE

*/

static void indable_son

    PROTO_N ( ( sto, to, e ) )

    PROTO_T ( bool sto X exp to X exp e )

{

  if (!is_indable (son (e))) {

    exp ec;

    cca (sto, to, 1, e);

    ec = contexp (sto, to);

    scan2 (1, ec, son (ec));

  }

  else

    scan2 (sto, to, son (e));

  return;

}

#endif

/*

    APPLY scan2 TO A BRO LIST

*/

static void scanargs

    PROTO_N ( ( st, e ) )

    PROTO_T ( bool st X exp e )

{

    exp t = e ;

    exp temp ;

    while ( temp = contexp ( st, t ), scan2 ( st, t, temp ),

	    temp = contexp ( st, t ), !last ( temp ) ) {

	t = contexp ( st, t ) ;

	st = 0 ;

    }

    return ;

}

/*

    DOIT ROUTINE FOR APPLY

*/

#if 0

static bool apdo

    PROTO_N ( ( t, i ) )

    PROTO_T ( exp t X int i )

{

    /* The first argument needs special treatment */

    if ( i == 1 ) return ( !is_indable ( t ) ) ;

    return ( 0 ) ;

}

#endif

/*

    DOIT ROUTINE FOR PLUS

*/

static bool plusdo

    PROTO_N ( ( t, i ) )

    PROTO_T ( exp t X int i )

{

    /* Can't negate first argument */

    if ( i == 1 ) return ( !is_opnd ( t ) ) ;

    /* But can negate the rest */

    if ( name ( t ) == neg_tag ) return ( 0 ) ;

    return ( !is_opnd ( t ) ) ;

}

/*

    DOIT ROUTINE FOR MULT

*/

static bool multdo

    PROTO_N ( ( t, i ) )

    PROTO_T ( exp t X int i )

{

    return ( i >= 0 && !is_o ( name ( t ) ) ) ;

}

/*

    DOIT ROUTINE FOR AND

*/

static bool anddo

    PROTO_N ( ( t, i ) )

    PROTO_T ( exp t X int i )

{

#if 0

    /* Can't negate first argument */

    if ( i == 1 ) return ( !is_o ( name ( t ) ) ) ;

    /* But can negate the rest */

    if ( name ( t ) == not_tag ) return ( 0 ) ;

#endif

    return ( !is_o ( name ( t ) ) ) ;

}

/*

    DOIT ROUTINE FOR XOR

*/

static bool notado

    PROTO_N ( ( t, i ) )

    PROTO_T ( exp t X int i )

{

    return ( i >= 0 && !is_o ( name ( t ) ) ) ;

}

/*

    MAIN SCAN ROUTINE

*/

void scan2

    PROTO_N ( ( sto, to, e ) )

    PROTO_T ( bool sto X exp to X exp e )

{

    switch ( name ( e ) ) {

	case cond_tag :

	case rep_tag :

	case compound_tag :

#ifdef rscope_tag

	case rscope_tag :

#endif

	case solve_tag :

	case concatnof_tag :

	case nof_tag :

	case diagnose_tag :

#ifndef tdf3

     case caller_tag: {

        if (son(e) == nilexp) /* empty make_nof */

        return ;

        scanargs (1, e);

        return ;

     };

#else

        {

	    scanargs ( 1, e ) ;

	    return ;

	}

#endif

	case labst_tag : {

	    scan2 ( 0, son ( e ), bro ( son ( e ) ) ) ;

	    return ;

	}

	case ident_tag : {

	    scan2 ( 0, son ( e ), bro ( son ( e ) ) ) ;

	    scan2 ( 1, e, son ( e ) ) ;

	    return ;

	}

	case seq_tag : {

	    scanargs ( 1, son ( e ) ) ;

	    scan2 ( 0, son ( e ), bro ( son ( e ) ) ) ;

	    return ;

	}

#if 0

	case diag_tag :

	case cscope_tag :

	case fscope_tag : {

	    scanargs ( 1, e ) ;

	    return ;

	}

#endif

	case local_free_tag :

	case long_jump_tag :

	case ncopies_tag : {

	    all_assable ( sto, to, e ) ;

	    return ;

	}

	case alloca_tag : {

	    all_opnd ( sto, to, e ) ;

	    return ;

	}

#ifndef tdf3

       case set_stack_limit_tag: {

          exp lim = get_stack_limit();

          setbro (lim, son(e));

          setson (e, lim);

          setname (e, ass_tag);

          scan2 (sto, to, e);

          return ;

       };

#endif

      case offset_add_tag :

      case offset_subtract_tag : {

	if((al2(sh(son(e))) == 1) && (al2(sh(bro(son(e)))) != 1)){

	  make_bitfield_offset(bro(son(e)),son(e),0,sh(e));

	}

	if((al2(sh(son(e))) != 1) && (al2(sh(bro(son(e)))) == 1)){

	  make_bitfield_offset(son(e),e,1,sh(e));

	}

      }

	case test_tag :

	case absbool_tag :

	case testbit_tag :

        case make_stack_limit_tag:

	case minus_tag :

	case subptr_tag :

	case div0_tag :

	case div1_tag :

	case div2_tag :

	case shl_tag :

	case shr_tag :

	case rem0_tag :

	case mod_tag :

	case rem2_tag :

	case round_tag :

	case max_tag :

        case offset_max_tag :

	case min_tag :

	case offset_div_by_int_tag :

	case offset_negate_tag :

	case offset_pad_tag :

	case minptr_tag :

	case fplus_tag :

	case fminus_tag :

	case fmult_tag :

	case fdiv_tag :

	case fneg_tag :

	case fabs_tag :

	case chfl_tag :

	case float_tag :

	case offset_mult_tag :

	case offset_div_tag :

	case movecont_tag : {

	    all_opnd ( sto, to, e ) ;

	    return ;

	}

	case not_tag :

	case neg_tag :

	case abs_tag :

	case chvar_tag : {

	    all_opnd ( sto, to, e ) ;

	    return ;

	}

	case bitf_to_int_tag :

	case int_to_bitf_tag : {

	    all_opnd ( sto, to, e ) ;

	    return ;

	}

	case ass_tag :

	case assvol_tag : {

	    exp toc ;

	    /* Change assvol into ass */

	    if ( name ( e ) == assvol_tag ) setname ( e, ass_tag ) ;

	    if ( !is_assable ( bro ( son ( e ) ) ) ) {

		cca ( sto, to, 0, son ( e ) ) ;

		toc = contexp ( sto, to ) ;

		scan2 ( 1, toc, son ( toc ) ) ;

	    } else {

		scan2 ( sto, to, bro ( son ( e ) ) ) ;

	    }

	    cont_arg ( sto, to, e, sh ( bro ( son ( e ) ) ) ) ;

	    return ;

	}

#ifndef tdf3

       case tail_call_tag: {

          exp cees = bro(son(e));

          cur_proc_has_tail_call = 1;

          cur_proc_use_same_callees  = (name(cees) == same_callees_tag);

          if (son(cees) != nilexp)

          cc (sto, to, 1, cees, no_alloca, 1);

          indable_son (sto, to, e);